DELETED ChangeLog Index: ChangeLog ================================================================== --- ChangeLog +++ /dev/null @@ -1,1073 +0,0 @@ -2003-04-21 Andreas Kupries - - * devdoc/indexing.txt: - * installer.tcl: Extended [gen_main_index] to include the header - of Don's generated package index. This makes the final chosen - master index a combination of [i7/ad] and [i4/sd] as the - fallback position. - - * installer.tcl: Made sure that all [file copy] operations use - -force. Fix for #719616. - -2003-04-19 Andreas Kupries - - * installer.tcl: Bug fix, the modules calendar, control, and math - have a "tclIndex" file which has to be installed too. Also - changed usage of 'tcl_pkgPath', as this variable does not exist - on windows. - -2003-04-17 Andreas Kupries - - * configure.in: Switched over from the original build system - * configure: to one where configure/Makefile are optional - * Makefile.in: and delegating all real work to 'sak.tcl'. - * INSTALL.txt: Updated documentation, reduced configure macros. - * aclocal.m4: - * sak.tcl: - * devdoc/releaseguide.html: - -2003-04-17 Andreas Kupries - - * installer.tcl: Bug fixes in non-gui mode, added option to force - cmdline mode. - - * sak.tcl: Added command to invoke the testsuite(s). - - * installer.tcl: Added GUI. - - * main.tcl: New file, entrypoint for *kit, *pack, redirects to - 'installer.tcl'. - - * sak.tcl: Helper tool for tcllib development (Generate - distribution, various forms of documentation, check the bundle - of packages for problems. - - * Makefile.in: Added des to the list of modules. (That is the good - thing which came out of the erroneous commit, we found this - error.) - - * mkIndex.tcl: Reverting accidential commit of this file. The - committed state works with a changed Makefile, but not with the - current one. - -2003-04-16 Andreas Kupries - - * installer.tcl: Added 'des' to list. Reworked according to - feedback from Don. - - * tcllib_version.tcl: Added, for sharing with other scripts. - - * modules/stats/pkgIndex: Now throwing an error when trying to - load 'stats'. - - * modules/struct/ChangeLog: Typo correction. - -2003-04-15 Andreas Kupries - - * installer.tcl: Added 'md4' to installer.tcl - -2003-04-15 Pat Thoyts - - * modules/md4: New module md4 created: MD4 hash algorithm. - -2003-04-15 Andreas Kupries - - * installer.tcl: EXPERIMENTAL. New installer for tcllib. Currently - only cmdline based. Use -help to get help. - -2003-04-13 Andreas Kupries - - * Makefile.in (check-doc-markup): Fixed setting for DOC_FLAGS. The - option '-visualwarn' does not exist anymore. Replaced by the - option '-deprecated'. Thanks to Larry Virden for reporting the - problem. - -2003-04-11 Andreas Kupries - - * install.tcl: Changed to notify the user if the directory to - install is not a source distribution but a CVS snapshot. Right - now a direct installation of a CVS snapshot is not possible. - - * Fixed bug #614591 throughout. Numerous modules updated. Also - first round of getting version number consistents, and updated - for a 1.4 release of the whole. - -2003-04-09 Andreas Kupries - - * New module: devtools. Internal use only for now. Does not - contain true packages. - -2003-04-01 Andreas Kupries - - * Makefile.in (MODULES): Added the soundex module. - -2003-03-28 Andreas Kupries - - * README: Updated information about acceptable documentation - formats, i.e. added doctools, made it the most prefered - format. This fixes the [Bug #685270], reported by Larry Virden - . - -2003-03-24 Andreas Kupries - - * README: Updated to refer to the SF website for Tcllib. Thanks to - Larry Virden for the report and - fix. [Bug #707607]. - -2003-03-17 Pat Thoyts - - * modules/ntp: New module ntp created for time related network - protocol stuff. Added RFC868 (TIME) protocol client and example. - -2003-03-13 Andreas Kupries - - * Makefile.in (install-libraries): Extended special code for - doctools to install the new idx and toc engines. - -2003-02-11 Pat Thoyts - - * modules/des: Imported and tcllib-ised the DES package - from wiki page "DES in Tcl" by Jochen Loewer. NOT added to the - main package list as it requires CBC/CFB/OFB modes for real use. - -2003-01-18 Andreas Kupries - - * More doctools changes: Command [strong] is deprecated now. Added - the command [copyright]. Went through all manpages to eliminate - [strong]. Partial setting of copyright information, where known. - -2003-01-13 Andreas Kupries - - * mkInstallScripts.tcl: - * Makefile.in (install-libraries): Added module specific - installation code. - - doctools: Install message catalogs and predefined formatting - engines. - - textutil: Install hyphenation files. - - * Module doctools rewritten to make it a true package + - application, instead of a pure application module. This means - that this module now truly installs some functionality useable - by other applications and packages. - -2003-01-03 Pat Thoyts - - * smtpd: enhanced error handling for FR #655611 - Handle some ESMTP options. - -2002-11-24 Gerald Lester - - * html: Fixed bug #643337 (changes made though 2002-12-2) - -2002-11-24 Gerald Lester - - * html: Fixed bug #596000 - -2002-10-16 Andreas Kupries - - * struct (graph): Implemented FR 603924 - -2002-10-14 Andreas Kupries - - * pop3: Fixed bug #620062. - -2002-10-09 Andreas Kupries - - * Makefile.in (install-libraries): Added code to skip directories - without .tcl files. Some shells do not like a for with nothing - to iterate over. - -2002-10-08 Pat Thoyts - - * smtpd: implemented feature request #531531 to use MIME tokens - -2002-09-25 Jeff Hobbs - - * Makefile.in: better DESTDIR/libdir support (steffen) - -2002-09-14 Andreas Kupries - - * mime: New field_decode, extended testsuite. - -2002-09-04 Andreas Kupries - - * all.tcl (tcltest::tooManyMessage): Additional command to create - different error messages for 8.3 and 8.4. Used in the testsuite - of pop3. - -2002-08-30 Andreas Kupries - - * cmdline: - * counter: - * dns: - * ftpd: - * html: - * ncgi: - * examples/ftp: Cleaned up nits ('info exist' --> 'info exists'). - -2002-08-21 Andreas Kupries - - * examples/ftp: Fixed problem in ftpdemo.tcl. - -2002-08-19 Andreas Kupries - - * nntp: Updated documentation, see Tcllib SF #597102. - - * Makefile.in (install-doc): Fixed problem noted by Elchonon - Edelson. Code to inline man.macros appended to existing - files. Multiple execution of 'make install-doc' thus extended - the manpages of tcllib with multiples of their original - content. Not anymore. - -2002-08-16 Andreas Kupries - - * exif: Applied patch #582828. Partially applied #530970. - -2002-08-15 Andreas Kupries - - * Makefile.in (DOC_EXP): Use the tclsh found during configuration - to run mpexpand. This ensures that mpexpand does not pick - something from the path on its own, possibly something too old - to understand TCLLIBPATH. Problem noted by Elchonon Edelson - . - - * mime: Accepted SF Tcllib FR #595240. This entails the donation - of the personal mail filter mbot, as written and used by - Marshall T. Rose, as an example of the usage of the mime and - smtp packages. - - * mime (smtp): Followup to patch SF #557520/2 (See 2002-07-25). - -2002-08-09 Andreas Kupries - - * Makefile.in (install-doc): Changed $$(basename) to - `basename`. Portability problem. Works for Linux for example, - but not everywhere else. See 2002-08-06 for the change which - introduced this. - -2002-08-08 Andreas Kupries - - * htmlparse: Fixed SF bug #579853. - -2002-08-06 Andreas Kupries - - * Makefile.in (dist): Fixed SF Bug #567079, reported by Don Porter - . No infinite recursion anymore for - srcdir == builddir. - - * ftp: Fixed SF Bug #582668. - - * comm: Fixed SF Bug #589225. - - * Makefile.in (install-doc): Restored the code inlining the - man.macros file into the generated nroff manpages. Got somehow - deleted. Was still in the 'dist' target. Thanks to Reinhard Max - for noticing this. - - * struct (pool): Fixed bug SF #585093. - * struct (tree): Fixed bug SF #587533. - -2002-07-25 Andreas Kupries - - * mime: Applied SF patch #585455. - * mime (smtp): Applied patch SF #557520/2. - -2002-07-08 Andreas Kupries - - * struct (tree): Fixed SF bug #578460. - - * doctools: Fixed bug #578465. - -2002-07-02 Don Porter - - * all.tcl: Corrected name of tcltest hook procedure - -2002-06-24 Andreas Kupries - - * csv: Fixed SF bug #565051. - - * mime: Fixed SF bug #548832. - -2002-06-17 Andreas Kupries - - * Applied patch for bug #567428. Bug reported by Larry Virden - , patch by him too. Correction of - spelling mistakes in the documentation of various modules + - correction of comment placements which interfere with solaris - conventions for nroff output. - -2002-06-10 Andreas Kupries - - * Released and tagged tcllib 1.3.0. ======================== - -2002-06-07 Andreas Kupries - - * dns: Fixed SF bug #564670. - -2002-06-05 Andreas Kupries - - * all.tcl: Updated to use a default value for -modules if that - option is not present. - - * install.tcl: New file, alternate installer for unix and - windows. Execute with any tclsh and tcllib 1.3 is installed in - the parent directory of the tcl script library - directory. Courtesy Gerald Lester - . - - * Makefile.in (install-doc): Changed to use the doctools generated - nroff and html files instead of the manually written .n files. - - * configure.in (MINOR_VERSION): Updated to version 1.3 - - * Makefile.in (doc): Removed tmml-doc from default set of - documentation. - - * Makefile.in (dist, install): New target 'gen-main-index' - encapsulates the generation of the package index for - tcllib. This target is used by both the direct installation - (install) and during the generation of a source distribution - (dist). - - * mkIndex.tcl: Rewritten to make use of 'pkg_mkIndex' to get the - list of all packages in tcllib. Added a message which deprecates - [package require tcllib] if it is used. - -2002-06-03 Andreas Kupries - - * math (calculus): Fixed SF Tcllib Bug #553773. - - * ftpd: - * html: - * htmlparse: - * base64: - * uuencode: Updated version information. - -2002-05-29 Andreas Kupries - - * mime: Fixed SF Tcllib Bug #561416 - -2002-05-27 Andreas Kupries - - * base64: Fixed SF Tcllib Bug #548354. - -2002-05-21 Andreas Kupries - - * doctools: Fixed bug #556509. - * fileutil: Fixed bug #556504. - -2002-05-15 Andreas Kupries - - * pop3d: Fixed bug #532216. All parts of pop3d now have a - testsuite. - -2002-05-14 Andreas Kupries - - * pop3d: Added testsuites for user database and simple mailbox - storage. - - * fileutil: SF Bug #462015 closed. Proosed change rejected, added - new commands to perform the desired operation instead. - -2002-05-09 Andreas Kupries - - * doctools: Fixed bug #534334 (actually more a FR). - - * examples/csv/csvdiff: Applied patch associated with tcllib SF - bug #551133. Bug reported by , - patch by . - - Accepted FR #551127 and added code implementing the feature. - -2002-05-08 Andreas Kupries - - * struct (tree): Accepted FR #552972. - - * mime: Fixed bugs #539952, #553784. - -2002-05-08 Don Porter - - * all.tcl: Show full stack trace when an error occurs sourcing - a test file. - -2002-04-24 Andreas Kupries - - * cmdline: Accepted patch #540313 - - * examples/ftp/hpupdate.tcl: Accepted patch #548221 by Larry - Virden . - Fixed bug #548224 (Touch). - - * base64: Fixed bug #548112. - -2002-04-23 Andreas Kupries - - * doctools: Fixed bug #527025. - - * smtp (mime): Fixed bug #547336. - -2002-04-16 Andreas Kupries - - * Makefile.in (dist): Ensured that the deprecated module 'stats' - is not distributed anymore. Use 'counter' instead. - (*-force): Enforced generation of documentation, for developers. - -2002-04-10 Andreas Kupries - - * Makefile.in (MODULES): Added irc module. - -2002-04-04 Andreas Kupries - - * mime: Fixed bug #533025. - -2002-04-01 Andreas Kupries - - * Makefile.in (doc_generate): Added 'touch' command to prevent - multiple execution of target. - - * struct (matrix): Fixed bug #532791. - - * doctools: Fixed SF Bug #535382. - -2002-03-25 Andreas Kupries - - * doctools: Implemented FR #530059 and FR #527029. - - * Fixed minor formatting errors in several existing doctools - manpages. - - * struct (matrix): Fixed bug #532783. - -2002-03-19 Andreas Kupries - - * ftpd: Fixed SF Bug #531799. - - * New module: pop3d. A POP3 server. - * Makefile.in: Added pop3d. - -2002-03-15 Andreas Kupries - - * math: Update of calculus. #528434 - - * report, struct (matrix): Fixed bug #530207. - -2002-03-14 Andreas Kupries - - * textutil (expander): Fixed SF Bug #530056. - -2002-03-13 Andreas Kupries - - * doctools: Fixed bug #528390. - -2002-03-09 Andreas Kupries - - * struct (matrix): Accepted FR #524430 (-nocase). - - * doctools: FR #527716 accepted. Bug #527025 partially fixed. - -2002-03-07 Andreas Kupries - - * Makefile.in (doc_generate): Added "TCLLIBPATH=$(srcdir)/modules" - in front of the mpexpand invocation so that it is forced to use - the "expander" package inside of the distribution. This fixes - Tcllib Bug #525007 reported by Don Porter - . - -2002-03-02 Pat Thoyts - - * New module: dns - * Makefile.in: updated for new module - -2002-02-27 Andreas Kupries - - * doctools: Done FR #517599. FR #520269. - - * mime: Fixed bug #519623. - - * Makefile.in (install-doc): Changed code determining the files to - install to handle missing files better (use 'ls', suppress error - messages). - -2002-02-18 Andreas Kupries - - * exif: New module. FR 517066 accepted. - -2002-02-14 Andreas Kupries - - * Makefile.in (statcheck, frink, procheck): Added developer - targets to invoke two static code checkers. - - * Ran frink over the package and corrected several minor problems. - -2002-02-12 Andreas Kupries - - * Makefile.in: Added target for generation of documentation in - various formats from .man pages - -2002-02-01 Andreas Kupries - - * mime: Applied patch 511692. - -2002-01-21 Andreas Kupries - - * Makefile.in (dist): Brought archive names and contents more in - sync with earlier releases. This comes from work on release 1.2. - -2002-01-18 Andreas Kupries - - * Bumped version to 1.2, new release. Summary of changes here. See - the individual Changelogs to see the detailed changes in each - module. - - New modules: calendar, crc, doctools, irc, smtpd, and stooop. - - calendar: Version is 0.1 - crc: Version is 1.0 - doctools: Version is 1.0 - irc: Version is 0.1 - smtpd: Version is 1.0 - stooop: Version is 4.3 - - Changed modules: base64, comm, control, csv, fileutil, ftp, - html, math, mime, ncgi, nntp, pop3, struct, textutil, and uri. - - base64: Version stays @ 2.2, but got new subpackage. - comm: Version up to 3.7.1 - control: Version up to 0.2 - csv: Version up to 0.2 - fileutil: Version up to 1.3 - ftp: Version up to 2.3 - html: Version up to 1.2 - math: Version up to 1.2 - mime: Version up to 1.3.1 - ncgi: Version up to 1.2.1 - nntp: Version up to 0.2 - pop3: Version up to 1.5.1 - struct: Version up to 1.2 - textutil: Version up to 0.4 - uri: Version up to 1.1 - -2002-01-18 Andreas Kupries - - * Makefile.in (dist): Fixed bug #495976. - -2002-01-17 Pat Thoyts - - * crc module: added sum manual page - * base64 module: added uuencode manual page - -2002-01-17 Andreas Kupries - - * examples/csv/csvdiff: New example for csv module. FR #485717. - - * mime: Fixed bug #499242. - -2002-01-16 Andreas Kupries - - * mime: Implemented FR #503336 - * ftp: Fixed bug #503471. - * nntp: Fixed bug #502250 - -2002-01-16 Pat Thoyts - - * base64 module: added uuencode package - * crc module: added sum and cksum packages. - -2002-01-11 Pat Thoyts - - * mkInstallScripts.tcl: - * Makefile.in: Added crc and smtpd modules to the installation files. - -2002-01-11 Kevin Kenny - - * mkInstallScripts.tcl: Changed the installation process for - Windows to avoid the unimplemented [file permissions] in favor of - [file attributes]. - -2002-01-11 Kevin Kenny - - * New module: calendar. - -2002-01-11 Pat Thoyts - - * New module: crc. From patch #501339 - -2002-01-11 Andreas Kupries - - * Makefile.in (install-doc): Fixed bug #500655. Using the code - from the tcl "Makefile.in" as template equivalent code for - tcllib was created and added to the file "Makefile.in". The - modified makefile now includes the contents of "man.macros" into - every installed manpage. - - * html: Applied patch #484117. - -2001-12-14 Andreas Kupries - - * New module: doctools. FR #492234. - -2001-12-13 Andreas Kupries - - * texturil: Applied patch #492156. - -2001-12-11 Andreas Kupries - - * pop3: Bugfix for item #490151. - - * textutil: Bugfix for item #476988. - -2001-12-10 Andreas Kupries - - * textutil: Update from William, 'evalcmd' callback. - -2001-12-06 Andreas Kupries - - * fileutil: Bugfix for item #486572. - -2001-11-28 Reinhard Max - - * split.tcl: Speed improvement. - -2001-11-23 Andreas Kupries - - * struct.matrix: Implemented FR #481022. - -2001-11-19 Andreas Kupries - - * irc: Added IRC example to examples section. Patch #481479. - - * struct/graph: Applied patch #483125 - - * smtpd: Example consolidation: Moved the smtpd example to - 'examples' directory. - - * ftp: Implemented FR #481161. - - * ftpd: Added example ftp server used for testing the - functionality of FR #481161. - -2001-11-17 Pat Thoyts - - * smtpd: New module. - -2001-11-16 Andreas Kupries - - * csv: Applied patch #482570. - - * comm: Fixed bug #480227. - - * ftp, uri: Implemented FR #476804. - - * ftp: Applied patch #428053. - -2001-11-12 Andreas Kupries - - * irc: New module. Internet protocol handling. Internet Relay Chat - (IRC). Author David N. Welton . - - * examples/nntp: Moved example applications out of the nntp module - into the example space. - - * examples/ftpd: Moved example applications out of the ftpd module - into the example space. - - * examples/ftp: Moved example applications out of the ftp module - into the example space. - - * csv: Implemented FR #481023. - - * textutil: Added 'expander' code by William H. Duquette - . Added option -strictlength to - adjust. Code by Dan Kuchler . - -2001-11-09 Joe English - - * comm: Replaced nroff macro trickery in comm.n manpage. - -2001-11-07 Andreas Kupries - - * mime: Fixed bug #479174. - - * mkInstallScripts.tcl: Added code to install tclIndex files. - - * Makefile.in (install-libraries, dist): Added commands to copy - 'tclIndex' files into installation and distribution. This fixes - the remainder of #475846. - (dist): Fixed error in generation of tar/zip files too. - -2001-11-07 Andreas Kupries - - * examples/ftp/ftpvalid: New example, using ftp and uri - modules. Validation of ftp urls. - - * fileutil: Accepted Patch #477805. - * ftp: Accepted Patch #478478. - -2001-11-07 Reinhard Max - - * control: added implementation for a 'do ... while/until' loop. - -2001-11-04 Andreas Kupries - - * ftp: Fixed bug #476729. - -2001-11-01 Andreas Kupries - - * mime: Fixed bugs #477088, #472009. - -2001-10-21 Andreas Kupries - - * uri: Accepted patch #470211. - -2001-10-20 Andreas Kupries - - * ncgi: Fixed bug #464560. - * ftp: Fixed bug #466746. - -2001-10-17 Andreas Kupries - - * ------------------ Tcllib 1.1 released ------------------ - - * tcllib moved to version 1.1 - - * cmdline: Version up to 1.1.1 - * ftp: Version up to 2.2.1 - * html: Version up to 1.1.1 - * md5: Version up to 1.4.1 - * mime/smtp: Version up to 1.3 - * ncgi: Version up to 1.2 - * pop3: Version up to 1.5 - * report: Version up to 0.2 - * sha1: Version up to 1.0.1 - * struct: Version up to 1.1.1 - * textutil: Version up to 0.3 - -2001-10-14 Jeff Hobbs - - * csv.tcl: moved to v0.2 - -2001-09-24 Joe English - - * modules/ftpd/ftpd.tcl: fix improperly-formatted multi-line - replies. See SF tracker ID #424797 - -2001-08-24 Andreas Kupries - - * Makefile.in (check): Added target to report modules without - testsuites and/or manpages. - -2001-08-22 Andreas Kupries - - * examples/nntp: Added new example application 'postnews'. This is - an example how to use the 'nntp'-client library provided by - tcllib. - - * Makefile.in (MODULES): Added package 'comm'. - -2001-08-21 Don Porter - - * Makefile.in (MODULES): Added package 'control'. - -2001-08-20 Andreas Kupries - - * Makefile.in (mandir, libdir): Applied patch [447141] by Reinhard - Max to virtualize mandir and libdir - via ${INSTALL_ROOT}. - - * all.tcl: Added ::tcltest::getErrorMessage in preparation of - fixing [440051], [440049] and [440046] reported by Larry Virden - . - -2001-07-17 Andreas Kupries - - * Bumped version to 1.0 - -2001-07-10 Andreas Kupries - - * Frink 2.2 run, fixed dubious code. - -2001-07-06 Andreas Kupries - - * Fixed #438748, corrections of various misspellings in manpages - accross all modules. - -2001-06-21 Andreas Kupries - - * Ran frink and procheck over all modules and fixed the reported - problems. As far as they actually were problems. - -2001-06-21 Andreas Kupries - - * Makefile.in (MODULES): Added module 'sha1'. This is another - message digest like 'md5'. - -2001-05-01 Andreas Kupries - - * Makefile.in (MODULES): Added module 'report'. - - * all.tcl: Added code to propagate "::tcltest::testDirectory" into - the slave actually doing the tests. This tripped some of the - tests for the new CSV module as they use some external files and - were thus unable to find them correctly without this setting. - - * Makefile.in (MODULES): Added module 'csv'. - - * Added directory 'examples' for future sample applications of - tcllib and some example applications too. - -2001-04-24 Andreas Kupries - - * Makefile.in: Added module 'md5'. - -2001-03-26 Andreas Kupries - - * Makefile.in (install-libraries): [Bug #404917] - Added 'smtp' explictly to the list of modules for the full - package index. It is part of the 'mime' directory and thus not - automatically found / part of the list. - -2001-03-26 Andreas Kupries - - * Makefile.in: Added module 'htmlparse'. - -2001-03-21 Andreas Kupries - - * Makefile.in: Added module 'log'. - -2001-03-20 Andreas Kupries - - * all.tcl: [Bug #410100, Patch #410105] - Squashed a subtle bug with package management for the - tests. Changes: all.tcl now adds the module path to the - auto_path (the tested modules did it themselves before) and also - moved the setting of the auto_path in the slave before the first - 'package require'. Why ? Assume the old code, an installed - fileutil 1.0 and a new fileutil 1.1 under development. The - initialization of the tests scans the package directories and - finds fileutil 1.0. The module then adds itself to the auto_path - and then requires fileutil (without version). Now fileutil 1.0 - is found by the pkg management, it is acceptable according to - the rules of require and thus used. The new version is not - considered at all, as changing the auto_path does *not* enforce - a rescan of package directories. It is possible to solve the - problem by having the modules require themselves and request a - specific version (1.1 in this case). But this would mean that in - each module we have (at least) one more file containing the - version number (all test files!) and we have to maintain this - for every module. The change here however solves the problem - without touching the modules at all. - -2000-11-02 Brent Welch - - * configure.in: Bumped version number to 0.8 - -2000-11-01 Dan Kuchler - - * Makefile.in: Added javascript package to tcllib. - -2000-10-27 Dan Kuchler - - * Makefile.in: Added ftpd package to tcllib. - -2000-10-04 Brent Welch - - * Makefile.in: Nuked stats in favor of counter. - -2000-09-19 Brent Welch - - * Makefile.in: - Added the stats module. - * configure.in: - Increased version number to 0.7 - * modules/stats/stats.tcl: - * modules/stats/stats.n: - * modules/stats/stats.test: - * modules/stats/pkgIndex.tcl: - Initial version of the stats package. - -2000-08-23 Brent Welch - - * Makefile.in: fixed typo - -2000-08-22 Brent Welch - - * configure.in: Bumped patchlevel to 0.6.1 - * Makefile.in: Ignore errors when installing documentation, - which only partly exists. You'll still see the error messages - but it doesn't stop the install. - Applied tcllib-0-6-1 tag - -2000-07-19 Brent Welch - - * configure.in: Bumped patchlevel to 0.6 - applied tcllib-0-6 tag - -2000-06-15 Dan Kuchler - - * Makefile.in: Added nntp client package. - * modules/nntp: Added nntp client package to tcllib. - -2000-06-13 Eric Melski - - * Makefile.in: Added uri package. - * modules/uri: Added uri package from Steve Ball, Andreas Kupries. - -2000-06-09 Brent Welch - - * configure.in: Bumped patchlevel to 0.5 - applied tcllib-0-5 tag - -2000-06-02 Eric Melski - - * Makefile.in: Added ftp package. - * modules/ftp: Added ftp package from Steffen Traeger to tcllib. - -2000-04-28 Sandeep Tamhankar - - * mkInstallScripts.tcl: Fixed a bug in the UNIX shell script where - it was checking if TCLINSTALL was non-null, but it was using ==, - which isn't legal in /bin/sh. I found this out the hard way while - trying to install tcllib0.4 in the default location - (/usr/local/lib/tcllib0.4) and because of this bug, it ended up - installing in /lib/tcllib0.4. - -2000-04-26 Brent Welch - - * configure.in: Bumped patchlevel to 0.4 - * Makefile.in: Fixed dist target to deal with missing manual - pages and test files. - * mkInstallScripts.tcl: Made install directory a parameter to - the unix install.sh script - -2000-04-25 Eric Melski - - * Makefile.in: Tweaked dist target to include README and - license.terms in distributions. - -2000-04-17 Brent Welch - - * modules/html: Added html generation module - -2000-04-10 Brent Welch - - * Makefile.in: restored ncgi module - -2000-04-07 Eric Melski - - * configure: - * configure.in: Upped version to 0.3. - -2000-03-29 Eric Melski - - * mkIndex.tcl: Added missing "== -1" to [lsearch] for package dir - in generated pkgIndex.tcl. - -2000-03-28 Eric Melski - - * Makefile.in: Added $(srcdir)/ prefix to mkIndex.tcl call in the - install-libraries target, so that it would find the mkIndex.tcl - script when run outside of the source tree. Same for man.macros - in the install-doc target, so it would find the file. - -2000-03-27 Eric Melski - - * Makefile.in: Added dist target for building distribution. - - * configure.in: Removed mkIndex.tcl from AC_OUTPUT call. - - * mkInstallScripts.tcl: First cut at script for autogenerating - simple INSTALL.BAT and install.sh files for tcllib distributions. - - * mkIndex.tcl: - * mkIndex.tcl.in: Replace mkIndex.tcl.in with mkIndex.tcl, which - now takes more args to specify values. - -2000-03-09 Eric Melski - - * Makefile.in: Added ncgi module, commented out until tests are done. - -2000-03-09 Eric Melski - - * Makefile.in: Updated test target to call out to all.tcl. - - * all.tcl: First checkin of all.tcl, the magic that hides behind - "make test". - -2000-03-08 Eric Melski - - * Makefile.in: Commented out cgi module until it's ready for use. - Added checks for bogus module names in install-libraries, but - they're not foolproof. - -2000-03-07 Brent Welch - - * modules/cgi: Preliminary version of a CGI module. Still needs - some cookie functions, test suite, and docs... - -2000-03-07 Eric Melski - - * modules/math: math library - - * Makefile.in: added math library to list of modules - -2000-03-07 Scott Stanton - - * configure.in: - * configure: - * aclocal.m4: - * Makefile.in: Changed to use shared config subdirectory. Also - fixed problem on Windows builds where it would fail to identify - the tclsh executable to use. Simplified configure.in to minimum - number of macros. - -2000-03-06 Eric Melski - - * man.macros: Moved from individual modules to toplevel tcllib - dir, so that it is not repeated hundreds of times. - - * Makefile.in: - * mkIndex.tcl.in: Added version number to installed tcllib dir. - - * license.terms: Adapted license from Tcl. - - * README: Added more information about file layout in module dirs. - -2000-03-06 Scott Redman - - * Makefile.in: added pop3 module. - -2000-03-02 Eric Melski - - * mkIndex.tcl.in: Instead of probing install dir for modules, - changed to take module list on command line, so that users can - change what goes into the pkgIndex.tcl from the Makefile. - - * Makefile.in: additional work on module list and pkgIndex.tcl - generation. Now changing the module list changes what is - installed and what is put in the pkgIndex.tcl. - -2000-03-02 Eric Melski - - * Makefile.in: Work on install-libraries, install-doc; removed - references to compiled bits. - - * mkIndex.tcl.in: Tweaked the generated pkgIndex.tcl to only - append the dirname if it doesn't already exist in the auto_path, - and to use \[file dirname \[info script\]\] instead of [pwd]. - - * configure: - * configure.in: Removed checks for compiler, and all stuff related - to compiling/linking (this is a tcl only extension). - - * tcl.m4: new tcl.m4 from sample extension. - -2000-03-01 Eric Melski - - * Makefile.in: Added fileutil, cmdline, mime, base64 modules. - -2000-02-24 Eric Melski - - * Makefile.in, et al: Preliminary Makefile and configure script, and - supporting files DELETED INSTALL.txt Index: INSTALL.txt ================================================================== --- INSTALL.txt +++ /dev/null @@ -1,77 +0,0 @@ -How to install Tcllib -===================== - -Introduction ------------- - -The tcllib distribution, whether a snapshot directly from CVS, or -officially released, offers a single method for installing tcllib, -based on Tcl itself. - -This is based on the assumption that for tcllib to be of use Tcl has -to be present, and therefore can be used. - -This single method however can be used in a variety of ways. - -0 For an unwrapped (= directory) distribution or CVS snapshot - - a. either call the application 'installer.tcl' directly, - b or use - - % configure ; make install - - The latter is provided for people which are used to - this method and more comfortable with it. In end this - boils down into a call of 'installer.tcl' too. - -1. A starpack distribution (window-only) is a self-extracting - installer which internally uses the aforementioned installer. - -2. A starkit distribution is very much like a starpack, but - required an external interpreyter to run. This can be any tcl - interpreter which has all the packages to support starkits - (tclvfs, memchan, trf). - -3. A distribution in a tarball has to be unpacked first, then any - of the methods described in (0) can be used. - - -Usage of the installer ----------------------- - -The installer selects automatically either a gui based mode, or a -command line based mode. If the package Tk is present and can be -loaded, then the GUI mode is entered, else the system falls back to -the command line. - -Note that it is possible to specify options on the command line even -if the installer ultimatively selects a gui mode. In that case the -hardwired defaults and the options determine the data presented to the -user for editing. - -Command line help can be asked for by using the option -help when -running the installer (3) or the distribution itself in the case of -(1) or (2). - -The installer will select a number of defaults for the locations of -packages, examples, and documentation, and also the format of the -documentation. The user can overide these defaults in the GUI, or by -specifying additional options. - -The defaults depend on the platform detected (unix/windows) and the -executable used to run the installer. In the case of a starpack -distribution (1) this means that _no defaults_ are possible for the -various locations as the executable is part of the distribution and -has no knowledge of its environment. - -In all other cases the intepreter executable is outside of the -distribution, which means that its location can be used to determine -sensible defaults. - -Notes ------ - -The installer will overwrite an existing installation of tcllib 1.4 -without asking back after the initial confirmation is given. And if -the user chooses the same directory as for tcllib 1.3 the installer -will overwrite that too. DELETED Makefile.in Index: Makefile.in ================================================================== --- Makefile.in +++ /dev/null @@ -1,110 +0,0 @@ -# Makefile.in -- -# -# This file is a Makefile for the tcllib standard tcl library. If this -# is "Makefile.in" then it is a template for a Makefile; to generate -# the actual Makefile, run "./configure", which is a configuration script -# generated by the "autoconf" program (constructs like "@foo@" will get -# replaced in the actual Makefile. -# -# Copyright (c) 1999-2000 Ajuba Solutions -# Copyright (c) 2001 ActiveState Tool Corp. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: Makefile.in,v 1.90 2003/04/18 02:57:46 andreas_kupries Exp $ - -#======================================================================== -# Nothing of the variables below this line need to be changed. Please -# check the TARGETS section below to make sure the make targets are -# correct. -#======================================================================== - -SHELL = @SHELL@ - -srcdir = @srcdir@ -top_srcdir = @top_srcdir@ -prefix = @prefix@ -exec_prefix = @exec_prefix@ -libdir = @libdir@ -mandir = @mandir@ - -DESTDIR = -pkglibdir = $(libdir)/@PACKAGE@@VERSION@ -top_builddir = . - -PACKAGE = @PACKAGE@ -VERSION = @VERSION@ -CYGPATH = @CYGPATH@ - -TCLSH_PROG = @TCLSH_PROG@ - -CONFIG_CLEAN_FILES = - -#======================================================================== -# Start of user-definable TARGETS section -#======================================================================== - -all: -install: install-libraries install-doc -doc: html-doc nroff-doc - -install-libraries: - $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/installer.tcl` \ - -pkg-path $(DESTDIR)$(pkglibdir) \ - -no-examples -no-html -no-nroff \ - -no-wait -no-gui - -install-doc: - $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/installer.tcl` \ - -nroff-path $(DESTDIR)$(mandir)/mann \ - -no-examples -no-pkgs -no-html \ - -no-wait -no-gui - -test: - $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` test - -depend: -dist: - $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` gendist - -clean: - rm -rf doc *-doc - -distclean: clean - -rm -f Makefile $(CONFIG_CLEAN_FILES) - -rm -f config.cache config.log stamp-h stamp-h[0-9]* - -rm -f config.status - -Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status - cd $(top_builddir) \ - && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status - -uninstall-binaries: - - -html-doc: - $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` html -nroff-doc: - $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` nroff -tmml-doc: - $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` tmml -wiki-doc: - $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` wiki -latex-doc: - $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` ps -list-doc: - $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` list - -check: - $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` validate - -sak-help: - $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` help - - -.PHONY: all binaries clean depend distclean doc install installdirs libraries test - -# Tell versions [3.59,3.63) of GNU make to not export all variables. -# Otherwise a system limit (for SysV at least) may be exceeded. -.NOEXPORT: DELETED README Index: README ================================================================== --- README +++ /dev/null @@ -1,75 +0,0 @@ -RCS: @(#) $Id: README,v 1.6 2003/04/17 22:54:04 andreas_kupries Exp $ - -Welcome to the tcllib, the Tcl Standard Library. This package is -intended to be a collection of Tcl packages that provide utility -functions useful to a large collection of Tcl programmers. - -The home web site for this code is http://tcllib.sourceforge.net/ . -At this web site, you will find mailing lists, web forums, databases -for bug reports and feature requests, the CVS repository (browsable on -the web, or read-only accessible via CVS ), and more. - -The structure of the tcllib source hierarchy is: - -tcllib - +- modules - +- - +- - +- ... - - -The install hierarchy is: - -.../lib/tcllib - +- - +- - +- ... - -There are some base requirements that a module must meet before it -will be added to tcllib: - -* the module must be a proper Tcl package -* the module must use a namespace for its commands and variables -* the name of the package must be the same as the name of the - namespace -* the module must reside in a subdirectory of the modules directory in - the source hierarchy, and that subdirectory must have the same name - as the package and namespace -* the module must be released under the BSD License, the terms of - which can be found in the toplevel tcllib source directory in the file - license.terms -* the module should have both documentation ([*]) and a test suite - (in the form of a group of *.test files in the module directory). - - [*] Possible forms: doctools, TMML/XML, nroff (man), or HTML. - The first format is the most prefered as it can be processed with - tools provided by tcllib itself (See module doctools). The first - two are prefered in general as they are semantic markup and thus - easier to convert into other formats. - -* the module must have either documentation or a test suite. It can - not have neither. -* the module should adhere to Tcl coding standards - -When adding a module to tcllib, be sure to add it to the Makefile.in -so it will be installed. Add a line like: - -MYNEWMODULE=mynewmodule - -to the list of modules at the top of the Makefile.in, and then add -$(MYNEWMODULE) to the definition of the MODULES variable. This will -allow users to choose which modules to install by commenting or -uncommenting lines in the Makefile. - -Each module source directory should have no subdirectories (other than -the CVS directory), and should contain the following files: - -* source code *.tcl -* package index pkgIndex.tcl -* tests *.test -* documentation *.man, *.n, *.xml - -If you do not follow this directory structure, the tcllib Makefile -will fail to locate the files from the new module. - - DELETED STATUS Index: STATUS ================================================================== --- STATUS +++ /dev/null @@ -1,23 +0,0 @@ -tcllib STATUS: -$Id: STATUS,v 1.2 2002/12/17 01:47:26 davidw Exp $ - -Release: -------- - -Next release? - -To be done before release? - -Open Issues: ------------ - -Problems outlined here (bgerror): -https://sourceforge.net/mailarchive/forum.php?thread_id=1288113&forum_id=6718 - - Bugs/feature requests need filing. - - Several solutions offered - we need to pick one. - -"Feature requests" for packages doing their own output. - -Feature requests for packages using too much regexp/regsub. DELETED aclocal.m4 Index: aclocal.m4 ================================================================== --- aclocal.m4 +++ /dev/null @@ -1,84 +0,0 @@ -# tcl.m4 -- -# -# This file provides a set of autoconf macros to help TEA-enable -# a Tcl extension. -# -# Copyright (c) 1999-2000 Ajuba Solutions. -# All rights reserved. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -#------------------------------------------------------------------------ -# SC_SIMPLE_EXEEXT -# Select the executable extension based on the host type. This -# is a lightweight replacement for AC_EXEEXT that doesn't require -# a compiler. -# -# Arguments -# none -# -# Results -# Subst's the following values: -# EXEEXT -#------------------------------------------------------------------------ - -AC_DEFUN(SC_SIMPLE_EXEEXT, [ - AC_MSG_CHECKING(executable extension based on host type) - - case "`uname -s`" in - *win32* | *WIN32* | *CYGWIN_NT* |*CYGWIN_98*|*CYGWIN_95*) - EXEEXT=".exe" - ;; - *) - EXEEXT="" - ;; - esac - - AC_MSG_RESULT(${EXEEXT}) - AC_SUBST(EXEEXT) -]) - -#------------------------------------------------------------------------ -# SC_PROG_TCLSH -# Locate a tclsh shell in the following directories: -# ${exec_prefix}/bin -# ${prefix}/bin -# ${TCL_BIN_DIR} -# ${TCL_BIN_DIR}/../bin -# ${PATH} -# -# Arguments -# none -# -# Results -# Subst's the following values: -# TCLSH_PROG -#------------------------------------------------------------------------ - -AC_DEFUN(SC_PROG_TCLSH, [ - AC_MSG_CHECKING([for tclsh]) - - AC_CACHE_VAL(ac_cv_path_tclsh, [ - search_path=`echo ${exec_prefix}/bin:${prefix}/bin:${TCL_BIN_DIR}:${TCL_BIN_DIR}/../bin:${PATH} | sed -e 's/:/ /g'` - for dir in $search_path ; do - for j in `ls -r $dir/tclsh[[8-9]]*${EXEEXT} 2> /dev/null` \ - `ls -r $dir/tclsh*${EXEEXT} 2> /dev/null` ; do - if test x"$ac_cv_path_tclsh" = x ; then - if test -f "$j" ; then - ac_cv_path_tclsh=$j - break - fi - fi - done - done - ]) - - if test -f "$ac_cv_path_tclsh" ; then - TCLSH_PROG=$ac_cv_path_tclsh - AC_MSG_RESULT($TCLSH_PROG) - else - AC_MSG_ERROR(No tclsh found in PATH: $search_path) - fi - AC_SUBST(TCLSH_PROG) -]) DELETED all.tcl Index: all.tcl ================================================================== --- all.tcl +++ /dev/null @@ -1,192 +0,0 @@ -# all.tcl -- -# -# This file contains a top-level script to run all of the Tcl -# tests. Execute it by invoking "tclsh all.test" in this directory. -# -# To test a subset of the modules, invoke it by 'tclsh all.test -modules ""' -# -# Copyright (c) 1998-2000 by Ajuba Solutions. -# All rights reserved. -# -# RCS: @(#) $Id: all.tcl,v 1.12 2003/03/29 02:01:23 patthoyts Exp $ - -set old_auto_path $auto_path - -if {[lsearch [namespace children] ::tcltest] == -1} { - namespace eval ::tcltest {} - proc ::tcltest::processCmdLineArgsAddFlagsHook {} { - return [list -modules] - } - proc ::tcltest::processCmdLineArgsHook {argv} { - array set foo $argv - catch {set ::modules $foo(-modules)} - } - proc ::tcltest::cleanupTestsHook {{c {}}} { - if { [string equal $c ""] } { - return - } - # Get total/pass/skip/fail counts - array set foo [$c eval {array get ::tcltest::numTests}] - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - incr ::tcltest::numTests($index) $foo($index) - } - incr ::tcltest::numTestFiles - - # Append the list of failFiles if necessary - set f [$c eval { - set ff $::tcltest::failFiles - if {($::tcltest::currentFailure) && \ - ([lsearch -exact $ff $testFileName] == -1)} { - set res [file join $::tcllibModule $testFileName] - } else { - set res "" - } - set res - }] ; # {} - if { ![string equal $f ""] } { - lappend ::tcltest::failFiles $f - } - - # Get the "skipped because" information - unset foo - array set foo [$c eval {array get ::tcltest::skippedBecause}] - foreach constraint [array names foo] { - if { ![info exists ::tcltest::skippedBecause($constraint)] } { - set ::tcltest::skippedBecause($constraint) $foo($constraint) - } else { - incr ::tcltest::skippedBecause($constraint) $foo($constraint) - } - } - - # Clean out the state in the slave - $c eval { - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - set ::tcltest::numTests($index) 0 - } - set ::tcltest::failFiles {} - foreach constraint [array names ::tcltest::skippedBecause] { - unset ::tcltest::skippedBecause($constraint) - } - } - } - - package require tcltest - namespace import ::tcltest::* -} - -set ::tcltest::testSingleFile false -set ::tcltest::testsDirectory [file dirname [info script]] -set root $::tcltest::testsDirectory - -# We need to ensure that the testsDirectory is absolute -::tcltest::normalizePath ::tcltest::testsDirectory - -puts stdout "tcllib tests" -puts stdout "Tests running in working dir: $::tcltest::testsDirectory" -if {[llength $::tcltest::skip] > 0} { - puts stdout "Skipping tests that match: $::tcltest::skip" -} -if {[llength $::tcltest::match] > 0} { - puts stdout "Only running tests that match: $::tcltest::match" -} - -if {[llength $::tcltest::skipFiles] > 0} { - puts stdout "Skipping test files that match: $::tcltest::skipFiles" -} -if {[llength $::tcltest::matchFiles] > 0} { - puts stdout "Only sourcing test files that match: $::tcltest::matchFiles" -} - -set timeCmd {clock format [clock seconds]} -puts stdout "Tests began at [eval $timeCmd]" - - -set auto_path $old_auto_path -set auto_path [linsert $auto_path 0 [file join $root modules]] -set old_apath $auto_path - -## -## Take default action if the modules are not specified -## - -if {![info exists modules]} then { - foreach module [glob [file join $root modules]/*/*.test] { - set tmp([lindex [file split $module] end-1]) 1 - } - set modules [array names tmp] - unset tmp -} - -foreach module $modules { - set ::tcltest::testsDirectory [file join $root modules $module] - - if { ![file isdirectory $::tcltest::testsDirectory] } { - puts stdout "unknown module $module" - } - - set auto_path $old_apath - set auto_path [linsert $auto_path 0 $::tcltest::testsDirectory] - - # foreach module, make a slave interp and source that module's tests into - # the slave. This isolates the test suites from one another. - puts stdout "Module:\t[file tail $module]" - set c [interp create] - interp alias $c pSet {} set - # import the auto_path from the parent interp, so "package require" works - $c eval { - set ::argv0 [pSet ::argv0] - set ::tcllibModule [pSet module] - set auto_path [pSet auto_path] - package require tcltest - namespace import ::tcltest::* - set ::tcltest::testSingleFile false - set ::tcltest::testsDirectory [pSet ::tcltest::testsDirectory] - #set ::tcltest::verbose ps - - # Add a function to construct a proper error message for - # 'wrong#args' situations. The format of the messages changed - # for 8.4 - - proc ::tcltest::getErrorMessage {functionName argList missingIndex} { - # if oldstyle errors: - if { [info tclversion] < 8.4 } { - set msg "no value given for parameter " - append msg "\"[lindex $argList $missingIndex]\" to " - append msg "\"$functionName\"" - } else { - set msg "wrong # args: should be \"$functionName $argList\"" - } - return $msg - } - - proc ::tcltest::tooManyMessage {functionName argList} { - # if oldstyle errors: - if { [info tclversion] < 8.4 } { - set msg "called \"$functionName\" with too many arguments" - } else { - set msg "wrong # args: should be \"$functionName $argList\"" - } - return $msg - } - } - interp alias $c ::tcltest::cleanupTestsHook {} \ - ::tcltest::cleanupTestsHook $c - # source each of the specified tests - foreach file [lsort [::tcltest::getMatchingFiles]] { - set tail [file tail $file] - puts stdout [string map [list "$root/" ""] $file] - $c eval { - if {[catch {source [pSet file]} msg]} { - puts stdout $errorInfo - } - } - } - interp delete $c - puts stdout "" -} - -# cleanup -puts stdout "\nTests ended at [eval $timeCmd]" -::tcltest::cleanupTests 1 -# FRINK: nocheck -return DELETED config/ChangeLog Index: config/ChangeLog ================================================================== --- config/ChangeLog +++ /dev/null @@ -1,36 +0,0 @@ -2001-03-15 Karl Lehenbauer - - * installFile.tcl: Added updating of the modification time of - the target file whether we overwrote it or decided that it - hadn't changed. This was necessary for us to be able to - determine whether or not a module install touched the file. - -2001-03-08 Karl Lehenbauer - - * installFile.tcl: Added support for converting new-style (1.1+) - Cygnus drive paths to Tcl-style. - -2001-01-15 - - * tcl.m4: Added FreeBSD clause. - -2001-01-03 - - * tcl.m4: Fixed typo in SC_LIB_SPEC where it is checking - for exec-prefix. - -2000-12-01 - - * tcl.m4: Concatenated most of the Ajuba acsite.m4 file - so we don't need to modify the autoconf installation. - * config.guess: - * config.sub: - * installFile.tcl: - Added files from the itcl config subdirectory, - which should go away. - -2000-7-29 - - * Fixed the use of TCL_SRC_DIR and TK_SRC_DIR within TCL_PRIVATE_INCLUDES - and TK_PRIVATE_INCLUDES to match their recent change from $(srcdir) - to $(srcdir)/.. DELETED config/config.guess Index: config/config.guess ================================================================== --- config/config.guess +++ /dev/null @@ -1,483 +0,0 @@ -#!/bin/sh -# Attempt to guess a canonical system name. -# Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. -# -# This file is free software; you can redistribute it and/or modify it -# under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -# -# As a special exception to the GNU General Public License, if you -# distribute this file as part of a program that contains a -# configuration script generated by Autoconf, you may include it under -# the same distribution terms that you use for the rest of that program. - -# Written by Per Bothner . -# The master version of this file is at the FSF in /home/gd/gnu/lib. -# -# This script attempts to guess a canonical system name similar to -# config.sub. If it succeeds, it prints the system name on stdout, and -# exits with 0. Otherwise, it exits with 1. -# -# The plan is that this can be called by configure scripts if you -# don't specify an explicit system type (host/target name). -# -# Only a few systems have been added to this list; please add others -# (but try to keep the structure clean). -# - -# This is needed to find uname on a Pyramid OSx when run in the BSD universe. -# (ghazi@noc.rutgers.edu 8/24/94.) -if (test -f /.attbin/uname) >/dev/null 2>&1 ; then - PATH=$PATH:/.attbin ; export PATH -fi - -UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown -UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown -UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown -UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown - -trap 'rm -f dummy.c dummy.o dummy; exit 1' 1 2 15 - -# Note: order is significant - the case branches are not exclusive. - -case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in - alpha:OSF1:V*:*) - # After 1.2, OSF1 uses "V1.3" for uname -r. - echo alpha-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^V//'` - exit 0 ;; - alpha:OSF1:*:*) - # 1.2 uses "1.2" for uname -r. - echo alpha-dec-osf${UNAME_RELEASE} - exit 0 ;; - arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) - echo arm-acorn-riscix${UNAME_RELEASE} - exit 0;; - Pyramid*:OSx*:*:*) - if test "`(/bin/universe) 2>/dev/null`" = att ; then - echo pyramid-pyramid-sysv3 - else - echo pyramid-pyramid-bsd - fi - exit 0 ;; - i86pc:SunOS:5.*:*) - echo i486-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit 0 ;; - sun4*:SunOS:5.*:*) - echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit 0 ;; - sun4*:SunOS:6*:*) - # According to config.sub, this is the proper way to canonicalize - # SunOS6. Hard to guess exactly what SunOS6 will be like, but - # it's likely to be more like Solaris than SunOS4. - echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit 0 ;; - sun4*:SunOS:*:*) - # Japanese Language versions have a version number like `4.1.3-JL'. - echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` - exit 0 ;; - sun3*:SunOS:*:*) - echo m68k-sun-sunos${UNAME_RELEASE} - exit 0 ;; - tp_s2*:SunOS:*:*) - # Tadpole Sparcbook 2 running a modified 4.1.3 - echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` - exit 0 ;; - RISC*:ULTRIX:*:*) - echo mips-dec-ultrix${UNAME_RELEASE} - exit 0 ;; - VAX*:ULTRIX*:*:*) - echo vax-dec-ultrix${UNAME_RELEASE} - exit 0 ;; - mips:*:5*:RISCos) - echo mips-mips-riscos${UNAME_RELEASE} - exit 0 ;; - m88k:CX/UX:7*:*) - echo m88k-harris-cxux7 - exit 0 ;; - m88k:*:4*:R4*) - echo m88k-motorola-sysv4 - exit 0 ;; - m88k:*:3*:R3*) - echo m88k-motorola-sysv3 - exit 0 ;; - AViiON:dgux:*:*) - if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx \ - -o ${TARGET_BINARY_INTERFACE}x = x ] ; then - echo m88k-dg-dgux${UNAME_RELEASE} - else - echo m88k-dg-dguxbcs${UNAME_RELEASE} - fi - exit 0 ;; - M88*:DolphinOS:*:*) # DolphinOS (SVR3) - echo m88k-dolphin-sysv3 - exit 0 ;; - M88*:*:R3*:*) - # Delta 88k system running SVR3 - echo m88k-motorola-sysv3 - exit 0 ;; - XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) - echo m88k-tektronix-sysv3 - exit 0 ;; - Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) - echo m68k-tektronix-bsd - exit 0 ;; - *:IRIX:*:*) - echo mips-sgi-irix${UNAME_RELEASE} - exit 0 ;; - i[34]86:AIX:*:*) - echo i386-ibm-aix - exit 0 ;; - *:AIX:2:3) - if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then - sed 's/^ //' << EOF >dummy.c - #include - - main() - { - if (!__power_pc()) - exit(1); - puts("powerpc-ibm-aix3.2.5"); - exit(0); - } -EOF - ${CC-cc} dummy.c -o dummy && ./dummy && rm dummy.c dummy && exit 0 - rm -f dummy.c dummy - echo rs6000-ibm-aix3.2.5 - elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then - echo rs6000-ibm-aix3.2.4 - else - echo rs6000-ibm-aix3.2 - fi - exit 0 ;; - *:AIX:*:4) - if /usr/sbin/lsattr -EHl proc0 | grep POWER >/dev/null 2>&1; then - IBM_ARCH=rs6000 - else - IBM_ARCH=powerpc - fi - if grep bos410 /usr/include/stdio.h >/dev/null 2>&1; then - IBM_REV=4.1 - elif grep bos411 /usr/include/stdio.h >/dev/null 2>&1; then - IBM_REV=4.1.1 - else - IBM_REV=4.${UNAME_RELEASE} - fi - echo ${IBM_ARCH}-ibm-aix${IBM_REV} - exit 0 ;; - *:AIX:*:*) - echo rs6000-ibm-aix - exit 0 ;; - *:BOSX:*:*) - echo rs6000-bull-bosx - exit 0 ;; - DPX/2?00:B.O.S.:*:*) - echo m68k-bull-sysv3 - exit 0 ;; - 9000/[34]??:4.3bsd:1.*:*) - echo m68k-hp-bsd - exit 0 ;; - hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) - echo m68k-hp-bsd4.4 - exit 0 ;; - 9000/[3478]??:HP-UX:*:*) - case "${UNAME_MACHINE}" in - 9000/31? ) HP_ARCH=m68000 ;; - 9000/[34]?? ) HP_ARCH=m68k ;; - 9000/7?? | 9000/8?7 ) HP_ARCH=hppa1.1 ;; - 9000/8?? ) HP_ARCH=hppa1.0 ;; - esac - HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` - echo ${HP_ARCH}-hp-hpux${HPUX_REV} - exit 0 ;; - 3050*:HI-UX:*:*) - sed 's/^ //' << EOF >dummy.c - #include - int - main () - { - long cpu = sysconf (_SC_CPU_VERSION); - /* The order matters, because CPU_IS_HP_MC68K erroneously returns - true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct - results, however. */ - if (CPU_IS_PA_RISC (cpu)) - { - switch (cpu) - { - case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; - case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; - case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; - default: puts ("hppa-hitachi-hiuxwe2"); break; - } - } - else if (CPU_IS_HP_MC68K (cpu)) - puts ("m68k-hitachi-hiuxwe2"); - else puts ("unknown-hitachi-hiuxwe2"); - exit (0); - } -EOF - ${CC-cc} dummy.c -o dummy && ./dummy && rm dummy.c dummy && exit 0 - rm -f dummy.c dummy - echo unknown-hitachi-hiuxwe2 - exit 0 ;; - 9000/7??:4.3bsd:*:* | 9000/8?7:4.3bsd:*:* ) - echo hppa1.1-hp-bsd - exit 0 ;; - 9000/8??:4.3bsd:*:*) - echo hppa1.0-hp-bsd - exit 0 ;; - hp7??:OSF1:*:* | hp8?7:OSF1:*:* ) - echo hppa1.1-hp-osf - exit 0 ;; - hp8??:OSF1:*:*) - echo hppa1.0-hp-osf - exit 0 ;; - C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) - echo c1-convex-bsd - exit 0 ;; - C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) - if getsysinfo -f scalar_acc - then echo c32-convex-bsd - else echo c2-convex-bsd - fi - exit 0 ;; - C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) - echo c34-convex-bsd - exit 0 ;; - C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) - echo c38-convex-bsd - exit 0 ;; - C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) - echo c4-convex-bsd - exit 0 ;; - CRAY*X-MP:UNICOS:*:*) - echo xmp-cray-unicos - exit 0 ;; - CRAY*Y-MP:UNICOS:*:*) - echo ymp-cray-unicos - exit 0 ;; - CRAY-2:UNICOS:*:*) - echo cray2-cray-unicos - exit 0 ;; - hp3[0-9][05]:NetBSD:*:*) - echo m68k-hp-netbsd${UNAME_RELEASE} - exit 0 ;; - i[34]86:BSD/386:*:*) - echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} - exit 0 ;; - i[34]86:BSD/OS:*:*) - echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} - exit 0 ;; - *:FreeBSD:*:*) - echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` - exit 0 ;; - *:NetBSD:*:*) - echo ${UNAME_MACHINE}-unknown-netbsd`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` - exit 0 ;; - *:GNU:*:*) - echo `echo ${UNAME_MACHINE}|sed -e 's,/.*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` - exit 0 ;; - *:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux - exit 0 ;; -# ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. earlier versions -# are messed up and put the nodename in both sysname and nodename. - i[34]86:DYNIX/ptx:4*:*) - echo i386-sequent-sysv4 - exit 0 ;; - i[34]86:*:4.*:* | i[34]86:SYSTEM_V:4.*:*) - if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then - echo ${UNAME_MACHINE}-univel-sysv${UNAME_RELEASE} - else - echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE} - fi - exit 0 ;; - i[34]86:*:3.2:*) - if /bin/uname -X 2>/dev/null >/dev/null ; then - UNAME_REL=`(/bin/uname -X|egrep Release|sed -e 's/.*= //')` - (/bin/uname -X|egrep i80486 >/dev/null) && UNAME_MACHINE=i486 - echo ${UNAME_MACHINE}-unknown-sco$UNAME_REL - elif test -f /usr/options/cb.name; then - UNAME_REL=`sed -n 's/.*Version //p' /dev/null 2>&1 ; then - echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 - else # Add other i860-SVR4 vendors below as they are discovered. - echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 - fi - exit 0 ;; - mini*:CTIX:SYS*5:*) - # "miniframe" - echo m68010-convergent-sysv - exit 0 ;; - M680[234]0:*:R3V[567]*:*) - test -r /sysV68 && echo 'm68k-motorola-sysv' && exit 0 ;; - 3[34]??:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0) - uname -p 2>/dev/null | grep 86 >/dev/null \ - && echo i486-ncr-sysv4.3 && exit 0 ;; - 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) - uname -p 2>/dev/null | grep 86 >/dev/null \ - && echo i486-ncr-sysv4 && exit 0 ;; - m680[234]0:LynxOS:2.2*:*) - echo m68k-lynx-lynxos${UNAME_RELEASE} - exit 0 ;; - PowerPC:LynxOS:2.2*:*) - echo powerpc-lynx-lynxos${UNAME_RELEASE} - exit 0 ;; - mc68030:UNIX_System_V:4.*:*) - echo m68k-atari-sysv4 - exit 0 ;; - i[34]86:LynxOS:2.2*:*) - echo i386-lynx-lynxos${UNAME_RELEASE} - exit 0 ;; - TSUNAMI:LynxOS:2.2*:*) - echo sparc-lynx-lynxos${UNAME_RELEASE} - exit 0 ;; - rs6000:LynxOS:2.2*:*) - echo rs6000-lynx-lynxos${UNAME_RELEASE} - exit 0 ;; - RM*:SINIX-*:*:*) - echo mips-sni-sysv4 - exit 0 ;; - *:SINIX-*:*:*) - if uname -p 2>/dev/null >/dev/null ; then - UNAME_MACHINE=`(uname -p) 2>/dev/null` - echo ${UNAME_MACHINE}-sni-sysv4 - else - echo ns32k-sni-sysv - fi - exit 0 ;; -esac - -#echo '(No uname command or uname output not recognized.)' 1>&2 -#echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2 - -cat >dummy.c </dev/null`; - printf ("%s-next-nextstep%s\n", __ARCHITECTURE__, version==2 ? "2" : "3"); - exit (0); -#endif - -#if defined (MULTIMAX) || defined (n16) -#if defined (UMAXV) - printf ("ns32k-encore-sysv\n"); exit (0); -#else -#if defined (CMU) - printf ("ns32k-encore-mach\n"); exit (0); -#else - printf ("ns32k-encore-bsd\n"); exit (0); -#endif -#endif -#endif - -#if defined (__386BSD__) - printf ("i386-unknown-bsd\n"); exit (0); -#endif - -#if defined (sequent) -#if defined (i386) - printf ("i386-sequent-dynix\n"); exit (0); -#endif -#if defined (ns32000) - printf ("ns32k-sequent-dynix\n"); exit (0); -#endif -#endif - -#if defined (_SEQUENT_) - printf ("i386-sequent-ptx\n"); exit (0); -#endif - -#if defined (vax) -#if !defined (ultrix) - printf ("vax-dec-bsd\n"); exit (0); -#else - printf ("vax-dec-ultrix\n"); exit (0); -#endif -#endif - -#if defined (alliant) && defined (i860) - printf ("i860-alliant-bsd\n"); exit (0); -#endif - - exit (1); -} -EOF - -${CC-cc} dummy.c -o dummy 2>/dev/null && ./dummy && rm dummy.c dummy && exit 0 -rm -f dummy.c dummy - -# Apollos put the system type in the environment. - -test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit 0; } - -# Convex versions that predate uname can use getsysinfo(1) - -if [ -x /usr/convex/getsysinfo ] -then - case `getsysinfo -f cpu_type` in - c1*) - echo c1-convex-bsd - exit 0 ;; - c2*) - if getsysinfo -f scalar_acc - then echo c32-convex-bsd - else echo c2-convex-bsd - fi - exit 0 ;; - c34*) - echo c34-convex-bsd - exit 0 ;; - c38*) - echo c38-convex-bsd - exit 0 ;; - c4*) - echo c4-convex-bsd - exit 0 ;; - esac -fi - -#echo '(Unable to guess system type)' 1>&2 - -exit 1 DELETED config/config.sub Index: config/config.sub ================================================================== --- config/config.sub +++ /dev/null @@ -1,793 +0,0 @@ -#!/bin/sh -# Configuration validation subroutine script, version 1.1. -# Copyright (C) 1991, 1992, 1993, 1994 Free Software Foundation, Inc. -# This file is (in principle) common to ALL GNU software. -# The presence of a machine in this file suggests that SOME GNU software -# can handle that machine. It does not imply ALL GNU software can. -# -# This file is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -# As a special exception to the GNU General Public License, if you -# distribute this file as part of a program that contains a -# configuration script generated by Autoconf, you may include it under -# the same distribution terms that you use for the rest of that program. - -# Configuration subroutine to validate and canonicalize a configuration type. -# Supply the specified configuration type as an argument. -# If it is invalid, we print an error message on stderr and exit with code 1. -# Otherwise, we print the canonical config type on stdout and succeed. - -# This file is supposed to be the same for all GNU packages -# and recognize all the CPU types, system types and aliases -# that are meaningful with *any* GNU software. -# Each package is responsible for reporting which valid configurations -# it does not support. The user should be able to distinguish -# a failure to support a valid configuration from a meaningless -# configuration. - -# The goal of this file is to map all the various variations of a given -# machine specification into a single specification in the form: -# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM -# It is wrong to echo any other type of specification. - -# First pass through any local machine types. -case $1 in - *local*) - echo $1 - exit 0 - ;; - *) - ;; -esac - -# Separate what the user gave into CPU-COMPANY and OS (if any). -basic_machine=`echo $1 | sed 's/-[^-]*$//'` -if [ $basic_machine != $1 ] -then os=`echo $1 | sed 's/.*-/-/'` -else os=; fi - -### Let's recognize common machines as not being operating systems so -### that things like config.sub decstation-3100 work. We also -### recognize some manufacturers as not being operating systems, so we -### can provide default operating systems below. -case $os in - -sun*os*) - # Prevent following clause from handling this invalid input. - ;; - -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ - -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ - -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ - -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ - -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ - -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp ) - os= - basic_machine=$1 - ;; - -hiux*) - os=-hiuxwe2 - ;; - -sco4) - os=-sco3.2v4 - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` - ;; - -sco3.2.[4-9]*) - os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` - ;; - -sco3.2v[4-9]*) - # Don't forget version if it is 3.2v4 or newer. - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` - ;; - -sco*) - os=-sco3.2v2 - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` - ;; - -isc) - os=-isc2.2 - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` - ;; - -clix*) - basic_machine=clipper-intergraph - ;; - -isc*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` - ;; - -lynx) - os=-lynxos - ;; - -ptx*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` - ;; - -windowsnt*) - os=`echo $os | sed -e 's/windowsnt/winnt/'` - ;; -esac - -# Decode aliases for certain CPU-COMPANY combinations. -case $basic_machine in - # Recognize the basic CPU types without company name. - # Some are omitted here because they have special meanings below. - tahoe | i[345]86 | i860 | m68k | m68000 | m88k | ns32k | arm | pyramid \ - | tron | a29k | 580 | i960 | h8300 | hppa1.0 | hppa1.1 \ - | alpha | we32k | ns16k | clipper | sparclite | i370 | sh \ - | powerpc | sparc64 | 1750a | dsp16xx | mips64 | mipsel \ - | pdp11 | mips64el | mips64orion | mips64orionel ) - basic_machine=$basic_machine-unknown - ;; - # Object if more than one company name word. - *-*-*) - echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 - exit 1 - ;; - # Recognize the basic CPU types with company name. - vax-* | tahoe-* | i[345]86-* | i860-* | m68k-* | m68000-* | m88k-* \ - | sparc-* | ns32k-* | fx80-* | arm-* | c[123]* \ - | mips-* | pyramid-* | tron-* | a29k-* | romp-* | rs6000-* \ - | none-* | 580-* | cray2-* | h8300-* | i960-* | xmp-* | ymp-* \ - | hppa1.0-* | hppa1.1-* | alpha-* | we32k-* | cydra-* | ns16k-* \ - | pn-* | np1-* | xps100-* | clipper-* | orion-* | sparclite-* \ - | pdp11-* | sh-* | powerpc-* | sparc64-* | mips64-* | mipsel-* \ - | mips64el-* | mips64orion-* | mips64orionel-* ) - ;; - # Recognize the various machine names and aliases which stand - # for a CPU type and a company and sometimes even an OS. - 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) - basic_machine=m68000-att - ;; - 3b*) - basic_machine=we32k-att - ;; - alliant | fx80) - basic_machine=fx80-alliant - ;; - altos | altos3068) - basic_machine=m68k-altos - ;; - am29k) - basic_machine=a29k-none - os=-bsd - ;; - amdahl) - basic_machine=580-amdahl - os=-sysv - ;; - amiga | amiga-*) - basic_machine=m68k-cbm - ;; - amigados) - basic_machine=m68k-cbm - os=-amigados - ;; - amigaunix | amix) - basic_machine=m68k-cbm - os=-sysv4 - ;; - apollo68) - basic_machine=m68k-apollo - os=-sysv - ;; - balance) - basic_machine=ns32k-sequent - os=-dynix - ;; - convex-c1) - basic_machine=c1-convex - os=-bsd - ;; - convex-c2) - basic_machine=c2-convex - os=-bsd - ;; - convex-c32) - basic_machine=c32-convex - os=-bsd - ;; - convex-c34) - basic_machine=c34-convex - os=-bsd - ;; - convex-c38) - basic_machine=c38-convex - os=-bsd - ;; - cray | ymp) - basic_machine=ymp-cray - os=-unicos - ;; - cray2) - basic_machine=cray2-cray - os=-unicos - ;; - crds | unos) - basic_machine=m68k-crds - ;; - da30 | da30-*) - basic_machine=m68k-da30 - ;; - decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) - basic_machine=mips-dec - ;; - delta | 3300 | motorola-3300 | motorola-delta \ - | 3300-motorola | delta-motorola) - basic_machine=m68k-motorola - ;; - delta88) - basic_machine=m88k-motorola - os=-sysv3 - ;; - dpx20 | dpx20-*) - basic_machine=rs6000-bull - os=-bosx - ;; - dpx2* | dpx2*-bull) - basic_machine=m68k-bull - os=-sysv3 - ;; - ebmon29k) - basic_machine=a29k-amd - os=-ebmon - ;; - elxsi) - basic_machine=elxsi-elxsi - os=-bsd - ;; - encore | umax | mmax) - basic_machine=ns32k-encore - ;; - fx2800) - basic_machine=i860-alliant - ;; - genix) - basic_machine=ns32k-ns - ;; - gmicro) - basic_machine=tron-gmicro - os=-sysv - ;; - h3050r* | hiux*) - basic_machine=hppa1.1-hitachi - os=-hiuxwe2 - ;; - h8300hms) - basic_machine=h8300-hitachi - os=-hms - ;; - harris) - basic_machine=m88k-harris - os=-sysv3 - ;; - hp300-*) - basic_machine=m68k-hp - ;; - hp300bsd) - basic_machine=m68k-hp - os=-bsd - ;; - hp300hpux) - basic_machine=m68k-hp - os=-hpux - ;; - hp9k2[0-9][0-9] | hp9k31[0-9]) - basic_machine=m68000-hp - ;; - hp9k3[2-9][0-9]) - basic_machine=m68k-hp - ;; - hp9k7[0-9][0-9] | hp7[0-9][0-9] | hp9k8[0-9]7 | hp8[0-9]7) - basic_machine=hppa1.1-hp - ;; - hp9k8[0-9][0-9] | hp8[0-9][0-9]) - basic_machine=hppa1.0-hp - ;; - i370-ibm* | ibm*) - basic_machine=i370-ibm - os=-mvs - ;; -# I'm not sure what "Sysv32" means. Should this be sysv3.2? - i[345]86v32) - basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` - os=-sysv32 - ;; - i[345]86v4*) - basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` - os=-sysv4 - ;; - i[345]86v) - basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` - os=-sysv - ;; - i[345]86sol2) - basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` - os=-solaris2 - ;; - iris | iris4d) - basic_machine=mips-sgi - case $os in - -irix*) - ;; - *) - os=-irix4 - ;; - esac - ;; - isi68 | isi) - basic_machine=m68k-isi - os=-sysv - ;; - m88k-omron*) - basic_machine=m88k-omron - ;; - magnum | m3230) - basic_machine=mips-mips - os=-sysv - ;; - merlin) - basic_machine=ns32k-utek - os=-sysv - ;; - miniframe) - basic_machine=m68000-convergent - ;; - mips3*-*) - basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` - ;; - mips3*) - basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown - ;; - ncr3000) - basic_machine=i486-ncr - os=-sysv4 - ;; - news | news700 | news800 | news900) - basic_machine=m68k-sony - os=-newsos - ;; - news1000) - basic_machine=m68030-sony - os=-newsos - ;; - news-3600 | risc-news) - basic_machine=mips-sony - os=-newsos - ;; - next | m*-next ) - basic_machine=m68k-next - case $os in - -nextstep* ) - ;; - -ns2*) - os=-nextstep2 - ;; - *) - os=-nextstep3 - ;; - esac - ;; - nh3000) - basic_machine=m68k-harris - os=-cxux - ;; - nh[45]000) - basic_machine=m88k-harris - os=-cxux - ;; - nindy960) - basic_machine=i960-intel - os=-nindy - ;; - np1) - basic_machine=np1-gould - ;; - pa-hitachi) - basic_machine=hppa1.1-hitachi - os=-hiuxwe2 - ;; - paragon) - basic_machine=i860-intel - os=-osf - ;; - pbd) - basic_machine=sparc-tti - ;; - pbb) - basic_machine=m68k-tti - ;; - pc532 | pc532-*) - basic_machine=ns32k-pc532 - ;; - pentium-*) - # We will change tis to say i586 once there has been - # time for various packages to start to recognize that. - basic_machine=i486-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pn) - basic_machine=pn-gould - ;; - ps2) - basic_machine=i386-ibm - ;; - rtpc | rtpc-*) - basic_machine=romp-ibm - ;; - sequent) - basic_machine=i386-sequent - ;; - sh) - basic_machine=sh-hitachi - os=-hms - ;; - sps7) - basic_machine=m68k-bull - os=-sysv2 - ;; - spur) - basic_machine=spur-unknown - ;; - sun2) - basic_machine=m68000-sun - ;; - sun2os3) - basic_machine=m68000-sun - os=-sunos3 - ;; - sun2os4) - basic_machine=m68000-sun - os=-sunos4 - ;; - sun3os3) - basic_machine=m68k-sun - os=-sunos3 - ;; - sun3os4) - basic_machine=m68k-sun - os=-sunos4 - ;; - sun4os3) - basic_machine=sparc-sun - os=-sunos3 - ;; - sun4os4) - basic_machine=sparc-sun - os=-sunos4 - ;; - sun3 | sun3-*) - basic_machine=m68k-sun - ;; - sun4) - basic_machine=sparc-sun - ;; - sun386 | sun386i | roadrunner) - basic_machine=i386-sun - ;; - symmetry) - basic_machine=i386-sequent - os=-dynix - ;; - tower | tower-32) - basic_machine=m68k-ncr - ;; - ultra3) - basic_machine=a29k-nyu - os=-sym1 - ;; - vaxv) - basic_machine=vax-dec - os=-sysv - ;; - vms) - basic_machine=vax-dec - os=-vms - ;; - vxworks960) - basic_machine=i960-wrs - os=-vxworks - ;; - vxworks68) - basic_machine=m68k-wrs - os=-vxworks - ;; - xmp) - basic_machine=xmp-cray - os=-unicos - ;; - xps | xps100) - basic_machine=xps100-honeywell - ;; - none) - basic_machine=none-none - os=-none - ;; - -# Here we handle the default manufacturer of certain CPU types. It is in -# some cases the only manufacturer, in others, it is the most popular. - mips) - basic_machine=mips-mips - ;; - romp) - basic_machine=romp-ibm - ;; - rs6000) - basic_machine=rs6000-ibm - ;; - vax) - basic_machine=vax-dec - ;; - pdp11) - basic_machine=pdp11-dec - ;; - we32k) - basic_machine=we32k-att - ;; - sparc) - basic_machine=sparc-sun - ;; - cydra) - basic_machine=cydra-cydrome - ;; - orion) - basic_machine=orion-highlevel - ;; - orion105) - basic_machine=clipper-highlevel - ;; - *) - echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 - exit 1 - ;; -esac - -# Here we canonicalize certain aliases for manufacturers. -case $basic_machine in - *-digital*) - basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` - ;; - *-commodore*) - basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` - ;; - *) - ;; -esac - -# Decode manufacturer-specific aliases for certain operating systems. - -if [ x"$os" != x"" ] -then -case $os in - # -solaris* is a basic system type, with this one exception. - -solaris1 | -solaris1.*) - os=`echo $os | sed -e 's|solaris1|sunos4|'` - ;; - -solaris) - os=-solaris2 - ;; - -gnu/linux*) - os=`echo $os | sed -e 's|gnu/linux|linux|'` - ;; - # First accept the basic system types. - # The portable systems comes first. - # Each alternative must end in a *, to match a version number. - # -sysv* is not here because it comes later, after sysvr4. - -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ - | -vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[345]* \ - | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \ - | -amigados* | -msdos* | -newsos* | -unicos* | -aos* \ - | -nindy* | -vxworks* | -ebmon* | -hms* | -mvs* | -clix* \ - | -riscos* | -linux* | -uniplus* | -iris* | -rtu* | -xenix* \ - | -hiux* | -386bsd* | -netbsd* | -freebsd* | -riscix* \ - | -lynxos* | -bosx* | -nextstep* | -cxux* | -aout* | -elf* \ - | -ptx* | -coff* | -winnt*) - ;; - -sunos5*) - os=`echo $os | sed -e 's|sunos5|solaris2|'` - ;; - -sunos6*) - os=`echo $os | sed -e 's|sunos6|solaris3|'` - ;; - -osfrose*) - os=-osfrose - ;; - -osf*) - os=-osf - ;; - -utek*) - os=-bsd - ;; - -dynix*) - os=-bsd - ;; - -acis*) - os=-aos - ;; - -ctix* | -uts*) - os=-sysv - ;; - -triton*) - os=-sysv3 - ;; - -oss*) - os=-sysv3 - ;; - -svr4) - os=-sysv4 - ;; - -svr3) - os=-sysv3 - ;; - -sysvr4) - os=-sysv4 - ;; - # This must come after -sysvr4. - -sysv*) - ;; - -xenix) - os=-xenix - ;; - -none) - ;; - *) - # Get rid of the `-' at the beginning of $os. - os=`echo $os | sed 's/[^-]*-//'` - echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 - exit 1 - ;; -esac -else - -# Here we handle the default operating systems that come with various machines. -# The value should be what the vendor currently ships out the door with their -# machine or put another way, the most popular os provided with the machine. - -# Note that if you're going to try to match "-MANUFACTURER" here (say, -# "-sun"), then you have to tell the case statement up towards the top -# that MANUFACTURER isn't an operating system. Otherwise, code above -# will signal an error saying that MANUFACTURER isn't an operating -# system, and we'll never get to this point. - -case $basic_machine in - *-acorn) - os=-riscix1.2 - ;; - pdp11-*) - os=-none - ;; - *-dec | vax-*) - os=-ultrix4.2 - ;; - i386-sun) - os=-sunos4.0.2 - ;; - m68000-sun) - os=-sunos3 - # This also exists in the configure program, but was not the - # default. - # os=-sunos4 - ;; - *-tti) # must be before sparc entry or we get the wrong os. - os=-sysv3 - ;; - sparc-* | *-sun) - os=-sunos4.1.1 - ;; - *-ibm) - os=-aix - ;; - *-hp) - os=-hpux - ;; - *-hitachi) - os=-hiux - ;; - i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) - os=-sysv - ;; - *-cbm) - os=-amigados - ;; - *-dg) - os=-dgux - ;; - *-dolphin) - os=-sysv3 - ;; - m68k-ccur) - os=-rtu - ;; - m88k-omron*) - os=-luna - ;; - *-sequent) - os=-ptx - ;; - *-crds) - os=-unos - ;; - *-ns) - os=-genix - ;; - i370-*) - os=-mvs - ;; - *-next) - os=-nextstep3 - ;; - *-gould) - os=-sysv - ;; - *-highlevel) - os=-bsd - ;; - *-encore) - os=-bsd - ;; - *-sgi) - os=-irix - ;; - *-masscomp) - os=-rtu - ;; - *) - os=-none - ;; -esac -fi - -# Here we handle the case where we know the os, and the CPU type, but not the -# manufacturer. We pick the logical manufacturer. -vendor=unknown -case $basic_machine in - *-unknown) - case $os in - -riscix*) - vendor=acorn - ;; - -sunos*) - vendor=sun - ;; - -lynxos*) - vendor=lynx - ;; - -aix*) - vendor=ibm - ;; - -hpux*) - vendor=hp - ;; - -hiux*) - vendor=hitachi - ;; - -unos*) - vendor=crds - ;; - -dgux*) - vendor=dg - ;; - -luna*) - vendor=omron - ;; - -genix*) - vendor=ns - ;; - -mvs*) - vendor=ibm - ;; - -ptx*) - vendor=sequent - ;; - esac - basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` - ;; -esac - -echo $basic_machine$os DELETED config/install-sh Index: config/install-sh ================================================================== --- config/install-sh +++ /dev/null @@ -1,119 +0,0 @@ -#!/bin/sh - -# -# install - install a program, script, or datafile -# This comes from X11R5; it is not part of GNU. -# -# $XConsortium: install.sh,v 1.2 89/12/18 14:47:22 jim Exp $ -# -# This script is compatible with the BSD install script, but was written -# from scratch. -# - - -# set DOITPROG to echo to test this script - -# Don't use :- since 4.3BSD and earlier shells don't like it. -doit="${DOITPROG-}" - - -# put in absolute paths if you don't have them in your path; or use env. vars. - -mvprog="${MVPROG-mv}" -cpprog="${CPPROG-cp}" -chmodprog="${CHMODPROG-chmod}" -chownprog="${CHOWNPROG-chown}" -chgrpprog="${CHGRPPROG-chgrp}" -stripprog="${STRIPPROG-strip}" -rmprog="${RMPROG-rm}" - -instcmd="$mvprog" -chmodcmd="" -chowncmd="" -chgrpcmd="" -stripcmd="" -rmcmd="$rmprog -f" -mvcmd="$mvprog" -src="" -dst="" - -while [ x"$1" != x ]; do - case $1 in - -c) instcmd="$cpprog" - shift - continue;; - - -m) chmodcmd="$chmodprog $2" - shift - shift - continue;; - - -o) chowncmd="$chownprog $2" - shift - shift - continue;; - - -g) chgrpcmd="$chgrpprog $2" - shift - shift - continue;; - - -s) stripcmd="$stripprog" - shift - continue;; - - *) if [ x"$src" = x ] - then - src=$1 - else - dst=$1 - fi - shift - continue;; - esac -done - -if [ x"$src" = x ] -then - echo "install: no input file specified" - exit 1 -fi - -if [ x"$dst" = x ] -then - echo "install: no destination specified" - exit 1 -fi - - -# If destination is a directory, append the input filename; if your system -# does not like double slashes in filenames, you may need to add some logic - -if [ -d $dst ] -then - dst="$dst"/`basename $src` -fi - -# Make a temp file name in the proper directory. - -dstdir=`dirname $dst` -dsttmp=$dstdir/#inst.$$# - -# Move or copy the file name to the temp name - -$doit $instcmd $src $dsttmp - -# and set any options; do chmod last to preserve setuid bits - -if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; fi -if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; fi -if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; fi -if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; fi - -# Now rename the file to the real destination. - -$doit $rmcmd $dst -$doit $mvcmd $dsttmp $dst - - -exit 0 DELETED config/installFile.tcl Index: config/installFile.tcl ================================================================== --- config/installFile.tcl +++ /dev/null @@ -1,131 +0,0 @@ -#!/bin/sh -# -# installFile.tcl - a Tcl version of install-sh -# that copies a file and preserves its permission bits. -# This also optimizes out installation of existing files -# that have the same size and time stamp as the source. -# -# \ -exec tclsh8.3 "$0" ${1+"$@"} - -set doCopy 0 ;# Rename files instead of copy -set doStrip 0 ;# Strip the symbols from installed copy -set verbose 0 -set src "" -set dst "" - -# Process command line arguments, compatible with install-sh - -for {set i 0} {$i < $argc} {incr i} { - set arg [lindex $argv $i] - switch -- $arg { - -c { - set doCopy 1 - } - -m { - incr i - # Assume UNIX standard "644", etc, so force Tcl to think octal - set permissions 0[lindex $argv $i] - } - -o { - incr i - set owner [lindex $argv $i] - } - -g { - incr i - set group [lindex $argv $i] - } - -s { - set doStrip 1 - } - -v { - set verbose 1 - } - default { - set src $arg - incr i - set dst [lindex $argv $i] - break - } - } -} -if {[string length $src] == 0} { - puts stderr "$argv0: no input file specified" - exit 1 -} -if {[string length $dst] == 0} { - puts stderr "$argv0: no destination file specified" - exit 1 -} - -# Compatibility with CYGNUS-style pathnames -regsub {^/(cygdrive)?/(.)/(.*)} $src {\2:/\3} src -regsub {^/(cygdrive)?/(.)/(.*)} $dst {\2:/\3} dst - -if {$verbose && $doStrip} { - puts stderr "Ignoring -s (strip) option for $dst" -} -if {[file isdirectory $dst]} { - set dst [file join $dst [file tail $src]] -} - -# Temporary file name - -set dsttmp [file join [file dirname $dst] #inst.[pid]#] - -# Optimize out install if the file already exists - -set actions "" -if {[file exists $dst] && - ([file mtime $src] == [file mtime $dst]) && - ([file size $src] == [file size $dst])} { - - # Looks like the same file, so don't bother to copy. - # Set dsttmp in case we still need to tweak mode, group, etc. - - set dsttmp $dst - lappend actions "already installed" -} else { - if {"[file type $src]" == "link"} { - # Perfom a true copy. - set in [open $src r] - set out [open $dsttmp w] - fcopy $in $out - close $in - close $out - } else { - file copy -force $src $dsttmp - } - lappend actions copied -} - -# update the modification time of the target file -file mtime $dsttmp [clock seconds] - -# At this point "$dsttmp" is installed, but might not have the -# right permissions and may need to be renamed. - - -foreach attrName {owner group permissions} { - upvar 0 $attrName attr - - if {[info exists attr]} { - if {![catch {file attributes $dsttmp -$attrName} dstattr]} { - - # This system supports "$attrName" kind of attributes - - if {($attr != $dstattr)} { - file attributes $dsttmp -$attrName $attr - lappend actions "set $attrName to $attr" - } - } - } -} - -if {[string compare $dst $dsttmp] != 0} { - file rename -force $dsttmp $dst -} -if {$verbose} { - puts stderr "$dst: [join $actions ", "]" -} -exit 0 DELETED config/mkinstalldirs Index: config/mkinstalldirs ================================================================== --- config/mkinstalldirs +++ /dev/null @@ -1,40 +0,0 @@ -#! /bin/sh -# mkinstalldirs --- make directory hierarchy -# Author: Noah Friedman -# Created: 1993-05-16 -# Public domain - -# $Id: mkinstalldirs,v 1.1 2002/12/05 20:22:57 andreas_kupries Exp $ - -errstatus=0 - -for file -do - set fnord `echo ":$file" | sed -ne 's/^:\//#/;s/^://;s/\// /g;s/^#/\//;p'` - shift - - pathcomp= - for d - do - pathcomp="$pathcomp$d" - case "$pathcomp" in - -* ) pathcomp=./$pathcomp ;; - esac - - if test ! -d "$pathcomp"; then - echo "mkdir $pathcomp" - - mkdir "$pathcomp" || lasterr=$? - - if test ! -d "$pathcomp"; then - errstatus=$lasterr - fi - fi - - pathcomp="$pathcomp/" - done -done - -exit $errstatus - -# mkinstalldirs ends here DELETED config/tcl.m4 Index: config/tcl.m4 ================================================================== --- config/tcl.m4 +++ /dev/null @@ -1,2709 +0,0 @@ -# tcl.m4 -- -# -# This file provides a set of autoconf macros to help TEA-enable -# a Tcl extension. -# -# Copyright (c) 1999-2000 Ajuba Solutions. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -#------------------------------------------------------------------------ -# SC_PATH_TCLCONFIG -- -# -# Locate the tclConfig.sh file and perform a sanity check on -# the Tcl compile flags -# -# Arguments: -# none -# -# Results: -# -# Adds the following arguments to configure: -# --with-tcl=... -# -# Defines the following vars: -# TCL_BIN_DIR Full path to the directory containing -# the tclConfig.sh file -#------------------------------------------------------------------------ - -AC_DEFUN(SC_PATH_TCLCONFIG, [ - # - # Ok, lets find the tcl configuration - # First, look for one uninstalled. - # the alternative search directory is invoked by --with-tcl - # - - if test x"${no_tcl}" = x ; then - # we reset no_tcl in case something fails here - no_tcl=true - AC_ARG_WITH(tcl, [ --with-tcl directory containing tcl configuration (tclConfig.sh)], with_tclconfig=${withval}) - AC_MSG_CHECKING([for Tcl configuration]) - AC_CACHE_VAL(ac_cv_c_tclconfig,[ - - # First check to see if --with-tcl was specified. - if test x"${with_tclconfig}" != x ; then - if test -f "${with_tclconfig}/tclConfig.sh" ; then - ac_cv_c_tclconfig=`(cd ${with_tclconfig}; pwd)` - else - AC_MSG_ERROR([${with_tclconfig} directory doesn't contain tclConfig.sh]) - fi - fi - - # then check for a private Tcl installation - if test x"${ac_cv_c_tclconfig}" = x ; then - for i in \ - ../tcl \ - `ls -dr ../tcl[[8-9]].[[0-9]]* 2>/dev/null` \ - ../../tcl \ - `ls -dr ../../tcl[[8-9]].[[0-9]]* 2>/dev/null` \ - ../../../tcl \ - `ls -dr ../../../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do - if test -f "$i/unix/tclConfig.sh" ; then - ac_cv_c_tclconfig=`(cd $i/unix; pwd)` - break - fi - done - fi - - # check in a few common install locations - if test x"${ac_cv_c_tclconfig}" = x ; then - for i in `ls -d ${prefix}/lib 2>/dev/null` \ - `ls -d /usr/lib 2>/dev/null` \ - `ls -d /usr/local/lib 2>/dev/null` ; do - if test -f "$i/tclConfig.sh" ; then - ac_cv_c_tclconfig=`(cd $i; pwd)` - break - fi - done - fi - - # check in a few other private locations - if test x"${ac_cv_c_tclconfig}" = x ; then - for i in \ - ${srcdir}/../tcl \ - `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do - if test -f "$i/unix/tclConfig.sh" ; then - ac_cv_c_tclconfig=`(cd $i/unix; pwd)` - break - fi - done - fi - ]) - - if test x"${ac_cv_c_tclconfig}" = x ; then - TCL_BIN_DIR="# no Tcl configs found" - AC_MSG_WARN(Can't find Tcl configuration definitions) - exit 0 - else - no_tcl= - TCL_BIN_DIR=${ac_cv_c_tclconfig} - AC_MSG_RESULT(found $TCL_BIN_DIR/tclConfig.sh) - fi - fi -]) - -#------------------------------------------------------------------------ -# SC_PATH_TKCONFIG -- -# -# Locate the tkConfig.sh file -# -# Arguments: -# none -# -# Results: -# -# Adds the following arguments to configure: -# --with-tk=... -# -# Defines the following vars: -# TK_BIN_DIR Full path to the directory containing -# the tkConfig.sh file -#------------------------------------------------------------------------ - -AC_DEFUN(SC_PATH_TKCONFIG, [ - # - # Ok, lets find the tk configuration - # First, look for one uninstalled. - # the alternative search directory is invoked by --with-tk - # - - if test x"${no_tk}" = x ; then - # we reset no_tk in case something fails here - no_tk=true - AC_ARG_WITH(tk, [ --with-tk directory containing tk configuration (tkConfig.sh)], with_tkconfig=${withval}) - AC_MSG_CHECKING([for Tk configuration]) - AC_CACHE_VAL(ac_cv_c_tkconfig,[ - - # First check to see if --with-tkconfig was specified. - if test x"${with_tkconfig}" != x ; then - if test -f "${with_tkconfig}/tkConfig.sh" ; then - ac_cv_c_tkconfig=`(cd ${with_tkconfig}; pwd)` - else - AC_MSG_ERROR([${with_tkconfig} directory doesn't contain tkConfig.sh]) - fi - fi - - # then check for a private Tk library - if test x"${ac_cv_c_tkconfig}" = x ; then - for i in \ - ../tk \ - `ls -dr ../tk[[8-9]].[[0-9]]* 2>/dev/null` \ - ../../tk \ - `ls -dr ../../tk[[8-9]].[[0-9]]* 2>/dev/null` \ - ../../../tk \ - `ls -dr ../../../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do - if test -f "$i/unix/tkConfig.sh" ; then - ac_cv_c_tkconfig=`(cd $i/unix; pwd)` - break - fi - done - fi - # check in a few common install locations - if test x"${ac_cv_c_tkconfig}" = x ; then - for i in `ls -d ${prefix}/lib 2>/dev/null` \ - `ls -d /usr/lib 2>/dev/null` \ - `ls -d /usr/local/lib 2>/dev/null` ; do - if test -f "$i/tkConfig.sh" ; then - ac_cv_c_tkconfig=`(cd $i; pwd)` - break - fi - done - fi - # check in a few other private locations - if test x"${ac_cv_c_tkconfig}" = x ; then - for i in \ - ${srcdir}/../tk \ - `ls -dr ${srcdir}/../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do - if test -f "$i/unix/tkConfig.sh" ; then - ac_cv_c_tkconfig=`(cd $i/unix; pwd)` - break - fi - done - fi - ]) - if test x"${ac_cv_c_tkconfig}" = x ; then - TK_BIN_DIR="# no Tk configs found" - AC_MSG_WARN(Can't find Tk configuration definitions) - exit 0 - else - no_tk= - TK_BIN_DIR=${ac_cv_c_tkconfig} - AC_MSG_RESULT(found $TK_BIN_DIR/tkConfig.sh) - fi - fi - -]) - -#------------------------------------------------------------------------ -# SC_LOAD_TCLCONFIG -- -# -# Load the tclConfig.sh file -# -# Arguments: -# -# Requires the following vars to be set: -# TCL_BIN_DIR -# -# Results: -# -# Subst the following vars: -# TCL_BIN_DIR -# TCL_SRC_DIR -# TCL_LIB_FILE -# -#------------------------------------------------------------------------ - -AC_DEFUN(SC_LOAD_TCLCONFIG, [ - AC_MSG_CHECKING([for existence of $TCL_BIN_DIR/tclConfig.sh]) - - if test -f "$TCL_BIN_DIR/tclConfig.sh" ; then - AC_MSG_RESULT([loading]) - . $TCL_BIN_DIR/tclConfig.sh - else - AC_MSG_RESULT([file not found]) - fi - - # - # The eval is required to do the TCL_DBGX substitution in the - # TCL_LIB_FILE variable - # - - eval TCL_LIB_FILE=${TCL_LIB_FILE} - eval TCL_LIB_FLAG=${TCL_LIB_FLAG} - - AC_SUBST(TCL_DBGX) - AC_SUBST(TCL_BIN_DIR) - AC_SUBST(TCL_SRC_DIR) - AC_SUBST(TCL_LIB_FILE) - AC_SUBST(TCL_LIBS) - AC_SUBST(TCL_DEFS) - AC_SUBST(TCL_SHLIB_LD_LIBS) - AC_SUBST(TCL_EXTRA_CFLAGS) - AC_SUBST(TCL_LD_FLAGS) - AC_SUBST(TCL_LIB_FILE) - AC_SUBST(TCL_STUB_LIB_FILE) - AC_SUBST(TCL_LIB_SPEC) - AC_SUBST(TCL_BUILD_LIB_SPEC) - AC_SUBST(TCL_STUB_LIB_SPEC) - AC_SUBST(TCL_BUILD_STUB_LIB_SPEC) -]) - -#------------------------------------------------------------------------ -# SC_LOAD_TKCONFIG -- -# -# Load the tkConfig.sh file -# -# Arguments: -# -# Requires the following vars to be set: -# TK_BIN_DIR -# -# Results: -# -# Sets the following vars that should be in tkConfig.sh: -# TK_BIN_DIR -#------------------------------------------------------------------------ - -AC_DEFUN(SC_LOAD_TKCONFIG, [ - AC_MSG_CHECKING([for existence of $TK_BIN_DIR/tkConfig.sh]) - - if test -f "$TK_BIN_DIR/tkConfig.sh" ; then - AC_MSG_RESULT([loading]) - . $TK_BIN_DIR/tkConfig.sh - else - AC_MSG_RESULT([could not find $TK_BIN_DIR/tkConfig.sh]) - fi - - AC_SUBST(TK_BIN_DIR) - AC_SUBST(TK_SRC_DIR) - AC_SUBST(TK_LIB_FILE) - AC_SUBST(TK_XINCLUDES) -]) - -#------------------------------------------------------------------------ -# SC_ENABLE_GCC -- -# -# Allows the use of GCC if available -# -# Arguments: -# none -# -# Results: -# -# Adds the following arguments to configure: -# --enable-gcc -# -# Sets the following vars: -# CC Command to use for the compiler -#------------------------------------------------------------------------ - -AC_DEFUN(SC_ENABLE_GCC, [ - AC_ARG_ENABLE(gcc, [ --enable-gcc allow use of gcc if available [--disable-gcc]], - [ok=$enableval], [ok=no]) - if test "$ok" = "yes"; then - CC=gcc - else - case "`uname -s`" in - *win32* | *WIN32* | *CYGWIN_NT* | *CYGWIN_98* | *CYGWIN_95*) - CC=cl - ;; - *) - CC=${CC-cc} - ;; - esac - fi - AC_PROG_CC -]) - -#------------------------------------------------------------------------ -# SC_ENABLE_SHARED -- -# -# Allows the building of shared libraries -# -# Arguments: -# none -# -# Results: -# -# Adds the following arguments to configure: -# --enable-shared=yes|no -# -# Defines the following vars: -# STATIC_BUILD Used for building import/export libraries -# on Windows. -# -# Sets the following vars: -# SHARED_BUILD Value of 1 or 0 -#------------------------------------------------------------------------ - -AC_DEFUN(SC_ENABLE_SHARED, [ - AC_MSG_CHECKING([how to build libraries]) - AC_ARG_ENABLE(shared, - [ --enable-shared build and link with shared libraries [--enable-shared]], - [tcl_ok=$enableval], [tcl_ok=yes]) - - if test "${enable_shared+set}" = set; then - enableval="$enable_shared" - tcl_ok=$enableval - else - tcl_ok=yes - fi - - if test "$tcl_ok" = "yes" ; then - AC_MSG_RESULT([shared]) - SHARED_BUILD=1 - else - AC_MSG_RESULT([static]) - SHARED_BUILD=0 - AC_DEFINE(STATIC_BUILD) - fi -]) - -#------------------------------------------------------------------------ -# SC_ENABLE_THREADS -- -# -# Specify if thread support should be enabled -# -# Arguments: -# none -# -# Results: -# -# Adds the following arguments to configure: -# --enable-threads -# -# Sets the following vars: -# THREADS_LIBS Thread library(s) -# -# Defines the following vars: -# TCL_THREADS -# _REENTRANT -# -#------------------------------------------------------------------------ - -AC_DEFUN(SC_ENABLE_THREADS, [ - AC_MSG_CHECKING(for building with threads) - AC_ARG_ENABLE(threads, [ --enable-threads build with threads], - [tcl_ok=$enableval], [tcl_ok=no]) - - if test "$tcl_ok" = "yes"; then - TCL_THREADS=1 - AC_DEFINE(TCL_THREADS) - AC_DEFINE(_REENTRANT) - - case "`uname -s`" in - *win32* | *WIN32* | *CYGWIN_NT* | *CYGWIN_98* | *CYGWIN_95*) - AC_MSG_RESULT(yes) - ;; - *) - AC_CHECK_LIB(pthread,pthread_mutex_init,tcl_ok=yes,tcl_ok=no) - if test "$tcl_ok" = "yes"; then - # The space is needed - THREADS_LIBS=" -lpthread" - AC_MSG_RESULT(yes) - else - TCL_THREADS=0 - AC_MSG_RESULT(no) - AC_MSG_WARN("Don t know how to find pthread lib on your system - you must disable thread support or edit the LIBS in the Makefile...") - fi - ;; - esac - else - TCL_THREADS=0 - AC_MSG_RESULT(no (default)) - fi - -]) - -#------------------------------------------------------------------------ -# SC_ENABLE_SYMBOLS -- -# -# Specify if debugging symbols should be used -# -# Arguments: -# none -# -# Requires the following vars to be set: -# CFLAGS_DEBUG -# CFLAGS_OPTIMIZE -# LDFLAGS_DEBUG -# LDFLAGS_OPTIMIZE -# -# Results: -# -# Adds the following arguments to configure: -# --enable-symbols -# -# Defines the following vars: -# CFLAGS_DEFAULT Sets to CFLAGS_DEBUG if true -# Sets to CFLAGS_OPTIMIZE if false -# LDFLAGS_DEFAULT Sets to LDFLAGS_DEBUG if true -# Sets to LDFLAGS_OPTIMIZE if false -# DBGX Debug library extension -# -#------------------------------------------------------------------------ - -AC_DEFUN(SC_ENABLE_SYMBOLS, [ - case "`uname -s`" in - *win32* | *WIN32* | *CYGWIN_NT* | *CYGWIN_98* | *CYGWIN_95*) - tcl_dbgx=d - ;; - *) - tcl_dbgx=g - ;; - esac - - AC_MSG_CHECKING([for build with symbols]) - AC_ARG_ENABLE(symbols, [ --enable-symbols build with debugging symbols [--disable-symbols]], [tcl_ok=$enableval], [tcl_ok=no]) - if test "$tcl_ok" = "yes"; then - CFLAGS_DEFAULT="${CFLAGS_DEBUG}" - LDFLAGS_DEFAULT="${LDFLAGS_DEBUG}" - DBGX=${tcl_dbgx} - TCL_DBGX=${tcl_dbgx} - AC_MSG_RESULT([yes]) - else - CFLAGS_DEFAULT="${CFLAGS_OPTIMIZE}" - LDFLAGS_DEFAULT="${LDFLAGS_OPTIMIZE}" - DBGX="" - TCL_DBGX="" - AC_MSG_RESULT([no]) - fi - - AC_SUBST(TCL_DBGX) - AC_SUBST(CFLAGS_DEFAULT) - AC_SUBST(LDFLAGS_DEFAULT) -]) - -#-------------------------------------------------------------------- -# SC_CONFIG_CFLAGS -# -# Try to determine the proper flags to pass to the compiler -# for building shared libraries and other such nonsense. -# -# Arguments: -# none -# -# Results: -# -# Defines the following vars: -# -# DL_OBJS - Name of the object file that implements dynamic -# loading for Tcl on this system. -# DL_LIBS - Library file(s) to include in tclsh and other base -# applications in order for the "load" command to work. -# LDFLAGS - Flags to pass to the compiler when linking object -# files into an executable application binary such -# as tclsh. -# LD_SEARCH_FLAGS-Flags to pass to ld, such as "-R /usr/local/tcl/lib", -# that tell the run-time dynamic linker where to look -# for shared libraries such as libtcl.so. Depends on -# the variable LIB_RUNTIME_DIR in the Makefile. -# MAKE_LIB - Command to execute to build the Tcl library; -# differs depending on whether or not Tcl is being -# compiled as a shared library. -# SHLIB_CFLAGS - Flags to pass to cc when compiling the components -# of a shared library (may request position-independent -# code, among other things). -# SHLIB_LD - Base command to use for combining object files -# into a shared library. -# SHLIB_LD_LIBS - Dependent libraries for the linker to scan when -# creating shared libraries. This symbol typically -# goes at the end of the "ld" commands that build -# shared libraries. The value of the symbol is -# "${LIBS}" if all of the dependent libraries should -# be specified when creating a shared library. If -# dependent libraries should not be specified (as on -# SunOS 4.x, where they cause the link to fail, or in -# general if Tcl and Tk aren't themselves shared -# libraries), then this symbol has an empty string -# as its value. -# SHLIB_SUFFIX - Suffix to use for the names of dynamically loadable -# extensions. An empty string means we don't know how -# to use shared libraries on this platform. -# TCL_LIB_FILE - Name of the file that contains the Tcl library, such -# as libtcl7.8.so or libtcl7.8.a. -# TCL_LIB_SUFFIX -Specifies everything that comes after the "libtcl" -# in the shared library name, using the $VERSION variable -# to put the version in the right place. This is used -# by platforms that need non-standard library names. -# Examples: ${VERSION}.so.1.1 on NetBSD, since it needs -# to have a version after the .so, and ${VERSION}.a -# on AIX, since the Tcl shared library needs to have -# a .a extension whereas shared objects for loadable -# extensions have a .so extension. Defaults to -# ${VERSION}${SHLIB_SUFFIX}. -# TCL_NEEDS_EXP_FILE - -# 1 means that an export file is needed to link to a -# shared library. -# TCL_EXP_FILE - The name of the installed export / import file which -# should be used to link to the Tcl shared library. -# Empty if Tcl is unshared. -# TCL_BUILD_EXP_FILE - -# The name of the built export / import file which -# should be used to link to the Tcl shared library. -# Empty if Tcl is unshared. -# CFLAGS_DEBUG - -# Flags used when running the compiler in debug mode -# CFLAGS_OPTIMIZE - -# Flags used when running the compiler in optimize mode -# -# EXTRA_CFLAGS -# -# Subst's the following vars: -# DL_LIBS -# CFLAGS_DEBUG -# CFLAGS_OPTIMIZE -#-------------------------------------------------------------------- - -AC_DEFUN(SC_CONFIG_CFLAGS, [ - - # Step 0: Enable 64 bit support? - - AC_MSG_CHECKING([if 64bit support is enabled]) - AC_ARG_ENABLE(64bit,[ --enable-64bit enable 64bit support],,enableval="no") - - if test "$enableval" = "yes"; then - AC_MSG_RESULT(Will compile with 64bit support) - do64bit=yes - else - do64bit=no - fi - AC_MSG_RESULT($do64bit) - - # Step 1: set the variable "system" to hold the name and version number - # for the system. This can usually be done via the "uname" command, but - # there are a few systems, like Next, where this doesn't work. - - AC_MSG_CHECKING([system version (for dynamic loading)]) - if test -f /usr/lib/NextStep/software_version; then - system=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version` - else - system=`uname -s`-`uname -r` - if test "$?" -ne 0 ; then - AC_MSG_RESULT([unknown (can't find uname command)]) - system=unknown - else - # Special check for weird MP-RAS system (uname returns weird - # results, and the version is kept in special file). - - if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then - system=MP-RAS-`awk '{print $3}' /etc/.relid'` - fi - if test "`uname -s`" = "AIX" ; then - system=AIX-`uname -v`.`uname -r` - fi - AC_MSG_RESULT($system) - fi - fi - - # Step 2: check for existence of -ldl library. This is needed because - # Linux can use either -ldl or -ldld for dynamic loading. - - AC_CHECK_LIB(dl, dlopen, have_dl=yes, have_dl=no) - - # Step 3: set configuration options based on system name and version. - - do64bit_ok=no - fullSrcDir=`cd $srcdir; pwd` - EXTRA_CFLAGS="" - TCL_EXPORT_FILE_SUFFIX="" - UNSHARED_LIB_SUFFIX="" - TCL_TRIM_DOTS='`echo ${VERSION} | tr -d .`' - ECHO_VERSION='`echo ${VERSION}`' - TCL_LIB_VERSIONS_OK=ok - CFLAGS_DEBUG=-g - CFLAGS_OPTIMIZE=-O - TCL_NEEDS_EXP_FILE=0 - TCL_BUILD_EXP_FILE="" - TCL_EXP_FILE="" - STLIB_LD="ar cr" - case $system in - AIX-5.*) - if test "${TCL_THREADS}" = "1" -a "$using_gcc" = "no" ; then - # AIX requires the _r compiler when gcc isn't being used - if test "${CC}" != "cc_r" ; then - CC=${CC}_r - fi - AC_MSG_RESULT(Using $CC for compiling with threads) - fi - # AIX-5 uses ELF style dynamic libraries - SHLIB_CFLAGS="" - SHLIB_LD="/usr/ccs/bin/ld -G -z text" - - # Note: need the LIBS below, otherwise Tk won't find Tcl's - # symbols when dynamically loaded into tclsh. - - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - # AIX-5 has dl* in libc.so - DL_LIBS="" - LDFLAGS="" - if test "$using_gcc" = "yes" ; then - LD_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' - else - LD_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}' - fi - - if test "$do64bit" = "yes" ; then - if test "$using_gcc" = "no" ; then - do64bit_ok=yes - EXTRA_CFLAGS="-q64" - LDFLAGS="-q64" - else - AC_MSG_WARN("64bit mode not supported with GCC on $system") - fi - fi - ;; - AIX-*) - if test "${TCL_THREADS}" = "1" -a "$using_gcc" = "no" ; then - # AIX requires the _r compiler when gcc isn't being used - if test "${CC}" != "cc_r" ; then - CC=${CC}_r - fi - AC_MSG_RESULT(Using $CC for compiling with threads) - fi - SHLIB_CFLAGS="" - SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LDFLAGS="" - LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - TCL_NEEDS_EXP_FILE=1 - TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.exp' - - # AIX v<=4.1 has some different flags than 4.2+ - if test "$system" = "AIX-4.1" -o "`uname -v`" -lt "4" ; then - LIBOBJS="$LIBOBJS tclLoadAix.o" - DL_LIBS="-lld" - fi - - # On AIX <=v4 systems, libbsd.a has to be linked in to support - # non-blocking file IO. This library has to be linked in after - # the MATH_LIBS or it breaks the pow() function. The way to - # insure proper sequencing, is to add it to the tail of MATH_LIBS. - # This library also supplies gettimeofday. - # - # AIX does not have a timezone field in struct tm. When the AIX - # bsd library is used, the timezone global and the gettimeofday - # methods are to be avoided for timezone deduction instead, we - # deduce the timezone by comparing the localtime result on a - # known GMT value. - - AC_CHECK_LIB(bsd, gettimeofday, libbsd=yes, libbsd=no) - if test $libbsd = yes; then - MATH_LIBS="$MATH_LIBS -lbsd" - AC_DEFINE(USE_DELTA_FOR_TZ) - fi - ;; - BSD/OS-2.1*|BSD/OS-3*) - SHLIB_CFLAGS="" - SHLIB_LD="shlicc -r" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LDFLAGS="" - LD_SEARCH_FLAGS="" - ;; - BSD/OS-4.*) - SHLIB_CFLAGS="-export-dynamic -fPIC" - SHLIB_LD="cc -shared" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LDFLAGS="-export-dynamic" - LD_SEARCH_FLAGS="" - ;; - *win32*|*WIN32*|CYGWIN_NT*|cygwin_nt*|*CYGWIN_98*|*CYGWIN_95*) - CFLAGS_DEBUG="-nologo -Z7 -Od -WX ${runtime}d" - CFLAGS_OPTIMIZE="-nologo -Oti -Gs -GD ${runtime}" - LDFLAGS_CONSOLE="-subsystem:console" - LDFLAGS_WINDOW="-subsystem:windows" - LDFLAGS_DEBUG="-debug:full -debugtype:cv" - LDFLAGS_OPTIMIZE="-release" - EXTRA_CFLAGS="-YX" - PATHTYPE=-w - STLIB_LD="lib -nologo" - SHLIB_LD="link -dll -nologo -incremental:no" - SHLIB_LD_LIBS="user32.lib advapi32.lib" - RC="rc" - ;; - dgux*) - SHLIB_CFLAGS="-K PIC" - SHLIB_LD="cc -G" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LDFLAGS="" - LD_SEARCH_FLAGS="" - ;; - HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*|HP-UX-*.11.*) - SHLIB_SUFFIX=".sl" - AC_CHECK_LIB(dld, shl_load, tcl_ok=yes, tcl_ok=no) - if test "$tcl_ok" = yes; then - SHLIB_CFLAGS="+z" - SHLIB_LD="ld -b" - SHLIB_LD_LIBS="" - DL_OBJS="tclLoadShl.o" - DL_LIBS="-ldld" - LDFLAGS="-Wl,-E" - LD_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' - fi - ;; - IRIX-4.*) - SHLIB_CFLAGS="-G 0" - SHLIB_SUFFIX=".a" - SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" - SHLIB_LD_LIBS='${LIBS}' - DL_OBJS="tclLoadAout.o" - DL_LIBS="" - LDFLAGS="-Wl,-D,08000000" - LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a' - ;; - IRIX-5.*) - SHLIB_CFLAGS="" - SHLIB_LD="ld -shared -rdata_shared" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - EXTRA_CFLAGS="" - LDFLAGS="" - ;; - IRIX-6.*|IRIX64-6.5*) - SHLIB_CFLAGS="" - SHLIB_LD="ld -n32 -shared -rdata_shared" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - if test "$using_gcc" = "yes" ; then - EXTRA_CFLAGS="-mabi=n32" - LDFLAGS="-mabi=n32" - else - case $system in - IRIX-6.3) - # Use to build 6.2 compatible binaries on 6.3. - EXTRA_CFLAGS="-n32 -D_OLD_TERMIOS" - ;; - *) - EXTRA_CFLAGS="-n32" - ;; - esac - LDFLAGS="-n32" - fi - ;; - IRIX64-6.*) - SHLIB_CFLAGS="" - SHLIB_LD="ld -32 -shared -rdata_shared" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - LDFLAGS="" - LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - ;; - Linux*) - SHLIB_CFLAGS="-fPIC" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - - # egcs-2.91.66 on Redhat Linux 6.0 generates lots of warnings - # when you inline the string and math operations. Turn this off to - # get rid of the warnings. - - CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES" - - if test "$have_dl" = yes; then - SHLIB_LD="${CC} -shared" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LDFLAGS="-rdynamic" - LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - else - AC_CHECK_HEADER(dld.h, [ - SHLIB_LD="ld -shared" - DL_OBJS="tclLoadDld.o" - DL_LIBS="-ldld" - LDFLAGS="" - LD_SEARCH_FLAGS=""]) - fi - if test "`uname -m`" = "alpha" ; then - EXTRA_CFLAGS="-mieee" - fi - ;; - MP-RAS-02*) - SHLIB_CFLAGS="-K PIC" - SHLIB_LD="cc -G" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LDFLAGS="" - LD_SEARCH_FLAGS="" - ;; - MP-RAS-*) - SHLIB_CFLAGS="-K PIC" - SHLIB_LD="cc -G" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LDFLAGS="-Wl,-Bexport" - LD_SEARCH_FLAGS="" - ;; - NetBSD-*|FreeBSD-[[12]].*|OpenBSD-*) - # Not available on all versions: check for include file. - AC_CHECK_HEADER(dlfcn.h, [ - SHLIB_CFLAGS="-fpic" - SHLIB_LD="ld -Bshareable -x" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - LDFLAGS="" - LD_SEARCH_FLAGS="" - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0' - ], [ - SHLIB_CFLAGS="" - SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".a" - DL_OBJS="tclLoadAout.o" - DL_LIBS="" - LDFLAGS="" - LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a' - ]) - - # FreeBSD doesn't handle version numbers with dots. - - UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a' - TCL_LIB_VERSIONS_OK=nodots - ;; - FreeBSD-*) - # FreeBSD 3.* and greater have ELF. - SHLIB_CFLAGS="-fpic" - SHLIB_LD="ld -Bshareable -x" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - LDFLAGS="" - LD_SEARCH_FLAGS="" - ;; - NEXTSTEP-*) - SHLIB_CFLAGS="" - SHLIB_LD="cc -nostdlib -r" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadNext.o" - DL_LIBS="" - LDFLAGS="" - LD_SEARCH_FLAGS="" - ;; - OS/390-*) - CFLAGS_OPTIMIZE="" # Optimizer is buggy - AC_DEFINE(_OE_SOCKETS) # needed in sys/socket.h - ;; - OSF1-1.0|OSF1-1.1|OSF1-1.2) - # OSF/1 1.[012] from OSF, and derivatives, including Paragon OSF/1 - SHLIB_CFLAGS="" - # Hack: make package name same as library name - SHLIB_LD='ld -R -export $@:' - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadOSF.o" - DL_LIBS="" - LDFLAGS="" - LD_SEARCH_FLAGS="" - ;; - OSF1-1.*) - # OSF/1 1.3 from OSF using ELF, and derivatives, including AD2 - SHLIB_CFLAGS="-fpic" - SHLIB_LD="ld -shared" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - LDFLAGS="" - LD_SEARCH_FLAGS="" - ;; - OSF1-V*) - # Digital OSF/1 - SHLIB_CFLAGS="" - SHLIB_LD='ld -shared -expect_unresolved "*"' - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - LDFLAGS="" - LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - ;; - RISCos-*) - SHLIB_CFLAGS="-G 0" - SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".a" - DL_OBJS="tclLoadAout.o" - DL_LIBS="" - LDFLAGS="-Wl,-D,08000000" - LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - ;; - SCO_SV-3.2*) - # Note, dlopen is available only on SCO 3.2.5 and greater. However, - # this test works, since "uname -s" was non-standard in 3.2.4 and - # below. - SHLIB_CFLAGS="-Kpic -belf" - SHLIB_LD="ld -G" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - LDFLAGS="-belf -Wl,-Bexport" - LD_SEARCH_FLAGS="" - ;; - SINIX*5.4*) - SHLIB_CFLAGS="-K PIC" - SHLIB_LD="cc -G" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LDFLAGS="" - LD_SEARCH_FLAGS="" - ;; - SunOS-4*) - SHLIB_CFLAGS="-PIC" - SHLIB_LD="ld" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LDFLAGS="" - LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - - # SunOS can't handle version numbers with dots in them in library - # specs, like -ltcl7.5, so use -ltcl75 instead. Also, it - # requires an extra version number at the end of .so file names. - # So, the library has to have a name like libtcl75.so.1.0 - - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0' - UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a' - TCL_LIB_VERSIONS_OK=nodots - ;; - SunOS-5.[[0-6]]*) - SHLIB_CFLAGS="-KPIC" - SHLIB_LD="/usr/ccs/bin/ld -G -z text" - - # Note: need the LIBS below, otherwise Tk won't find Tcl's - # symbols when dynamically loaded into tclsh. - - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LDFLAGS="" - LD_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' - ;; - SunOS-5*) - SHLIB_CFLAGS="-KPIC" - SHLIB_LD="/usr/ccs/bin/ld -G -z text" - LDFLAGS="" - - do64bit_ok=no - if test "$do64bit" = "yes" ; then - arch=`isainfo` - if test "$arch" = "sparcv9 sparc" ; then - if test "$CC" != "gcc" -a `$CC -v 2>&1 | grep -c gcc` = "0" ; then - do64bit_ok=yes - EXTRA_CFLAGS="-xarch=v9" - LDFLAGS="-xarch=v9" - else - AC_MSG_WARN("64bit mode not supported using GCC on $system") - fi - else - AC_MSG_WARN("64bit mode only supported sparcv9 system") - fi - fi - - # Note: need the LIBS below, otherwise Tk won't find Tcl's - # symbols when dynamically loaded into tclsh. - - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - if test "$CC" = "gcc" -o `$CC -v 2>&1 | grep -c gcc` != "0" ; then - LD_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' - else - LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' - fi - ;; - ULTRIX-4.*) - SHLIB_CFLAGS="-G 0" - SHLIB_SUFFIX=".a" - SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" - SHLIB_LD_LIBS='${LIBS}' - DL_OBJS="tclLoadAout.o" - DL_LIBS="" - LDFLAGS="-Wl,-D,08000000" - LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - ;; - UNIX_SV* | UnixWare-5*) - SHLIB_CFLAGS="-KPIC" - SHLIB_LD="cc -G" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - # Some UNIX_SV* systems (unixware 1.1.2 for example) have linkers - # that don't grok the -Bexport option. Test that it does. - hold_ldflags=$LDFLAGS - AC_MSG_CHECKING(for ld accepts -Bexport flag) - LDFLAGS="${LDFLAGS} -Wl,-Bexport" - AC_TRY_LINK(, [int i;], found=yes, found=no) - LDFLAGS=$hold_ldflags - AC_MSG_RESULT($found) - if test $found = yes; then - LDFLAGS="-Wl,-Bexport" - else - LDFLAGS="" - fi - LD_SEARCH_FLAGS="" - ;; - esac - - if test "$do64bit" = "yes" -a "$do64bit_ok" = "no" ; then - AC_MSG_WARN("64bit support being disabled -- not supported on this platform") - fi - - # Step 4: If pseudo-static linking is in use (see K. B. Kenny, "Dynamic - # Loading for Tcl -- What Became of It?". Proc. 2nd Tcl/Tk Workshop, - # New Orleans, LA, Computerized Processes Unlimited, 1994), then we need - # to determine which of several header files defines the a.out file - # format (a.out.h, sys/exec.h, or sys/exec_aout.h). At present, we - # support only a file format that is more or less version-7-compatible. - # In particular, - # - a.out files must begin with `struct exec'. - # - the N_TXTOFF on the `struct exec' must compute the seek address - # of the text segment - # - The `struct exec' must contain a_magic, a_text, a_data, a_bss - # and a_entry fields. - # The following compilation should succeed if and only if either sys/exec.h - # or a.out.h is usable for the purpose. - # - # Note that the modified COFF format used on MIPS Ultrix 4.x is usable; the - # `struct exec' includes a second header that contains information that - # duplicates the v7 fields that are needed. - - if test "x$DL_OBJS" = "xtclLoadAout.o" ; then - AC_MSG_CHECKING(sys/exec.h) - AC_TRY_COMPILE([#include ],[ - struct exec foo; - unsigned long seek; - int flag; -#if defined(__mips) || defined(mips) - seek = N_TXTOFF (foo.ex_f, foo.ex_o); -#else - seek = N_TXTOFF (foo); -#endif - flag = (foo.a_magic == OMAGIC); - return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; - ], tcl_ok=usable, tcl_ok=unusable) - AC_MSG_RESULT($tcl_ok) - if test $tcl_ok = usable; then - AC_DEFINE(USE_SYS_EXEC_H) - else - AC_MSG_CHECKING(a.out.h) - AC_TRY_COMPILE([#include ],[ - struct exec foo; - unsigned long seek; - int flag; -#if defined(__mips) || defined(mips) - seek = N_TXTOFF (foo.ex_f, foo.ex_o); -#else - seek = N_TXTOFF (foo); -#endif - flag = (foo.a_magic == OMAGIC); - return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; - ], tcl_ok=usable, tcl_ok=unusable) - AC_MSG_RESULT($tcl_ok) - if test $tcl_ok = usable; then - AC_DEFINE(USE_A_OUT_H) - else - AC_MSG_CHECKING(sys/exec_aout.h) - AC_TRY_COMPILE([#include ],[ - struct exec foo; - unsigned long seek; - int flag; -#if defined(__mips) || defined(mips) - seek = N_TXTOFF (foo.ex_f, foo.ex_o); -#else - seek = N_TXTOFF (foo); -#endif - flag = (foo.a_midmag == OMAGIC); - return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; - ], tcl_ok=usable, tcl_ok=unusable) - AC_MSG_RESULT($tcl_ok) - if test $tcl_ok = usable; then - AC_DEFINE(USE_SYS_EXEC_AOUT_H) - else - DL_OBJS="" - fi - fi - fi - fi - - # Step 5: disable dynamic loading if requested via a command-line switch. - - AC_ARG_ENABLE(load, [ --disable-load disallow dynamic loading and "load" command], - [tcl_ok=$enableval], [tcl_ok=yes]) - if test "$tcl_ok" = "no"; then - DL_OBJS="" - fi - - if test "x$DL_OBJS" != "x" ; then - BUILD_DLTEST="\$(DLTEST_TARGETS)" - else - echo "Can't figure out how to do dynamic loading or shared libraries" - echo "on this system." - SHLIB_CFLAGS="" - SHLIB_LD="" - SHLIB_SUFFIX="" - DL_OBJS="tclLoadNone.o" - DL_LIBS="" - LDFLAGS="" - LD_SEARCH_FLAGS="" - BUILD_DLTEST="" - fi - - # If we're running gcc, then change the C flags for compiling shared - # libraries to the right flags for gcc, instead of those for the - # standard manufacturer compiler. - - if test "$DL_OBJS" != "tclLoadNone.o" ; then - if test "$CC" = "gcc" -o `$CC -v 2>&1 | grep -c gcc` != "0" ; then - case $system in - AIX-*) - ;; - BSD/OS*) - ;; - IRIX*) - ;; - NetBSD-*|FreeBSD-*|OpenBSD-*) - ;; - RISCos-*) - ;; - ULTRIX-4.*) - ;; - *) - SHLIB_CFLAGS="-fPIC" - ;; - esac - fi - fi - - if test "$SHARED_LIB_SUFFIX" = "" ; then - SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}${SHLIB_SUFFIX}' - fi - if test "$UNSHARED_LIB_SUFFIX" = "" ; then - UNSHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a' - fi - - AC_SUBST(STLIB_LD) - AC_SUBST(SHLIB_LD) - AC_SUBST(SHLIB_CFLAGS) - AC_SUBST(SHLIB_LDFLAGS) - AC_SUBST(DL_LIBS) - AC_SUBST(CFLAGS_DEBUG) - AC_SUBST(CFLAGS_OPTIMIZE) - AC_SUBST(LDFLAGS_DEBUG) - AC_SUBST(LDFLAGS_OPTIMIZE) -]) - -#-------------------------------------------------------------------- -# SC_SERIAL_PORT -# -# Determine which interface to use to talk to the serial port. -# Note that #include lines must begin in leftmost column for -# some compilers to recognize them as preprocessor directives. -# -# Arguments: -# none -# -# Results: -# -# Defines only one of the following vars: -# USE_TERMIOS -# USE_TERMIO -# USE_SGTTY -# -#-------------------------------------------------------------------- - -AC_DEFUN(SC_SERIAL_PORT, [ - AC_MSG_CHECKING([termios vs. termio vs. sgtty]) - - AC_TRY_RUN([ -#include - -main() -{ - struct termios t; - if (tcgetattr(0, &t) == 0) { - cfsetospeed(&t, 0); - t.c_cflag |= PARENB | PARODD | CSIZE | CSTOPB; - return 0; - } - return 1; -}], tk_ok=termios, tk_ok=no, tk_ok=no) - - if test $tk_ok = termios; then - AC_DEFINE(USE_TERMIOS) - else - AC_TRY_RUN([ -#include - -main() -{ - struct termio t; - if (ioctl(0, TCGETA, &t) == 0) { - t.c_cflag |= CBAUD | PARENB | PARODD | CSIZE | CSTOPB; - return 0; - } - return 1; - }], tk_ok=termio, tk_ok=no, tk_ok=no) - - if test $tk_ok = termio; then - AC_DEFINE(USE_TERMIO) - else - AC_TRY_RUN([ -#include - -main() -{ - struct sgttyb t; - if (ioctl(0, TIOCGETP, &t) == 0) { - t.sg_ospeed = 0; - t.sg_flags |= ODDP | EVENP | RAW; - return 0; - } - return 1; -}], tk_ok=sgtty, tk_ok=none, tk_ok=none) - - if test $tk_ok = sgtty; then - AC_DEFINE(USE_SGTTY) - else - AC_TRY_RUN([ -#include -#include - -main() -{ - struct termios t; - if (tcgetattr(0, &t) == 0 - || errno == ENOTTY || errno == ENXIO || errno == EINVAL) { - cfsetospeed(&t, 0); - t.c_cflag |= PARENB | PARODD | CSIZE | CSTOPB; - return 0; - } - return 1; -}], tk_ok=termios, tk_ok=no, tk_ok=no) - - if test $tk_ok = termios; then - AC_DEFINE(USE_TERMIOS) - else - AC_TRY_RUN([ -#include -#include - -main() -{ - struct termio t; - if (ioctl(0, TCGETA, &t) == 0 - || errno == ENOTTY || errno == ENXIO || errno == EINVAL) { - t.c_cflag |= CBAUD | PARENB | PARODD | CSIZE | CSTOPB; - return 0; - } - return 1; - }], tk_ok=termio, tk_ok=no, tk_ok=no) - - if test $tk_ok = termio; then - AC_DEFINE(USE_TERMIO) - else - AC_TRY_RUN([ -#include -#include - -main() -{ - struct sgttyb t; - if (ioctl(0, TIOCGETP, &t) == 0 - || errno == ENOTTY || errno == ENXIO || errno == EINVAL) { - t.sg_ospeed = 0; - t.sg_flags |= ODDP | EVENP | RAW; - return 0; - } - return 1; -}], tk_ok=sgtty, tk_ok=none, tk_ok=none) - - if test $tk_ok = sgtty; then - AC_DEFINE(USE_SGTTY) - fi - fi - fi - fi - fi - fi - AC_MSG_RESULT($tk_ok) -]) - -#-------------------------------------------------------------------- -# SC_MISSING_POSIX_HEADERS -# -# Supply substitutes for missing POSIX header files. Special -# notes: -# - stdlib.h doesn't define strtol, strtoul, or -# strtod insome versions of SunOS -# - some versions of string.h don't declare procedures such -# as strstr -# -# Arguments: -# none -# -# Results: -# -# Defines some of the following vars: -# NO_DIRENT_H -# NO_ERRNO_H -# NO_VALUES_H -# NO_LIMITS_H -# NO_STDLIB_H -# NO_STRING_H -# NO_SYS_WAIT_H -# NO_DLFCN_H -# HAVE_UNISTD_H -# HAVE_SYS_PARAM_H -# -# HAVE_STRING_H ? -# -#-------------------------------------------------------------------- - -AC_DEFUN(SC_MISSING_POSIX_HEADERS, [ - - AC_MSG_CHECKING(dirent.h) - AC_TRY_LINK([#include -#include ], [ -#ifndef _POSIX_SOURCE -# ifdef __Lynx__ - /* - * Generate compilation error to make the test fail: Lynx headers - * are only valid if really in the POSIX environment. - */ - - missing_procedure(); -# endif -#endif -DIR *d; -struct dirent *entryPtr; -char *p; -d = opendir("foobar"); -entryPtr = readdir(d); -p = entryPtr->d_name; -closedir(d); -], tcl_ok=yes, tcl_ok=no) - - if test $tcl_ok = no; then - AC_DEFINE(NO_DIRENT_H) - fi - - AC_MSG_RESULT($tcl_ok) - AC_CHECK_HEADER(errno.h, , AC_DEFINE(NO_ERRNO_H)) - AC_CHECK_HEADER(float.h, , AC_DEFINE(NO_FLOAT_H)) - AC_CHECK_HEADER(values.h, , AC_DEFINE(NO_VALUES_H)) - AC_CHECK_HEADER(limits.h, , AC_DEFINE(NO_LIMITS_H)) - AC_CHECK_HEADER(stdlib.h, tcl_ok=1, tcl_ok=0) - AC_EGREP_HEADER(strtol, stdlib.h, , tcl_ok=0) - AC_EGREP_HEADER(strtoul, stdlib.h, , tcl_ok=0) - AC_EGREP_HEADER(strtod, stdlib.h, , tcl_ok=0) - if test $tcl_ok = 0; then - AC_DEFINE(NO_STDLIB_H) - fi - AC_CHECK_HEADER(string.h, tcl_ok=1, tcl_ok=0) - AC_EGREP_HEADER(strstr, string.h, , tcl_ok=0) - AC_EGREP_HEADER(strerror, string.h, , tcl_ok=0) - - # See also memmove check below for a place where NO_STRING_H can be - # set and why. - - if test $tcl_ok = 0; then - AC_DEFINE(NO_STRING_H) - fi - - AC_CHECK_HEADER(sys/wait.h, , AC_DEFINE(NO_SYS_WAIT_H)) - AC_CHECK_HEADER(dlfcn.h, , AC_DEFINE(NO_DLFCN_H)) - - # OS/390 lacks sys/param.h (and doesn't need it, by chance). - - AC_HAVE_HEADERS(unistd.h sys/param.h) - -]) - -#-------------------------------------------------------------------- -# SC_PATH_X -# -# Locate the X11 header files and the X11 library archive. Try -# the ac_path_x macro first, but if it doesn't find the X stuff -# (e.g. because there's no xmkmf program) then check through -# a list of possible directories. Under some conditions the -# autoconf macro will return an include directory that contains -# no include files, so double-check its result just to be safe. -# -# Arguments: -# none -# -# Results: -# -# Sets the the following vars: -# XINCLUDES -# XLIBSW -# -#-------------------------------------------------------------------- - -AC_DEFUN(SC_PATH_X, [ - AC_PATH_X - not_really_there="" - if test "$no_x" = ""; then - if test "$x_includes" = ""; then - AC_TRY_CPP([#include ], , not_really_there="yes") - else - if test ! -r $x_includes/X11/Intrinsic.h; then - not_really_there="yes" - fi - fi - fi - if test "$no_x" = "yes" -o "$not_really_there" = "yes"; then - AC_MSG_CHECKING(for X11 header files) - XINCLUDES="# no special path needed" - AC_TRY_CPP([#include ], , XINCLUDES="nope") - if test "$XINCLUDES" = nope; then - dirs="/usr/unsupported/include /usr/local/include /usr/X386/include /usr/X11R6/include /usr/X11R5/include /usr/include/X11R5 /usr/include/X11R4 /usr/openwin/include /usr/X11/include /usr/sww/include" - for i in $dirs ; do - if test -r $i/X11/Intrinsic.h; then - AC_MSG_RESULT($i) - XINCLUDES=" -I$i" - break - fi - done - fi - else - if test "$x_includes" != ""; then - XINCLUDES=-I$x_includes - else - XINCLUDES="# no special path needed" - fi - fi - if test "$XINCLUDES" = nope; then - AC_MSG_RESULT(couldn't find any!) - XINCLUDES="# no include files found" - fi - - if test "$no_x" = yes; then - AC_MSG_CHECKING(for X11 libraries) - XLIBSW=nope - dirs="/usr/unsupported/lib /usr/local/lib /usr/X386/lib /usr/X11R6/lib /usr/X11R5/lib /usr/lib/X11R5 /usr/lib/X11R4 /usr/openwin/lib /usr/X11/lib /usr/sww/X11/lib" - for i in $dirs ; do - if test -r $i/libX11.a -o -r $i/libX11.so -o -r $i/libX11.sl; then - AC_MSG_RESULT($i) - XLIBSW="-L$i -lX11" - x_libraries="$i" - break - fi - done - else - if test "$x_libraries" = ""; then - XLIBSW=-lX11 - else - XLIBSW="-L$x_libraries -lX11" - fi - fi - if test "$XLIBSW" = nope ; then - AC_CHECK_LIB(Xwindow, XCreateWindow, XLIBSW=-lXwindow) - fi - if test "$XLIBSW" = nope ; then - AC_MSG_RESULT(couldn't find any! Using -lX11.) - XLIBSW=-lX11 - fi -]) -#-------------------------------------------------------------------- -# SC_BLOCKING_STYLE -# -# The statements below check for systems where POSIX-style -# non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented. -# On these systems (mostly older ones), use the old BSD-style -# FIONBIO approach instead. -# -# Arguments: -# none -# -# Results: -# -# Defines some of the following vars: -# HAVE_SYS_IOCTL_H -# HAVE_SYS_FILIO_H -# USE_FIONBIO -# O_NONBLOCK -# -#-------------------------------------------------------------------- - -AC_DEFUN(SC_BLOCKING_STYLE, [ - AC_CHECK_HEADERS(sys/ioctl.h) - AC_CHECK_HEADERS(sys/filio.h) - AC_MSG_CHECKING([FIONBIO vs. O_NONBLOCK for nonblocking I/O]) - if test -f /usr/lib/NextStep/software_version; then - system=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version` - else - system=`uname -s`-`uname -r` - if test "$?" -ne 0 ; then - system=unknown - else - # Special check for weird MP-RAS system (uname returns weird - # results, and the version is kept in special file). - - if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then - system=MP-RAS-`awk '{print $3}' /etc/.relid'` - fi - if test "`uname -s`" = "AIX" ; then - system=AIX-`uname -v`.`uname -r` - fi - fi - fi - case $system in - # There used to be code here to use FIONBIO under AIX. However, it - # was reported that FIONBIO doesn't work under AIX 3.2.5. Since - # using O_NONBLOCK seems fine under AIX 4.*, I removed the FIONBIO - # code (JO, 5/31/97). - - OSF*) - AC_DEFINE(USE_FIONBIO) - AC_MSG_RESULT(FIONBIO) - ;; - SunOS-4*) - AC_DEFINE(USE_FIONBIO) - AC_MSG_RESULT(FIONBIO) - ;; - ULTRIX-4.*) - AC_DEFINE(USE_FIONBIO) - AC_MSG_RESULT(FIONBIO) - ;; - *) - AC_MSG_RESULT(O_NONBLOCK) - ;; - esac -]) - -#-------------------------------------------------------------------- -# SC_HAVE_VFORK -# -# Check to see whether the system provides a vfork kernel call. -# If not, then use fork instead. Also, check for a problem with -# vforks and signals that can cause core dumps if a vforked child -# resets a signal handler. If the problem exists, then use fork -# instead of vfork. -# -# Arguments: -# none -# -# Results: -# -# Defines some of the following vars: -# vfork (=fork) -# -#-------------------------------------------------------------------- - -AC_DEFUN(SC_HAVE_VFORK, [ - AC_TYPE_SIGNAL() - AC_CHECK_FUNC(vfork, tcl_ok=1, tcl_ok=0) - if test "$tcl_ok" = 1; then - AC_MSG_CHECKING([vfork/signal bug]); - AC_TRY_RUN([ -#include -#include -#include -int gotSignal = 0; -sigProc(sig) - int sig; -{ - gotSignal = 1; -} -main() -{ - int pid, sts; - (void) signal(SIGCHLD, sigProc); - pid = vfork(); - if (pid < 0) { - exit(1); - } else if (pid == 0) { - (void) signal(SIGCHLD, SIG_DFL); - _exit(0); - } else { - (void) wait(&sts); - } - exit((gotSignal) ? 0 : 1); -}], tcl_ok=1, tcl_ok=0, tcl_ok=0) - - if test "$tcl_ok" = 1; then - AC_MSG_RESULT(ok) - else - AC_MSG_RESULT([buggy, using fork instead]) - fi - fi - rm -f core - if test "$tcl_ok" = 0; then - AC_DEFINE(vfork, fork) - fi -]) - -#-------------------------------------------------------------------- -# SC_TIME_HANLDER -# -# Checks how the system deals with time.h, what time structures -# are used on the system, and what fields the structures have. -# -# Arguments: -# none -# -# Results: -# -# Defines some of the following vars: -# USE_DELTA_FOR_TZ -# HAVE_TM_GMTOFF -# HAVE_TM_TZADJ -# HAVE_TIMEZONE_VAR -# -#-------------------------------------------------------------------- - -AC_DEFUN(SC_TIME_HANDLER, [ - AC_CHECK_HEADERS(sys/time.h) - AC_HEADER_TIME - AC_STRUCT_TIMEZONE - - AC_MSG_CHECKING([tm_tzadj in struct tm]) - AC_TRY_COMPILE([#include ], [struct tm tm; tm.tm_tzadj;], - [AC_DEFINE(HAVE_TM_TZADJ) - AC_MSG_RESULT(yes)], - AC_MSG_RESULT(no)) - - AC_MSG_CHECKING([tm_gmtoff in struct tm]) - AC_TRY_COMPILE([#include ], [struct tm tm; tm.tm_gmtoff;], - [AC_DEFINE(HAVE_TM_GMTOFF) - AC_MSG_RESULT(yes)], - AC_MSG_RESULT(no)) - - # - # Its important to include time.h in this check, as some systems - # (like convex) have timezone functions, etc. - # - have_timezone=no - AC_MSG_CHECKING([long timezone variable]) - AC_TRY_COMPILE([#include ], - [extern long timezone; - timezone += 1; - exit (0);], - [have_timezone=yes - AC_DEFINE(HAVE_TIMEZONE_VAR) - AC_MSG_RESULT(yes)], - AC_MSG_RESULT(no)) - - # - # On some systems (eg IRIX 6.2), timezone is a time_t and not a long. - # - if test "$have_timezone" = no; then - AC_MSG_CHECKING([time_t timezone variable]) - AC_TRY_COMPILE([#include ], - [extern time_t timezone; - timezone += 1; - exit (0);], - [AC_DEFINE(HAVE_TIMEZONE_VAR) - AC_MSG_RESULT(yes)], - AC_MSG_RESULT(no)) - fi - - # - # AIX does not have a timezone field in struct tm. When the AIX bsd - # library is used, the timezone global and the gettimeofday methods are - # to be avoided for timezone deduction instead, we deduce the timezone - # by comparing the localtime result on a known GMT value. - # - - if test "`uname -s`" = "AIX" ; then - AC_CHECK_LIB(bsd, gettimeofday, libbsd=yes) - if test $libbsd = yes; then - AC_DEFINE(USE_DELTA_FOR_TZ) - fi - fi -]) - -#-------------------------------------------------------------------- -# SC_BUGGY_STRTOD -# -# Under Solaris 2.4, strtod returns the wrong value for the -# terminating character under some conditions. Check for this -# and if the problem exists use a substitute procedure -# "fixstrtod" (provided by Tcl) that corrects the error. -# -# Arguments: -# none -# -# Results: -# -# Might defines some of the following vars: -# strtod (=fixstrtod) -# -#-------------------------------------------------------------------- - -AC_DEFUN(SC_BUGGY_STRTOD, [ - AC_CHECK_FUNC(strtod, tcl_strtod=1, tcl_strtod=0) - if test "$tcl_strtod" = 1; then - AC_MSG_CHECKING([for Solaris2.4/Tru64 strtod bugs]) - AC_TRY_RUN([ - extern double strtod(); - int main() - { - char *string = "NaN", *spaceString = " "; - char *term; - double value; - value = strtod(string, &term); - if ((term != string) && (term[-1] == 0)) { - exit(1); - } - value = strtod(spaceString, &term); - if (term == (spaceString+1)) { - exit(1); - } - exit(0); - }], tcl_ok=1, tcl_ok=0, tcl_ok=0) - if test "$tcl_ok" = 1; then - AC_MSG_RESULT(ok) - else - AC_MSG_RESULT(buggy) - LIBOBJS="$LIBOBJS fixstrtod.o" - AC_DEFINE(strtod, fixstrtod) - fi - fi -]) - -#-------------------------------------------------------------------- -# SC_TCL_LINK_LIBS -# -# Search for the libraries needed to link the Tcl shell. -# Things like the math library (-lm) and socket stuff (-lsocket vs. -# -lnsl) are dealt with here. -# -# Arguments: -# Requires the following vars to be set in the Makefile: -# DL_LIBS -# LIBS -# MATH_LIBS -# -# Results: -# -# Subst's the following var: -# TCL_LIBS -# MATH_LIBS -# -# Might append to the following vars: -# LIBS -# -# Might define the following vars: -# HAVE_NET_ERRNO_H -# -#-------------------------------------------------------------------- - -AC_DEFUN(SC_TCL_LINK_LIBS, [ - #-------------------------------------------------------------------- - # On a few very rare systems, all of the libm.a stuff is - # already in libc.a. Set compiler flags accordingly. - # Also, Linux requires the "ieee" library for math to work - # right (and it must appear before "-lm"). - #-------------------------------------------------------------------- - - AC_CHECK_FUNC(sin, MATH_LIBS="", MATH_LIBS="-lm") - AC_CHECK_LIB(ieee, main, [MATH_LIBS="-lieee $MATH_LIBS"]) - - #-------------------------------------------------------------------- - # On AIX systems, libbsd.a has to be linked in to support - # non-blocking file IO. This library has to be linked in after - # the MATH_LIBS or it breaks the pow() function. The way to - # insure proper sequencing, is to add it to the tail of MATH_LIBS. - # This library also supplies gettimeofday. - #-------------------------------------------------------------------- - - libbsd=no - if test "`uname -s`" = "AIX" ; then - AC_CHECK_LIB(bsd, gettimeofday, libbsd=yes) - if test $libbsd = yes; then - MATH_LIBS="$MATH_LIBS -lbsd" - fi - fi - - - #-------------------------------------------------------------------- - # Interactive UNIX requires -linet instead of -lsocket, plus it - # needs net/errno.h to define the socket-related error codes. - #-------------------------------------------------------------------- - - AC_CHECK_LIB(inet, main, [LIBS="$LIBS -linet"]) - AC_CHECK_HEADER(net/errno.h, AC_DEFINE(HAVE_NET_ERRNO_H)) - - #-------------------------------------------------------------------- - # Check for the existence of the -lsocket and -lnsl libraries. - # The order here is important, so that they end up in the right - # order in the command line generated by make. Here are some - # special considerations: - # 1. Use "connect" and "accept" to check for -lsocket, and - # "gethostbyname" to check for -lnsl. - # 2. Use each function name only once: can't redo a check because - # autoconf caches the results of the last check and won't redo it. - # 3. Use -lnsl and -lsocket only if they supply procedures that - # aren't already present in the normal libraries. This is because - # IRIX 5.2 has libraries, but they aren't needed and they're - # bogus: they goof up name resolution if used. - # 4. On some SVR4 systems, can't use -lsocket without -lnsl too. - # To get around this problem, check for both libraries together - # if -lsocket doesn't work by itself. - #-------------------------------------------------------------------- - - tcl_checkBoth=0 - AC_CHECK_FUNC(connect, tcl_checkSocket=0, tcl_checkSocket=1) - if test "$tcl_checkSocket" = 1; then - AC_CHECK_LIB(socket, main, LIBS="$LIBS -lsocket", tcl_checkBoth=1) - fi - if test "$tcl_checkBoth" = 1; then - tk_oldLibs=$LIBS - LIBS="$LIBS -lsocket -lnsl" - AC_CHECK_FUNC(accept, tcl_checkNsl=0, [LIBS=$tk_oldLibs]) - fi - AC_CHECK_FUNC(gethostbyname, , AC_CHECK_LIB(nsl, main, - [LIBS="$LIBS -lnsl"])) - - # Don't perform the eval of the libraries here because DL_LIBS - # won't be set until we call SC_CONFIG_CFLAGS - - TCL_LIBS='${DL_LIBS} ${LIBS} ${MATH_LIBS}' - AC_SUBST(TCL_LIBS) - AC_SUBST(MATH_LIBS) -]) - -#------------------------------------------------------------------------ -# SC_MAKE_LIB -- -# -# Generate a line that can be used to build a shared/unshared library -# in a platform independent manner. -# -# Arguments: -# none -# -# Requires: -# -# Results: -# -# Defines the following vars: -# MAKE_LIB Makefile rule for building a library -# MAKE_SHARED_LIB Makefile rule for building a shared library -# MAKE_UNSHARED_LIB Makefile rule for building a static -# library -#------------------------------------------------------------------------ - -AC_DEFUN(SC_MAKE_LIB, [ - case "`uname -s`" in - *win32* | *WIN32* | *CYGWIN_NT* |*CYGWIN_98*|*CYGWIN_95*) - if test "${CC-cc}" = "cl"; then - MAKE_STATIC_LIB="\${STLIB_LD} -out:\[$]@ \$(${PACKAGE}_LIB_OBJECTS) " - MAKE_SHARED_LIB="\${SHLIB_LD} \${SHLIB_LDFLAGS} \${SHLIB_LD_LIBS} \$(LDFLAGS) -out:\[$]@ \$(${PACKAGE}_LIB_OBJECTS) " - fi - ;; - *) - MAKE_STATIC_LIB="\${STLIB_LD} \[$]@ \$(${PACKAGE}_LIB_OBJECTS)" - MAKE_SHARED_LIB="\${SHLIB_LD} -o \[$]@ \$(${PACKAGE}_LIB_OBJECTS) \${SHLIB_LDFLAGS} \${SHLIB_LD_LIBS}" - ;; - esac - - if test "${SHARED_BUILD}" = "1" ; then - MAKE_LIB=${MAKE_SHARED_LIB} - else - MAKE_LIB=${MAKE_STATIC_LIB} - fi - - AC_SUBST(MAKE_LIB) - AC_SUBST(MAKE_SHARED_LIB) - AC_SUBST(MAKE_STATIC_LIB) -]) - -#------------------------------------------------------------------------ -# SC_LIB_SPEC -- -# -# Compute the name of an existing object library located in libdir -# from the given base name and produce the appropriate linker flags. -# -# Arguments: -# basename The base name of the library without version -# numbers, extensions, or "lib" prefixes. -# extra_dir Extra directory in which to search for the -# library. This location is used first, then -# $prefix/$exec-prefix, then some defaults. -# -# Requires: -# CYGPATH command used to generate native style paths -# -# Results: -# -# Defines the following vars: -# ${basename}_LIB_NAME The computed library name. -# ${basename}_LIB_SPEC The computed linker flags. -#------------------------------------------------------------------------ - -AC_DEFUN(SC_LIB_SPEC, [ - AC_MSG_CHECKING(for $1 library) - - # Look in exec-prefix and prefix for the library. If neither of - # these were specified, look in libdir. It doesn't matter if libdir - # wasn't specified since a search in the unspecified directory will - # fail (NONE/lib) - - if test x"${exec_prefix}" != x"NONE" ; then - sc_lib_name_dir="${exec_prefix}/lib" - elif test x"${prefix}" != x"NONE" ; then - sc_lib_name_dir="${prefix}/lib" - else - eval "sc_lib_name_dir=${libdir}" - fi - - if test x"$2" != x ; then - sc_extra_lib_dir=$2 - else - sc_extra_lib_dir=NONE - fi - - for i in \ - `ls -dr ${sc_extra_lib_dir}/$1[[0-9]]*.lib 2>/dev/null ` \ - `ls -dr ${sc_extra_lib_dir}/$1.lib 2>/dev/null ` \ - `ls -dr ${sc_extra_lib_dir}/lib$1[[0-9]]* 2>/dev/null ` \ - `ls -dr ${sc_extra_lib_dir}/lib$1.* 2>/dev/null ` \ - `ls -dr ${sc_lib_name_dir}/$1[[0-9]]*.lib 2>/dev/null ` \ - `ls -dr ${sc_lib_name_dir}/$1.lib 2>/dev/null ` \ - `ls -dr ${sc_lib_name_dir}/lib$1[[0-9]]* 2>/dev/null ` \ - `ls -dr ${sc_lib_name_dir}/lib$1.* 2>/dev/null ` \ - `ls -dr /usr/lib/$1[[0-9]]*.lib 2>/dev/null ` \ - `ls -dr /usr/lib/$1.lib 2>/dev/null ` \ - `ls -dr /usr/lib/lib$1[[0-9]]* 2>/dev/null ` \ - `ls -dr /usr/lib/lib$1.* 2>/dev/null ` \ - `ls -dr /usr/local/lib/$1[[0-9]]*.lib 2>/dev/null ` \ - `ls -dr /usr/local/lib/$1.lib 2>/dev/null ` \ - `ls -dr /usr/local/lib/lib$1[[0-9]]* 2>/dev/null ` \ - `ls -dr /usr/local/lib/lib$1.* 2>/dev/null ` ; do - if test -f "$i" ; then - - sc_lib_name_dir=`dirname $i` - $1_LIB_NAME=`basename $i` - $1_LIB_PATH_NAME=$i - break - fi - done - - case "`uname -s`" in - *win32* | *WIN32* | *CYGWIN_NT* |*CYGWIN_98*|*CYGWIN_95*) - $1_LIB_SPEC=\"`${CYGPATH} ${$1_LIB_PATH_NAME}`\" - ;; - *) - # Strip off the leading "lib" and trailing ".a" or ".so" - - sc_lib_name_lib=`echo ${$1_LIB_NAME}|sed -e 's/^lib//' -e 's/\.[[^.]]*$//' -e 's/\.so.*//'` - $1_LIB_SPEC="-L${sc_lib_name_dir} -l${sc_lib_name_lib}" - ;; - esac - - if test "x${$1_LIB_NAME}" = x ; then - AC_MSG_ERROR(not found) - else - AC_MSG_RESULT(${$1_LIB_SPEC}) - fi -]) - -#------------------------------------------------------------------------ -# SC_PRIVATE_TCL_HEADERS -- -# -# Locate the private Tcl include files -# -# Arguments: -# -# Requires: -# TCL_SRC_DIR Assumes that SC_LOAD_TCLCONFIG has -# already been called. -# -# Results: -# -# Substs the following vars: -# TCL_TOP_DIR_NATIVE -# TCL_GENERIC_DIR_NATIVE -# TCL_UNIX_DIR_NATIVE -# TCL_WIN_DIR_NATIVE -# TCL_BMAP_DIR_NATIVE -# TCL_TOOL_DIR_NATIVE -# TCL_PLATFORM_DIR_NATIVE -# TCL_BIN_DIR_NATIVE -# TCL_INCLUDES -#------------------------------------------------------------------------ - -AC_DEFUN(SC_PRIVATE_TCL_HEADERS, [ - AC_MSG_CHECKING(for Tcl private include files) - - case "`uname -s`" in - *win32* | *WIN32* | *CYGWIN_NT* |*CYGWIN_98*|*CYGWIN_95*) - TCL_TOP_DIR_NATIVE=\"`${CYGPATH} ${TCL_SRC_DIR}`\" - TCL_GENERIC_DIR_NATIVE=\"`${CYGPATH} ${TCL_SRC_DIR}/generic`\" - TCL_UNIX_DIR_NATIVE=\"`${CYGPATH} ${TCL_SRC_DIR}/unix`\" - TCL_WIN_DIR_NATIVE=\"`${CYGPATH} ${TCL_SRC_DIR}/win`\" - TCL_BMAP_DIR_NATIVE=\"`${CYGPATH} ${TCL_SRC_DIR}/bitmaps`\" - TCL_TOOL_DIR_NATIVE=\"`${CYGPATH} ${TCL_SRC_DIR}/tools`\" - TCL_COMPAT_DIR_NATIVE=\"`${CYGPATH} ${TCL_SRC_DIR}/compat`\" - TCL_PLATFORM_DIR_NATIVE=${TCL_WIN_DIR_NATIVE} - ;; - *) - TCL_TOP_DIR_NATIVE='$(TCL_SRC_DIR)' - TCL_GENERIC_DIR_NATIVE='$(TCL_TOP_DIR_NATIVE)/generic' - TCL_UNIX_DIR_NATIVE='$(TCL_TOP_DIR_NATIVE)/unix' - TCL_WIN_DIR_NATIVE='$(TCL_TOP_DIR_NATIVE)/win' - TCL_BMAP_DIR_NATIVE='$(TCL_TOP_DIR_NATIVE)/bitmaps' - TCL_TOOL_DIR_NATIVE='$(TCL_TOP_DIR_NATIVE)/tools' - TCL_COMPAT_DIR_NATIVE='$(TCL_TOP_DIR_NATIVE)/compat' - TCL_PLATFORM_DIR_NATIVE=${TCL_UNIX_DIR_NATIVE} - ;; - esac - - AC_SUBST(TCL_TOP_DIR_NATIVE) - AC_SUBST(TCL_GENERIC_DIR_NATIVE) - AC_SUBST(TCL_UNIX_DIR_NATIVE) - AC_SUBST(TCL_WIN_DIR_NATIVE) - AC_SUBST(TCL_BMAP_DIR_NATIVE) - AC_SUBST(TCL_TOOL_DIR_NATIVE) - AC_SUBST(TCL_PLATFORM_DIR_NATIVE) - - TCL_INCLUDES="-I${TCL_GENERIC_DIR_NATIVE} -I${TCL_PLATFORM_DIR_NATIVE}" - AC_SUBST(TCL_INCLUDES) - AC_MSG_RESULT(Using srcdir found in tclConfig.sh) -]) - -#------------------------------------------------------------------------ -# SC_PUBLIC_TCL_HEADERS -- -# -# Locate the installed public Tcl header files -# -# Arguments: -# None. -# -# Requires: -# CYGPATH must be set -# -# Results: -# -# Adds a --with-tclinclude switch to configure. -# Result is cached. -# -# Substs the following vars: -# TCL_INCLUDES -#------------------------------------------------------------------------ - -AC_DEFUN(SC_PUBLIC_TCL_HEADERS, [ - AC_MSG_CHECKING(for Tcl public headers) - - AC_ARG_WITH(tclinclude, [ --with-tclinclude directory containing the public Tcl header files.], with_tclinclude=${withval}) - - if test x"${with_tclinclude}" != x ; then - if test -f "${with_tclinclude}/tcl.h" ; then - ac_cv_c_tclh=${with_tclinclude} - else - AC_MSG_ERROR([${with_tclinclude} directory does not contain Tcl public header file tcl.h]) - fi - else - AC_CACHE_VAL(ac_cv_c_tclh, [ - # Use the value from --with-tclinclude, if it was given - - if test x"${with_tclinclude}" != x ; then - ac_cv_c_tclh=${with_tclinclude} - else - # Check in the includedir, if --prefix was specified - - eval "temp_includedir=${includedir}" - for i in \ - `ls -d ${TCL_PREFIX}/include 2>/dev/null` \ - `ls -d ${temp_includedir} 2>/dev/null` \ - `ls -d ${TCL_BIN_DIR}/../include 2>/dev/null` \ - /usr/local/include /usr/include ; do - if test -f "$i/tcl.h" ; then - ac_cv_c_tclh=$i - break - fi - done - fi - ]) - fi - - # Print a message based on how we determined the include path - - if test x"${ac_cv_c_tclh}" = x ; then - AC_MSG_ERROR(tcl.h not found. Please specify its location with --with-tclinclude) - else - AC_MSG_RESULT(${ac_cv_c_tclh}) - fi - - # Convert to a native path and substitute into the output files. - - INCLUDE_DIR_NATIVE=`${CYGPATH} ${ac_cv_c_tclh}` - - TCL_INCLUDES=-I\"${INCLUDE_DIR_NATIVE}\" - - AC_SUBST(TCL_INCLUDES) -]) - -#------------------------------------------------------------------------ -# SC_PRIVATE_TK_HEADERS -- -# -# Locate the private Tk include files -# -# Arguments: -# -# Requires: -# TK_SRC_DIR Assumes that SC_LOAD_TKCONFIG has -# already been called. -# -# Results: -# -# Substs the following vars: -# TK_INCLUDES -#------------------------------------------------------------------------ - -AC_DEFUN(SC_PRIVATE_TK_HEADERS, [ - AC_MSG_CHECKING(for Tk private include files) - - case "`uname -s`" in - *win32* | *WIN32* | *CYGWIN_NT* |*CYGWIN_98*|*CYGWIN_95*) - TK_TOP_DIR_NATIVE=\"`${CYGPATH} ${TK_SRC_DIR}`\" - TK_UNIX_DIR_NATIVE=\"`${CYGPATH} ${TK_SRC_DIR}/unix`\" - TK_WIN_DIR_NATIVE=\"`${CYGPATH} ${TK_SRC_DIR}/win`\" - TK_GENERIC_DIR_NATIVE=\"`${CYGPATH} ${TK_SRC_DIR}/generic`\" - TK_XLIB_DIR_NATIVE=\"`${CYGPATH} ${TK_SRC_DIR}/xlib`\" - TK_PLATFORM_DIR_NATIVE=${TK_WIN_DIR_NATIVE} - - TK_INCLUDES="-I${TK_GENERIC_DIR_NATIVE} -I${TK_PLATFORM_DIR_NATIVE} -I${TK_XLIB_DIR_NATIVE}" - ;; - *) - TK_TOP_DIR_NATIVE='$(TK_SRC_DIR)' - TK_GENERIC_DIR_NATIVE='$(TK_TOP_DIR_NATIVE)/generic' - TK_UNIX_DIR_NATIVE='$(TK_TOP_DIR_NATIVE)/unix' - TK_WIN_DIR_NATIVE='$(TK_TOP_DIR_NATIVE)/win' - TK_PLATFORM_DIR_NATIVE=${TK_UNIX_DIR_NATIVE} - - TK_INCLUDES="-I${TK_GENERIC_DIR_NATIVE} -I${TK_PLATFORM_DIR_NATIVE}" - ;; - esac - - AC_SUBST(TK_TOP_DIR_NATIVE) - AC_SUBST(TK_UNIX_DIR_NATIVE) - AC_SUBST(TK_WIN_DIR_NATIVE) - AC_SUBST(TK_GENERIC_DIR_NATIVE) - AC_SUBST(TK_XLIB_DIR_NATIVE) - AC_SUBST(TK_PLATFORM_DIR_NATIVE) - - AC_SUBST(TK_INCLUDES) - AC_MSG_RESULT(Using srcdir found in tkConfig.sh) -]) - -#------------------------------------------------------------------------ -# SC_PUBLIC_TK_HEADERS -- -# -# Locate the installed public Tk header files -# -# Arguments: -# None. -# -# Requires: -# CYGPATH must be set -# -# Results: -# -# Adds a --with-tkinclude switch to configure. -# Result is cached. -# -# Substs the following vars: -# TK_INCLUDES -#------------------------------------------------------------------------ - -AC_DEFUN(SC_PUBLIC_TK_HEADERS, [ - AC_MSG_CHECKING(for Tk public headers) - - AC_ARG_WITH(tkinclude, [ --with-tkinclude directory containing the public Tk header files.], with_tkinclude=${withval}) - - if test x"${with_tkinclude}" != x ; then - if test -f "${with_tkinclude}/tk.h" ; then - ac_cv_c_tkh=${with_tkinclude} - else - AC_MSG_ERROR([${with_tkinclude} directory does not contain Tk public header file tk.h]) - fi - else - AC_CACHE_VAL(ac_cv_c_tkh, [ - # Use the value from --with-tkinclude, if it was given - - if test x"${with_tkinclude}" != x ; then - ac_cv_c_tkh=${with_tkinclude} - else - # Check in the includedir, if --prefix was specified - - eval "temp_includedir=${includedir}" - for i in \ - `ls -d ${TCL_PREFIX}/include 2>/dev/null` \ - `ls -d ${temp_includedir} 2>/dev/null` \ - `ls -d ${TCL_BIN_DIR}/../include 2>/dev/null` \ - /usr/local/include /usr/include ; do - if test -f "$i/tk.h" ; then - ac_cv_c_tkh=$i - break - fi - done - fi - ]) - fi - - # Print a message based on how we determined the include path - - if test x"${ac_cv_c_tkh}" = x ; then - AC_MSG_ERROR(tk.h not found. Please specify its location with --with-tkinclude) - else - AC_MSG_RESULT(${ac_cv_c_tkh}) - fi - - # Convert to a native path and substitute into the output files. - - INCLUDE_DIR_NATIVE=`${CYGPATH} ${ac_cv_c_tkh}` - - TK_INCLUDES=-I\"${INCLUDE_DIR_NATIVE}\" - - AC_SUBST(TK_INCLUDES) -]) - -#------------------------------------------------------------------------ -# SC_SIMPLE_EXEEXT -# Select the executable extension based on the host type. This -# is a lightweight replacement for AC_EXEEXT that doesn't require -# a compiler. -# -# Arguments -# none -# -# Results -# Subst's the following values: -# EXEEXT -#------------------------------------------------------------------------ - -AC_DEFUN(SC_SIMPLE_EXEEXT, [ - AC_MSG_CHECKING(executable extension based on host type) - - case "`uname -s`" in - *win32* | *WIN32* | *CYGWIN_NT* |*CYGWIN_98*|*CYGWIN_95*) - EXEEXT=".exe" - ;; - *) - EXEEXT="" - ;; - esac - - AC_MSG_RESULT(${EXEEXT}) - AC_SUBST(EXEEXT) -]) - -#------------------------------------------------------------------------ -# SC_PROG_TCLSH -# Locate a tclsh shell in the following directories: -# ${exec_prefix}/bin -# ${prefix}/bin -# ${TCL_BIN_DIR} -# ${TCL_BIN_DIR}/../bin -# ${PATH} -# -# Arguments -# none -# -# Results -# Subst's the following values: -# TCLSH_PROG -#------------------------------------------------------------------------ - -AC_DEFUN(SC_PROG_TCLSH, [ - AC_MSG_CHECKING([for tclsh]) - - AC_CACHE_VAL(ac_cv_path_tclsh, [ - search_path=`echo ${exec_prefix}/bin:${prefix}/bin:${TCL_BIN_DIR}:${TCL_BIN_DIR}/../bin:${PATH} | sed -e 's/:/ /g'` - for dir in $search_path ; do - for j in `ls -r $dir/tclsh[[8-9]]*${EXEEXT} 2> /dev/null` \ - `ls -r $dir/tclsh*${EXEEXT} 2> /dev/null` ; do - if test x"$ac_cv_path_tclsh" = x ; then - if test -f "$j" ; then - ac_cv_path_tclsh=$j - break - fi - fi - done - done - ]) - - if test -f "$ac_cv_path_tclsh" ; then - TCLSH_PROG=$ac_cv_path_tclsh - AC_MSG_RESULT($TCLSH_PROG) - else - AC_MSG_ERROR(No tclsh found in PATH: $search_path) - fi - AC_SUBST(TCLSH_PROG) -]) - -#------------------------------------------------------------------------ -# SC_PROG_WISH -# Locate a wish shell in the following directories: -# ${exec_prefix}/bin -# ${prefix}/bin -# ${TCL_BIN_DIR} -# ${TCL_BIN_DIR}/../bin -# ${PATH} -# -# Arguments -# none -# -# Results -# Subst's the following values: -# WISH_PROG -#------------------------------------------------------------------------ - -AC_DEFUN(SC_PROG_WISH, [ - AC_MSG_CHECKING([for wish]) - - AC_CACHE_VAL(ac_cv_path_wish, [ - search_path=`echo ${exec_prefix}/bin:${prefix}/bin:${TCL_BIN_DIR}:${TCL_BIN_DIR}/../bin:${PATH} | sed -e 's/:/ /g'` - for dir in $search_path ; do - for j in `ls -r $dir/wish[[8-9]]*${EXEEXT} 2> /dev/null` \ - `ls -r $dir/wish*${EXEEXT} 2> /dev/null` ; do - if test x"$ac_cv_path_wish" = x ; then - if test -f "$j" ; then - ac_cv_path_wish=$j - break - fi - fi - done - done - ]) - - if test -f "$ac_cv_path_wish" ; then - WISH_PROG=$ac_cv_path_wish - AC_MSG_RESULT($WISH_PROG) - else - AC_MSG_ERROR(No wish found in PATH: $search_path) - fi - AC_SUBST(WISH_PROG) -]) - -#------------------------------------------------------------------------ -# SC_SET_PLATFORM -# Determine the common name of the platform we are using -# -# Arguments -# none -# -# Results -# Subst's the following values: -# PLATFORM -# CYGPATH -#------------------------------------------------------------------------ - -AC_DEFUN(SC_SET_PLATFORM, [ - AC_MSG_CHECKING(host platform) - - case "`uname -s`" in - *win32* | *WIN32* | *CYGWIN_NT* | *CYGWIN_98* | *CYGWIN_95*) - CYGPATH="cygpath -w" - PLATFORM=win32-ix86 - ;; - SunOS) - CYGPATH=echo - PLATFORM=solaris-sparc - ;; - Linux) - CYGPATH=echo - PLATFORM=linux-ix86 - ;; - FreeBSD) - CYGPATH=echo - PLATFORM=freebsd-ix86 - ;; - AIX) - CYGPATH=echo - PLATFORM=aix-risc - ;; - HP-UX) - CYGPATH=echo - PLATFORM=hpux-parisc - ;; - IRIX) - CYGPATH=echo - PLATFORM=irix-mips - ;; - *) - CYGPATH=echo - PLATFORM=UNSUPPORTED - ;; - esac - - if test x"${PLATFORM}" = x"UNSUPPORTED" ; then - AC_MSG_ERROR(Can't figure out what platform you are using) - else - AC_MSG_RESULT(${PLATFORM}) - fi - - AC_SUBST(PLATFORM) - AC_SUBST(CYGPATH) -]) - -#------------------------------------------------------------------------ -# SC_PATH_MODULE -# Add a --with-foodir flag for locating sources for an external module -# Search order: -# --with-foodir configure switch value -# cached configure value -# $2 argument -# ${srcdir}/modules/$1 -# ${srcdir}/../$1 -# ${srcdir}/../$1[0-9]* -# -# Arguments -# $1 Name of module to locate -# $2 Default directory where module can be found. If not specified, -# the macro looks in some well-known locations. This argument -# is mainly used for internal modules. -# -# Results -# sets MODULE_DIR_$1 to point to the top level directory of -# the module. -#------------------------------------------------------------------------ - -AC_DEFUN(SC_PATH_MODULE, [ - - if test x"${CYGPATH}" = x ; then - SC_SET_PLATFORM - fi - - modsrcdir=$1 - - AC_ARG_WITH($1dir, [ --with-$1dir directory containing sources for $1], with_module=${withval}, with_module="") - AC_MSG_CHECKING([for $1dir]) - - if test x"${with_module}" = x ; then - AC_CACHE_VAL(ac_cv_module_$1dir,[ - if test x"${with_module}" != x ; then - # Sanity check. Look for this module dir - if test -d "${with_module}" ; then - ac_cv_module_$1dir=`(cd ${with_module} ; pwd)` - fi - fi - - - # If not found, look in a few standard places for this module. - # Look in the default location (as specified by the argument(s) - # to this macro) first - - if test x"$2" != x ; then - for i in \ - `ls -dr $2 2>/dev/null` \ - `ls -dr ${srcdir}/$2 2>/dev/null` \ - `ls -dr ${srcdir}/../$2 2>/dev/null` \ - `ls -dr ${srcdir}/../$2[[0-9]]* 2>/dev/null` ; do - if test -d $i ; then - ac_cv_module_$1dir=`(cd $i; pwd)` - break - fi - done - fi - - # Make sure not to require a specific version number. - - if test x"${ac_cv_module_$1dir}" = x ; then - for i in \ - `ls -dr ${srcdir}/modules/$modsrcdir 2>/dev/null` \ - `ls -dr ${srcdir}/../$modsrcdir 2>/dev/null` \ - `ls -dr ${srcdir}/../$modsrcdir[[0-9]]* 2>/dev/null` ; do - if test -d $i ; then - ac_cv_module_$1dir=`(cd $i; pwd)` - break - fi - done - fi - - - ]) - else - if test -d "${with_module}" ; then - ac_cv_module_$1dir=`(cd ${with_module} ; pwd)` - else - AC_MSG_ERROR("Directory ${with_module} does not exist!") - fi - fi - - if test x"${ac_cv_module_$1dir}" = x ; then - AC_MSG_WARN(MISSING. Use --with-$1dir to specify location of $1 or make sure you have checked out the sources from cvs.) - MISSING_MODULE_LIST="${MISSING_MODULE_LIST} $1" - MODULE_LIST="${MODULE_LIST} $1" - else - # Strip off any trailing \ from the path - MODULE_DIR_$1=`${CYGPATH} ${ac_cv_module_$1dir} | sed -e 's%\\\\$%%'` - AC_MSG_RESULT(${MODULE_DIR_$1}) - AC_SUBST(MODULE_DIR_$1) - if test x"$1" != x"${PACKAGE}" ; then - MODULE_LIST="${MODULE_LIST} $1" - fi - fi -]) - -#------------------------------------------------------------------------ -# SC_PATH_TOOLS -# Add a --with-toolsdir flag for locating sources for an external module -# -# Arguments -# none -# -# Results -# sets MODULE_DIR_tools to point to the top level directory of -# the module. -#------------------------------------------------------------------------ - -AC_DEFUN(SC_PATH_TOOLS, [ - AC_ARG_WITH(toolsdir, [ --with-toolsdir directory containing sources for tools], with_module=${withval}, with_module="") - AC_MSG_CHECKING([for toolsdir]) - - if test x"${with_module}" = x ; then - AC_CACHE_VAL(ac_cv_module_toolsdir,[ - if test x"${with_module}" != x ; then - # Sanity check. Look for configure.in in this module dir - if test -d "${with_module}" ; then - ac_cv_module_toolsdir=`(cd ${with_module} ; pwd)` - fi - fi - - - - # If not found, look in a few standard places for this module. - # Make sure not to require a specific version number. - - if test x"${ac_cv_module_toolsdir}" = x ; then - for i in \ - `ls -dr /tools/1.[[1-5]] 2>/dev/null` \ - `ls -dr /tools/TclPro1.[[1-5]] 2>/dev/null` \ - `ls -dr //t/tools/1.[[1-5]] 2>/dev/null` \ - `ls -dr //t/tools/TclPro1.[[1-5]] 2>/dev/null` \ - `ls -dr //pop/tools/1.[[1-5]] 2>/dev/null` \ - `ls -dr //pop/tools/TclPro1.[[1-5]] 2>/dev/null` ; do - if test -d $i ; then - ac_cv_module_toolsdir=`(cd $i; pwd)` - break - fi - done - fi - - - ]) - else - if test -d "${with_module}" ; then - ac_cv_module_toolsdir=`(cd ${with_module} ; pwd)` - else - AC_MSG_WARN(Directory ${with_module} does not exist!) - fi - fi - - if test x"${ac_cv_module_toolsdir}" = x ; then - AC_MSG_WARN(No tools directory - pressing forward with bogus value.) - MODULE_DIR_tools=no_tools_dir - AC_SUBST(MODULE_DIR_tools) -# AC_MSG_ERROR("Use --with-toolsdir to specify location of tools") -# exit 1 - else - MODULE_DIR_tools=${ac_cv_module_toolsdir} - AC_MSG_RESULT(${ac_cv_module_toolsdir}) - AC_SUBST(MODULE_DIR_tools) - fi -]) - -#------------------------------------------------------------------------ -# SC_PATH_PROTOOLS -# Path to a valid Tclpro installation. You must call SC_ SET_PLATFORM -# before calling this macro. -# -# Arguments -# none -# -# Results -# Subst's the following values: -# PROTOOLSDIR -#------------------------------------------------------------------------ - -AC_DEFUN(SC_PATH_PROTOOLS, [ - if test x"${PLATFORM}" = x ; then - SC_SET_PLATFORM - fi - - AC_ARG_WITH(protools, [ --with-protools directory containing the Tclpro installation], protools_dir=${withval}) - - AC_MSG_CHECKING(for protclsh in a TclPro installation) - - if test x"${protools_dir}" != x ; then - # Look for protclsh - - for i in `ls -r ${protools_dir}/${PLATFORM}/bin/protclsh* 2>/dev/null` ; do - if test -f $i ; then - PROTCLSH=$i - break - fi - done - else - for i in `ls -dr /tools/TclPro1.[[3-4]] 2>/dev/null` \ - `ls -dr //t/tools/TclPro1.[[3-4]] 2>/dev/null ` ; do - - # Look for protclsh - - for j in `ls $i/${PLATFORM}/bin/protclsh* 2>/dev/null` ; do - if test -f $j ; then - PROTCLSH=$j - break - fi - done - - if test x"${PROTCLSH}" != x ; then - protools_dir=$i - break - fi - done - fi - - if test x"${PROTCLSH}" = x ; then - AC_MSG_WARN(Could not locate a TclPro installation containing protclsh. Use --with-protoolsdir to specify a valid TclPro installation.) - protools_dir=BOGUS_protools_dir - else - AC_MSG_RESULT("found ${PROTCLSH}") - fi - - PROTOOLSDIR=${protools_dir} - AC_SUBST(PROTOOLSDIR) -]) DELETED configure Index: configure ================================================================== --- configure +++ /dev/null @@ -1,854 +0,0 @@ -#! /bin/sh - -# Guess values for system-dependent variables and create Makefiles. -# Generated automatically using autoconf version 2.13 -# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc. -# -# This configure script is free software; the Free Software Foundation -# gives unlimited permission to copy, distribute and modify it. - -# Defaults: -ac_help= -ac_default_prefix=/usr/local -# Any additions from configure.in: - -# Initialize some variables set by options. -# The variables have the same names as the options, with -# dashes changed to underlines. -build=NONE -cache_file=./config.cache -exec_prefix=NONE -host=NONE -no_create= -nonopt=NONE -no_recursion= -prefix=NONE -program_prefix=NONE -program_suffix=NONE -program_transform_name=s,x,x, -silent= -site= -srcdir= -target=NONE -verbose= -x_includes=NONE -x_libraries=NONE -bindir='${exec_prefix}/bin' -sbindir='${exec_prefix}/sbin' -libexecdir='${exec_prefix}/libexec' -datadir='${prefix}/share' -sysconfdir='${prefix}/etc' -sharedstatedir='${prefix}/com' -localstatedir='${prefix}/var' -libdir='${exec_prefix}/lib' -includedir='${prefix}/include' -oldincludedir='/usr/include' -infodir='${prefix}/info' -mandir='${prefix}/man' - -# Initialize some other variables. -subdirs= -MFLAGS= MAKEFLAGS= -SHELL=${CONFIG_SHELL-/bin/sh} -# Maximum number of lines to put in a shell here document. -ac_max_here_lines=12 - -ac_prev= -for ac_option -do - - # If the previous option needs an argument, assign it. - if test -n "$ac_prev"; then - eval "$ac_prev=\$ac_option" - ac_prev= - continue - fi - - case "$ac_option" in - -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;; - *) ac_optarg= ;; - esac - - # Accept the important Cygnus configure options, so we can diagnose typos. - - case "$ac_option" in - - -bindir | --bindir | --bindi | --bind | --bin | --bi) - ac_prev=bindir ;; - -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) - bindir="$ac_optarg" ;; - - -build | --build | --buil | --bui | --bu) - ac_prev=build ;; - -build=* | --build=* | --buil=* | --bui=* | --bu=*) - build="$ac_optarg" ;; - - -cache-file | --cache-file | --cache-fil | --cache-fi \ - | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) - ac_prev=cache_file ;; - -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ - | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) - cache_file="$ac_optarg" ;; - - -datadir | --datadir | --datadi | --datad | --data | --dat | --da) - ac_prev=datadir ;; - -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ - | --da=*) - datadir="$ac_optarg" ;; - - -disable-* | --disable-*) - ac_feature=`echo $ac_option|sed -e 's/-*disable-//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then - { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } - fi - ac_feature=`echo $ac_feature| sed 's/-/_/g'` - eval "enable_${ac_feature}=no" ;; - - -enable-* | --enable-*) - ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then - { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } - fi - ac_feature=`echo $ac_feature| sed 's/-/_/g'` - case "$ac_option" in - *=*) ;; - *) ac_optarg=yes ;; - esac - eval "enable_${ac_feature}='$ac_optarg'" ;; - - -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ - | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ - | --exec | --exe | --ex) - ac_prev=exec_prefix ;; - -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ - | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ - | --exec=* | --exe=* | --ex=*) - exec_prefix="$ac_optarg" ;; - - -gas | --gas | --ga | --g) - # Obsolete; use --with-gas. - with_gas=yes ;; - - -help | --help | --hel | --he) - # Omit some internal or obsolete options to make the list less imposing. - # This message is too long to be a string in the A/UX 3.1 sh. - cat << EOF -Usage: configure [options] [host] -Options: [defaults in brackets after descriptions] -Configuration: - --cache-file=FILE cache test results in FILE - --help print this message - --no-create do not create output files - --quiet, --silent do not print \`checking...' messages - --version print the version of autoconf that created configure -Directory and file names: - --prefix=PREFIX install architecture-independent files in PREFIX - [$ac_default_prefix] - --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX - [same as prefix] - --bindir=DIR user executables in DIR [EPREFIX/bin] - --sbindir=DIR system admin executables in DIR [EPREFIX/sbin] - --libexecdir=DIR program executables in DIR [EPREFIX/libexec] - --datadir=DIR read-only architecture-independent data in DIR - [PREFIX/share] - --sysconfdir=DIR read-only single-machine data in DIR [PREFIX/etc] - --sharedstatedir=DIR modifiable architecture-independent data in DIR - [PREFIX/com] - --localstatedir=DIR modifiable single-machine data in DIR [PREFIX/var] - --libdir=DIR object code libraries in DIR [EPREFIX/lib] - --includedir=DIR C header files in DIR [PREFIX/include] - --oldincludedir=DIR C header files for non-gcc in DIR [/usr/include] - --infodir=DIR info documentation in DIR [PREFIX/info] - --mandir=DIR man documentation in DIR [PREFIX/man] - --srcdir=DIR find the sources in DIR [configure dir or ..] - --program-prefix=PREFIX prepend PREFIX to installed program names - --program-suffix=SUFFIX append SUFFIX to installed program names - --program-transform-name=PROGRAM - run sed PROGRAM on installed program names -EOF - cat << EOF -Host type: - --build=BUILD configure for building on BUILD [BUILD=HOST] - --host=HOST configure for HOST [guessed] - --target=TARGET configure for TARGET [TARGET=HOST] -Features and packages: - --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) - --enable-FEATURE[=ARG] include FEATURE [ARG=yes] - --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] - --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) - --x-includes=DIR X include files are in DIR - --x-libraries=DIR X library files are in DIR -EOF - if test -n "$ac_help"; then - echo "--enable and --with options recognized:$ac_help" - fi - exit 0 ;; - - -host | --host | --hos | --ho) - ac_prev=host ;; - -host=* | --host=* | --hos=* | --ho=*) - host="$ac_optarg" ;; - - -includedir | --includedir | --includedi | --included | --include \ - | --includ | --inclu | --incl | --inc) - ac_prev=includedir ;; - -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ - | --includ=* | --inclu=* | --incl=* | --inc=*) - includedir="$ac_optarg" ;; - - -infodir | --infodir | --infodi | --infod | --info | --inf) - ac_prev=infodir ;; - -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) - infodir="$ac_optarg" ;; - - -libdir | --libdir | --libdi | --libd) - ac_prev=libdir ;; - -libdir=* | --libdir=* | --libdi=* | --libd=*) - libdir="$ac_optarg" ;; - - -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ - | --libexe | --libex | --libe) - ac_prev=libexecdir ;; - -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ - | --libexe=* | --libex=* | --libe=*) - libexecdir="$ac_optarg" ;; - - -localstatedir | --localstatedir | --localstatedi | --localstated \ - | --localstate | --localstat | --localsta | --localst \ - | --locals | --local | --loca | --loc | --lo) - ac_prev=localstatedir ;; - -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ - | --localstate=* | --localstat=* | --localsta=* | --localst=* \ - | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) - localstatedir="$ac_optarg" ;; - - -mandir | --mandir | --mandi | --mand | --man | --ma | --m) - ac_prev=mandir ;; - -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) - mandir="$ac_optarg" ;; - - -nfp | --nfp | --nf) - # Obsolete; use --without-fp. - with_fp=no ;; - - -no-create | --no-create | --no-creat | --no-crea | --no-cre \ - | --no-cr | --no-c) - no_create=yes ;; - - -no-recursion | --no-recursion | --no-recursio | --no-recursi \ - | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) - no_recursion=yes ;; - - -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ - | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ - | --oldin | --oldi | --old | --ol | --o) - ac_prev=oldincludedir ;; - -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ - | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ - | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) - oldincludedir="$ac_optarg" ;; - - -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) - ac_prev=prefix ;; - -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) - prefix="$ac_optarg" ;; - - -program-prefix | --program-prefix | --program-prefi | --program-pref \ - | --program-pre | --program-pr | --program-p) - ac_prev=program_prefix ;; - -program-prefix=* | --program-prefix=* | --program-prefi=* \ - | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) - program_prefix="$ac_optarg" ;; - - -program-suffix | --program-suffix | --program-suffi | --program-suff \ - | --program-suf | --program-su | --program-s) - ac_prev=program_suffix ;; - -program-suffix=* | --program-suffix=* | --program-suffi=* \ - | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) - program_suffix="$ac_optarg" ;; - - -program-transform-name | --program-transform-name \ - | --program-transform-nam | --program-transform-na \ - | --program-transform-n | --program-transform- \ - | --program-transform | --program-transfor \ - | --program-transfo | --program-transf \ - | --program-trans | --program-tran \ - | --progr-tra | --program-tr | --program-t) - ac_prev=program_transform_name ;; - -program-transform-name=* | --program-transform-name=* \ - | --program-transform-nam=* | --program-transform-na=* \ - | --program-transform-n=* | --program-transform-=* \ - | --program-transform=* | --program-transfor=* \ - | --program-transfo=* | --program-transf=* \ - | --program-trans=* | --program-tran=* \ - | --progr-tra=* | --program-tr=* | --program-t=*) - program_transform_name="$ac_optarg" ;; - - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil) - silent=yes ;; - - -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) - ac_prev=sbindir ;; - -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ - | --sbi=* | --sb=*) - sbindir="$ac_optarg" ;; - - -sharedstatedir | --sharedstatedir | --sharedstatedi \ - | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ - | --sharedst | --shareds | --shared | --share | --shar \ - | --sha | --sh) - ac_prev=sharedstatedir ;; - -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ - | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ - | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ - | --sha=* | --sh=*) - sharedstatedir="$ac_optarg" ;; - - -site | --site | --sit) - ac_prev=site ;; - -site=* | --site=* | --sit=*) - site="$ac_optarg" ;; - - -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) - ac_prev=srcdir ;; - -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) - srcdir="$ac_optarg" ;; - - -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ - | --syscon | --sysco | --sysc | --sys | --sy) - ac_prev=sysconfdir ;; - -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ - | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) - sysconfdir="$ac_optarg" ;; - - -target | --target | --targe | --targ | --tar | --ta | --t) - ac_prev=target ;; - -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) - target="$ac_optarg" ;; - - -v | -verbose | --verbose | --verbos | --verbo | --verb) - verbose=yes ;; - - -version | --version | --versio | --versi | --vers) - echo "configure generated by autoconf version 2.13" - exit 0 ;; - - -with-* | --with-*) - ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then - { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } - fi - ac_package=`echo $ac_package| sed 's/-/_/g'` - case "$ac_option" in - *=*) ;; - *) ac_optarg=yes ;; - esac - eval "with_${ac_package}='$ac_optarg'" ;; - - -without-* | --without-*) - ac_package=`echo $ac_option|sed -e 's/-*without-//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then - { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } - fi - ac_package=`echo $ac_package| sed 's/-/_/g'` - eval "with_${ac_package}=no" ;; - - --x) - # Obsolete; use --with-x. - with_x=yes ;; - - -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ - | --x-incl | --x-inc | --x-in | --x-i) - ac_prev=x_includes ;; - -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ - | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) - x_includes="$ac_optarg" ;; - - -x-libraries | --x-libraries | --x-librarie | --x-librari \ - | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) - ac_prev=x_libraries ;; - -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ - | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) - x_libraries="$ac_optarg" ;; - - -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; } - ;; - - *) - if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then - echo "configure: warning: $ac_option: invalid host type" 1>&2 - fi - if test "x$nonopt" != xNONE; then - { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; } - fi - nonopt="$ac_option" - ;; - - esac -done - -if test -n "$ac_prev"; then - { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; } -fi - -trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 - -# File descriptor usage: -# 0 standard input -# 1 file creation -# 2 errors and warnings -# 3 some systems may open it to /dev/tty -# 4 used on the Kubota Titan -# 6 checking for... messages and results -# 5 compiler messages saved in config.log -if test "$silent" = yes; then - exec 6>/dev/null -else - exec 6>&1 -fi -exec 5>./config.log - -echo "\ -This file contains any messages produced by compilers while -running configure, to aid debugging if configure makes a mistake. -" 1>&5 - -# Strip out --no-create and --no-recursion so they do not pile up. -# Also quote any args containing shell metacharacters. -ac_configure_args= -for ac_arg -do - case "$ac_arg" in - -no-create | --no-create | --no-creat | --no-crea | --no-cre \ - | --no-cr | --no-c) ;; - -no-recursion | --no-recursion | --no-recursio | --no-recursi \ - | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;; - *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*) - ac_configure_args="$ac_configure_args '$ac_arg'" ;; - *) ac_configure_args="$ac_configure_args $ac_arg" ;; - esac -done - -# NLS nuisances. -# Only set these to C if already set. These must not be set unconditionally -# because not all systems understand e.g. LANG=C (notably SCO). -# Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'! -# Non-C LC_CTYPE values break the ctype check. -if test "${LANG+set}" = set; then LANG=C; export LANG; fi -if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi -if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi -if test "${LC_CTYPE+set}" = set; then LC_CTYPE=C; export LC_CTYPE; fi - -# confdefs.h avoids OS command line length limits that DEFS can exceed. -rm -rf conftest* confdefs.h -# AIX cpp loses on an empty file, so make sure it contains at least a newline. -echo > confdefs.h - -# A filename unique to this package, relative to the directory that -# configure is in, which we can look for to find out if srcdir is correct. -ac_unique_file=ChangeLog - -# Find the source files, if location was not specified. -if test -z "$srcdir"; then - ac_srcdir_defaulted=yes - # Try the directory containing this script, then its parent. - ac_prog=$0 - ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'` - test "x$ac_confdir" = "x$ac_prog" && ac_confdir=. - srcdir=$ac_confdir - if test ! -r $srcdir/$ac_unique_file; then - srcdir=.. - fi -else - ac_srcdir_defaulted=no -fi -if test ! -r $srcdir/$ac_unique_file; then - if test "$ac_srcdir_defaulted" = yes; then - { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; } - else - { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; } - fi -fi -srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'` - -# Prefer explicitly selected file to automatically selected ones. -if test -z "$CONFIG_SITE"; then - if test "x$prefix" != xNONE; then - CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" - else - CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" - fi -fi -for ac_site_file in $CONFIG_SITE; do - if test -r "$ac_site_file"; then - echo "loading site script $ac_site_file" - . "$ac_site_file" - fi -done - -if test -r "$cache_file"; then - echo "loading cache $cache_file" - . $cache_file -else - echo "creating cache $cache_file" - > $cache_file -fi - -ac_ext=c -# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. -ac_cpp='$CPP $CPPFLAGS' -ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' -ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' -cross_compiling=$ac_cv_prog_cc_cross - -ac_exeext= -ac_objext=o -if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then - # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu. - if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then - ac_n= ac_c=' -' ac_t=' ' - else - ac_n=-n ac_c= ac_t= - fi -else - ac_n= ac_c='\c' ac_t= -fi - - - -case "`uname -s`" in - *win32* | *WIN32* | *CYGWIN_NT* | *CYGWIN_98* | *CYGWIN_95*) - CYGPATH="cygpath -w" - ;; - *) - CYGPATH=echo - ;; -esac - - - - echo $ac_n "checking executable extension based on host type""... $ac_c" 1>&6 -echo "configure:538: checking executable extension based on host type" >&5 - - case "`uname -s`" in - *win32* | *WIN32* | *CYGWIN_NT* |*CYGWIN_98*|*CYGWIN_95*) - EXEEXT=".exe" - ;; - *) - EXEEXT="" - ;; - esac - - echo "$ac_t""${EXEEXT}" 1>&6 - - - - echo $ac_n "checking for tclsh""... $ac_c" 1>&6 -echo "configure:554: checking for tclsh" >&5 - - if eval "test \"`echo '$''{'ac_cv_path_tclsh'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - - search_path=`echo ${exec_prefix}/bin:${prefix}/bin:${TCL_BIN_DIR}:${TCL_BIN_DIR}/../bin:${PATH} | sed -e 's/:/ /g'` - for dir in $search_path ; do - for j in `ls -r $dir/tclsh[8-9]*${EXEEXT} 2> /dev/null` \ - `ls -r $dir/tclsh*${EXEEXT} 2> /dev/null` ; do - if test x"$ac_cv_path_tclsh" = x ; then - if test -f "$j" ; then - ac_cv_path_tclsh=$j - break - fi - fi - done - done - -fi - - - if test -f "$ac_cv_path_tclsh" ; then - TCLSH_PROG=$ac_cv_path_tclsh - echo "$ac_t""$TCLSH_PROG" 1>&6 - else - { echo "configure: error: No tclsh found in PATH: $search_path" 1>&2; exit 1; } - fi - - - -# ### ######### ########################### - -PACKAGE=`$TCLSH_PROG ${srcdir}/sak.tcl name` -MAJOR_VERSION=`$TCLSH_PROG ${srcdir}/sak.tcl major` -MINOR_VERSION=`$TCLSH_PROG ${srcdir}/sak.tcl minor` -PATCHLEVEL="" - -VERSION=${MAJOR_VERSION}.${MINOR_VERSION}${PATCHLEVEL} -NODOT_VERSION=${MAJOR_VERSION}${MINOR_VERSION} - - - - -# ### ######### ########################### - -trap '' 1 2 15 -cat > confcache <<\EOF -# This file is a shell script that caches the results of configure -# tests run on this system so they can be shared between configure -# scripts and configure runs. It is not useful on other systems. -# If it contains results you don't want to keep, you may remove or edit it. -# -# By default, configure uses ./config.cache as the cache file, -# creating it if it does not exist already. You can give configure -# the --cache-file=FILE option to use a different cache file; that is -# what configure does when it calls configure scripts in -# subdirectories, so they share the cache. -# Giving --cache-file=/dev/null disables caching, for debugging configure. -# config.status only pays attention to the cache file if you give it the -# --recheck option to rerun configure. -# -EOF -# The following way of writing the cache mishandles newlines in values, -# but we know of no workaround that is simple, portable, and efficient. -# So, don't put newlines in cache variables' values. -# Ultrix sh set writes to stderr and can't be redirected directly, -# and sets the high bit in the cache file unless we assign to the vars. -(set) 2>&1 | - case `(ac_space=' '; set | grep ac_space) 2>&1` in - *ac_space=\ *) - # `set' does not quote correctly, so add quotes (double-quote substitution - # turns \\\\ into \\, and sed turns \\ into \). - sed -n \ - -e "s/'/'\\\\''/g" \ - -e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p" - ;; - *) - # `set' quotes correctly as required by POSIX, so do not add quotes. - sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p' - ;; - esac >> confcache -if cmp -s $cache_file confcache; then - : -else - if test -w $cache_file; then - echo "updating cache $cache_file" - cat confcache > $cache_file - else - echo "not updating unwritable cache $cache_file" - fi -fi -rm -f confcache - -trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 - -test "x$prefix" = xNONE && prefix=$ac_default_prefix -# Let make expand exec_prefix. -test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' - -# Any assignment to VPATH causes Sun make to only execute -# the first set of double-colon rules, so remove it if not needed. -# If there is a colon in the path, we need to keep it. -if test "x$srcdir" = x.; then - ac_vpsub='/^[ ]*VPATH[ ]*=[^:]*$/d' -fi - -trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15 - -# Transform confdefs.h into DEFS. -# Protect against shell expansion while executing Makefile rules. -# Protect against Makefile macro expansion. -cat > conftest.defs <<\EOF -s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%-D\1=\2%g -s%[ `~#$^&*(){}\\|;'"<>?]%\\&%g -s%\[%\\&%g -s%\]%\\&%g -s%\$%$$%g -EOF -DEFS=`sed -f conftest.defs confdefs.h | tr '\012' ' '` -rm -f conftest.defs - - -# Without the "./", some shells look in PATH for config.status. -: ${CONFIG_STATUS=./config.status} - -echo creating $CONFIG_STATUS -rm -f $CONFIG_STATUS -cat > $CONFIG_STATUS </dev/null | sed 1q`: -# -# $0 $ac_configure_args -# -# Compiler output produced by configure, useful for debugging -# configure, is in ./config.log if it exists. - -ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]" -for ac_option -do - case "\$ac_option" in - -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) - echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion" - exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;; - -version | --version | --versio | --versi | --vers | --ver | --ve | --v) - echo "$CONFIG_STATUS generated by autoconf version 2.13" - exit 0 ;; - -help | --help | --hel | --he | --h) - echo "\$ac_cs_usage"; exit 0 ;; - *) echo "\$ac_cs_usage"; exit 1 ;; - esac -done - -ac_given_srcdir=$srcdir - -trap 'rm -fr `echo "Makefile" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 -EOF -cat >> $CONFIG_STATUS < conftest.subs <<\\CEOF -$ac_vpsub -$extrasub -s%@SHELL@%$SHELL%g -s%@CFLAGS@%$CFLAGS%g -s%@CPPFLAGS@%$CPPFLAGS%g -s%@CXXFLAGS@%$CXXFLAGS%g -s%@FFLAGS@%$FFLAGS%g -s%@DEFS@%$DEFS%g -s%@LDFLAGS@%$LDFLAGS%g -s%@LIBS@%$LIBS%g -s%@exec_prefix@%$exec_prefix%g -s%@prefix@%$prefix%g -s%@program_transform_name@%$program_transform_name%g -s%@bindir@%$bindir%g -s%@sbindir@%$sbindir%g -s%@libexecdir@%$libexecdir%g -s%@datadir@%$datadir%g -s%@sysconfdir@%$sysconfdir%g -s%@sharedstatedir@%$sharedstatedir%g -s%@localstatedir@%$localstatedir%g -s%@libdir@%$libdir%g -s%@includedir@%$includedir%g -s%@oldincludedir@%$oldincludedir%g -s%@infodir@%$infodir%g -s%@mandir@%$mandir%g -s%@CYGPATH@%$CYGPATH%g -s%@EXEEXT@%$EXEEXT%g -s%@TCLSH_PROG@%$TCLSH_PROG%g -s%@PACKAGE@%$PACKAGE%g -s%@VERSION@%$VERSION%g - -CEOF -EOF - -cat >> $CONFIG_STATUS <<\EOF - -# Split the substitutions into bite-sized pieces for seds with -# small command number limits, like on Digital OSF/1 and HP-UX. -ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script. -ac_file=1 # Number of current file. -ac_beg=1 # First line for current file. -ac_end=$ac_max_sed_cmds # Line after last line for current file. -ac_more_lines=: -ac_sed_cmds="" -while $ac_more_lines; do - if test $ac_beg -gt 1; then - sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file - else - sed "${ac_end}q" conftest.subs > conftest.s$ac_file - fi - if test ! -s conftest.s$ac_file; then - ac_more_lines=false - rm -f conftest.s$ac_file - else - if test -z "$ac_sed_cmds"; then - ac_sed_cmds="sed -f conftest.s$ac_file" - else - ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file" - fi - ac_file=`expr $ac_file + 1` - ac_beg=$ac_end - ac_end=`expr $ac_end + $ac_max_sed_cmds` - fi -done -if test -z "$ac_sed_cmds"; then - ac_sed_cmds=cat -fi -EOF - -cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF -for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then - # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". - case "$ac_file" in - *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'` - ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;; - *) ac_file_in="${ac_file}.in" ;; - esac - - # Adjust a relative srcdir, top_srcdir, and INSTALL for subdirectories. - - # Remove last slash and all that follows it. Not all systems have dirname. - ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'` - if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then - # The file is in a subdirectory. - test ! -d "$ac_dir" && mkdir "$ac_dir" - ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`" - # A "../" for each directory in $ac_dir_suffix. - ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'` - else - ac_dir_suffix= ac_dots= - fi - - case "$ac_given_srcdir" in - .) srcdir=. - if test -z "$ac_dots"; then top_srcdir=. - else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;; - /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;; - *) # Relative path. - srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix" - top_srcdir="$ac_dots$ac_given_srcdir" ;; - esac - - - echo creating "$ac_file" - rm -f "$ac_file" - configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure." - case "$ac_file" in - *Makefile*) ac_comsub="1i\\ -# $configure_input" ;; - *) ac_comsub= ;; - esac - - ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"` - sed -e "$ac_comsub -s%@configure_input@%$configure_input%g -s%@srcdir@%$srcdir%g -s%@top_srcdir@%$top_srcdir%g -" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file -fi; done -rm -f conftest.s* - -EOF -cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF - -exit 0 -EOF -chmod +x $CONFIG_STATUS -rm -fr confdefs* $ac_clean_files -test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1 - DELETED configure.in Index: configure.in ================================================================== --- configure.in +++ /dev/null @@ -1,31 +0,0 @@ -AC_INIT(ChangeLog) - -case "`uname -s`" in - *win32* | *WIN32* | *CYGWIN_NT* | *CYGWIN_98* | *CYGWIN_95*) - CYGPATH="cygpath -w" - ;; - *) - CYGPATH=echo - ;; -esac -AC_SUBST(CYGPATH) - -SC_SIMPLE_EXEEXT -SC_PROG_TCLSH - -# ### ######### ########################### - -PACKAGE=`$TCLSH_PROG ${srcdir}/sak.tcl name` -MAJOR_VERSION=`$TCLSH_PROG ${srcdir}/sak.tcl major` -MINOR_VERSION=`$TCLSH_PROG ${srcdir}/sak.tcl minor` -PATCHLEVEL="" - -VERSION=${MAJOR_VERSION}.${MINOR_VERSION}${PATCHLEVEL} -NODOT_VERSION=${MAJOR_VERSION}${MINOR_VERSION} - -AC_SUBST(PACKAGE) -AC_SUBST(VERSION) - -# ### ######### ########################### - -AC_OUTPUT([Makefile]) DELETED devdoc/cvs.branches.fig Index: devdoc/cvs.branches.fig ================================================================== --- devdoc/cvs.branches.fig +++ /dev/null @@ -1,32 +0,0 @@ -#FIG 3.2 -Landscape -Center -Inches -Letter -100.00 -Single --2 -1200 2 -6 3000 2025 5400 2400 -4 0 12 50 0 0 14 0.0000 4 150 2385 3000 2175 Point releases are branched\001 -4 0 12 50 0 0 14 0.0000 4 150 1530 3000 2370 from RELEASES\001 --6 -6 2400 750 5700 1200 -4 0 1 50 0 0 14 0.0000 4 195 3225 2400 900 Developer performs internal releases,\001 -4 0 1 50 0 0 14 0.0000 4 195 3285 2400 1095 merging from HEAD into RELEASES\001 --6 -2 1 0 4 0 7 50 0 -1 0.000 0 0 7 1 0 2 - 2 1 4.00 240.00 480.00 - 300 600 5700 600 -2 1 0 2 1 7 50 0 -1 0.000 0 0 -1 1 0 2 - 2 1 2.00 120.00 240.00 - 2100 600 2400 1800 -2 1 0 5 12 7 50 0 -1 0.000 0 0 -1 1 0 3 - 2 1 5.00 300.00 600.00 - 2700 1800 3000 3000 5700 3000 -2 1 0 4 17 7 50 0 -1 0.000 0 0 7 1 0 3 - 2 1 4.00 240.00 480.00 - 1200 600 1500 1800 5700 1800 -4 0 0 50 0 0 14 0.0000 4 195 2835 3150 1575 Staging for release : RELEASES\001 -4 0 0 50 0 0 14 0.0000 4 195 1905 3900 300 Development : HEAD\001 -4 0 0 50 0 0 14 0.0000 4 150 930 4800 2700 Tcllib 1.2.0\001 DELETED devdoc/devguide.html Index: devdoc/devguide.html ================================================================== --- devdoc/devguide.html +++ /dev/null @@ -1,50 +0,0 @@ - - -

Guide for Tcllib developers. -

-
- -

CVS Repository -

-
- - -

- -The CVS repository for Tcllib contains two main branches, the HEAD for -development, and RELEASES as the staging area for official -releases. At RELEASES the minor branches containing the various -official releases are anchored at. -

- -

All the branches are of interest to the developers for - Tcllib. Ongoing development happens in HEAD, which can be - unstable or may not work at all. Whenever a developer considers - a piece of code, or module, he is responsible for as - sufficiently stable she has to perform an internal release which - merges this part from HEAD into RELEASES. Tools to help with - this will be provided. -

- -

The branches for the official releases of tcllib are of interest to - a developer because it is expected that fixes for important bugs - not only go into the HEAD branch but also into the release - branches for the release they were found in and all releases - following that one. This is to allow the release manager to - create patch releases of existing releases distribung important - bugfixes as well. -

- -

Version numbers for modules are handled as described below. This - way of handling them was chosen so that the modules in the - development branch always uses version numbers different from - the version numbers in the official releases made so far. -

-
    -
  • Whenever an internal release of a module FOO is done, the - developer performing this internal release has to increment - the version number of the module after the release was - executed. -
DELETED devdoc/dirlayout_install.txt Index: devdoc/dirlayout_install.txt ================================================================== --- devdoc/dirlayout_install.txt +++ /dev/null @@ -1,85 +0,0 @@ -Tcllib installation directory layout -==================================== - -This document describes the possible layouts for an installed tcllib, -discusses their pro and contra and makes a choice for Tcllib 1.4. A -roadmap of changes in the future is made available as appendix. - -[L1/D] Deep layout ------------------- - - This is the layout of Tcllib 1.3 (and versions before that). - - A single directory tcllib is created, and all - subdirectories of the 'modules' subdirectory in the - distribution is copied into it. This is restricted at large to - *.tcl files, with exception made for some modules with special - needs. - - Pro: - Contra: - Makes the handling of the various package indices, - well, not difficult, but uncomfortable. - - -[L2/Fa] Flat layout 1 ---------------------- - - A directory is created for each module of tcllib. - - Pro: - Handling of package indices is easier than for L1/D, a - toplevel index file with all its problems is not - required anymore. - - Contra: - Directories should be versioned to avoid conflicts - between multiple releases. modules have no - version. This can be faked for mdules containing one - package, but not for the modules with more. - - -[L2/Fb] Flat layout 2 ---------------------- - - A directory is created for each package in tcllib. - - Pro - Handling of package indices is easy, one per package. - - Contra: - Modules containing more than one package are difficult - to handle. The system has to split them into the - individual packages. This rendered very difficult - because of shared package index files. - - This can be solved by moving tcllib (back) towards of - one package per module. When that goal is reached - L2/Fa and L2/Fb become the same, and the contra for - L2/Fa vanishes too as an exact version number can be - associated with each directory. - -Chosen layout for Tcllib 1.4 ----------------------------- - - L1/D - - Despite the problems with package indices the contras against - the flat structures are too strong at this point in - time. Automatic solutions are not really possible, or require - a very high effort. - -Roadmap -------- - Change the module directories of tcllib to contain exactly one - package per directory, with appropriate index (and meta data). - - This not only makes sense for easier handling of installation - and package indices, but also in the geater context of - wrapping code for deployment. - - ------------------------------------ -This document is in the public domain. - - Andreas Kupries DELETED devdoc/indexing.txt Index: devdoc/indexing.txt ================================================================== --- devdoc/indexing.txt +++ /dev/null @@ -1,418 +0,0 @@ -Tcllib package indexing -======================= - -This document describes the possibilities for using one or more -pkgIndex.tcl files in an installation of tcllib to provide the -information about all of its packages to a tcl interpreter, discusses -their pro and contra and makes a choice for Tcllib 1.4. A roadmap of -changes in the future is made available as appendix. - -Background under which to see the solutions: - - There are three level of groupings: - - - The tcllib project itself - - Modules in the project (== subdirectory of 'modules') - - Packages in a module. - - Each module currently contains one package index file. - - Some modules contain more than one package. They share the index. - - Most packages require specific versions of the Tcl - interpreter. They perform the checks in their package index - file and do not register if the pre-requisites are not - fulfilled. - - Other checks are possible, but currently not in use. - -Note I: - Whether a solutions is actually applicable depends on external - factors, like the chosen directory layout of an installed - tcllib. - -Note II: - All solutions currently depend on the specific implementation - of [tclPkgUnknown] coming with the basic core, simply by the - fact that the files looked at are called 'pkgIndex.tcl'. This - is therefore no contra argument against any specific solution, - but against all. We ignore this as currently there is no - better replacement in existence. - -Note III: - We have to support Tcl before 8.3. as some packages in tcllib - allow this. - - -[i1/ng] No global package index -------------------------------- - - In this solution the module package indices are the only index - files present in an installation. - - This solution is applicable if and only if one of the flat - directory layouts (L2/Fa or L2/Fb) has been chosen. - - Pro: - Simple. No need for complex management. - - -[i2/ad] Global package index, auto_path extension, direct ---------------------------------------------------------- - - A single global package index is present in the toplevel - directory of the installation. - - This solution is applicable if and only if the deep directory - layout (L2/D) has been chosen. - - The package index contains a series of statements extending - the auto_path variable with all module directories. The list - of names of the module directories is hardcoded. In other - words, it is _not_ determined via [glob]. - - Example: - lappend auto_path [file join $dir md4] - lappend auto_path [file join $dir md5] - lappend auto_path [file join $dir sha1] - ... - - - Pro: - [[0]] Compared to [i3/ag] this should be bit faster - as glob'ing the directory tree of tcllib is - avoided. This performance-boost is not a big - pro according to the opinions below. - - [[1]] Relies on the module package index files for - the actual registration of packages, thus - automatically inherits the correct contraints - on the registration of packages. No additional - complexities. - - [[2]] Easier to generate than [i6/dr]. - - Contra: - [[3]] Hard coding the directory names implies that - adding modules to the installed tcllib is not - as easy as just creating a new directory for - the module/package. The global index has to be - updated too. - - Contra-Contra: - <> - - <> - - [[4]] Extending the 'auto_path' list causes the - package management of the tcl core to re-read - the list and glob through all of them for new - package indices. This has a high cost in terms - of filesystem access, i.e. is an issue of - performance. - - Contra-Contra: - <> - - <> - - - [[5]] This enables auto-loading in each module - (according to any tclIndex file installed). - This should not be done by the package - indexer, but by the package itself. See - control for an example. - - [[10]] Will not work with Tcl releases prior to - 8.3.1. Only then was [tclPkgUnknown] - "enhanced" to deal with changing ::auto_path - values. If tcllib 1.4 wishes to continue - supporting pre-8.3.1 Tcl, then this option has - to be supplemented with a fallback. - - -[i3/ag] Global package index, auto_path extension, glob -------------------------------------------------------- - - This is like [i2/ad], except that the list of sub directories - is not hardcoded into the index, but determined through glob. - - Example: - foreach subdir [glob -nocomplain -type d $dir/*] { - lappend auto_path $subdir - } - - Pro: - Anti-[[3]] - [[1]] - - Contra: - All the contras of [i2/ad] and Anti-[[0]]. - - -[i4/sd] Global package index, sourcing module indices, direct -------------------------------------------------------------- - - A single global package index is present in the toplevel - directory of the installation. - - This solution is applicable if and only if the deep directory - layout (L2/D) has been chosen. - - The package index contains a series of statements source'ing - the package index files of the modules in tcllib. The list - of names of the module directories is hardcoded. In other - words, it is _not_ determined via [glob]. - - Example: - set main $dir - set dir [file join $main md4] ; source [file join $dir pkgIndex.tcl] - set dir [file join $main md5] ; source [file join $dir pkgIndex.tcl] - set dir [file join $main sha1] ; source [file join $dir pkgIndex.tcl] - ... - - Pro: - [[0]], but compared to [i5/sg]. - [[1]] - [[2]] - [[6]] In contrast to [i2/ad] and [i3/ag] repeated - glob'bing for package index files is - avoided. This cuts down on costly FS accesses. - I.e. another perf. boost. - - Contra: - [[3]] - -[i5/sg] Global package index, sourcing module indices, glob ------------------------------------------------------------ - - This is like [i4/sd], except that the list of package indices - to source is not hardcoded into the index, but determined - through glob. - - Example: - foreach subdir [glob -nocomplain -type d $dir/*] { - set dir $subdir - source [file join $dir pkgIndex.tcl] - } - - Pro: - Anti-[[3]] - [[1]] - [[2]] - - Contra: - All the contras of [i2/sd], and Anti-[[0]] - - -[i6/dr] Global package index, direct registration -------------------------------------------------- - - A single global package index is present in the toplevel - directory of the installation. - - This solution is applicable if and only if the deep directory - layout (L2/D) has been chosen. - - The package index contains a series of statements which - directly register all the tcllib packages. - - Example: - if {[constraint]} {return} - package ifneeded md4 [list source [file join $dir md4 md4.tcl]] - package ifneeded md5 [list source [file join $dir md4 md4.tcl]] - package ifneeded sha1 [list source [file join $dir md4 md4.tcl]] - ... more constraints ... package ifneeded - - Pro: - [[7]] This is the fasted solution as the number of - accesses to the filesystem is minimal. - - Contra: - [[[3]] - Anti-[[1]] Care has to be taken to ensure that - the constraints the module indices - place on the registration of packages - are replicated in the global - index. All other solutions simply used - the module indices and thus got it - right automatically. Now supporting - code is required to detect such - constraints and then to properly - recreate them globally. - - = High complexity for the maintainer. - -[i7/ad] Global package index, auto_path extension, direct ---------------------------------------------------------- - - A single global package index is present in the toplevel - directory of the installation. - - This solution is applicable if and only if the deep directory - layout (L2/D) has been chosen. - - The package index contains a single statement extending the - auto_path variable with the tcllib main directory. The - standard package management will then find all module sub - directories and the package indices in them. - - Example: - lappend auto_path $dir - - Pro: - [[1]] - [[8]] This is the easiest solution by far in terms - of code to write, and complexities to solve - (none). - - [[9]] <> - - <> - - Contra: [[4]] - [[10]] - - -[i8/pm] Global package index, pkg_mkIndex ------------------------------------------ - -Just use [pkg_mkIndex modules */*.tcl] to generate the master index. - - Pro: - Easy to do. - - Contra: - Does not handle constraints in subordinate package - indices, simply because they are actually ignored - during processing. - - Adding code to handle constraints evolves this into - [i6/dr]. - - Note: The contra is hard enough IMHO to make this solution not - applicable for 1.4, which does have constraints, and handling - them wrong (not at all) is a bug. - - -General discussion ------------------- - -Given that a deep directory layout was chosen [i1/ng] is not -applicable and therefore dropped from the discussion. - -In the pro and contra arguments listed above three independent axes of -reasoning emerged: - -a) Performance of the solution, with the number of accesses to - filesystem the main factor determining it. - -b) Complexity/difficulty of the solution with regard to - adding/updating packages. - -c) Complexity of generating the master index. - -Axis (b) has essentially been thrown out. Trying to modify the -installation of tcllib itself is bad practice. Install new/updated -packages separately. The version numbering takes care of the rest, -i.e. usage of the new over the older version found in tcllib. - -With respect to axis (c), complexity of generation, [i7/ad] is the -definite winner, with the other *d solutions close behind (all use -fixed scripts, I7/ad wins on size). This is followed by the *g -solutions as they require actual dynamic generation of code. And at -the bottom of the ladder is [i6/dr] with its need for close inspection -of the sub-ordinate indices to get everything right. - -Now axis (a), performance, [i6/dr] is most likely the winner as it -causes only one index to be read and nothing else. This is followed by -the all *d solutions, they read the subordinate indices, but do not -need much globbing. The actual order in this group is difficult to -determine. I guess that the auto_path extending methods are slower -than the sourcing methods, and the adding of one directory faster than -the adding of all, as the latter looks for much more subdirectories. -The next group oare the *g solutions as they their own globbing too -beyond that done by the package mgmt. - -Two final rankings - - (c), then (a) (a), then (c) - ------------- ------------- - [i7/ad] [i6/dr] - [i4/sd] [i4/sd] - [i2/ad] [i7/ad] - [i5/sg] [i2/ad] - [i3/ag] [i5/sg] - [i6/dr] [i3/ag] - ------------- ------------- - -[i4/sd] seems to be a good compromise solution between performance and -complexity of generation, but [i7/ad] is not too bad either. - -[i4/sd] reminder: - set main $dir - set dir [file join $main md4] ; source [file join $dir pkgIndex.tcl] - set dir [file join $main md5] ; source [file join $dir pkgIndex.tcl] - set dir [file join $main sha1] ; source [file join $dir pkgIndex.tcl] - ... - -[i7/ad] reminder: - lappend auto_path $dir - -Other opinions: - - Don Porter prefers [i7/ad], and [i6/dr] as second choice. Also - as [i7/ad] fallback for older Tcl before 8.3.1 - - Joe English strictly opposes any solution modifying the - auto_path, violoating his opinion that index scripts should - have no side-effects beyond registering a package. - - -Chosen solution for Tcllib 1.4 ------------------------------- - -After comparing the code for the combination of [i7/ad] and [i6/dr] as -submitted by Don Porter, and for [i4/sd] as submitted by myself -(Andreas), and a small discussion on the Tcl'ers chat between Don and -me we took [i4/sd] for the main body of the idnex, and the header of -Don's code. Basically the chosen package index is a combination of -[i7/id] and of [i4/sd] as fallback. - -This is still as easy to generate as [4/sd], the index is also only a -bit more complex, and speed should be ok too. - -Don convinced me that while extending auto_path is definitely bad in -the long-term it is still ok for the short-term and release 1.4. - - -Roadmap -------- - -After Tcllib has been driven into the state of one package per module -directory, and switched to a flat directory layout for its -installation we switch to [i1/ng] for the indexing structure. - - ------------------------------------ -This document is in the public domain. - - Andreas Kupries DELETED devdoc/installation.txt Index: devdoc/installation.txt ================================================================== --- devdoc/installation.txt +++ /dev/null @@ -1,85 +0,0 @@ -Tcllib installation directory layout -==================================== - -This document describes the possible layouts for an installed tcllib, -discusses their pro and contra and makes a choice for Tcllib 1.4. A -roadmap of changes in the future is made available as appendix. - -[L1/D] Deep layout ------------------- - - This is the layout of Tcllib 1.3 (and versions before that). - - A single directory tcllib is created, and all - subdirectories of the 'modules' subdirectory in the - distribution is copied into it. This is restricted at large to - *.tcl files, with exception made for some modules with special - needs. - - Pro: - Contra: - Makes the handling of the various package indices, - well, not difficult, but uncomfortable. - - -[L2/Fa] Flat layout 1 ---------------------- - - A directory is created for each module of tcllib. - - Pro: - Handling of package indices is easier than for L1/D, a - toplevel index file with all its problems is not - required anymore. - - Contra: - Directories should be versioned to avoid conflicts - between multiple releases. modules have no - version. This can be faked for mdules containing one - package, but not for the modules with more. - - -[L2/Fb] Flat layout 2 ---------------------- - - A directory is created for each package in tcllib. - - Pro - Handling of package indices is easy, one per package. - - Contra: - Modules containing more than one package are difficult - to handle. The system has to split them into the - individual packages. This rendered very difficult - because of shared package index files. - - This can be solved by moving tcllib (back) towards of - one package per module. When that goal is reached - L2/Fa and L2/Fb become the same, and the contra for - L2/Fa vanishes too as an exact version number can be - associated with each directory. - -Chosen layout for Tcllib 1.4 ----------------------------- - - L2/D - - Despite the problems with package indices the contras against - the flat structures are too strong at this point in - time. Automatic solutions are not really possible, or require - a very high effort. - -Roadmap -------- - Change the module directories of tcllib to contain exactly one - package per directory, with appropriate index (and meta data). - - This not only makes sense for easier handling of installation - and package indices, but also in the geater context of - wrapping code for deployment. - - ------------------------------------ -This document is in the public domain. - - Andreas Kupries DELETED devdoc/releaseguide.html Index: devdoc/releaseguide.html ================================================================== --- devdoc/releaseguide.html +++ /dev/null @@ -1,72 +0,0 @@ - - -

Guide to the creation of source releases for Tcllib -

-
- -

Recap -

-
- - -

-The CVS repository for Tcllib contains two main branches, - the HEAD for development, and RELEASES as the staging area for - official releases. -

- -

Dependencies -

- -

Creation of a new official release -

- -

To create a new official release of Tcllib the release manager has - to perform the steps described below: -

- - -
    -
  1. Retrieve the sources at the current head - from the CVS repository, using a command like -
    -	  CVSROOT=:pserver:anonymous@cvs.tcllib.sourceforge.net:/cvsroot/tcllib
-	  cvs -d${CVSROOT} co tcllib
-
    - Vary this command according to taste as long as the overall - meaning is not changed. Compression options and the like. - -
  2. Tag these sources with a new branch tag for the new release of - tcllib, like -
    -	  cvs -d${CVSROOT} rtag tcllib
-
    - -
  3. Commit the changes, then update the working directory. - -
  4. Use a tclsh to run the sak tool with the argument gendist, like -
    -    tclsh /path/to/tcllib/sak.tcl gendist
-
    - -
  5. This results in the creation of a tcllib-VERSION directory -in the current working directory, and of two archives, .zip, -and .tar.gz. A starkit will be created if sdx is present -in the PATH. If additionally a file named tclkit is present in -the current working directory a starpack will be created too, using -this tclkit as the runtime. - - -
  6. Now follow the instructions in the Sourceforge site documentation - for uploading the archives generated by the last - step to - ftp://upload.sourceforge.net/incoming, and - follow the procedures for creating packages and - releases at Sourceforge. -
- -

At last notify the relevant persons in other communities like -Debian (See list of contacts) about the new release. -

DELETED examples/README Index: examples/README ================================================================== --- examples/README +++ /dev/null @@ -1,2 +0,0 @@ -This directory contains example applications using the facilities of -tcllib. DELETED examples/csv/Bench.csv Index: examples/csv/Bench.csv ================================================================== --- examples/csv/Bench.csv +++ /dev/null @@ -1,254 +0,0 @@ -000,VERSIONS:,1:8.4a3,1:8.3.3,1:8.2.3,1:8.1.1,1:8.0.5,1:7.6p2,1:7.5p1 -001,CATCH return ok,11,6,7,4,5,28,17 -002,CATCH return error,70,64,275,54,204,146,33 -003,CATCH no catch used,10,6,7,13,4,24,9 -004,IF if true numeric,17,11,13,7,9,152,61 -005,IF elseif true numeric,20,15,16,20,11,299,292 -006,IF else true numeric,20,15,16,15,11,318,82 -007,IF if true num/num,17,12,281,22,9,329,174 -008,IF if false num/num,17,12,13,13,9,202,182 -009,IF if false al/num,27,20,20,29,17,467,121 -010,IF if true al/al,31,26,26,51,169,292,184 -011,IF if false al/al,31,25,25,51,60,217,243 -012,IF if true al,32,25,25,42,51,214,76 -013,IF elseif true al,47,39,338,89,156,358,154 -014,IF else true al,46,40,42,71,51,292,323 -015,SWITCH first true,63,42,103,58,73,391,241 -016,SWITCH second true,58,39,153,65,62,340,282 -017,SWITCH ninth true,67,44,238,73,112,391,284 -018,SWITCH default true,62,38,46,73,77,492,292 -019,DATA create in a list,4883,4083,15014,12925,7886,40180,29501 -020,DATA create in an array,5388,4916,19172,12827,16792,53723,40784 -021,DATA access in a list,4028,3546,15346,10386,7024,182889,175028 -022,DATA access in an array,3507,3223,14156,6966,7640,43232,39744 -023,EVAL cmd eval in list obj var,26,22,52,40,84,27,26 -024,EVAL cmd eval as list,24,21,49,88,144,22,52 -025,EVAL cmd eval as string,60,50,54,79,90,26,64 -026,EVAL cmd and mixed lists,3347,3546,32485,21937,13914,3017,2112 -027,EVAL list cmd and mixed lists,3403,3591,40366,19014,14703,2936,2259 -028,EVAL list cmd and pure lists,543,582,40115,21974,12611,2653,2245 -029,EXPR unbraced,153,167,502,23,331,313,365 -030,EXPR braced,29,25,29,53,92,505,386 -031,EXPR inline,31,30,40,68,59,321,177 -032,EXPR one operand,11,6,158,9,11,47,65 -033,EXPR ten operands,18,13,97,13,20,159,141 -034,EXPR fifty operands,48,43,45,71,85,708,430 -035,EXPR incr with incr,16,11,10,16,22,31,45 -036,EXPR incr with expr,11,7,9,11,13,73,74 -037,FCOPY std: 160010 bytes,10069,10242,46300,25104,26557 -038,FCOPY binary: 160010 bytes,9932,9892,41776,25211, -039,FCOPY encoding: 160010 bytes,9818,9831,44598,25972, -040,KLIST shuffle0 llength 1,144,127,554,271,367 -041,KLIST shuffle0 llength 10,457,413,1592,901,728 -042,KLIST shuffle0 llength 100,3986,3552,13565,8229,6484 -043,KLIST shuffle0 llength 1000,44083,41766,164223,92480,81157 -044,KLIST shuffle0 llength 10000,563245,533804,2073612,1214997,1161217 -045,KLIST shuffle1 llength 1,84,85,367,163,149 -046,KLIST shuffle1 llength 10,358,333,1371,718,634 -047,KLIST shuffle1 llength 100,6374,5238,12737,9243,8576 -048,KLIST shuffle1 llength 1000,1190696,1194146,1770024,1762135,1736049 -049,KLIST shuffle1a llength 1,110,100,94,172,150 -050,KLIST shuffle1a llength 10,474,368,404,768,910 -051,KLIST shuffle1a llength 100,4667,3625,3833,8986,9480 -052,KLIST shuffle1a llength 1000,47818,37340,39248,84798,95305 -053,KLIST shuffle1a llength 10000,474513,380522,408005,861405,1004602 -054,KLIST shuffle2 llength 1,104,99,108,196,229 -055,KLIST shuffle2 llength 10,440,375,481,938,1080 -056,KLIST shuffle2 llength 100,3762,3625,4250,8904,9803 -057,KLIST shuffle2 llength 1000,39573,37028,45651,95513,116933 -058,KLIST shuffle2 llength 10000,474558,433771,527055,1176566,1304458 -059,KLIST shuffle3 llength 1,104,98,102,217,170 -060,KLIST shuffle3 llength 10,380,335,376,786,832 -061,KLIST shuffle3 llength 100,3408,2883,3413,7161,7632 -062,KLIST shuffle3 llength 1000,38716,33237,37667,87353,82985 -063,KLIST shuffle3 llength 10000,945771,777699,844383,1789387,1732151 -064,KLIST shuffle4 llength 1,114,102,100,202,178 -065,KLIST shuffle4 llength 10,431,374,416,837,876 -066,KLIST shuffle4 llength 100,3871,3250,3758,8572,8278 -067,KLIST shuffle4 llength 1000,40201,32119,38186,82985,80450 -068,KLIST shuffle4 llength 10000,393369,330472,398724,874454,834612 -069,"STR/LIST length, obj shimmer",2390,2767,2333,905,28,2585,2638 -070,"LIST length, pure list",18,13,13,21,18,2023,1837 -071,STR length of a LIST,15,12,12,529,23,525,400 -072,"LIST exact search, first item",19,11,14,17,32,2303,1693 -073,"LIST exact search, middle item",69,25,27,46,38,1787,1944 -074,"LIST exact search, last item",132,48,50,90,111,2261,2009 -075,"LIST exact search, non-item",314,110,121,212,220,2099,2118 -076,"LIST sorted search, first item",23,12,12,16,29,1862,1610 -077,"LIST sorted search, middle item",24,26,26,42,40,1623,2252 -078,"LIST sorted search, last item",24,52,49,84,121,2145,1784 -079,"LIST sorted search, non-item",23,111,122,201,257,1999,2057 -080,"LIST exact search, untyped item",131,47,51,80,101,2166,2218 -081,"LIST exact search, typed item",128,48,49,77,111,2072,1872 -082,"LIST sorted search, typed item",19,46,50,93,104,1887,2221 -083,LIST sort,3299,3578,3293,6723,7021,10959,9644 -084,LIST typed sort,2739,2943,2660,4737,4651,28889,23969 -085,LIST remove first element,317,296,363,806,866,625,522 -086,LIST remove middle element,325,291,358,692,876,656,677 -087,LIST remove last element,318,293,360,689,879,754,675 -088,LIST replace first element,310,289,346,722,917,727,978 -089,LIST replace middle element,316,286,353,693,1045,1024,876 -090,LIST replace last element,316,283,346,963,832,1450,1243 -091,LIST replace first el with multiple,333,304,372,819,938,702,612 -092,LIST replace middle el with multiple,319,310,351,691,736,1088,1123 -093,LIST replace last el with multiple,319,282,347,813,740,1413,1313 -094,LIST replace range,294,282,343,744,866,1198,971 -095,LIST remove in mixed list,389,374,2195,833,999,829,617 -096,LIST replace in mixed list,377,352,2184,1054,925,756,592 -097,LIST index first element,18,10,13,16,25,451,375 -098,LIST index middle element,17,10,13,16,23,516,536 -099,LIST index last element,17,11,13,13,17,622,663 -100,LIST insert an item at start,291,298,366,775,805,729,563 -101,LIST insert an item at middle,269,266,370,684,667,978,630 -102,"LIST insert an item at ""end""",257,254,349,670,1013,1779,1200 -103,"LIST small, early range",23,19,16,42,35,500,383 -104,"LIST small, late range",23,18,16,28,38,618,685 -105,"LIST large, early range",37,29,24,54,108,511,697 -106,"LIST large, late range",40,30,21,81,131,567,551 -107,LIST append to list,409,401,396,917,1032,737,682 -108,LIST join list,1053,1072,1066,1818,1453,3672,3167 -109,"LOOP for, iterate list",6616,5198,5372,13766,9653,662376,583297 -110,"LOOP foreach, iterate list",1919,1845,1952,3750,3553,11561,12556 -111,LOOP for (to 1000),2566,2674,3065,4639,4867,66896,73851 -112,LOOP while (to 1000),2568,2942,3065,4551,4637,69891,80404 -113,"LOOP for, iterate string",6456,9440,9637,141594,14530,219770,199570 -114,"LOOP foreach, iterate string",2240,2249,3955,9099,8147,15468,13206 -115,MAP string 1 val,679,5931,6028,9096,(8.2+),(8.2+),(8.2+) -116,MAP string 2 val,1562,6643,6877,12943,(8.2+),(8.2+),(8.2+) -117,MAP string 3 val,1836,7673,7832,12825,(8.2+),(8.2+),(8.2+) -118,MAP string 4 val,2510,8429,8622,17267,(8.2+),(8.2+),(8.2+) -119,MAP string 1 val -nocase,3497,10259,10381,17685,(8.2+),(8.2+),(8.2+) -120,MAP string 2 val -nocase,6218,14570,15024,27379,(8.2+),(8.2+),(8.2+) -121,MAP string 3 val -nocase,8364,19344,18973,35569,(8.2+),(8.2+),(8.2+) -122,MAP string 4 val -nocase,10135,21861,22132,39660,(8.2+),(8.2+),(8.2+) -123,MAP regsub 1 val,3702,3954,4303,9663,1830,4430,3684 -124,MAP regsub 2 val,16066,16981,18176,41500,4184,9394,11576 -125,MAP regsub 3 val,21671,23258,24817,52315,6075,11441,12456 -126,MAP regsub 4 val,26657,29335,31350,67973,8659,15319,13884 -127,MAP regsub 1 val -nocase,3686,3913,4332,9463,2766,4729,4488 -128,MAP regsub 2 val -nocase,15821,17024,18134,40735,5881,9546,11911 -129,MAP regsub 3 val -nocase,20987,23228,24747,52639,8625,12501,14437 -130,MAP regsub 4 val -nocase,26227,29397,31314,66937,11664,14510,16818 -131,"MAP string, no match",926,7712,8028,14020,(8.2+),(8.2+),(8.2+) -132,"MAP string -nocase, no match",6726,18725,18933,35683,(8.2+),(8.2+),(8.2+) -133,"MAP regsub, no match",1149,2764,2830,6704,1843,3352,4823 -134,"MAP regsub -nocase, no match",1151,2785,2890,6609,3563,4499,5249 -135,MAP string short,37,41,39,116,(8.2+),(8.2+),(8.2+) -136,MAP regsub short,164,180,193,308,154,244,432 -137,MTHD direct ns proc call,10,6,8,3,7 -138,MTHD imported ns proc call,11,6,7,5,7 -139,MTHD interp alias proc call,25,18,18,18,9 -140,MTHD indirect proc eval,36,29,61,56,72 -141,MTHD indirect proc eval #2,58,48,57,81,107 -142,MTHD array stored proc call,14,9,10,22,19 -143,MTHD switch method call,50,38,83,119,172 -144,MTHD ns lookup call,99,81,216,374,376 -145,MTHD inline call,5,3,3,2,2 -146,PROC explicit return,15,7,8,7,7,11,11 -147,PROC implicit return,11,6,7,4,11,16,15 -148,PROC explicit return (2),12,7,8,13,13,14,10 -149,PROC implicit return (2),10,6,7,10,18,21,24 -150,PROC explicit return (3),10,7,7,4,14,14,25 -151,PROC implicit return (3),10,6,7,3,12,10,18 -152,PROC heavily commented,10,5,6,12,5,629,753 -153,"PROC do-nothing, no args",8,5,28,38,4,5,2 -154,"PROC do-nothing, one arg",10,5,6,9,8,15,21 -155,PROC local links with global,1579,1569,1626,3586,4533,7955,11505 -156,PROC local links with upvar,1287,1166,1387,2806,2922,8371,10317 -157,PROC local links with variable,1195,1101,1334,2614,1050,9091,9212 -158,"READ 595K, gets",340064,299797,306109,819327,372526,978472,985676 -159,"READ 595K, read",77751,97698,97019,227338,2936958,3774669,3834017 -160,"READ 595K, read & size",77606,97909,97074,242255,124776,3696432,3704813 -161,"READ 3050b, gets",1869,1641,2052,4118,954,2074,2201 -162,"READ 3050b, read",522,494,494,789,748,503,415 -163,"READ 3050b, read & size",569,534,530,790,410,467,361 -164,"BREAD 595K, gets",350077,292326,304961,833500,365165,953379,979961 -165,"BREAD 595K, read",50105,50454,50018,228963,2952787,3640795,3741298 -166,"BREAD 595K, read & size",50303,50486,50140,246365,87019,3685978,3688120 -167,"BREAD 3050b, gets",2097,1777,1774,5220,1062,2208,2178 -168,"BREAD 3050b, read",340,347,334,1310,412,458,359 -169,"BREAD 3050b, read & size",396,389,369,1144,1230,390,495 -170,REGEXP literal regexp,39,37,38,42,31,26,26 -171,REGEXP var-based regexp,41,40,40,55,45,30,61 -172,REGEXP count all matches,137,139,530,1280,1332,2277,2776 -173,REGEXP extract all matches,169,177,616,1790,1129,3068,3620 -174,STARTUP time to launch tclsh,21138,20425,18293,85723,102877,70500,90323 -175,STR str [string compare],18,26,24,17,26,199,193 -176,STR str [string equal],18,25,23,68,38,160,198 -177,"STR str $a equal """"",17,26,24,81,52,670,410 -178,"STR str num == """"",19,14,24,36,52,338,419 -179,STR str $a eq $b,22,33,31,39,56,231,261 -180,STR str $a ne $b,23,31,30,85,47,226,265 -181,STR str $a eq $b (same obj),22,33,36,161,53,271,338 -182,STR str $a ne $b (same obj),21,33,30,28,57,203,235 -183,STR length (==4010),15,14,13,678,17,508,867 -184,STR index 0,26,19,19,487,30,522,614 -185,STR index 100,21,24,19,500,43,491,601 -186,STR index 500,21,18,19,483,42,489,493 -187,STR index2 0,21,19,19,494,27,485,583 -188,STR index2 100,20,19,19,470,26,557,459 -189,STR index2 500,21,19,19,484,40,764,468 -190,STR first (success),19,16,15,21,33,533,519 -191,STR first (failure),120,56,50,123,117,697,822 -192,STR first (total failure),109,42,28,54,57,545,631 -193,STR last (success),19,229,224,469,18,815,728 -194,STR last (failure),90,99,91,185,201,657,859 -195,STR last (total failure),82,90,83,135,151,584,1153 -196,"STR match, simple (success early)",17,14,13,25,33,503,489 -197,"STR match, simple (success late)",16,14,13,11,27,619,502 -198,"STR match, simple (failure)",17,15,13,26,36,421,680 -199,"STR match, simple (total failure)",16,18,13,17,30,456,378 -200,"STR match, complex (success early)",17,23,22,33,35,466,448 -201,"STR match, complex (success late)",145,1020,1040,2173,926,1529,1676 -202,"STR match, complex (failure)",122,1011,1010,1785,964,1357,1698 -203,"STR match, complex (total failure)",90,994,994,1844,1216,1725,1602 -204,"STR range, index 100..200 of 4010",26,21,21,716,25,589,609 -205,"STR replace, no replacement",79,270,264,570,166,1217,1315 -206,"STR replace, equal replacement",92,277,257,526,140,1560,1263 -207,"STR replace, longer replacement",95,270,265,551,103,1563,1309 -208,"STR repeat, abcdefghij * 10",19,22,22,21,199,997,963 -209,"STR repeat, abcdefghij * 100",39,72,74,120,1267,8488,9065 -210,"STR repeat, abcdefghij * 1000",245,565,557,798,12264,81587,86928 -211,"STR repeat, 4010 chars * 10",314,797,671,1971,1494,11891,7688 -212,"STR repeat, 4010 chars * 100",7347,18287,18194,47967,69328,105423,107290 -213,"STR reverse iter1, 100 chars",1285,1628,1425,4104,1871,8459,8704 -214,"STR reverse iter1, 100 uchars",1264,1768,1436,4448,1864,8250,9034 -215,"STR reverse iter2, 100 chars",808,1252,1168,3860,2099,8379,8292 -216,"STR reverse iter2, 100 uchars",807,1259,1096,4086,1602,9513,5431 -217,"STR reverse recur1, 100 chars",4092,4770,3998,8749,8470,20868,11271 -218,"STR reverse recur1, 100 uchars",4169,5467,4767,8794,9075,21634,13821 -219,"STR split, 4010 chars",2663,2138,8847,23626,18954,4372,3169 -220,"STR split, 12100 uchars",7207,6395,,, -221,"STR split iter, 4010 chars",9349,9372,16664,39846,35962,52886,48521 -222,"STR split iter, 12100 uchars",28171,28299,,, -223,STR append,100,82,71,108,164,1055,1145 -224,STR append (1KB + 1KB),65,55,49,96,79,236,290 -225,STR append (10KB + 1KB),186,193,196,474,75,215,213 -226,STR append (1MB + 2b * 1000),37786,70498,74635,178639,12391,82339,84345 -227,STR append (1MB + 1KB),29729,63374,61479,136891,68,215,335 -228,STR append (1MB + 1KB * 20),29635,64566,61865,127033,270,1551,1724 -229,STR append (1MB + 1KB * 1000),66605,94413,101998,177875,10955,78370,81930 -230,STR append (1MB + 1MB * 3),126103,153051,157370,282029,218,248,876 -231,STR append (1MB + 1MB * 5),157407,303871,315407,1051814,45,543,342 -232,STR append (1MB + (1b + 1K + 1b) * 100),33118,63834,69167,290360,2398,8930,9893 -233,STR info locals match,828,818,993,2025,1518,8071,9043 -234,TRACE no trace set,35,25,26,18,27,42,91 -235,TRACE read,35,26,26,16,59,128,113 -236,TRACE write,35,25,26,16,55,78,78 -237,TRACE unset,35,26,26,16,70,94,112 -238,TRACE all set (rwu),35,25,25,18,59,77,105 -239,UNSET var exists,14,8,9,8,16,27,37 -240,UNSET catch var exists,16,9,10,52,20,61,58 -241,UNSET catch var !exist,69,64,59,191,120,77,96 -242,UNSET info check var exists,19,14,13,69,27,80,78 -243,UNSET info check var !exist,16,11,11,6,17,73,64 -244,UNSET nocomplain var exists,14,9,10,35,20,52,56 -245,UNSET nocomplain var !exist,14,64,59,157,122,90,109 -246,VAR access locally set,14,8,10,18,20,106,67 -247,VAR access local proc arg,14,9,10,6,26,88,110 -248,VAR access global,34,25,26,101,61,82,121 -249,VAR access upvar,36,29,30,103,65,97,101 -250,VAR set scalar,10,6,7,4,11,35,74 -251,VAR set array element,18,12,14,9,33,59,35 -252,VAR 100 'set's in array,162,133,160,296,292,917,827 -253,VAR 'array set' of 100 elems,293,251,264,741,816,1063,993 DELETED examples/csv/Bench.html Index: examples/csv/Bench.html ================================================================== --- examples/csv/Bench.html +++ /dev/null @@ -1,258 +0,0 @@ -Core Benchmark Results -

Core Benchmark Results

-

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
000 VERSIONS: 1:8.4a3 1:8.3.3 1:8.2.3 1:8.1.1 1:8.0.5 1:7.6p2 1:7.5p1
001 CATCH return ok 11 6 7 4 5 28 17
002 CATCH return error 70 64 275 54 204 146 33
003 CATCH no catch used 10 6 7 13 4 24 9
004 IF if true numeric 17 11 13 7 9 152 61
005 IF elseif true numeric 20 15 16 20 11 299 292
006 IF else true numeric 20 15 16 15 11 318 82
007 IF if true num/num 17 12 281 22 9 329 174
008 IF if false num/num 17 12 13 13 9 202 182
009 IF if false al/num 27 20 20 29 17 467 121
010 IF if true al/al 31 26 26 51 169 292 184
011 IF if false al/al 31 25 25 51 60 217 243
012 IF if true al 32 25 25 42 51 214 76
013 IF elseif true al 47 39 338 89 156 358 154
014 IF else true al 46 40 42 71 51 292 323
015 SWITCH first true 63 42 103 58 73 391 241
016 SWITCH second true 58 39 153 65 62 340 282
017 SWITCH ninth true 67 44 238 73 112 391 284
018 SWITCH default true 62 38 46 73 77 492 292
019 DATA create in a list 4883 4083 15014 12925 7886 40180 29501
020 DATA create in an array 5388 4916 19172 12827 16792 53723 40784
021 DATA access in a list 4028 3546 15346 10386 7024 182889 175028
022 DATA access in an array 3507 3223 14156 6966 7640 43232 39744
023 EVAL cmd eval in list obj var 26 22 52 40 84 27 26
024 EVAL cmd eval as list 24 21 49 88 144 22 52
025 EVAL cmd eval as string 60 50 54 79 90 26 64
026 EVAL cmd and mixed lists 3347 3546 32485 21937 13914 3017 2112
027 EVAL list cmd and mixed lists 3403 3591 40366 19014 14703 2936 2259
028 EVAL list cmd and pure lists 543 582 40115 21974 12611 2653 2245
029 EXPR unbraced 153 167 502 23 331 313 365
030 EXPR braced 29 25 29 53 92 505 386
031 EXPR inline 31 30 40 68 59 321 177
032 EXPR one operand 11 6 158 9 11 47 65
033 EXPR ten operands 18 13 97 13 20 159 141
034 EXPR fifty operands 48 43 45 71 85 708 430
035 EXPR incr with incr 16 11 10 16 22 31 45
036 EXPR incr with expr 11 7 9 11 13 73 74
037 FCOPY std: 160010 bytes 10069 10242 46300 25104 26557
038 FCOPY binary: 160010 bytes 9932 9892 41776 25211
039 FCOPY encoding: 160010 bytes 9818 9831 44598 25972
040 KLIST shuffle0 llength 1 144 127 554 271 367
041 KLIST shuffle0 llength 10 457 413 1592 901 728
042 KLIST shuffle0 llength 100 3986 3552 13565 8229 6484
043 KLIST shuffle0 llength 1000 44083 41766 164223 92480 81157
044 KLIST shuffle0 llength 10000 563245 533804 2073612 1214997 1161217
045 KLIST shuffle1 llength 1 84 85 367 163 149
046 KLIST shuffle1 llength 10 358 333 1371 718 634
047 KLIST shuffle1 llength 100 6374 5238 12737 9243 8576
048 KLIST shuffle1 llength 1000 1190696 1194146 1770024 1762135 1736049
049 KLIST shuffle1a llength 1 110 100 94 172 150
050 KLIST shuffle1a llength 10 474 368 404 768 910
051 KLIST shuffle1a llength 100 4667 3625 3833 8986 9480
052 KLIST shuffle1a llength 1000 47818 37340 39248 84798 95305
053 KLIST shuffle1a llength 10000 474513 380522 408005 861405 1004602
054 KLIST shuffle2 llength 1 104 99 108 196 229
055 KLIST shuffle2 llength 10 440 375 481 938 1080
056 KLIST shuffle2 llength 100 3762 3625 4250 8904 9803
057 KLIST shuffle2 llength 1000 39573 37028 45651 95513 116933
058 KLIST shuffle2 llength 10000 474558 433771 527055 1176566 1304458
059 KLIST shuffle3 llength 1 104 98 102 217 170
060 KLIST shuffle3 llength 10 380 335 376 786 832
061 KLIST shuffle3 llength 100 3408 2883 3413 7161 7632
062 KLIST shuffle3 llength 1000 38716 33237 37667 87353 82985
063 KLIST shuffle3 llength 10000 945771 777699 844383 1789387 1732151
064 KLIST shuffle4 llength 1 114 102 100 202 178
065 KLIST shuffle4 llength 10 431 374 416 837 876
066 KLIST shuffle4 llength 100 3871 3250 3758 8572 8278
067 KLIST shuffle4 llength 1000 40201 32119 38186 82985 80450
068 KLIST shuffle4 llength 10000 393369 330472 398724 874454 834612
069 STR/LIST length, obj shimmer 2390 2767 2333 905 28 2585 2638
070 LIST length, pure list 18 13 13 21 18 2023 1837
071 STR length of a LIST 15 12 12 529 23 525 400
072 LIST exact search, first item 19 11 14 17 32 2303 1693
073 LIST exact search, middle item 69 25 27 46 38 1787 1944
074 LIST exact search, last item 132 48 50 90 111 2261 2009
075 LIST exact search, non-item 314 110 121 212 220 2099 2118
076 LIST sorted search, first item 23 12 12 16 29 1862 1610
077 LIST sorted search, middle item 24 26 26 42 40 1623 2252
078 LIST sorted search, last item 24 52 49 84 121 2145 1784
079 LIST sorted search, non-item 23 111 122 201 257 1999 2057
080 LIST exact search, untyped item 131 47 51 80 101 2166 2218
081 LIST exact search, typed item 128 48 49 77 111 2072 1872
082 LIST sorted search, typed item 19 46 50 93 104 1887 2221
083 LIST sort 3299 3578 3293 6723 7021 10959 9644
084 LIST typed sort 2739 2943 2660 4737 4651 28889 23969
085 LIST remove first element 317 296 363 806 866 625 522
086 LIST remove middle element 325 291 358 692 876 656 677
087 LIST remove last element 318 293 360 689 879 754 675
088 LIST replace first element 310 289 346 722 917 727 978
089 LIST replace middle element 316 286 353 693 1045 1024 876
090 LIST replace last element 316 283 346 963 832 1450 1243
091 LIST replace first el with multiple 333 304 372 819 938 702 612
092 LIST replace middle el with multiple 319 310 351 691 736 1088 1123
093 LIST replace last el with multiple 319 282 347 813 740 1413 1313
094 LIST replace range 294 282 343 744 866 1198 971
095 LIST remove in mixed list 389 374 2195 833 999 829 617
096 LIST replace in mixed list 377 352 2184 1054 925 756 592
097 LIST index first element 18 10 13 16 25 451 375
098 LIST index middle element 17 10 13 16 23 516 536
099 LIST index last element 17 11 13 13 17 622 663
100 LIST insert an item at start 291 298 366 775 805 729 563
101 LIST insert an item at middle 269 266 370 684 667 978 630
102 LIST insert an item at "end" 257 254 349 670 1013 1779 1200
103 LIST small, early range 23 19 16 42 35 500 383
104 LIST small, late range 23 18 16 28 38 618 685
105 LIST large, early range 37 29 24 54 108 511 697
106 LIST large, late range 40 30 21 81 131 567 551
107 LIST append to list 409 401 396 917 1032 737 682
108 LIST join list 1053 1072 1066 1818 1453 3672 3167
109 LOOP for, iterate list 6616 5198 5372 13766 9653 662376 583297
110 LOOP foreach, iterate list 1919 1845 1952 3750 3553 11561 12556
111 LOOP for (to 1000) 2566 2674 3065 4639 4867 66896 73851
112 LOOP while (to 1000) 2568 2942 3065 4551 4637 69891 80404
113 LOOP for, iterate string 6456 9440 9637 141594 14530 219770 199570
114 LOOP foreach, iterate string 2240 2249 3955 9099 8147 15468 13206
115 MAP string 1 val 679 5931 6028 9096 (8.2+) (8.2+) (8.2+)
116 MAP string 2 val 1562 6643 6877 12943 (8.2+) (8.2+) (8.2+)
117 MAP string 3 val 1836 7673 7832 12825 (8.2+) (8.2+) (8.2+)
118 MAP string 4 val 2510 8429 8622 17267 (8.2+) (8.2+) (8.2+)
119 MAP string 1 val -nocase 3497 10259 10381 17685 (8.2+) (8.2+) (8.2+)
120 MAP string 2 val -nocase 6218 14570 15024 27379 (8.2+) (8.2+) (8.2+)
121 MAP string 3 val -nocase 8364 19344 18973 35569 (8.2+) (8.2+) (8.2+)
122 MAP string 4 val -nocase 10135 21861 22132 39660 (8.2+) (8.2+) (8.2+)
123 MAP regsub 1 val 3702 3954 4303 9663 1830 4430 3684
124 MAP regsub 2 val 16066 16981 18176 41500 4184 9394 11576
125 MAP regsub 3 val 21671 23258 24817 52315 6075 11441 12456
126 MAP regsub 4 val 26657 29335 31350 67973 8659 15319 13884
127 MAP regsub 1 val -nocase 3686 3913 4332 9463 2766 4729 4488
128 MAP regsub 2 val -nocase 15821 17024 18134 40735 5881 9546 11911
129 MAP regsub 3 val -nocase 20987 23228 24747 52639 8625 12501 14437
130 MAP regsub 4 val -nocase 26227 29397 31314 66937 11664 14510 16818
131 MAP string, no match 926 7712 8028 14020 (8.2+) (8.2+) (8.2+)
132 MAP string -nocase, no match 6726 18725 18933 35683 (8.2+) (8.2+) (8.2+)
133 MAP regsub, no match 1149 2764 2830 6704 1843 3352 4823
134 MAP regsub -nocase, no match 1151 2785 2890 6609 3563 4499 5249
135 MAP string short 37 41 39 116 (8.2+) (8.2+) (8.2+)
136 MAP regsub short 164 180 193 308 154 244 432
137 MTHD direct ns proc call 10 6 8 3 7
138 MTHD imported ns proc call 11 6 7 5 7
139 MTHD interp alias proc call 25 18 18 18 9
140 MTHD indirect proc eval 36 29 61 56 72
141 MTHD indirect proc eval #2 58 48 57 81 107
142 MTHD array stored proc call 14 9 10 22 19
143 MTHD switch method call 50 38 83 119 172
144 MTHD ns lookup call 99 81 216 374 376
145 MTHD inline call 5 3 3 2 2
146 PROC explicit return 15 7 8 7 7 11 11
147 PROC implicit return 11 6 7 4 11 16 15
148 PROC explicit return (2) 12 7 8 13 13 14 10
149 PROC implicit return (2) 10 6 7 10 18 21 24
150 PROC explicit return (3) 10 7 7 4 14 14 25
151 PROC implicit return (3) 10 6 7 3 12 10 18
152 PROC heavily commented 10 5 6 12 5 629 753
153 PROC do-nothing, no args 8 5 28 38 4 5 2
154 PROC do-nothing, one arg 10 5 6 9 8 15 21
155 PROC local links with global 1579 1569 1626 3586 4533 7955 11505
156 PROC local links with upvar 1287 1166 1387 2806 2922 8371 10317
157 PROC local links with variable 1195 1101 1334 2614 1050 9091 9212
158 READ 595K, gets 340064 299797 306109 819327 372526 978472 985676
159 READ 595K, read 77751 97698 97019 227338 2936958 3774669 3834017
160 READ 595K, read & size 77606 97909 97074 242255 124776 3696432 3704813
161 READ 3050b, gets 1869 1641 2052 4118 954 2074 2201
162 READ 3050b, read 522 494 494 789 748 503 415
163 READ 3050b, read & size 569 534 530 790 410 467 361
164 BREAD 595K, gets 350077 292326 304961 833500 365165 953379 979961
165 BREAD 595K, read 50105 50454 50018 228963 2952787 3640795 3741298
166 BREAD 595K, read & size 50303 50486 50140 246365 87019 3685978 3688120
167 BREAD 3050b, gets 2097 1777 1774 5220 1062 2208 2178
168 BREAD 3050b, read 340 347 334 1310 412 458 359
169 BREAD 3050b, read & size 396 389 369 1144 1230 390 495
170 REGEXP literal regexp 39 37 38 42 31 26 26
171 REGEXP var-based regexp 41 40 40 55 45 30 61
172 REGEXP count all matches 137 139 530 1280 1332 2277 2776
173 REGEXP extract all matches 169 177 616 1790 1129 3068 3620
174 STARTUP time to launch tclsh 21138 20425 18293 85723 102877 70500 90323
175 STR str [string compare] 18 26 24 17 26 199 193
176 STR str [string equal] 18 25 23 68 38 160 198
177 STR str $a equal "" 17 26 24 81 52 670 410
178 STR str num == "" 19 14 24 36 52 338 419
179 STR str $a eq $b 22 33 31 39 56 231 261
180 STR str $a ne $b 23 31 30 85 47 226 265
181 STR str $a eq $b (same obj) 22 33 36 161 53 271 338
182 STR str $a ne $b (same obj) 21 33 30 28 57 203 235
183 STR length (==4010) 15 14 13 678 17 508 867
184 STR index 0 26 19 19 487 30 522 614
185 STR index 100 21 24 19 500 43 491 601
186 STR index 500 21 18 19 483 42 489 493
187 STR index2 0 21 19 19 494 27 485 583
188 STR index2 100 20 19 19 470 26 557 459
189 STR index2 500 21 19 19 484 40 764 468
190 STR first (success) 19 16 15 21 33 533 519
191 STR first (failure) 120 56 50 123 117 697 822
192 STR first (total failure) 109 42 28 54 57 545 631
193 STR last (success) 19 229 224 469 18 815 728
194 STR last (failure) 90 99 91 185 201 657 859
195 STR last (total failure) 82 90 83 135 151 584 1153
196 STR match, simple (success early) 17 14 13 25 33 503 489
197 STR match, simple (success late) 16 14 13 11 27 619 502
198 STR match, simple (failure) 17 15 13 26 36 421 680
199 STR match, simple (total failure) 16 18 13 17 30 456 378
200 STR match, complex (success early) 17 23 22 33 35 466 448
201 STR match, complex (success late) 145 1020 1040 2173 926 1529 1676
202 STR match, complex (failure) 122 1011 1010 1785 964 1357 1698
203 STR match, complex (total failure) 90 994 994 1844 1216 1725 1602
204 STR range, index 100..200 of 4010 26 21 21 716 25 589 609
205 STR replace, no replacement 79 270 264 570 166 1217 1315
206 STR replace, equal replacement 92 277 257 526 140 1560 1263
207 STR replace, longer replacement 95 270 265 551 103 1563 1309
208 STR repeat, abcdefghij * 10 19 22 22 21 199 997 963
209 STR repeat, abcdefghij * 100 39 72 74 120 1267 8488 9065
210 STR repeat, abcdefghij * 1000 245 565 557 798 12264 81587 86928
211 STR repeat, 4010 chars * 10 314 797 671 1971 1494 11891 7688
212 STR repeat, 4010 chars * 100 7347 18287 18194 47967 69328 105423 107290
213 STR reverse iter1, 100 chars 1285 1628 1425 4104 1871 8459 8704
214 STR reverse iter1, 100 uchars 1264 1768 1436 4448 1864 8250 9034
215 STR reverse iter2, 100 chars 808 1252 1168 3860 2099 8379 8292
216 STR reverse iter2, 100 uchars 807 1259 1096 4086 1602 9513 5431
217 STR reverse recur1, 100 chars 4092 4770 3998 8749 8470 20868 11271
218 STR reverse recur1, 100 uchars 4169 5467 4767 8794 9075 21634 13821
219 STR split, 4010 chars 2663 2138 8847 23626 18954 4372 3169
220 STR split, 12100 uchars 7207 6395
221 STR split iter, 4010 chars 9349 9372 16664 39846 35962 52886 48521
222 STR split iter, 12100 uchars 28171 28299
223 STR append 100 82 71 108 164 1055 1145
224 STR append (1KB + 1KB) 65 55 49 96 79 236 290
225 STR append (10KB + 1KB) 186 193 196 474 75 215 213
226 STR append (1MB + 2b * 1000) 37786 70498 74635 178639 12391 82339 84345
227 STR append (1MB + 1KB) 29729 63374 61479 136891 68 215 335
228 STR append (1MB + 1KB * 20) 29635 64566 61865 127033 270 1551 1724
229 STR append (1MB + 1KB * 1000) 66605 94413 101998 177875 10955 78370 81930
230 STR append (1MB + 1MB * 3) 126103 153051 157370 282029 218 248 876
231 STR append (1MB + 1MB * 5) 157407 303871 315407 1051814 45 543 342
232 STR append (1MB + (1b + 1K + 1b) * 100) 33118 63834 69167 290360 2398 8930 9893
233 STR info locals match 828 818 993 2025 1518 8071 9043
234 TRACE no trace set 35 25 26 18 27 42 91
235 TRACE read 35 26 26 16 59 128 113
236 TRACE write 35 25 26 16 55 78 78
237 TRACE unset 35 26 26 16 70 94 112
238 TRACE all set (rwu) 35 25 25 18 59 77 105
239 UNSET var exists 14 8 9 8 16 27 37
240 UNSET catch var exists 16 9 10 52 20 61 58
241 UNSET catch var !exist 69 64 59 191 120 77 96
242 UNSET info check var exists 19 14 13 69 27 80 78
243 UNSET info check var !exist 16 11 11 6 17 73 64
244 UNSET nocomplain var exists 14 9 10 35 20 52 56
245 UNSET nocomplain var !exist 14 64 59 157 122 90 109
246 VAR access locally set 14 8 10 18 20 106 67
247 VAR access local proc arg 14 9 10 6 26 88 110
248 VAR access global 34 25 26 101 61 82 121
249 VAR access upvar 36 29 30 103 65 97 101
250 VAR set scalar 10 6 7 4 11 35 74
251 VAR set array element 18 12 14 9 33 59 35
252 VAR 100 'set's in array 162 133 160 296 292 917 827
253 VAR 'array set' of 100 elems 293 251 264 741 816 1063 993

DELETED examples/csv/Benchmark.75p2.csv Index: examples/csv/Benchmark.75p2.csv ================================================================== --- examples/csv/Benchmark.75p2.csv +++ /dev/null @@ -1,215 +0,0 @@ -000,VERSIONS:,1:7.5p1 -001,CATCH return ok,17 -002,CATCH return error,33 -003,CATCH no catch used,9 -004,IF if true numeric,61 -005,IF elseif true numeric,292 -006,IF else true numeric,82 -007,IF if true num/num,174 -008,IF if false num/num,182 -009,IF if false al/num,121 -010,IF if true al/al,184 -011,IF if false al/al,243 -012,IF if true al,76 -013,IF elseif true al,154 -014,IF else true al,323 -015,SWITCH first true,241 -016,SWITCH second true,282 -017,SWITCH ninth true,284 -018,SWITCH default true,292 -019,DATA create in a list,29501 -020,DATA create in an array,40784 -021,DATA access in a list,175028 -022,DATA access in an array,39744 -023,EVAL cmd eval in list obj var,26 -024,EVAL cmd eval as list,52 -025,EVAL cmd eval as string,64 -026,EVAL cmd and mixed lists,2112 -027,EVAL list cmd and mixed lists,2259 -028,EVAL list cmd and pure lists,2245 -029,EXPR unbraced,365 -030,EXPR braced,386 -031,EXPR inline,177 -032,EXPR one operand,65 -033,EXPR ten operands,141 -034,EXPR fifty operands,430 -035,EXPR incr with incr,45 -036,EXPR incr with expr,74 -037,FCOPY std: 160010 bytes,26979 -038,"STR/LIST length, obj shimmer",2638 -039,"LIST length, pure list",1837 -040,STR length of a LIST,400 -041,"LIST exact search, first item",1693 -042,"LIST exact search, middle item",1944 -043,"LIST exact search, last item",2009 -044,"LIST exact search, non-item",2118 -045,"LIST sorted search, first item",1610 -046,"LIST sorted search, middle item",2252 -047,"LIST sorted search, last item",1784 -048,"LIST sorted search, non-item",2057 -049,"LIST exact search, untyped item",2218 -050,"LIST exact search, typed item",1872 -051,"LIST sorted search, typed item",2221 -052,LIST sort,9644 -053,LIST typed sort,23969 -054,LIST remove first element,522 -055,LIST remove middle element,677 -056,LIST remove last element,675 -057,LIST replace first element,978 -058,LIST replace middle element,876 -059,LIST replace last element,1243 -060,LIST replace first el with multiple,612 -061,LIST replace middle el with multiple,1123 -062,LIST replace last el with multiple,1313 -063,LIST replace range,971 -064,LIST remove in mixed list,617 -065,LIST replace in mixed list,592 -066,LIST index first element,375 -067,LIST index middle element,536 -068,LIST index last element,663 -069,LIST insert an item at start,563 -070,LIST insert an item at middle,630 -071,"LIST insert an item at ""end""",1200 -072,"LIST small, early range",383 -073,"LIST small, late range",685 -074,"LIST large, early range",697 -075,"LIST large, late range",551 -076,LIST append to list,682 -077,LIST join list,3167 -078,"LOOP for, iterate list",583297 -079,"LOOP foreach, iterate list",12556 -080,LOOP for (to 1000),73851 -081,LOOP while (to 1000),80404 -082,"LOOP for, iterate string",199570 -083,"LOOP foreach, iterate string",13206 -084,MAP string 1 val,(8.2+) -085,MAP string 2 val,(8.2+) -086,MAP string 3 val,(8.2+) -087,MAP string 4 val,(8.2+) -088,MAP string 1 val -nocase,(8.2+) -089,MAP string 2 val -nocase,(8.2+) -090,MAP string 3 val -nocase,(8.2+) -091,MAP string 4 val -nocase,(8.2+) -092,MAP regsub 1 val,3684 -093,MAP regsub 2 val,11576 -094,MAP regsub 3 val,12456 -095,MAP regsub 4 val,13884 -096,MAP regsub 1 val -nocase,4488 -097,MAP regsub 2 val -nocase,11911 -098,MAP regsub 3 val -nocase,14437 -099,MAP regsub 4 val -nocase,16818 -100,"MAP string, no match",(8.2+) -101,"MAP string -nocase, no match",(8.2+) -102,"MAP regsub, no match",4823 -103,"MAP regsub -nocase, no match",5249 -104,MAP string short,(8.2+) -105,MAP regsub short,432 -106,PROC explicit return,11 -107,PROC implicit return,15 -108,PROC explicit return (2),10 -109,PROC implicit return (2),24 -110,PROC explicit return (3),25 -111,PROC implicit return (3),18 -112,PROC heavily commented,753 -113,"PROC do-nothing, no args",2 -114,"PROC do-nothing, one arg",21 -115,PROC local links with global,11505 -116,PROC local links with upvar,10317 -117,PROC local links with variable,9212 -118,"READ 595K, gets",985676 -119,"READ 595K, read",3834017 -120,"READ 595K, read & size",3704813 -121,"READ 3050b, gets",2201 -122,"READ 3050b, read",415 -123,"READ 3050b, read & size",361 -124,"BREAD 595K, gets",979961 -125,"BREAD 595K, read",3741298 -126,"BREAD 595K, read & size",3688120 -127,"BREAD 3050b, gets",2178 -128,"BREAD 3050b, read",359 -129,"BREAD 3050b, read & size",495 -130,REGEXP literal regexp,26 -131,REGEXP var-based regexp,61 -132,REGEXP count all matches,2776 -133,REGEXP extract all matches,3620 -134,STARTUP time to launch tclsh,90323 -135,STR str [string compare],193 -136,STR str [string equal],198 -137,"STR str $a equal """"",410 -138,"STR str num == """"",419 -139,STR str $a eq $b,261 -140,STR str $a ne $b,265 -141,STR str $a eq $b (same obj),338 -142,STR str $a ne $b (same obj),235 -143,STR length (==4010),867 -144,STR index 0,614 -145,STR index 100,601 -146,STR index 500,493 -147,STR index2 0,583 -148,STR index2 100,459 -149,STR index2 500,468 -150,STR first (success),519 -151,STR first (failure),822 -152,STR first (total failure),631 -153,STR last (success),728 -154,STR last (failure),859 -155,STR last (total failure),1153 -156,"STR match, simple (success early)",489 -157,"STR match, simple (success late)",502 -158,"STR match, simple (failure)",680 -159,"STR match, simple (total failure)",378 -160,"STR match, complex (success early)",448 -161,"STR match, complex (success late)",1676 -162,"STR match, complex (failure)",1698 -163,"STR match, complex (total failure)",1602 -164,"STR range, index 100..200 of 4010",609 -165,"STR replace, no replacement",1315 -166,"STR replace, equal replacement",1263 -167,"STR replace, longer replacement",1309 -168,"STR repeat, abcdefghij * 10",963 -169,"STR repeat, abcdefghij * 100",9065 -170,"STR repeat, abcdefghij * 1000",86928 -171,"STR repeat, 4010 chars * 10",7688 -172,"STR repeat, 4010 chars * 100",107290 -173,"STR reverse iter1, 100 chars",8704 -174,"STR reverse iter1, 100 uchars",9034 -175,"STR reverse iter2, 100 chars",8292 -176,"STR reverse iter2, 100 uchars",5431 -177,"STR reverse recur1, 100 chars",11271 -178,"STR reverse recur1, 100 uchars",13821 -179,"STR split, 4010 chars",3169 -180,"STR split, 12000 uchars",9080 -181,"STR split iter, 4010 chars",48521 -182,"STR split iter, 12000 uchars",156287 -183,STR append,1145 -184,STR append (1KB + 1KB),290 -185,STR append (10KB + 1KB),213 -186,STR append (1MB + 2b * 1000),84345 -187,STR append (1MB + 1KB),335 -188,STR append (1MB + 1KB * 20),1724 -189,STR append (1MB + 1KB * 1000),81930 -190,STR append (1MB + 1MB * 3),876 -191,STR append (1MB + 1MB * 5),342 -192,STR append (1MB + (1b + 1K + 1b) * 100),9893 -193,STR info locals match,9043 -194,TRACE no trace set,91 -195,TRACE read,113 -196,TRACE write,78 -197,TRACE unset,112 -198,TRACE all set (rwu),105 -199,UNSET var exists,37 -200,UNSET catch var exists,58 -201,UNSET catch var !exist,96 -202,UNSET info check var exists,78 -203,UNSET info check var !exist,64 -204,UNSET nocomplain var exists,56 -205,UNSET nocomplain var !exist,109 -206,VAR access locally set,67 -207,VAR access local proc arg,110 -208,VAR access global,121 -209,VAR access upvar,101 -210,VAR set scalar,74 -211,VAR set array element,35 -212,VAR 100 'set's in array,827 -213,VAR 'array set' of 100 elems,993 - DELETED examples/csv/Benchmark.76p2.csv Index: examples/csv/Benchmark.76p2.csv ================================================================== --- examples/csv/Benchmark.76p2.csv +++ /dev/null @@ -1,215 +0,0 @@ -000,VERSIONS:,1:7.6p2 -001,CATCH return ok,28 -002,CATCH return error,146 -003,CATCH no catch used,24 -004,IF if true numeric,152 -005,IF elseif true numeric,299 -006,IF else true numeric,318 -007,IF if true num/num,329 -008,IF if false num/num,202 -009,IF if false al/num,467 -010,IF if true al/al,292 -011,IF if false al/al,217 -012,IF if true al,214 -013,IF elseif true al,358 -014,IF else true al,292 -015,SWITCH first true,391 -016,SWITCH second true,340 -017,SWITCH ninth true,391 -018,SWITCH default true,492 -019,DATA create in a list,40180 -020,DATA create in an array,53723 -021,DATA access in a list,182889 -022,DATA access in an array,43232 -023,EVAL cmd eval in list obj var,27 -024,EVAL cmd eval as list,22 -025,EVAL cmd eval as string,26 -026,EVAL cmd and mixed lists,3017 -027,EVAL list cmd and mixed lists,2936 -028,EVAL list cmd and pure lists,2653 -029,EXPR unbraced,313 -030,EXPR braced,505 -031,EXPR inline,321 -032,EXPR one operand,47 -033,EXPR ten operands,159 -034,EXPR fifty operands,708 -035,EXPR incr with incr,31 -036,EXPR incr with expr,73 -037,FCOPY std: 160010 bytes,29538 -038,"STR/LIST length, obj shimmer",2585 -039,"LIST length, pure list",2023 -040,STR length of a LIST,525 -041,"LIST exact search, first item",2303 -042,"LIST exact search, middle item",1787 -043,"LIST exact search, last item",2261 -044,"LIST exact search, non-item",2099 -045,"LIST sorted search, first item",1862 -046,"LIST sorted search, middle item",1623 -047,"LIST sorted search, last item",2145 -048,"LIST sorted search, non-item",1999 -049,"LIST exact search, untyped item",2166 -050,"LIST exact search, typed item",2072 -051,"LIST sorted search, typed item",1887 -052,LIST sort,10959 -053,LIST typed sort,28889 -054,LIST remove first element,625 -055,LIST remove middle element,656 -056,LIST remove last element,754 -057,LIST replace first element,727 -058,LIST replace middle element,1024 -059,LIST replace last element,1450 -060,LIST replace first el with multiple,702 -061,LIST replace middle el with multiple,1088 -062,LIST replace last el with multiple,1413 -063,LIST replace range,1198 -064,LIST remove in mixed list,829 -065,LIST replace in mixed list,756 -066,LIST index first element,451 -067,LIST index middle element,516 -068,LIST index last element,622 -069,LIST insert an item at start,729 -070,LIST insert an item at middle,978 -071,"LIST insert an item at ""end""",1779 -072,"LIST small, early range",500 -073,"LIST small, late range",618 -074,"LIST large, early range",511 -075,"LIST large, late range",567 -076,LIST append to list,737 -077,LIST join list,3672 -078,"LOOP for, iterate list",662376 -079,"LOOP foreach, iterate list",11561 -080,LOOP for (to 1000),66896 -081,LOOP while (to 1000),69891 -082,"LOOP for, iterate string",219770 -083,"LOOP foreach, iterate string",15468 -084,MAP string 1 val,(8.2+) -085,MAP string 2 val,(8.2+) -086,MAP string 3 val,(8.2+) -087,MAP string 4 val,(8.2+) -088,MAP string 1 val -nocase,(8.2+) -089,MAP string 2 val -nocase,(8.2+) -090,MAP string 3 val -nocase,(8.2+) -091,MAP string 4 val -nocase,(8.2+) -092,MAP regsub 1 val,4430 -093,MAP regsub 2 val,9394 -094,MAP regsub 3 val,11441 -095,MAP regsub 4 val,15319 -096,MAP regsub 1 val -nocase,4729 -097,MAP regsub 2 val -nocase,9546 -098,MAP regsub 3 val -nocase,12501 -099,MAP regsub 4 val -nocase,14510 -100,"MAP string, no match",(8.2+) -101,"MAP string -nocase, no match",(8.2+) -102,"MAP regsub, no match",3352 -103,"MAP regsub -nocase, no match",4499 -104,MAP string short,(8.2+) -105,MAP regsub short,244 -106,PROC explicit return,11 -107,PROC implicit return,16 -108,PROC explicit return (2),14 -109,PROC implicit return (2),21 -110,PROC explicit return (3),14 -111,PROC implicit return (3),10 -112,PROC heavily commented,629 -113,"PROC do-nothing, no args",5 -114,"PROC do-nothing, one arg",15 -115,PROC local links with global,7955 -116,PROC local links with upvar,8371 -117,PROC local links with variable,9091 -118,"READ 595K, gets",978472 -119,"READ 595K, read",3774669 -120,"READ 595K, read & size",3696432 -121,"READ 3050b, gets",2074 -122,"READ 3050b, read",503 -123,"READ 3050b, read & size",467 -124,"BREAD 595K, gets",953379 -125,"BREAD 595K, read",3640795 -126,"BREAD 595K, read & size",3685978 -127,"BREAD 3050b, gets",2208 -128,"BREAD 3050b, read",458 -129,"BREAD 3050b, read & size",390 -130,REGEXP literal regexp,26 -131,REGEXP var-based regexp,30 -132,REGEXP count all matches,2277 -133,REGEXP extract all matches,3068 -134,STARTUP time to launch tclsh,70500 -135,STR str [string compare],199 -136,STR str [string equal],160 -137,"STR str $a equal """"",670 -138,"STR str num == """"",338 -139,STR str $a eq $b,231 -140,STR str $a ne $b,226 -141,STR str $a eq $b (same obj),271 -142,STR str $a ne $b (same obj),203 -143,STR length (==4010),508 -144,STR index 0,522 -145,STR index 100,491 -146,STR index 500,489 -147,STR index2 0,485 -148,STR index2 100,557 -149,STR index2 500,764 -150,STR first (success),533 -151,STR first (failure),697 -152,STR first (total failure),545 -153,STR last (success),815 -154,STR last (failure),657 -155,STR last (total failure),584 -156,"STR match, simple (success early)",503 -157,"STR match, simple (success late)",619 -158,"STR match, simple (failure)",421 -159,"STR match, simple (total failure)",456 -160,"STR match, complex (success early)",466 -161,"STR match, complex (success late)",1529 -162,"STR match, complex (failure)",1357 -163,"STR match, complex (total failure)",1725 -164,"STR range, index 100..200 of 4010",589 -165,"STR replace, no replacement",1217 -166,"STR replace, equal replacement",1560 -167,"STR replace, longer replacement",1563 -168,"STR repeat, abcdefghij * 10",997 -169,"STR repeat, abcdefghij * 100",8488 -170,"STR repeat, abcdefghij * 1000",81587 -171,"STR repeat, 4010 chars * 10",11891 -172,"STR repeat, 4010 chars * 100",105423 -173,"STR reverse iter1, 100 chars",8459 -174,"STR reverse iter1, 100 uchars",8250 -175,"STR reverse iter2, 100 chars",8379 -176,"STR reverse iter2, 100 uchars",9513 -177,"STR reverse recur1, 100 chars",20868 -178,"STR reverse recur1, 100 uchars",21634 -179,"STR split, 4010 chars",4372 -180,"STR split, 12000 uchars",15202 -181,"STR split iter, 4010 chars",52886 -182,"STR split iter, 12000 uchars",162558 -183,STR append,1055 -184,STR append (1KB + 1KB),236 -185,STR append (10KB + 1KB),215 -186,STR append (1MB + 2b * 1000),82339 -187,STR append (1MB + 1KB),215 -188,STR append (1MB + 1KB * 20),1551 -189,STR append (1MB + 1KB * 1000),78370 -190,STR append (1MB + 1MB * 3),248 -191,STR append (1MB + 1MB * 5),543 -192,STR append (1MB + (1b + 1K + 1b) * 100),8930 -193,STR info locals match,8071 -194,TRACE no trace set,42 -195,TRACE read,128 -196,TRACE write,78 -197,TRACE unset,94 -198,TRACE all set (rwu),77 -199,UNSET var exists,27 -200,UNSET catch var exists,61 -201,UNSET catch var !exist,77 -202,UNSET info check var exists,80 -203,UNSET info check var !exist,73 -204,UNSET nocomplain var exists,52 -205,UNSET nocomplain var !exist,90 -206,VAR access locally set,106 -207,VAR access local proc arg,88 -208,VAR access global,82 -209,VAR access upvar,97 -210,VAR set scalar,35 -211,VAR set array element,59 -212,VAR 100 'set's in array,917 -213,VAR 'array set' of 100 elems,1063 - DELETED examples/csv/Benchmark.805.csv Index: examples/csv/Benchmark.805.csv ================================================================== --- examples/csv/Benchmark.805.csv +++ /dev/null @@ -1,252 +0,0 @@ -000,VERSIONS:,1:8.0.5 -001,CATCH return ok,5 -002,CATCH return error,204 -003,CATCH no catch used,4 -004,IF if true numeric,9 -005,IF elseif true numeric,11 -006,IF else true numeric,11 -007,IF if true num/num,9 -008,IF if false num/num,9 -009,IF if false al/num,17 -010,IF if true al/al,169 -011,IF if false al/al,60 -012,IF if true al,51 -013,IF elseif true al,156 -014,IF else true al,51 -015,SWITCH first true,73 -016,SWITCH second true,62 -017,SWITCH ninth true,112 -018,SWITCH default true,77 -019,DATA create in a list,7886 -020,DATA create in an array,16792 -021,DATA access in a list,7024 -022,DATA access in an array,7640 -023,EVAL cmd eval in list obj var,84 -024,EVAL cmd eval as list,144 -025,EVAL cmd eval as string,90 -026,EVAL cmd and mixed lists,13914 -027,EVAL list cmd and mixed lists,14703 -028,EVAL list cmd and pure lists,12611 -029,EXPR unbraced,331 -030,EXPR braced,92 -031,EXPR inline,59 -032,EXPR one operand,11 -033,EXPR ten operands,20 -034,EXPR fifty operands,85 -035,EXPR incr with incr,22 -036,EXPR incr with expr,13 -037,FCOPY std: 160010 bytes,26557 -038,KLIST shuffle0 llength 1,367 -039,KLIST shuffle0 llength 10,728 -040,KLIST shuffle0 llength 100,6484 -041,KLIST shuffle0 llength 1000,81157 -042,KLIST shuffle0 llength 10000,1161217 -043,KLIST shuffle1 llength 1,149 -044,KLIST shuffle1 llength 10,634 -045,KLIST shuffle1 llength 100,8576 -046,KLIST shuffle1 llength 1000,1736049 -047,KLIST shuffle1a llength 1,150 -048,KLIST shuffle1a llength 10,910 -049,KLIST shuffle1a llength 100,9480 -050,KLIST shuffle1a llength 1000,95305 -051,KLIST shuffle1a llength 10000,1004602 -052,KLIST shuffle2 llength 1,229 -053,KLIST shuffle2 llength 10,1080 -054,KLIST shuffle2 llength 100,9803 -055,KLIST shuffle2 llength 1000,116933 -056,KLIST shuffle2 llength 10000,1304458 -057,KLIST shuffle3 llength 1,170 -058,KLIST shuffle3 llength 10,832 -059,KLIST shuffle3 llength 100,7632 -060,KLIST shuffle3 llength 1000,82985 -061,KLIST shuffle3 llength 10000,1732151 -062,KLIST shuffle4 llength 1,178 -063,KLIST shuffle4 llength 10,876 -064,KLIST shuffle4 llength 100,8278 -065,KLIST shuffle4 llength 1000,80450 -066,KLIST shuffle4 llength 10000,834612 -067,"STR/LIST length, obj shimmer",28 -068,"LIST length, pure list",18 -069,STR length of a LIST,23 -070,"LIST exact search, first item",32 -071,"LIST exact search, middle item",38 -072,"LIST exact search, last item",111 -073,"LIST exact search, non-item",220 -074,"LIST sorted search, first item",29 -075,"LIST sorted search, middle item",40 -076,"LIST sorted search, last item",121 -077,"LIST sorted search, non-item",257 -078,"LIST exact search, untyped item",101 -079,"LIST exact search, typed item",111 -080,"LIST sorted search, typed item",104 -081,LIST sort,7021 -082,LIST typed sort,4651 -083,LIST remove first element,866 -084,LIST remove middle element,876 -085,LIST remove last element,879 -086,LIST replace first element,917 -087,LIST replace middle element,1045 -088,LIST replace last element,832 -089,LIST replace first el with multiple,938 -090,LIST replace middle el with multiple,736 -091,LIST replace last el with multiple,740 -092,LIST replace range,866 -093,LIST remove in mixed list,999 -094,LIST replace in mixed list,925 -095,LIST index first element,25 -096,LIST index middle element,23 -097,LIST index last element,17 -098,LIST insert an item at start,805 -099,LIST insert an item at middle,667 -100,"LIST insert an item at ""end""",1013 -101,"LIST small, early range",35 -102,"LIST small, late range",38 -103,"LIST large, early range",108 -104,"LIST large, late range",131 -105,LIST append to list,1032 -106,LIST join list,1453 -107,"LOOP for, iterate list",9653 -108,"LOOP foreach, iterate list",3553 -109,LOOP for (to 1000),4867 -110,LOOP while (to 1000),4637 -111,"LOOP for, iterate string",14530 -112,"LOOP foreach, iterate string",8147 -113,MAP string 1 val,(8.2+) -114,MAP string 2 val,(8.2+) -115,MAP string 3 val,(8.2+) -116,MAP string 4 val,(8.2+) -117,MAP string 1 val -nocase,(8.2+) -118,MAP string 2 val -nocase,(8.2+) -119,MAP string 3 val -nocase,(8.2+) -120,MAP string 4 val -nocase,(8.2+) -121,MAP regsub 1 val,1830 -122,MAP regsub 2 val,4184 -123,MAP regsub 3 val,6075 -124,MAP regsub 4 val,8659 -125,MAP regsub 1 val -nocase,2766 -126,MAP regsub 2 val -nocase,5881 -127,MAP regsub 3 val -nocase,8625 -128,MAP regsub 4 val -nocase,11664 -129,"MAP string, no match",(8.2+) -130,"MAP string -nocase, no match",(8.2+) -131,"MAP regsub, no match",1843 -132,"MAP regsub -nocase, no match",3563 -133,MAP string short,(8.2+) -134,MAP regsub short,154 -135,MTHD direct ns proc call,7 -136,MTHD imported ns proc call,7 -137,MTHD interp alias proc call,9 -138,MTHD indirect proc eval,72 -139,MTHD indirect proc eval #2,107 -140,MTHD array stored proc call,19 -141,MTHD switch method call,172 -142,MTHD ns lookup call,376 -143,MTHD inline call,2 -144,PROC explicit return,7 -145,PROC implicit return,11 -146,PROC explicit return (2),13 -147,PROC implicit return (2),18 -148,PROC explicit return (3),14 -149,PROC implicit return (3),12 -150,PROC heavily commented,5 -151,"PROC do-nothing, no args",4 -152,"PROC do-nothing, one arg",8 -153,PROC local links with global,4533 -154,PROC local links with upvar,2922 -155,PROC local links with variable,1050 -156,"READ 595K, gets",372526 -157,"READ 595K, read",2936958 -158,"READ 595K, read & size",124776 -159,"READ 3050b, gets",954 -160,"READ 3050b, read",748 -161,"READ 3050b, read & size",410 -162,"BREAD 595K, gets",365165 -163,"BREAD 595K, read",2952787 -164,"BREAD 595K, read & size",87019 -165,"BREAD 3050b, gets",1062 -166,"BREAD 3050b, read",412 -167,"BREAD 3050b, read & size",1230 -168,REGEXP literal regexp,31 -169,REGEXP var-based regexp,45 -170,REGEXP count all matches,1332 -171,REGEXP extract all matches,1129 -172,STARTUP time to launch tclsh,102877 -173,STR str [string compare],26 -174,STR str [string equal],38 -175,"STR str $a equal """"",52 -176,"STR str num == """"",52 -177,STR str $a eq $b,56 -178,STR str $a ne $b,47 -179,STR str $a eq $b (same obj),53 -180,STR str $a ne $b (same obj),57 -181,STR length (==4010),17 -182,STR index 0,30 -183,STR index 100,43 -184,STR index 500,42 -185,STR index2 0,27 -186,STR index2 100,26 -187,STR index2 500,40 -188,STR first (success),33 -189,STR first (failure),117 -190,STR first (total failure),57 -191,STR last (success),18 -192,STR last (failure),201 -193,STR last (total failure),151 -194,"STR match, simple (success early)",33 -195,"STR match, simple (success late)",27 -196,"STR match, simple (failure)",36 -197,"STR match, simple (total failure)",30 -198,"STR match, complex (success early)",35 -199,"STR match, complex (success late)",926 -200,"STR match, complex (failure)",964 -201,"STR match, complex (total failure)",1216 -202,"STR range, index 100..200 of 4010",25 -203,"STR replace, no replacement",166 -204,"STR replace, equal replacement",140 -205,"STR replace, longer replacement",103 -206,"STR repeat, abcdefghij * 10",199 -207,"STR repeat, abcdefghij * 100",1267 -208,"STR repeat, abcdefghij * 1000",12264 -209,"STR repeat, 4010 chars * 10",1494 -210,"STR repeat, 4010 chars * 100",69328 -211,"STR reverse iter1, 100 chars",1871 -212,"STR reverse iter1, 100 uchars",1864 -213,"STR reverse iter2, 100 chars",2099 -214,"STR reverse iter2, 100 uchars",1602 -215,"STR reverse recur1, 100 chars",8470 -216,"STR reverse recur1, 100 uchars",9075 -217,"STR split, 4010 chars",18954 -218,"STR split, 12000 uchars",60753 -219,"STR split iter, 4010 chars",35962 -220,"STR split iter, 12000 uchars",108683 -221,STR append,164 -222,STR append (1KB + 1KB),79 -223,STR append (10KB + 1KB),75 -224,STR append (1MB + 2b * 1000),12391 -225,STR append (1MB + 1KB),68 -226,STR append (1MB + 1KB * 20),270 -227,STR append (1MB + 1KB * 1000),10955 -228,STR append (1MB + 1MB * 3),218 -229,STR append (1MB + 1MB * 5),45 -230,STR append (1MB + (1b + 1K + 1b) * 100),2398 -231,STR info locals match,1518 -232,TRACE no trace set,27 -233,TRACE read,59 -234,TRACE write,55 -235,TRACE unset,70 -236,TRACE all set (rwu),59 -237,UNSET var exists,16 -238,UNSET catch var exists,20 -239,UNSET catch var !exist,120 -240,UNSET info check var exists,27 -241,UNSET info check var !exist,17 -242,UNSET nocomplain var exists,20 -243,UNSET nocomplain var !exist,122 -244,VAR access locally set,20 -245,VAR access local proc arg,26 -246,VAR access global,61 -247,VAR access upvar,65 -248,VAR set scalar,11 -249,VAR set array element,33 -250,VAR 100 'set's in array,292 -251,VAR 'array set' of 100 elems,816 DELETED examples/csv/Benchmark.811.csv Index: examples/csv/Benchmark.811.csv ================================================================== --- examples/csv/Benchmark.811.csv +++ /dev/null @@ -1,254 +0,0 @@ -000,VERSIONS:,1:8.1.1 -001,CATCH return ok,4 -002,CATCH return error,54 -003,CATCH no catch used,13 -004,IF if true numeric,7 -005,IF elseif true numeric,20 -006,IF else true numeric,15 -007,IF if true num/num,22 -008,IF if false num/num,13 -009,IF if false al/num,29 -010,IF if true al/al,51 -011,IF if false al/al,51 -012,IF if true al,42 -013,IF elseif true al,89 -014,IF else true al,71 -015,SWITCH first true,58 -016,SWITCH second true,65 -017,SWITCH ninth true,73 -018,SWITCH default true,73 -019,DATA create in a list,12925 -020,DATA create in an array,12827 -021,DATA access in a list,10386 -022,DATA access in an array,6966 -023,EVAL cmd eval in list obj var,40 -024,EVAL cmd eval as list,88 -025,EVAL cmd eval as string,79 -026,EVAL cmd and mixed lists,21937 -027,EVAL list cmd and mixed lists,19014 -028,EVAL list cmd and pure lists,21974 -029,EXPR unbraced,23 -030,EXPR braced,53 -031,EXPR inline,68 -032,EXPR one operand,9 -033,EXPR ten operands,13 -034,EXPR fifty operands,71 -035,EXPR incr with incr,16 -036,EXPR incr with expr,11 -037,FCOPY std: 160010 bytes,25104 -038,FCOPY binary: 160010 bytes,25211 -039,FCOPY encoding: 160010 bytes,25972 -040,KLIST shuffle0 llength 1,271 -041,KLIST shuffle0 llength 10,901 -042,KLIST shuffle0 llength 100,8229 -043,KLIST shuffle0 llength 1000,92480 -044,KLIST shuffle0 llength 10000,1214997 -045,KLIST shuffle1 llength 1,163 -046,KLIST shuffle1 llength 10,718 -047,KLIST shuffle1 llength 100,9243 -048,KLIST shuffle1 llength 1000,1762135 -049,KLIST shuffle1a llength 1,172 -050,KLIST shuffle1a llength 10,768 -051,KLIST shuffle1a llength 100,8986 -052,KLIST shuffle1a llength 1000,84798 -053,KLIST shuffle1a llength 10000,861405 -054,KLIST shuffle2 llength 1,196 -055,KLIST shuffle2 llength 10,938 -056,KLIST shuffle2 llength 100,8904 -057,KLIST shuffle2 llength 1000,95513 -058,KLIST shuffle2 llength 10000,1176566 -059,KLIST shuffle3 llength 1,217 -060,KLIST shuffle3 llength 10,786 -061,KLIST shuffle3 llength 100,7161 -062,KLIST shuffle3 llength 1000,87353 -063,KLIST shuffle3 llength 10000,1789387 -064,KLIST shuffle4 llength 1,202 -065,KLIST shuffle4 llength 10,837 -066,KLIST shuffle4 llength 100,8572 -067,KLIST shuffle4 llength 1000,82985 -068,KLIST shuffle4 llength 10000,874454 -069,"STR/LIST length, obj shimmer",905 -070,"LIST length, pure list",21 -071,STR length of a LIST,529 -072,"LIST exact search, first item",17 -073,"LIST exact search, middle item",46 -074,"LIST exact search, last item",90 -075,"LIST exact search, non-item",212 -076,"LIST sorted search, first item",16 -077,"LIST sorted search, middle item",42 -078,"LIST sorted search, last item",84 -079,"LIST sorted search, non-item",201 -080,"LIST exact search, untyped item",80 -081,"LIST exact search, typed item",77 -082,"LIST sorted search, typed item",93 -083,LIST sort,6723 -084,LIST typed sort,4737 -085,LIST remove first element,806 -086,LIST remove middle element,692 -087,LIST remove last element,689 -088,LIST replace first element,722 -089,LIST replace middle element,693 -090,LIST replace last element,963 -091,LIST replace first el with multiple,819 -092,LIST replace middle el with multiple,691 -093,LIST replace last el with multiple,813 -094,LIST replace range,744 -095,LIST remove in mixed list,833 -096,LIST replace in mixed list,1054 -097,LIST index first element,16 -098,LIST index middle element,16 -099,LIST index last element,13 -100,LIST insert an item at start,775 -101,LIST insert an item at middle,684 -102,"LIST insert an item at ""end""",670 -103,"LIST small, early range",42 -104,"LIST small, late range",28 -105,"LIST large, early range",54 -106,"LIST large, late range",81 -107,LIST append to list,917 -108,LIST join list,1818 -109,"LOOP for, iterate list",13766 -110,"LOOP foreach, iterate list",3750 -111,LOOP for (to 1000),4639 -112,LOOP while (to 1000),4551 -113,"LOOP for, iterate string",141594 -114,"LOOP foreach, iterate string",9099 -115,MAP string 1 val,9096 -116,MAP string 2 val,12943 -117,MAP string 3 val,12825 -118,MAP string 4 val,17267 -119,MAP string 1 val -nocase,17685 -120,MAP string 2 val -nocase,27379 -121,MAP string 3 val -nocase,35569 -122,MAP string 4 val -nocase,39660 -123,MAP regsub 1 val,9663 -124,MAP regsub 2 val,41500 -125,MAP regsub 3 val,52315 -126,MAP regsub 4 val,67973 -127,MAP regsub 1 val -nocase,9463 -128,MAP regsub 2 val -nocase,40735 -129,MAP regsub 3 val -nocase,52639 -130,MAP regsub 4 val -nocase,66937 -131,"MAP string, no match",14020 -132,"MAP string -nocase, no match",35683 -133,"MAP regsub, no match",6704 -134,"MAP regsub -nocase, no match",6609 -135,MAP string short,116 -136,MAP regsub short,308 -137,MTHD direct ns proc call,3 -138,MTHD imported ns proc call,5 -139,MTHD interp alias proc call,18 -140,MTHD indirect proc eval,56 -141,MTHD indirect proc eval #2,81 -142,MTHD array stored proc call,22 -143,MTHD switch method call,119 -144,MTHD ns lookup call,374 -145,MTHD inline call,2 -146,PROC explicit return,7 -147,PROC implicit return,4 -148,PROC explicit return (2),13 -149,PROC implicit return (2),10 -150,PROC explicit return (3),4 -151,PROC implicit return (3),3 -152,PROC heavily commented,12 -153,"PROC do-nothing, no args",38 -154,"PROC do-nothing, one arg",9 -155,PROC local links with global,3586 -156,PROC local links with upvar,2806 -157,PROC local links with variable,2614 -158,"READ 595K, gets",819327 -159,"READ 595K, read",227338 -160,"READ 595K, read & size",242255 -161,"READ 3050b, gets",4118 -162,"READ 3050b, read",789 -163,"READ 3050b, read & size",790 -164,"BREAD 595K, gets",833500 -165,"BREAD 595K, read",228963 -166,"BREAD 595K, read & size",246365 -167,"BREAD 3050b, gets",5220 -168,"BREAD 3050b, read",1310 -169,"BREAD 3050b, read & size",1144 -170,REGEXP literal regexp,42 -171,REGEXP var-based regexp,55 -172,REGEXP count all matches,1280 -173,REGEXP extract all matches,1790 -174,STARTUP time to launch tclsh,85723 -175,STR str [string compare],17 -176,STR str [string equal],68 -177,"STR str $a equal """"",81 -178,"STR str num == """"",36 -179,STR str $a eq $b,39 -180,STR str $a ne $b,85 -181,STR str $a eq $b (same obj),161 -182,STR str $a ne $b (same obj),28 -183,STR length (==4010),678 -184,STR index 0,487 -185,STR index 100,500 -186,STR index 500,483 -187,STR index2 0,494 -188,STR index2 100,470 -189,STR index2 500,484 -190,STR first (success),21 -191,STR first (failure),123 -192,STR first (total failure),54 -193,STR last (success),469 -194,STR last (failure),185 -195,STR last (total failure),135 -196,"STR match, simple (success early)",25 -197,"STR match, simple (success late)",11 -198,"STR match, simple (failure)",26 -199,"STR match, simple (total failure)",17 -200,"STR match, complex (success early)",33 -201,"STR match, complex (success late)",2173 -202,"STR match, complex (failure)",1785 -203,"STR match, complex (total failure)",1844 -204,"STR range, index 100..200 of 4010",716 -205,"STR replace, no replacement",570 -206,"STR replace, equal replacement",526 -207,"STR replace, longer replacement",551 -208,"STR repeat, abcdefghij * 10",21 -209,"STR repeat, abcdefghij * 100",120 -210,"STR repeat, abcdefghij * 1000",798 -211,"STR repeat, 4010 chars * 10",1971 -212,"STR repeat, 4010 chars * 100",47967 -213,"STR reverse iter1, 100 chars",4104 -214,"STR reverse iter1, 100 uchars",4448 -215,"STR reverse iter2, 100 chars",3860 -216,"STR reverse iter2, 100 uchars",4086 -217,"STR reverse recur1, 100 chars",8749 -218,"STR reverse recur1, 100 uchars",8794 -219,"STR split, 4010 chars",23626 -220,"STR split, 12000 uchars",74910 -221,"STR split iter, 4010 chars",39846 -222,"STR split iter, 12000 uchars",122753 -223,STR append,108 -224,STR append (1KB + 1KB),96 -225,STR append (10KB + 1KB),474 -226,STR append (1MB + 2b * 1000),178639 -227,STR append (1MB + 1KB),136891 -228,STR append (1MB + 1KB * 20),127033 -229,STR append (1MB + 1KB * 1000),177875 -230,STR append (1MB + 1MB * 3),282029 -231,STR append (1MB + 1MB * 5),1051814 -232,STR append (1MB + (1b + 1K + 1b) * 100),290360 -233,STR info locals match,2025 -234,TRACE no trace set,18 -235,TRACE read,16 -236,TRACE write,16 -237,TRACE unset,16 -238,TRACE all set (rwu),18 -239,UNSET var exists,8 -240,UNSET catch var exists,52 -241,UNSET catch var !exist,191 -242,UNSET info check var exists,69 -243,UNSET info check var !exist,6 -244,UNSET nocomplain var exists,35 -245,UNSET nocomplain var !exist,157 -246,VAR access locally set,18 -247,VAR access local proc arg,6 -248,VAR access global,101 -249,VAR access upvar,103 -250,VAR set scalar,4 -251,VAR set array element,9 -252,VAR 100 'set's in array,296 -253,VAR 'array set' of 100 elems,741 DELETED examples/csv/Benchmark.823.csv Index: examples/csv/Benchmark.823.csv ================================================================== --- examples/csv/Benchmark.823.csv +++ /dev/null @@ -1,254 +0,0 @@ -000,VERSIONS:,1:8.2.3 -001,CATCH return ok,7 -002,CATCH return error,275 -003,CATCH no catch used,7 -004,IF if true numeric,13 -005,IF elseif true numeric,16 -006,IF else true numeric,16 -007,IF if true num/num,281 -008,IF if false num/num,13 -009,IF if false al/num,20 -010,IF if true al/al,26 -011,IF if false al/al,25 -012,IF if true al,25 -013,IF elseif true al,338 -014,IF else true al,42 -015,SWITCH first true,103 -016,SWITCH second true,153 -017,SWITCH ninth true,238 -018,SWITCH default true,46 -019,DATA create in a list,15014 -020,DATA create in an array,19172 -021,DATA access in a list,15346 -022,DATA access in an array,14156 -023,EVAL cmd eval in list obj var,52 -024,EVAL cmd eval as list,49 -025,EVAL cmd eval as string,54 -026,EVAL cmd and mixed lists,32485 -027,EVAL list cmd and mixed lists,40366 -028,EVAL list cmd and pure lists,40115 -029,EXPR unbraced,502 -030,EXPR braced,29 -031,EXPR inline,40 -032,EXPR one operand,158 -033,EXPR ten operands,97 -034,EXPR fifty operands,45 -035,EXPR incr with incr,10 -036,EXPR incr with expr,9 -037,FCOPY std: 160010 bytes,46300 -038,FCOPY binary: 160010 bytes,41776 -039,FCOPY encoding: 160010 bytes,44598 -040,KLIST shuffle0 llength 1,554 -041,KLIST shuffle0 llength 10,1592 -042,KLIST shuffle0 llength 100,13565 -043,KLIST shuffle0 llength 1000,164223 -044,KLIST shuffle0 llength 10000,2073612 -045,KLIST shuffle1 llength 1,367 -046,KLIST shuffle1 llength 10,1371 -047,KLIST shuffle1 llength 100,12737 -048,KLIST shuffle1 llength 1000,1770024 -049,KLIST shuffle1a llength 1,94 -050,KLIST shuffle1a llength 10,404 -051,KLIST shuffle1a llength 100,3833 -052,KLIST shuffle1a llength 1000,39248 -053,KLIST shuffle1a llength 10000,408005 -054,KLIST shuffle2 llength 1,108 -055,KLIST shuffle2 llength 10,481 -056,KLIST shuffle2 llength 100,4250 -057,KLIST shuffle2 llength 1000,45651 -058,KLIST shuffle2 llength 10000,527055 -059,KLIST shuffle3 llength 1,102 -060,KLIST shuffle3 llength 10,376 -061,KLIST shuffle3 llength 100,3413 -062,KLIST shuffle3 llength 1000,37667 -063,KLIST shuffle3 llength 10000,844383 -064,KLIST shuffle4 llength 1,100 -065,KLIST shuffle4 llength 10,416 -066,KLIST shuffle4 llength 100,3758 -067,KLIST shuffle4 llength 1000,38186 -068,KLIST shuffle4 llength 10000,398724 -069,"STR/LIST length, obj shimmer",2333 -070,"LIST length, pure list",13 -071,STR length of a LIST,12 -072,"LIST exact search, first item",14 -073,"LIST exact search, middle item",27 -074,"LIST exact search, last item",50 -075,"LIST exact search, non-item",121 -076,"LIST sorted search, first item",12 -077,"LIST sorted search, middle item",26 -078,"LIST sorted search, last item",49 -079,"LIST sorted search, non-item",122 -080,"LIST exact search, untyped item",51 -081,"LIST exact search, typed item",49 -082,"LIST sorted search, typed item",50 -083,LIST sort,3293 -084,LIST typed sort,2660 -085,LIST remove first element,363 -086,LIST remove middle element,358 -087,LIST remove last element,360 -088,LIST replace first element,346 -089,LIST replace middle element,353 -090,LIST replace last element,346 -091,LIST replace first el with multiple,372 -092,LIST replace middle el with multiple,351 -093,LIST replace last el with multiple,347 -094,LIST replace range,343 -095,LIST remove in mixed list,2195 -096,LIST replace in mixed list,2184 -097,LIST index first element,13 -098,LIST index middle element,13 -099,LIST index last element,13 -100,LIST insert an item at start,366 -101,LIST insert an item at middle,370 -102,"LIST insert an item at ""end""",349 -103,"LIST small, early range",16 -104,"LIST small, late range",16 -105,"LIST large, early range",24 -106,"LIST large, late range",21 -107,LIST append to list,396 -108,LIST join list,1066 -109,"LOOP for, iterate list",5372 -110,"LOOP foreach, iterate list",1952 -111,LOOP for (to 1000),3065 -112,LOOP while (to 1000),3065 -113,"LOOP for, iterate string",9637 -114,"LOOP foreach, iterate string",3955 -115,MAP string 1 val,6028 -116,MAP string 2 val,6877 -117,MAP string 3 val,7832 -118,MAP string 4 val,8622 -119,MAP string 1 val -nocase,10381 -120,MAP string 2 val -nocase,15024 -121,MAP string 3 val -nocase,18973 -122,MAP string 4 val -nocase,22132 -123,MAP regsub 1 val,4303 -124,MAP regsub 2 val,18176 -125,MAP regsub 3 val,24817 -126,MAP regsub 4 val,31350 -127,MAP regsub 1 val -nocase,4332 -128,MAP regsub 2 val -nocase,18134 -129,MAP regsub 3 val -nocase,24747 -130,MAP regsub 4 val -nocase,31314 -131,"MAP string, no match",8028 -132,"MAP string -nocase, no match",18933 -133,"MAP regsub, no match",2830 -134,"MAP regsub -nocase, no match",2890 -135,MAP string short,39 -136,MAP regsub short,193 -137,MTHD direct ns proc call,8 -138,MTHD imported ns proc call,7 -139,MTHD interp alias proc call,18 -140,MTHD indirect proc eval,61 -141,MTHD indirect proc eval #2,57 -142,MTHD array stored proc call,10 -143,MTHD switch method call,83 -144,MTHD ns lookup call,216 -145,MTHD inline call,3 -146,PROC explicit return,8 -147,PROC implicit return,7 -148,PROC explicit return (2),8 -149,PROC implicit return (2),7 -150,PROC explicit return (3),7 -151,PROC implicit return (3),7 -152,PROC heavily commented,6 -153,"PROC do-nothing, no args",28 -154,"PROC do-nothing, one arg",6 -155,PROC local links with global,1626 -156,PROC local links with upvar,1387 -157,PROC local links with variable,1334 -158,"READ 595K, gets",306109 -159,"READ 595K, read",97019 -160,"READ 595K, read & size",97074 -161,"READ 3050b, gets",2052 -162,"READ 3050b, read",494 -163,"READ 3050b, read & size",530 -164,"BREAD 595K, gets",304961 -165,"BREAD 595K, read",50018 -166,"BREAD 595K, read & size",50140 -167,"BREAD 3050b, gets",1774 -168,"BREAD 3050b, read",334 -169,"BREAD 3050b, read & size",369 -170,REGEXP literal regexp,38 -171,REGEXP var-based regexp,40 -172,REGEXP count all matches,530 -173,REGEXP extract all matches,616 -174,STARTUP time to launch tclsh,18293 -175,STR str [string compare],24 -176,STR str [string equal],23 -177,"STR str $a equal """"",24 -178,"STR str num == """"",24 -179,STR str $a eq $b,31 -180,STR str $a ne $b,30 -181,STR str $a eq $b (same obj),36 -182,STR str $a ne $b (same obj),30 -183,STR length (==4010),13 -184,STR index 0,19 -185,STR index 100,19 -186,STR index 500,19 -187,STR index2 0,19 -188,STR index2 100,19 -189,STR index2 500,19 -190,STR first (success),15 -191,STR first (failure),50 -192,STR first (total failure),28 -193,STR last (success),224 -194,STR last (failure),91 -195,STR last (total failure),83 -196,"STR match, simple (success early)",13 -197,"STR match, simple (success late)",13 -198,"STR match, simple (failure)",13 -199,"STR match, simple (total failure)",13 -200,"STR match, complex (success early)",22 -201,"STR match, complex (success late)",1040 -202,"STR match, complex (failure)",1010 -203,"STR match, complex (total failure)",994 -204,"STR range, index 100..200 of 4010",21 -205,"STR replace, no replacement",264 -206,"STR replace, equal replacement",257 -207,"STR replace, longer replacement",265 -208,"STR repeat, abcdefghij * 10",22 -209,"STR repeat, abcdefghij * 100",74 -210,"STR repeat, abcdefghij * 1000",557 -211,"STR repeat, 4010 chars * 10",671 -212,"STR repeat, 4010 chars * 100",18194 -213,"STR reverse iter1, 100 chars",1425 -214,"STR reverse iter1, 100 uchars",1436 -215,"STR reverse iter2, 100 chars",1168 -216,"STR reverse iter2, 100 uchars",1096 -217,"STR reverse recur1, 100 chars",3998 -218,"STR reverse recur1, 100 uchars",4767 -219,"STR split, 4010 chars",8847 -220,"STR split, 12000 uchars",27293 -221,"STR split iter, 4010 chars",16664 -222,"STR split iter, 12000 uchars",52115 -223,STR append,71 -224,STR append (1KB + 1KB),49 -225,STR append (10KB + 1KB),196 -226,STR append (1MB + 2b * 1000),74635 -227,STR append (1MB + 1KB),61479 -228,STR append (1MB + 1KB * 20),61865 -229,STR append (1MB + 1KB * 1000),101998 -230,STR append (1MB + 1MB * 3),157370 -231,STR append (1MB + 1MB * 5),315407 -232,STR append (1MB + (1b + 1K + 1b) * 100),69167 -233,STR info locals match,993 -234,TRACE no trace set,26 -235,TRACE read,26 -236,TRACE write,26 -237,TRACE unset,26 -238,TRACE all set (rwu),25 -239,UNSET var exists,9 -240,UNSET catch var exists,10 -241,UNSET catch var !exist,59 -242,UNSET info check var exists,13 -243,UNSET info check var !exist,11 -244,UNSET nocomplain var exists,10 -245,UNSET nocomplain var !exist,59 -246,VAR access locally set,10 -247,VAR access local proc arg,10 -248,VAR access global,26 -249,VAR access upvar,30 -250,VAR set scalar,7 -251,VAR set array element,14 -252,VAR 100 'set's in array,160 -253,VAR 'array set' of 100 elems,264 DELETED examples/csv/Benchmark.833.csv Index: examples/csv/Benchmark.833.csv ================================================================== --- examples/csv/Benchmark.833.csv +++ /dev/null @@ -1,254 +0,0 @@ -000,VERSIONS:,1:8.3.3 -001,CATCH return ok,6 -002,CATCH return error,64 -003,CATCH no catch used,6 -004,IF if true numeric,11 -005,IF elseif true numeric,15 -006,IF else true numeric,15 -007,IF if true num/num,12 -008,IF if false num/num,12 -009,IF if false al/num,20 -010,IF if true al/al,26 -011,IF if false al/al,25 -012,IF if true al,25 -013,IF elseif true al,39 -014,IF else true al,40 -015,SWITCH first true,42 -016,SWITCH second true,39 -017,SWITCH ninth true,44 -018,SWITCH default true,38 -019,DATA create in a list,4083 -020,DATA create in an array,4916 -021,DATA access in a list,3546 -022,DATA access in an array,3223 -023,EVAL cmd eval in list obj var,22 -024,EVAL cmd eval as list,21 -025,EVAL cmd eval as string,50 -026,EVAL cmd and mixed lists,3546 -027,EVAL list cmd and mixed lists,3591 -028,EVAL list cmd and pure lists,582 -029,EXPR unbraced,167 -030,EXPR braced,25 -031,EXPR inline,30 -032,EXPR one operand,6 -033,EXPR ten operands,13 -034,EXPR fifty operands,43 -035,EXPR incr with incr,11 -036,EXPR incr with expr,7 -037,FCOPY std: 160010 bytes,10242 -038,FCOPY binary: 160010 bytes,9892 -039,FCOPY encoding: 160010 bytes,9831 -040,KLIST shuffle0 llength 1,127 -041,KLIST shuffle0 llength 10,413 -042,KLIST shuffle0 llength 100,3552 -043,KLIST shuffle0 llength 1000,41766 -044,KLIST shuffle0 llength 10000,533804 -045,KLIST shuffle1 llength 1,85 -046,KLIST shuffle1 llength 10,333 -047,KLIST shuffle1 llength 100,5238 -048,KLIST shuffle1 llength 1000,1194146 -049,KLIST shuffle1a llength 1,100 -050,KLIST shuffle1a llength 10,368 -051,KLIST shuffle1a llength 100,3625 -052,KLIST shuffle1a llength 1000,37340 -053,KLIST shuffle1a llength 10000,380522 -054,KLIST shuffle2 llength 1,99 -055,KLIST shuffle2 llength 10,375 -056,KLIST shuffle2 llength 100,3625 -057,KLIST shuffle2 llength 1000,37028 -058,KLIST shuffle2 llength 10000,433771 -059,KLIST shuffle3 llength 1,98 -060,KLIST shuffle3 llength 10,335 -061,KLIST shuffle3 llength 100,2883 -062,KLIST shuffle3 llength 1000,33237 -063,KLIST shuffle3 llength 10000,777699 -064,KLIST shuffle4 llength 1,102 -065,KLIST shuffle4 llength 10,374 -066,KLIST shuffle4 llength 100,3250 -067,KLIST shuffle4 llength 1000,32119 -068,KLIST shuffle4 llength 10000,330472 -069,"STR/LIST length, obj shimmer",2767 -070,"LIST length, pure list",13 -071,STR length of a LIST,12 -072,"LIST exact search, first item",11 -073,"LIST exact search, middle item",25 -074,"LIST exact search, last item",48 -075,"LIST exact search, non-item",110 -076,"LIST sorted search, first item",12 -077,"LIST sorted search, middle item",26 -078,"LIST sorted search, last item",52 -079,"LIST sorted search, non-item",111 -080,"LIST exact search, untyped item",47 -081,"LIST exact search, typed item",48 -082,"LIST sorted search, typed item",46 -083,LIST sort,3578 -084,LIST typed sort,2943 -085,LIST remove first element,296 -086,LIST remove middle element,291 -087,LIST remove last element,293 -088,LIST replace first element,289 -089,LIST replace middle element,286 -090,LIST replace last element,283 -091,LIST replace first el with multiple,304 -092,LIST replace middle el with multiple,310 -093,LIST replace last el with multiple,282 -094,LIST replace range,282 -095,LIST remove in mixed list,374 -096,LIST replace in mixed list,352 -097,LIST index first element,10 -098,LIST index middle element,10 -099,LIST index last element,11 -100,LIST insert an item at start,298 -101,LIST insert an item at middle,266 -102,"LIST insert an item at ""end""",254 -103,"LIST small, early range",19 -104,"LIST small, late range",18 -105,"LIST large, early range",29 -106,"LIST large, late range",30 -107,LIST append to list,401 -108,LIST join list,1072 -109,"LOOP for, iterate list",5198 -110,"LOOP foreach, iterate list",1845 -111,LOOP for (to 1000),2674 -112,LOOP while (to 1000),2942 -113,"LOOP for, iterate string",9440 -114,"LOOP foreach, iterate string",2249 -115,MAP string 1 val,5931 -116,MAP string 2 val,6643 -117,MAP string 3 val,7673 -118,MAP string 4 val,8429 -119,MAP string 1 val -nocase,10259 -120,MAP string 2 val -nocase,14570 -121,MAP string 3 val -nocase,19344 -122,MAP string 4 val -nocase,21861 -123,MAP regsub 1 val,3954 -124,MAP regsub 2 val,16981 -125,MAP regsub 3 val,23258 -126,MAP regsub 4 val,29335 -127,MAP regsub 1 val -nocase,3913 -128,MAP regsub 2 val -nocase,17024 -129,MAP regsub 3 val -nocase,23228 -130,MAP regsub 4 val -nocase,29397 -131,"MAP string, no match",7712 -132,"MAP string -nocase, no match",18725 -133,"MAP regsub, no match",2764 -134,"MAP regsub -nocase, no match",2785 -135,MAP string short,41 -136,MAP regsub short,180 -137,MTHD direct ns proc call,6 -138,MTHD imported ns proc call,6 -139,MTHD interp alias proc call,18 -140,MTHD indirect proc eval,29 -141,MTHD indirect proc eval #2,48 -142,MTHD array stored proc call,9 -143,MTHD switch method call,38 -144,MTHD ns lookup call,81 -145,MTHD inline call,3 -146,PROC explicit return,7 -147,PROC implicit return,6 -148,PROC explicit return (2),7 -149,PROC implicit return (2),6 -150,PROC explicit return (3),7 -151,PROC implicit return (3),6 -152,PROC heavily commented,5 -153,"PROC do-nothing, no args",5 -154,"PROC do-nothing, one arg",5 -155,PROC local links with global,1569 -156,PROC local links with upvar,1166 -157,PROC local links with variable,1101 -158,"READ 595K, gets",299797 -159,"READ 595K, read",97698 -160,"READ 595K, read & size",97909 -161,"READ 3050b, gets",1641 -162,"READ 3050b, read",494 -163,"READ 3050b, read & size",534 -164,"BREAD 595K, gets",292326 -165,"BREAD 595K, read",50454 -166,"BREAD 595K, read & size",50486 -167,"BREAD 3050b, gets",1777 -168,"BREAD 3050b, read",347 -169,"BREAD 3050b, read & size",389 -170,REGEXP literal regexp,37 -171,REGEXP var-based regexp,40 -172,REGEXP count all matches,139 -173,REGEXP extract all matches,177 -174,STARTUP time to launch tclsh,20425 -175,STR str [string compare],26 -176,STR str [string equal],25 -177,"STR str $a equal """"",26 -178,"STR str num == """"",14 -179,STR str $a eq $b,33 -180,STR str $a ne $b,31 -181,STR str $a eq $b (same obj),33 -182,STR str $a ne $b (same obj),33 -183,STR length (==4010),14 -184,STR index 0,19 -185,STR index 100,24 -186,STR index 500,18 -187,STR index2 0,19 -188,STR index2 100,19 -189,STR index2 500,19 -190,STR first (success),16 -191,STR first (failure),56 -192,STR first (total failure),42 -193,STR last (success),229 -194,STR last (failure),99 -195,STR last (total failure),90 -196,"STR match, simple (success early)",14 -197,"STR match, simple (success late)",14 -198,"STR match, simple (failure)",15 -199,"STR match, simple (total failure)",18 -200,"STR match, complex (success early)",23 -201,"STR match, complex (success late)",1020 -202,"STR match, complex (failure)",1011 -203,"STR match, complex (total failure)",994 -204,"STR range, index 100..200 of 4010",21 -205,"STR replace, no replacement",270 -206,"STR replace, equal replacement",277 -207,"STR replace, longer replacement",270 -208,"STR repeat, abcdefghij * 10",22 -209,"STR repeat, abcdefghij * 100",72 -210,"STR repeat, abcdefghij * 1000",565 -211,"STR repeat, 4010 chars * 10",797 -212,"STR repeat, 4010 chars * 100",18287 -213,"STR reverse iter1, 100 chars",1628 -214,"STR reverse iter1, 100 uchars",1768 -215,"STR reverse iter2, 100 chars",1252 -216,"STR reverse iter2, 100 uchars",1259 -217,"STR reverse recur1, 100 chars",4770 -218,"STR reverse recur1, 100 uchars",5467 -219,"STR split, 4010 chars",2138 -220,"STR split, 12100 uchars",6395 -221,"STR split iter, 4010 chars",9372 -222,"STR split iter, 12100 uchars",28299 -223,STR append,82 -224,STR append (1KB + 1KB),55 -225,STR append (10KB + 1KB),193 -226,STR append (1MB + 2b * 1000),70498 -227,STR append (1MB + 1KB),63374 -228,STR append (1MB + 1KB * 20),64566 -229,STR append (1MB + 1KB * 1000),94413 -230,STR append (1MB + 1MB * 3),153051 -231,STR append (1MB + 1MB * 5),303871 -232,STR append (1MB + (1b + 1K + 1b) * 100),63834 -233,STR info locals match,818 -234,TRACE no trace set,25 -235,TRACE read,26 -236,TRACE write,25 -237,TRACE unset,26 -238,TRACE all set (rwu),25 -239,UNSET var exists,8 -240,UNSET catch var exists,9 -241,UNSET catch var !exist,64 -242,UNSET info check var exists,14 -243,UNSET info check var !exist,11 -244,UNSET nocomplain var exists,9 -245,UNSET nocomplain var !exist,64 -246,VAR access locally set,8 -247,VAR access local proc arg,9 -248,VAR access global,25 -249,VAR access upvar,29 -250,VAR set scalar,6 -251,VAR set array element,12 -252,VAR 100 'set's in array,133 -253,VAR 'array set' of 100 elems,251 DELETED examples/csv/Benchmark.84a3.csv Index: examples/csv/Benchmark.84a3.csv ================================================================== --- examples/csv/Benchmark.84a3.csv +++ /dev/null @@ -1,254 +0,0 @@ -000,VERSIONS:,1:8.4a3 -001,CATCH return ok,11 -002,CATCH return error,70 -003,CATCH no catch used,10 -004,IF if true numeric,17 -005,IF elseif true numeric,20 -006,IF else true numeric,20 -007,IF if true num/num,17 -008,IF if false num/num,17 -009,IF if false al/num,27 -010,IF if true al/al,31 -011,IF if false al/al,31 -012,IF if true al,32 -013,IF elseif true al,47 -014,IF else true al,46 -015,SWITCH first true,63 -016,SWITCH second true,58 -017,SWITCH ninth true,67 -018,SWITCH default true,62 -019,DATA create in a list,4883 -020,DATA create in an array,5388 -021,DATA access in a list,4028 -022,DATA access in an array,3507 -023,EVAL cmd eval in list obj var,26 -024,EVAL cmd eval as list,24 -025,EVAL cmd eval as string,60 -026,EVAL cmd and mixed lists,3347 -027,EVAL list cmd and mixed lists,3403 -028,EVAL list cmd and pure lists,543 -029,EXPR unbraced,153 -030,EXPR braced,29 -031,EXPR inline,31 -032,EXPR one operand,11 -033,EXPR ten operands,18 -034,EXPR fifty operands,48 -035,EXPR incr with incr,16 -036,EXPR incr with expr,11 -037,FCOPY std: 160010 bytes,10069 -038,FCOPY binary: 160010 bytes,9932 -039,FCOPY encoding: 160010 bytes,9818 -040,KLIST shuffle0 llength 1,144 -041,KLIST shuffle0 llength 10,457 -042,KLIST shuffle0 llength 100,3986 -043,KLIST shuffle0 llength 1000,44083 -044,KLIST shuffle0 llength 10000,563245 -045,KLIST shuffle1 llength 1,84 -046,KLIST shuffle1 llength 10,358 -047,KLIST shuffle1 llength 100,6374 -048,KLIST shuffle1 llength 1000,1190696 -049,KLIST shuffle1a llength 1,110 -050,KLIST shuffle1a llength 10,474 -051,KLIST shuffle1a llength 100,4667 -052,KLIST shuffle1a llength 1000,47818 -053,KLIST shuffle1a llength 10000,474513 -054,KLIST shuffle2 llength 1,104 -055,KLIST shuffle2 llength 10,440 -056,KLIST shuffle2 llength 100,3762 -057,KLIST shuffle2 llength 1000,39573 -058,KLIST shuffle2 llength 10000,474558 -059,KLIST shuffle3 llength 1,104 -060,KLIST shuffle3 llength 10,380 -061,KLIST shuffle3 llength 100,3408 -062,KLIST shuffle3 llength 1000,38716 -063,KLIST shuffle3 llength 10000,945771 -064,KLIST shuffle4 llength 1,114 -065,KLIST shuffle4 llength 10,431 -066,KLIST shuffle4 llength 100,3871 -067,KLIST shuffle4 llength 1000,40201 -068,KLIST shuffle4 llength 10000,393369 -069,"STR/LIST length, obj shimmer",2390 -070,"LIST length, pure list",18 -071,STR length of a LIST,15 -072,"LIST exact search, first item",19 -073,"LIST exact search, middle item",69 -074,"LIST exact search, last item",132 -075,"LIST exact search, non-item",314 -076,"LIST sorted search, first item",23 -077,"LIST sorted search, middle item",24 -078,"LIST sorted search, last item",24 -079,"LIST sorted search, non-item",23 -080,"LIST exact search, untyped item",131 -081,"LIST exact search, typed item",128 -082,"LIST sorted search, typed item",19 -083,LIST sort,3299 -084,LIST typed sort,2739 -085,LIST remove first element,317 -086,LIST remove middle element,325 -087,LIST remove last element,318 -088,LIST replace first element,310 -089,LIST replace middle element,316 -090,LIST replace last element,316 -091,LIST replace first el with multiple,333 -092,LIST replace middle el with multiple,319 -093,LIST replace last el with multiple,319 -094,LIST replace range,294 -095,LIST remove in mixed list,389 -096,LIST replace in mixed list,377 -097,LIST index first element,18 -098,LIST index middle element,17 -099,LIST index last element,17 -100,LIST insert an item at start,291 -101,LIST insert an item at middle,269 -102,"LIST insert an item at ""end""",257 -103,"LIST small, early range",23 -104,"LIST small, late range",23 -105,"LIST large, early range",37 -106,"LIST large, late range",40 -107,LIST append to list,409 -108,LIST join list,1053 -109,"LOOP for, iterate list",6616 -110,"LOOP foreach, iterate list",1919 -111,LOOP for (to 1000),2566 -112,LOOP while (to 1000),2568 -113,"LOOP for, iterate string",6456 -114,"LOOP foreach, iterate string",2240 -115,MAP string 1 val,679 -116,MAP string 2 val,1562 -117,MAP string 3 val,1836 -118,MAP string 4 val,2510 -119,MAP string 1 val -nocase,3497 -120,MAP string 2 val -nocase,6218 -121,MAP string 3 val -nocase,8364 -122,MAP string 4 val -nocase,10135 -123,MAP regsub 1 val,3702 -124,MAP regsub 2 val,16066 -125,MAP regsub 3 val,21671 -126,MAP regsub 4 val,26657 -127,MAP regsub 1 val -nocase,3686 -128,MAP regsub 2 val -nocase,15821 -129,MAP regsub 3 val -nocase,20987 -130,MAP regsub 4 val -nocase,26227 -131,"MAP string, no match",926 -132,"MAP string -nocase, no match",6726 -133,"MAP regsub, no match",1149 -134,"MAP regsub -nocase, no match",1151 -135,MAP string short,37 -136,MAP regsub short,164 -137,MTHD direct ns proc call,10 -138,MTHD imported ns proc call,11 -139,MTHD interp alias proc call,25 -140,MTHD indirect proc eval,36 -141,MTHD indirect proc eval #2,58 -142,MTHD array stored proc call,14 -143,MTHD switch method call,50 -144,MTHD ns lookup call,99 -145,MTHD inline call,5 -146,PROC explicit return,15 -147,PROC implicit return,11 -148,PROC explicit return (2),12 -149,PROC implicit return (2),10 -150,PROC explicit return (3),10 -151,PROC implicit return (3),10 -152,PROC heavily commented,10 -153,"PROC do-nothing, no args",8 -154,"PROC do-nothing, one arg",10 -155,PROC local links with global,1579 -156,PROC local links with upvar,1287 -157,PROC local links with variable,1195 -158,"READ 595K, gets",340064 -159,"READ 595K, read",77751 -160,"READ 595K, read & size",77606 -161,"READ 3050b, gets",1869 -162,"READ 3050b, read",522 -163,"READ 3050b, read & size",569 -164,"BREAD 595K, gets",350077 -165,"BREAD 595K, read",50105 -166,"BREAD 595K, read & size",50303 -167,"BREAD 3050b, gets",2097 -168,"BREAD 3050b, read",340 -169,"BREAD 3050b, read & size",396 -170,REGEXP literal regexp,39 -171,REGEXP var-based regexp,41 -172,REGEXP count all matches,137 -173,REGEXP extract all matches,169 -174,STARTUP time to launch tclsh,21138 -175,STR str [string compare],18 -176,STR str [string equal],18 -177,"STR str $a equal """"",17 -178,"STR str num == """"",19 -179,STR str $a eq $b,22 -180,STR str $a ne $b,23 -181,STR str $a eq $b (same obj),22 -182,STR str $a ne $b (same obj),21 -183,STR length (==4010),15 -184,STR index 0,26 -185,STR index 100,21 -186,STR index 500,21 -187,STR index2 0,21 -188,STR index2 100,20 -189,STR index2 500,21 -190,STR first (success),19 -191,STR first (failure),120 -192,STR first (total failure),109 -193,STR last (success),19 -194,STR last (failure),90 -195,STR last (total failure),82 -196,"STR match, simple (success early)",17 -197,"STR match, simple (success late)",16 -198,"STR match, simple (failure)",17 -199,"STR match, simple (total failure)",16 -200,"STR match, complex (success early)",17 -201,"STR match, complex (success late)",145 -202,"STR match, complex (failure)",122 -203,"STR match, complex (total failure)",90 -204,"STR range, index 100..200 of 4010",26 -205,"STR replace, no replacement",79 -206,"STR replace, equal replacement",92 -207,"STR replace, longer replacement",95 -208,"STR repeat, abcdefghij * 10",19 -209,"STR repeat, abcdefghij * 100",39 -210,"STR repeat, abcdefghij * 1000",245 -211,"STR repeat, 4010 chars * 10",314 -212,"STR repeat, 4010 chars * 100",7347 -213,"STR reverse iter1, 100 chars",1285 -214,"STR reverse iter1, 100 uchars",1264 -215,"STR reverse iter2, 100 chars",808 -216,"STR reverse iter2, 100 uchars",807 -217,"STR reverse recur1, 100 chars",4092 -218,"STR reverse recur1, 100 uchars",4169 -219,"STR split, 4010 chars",2663 -220,"STR split, 12100 uchars",7207 -221,"STR split iter, 4010 chars",9349 -222,"STR split iter, 12100 uchars",28171 -223,STR append,100 -224,STR append (1KB + 1KB),65 -225,STR append (10KB + 1KB),186 -226,STR append (1MB + 2b * 1000),37786 -227,STR append (1MB + 1KB),29729 -228,STR append (1MB + 1KB * 20),29635 -229,STR append (1MB + 1KB * 1000),66605 -230,STR append (1MB + 1MB * 3),126103 -231,STR append (1MB + 1MB * 5),157407 -232,STR append (1MB + (1b + 1K + 1b) * 100),33118 -233,STR info locals match,828 -234,TRACE no trace set,35 -235,TRACE read,35 -236,TRACE write,35 -237,TRACE unset,35 -238,TRACE all set (rwu),35 -239,UNSET var exists,14 -240,UNSET catch var exists,16 -241,UNSET catch var !exist,69 -242,UNSET info check var exists,19 -243,UNSET info check var !exist,16 -244,UNSET nocomplain var exists,14 -245,UNSET nocomplain var !exist,14 -246,VAR access locally set,14 -247,VAR access local proc arg,14 -248,VAR access global,34 -249,VAR access upvar,36 -250,VAR set scalar,10 -251,VAR set array element,18 -252,VAR 100 'set's in array,162 -253,VAR 'array set' of 100 elems,293 DELETED examples/csv/README Index: examples/csv/README ================================================================== --- examples/csv/README +++ /dev/null @@ -1,85 +0,0 @@ -Here are some applications for handling and manipulating CSV files in -various ways. Provided are: -======================================================================= - -csv2html ?-sep sepchar? ?-title string? file... - - Reads CSV data from the files and returns it as a HTML table - on stdout. - -======================================================================= - -csvsort ?-sep sepchar? ?-f? ?-n? ?-r? ?-skip cnt? column file.in|- file.out|- - - Like "sort", but for CSV files. Sorts after the specified - column. Input and output are from and to a file or stdin - and stdout (Any combination is possible). - - Options: - - -sep specifies the separator character used in the input file. - Default is comma. - - -n If specified integer sorting is used. - -f If specified floating point sorting is used. - (-n and -f exclude each other. If both are used the - last option decides the mode). - - -r If specified reverse sorting is used (largest first) - - -skip If specified that number of rows is skipped at the beginning, - i.e. excluded from sorting. This is to allow sorting of - CSV files with header lines. - -======================================================================= - -csvcut ?-sep sepchar? LIST file... - - Like "cut", but for CSV files. Print selected parts of CSV - records from each FILE to standard output. - - LIST is a comma separated list of column specifications. The - allowed forms are: - - N numeric specification of single column - N-M range specification, both parts numberic, - N < M required. - -M See N-M, N defaults to 0. - N- See N-M, M defaults to last column - - If there are no files or file = "-" read from stdin. - -======================================================================= - -csvuniq ?-sep sepchar? column file.in|- file.out|- - - Like "uniq", but for CSV files. Uniq's the specified column. - Writes the first record it encounters for a value. Input and - output are from and to a file or stdin and stdout (Any - combination is possible). - - Options: - - -sep specifies the separator character used in the input file. - Default is comma. - -======================================================================= - -csvjoin ?-sep sepchar? ?-outer? keycol1 file1.in keycol2 file2.in file.out|- - - Joins the two CSV inputtables using the specified columns as - keys to compare and associate. The result will contain all - columns from both files with the exception of the second key - column (the result needs only one key column, the other is - identical by definition and therefore superfluous). - - Options: - - -sep specifies the separator character used in the input file. - Default is comma. - - -outer Flag, perform outer join. Means that if the key is - missing in file2 a record is nevertheless written, - extended with empty values. - -======================================================================= DELETED examples/csv/bench_join Index: examples/csv/bench_join ================================================================== --- examples/csv/bench_join +++ /dev/null @@ -1,11 +0,0 @@ - -./csvcut '1-' Benchmark.833.csv > tmp.csv ; ./csvjoin -outer 1 Benchmark.84a3.csv 0 tmp.csv tmp1.csv -./csvcut '1-' Benchmark.823.csv > tmp.csv ; ./csvjoin -outer 1 tmp1.csv 0 tmp.csv tmp2.csv -./csvcut '1-' Benchmark.811.csv > tmp.csv ; ./csvjoin -outer 1 tmp2.csv 0 tmp.csv tmp1.csv -./csvcut '1-' Benchmark.805.csv > tmp.csv ; ./csvjoin -outer 1 tmp1.csv 0 tmp.csv tmp2.csv -./csvcut '1-' Benchmark.76p2.csv > tmp.csv ; ./csvjoin -outer 1 tmp2.csv 0 tmp.csv tmp1.csv -./csvcut '1-' Benchmark.75p2.csv > tmp.csv ; ./csvjoin -outer 1 tmp1.csv 0 tmp.csv Bench.csv - -rm -f tmp.csv tmp1.csv tmp2.csv - -./csv2html -title 'Core Benchmark Results' Bench.csv > Bench.html DELETED examples/csv/csv2html Index: examples/csv/csv2html ================================================================== --- examples/csv/csv2html +++ /dev/null @@ -1,105 +0,0 @@ -#!/bin/sh -# use -*- tcl -*- \ -exec tclsh "$0" "$@" -# Generate HTML table from CSV data - -package require csv -package require cmdline -package require report -package require struct - -# ---------------------------------------------------- -# csv2html ?-sep sepchar? file... -# -# Argument processing and checks. - -set sepChar , -set title "Title" -set usage "Usage: $argv0 ?-sep sepchar? ?-title string? file..." - -while {[set ok [cmdline::getopt argv {sep.arg title.arg} opt val]] > 0} { - #puts stderr "= $opt $val" - switch -exact -- $opt { - sep {set sepChar $val} - title {set title $val} - } -} -if {($ok < 0) || ([llength $argv] < 1)} { - #puts stderr "A >>$ok<< >>[llength $argv]<<" - puts stderr $usage - exit -1 -} - -set files $argv - -if {[llength $files] == 0} { - set files - -} - -# ---------------------------------------------------- -# Actual processing, uses the following information from the -# commandline: -# -# files - name of the files to read -# indices - preprocessed indices -# sepChar - separator character - -::report::defstyle html {} { - set c [columns] - set cl $c ; incr cl -1 - data set " [split [string repeat " " $cl] ""] " - for {set col 0} {$col < $c} {incr col} { - pad $col left "" - pad $col right "" - } - return -} - -set stdin 1 -set first 1 - -struct::matrix::matrix m - -foreach f $files { - if {![string compare $f -]} { - if {!$stdin} { - puts stderr "Cannot use - (stdin) more than once" - exit -1 - } - set in stdin - set stdin 0 - } else { - set in [open $f r] - } - - if {$first} { - set first 0 - if {[gets $in line] < 0} { - continue - } - set data [::csv::split $line $sepChar] - - m add columns [llength $data] - m add row $data - } - - csv::read2matrix $in m $sepChar - - if {[string compare $f -]} { - close $in - } -} - -# And writing the accumulated results - -report::report r [m columns] style html - -puts stdout "$title" -puts stdout "

$title

" -puts stdout "

" -r printmatrix2channel m stdout -#m format 2chan r stdout -puts stdout "

" -r destroy - -exit DELETED examples/csv/csvcut Index: examples/csv/csvcut ================================================================== --- examples/csv/csvcut +++ /dev/null @@ -1,105 +0,0 @@ -#!/bin/sh -# use -*- tcl -*- \ -exec tclsh "$0" "$@" -# Cut and reorder fields in a CSV file. - -package require csv -package require cmdline - -# ---------------------------------------------------- -# csvcut ?-sep sepchar? LIST file... -# -# Argument processing and checks. - -set sepChar , -set usage "Usage: $argv0 ?-sep sepchar? LIST file...\n\tLIST=idx,...\n\tidx in \{n, -m, n-, n-m\}" - -while {[set ok [cmdline::getopt argv {sep.arg} opt val]] > 0} { - #puts stderr "= $opt $val" - switch -exact -- $opt { - sep {set sepChar $val} - } -} -if {($ok < 0) || ([llength $argv] < 2)} { - #puts stderr "A >>$ok<< >>[llength $argv]<<" - puts stderr $usage - exit -1 -} - -set indices [split [lindex $argv 0] ,] -set files [lrange $argv 1 end] - -if {[llength $indices] == 0} { - #puts stderr >>$indices<< - #puts stderr B - puts stderr $usage - exit -1 -} - -set idx [list] -foreach i $indices { - if {[regexp -- {[0-9]+-[0-9]+} $i]} { - foreach {f t} [split $i -] break - lappend idx [list $f $t] - } elseif {[regexp -- {[0-9]+-} $i]} { - foreach {f t} [split $i -] break - lappend idx [list $f end] - } elseif {[regexp -- {-[0-9]+} $i]} { - foreach {f t} [split $i -] break - lappend idx [list 0 $t] - } elseif {[regexp -- {[0-9]+} $i]} { - lappend idx [list $i $i] - } else { - #puts stderr >>$idx<< - #puts stderr C - puts stderr $usage - exit -1 - } -} -set indices $idx - -if {[llength $files] == 0} { - set files - -} - -# ---------------------------------------------------- -# Actual processing, uses the following information from the -# commandline: -# -# files - name of the files to read -# indices - preprocessed indices -# sepChar - separator character - -set stdin 1 -foreach f $files { - if {![string compare $f -]} { - if {!$stdin} { - puts stderr "Cannot use - (stdin) more than once" - exit -1 - } - set in stdin - set stdin 0 - } else { - set in [open $f r] - } - - while {![eof $in]} { - if {[gets $in line] < 0} { - continue - } - set data [::csv::split $line $sepChar] - - set dataOut [list] - - foreach i $indices { - foreach {f t} $i break - eval lappend dataOut [lrange $data $f $t] - } - puts stdout [::csv::join $dataOut $sepChar] - } - if {[string compare $f -]} { - close $in - } -} - -exit DELETED examples/csv/csvdiff Index: examples/csv/csvdiff ================================================================== --- examples/csv/csvdiff +++ /dev/null @@ -1,163 +0,0 @@ -#!/bin/sh -# use -*- tcl -*- \ -exec tclsh "$0" "$@" -# Perform a diff on two CSV files. -# The result is a CSV file - -package require csv -package require cmdline - -# ---------------------------------------------------- -# csvdiff ?-sep sepchar? ?-key LIST? file1 file2 -# -# Argument processing and checks. - -set sepChar , -set usage "Usage: $argv0 ?-n? ?-sep sepchar? ?-key LIST? file1 file2\n\tLIST=idx,...\n\tidx in \{n, -m, n-, n-m\}" -set keySpec "0-" - -# lineout = boolean flag, indicates if linenumbers has to be written -# as part of the output (1) or not (0). Defaults to 0. - -set lineout 0 -while {[set ok [cmdline::getopt argv {sep.arg key.arg n} opt val]] > 0} { - #puts stderr "= $opt $val" - switch -exact -- $opt { - sep {set sepChar $val} - key {set keySpec $val} - n {set lineout 1} - } -} -if {($ok < 0) || ([llength $argv] != 2)} { - puts stderr $usage - exit -1 -} - -foreach {fileA fileB} $argv break - - -if {[llength $keySpec] == 0} { - #puts stderr >>$keySpec<< - #puts stderr B - puts stderr $usage - exit -1 -} - -set idx [list] -foreach i $keySpec { - if {[regexp -- {[0-9]+-[0-9]+} $i]} { - foreach {f t} [split $i -] break - lappend idx [list $f $t] - } elseif {[regexp -- {[0-9]+-} $i]} { - foreach {f t} [split $i -] break - lappend idx [list $f end] - } elseif {[regexp -- {-[0-9]+} $i]} { - foreach {f t} [split $i -] break - lappend idx [list 0 $t] - } elseif {[regexp -- {[0-9]+} $i]} { - lappend idx [list $i $i] - } else { - #puts stderr >>$idx<< - #puts stderr C - puts stderr $usage - exit -1 - } -} -set keySpec $idx - - -set inA [open $fileA r] -set inB [open $fileB r] - -# ---------------------------------------------------- -# Actual processing, uses the following information from the -# commandline: -# -# inA - channel for input A -# inB - channel for input B -# sepChar - separator character - -# We read file2 completely and then go through the records of -# file1. For any record we don't find we write a "deleted" record. If -# we find the matching record we remove it from the internal -# storage. In a second sweep through the internal array we write -# "added" records for the remaining data as that was not in file1 but -# is in file2. - -proc keyof {data} { - global keySpec - set key [list] - foreach i $keySpec { - foreach {f t} $i break - eval lappend key [lrange $data $f $t] - } - return $key -} - - - -set order [list] -array set map {} -set linenum 0 -while {![eof $inB]} { - if {[gets $inB line] < 0} { - continue - } - incr linenum - set data [::csv::split $line $sepChar] - set key [keyof $data] - - if {[info exist map($key)]} { - puts stderr "warning: $key occurs multiple times in $fileB (lines $linenum and $map($key))" - } - set map($key) $linenum - lappend order $data -} -close $inB - -set linenum 0 - -if {$lineout} { - array set lmap {} -} - -while {![eof $inA]} { - if {[gets $inA line] < 0} { - continue - } - incr linenum - set data [::csv::split $line $sepChar] - set key [keyof $data] - - if {$lineout} {set lmap($key) $linenum} - - if {[info exists map($key)]} { - if {$map($key) < 0} { - puts stderr "warning: $key occurs multiple times\ - in $fileA (lines $linenum and [expr {-$map($key)}]" - } else { - set map($key) [expr {-$linenum}] - } - continue - } - - if {$lineout} { - puts stdout [::csv::join [linsert $data 0 - $linenum] $sepChar] - } else { - puts stdout [::csv::join [linsert $data 0 -] $sepChar] - } -} -close $inA - -foreach data $order { - set key [keyof $data] - if {$map($key) > 0} { - if {$lineout} { - puts stdout [::csv::join [linsert $data 0 + $lmap($key)] $sepChar] - } else { - puts stdout [::csv::join [linsert $data 0 +] $sepChar] - } - } -} - -exit DELETED examples/csv/csvjoin Index: examples/csv/csvjoin ================================================================== --- examples/csv/csvjoin +++ /dev/null @@ -1,122 +0,0 @@ -#!/bin/sh -# use -*- tcl -*- \ -exec tclsh "$0" "$@" -# Join two CSV files by key - -package require csv -package require cmdline - -# ---------------------------------------------------- -# csvuniq ?-sep sepchar? keycol1 file1.in keycol2 file2.in file.out|- -# -# Argument processing and checks. - -set sepChar , -set outer 0 - -set usage "Usage: $argv0 ?-sep sepchar? ?-outer? key1 file1.in key2 file2.in file.out|-" - -while {[set ok [cmdline::getopt argv {sep.arg outer} opt val]] > 0} { - #puts stderr "= $opt $val" - switch -exact -- $opt { - sep {set sepChar $val} - outer {set outer 1} - } -} -if {($ok < 0) || ([llength $argv] != 5)} { - puts stderr $usage - exit -1 -} - -foreach {keyA inA keyB inB out} $argv break - -if { - ![string is integer $keyA] || - ($keyA < 0) || - ![string is integer $keyB] || - ($keyB < 0) || - ![string compare $inA ""] || - ![string compare $inB ""] || - ![string compare $out ""] -} { - puts stderr $usage - exit -1 -} - -if {![string compare $out -]} { - set out stdout -} else { - set out [open $out w] -} - -set inA [open $inA r] -set inB [open $inB r] - -# ---------------------------------------------------- -# Actual processing, uses the following information from the -# commandline: -# -# inA - channel for input A -# inB - channel for input B -# out - channel for output -# sepChar - separator character -# keyA - key column in A -# keyB - key column in B - -# 1. Read input B completely into an array indexed by the contents of -# the key column. Store only the non-key information of input -# B. Note that B may contain several lines having the same key. -# -# 2. Read input A line by line and match its key information against -# the array. If there is no match ignore the record, else join the -# record with all records from the array and write the resulting -# records into the output. - -set bwidth 0 - -array set map {} -while {![eof $inB]} { - if {[gets $inB line] < 0} { - continue - } - - set data [::csv::split $line $sepChar] - set key [lindex $data $keyB] - set data [lreplace $data $keyB $keyB] - - if {[info exists map($key)]} { - lappend map($key) $data - } else { - set map($key) [list $data] - } - set bwidth [llength $data] -} -close $inB - -while {![eof $inA]} { - if {[gets $inA line] < 0} { - continue - } - set data [::csv::split $line $sepChar] - set key [lindex $data $keyA] - - if {[info exists map($key)]} { - foreach record $map($key) { - set res $data - eval lappend res $record - puts $out [::csv::join $res $sepChar] - } - } elseif {$outer} { - # Nothing was found, but an outer join was requested too => - # append 'bwidth' empty cells to the data and write the new - # record. - - for {set i 0} {$i < $bwidth} {incr i} { - lappend data {} - } - - puts $out [::csv::join $data $sepChar] - } -} - -exit ; # automatically closes the channels DELETED examples/csv/csvsort Index: examples/csv/csvsort ================================================================== --- examples/csv/csvsort +++ /dev/null @@ -1,95 +0,0 @@ -#!/bin/sh -# use -*- tcl -*- \ -exec tclsh "$0" "$@" -# Sort CSV data by a column - -package require csv -package require cmdline - -# ---------------------------------------------------- -# csvsort ?-sep sepchar? ?-f? ?-n? ?-r? ?-skip cnt? column file.in|- file.out|- -# -# Argument processing and checks. - -set sepChar , -set sortmode ascii -set order increasing -set reverse 0 -set skip 0 - -set usage "Usage: $argv0 ?-sep sepchar? ?-f? ?-n? ?-r? ?-skip cnt? column file.in|- file.out|-" - -while {[set ok [cmdline::getopt argv {sep.arg f n r skip.arg} opt val]] > 0} { - #puts stderr "= $opt $val" - switch -exact -- $opt { - sep {set sepChar $val} - n {set sortmode integer} - f {set sortmode real} - r {set order decreasing} - skip {set skip $val} - } -} -if {($ok < 0) || ([llength $argv] != 3)} { - puts stderr $usage - exit -1 -} - -foreach {sortCol in out} $argv break - -if { - ![string is integer $sortCol] || - ($sortCol < 0) || - ![string compare $in ""] || - ![string compare $out ""] -} { - puts stderr $usage - exit -1 -} - -if {![string compare $in -]} { - set in stdin -} else { - set in [open $in r] -} -if {![string compare $out -]} { - set out stdout -} else { - set out [open $out w] -} - -# ---------------------------------------------------- -# Actual processing, uses the following information from the -# commandline: -# -# in - channel for input -# out - channel for output -# sepChar - separator character -# sortCol - column to sort after -# sortmode - Sort integer (1) or string (0) -# reverse - Sort ascending (0) or descending (1) -# skip - Skip that many lines at the beginning. - -set data [list] - -while {![eof $in]} { - if {[gets $in line] < 0} { - continue - } - if {$skip > 0} { - puts $out $line - incr skip -1 - continue - } - lappend data [::csv::split $line $sepChar] -} - -#puts stderr $sortmode,$order - -set data [lsort -index $sortCol -$order -$sortmode $data] - -foreach item $data { - puts $out [::csv::join $item $sepChar] -} - -exit ; # automatically closes the channels - DELETED examples/csv/csvuniq Index: examples/csv/csvuniq ================================================================== --- examples/csv/csvuniq +++ /dev/null @@ -1,81 +0,0 @@ -#!/bin/sh -# use -*- tcl -*- \ -exec tclsh "$0" "$@" -# Make CSV data the specified column unique. - -package require csv -package require cmdline - -# ---------------------------------------------------- -# csvuniq ?-sep sepchar? column file.in|- file.out|- -# -# Argument processing and checks. - -set sepChar , - -set usage "Usage: $argv0 ?-sep sepchar? column file.in|- file.out|-" - -while {[set ok [cmdline::getopt argv {sep.arg} opt val]] > 0} { - #puts stderr "= $opt $val" - switch -exact -- $opt { - sep {set sepChar $val} - } -} -if {($ok < 0) || ([llength $argv] != 3)} { - puts stderr $usage - exit -1 -} - -foreach {uniCol in out} $argv break - -if { - ![string is integer $uniCol] || - ($uniCol < 0) || - ![string compare $in ""] || - ![string compare $out ""] -} { - puts stderr $usage - exit -1 -} - -if {![string compare $in -]} { - set in stdin -} else { - set in [open $in r] -} -if {![string compare $out -]} { - set out stdout -} else { - set out [open $out w] -} - -# ---------------------------------------------------- -# Actual processing, uses the following information from the -# commandline: -# -# in - channel for input -# out - channel for output -# sepChar - separator character -# uniCol - column to make unique - -set last "" -set first 1 - -while {![eof $in]} { - if {[gets $in line] < 0} { - continue - } - - set data [::csv::split $line $sepChar] - - if {$first} { - set first 0 - set last [lindex $data $uniCol] - puts $out [::csv::join $data $sepChar] - } elseif {[string compare $last [lindex $data $uniCol]] != 0} { - set last [lindex $data $uniCol] - puts $out [::csv::join $data $sepChar] - } ; # else {no change in column, ignore record} -} - -exit ; # automatically closes the channels DELETED examples/dns/tk_sample.tcl Index: examples/dns/tk_sample.tcl ================================================================== --- examples/dns/tk_sample.tcl +++ /dev/null @@ -1,88 +0,0 @@ -# tk-sample.tcl - Copyright (C) 2002 Pat Thoyts -# -# Derived from Neil Madden's browser sig :) -# -# Note that this doesn't work for sites using virtual hosting and is dubious for -# multi-homed sites too. This is only to illustrate the resolver usage. What we -# should be doing is connecting a socket to the resolved address and then requesting -# the original URL. Useless if there is a proxy between you as well. -# -# $Id: tk_sample.tcl,v 1.1 2002/03/02 01:54:21 patthoyts Exp $ - -package require Tkhtml -package require http -package require dns - -set Sample(URL) http://mini.net/tcl/976.html -set Sample(nameserver) localhost - -# Description: -# Construct a simple web browser interface. -# -proc gui {} { - frame .f -bd 0 -relief flat - label .f.l1 -text "Nameserver" -underline 0 - entry .f.e1 -textvariable ::Sample(nameserver) - label .f.l2 -text "URL" -underline 0 - entry .f.e2 -textvariable ::Sample(URL) - button .f.b -text Go -underline 0 -command {get $::Sample(URL)} - button .f.x -text Exit -underline 1 -command {bye} - - scrollbar .v -orient v -command {.h yv} - html .h -yscrollcommand {.v set} - - pack .f.l1 -side left -fill y - pack .f.e1 -side left -fill both -expand 1 - pack .f.x -side right -fill y - pack .f.b -side right -fill y - pack .f.l2 -side left -fill y - pack .f.e2 -side right -fill both -expand 1 - - pack .f -side top -fill x - pack .v -side right -fill y - pack .h -fill both -expand 1 - - bind .h.x <1> {eval get [.h href %x %y]} -} - -proc bye {} { - destroy .f .v .h -} - -proc bgerror {args} { -} - -# Description: -# Rewrite the URL by looking up the domain name and replacing with the -# IP address. -# -proc resolve {url} { - global Sample - if {![catch {array set URL [uri::split $url]} msg]} { - set tok [dns::resolve $URL(host) -server $Sample(nameserver)] - if {[dns::status $tok] == "ok"} { - set URL(host) [dns::address $tok] - set url [eval uri::join [array get URL]] - } - dns::cleanup $tok - } - log::log debug "resolved to $url" - return $url -} - -# Description: -# Fetch an HTTP URL and display. -# -proc get {url} { - global Sample - set url [resolve $url] - set Sample(URL) $url - set tok [http::geturl $url -headers $::auth] - .h clear - .h parse [http::data $tok] - http::cleanup $tok - .h configure -base $url -} - -gui -get $::Sample(URL) DELETED examples/doctools/doctools.idx Index: examples/doctools/doctools.idx ================================================================== --- examples/doctools/doctools.idx +++ /dev/null @@ -1,81 +0,0 @@ -[index_begin tcllib/doctools {Documentation tools}] - [key HTML] - [manpage didxengine {docidx engine}] - [manpage didxformat {docidx format}] - [manpage doctools {doctools package}] - [manpage dtformat {doctools format}] - [manpage dtformatter {doctools formatter}] - [manpage dtocengine {doctoc engine}] - [manpage dtocformat {doctoc format}] - [manpage mpexpand mpexpand] - [key TMML] - [manpage didxengine {docidx engine}] - [manpage didxformat {docidx format}] - [manpage doctools {doctools package}] - [manpage dtformat {doctools format}] - [manpage dtformatter {doctools formatter}] - [manpage dtocengine {doctoc engine}] - [manpage dtocformat {doctoc format}] - [manpage mpexpand mpexpand] - [key conversion] - [manpage didxengine {docidx engine}] - [manpage didxformat {docidx format}] - [manpage doctools {doctools package}] - [manpage dtformat {doctools format}] - [manpage dtformatter {doctools formatter}] - [manpage dtocengine {doctoc engine}] - [manpage dtocformat {doctoc format}] - [manpage mpexpand mpexpand] - [key documentation] - [manpage doctools {doctools package}] - [manpage dtformatter {doctools formatter}] - [key index] - [manpage didxengine {docidx engine}] - [manpage didxformat {docidx format}] - [manpage doctools {doctools package}] - [manpage dtformat {doctools format}] - [manpage dtocformat {doctoc format}] - [key interface] - [manpage didxengine {docidx engine}] - [manpage dtformatter {doctools formatter}] - [manpage dtocengine {doctoc engine}] - [key manpage] - [manpage didxengine {docidx engine}] - [manpage didxformat {docidx format}] - [manpage doctools {doctools package}] - [manpage dtformat {doctools format}] - [manpage dtformatter {doctools formatter}] - [manpage dtocengine {doctoc engine}] - [manpage dtocformat {doctoc format}] - [manpage mpexpand mpexpand] - [key markup] - [manpage didxengine {docidx engine}] - [manpage didxformat {docidx format}] - [manpage doctools {doctools package}] - [manpage dtformat {doctools format}] - [manpage dtformatter {doctools formatter}] - [manpage dtocengine {doctoc engine}] - [manpage dtocformat {doctoc format}] - [manpage mpexpand mpexpand] - [key nroff] - [manpage didxengine {docidx engine}] - [manpage didxformat {docidx format}] - [manpage doctools {doctools package}] - [manpage dtformat {doctools format}] - [manpage dtformatter {doctools formatter}] - [manpage dtocengine {doctoc engine}] - [manpage dtocformat {doctoc format}] - [manpage mpexpand mpexpand] - [key {table of contents}] - [manpage didxformat {docidx format}] - [manpage doctools {doctools package}] - [manpage dtformat {doctools format}] - [manpage dtocengine {doctoc engine}] - [manpage dtocformat {doctoc format}] - [key toc] - [manpage didxformat {docidx format}] - [manpage doctools {doctools package}] - [manpage dtformat {doctools format}] - [manpage dtocengine {doctoc engine}] - [manpage dtocformat {doctoc format}] -[index_end] DELETED examples/doctools/doctools.toc Index: examples/doctools/doctools.toc ================================================================== --- examples/doctools/doctools.toc +++ /dev/null @@ -1,36 +0,0 @@ -[toc_begin tcllib/doctools {Documentation tools}] -[division_start {Basic format}] -[item dtformat dtformat {doctools format specification}] -[item dtformatter dtformatter {doctools engine interface}] -[item doctools doctools {Package to handle doctools input and engines}] -[division_end] -[division_start {Table of Contents}] -[item dtocformat dtocformat {doctoc format specification}] -[item dtocformatter dtocformatter {doctoc engine interface}] -[item doctoc doctoc {Package to handle doctoc input and engines}] -[division_end] -[division_start {Indices}] -[item dtidxformat dtidxformat {docindex format specification}] -[item dtidxformatter dtidxformatter {docindex engine interface}] -[item docindex docindex {Package to handle docindex input and engines}] -[division_end] -[division_start {Test}] -[division_start {Test2}] -[item dtidxformat dtidxformat {docindex format specification}] -[division_end] -[division_start {Test3}] -[item dtidxformatter dtidxformatter {docindex engine interface}] -[division_end] -[division_end] -[division_start {Test}] -[division_start {Test2}] -[item AAAAAAA AA AA] -[division_end] -[division_start {Test3}] -[item BBBBBBB BB BB] -[division_end] -[division_end] -[division_start {Test4}] -[item CCCCCCC CC CC] -[division_end] -[toc_end] DELETED examples/ftp/ChangeLog Index: examples/ftp/ChangeLog ================================================================== --- examples/ftp/ChangeLog +++ /dev/null @@ -1,4 +0,0 @@ -2002-02-14 Andreas Kupries - - * hpupdate.tcl: Frink run. - DELETED examples/ftp/README Index: examples/ftp/README ================================================================== --- examples/ftp/README +++ /dev/null @@ -1,61 +0,0 @@ -======================= -ftp examples README -======================= - -Example #1 - Directory Mirror (mirror.tcl) ------------------------------ - -The script mirror.tcl is used to mirror a complete remote directory -structure. It creates an exact copy of this structure on the locale -machine. Three parameters needs to be modified to work properly, -the hostname of the remote server, the username and the password -for login. - - -Example #2 - Software Update (newer.tcl) ----------------------------- - -The script newer.tcl is used to detect whether a new release of -Brent Welch's phantastic tcl-httpd is present at scriptics ftp -server. If ftp::Newer detects a newer file then it causes the -upload process and sends me (as root) an email to inform about. -The file name for the remote copy of tclhttpd may have changed, -and the script needs a local copy of tclhttpd's source to do -the comparison. - -Example #3 - Homepage Update (hpupdate.tcl) ----------------------------- - -Quite a few people must have to keep permanent updating their -homepages on a ISP server. hpupdate.tcl is a tk-program for -the interactive comparsion of the homepage directory on the local -computer with the same directories on the remote homepage server. - -It is based on File Transfer Protocol. This process can be automated -easily by hpupdate. It makes it quick and easy to keep the track of -new/old or changed files. - -Brief overview: - - - FTP connection to remote server - - Processing subdirectories - - Display of summary used and selected disk space - - Automatically all superfluous directories/files of remote - homepage server will be deleted - - Automatically all new/updated files will be uploaded - - Tested under Linux, should also run without problems under - Windows 95/NT and on Macintosh computers - -Example #4 - TkCon command line ftp client ------------------------------------------- - -Loading the ftp Library Package into Jeffrey Hobbs' TkCon rovides -a simple ftp command line utility with command history. TkCon is a -replacement for the standard console that comes with Tk. It must be -started with the "package" option: - - tkcon -package ftp - -to load ftp automatically. TkCon is available at - - http://www.purl.org/net/hobbs/tcl/script/tkcon DELETED examples/ftp/ftpdemo.tcl Index: examples/ftp/ftpdemo.tcl ================================================================== --- examples/ftp/ftpdemo.tcl +++ /dev/null @@ -1,860 +0,0 @@ -#!/bin/sh -# the next line restarts using wish \ -exec wish8.3 "$0" "$@" -# -# - simple tcl/tk test script for FTP library package - -# -# Required: tcl/tk8.3 -# -# Created: 07/97 -# Changed: 07/00 -# Version: 1.1 -# -# Copyright (C) 1997,1998 Steffen Traeger -# EMAIL: Steffen.Traeger@t-online.de -# URL: http://home.t-online.de/home/Steffen.Traeger -# -# This program is free software; you can redistribute it and/or -# modify it. -# 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. -# -######################################################################## - -package require Tcl 8 -package require Tk -package require ftp 2.0 - -# set palette under X -if { [string range [winfo server .] 0 0] == "X" } { - option add *background LightGray - tk_setPalette LightGray - option add *Text.foreground black - option add *Text.background [option get . selectBackground Listbox] - option add *Listbox.background [option get . selectBackground Listbox] - option add *Listbox.selectBackground [option get . insertBackground Listbox] - option add *Listbox.selectForeground white - option add *Entry.background [option get . selectBackground Listbox] - option add *Entry.selectBackground [option get . insertBackground Listbox] - option add *Entry.selectForeground white - option add *borderWidth 2 -} else { - option add *Checkbutton.borderWidth 0 - option add *Radiobutton.borderWidth 0 - -} - -# main window -wm title . "ftp Test" -wm iconname . ftptest -wm minsize . 1 1 - -# split area -frame .msg -bd 1 -relief raised - pack .msg -in . -side top -fill both -expand 1 -frame .op -bd 1 -relief raised - pack .op -in . -side top -fill x -frame .but -bd 1 -relief raised - pack .but -in . -side top -fill both -expand 1 - -#################################################################### -# Frame 1 -# -# Options -frame .op.f -bd 3 - pack .op.f -in .op -side top -fill x - -### options -frame .op.f.f1 -bd 3 - pack .op.f.f1 -in .op.f -side left -fill both -label .op.f.f1.l -bd 2 -text "Server Options: " -relief flat -anchor w - pack .op.f.f1.l -in .op.f.f1 -side top -fill x - -frame .op.f.f1.server -bd 2 - pack .op.f.f1.server -in .op.f.f1 -side top -fill x -padx 15 -label .op.f.f1.server.l -text "Host: " -width 10 -relief flat -anchor w - pack .op.f.f1.server.l -in .op.f.f1.server -side left -fill x -entry .op.f.f1.server.e -width 20 - pack .op.f.f1.server.e -in .op.f.f1.server -side left -fill x - -frame .op.f.f1.port -bd 2 - pack .op.f.f1.port -in .op.f.f1 -side top -fill x -padx 15 -label .op.f.f1.port.l -text "Port: " -width 10 -relief flat -anchor w - pack .op.f.f1.port.l -in .op.f.f1.port -side left -fill x -entry .op.f.f1.port.e -width 5 - pack .op.f.f1.port.e -in .op.f.f1.port -side left -fill x - -frame .op.f.f1.username -bd 2 - pack .op.f.f1.username -in .op.f.f1 -side top -fill x -padx 15 -label .op.f.f1.username.l -text "Username: " -width 10 -relief flat -anchor w - pack .op.f.f1.username.l -in .op.f.f1.username -side left -fill x -entry .op.f.f1.username.e -width 10 - pack .op.f.f1.username.e -in .op.f.f1.username -side left -fill x - -frame .op.f.f1.password -bd 2 - pack .op.f.f1.password -in .op.f.f1 -side top -fill x -padx 15 -label .op.f.f1.password.l -text "Password: " -width 10 -relief flat -anchor w - pack .op.f.f1.password.l -in .op.f.f1.password -side left -fill x -entry .op.f.f1.password.e -width 10 -show "*" - pack .op.f.f1.password.e -in .op.f.f1.password -side left -fill x - -frame .op.f.f1.directory -bd 2 - pack .op.f.f1.directory -in .op.f.f1 -side top -fill x -padx 15 -label .op.f.f1.directory.l -text "Directory: " -width 10 -relief flat -anchor w - pack .op.f.f1.directory.l -in .op.f.f1.directory -side left -fill x -entry .op.f.f1.directory.e -width 20 - pack .op.f.f1.directory.e -in .op.f.f1.directory -side left -fill x - -# Separator -frame .op.f.sep1 -bd 1 -relief sunken - pack .op.f.sep1 -in .op.f -fill y -side left -pady 2 -padx 4 -frame .op.f.sep1.f -bd 1 -relief flat - pack .op.f.sep1.f -in .op.f.sep1 -fill y -side left - -frame .op.f.f2 -bd 3 - pack .op.f.f2 -in .op.f -side left -fill both -ipadx 15 -### transfer mode -label .op.f.f2.l2 -borderwidth 2 -anchor w -text "Transfer mode:" - pack .op.f.f2.l2 -in .op.f.f2 -side top -fill x -radiobutton .op.f.f2.active -anchor w -text "Active" -variable test(mode) -value "active" - pack .op.f.f2.active -in .op.f.f2 -side top -fill x -padx 15 -radiobutton .op.f.f2.passive -anchor w -text "Passive" -variable test(mode) -value "passive" - pack .op.f.f2.passive -in .op.f.f2 -side top -fill x -padx 15 - -#################################################################### -# Frame 2 -# -### debugging -label .op.f.f2.l1 -borderwidth 2 -anchor w -text "Debugging:" - pack .op.f.f2.l1 -in .op.f.f2 -side top -fill x -checkbutton .op.f.f2.debug -anchor w -text "Debug" -variable ftp::DEBUG - pack .op.f.f2.debug -in .op.f.f2 -side top -fill x -padx 15 -checkbutton .op.f.f2.verbose -anchor w -text "Verbose" -variable ftp::VERBOSE - pack .op.f.f2.verbose -in .op.f.f2 -side top -fill x -padx 15 - -#Iterations -frame .op.f.f2.loops -bd 2 - pack .op.f.f2.loops -in .op.f.f2 -side top -fill x -pady 2 -label .op.f.f2.loops.l -borderwidth 2 -text "Iterations: " -relief flat -anchor w - pack .op.f.f2.loops.l -in .op.f.f2.loops -side left -fill x -entry .op.f.f2.loops.e -borderwidth 2 -width 5 - pack .op.f.f2.loops.e -in .op.f.f2.loops -side left -fill x - -# Separator -frame .op.f.sep2 -bd 1 -relief sunken - pack .op.f.sep2 -in .op.f -fill y -side left -pady 2 -padx 4 -frame .op.f.sep2.f -bd 1 -relief flat - pack .op.f.sep2.f -in .op.f.sep2 -fill y -side left - -#################################################################### -# Frame 3 -# -frame .op.f.f3 -bd 3 - pack .op.f.f3 -in .op.f -side left -fill both -expand 1 -ipadx 15 - -label .op.f.f3.l1 -anchor w -width 10 -text "Variable trace:" - pack .op.f.f3.l1 -in .op.f.f3 -side top -fill x - -frame .op.f.f3.v0 -bd 0 - pack .op.f.f3.v0 -in .op.f.f3 -side top -fill x -pady 2 -padx 15 -label .op.f.f3.v0.name -anchor w -text "iterations = " - pack .op.f.f3.v0.name -in .op.f.f3.v0 -side left -fill x -label .op.f.f3.v0.value -anchor w -textvariable test(loop) - pack .op.f.f3.v0.value -in .op.f.f3.v0 -side top -fill x -frame .op.f.f3.v1 -bd 0 - pack .op.f.f3.v1 -in .op.f.f3 -side top -fill x -pady 2 -padx 15 -label .op.f.f3.v1.name -anchor w -text "errors = " - pack .op.f.f3.v1.name -in .op.f.f3.v1 -side left -fill x -label .op.f.f3.v1.value -anchor w -textvariable test(errors) - pack .op.f.f3.v1.value -in .op.f.f3.v1 -side top -fill x -frame .op.f.f3.v2 -bd 0 - pack .op.f.f3.v2 -in .op.f.f3 -side top -fill x -pady 2 -padx 15 -label .op.f.f3.v2.name -anchor w -text "after queues = " - pack .op.f.f3.v2.name -in .op.f.f3.v2 -side left -fill x -label .op.f.f3.v2.value -anchor w -textvariable test(after) - pack .op.f.f3.v2.value -in .op.f.f3.v2 -side top -fill x -frame .op.f.f3.v4 -bd 0 - pack .op.f.f3.v4 -in .op.f.f3 -side top -fill x -pady 2 -padx 15 -label .op.f.f3.v4.name -anchor w -text "open channels:" - pack .op.f.f3.v4.name -in .op.f.f3.v4 -side top -fill x -label .op.f.f3.v4.value -anchor w -textvariable test(open) - pack .op.f.f3.v4.value -in .op.f.f3.v4 -side top -fill x -padx 8 - -##################################################################################### -# Messages -frame .msg.f -bd 3 - pack .msg.f -in .msg -side top -fill both -expand 1 - -frame .msg.f.f1 -bd 2 -relief groove - pack .msg.f.f1 -in .msg.f -side left -fill both -padx 2 -pady 2 -label .msg.f.f1.l -text "Test commands: " -relief flat -anchor w - pack .msg.f.f1.l -in .msg.f.f1 -side top -fill x -padx 4 -pady 2 - -### Test commands -set idlist {} -foreach {id text} { quote "System Info"\ - list "List" \ - nlist "NList" \ - dir "Cd, MkDir, RmDir" \ - afile "ASCII Put/Get" \ - bfile "Binary Put/Ret" \ - ren "Rename" \ - append "Append" \ - new "Newer" \ - reget "Reget" \ - notfound "file not found"} { - checkbutton .msg.f.f1.$id -anchor w -text $text -variable test($id) - pack .msg.f.f1.$id -in .msg.f.f1 -side top -fill x -padx 16 - set test($id) 1 - lappend idlist $id -} -button .msg.f.f1.plus -text "+ all" -command "foreach i {$idlist} {set test(\$i) 1}" - pack .msg.f.f1.plus -in .msg.f.f1 -side left -fill x -padx 16 -pady 8 -button .msg.f.f1.minus -text "- all" -command "foreach i {$idlist} {set test(\$i) 0}" - pack .msg.f.f1.minus -in .msg.f.f1 -side left -fill x -pady 8 - -frame .msg.f.f2 -bd 2 -relief groove - pack .msg.f.f2 -in .msg.f -side left -fill both -pady 2 - -label .msg.f.f2.label -text "Messages:" -anchor w - pack .msg.f.f2.label -in .msg.f.f2 -side top -fill x -padx 2 -scrollbar .msg.f.f2.yscroll -command ".msg.f.f2.text yview" - pack .msg.f.f2.yscroll -in .msg.f.f2 -side right -fill y -scrollbar .msg.f.f2.xscroll -relief sunken -orient horizontal -command ".msg.f.f2.text xview" - pack .msg.f.f2.xscroll -in .msg.f.f2 -side bottom -fill x -text .msg.f.f2.text -relief sunken -setgrid 1 -wrap none -height 20 -width 80 -bg white -fg black\ - -state disabled -xscrollcommand ".msg.f.f2.xscroll set" \ - -yscrollcommand ".msg.f.f2.yscroll set" - pack .msg.f.f2.text -in .msg.f.f2 -side left -expand 1 -fill both -.msg.f.f2.text tag configure error -foreground red -.msg.f.f2.text tag configure data -foreground brown -.msg.f.f2.text tag configure control -foreground blue -.msg.f.f2.text tag configure header -foreground white -background black - -##################################################################################### -# Buttons -frame .but.f -bd 3 - pack .but.f -in .but -side top -fill both -expand 1 - -frame .but.f.f1 -bd 3 - pack .but.f.f1 -in .but.f -side top -fill x -padx 15 -pady 6 -button .but.f.f1.start -text "Start Test" -width 12 -state normal -command "StartTest" - pack .but.f.f1.start -side left -fill x -padx 15 -button .but.f.f1.stop -text "Stop Test" -width 12 -state disabled -command "StopTest" - pack .but.f.f1.stop -side left -fill x -padx 15 -button .but.f.f1.close -text "Quit" -width 12 -state normal -command "destroy ." - pack .but.f.f1.close -side right -fill x -padx 15 -button .but.f.f1.save -text "Save Options" -width 12 -state normal -command "SaveConfig" - pack .but.f.f1.save -side right -fill x -padx 15 - -################ procedures #################################################################### - -# overwrite default ftp display message procedure -namespace eval ftp { -proc DisplayMsg {s msg {state ""}} { -global test - .msg.f.f2.text configure -state normal - - # change state from "error" to "" for procedure test_9notfound - if { ($state == "error") && [info exist test(proc)] && ($test(proc) == "test_99notfound") } { - set state "" - } - - switch -exact -- $state { - data {.msg.f.f2.text insert end "$msg\n" data} - control {.msg.f.f2.text insert end "$msg\n" control} - error {.msg.f.f2.text insert end "$msg\n" error; incr test(errors)} - header {.msg.f.f2.text insert end "$msg\n" header} - default {.msg.f.f2.text insert end "$msg\n"} - } - .msg.f.f2.text configure -state disabled - .msg.f.f2.text see end - update idletasks -}} - -# new tracing open command -rename open ftpopen -proc open {args} { -global test - set rc [eval ftpopen $args] - if {[lsearch -exact $test(open) $rc] == "-1"} { - lappend test(open) $rc - } -#puts "open: $test(open)" - return $rc -} - -# new tracing close command -rename close ftpclose -proc close {args} { -global test - set rc [eval ftpclose $args] - set index [lsearch -exact $test(open) $args] - if {$index != "-1"} { - set test(open) [lreplace $test(open) $index $index] - } -#puts "close: $test(open)" - return $rc -} - -# new tracing socket command -rename socket ftpsocket -proc socket {args} { -global test - set rc [eval ftpsocket $args] - if {[lsearch -exact $test(open) $rc] == "-1"} { - lappend test(open) $rc - } -#puts "socket: $test(open)" - return $rc -} - - -# new tracing InitDataConn command -namespace eval ftp { -rename InitDataConn ftpInitDataConn -proc InitDataConn {args} { -global test - set rc [eval ftpInitDataConn $args] - set s [lindex $args 0] - if {[lsearch -exact $test(open) $s] == "-1"} { - lappend test(open) $s - } -#puts "InitDataConn: $test(open)" - return $rc -}} - -# progress bar for put/get operations -proc ProgressBar {state {bytes 0} {total {}} {filename {}}} { -global progress - set w .progress - switch -exact -- $state { - init { - set progress(percent) "0%" - set progress(total) $total - set progress(left) 0 - toplevel $w -bd 0 -class Progressbar - wm transient $w . - wm title $w Progress - wm iconname $w Progress - wm resizable $w 0 0 - focus $w - - frame $w.frame -bd 4 - pack $w.frame -side top -fill both - label $w.frame.label -text "Transfering $filename..." -relief flat -anchor w -bd 1 - pack $w.frame.label -in $w.frame -side top -fill x -padx 10 -pady 5 - frame $w.frame.bar -bd 1 -relief sunken -bg #ffffff - pack $w.frame.bar -in $w.frame -side left -padx 10 -pady 5 - frame $w.frame.bar.dummy -bd 0 -width 250 -height 0 - pack $w.frame.bar.dummy -in $w.frame.bar -side top -fill x - frame $w.frame.bar.pbar -bd 0 -width 0 -height 20 - pack $w.frame.bar.pbar -in $w.frame.bar -side left - label $w.frame.proz -textvariable progress(percent) -width 5 -relief flat -anchor e -bd 1 - pack $w.frame.proz -in $w.frame -side right -padx 10 -pady 5 - - wm withdraw $w - update idletasks - set x [expr {[winfo x .] + ([winfo width .] / 2) - ([winfo reqwidth $w] / 2)}] - set y [expr {[winfo y .] + ([winfo height .] / 2) - ([winfo reqheight $w] / 2)}] - wm geometry $w +$x+$y - update idletasks - wm deiconify $w - update idletasks - } - - update { - if {![winfo exist $w]} {return} - set cur_width 250 - catch { - set progress(percent) "[expr {round($bytes) * 100 / $progress(total)}]%"; - set cur_width [expr {round($bytes * 250 / $progress(total))}] - } msg - $w.frame.bar.pbar configure -width $cur_width -bg #000080 - update idletasks - } - - done { - unset progress - destroy $w - update - } - default { - error "Unknown state \"$state\"" - } - } -} - -# -# 1.) list - returns a long list -# -proc test_10list {loop} { -global test - - # check if enabled - if {!$test(list)} {return} - - ftp::DisplayMsg $test(conn) "*** TEST $loop.1 (long directory listing) ***" header - set remote_list [ftp::List $test(conn)] - ftp::DisplayMsg $test(conn) "[llength $remote_list] directory lines!" -} - -# -# 2.) nlist - returns a sorted short list -# -proc test_20nlist {loop} { -global test - - # check if enabled - if {!$test(nlist)} {return} - - ftp::DisplayMsg $test(conn) "*** TEST $loop.2 (short directory listing) ***" header - set remote_list [ftp::NList $test(conn)] - ftp::DisplayMsg $test(conn) "[llength $remote_list] directory entries!" -} - - -# -# 3.) directory commands (cd, mkdir, rmdir) -# - creates a remote directory foo -# - changes to this directory -# - changes back to parent directory -# - removes a remote directory foo -# -proc test_30dir {loop} { -global test - - # check if enabled - if {!$test(dir)} {return} - ftp::DisplayMsg $test(conn) "*** TEST $loop.3 (directory commands cd,mkdir,rmdir) ***" header - ftp::Pwd $test(conn) - ftp::MkDir $test(conn) foo$test(pid) - ftp::Cd $test(conn) foo$test(pid) - ftp::Pwd $test(conn) - ftp::Cd $test(conn) .. - ftp::Pwd $test(conn) - ftp::RmDir $test(conn) foo$test(pid) -} - -# -# 4.) ascii put/get and delete -# - go to ascii mode -# - store a file to remote site -# - retrieve the same file from remote site -# - delete a file on remote site -# - compare the size of both files -# (file sizes should be equal or only the "\r" difference -# between DOS/WINDOWS <> UNIX -# -proc test_40afile {loop} { -global test - - # check if enabled - if {!$test(afile)} {return} - - ftp::DisplayMsg $test(conn) "*** TEST $loop.4 (put/get ascii files) ***" header - set ascii_file ftpdemo.tcl - set lsize [file size $ascii_file] - ftp::Type $test(conn) ascii - ftp::Put $test(conn) $ascii_file ignore$test(pid).tmp - - # FileSize only works proper in binary mode - ftp::Type $test(conn) binary - set rsize [ftp::FileSize $test(conn) ignore$test(pid).tmp] - ftp::Type $test(conn) ascii - ftp::Get $test(conn) ignore$test(pid).tmp - ftp::Delete $test(conn) ignore$test(pid).tmp - - catch { - ftp::DisplayMsg $test(conn) "Original File:\t$lsize bytes" - ftp::DisplayMsg $test(conn) "Stored File:\t$rsize bytes" - ftp::DisplayMsg $test(conn) "Retrieved File:\t[file size ignore$test(pid).tmp] bytes" - file delete ignore$test(pid).tmp } - -} - -# -# 5.) binary put/get -# - switch to binary mode -# - store a file to remote site -# - retrieve the same file from remote site -# - delete a file on remote site -# - compare the size of both files -# -proc test_50bfile {loop} { -global test tk_library - - # check if enabled - if {!$test(bfile)} {return} - - ftp::DisplayMsg $test(conn) "*** TEST $loop.5 (put/get binary files) ***" header - set bin_file $tk_library/demos/images/teapot.ppm - set lsize [file size $bin_file] - ftp::Type $test(conn) binary - - # Put with ProgressBar - # - ProgressBar init ... - # - ProgressBar update ... callback defined in ftp! - # - ProgressBar done - ProgressBar init 0 $lsize teapot.ppm - ftp::Put $test(conn) $bin_file ignore$test(pid).tmp - ProgressBar done - - # Put with ProgressBar - set rsize [ftp::FileSize $test(conn) ignore$test(pid).tmp] - ProgressBar init 0 $rsize ignore$test(pid).tmp - ftp::Get $test(conn) ignore$test(pid).tmp - ProgressBar done - - ftp::Delete $test(conn) ignore$test(pid).tmp - - catch { - ftp::DisplayMsg $test(conn) "Original File:\t$lsize bytes" - ftp::DisplayMsg $test(conn) "Stored File:\t$rsize bytes" - ftp::DisplayMsg $test(conn) "Retrieved File:\t[file size ignore$test(pid).tmp] bytes" - file delete ignore$test(pid).tmp - } - -} - -# -# 6.) rename -# - stores a binary file on remote site and renames it -# -proc test_60ren {loop} { -global test tk_library - - # check if enabled - if {!$test(ren)} {return} - - ftp::DisplayMsg $test(conn) "*** TEST $loop.6 (renaming remote files) ***" header - set bin_file $tk_library/demos/images/earth.gif - ftp::Type $test(conn) binary - ftp::Put $test(conn) $bin_file ignore$test(pid).tmp - ftp::Rename $test(conn) ignore$test(pid).tmp renamed$test(pid).tmp - ftp::Delete $test(conn) renamed$test(pid).tmp - -} -# -# 7.) append -# - go to ascii mode -# - store a ascii file to remote site -# - appends ascci file on remote site and renames it -# - delete a file on remote site -# - compare the size of both files -# remote file must have the double size -# (file sizes should be equal or only the "\r" difference -# between DOS/WINDOWS <> UNIX -# -proc test_70append {loop} { -global test tk_library - - # check if enabled - if {!$test(append)} {return} - - ftp::DisplayMsg $test(conn) "*** TEST $loop.7 (append ascii file) ***" header - set ascii_file ftpdemo.tcl - set lsize [file size $ascii_file] - ftp::Type $test(conn) ascii - ftp::Append $test(conn) $ascii_file ignore$test(pid).tmp - ftp::Append $test(conn) $ascii_file ignore$test(pid).tmp - ftp::Get $test(conn) ignore$test(pid).tmp - ftp::Delete $test(conn) ignore$test(pid).tmp - - catch { - ftp::DisplayMsg $test(conn) "Original File:\t$lsize bytes ( * 2 = [expr {$lsize * 2}])" - ftp::DisplayMsg $test(conn) "Appended File:\t[file size ignore$test(pid).tmp] bytes" - file delete ignore$test(pid).tmp } - -} - -# -# 8.) newer -# - create a local copy of a a file -# - create a remote copy of a a file -# - check date entries -# - transfer only if the specifieid file is newer -# -proc test_80new {loop} { -global test tk_library - - # check if enabled - if {!$test(new)} {return} - - ftp::DisplayMsg $test(conn) "*** TEST $loop.8 (newer) ***" header - set bin_file $tk_library/demos/images/earth.gif - ftp::Type $test(conn) binary - - file copy $bin_file ignore$test(pid).tmp - ftp::Put $test(conn) $bin_file ignore$test(pid).tmp - set datestr "%m/%d/%Y, %H:%M" - - set out {} - catch { - append out "Local File:\t[clock format [file mtime ignore$test(pid).tmp] -format $datestr -gmt 1]" \n - append out "Remote File:\t[clock format [ftp::ModTime $test(conn) ignore$test(pid).tmp] -format $datestr -gmt 1]" \n - } - - ftp::Newer $test(conn) ignore$test(pid).tmp - - catch { - append out "Local File:\t[clock format [file mtime ignore$test(pid).tmp] -format $datestr -gmt 1] (after ftp::Newer)" - } - - ftp::Delete $test(conn) ignore$test(pid).tmp - catch {file delete ignore$test(pid).tmp} - ftp::DisplayMsg $test(conn) $out - -} - -# -# 9.) reget - reget command -# - store file to remote site -# - write 6 bytes to local file -# - test the reget at position 6 -# -proc test_90reget {loop} { -global test tk_library - - # check if enabled - if {!$test(reget)} {return} - - ftp::DisplayMsg $test(conn) "*** TEST $loop.9 (reget command) ***" header - set bin_file $tk_library/demos/images/earth.gif - ftp::Type $test(conn) binary - ftp::Put $test(conn) $bin_file ignore$test(pid).tmp - set f [open ignore$test(pid).tmp w] - puts -nonewline $f "123456" - close $f - ftp::Reget $test(conn) ignore$test(pid).tmp - ftp::Delete $test(conn) ignore$test(pid).tmp - - catch { - ftp::DisplayMsg $test(conn) "Original File:\t\t[file size $bin_file]" - ftp::DisplayMsg $test(conn) "Transfered File:\t[file size ignore$test(pid).tmp]" - file delete ignore$test(pid).tmp - } -} - -## -# 10.) not existing file/directory -# all command with a not existing file name as parameter -# - nlist, filesize, modtime, delete, rename, cd, rmdir, put, get, reget, newer -# - write 6 bytes to local file -# - test the reget at position 6 -# -proc test_99notfound {loop} { -global test tk_library - - # check if enabled - if {!$test(notfound)} {return} - - ftp::DisplayMsg $test(conn) "*** TEST $loop.10 (not existing file/directory) ***" header - ftp::NList $test(conn) filenotfound - ftp::FileSize $test(conn) filenotfound - ftp::ModTime $test(conn) filenotfound - ftp::Rename $test(conn) filenotfound filenotfound - ftp::Delete $test(conn) filenotfound - ftp::Cd $test(conn) filenotfound - ftp::RmDir $test(conn) filenotfound - ftp::Put $test(conn) filenotfound - ftp::Get $test(conn) filenotfound - ftp::Reget $test(conn) filenotfound - ftp::Newer $test(conn) filenotfound -} - -# save preferences -proc SaveConfig {} { -global cnf - - set cnf(server) [.op.f.f1.server.e get] - set cnf(port) [.op.f.f1.port.e get] - set cnf(username) [.op.f.f1.username.e get] - set cnf(password) [.op.f.f1.password.e get] - set cnf(directory) [.op.f.f1.directory.e get] - set cnf(loops) [.op.f.f2.loops.e get] - set cnf(debug) $ftp::DEBUG - set cnf(verbose) $ftp::VERBOSE - - set f [open $cnf(configfile) w] - puts $f [array get cnf] - close $f -} - -# load preferences -proc LoadConfig {} { -global cnf - - # Defaults - set cnf(server) "xxx" - set cnf(port) 21 - set cnf(username) "xxx" - set cnf(password) "xxx" - set cnf(directory) "" - set cnf(loops) 1 - set cnf(debug) 0 - set cnf(verbose) 1 - - if {[file exists $cnf(configfile)]} { - set f [open $cnf(configfile) r] - array set cnf [read $f] - close $f - } - - .op.f.f1.server.e delete 0 end - .op.f.f1.server.e insert 0 $cnf(server) - .op.f.f1.port.e delete 0 end - .op.f.f1.port.e insert 0 $cnf(port) - .op.f.f1.username.e delete 0 end - .op.f.f1.username.e insert 0 $cnf(username) - .op.f.f1.password.e delete 0 end - .op.f.f1.password.e insert 0 $cnf(password) - .op.f.f1.directory.e delete 0 end - .op.f.f1.directory.e insert 0 $cnf(directory) - .op.f.f2.loops.e delete 0 end - .op.f.f2.loops.e insert 0 $cnf(loops) - set ::ftp::DEBUG $cnf(debug) - set ::ftp::VERBOSE $cnf(verbose) -} - -# stop the test -proc StopTest {} { -global test - set test(break) 1 -} - -# start the test -proc StartTest {} { -global test - - .but.f.f1.stop configure -state normal - .but.f.f1.start configure -state disabled - - .msg.f.f2.text configure -state normal - .msg.f.f2.text delete 1.0 end - .msg.f.f2.text configure -state disabled -fg black - - set loops [.op.f.f2.loops.e get] - set server [.op.f.f1.server.e get] - set port [.op.f.f1.port.e get] - set username [.op.f.f1.username.e get] - set passwd [.op.f.f1.password.e get] - set dir [.op.f.f1.directory.e get] - - # open a ftp server connection - set test(errors) 0 - set test(open) {} - set test(pid) [pid] - set start_time [clock seconds] - ftp::DisplayMsg "" "*** Test started at [clock format [clock seconds] -format %d.%m.%Y\ %H:%M:%S ] ..." header - if {[set conn [ftp::Open $server $username $passwd -port $port -progress {ProgressBar update} -mode $test(mode) -blocksize 8196 -timeout 60]] >= 0} { - - if {$test(quote)} { - ftp::DisplayMsg $conn [ftp::Quote $conn syst] - ftp::DisplayMsg $conn [ftp::Quote $conn site umask 022] - ftp::DisplayMsg $conn [ftp::Quote $conn help] - } - - - if { $dir != "" } { - ftp::Cd $conn $dir - } - - # begin test loop - set test(break) 0 - set test(conn) $conn - for {set test(loop) 1} {$test(loop) <= $loops} {incr test(loop)} { - if {$test(break)} {break} - foreach test(proc) [lsort [info proc test*]] { - if {$test(break)} {break} - - # count entries in the after queues - set test(after) [after info] - - # run procedure - eval $test(proc) $test(loop) - } - } - if {$test(break)} { - ftp::DisplayMsg "... user break!" error - } else { - incr test(loop) -1 - } - - ftp::Close $conn - set stop_time [clock seconds] - set elapsed [expr {$stop_time - $start_time}] - if { $elapsed == 0 } { set elapsed 1} - ftp::DisplayMsg "" "************************* THE END *************************" header - ftp::DisplayMsg "" "=> $loops iterations takes $elapsed seconds" - ftp::DisplayMsg "" "=> $test(errors) error(s) occured" - } - .but.f.f1.stop configure -state disabled - .but.f.f1.start configure -state normal -} - -# Help -proc Help {} { - .msg.f.f2.text configure -state normal - .msg.f.f2.text delete 1.0 end - .msg.f.f2.text insert 1.0 " **** CONFIGURATION HELP ***** - -Ftp_demo is the simple user interface to the ftp test program. It -checks all ftp commands of the FTP library package against an -existing FTP server. It requires some configuration entries specified -in the form below. - -- Host ... Host FTP server on which the connection will be established -- Username ... Users login name at host -- Password ... Users password at host -- Directory ... Starting directory when differs from root \"/\" -- Iterations ... Count of interations for the test algorithm (default 1) - -The message window shows all responses from the remote server, as well -as report on data transfer statistics and file sizes. Two switches -toggles enhanced output: - -1. Debug...Enables debugging (return code, state, real FTP commands ) -2. Verbose ... Forces to show all responses from the FTP server - -Active or passive file transfer mode is selected in the upper frame. -When ftpdemo uses the active mode it waits for the server to open -a connection to transfer files or get file listings. In passive mode -the server waits for ftpdemo to open a connection to transfer files -or get file listings. Passive mode is normally a requirement when -accessing sites via a firewall. - -Press \"Save Options\" to save these options in a configuration file. -Options will be restored next time you start the ftpdemo program. -Check marked test commands and start test by pressing \"Start test\" -button. Any time the test program can be canceled by pressing the -\"Stop test\" button. - -NOTE: ------ -THE FTP_DEMO PROGRAM IS A DEVELOPMENT AND DEBUGGING TOOL RATHER THAN -A USEFUL FTP USER INTERFACE. FEEL FREE TO USE IT. - - - ***" - .msg.f.f2.text configure -state disabled -fg darkgreen -} - -################ main ########################################################################## - -# default file transfer mode ... active -set test(mode) active - -# Configuration file -set cnf(configfile) "ftpdemo.cnf" -LoadConfig - -Help - - - - - - - DELETED examples/ftp/ftpvalid Index: examples/ftp/ftpvalid ================================================================== --- examples/ftp/ftpvalid +++ /dev/null @@ -1,78 +0,0 @@ -#!/bin/sh -# -*- tcl -*- \ -exec tclsh "$0" ${1+"$@"} -# Author: [Larry W. Virden] [LV], modified Andreas Kupries [AK] -# Version: 3 -# Validate the ftp: urls given on the command line. - -package require uri -package require ftp - -# Should eventually add a command line argument to toggle verbose -#set ftp::VERBOSE 1 - -if {0} { - proc ftp::DisplayMsg {s msg {state ""}} { - upvar ::ftp::ftp$s ftp - variable VERBOSE - - switch -exact -- $state { - data { - if { $VERBOSE } { puts $msg } - } - control { - if { $VERBOSE } { puts $msg } - } - error { - if { $VERBOSE } { puts "E: $msg" } - #error "ERROR: $msg" - } - default { - if { $VERBOSE } { puts $msg } - } - } - return - } -} - -foreach arg $argv { - array set current [uri::split $arg] - - # parray current - - if {[catch { - set fdc [ftp::Open $current(host) anonymous enteryourname@here.com] - } returncode]} { - puts stderr [format "error 1: unable to open %s\n" $current(host)] - continue - } - set ftp_dir [file dirname $current(path)] - set ftp_file [file tail $current(path)] - - if {[catch { - set result [ftp::Cd $fdc $ftp_dir] } returncode] - } { - puts stderr [format "error 2: unable to enter directory %s:%s\n" $current(host) $ftp_dir] - continue - } - - if { $result == 0 } { - puts stderr [format "error 3: failure to enter %s:%s\n" $current(host) $ftp_dir] - continue - } - - if {[catch { - set result [ftp::List $fdc "${ftp_file}*"] } returncode] - } { - puts stderr [format "error 4: no match for ${ftp_file}*\n" $current(host) $ftp_dir] - continue - } - if { $result == {} } { - puts stderr [format "error 5: no match for ${ftp_file}*\n" $current(host) $ftp_dir] - continue - } - - ftp::Close $fdc -} - -exit DELETED examples/ftp/hpupdate.tcl Index: examples/ftp/hpupdate.tcl ================================================================== --- examples/ftp/hpupdate.tcl +++ /dev/null @@ -1,1186 +0,0 @@ -#!/bin/sh -# the next line restarts using wish \ -exec wish8.3 "$0" -- "$@" -# -# - homepage update program using FTP - -# -# Required: tcl/tk8.2 -# -# Created: 12/96 -# Changed: 7/2000 -# Version: 2.0 -# -# Copyright (C) 1998 Steffen Traeger -# EMAIL: Steffen.Traeger@t-online.de -# URL: http://home.t-online.de/home/Steffen.Traeger -# -# This program is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -# -######################################################################## - -# load required FTP package library -package require ftp 2.0 -package require Tk -if {![llength [info commands tkButtonInvoke]]} { - ::tk::unsupported::ExposePrivateCommand tkButtonInvoke -} - -# LED Colors -set status(off) "#006666" -set status(on) "#00ff00" -set ftp(Mode) passive - -# set palette under X -if { [string range [winfo server .] 0 0] == "X" } { - set tk_strictMotif 1 - tk_setPalette LightGray - option add *font {Helvetica 12} - option add *Text.foreground black - option add *Text.background white - option add *Listbox.background white - option add *Listbox.selectForeground white - option add *Entry.background white - option add *Entry.selectBackground black - option add *Entry.selectForeground white - option add *Scrollbar.width 12 -} - -# main window -wm title . "hpupdate 2.0" -wm iconname . hpupdate -wm minsize . 1 1 - -# Menue -menu .menu -tearoff 0 -menu .menu.file -tearoff 0 -.menu add cascade -label "File" -menu .menu.file -underline 0 -.menu.file add command -label "Connect" -underline 0 -command {BusyCommand Connect} -accelerator Alt+C -.menu.file add command -label "Disconnect" -underline 1 -state disabled -command {BusyCommand Disconnect} -accelerator Alt+I -.menu.file add separator -.menu.file add command -label "Exit" -underline 0 -command Quit -accelerator Alt+X - -#menu .menu.edit -tearoff 0 -#.menu add cascade -label "Bearbeiten" -menu .menu.edit -underline 0 -#.menu.edit add command -label "Alle Löschen" -underline 0 -state disabled -command { -# .view.remote.list selection set 0 end; BusyCommand DeleteremoteFiles} -#.menu.edit add command -label "Alle Übertragen" -underline 0 -state disabled -command Quit - -menu .menu.view -tearoff 0 -.menu add cascade -label "View" -menu .menu.view -underline 0 -.menu.view add command -label "Refresh" -underline 0 -command {BusyCommand Refresh} -accelerator Alt+R - -menu .menu.options -tearoff 0 -.menu add cascade -label "Options" -menu .menu.options -underline 0 -.menu.options add command -label "Preferences" -underline 0 -command {BusyCommand Config} -accelerator Alt+P - -menu .menu.help -tearoff 0 -.menu add cascade -label "Help" -menu .menu.help -underline 0 -.menu.help add command -label "Overview" -underline 0 -command {Help overview} -.menu.help add command -label "Installation" -underline 0 -command {Help install} -.menu.help add command -label "Usage" -underline 0 -command {Help usage} -.menu.help add separator -.menu.help add command -label "About" -underline 1 -command {Help about} - -. configure -menu .menu - -# View area -frame .status -bd 1 -relief flat - pack .status -in . -side bottom -fill x -frame .view -bd 1 -relief flat - pack .view -in . -side top -expand 1 -fill both - -# Status -frame .status.head -bd 1 -relief sunken - pack .status.head -in .status -side top -fill x -label .status.head.label -textvariable status(header) -relief raised -anchor w -bd 1 - pack .status.head.label -in .status.head -side left -expand 1 -fill x -ipadx 2 -ipady 2 - -# Connection status -frame .view.conn -bd 1 -relief flat - pack .view.conn -in .view -side top -fill both -padx 8 -frame .view.conn.led1 -bd 2 -relief raised -width 20 -height 10 - pack .view.conn.led1 -in .view.conn -side left -fill x -padx 3 -label .view.conn.lab1 -text "No Connection!" -relief flat -anchor w -bd 1 -font {Helvetica 8} - pack .view.conn.lab1 -in .view.conn -side left -fill x -padx 3 -checkbutton .view.conn.check -text "syncronize scrollbars" -takefocus 0 -variable ftp(SyncScroll) \ - -command SyncScroll -relief flat -anchor w -bd 2 -font {Helvetica 12} - pack .view.conn.check -in .view.conn -side right - -# Separator -frame .view.line -bd 1 -height 2 -relief sunken - pack .view.line -in .view -side top -fill x -padx 8 -pady 5 - -# Dummy -frame .view.dummy -bd 1 -height 5 -relief flat - pack .view.dummy -in .view -side bottom -fill x -padx 8 -pady 5 - -# Remote directory -frame .view.remote -bd 1 - pack .view.remote -in .view -side right -expand 1 -fill both -padx 5 -frame .view.remote.status -bd 0 - pack .view.remote.status -in .view.remote -side top -fill x -label .view.remote.status.label -text "Remote: " -anchor w -relief flat -font {Helvetica 12 italic} - pack .view.remote.status.label -in .view.remote.status -side left -label .view.remote.status.mark -text "" -anchor w -relief flat -font {Helvetica 10} - pack .view.remote.status.mark -in .view.remote.status -side right -label .view.remote.status.use -text "0K" -anchor w -relief flat -fg #0000ff - pack .view.remote.status.use -in .view.remote.status -side left - -frame .view.remote.buttons -bd 1 - pack .view.remote.buttons -in .view.remote -side bottom -fill x -button .view.remote.buttons.delete -text "Delete" -under 0 -state disabled -command {BusyCommand DeleteRemoteFiles} - pack .view.remote.buttons.delete -in .view.remote.buttons -side top -pady 1m -scrollbar .view.remote.yscroll -relief sunken -takefocus 0 -command ".view.remote.list yview" - pack .view.remote.yscroll -in .view.remote -side right -fill y -scrollbar .view.remote.xscroll -relief sunken -orient horizontal -takefocus 0 -command ".view.remote.list xview" - pack .view.remote.xscroll -in .view.remote -side bottom -fill x -listbox .view.remote.list -relief sunken -xscroll ".view.remote.xscroll set" -yscroll ".view.remote.yscroll set" \ - -width 40 -height 24 -font {Courier 12} \ - -exportselection 0 -selectmode multiple -takefocus 0 -selectbackground #ff0000 - pack .view.remote.list -in .view.remote -side left -expand 1 -fill both - -# Local directory -frame .view.local -bd 1 - pack .view.local -in .view -side left -expand 1 -fill both -padx 5 -frame .view.local.status -bd 0 - pack .view.local.status -in .view.local -side top -fill x -label .view.local.status.label -text "Local: " -anchor w -relief flat -font {Helvetica 12 italic} - pack .view.local.status.label -in .view.local.status -side left -label .view.local.status.mark -text "" -anchor w -relief flat -font {Helvetica 10} - pack .view.local.status.mark -in .view.local.status -side right -label .view.local.status.use -text "0K" -anchor w -relief flat -fg #0000ff - pack .view.local.status.use -in .view.local.status -side left - -frame .view.local.buttons -bd 1 - pack .view.local.buttons -in .view.local -side bottom -fill x -button .view.local.buttons.transfer -text "Upload->" -under 0 -state disabled -command UpdateRemoteFiles - pack .view.local.buttons.transfer -in .view.local.buttons -side top -pady 1m -scrollbar .view.local.yscroll -relief sunken -takefocus 0 -command ".view.local.list yview" - pack .view.local.yscroll -in .view.local -side right -fill y -scrollbar .view.local.xscroll -relief sunken -orient horizontal -takefocus 0 -command ".view.local.list xview" - pack .view.local.xscroll -in .view.local -side bottom -fill x -listbox .view.local.list -relief sunken -xscroll ".view.local.xscroll set" -yscroll ".view.local.yscroll set" \ - -width 40 -height 24 -font {Courier 12} \ - -exportselection 0 -selectmode multiple -takefocus 0 -selectbackground #000080 - pack .view.local.list -in .view.local -side left -expand 1 -fill both - -# Shows selected files -bindtags .view.local.list {Listbox . all .view.local.list} -bindtags .view.remote.list {Listbox . all .view.remote.list} -bind .view.local.list {Showselected local} -bind .view.remote.list {Showselected remote} - -# Acc. Keys -bind . {BusyCommand Connect} -bind . {BusyCommand Disconnect} -bind . {BusyCommand Refresh} -bind . {BusyCommand Config} -bind . "tkButtonInvoke .view.local.buttons.transfer" -bind . "tkButtonInvoke .view.remote.buttons.delete" -bind . Quit - -proc SyncY {args} { - eval .view.local.list yview $args - eval .view.remote.list yview $args -} - -proc SyncX {args} { - eval .view.local.list xview $args - eval .view.remote.list xview $args -} - -# Syncron Scrollbars -proc SyncScroll {} { -global ftp - if { $ftp(SyncScroll) == 1} { - .view.local.yscroll configure -command SyncY - .view.remote.yscroll configure -command SyncY - .view.local.xscroll configure -command SyncX - .view.remote.xscroll configure -command SyncX - } else { - .view.local.yscroll configure -command ".view.local.list yview" - .view.remote.yscroll configure -command ".view.remote.list yview" - .view.local.xscroll configure -command ".view.local.list xview" - .view.remote.xscroll configure -command ".view.remote.list xview" - } -} - -# messages -proc ftp::DisplayMsg {s msg {state normal}} { -global status - - switch -- $state { - data {return} - control {return} - normal {.status.head.label configure -fg black} - error {.status.head.label configure -fg red} - } - set status(header) $msg - update idletasks -} - -################################################ -# -# Procedures -# -################################################ - -# hourglass -proc BusyCommand {args} { - set command $args - set busy {.menu .view .status} - set window_list {.menu .view .status} - while {$window_list != ""} { - set next {} - foreach w $window_list { - set class [winfo class $w] - set cursor [lindex [$w config -cursor] 4] - if {[winfo toplevel $w] == $w || $cursor != ""} { - lappend busy [list $w $cursor] - } - set next [concat $next [winfo children $w]] - } - set window_list $next - } - foreach w $busy { - catch { grab set [lindex $w 0]} - catch {[lindex $w 0] config -cursor watch} - } - update idletasks - set error [catch {uplevel eval [list $command]} g] - foreach w $busy { - catch {grab release [lindex $w 0]} - catch {[lindex $w 0] config -cursor [lindex $w 1]} - } - if { !$error } { - return $g - } else { - bgerror $g - } - return "" -} - -# read recursive the remote directory tree -proc GetRemoteTree {{dir ""}} { -global ftp - - foreach i [ftp::List $ftp(conn) $dir] { - set rc [scan $i "%s %s %s %s %s %s %s %s %s" perm l u g size d1 d2 d3 name] - if {$rc == "9"} { - - if { ($name == ".") || ($name == "..") } { - continue - } - - set type [string range $perm 0 0] - if { $dir != "" } { - regsub {\./} [file join $dir $name] "" name - } - switch -- $type { - d { - lappend ftp(remoteDirList) $name - lappend ftp(remoteFileList) "$name" - lappend ftp(remoteSizeList) $size - GetRemoteTree $name - } - - - { - lappend ftp(remoteFileList) "$name" - lappend ftp(remoteSizeList) $size - } - - default { - lappend ftp(remoteFileList) "$name" - lappend ftp(remoteSizeList) $size - } - } - } - } -} - -# read remote directory -proc ReadRemoteDir {} { -global ftp opt - - # connected? - if {(![info exists ftp(conn)]) || - (![info exists ftp::ftp${ftp(conn)}(State)])} { - .view.remote.list delete 0 end - return - } - - focus .view.remote.list - .view.remote.list delete 0 end - .view.remote.list insert end "Working..." - update idletasks - - set ftp(remoteDirList) {} - set ftp(remoteFileList) {} - set ftp(remoteSizeList) {} - GetRemoteTree . - - foreach name $ftp(remoteFileList) { - if { [string length $name] > $ftp(MaxLength) } { - set ftp(MaxLength) [string length $name] - } - } - - set max_length $ftp(MaxLength) - .view.remote.list delete 0 end - update idletasks - set index 0 - foreach i $ftp(remoteFileList) { - - set name $i - set size [lindex $ftp(remoteSizeList) $index ] - set entry [format "%-${max_length}s %8s" $name $size] - .view.remote.list insert end $entry - - # If file doesn't exist on local location then mark it to delete - set index [lsearch -regexp [.view.local.list get 0 end] "^$name "] - if { $index == "-1" } { - .view.remote.list selection set end end - } - incr index - - } - - ShowUsed remote - Showselected remote - ReadLocalDir -} - -# shine a light -proc Blink {mode} { -global status - switch -- $mode { - on { - .view.conn.led1 configure -bg $status(on) - update idletasks - } - off { - .view.conn.led1 configure -bg $status(off) - update idletasks - } - } -} - -# connect to ftp server -proc Connect {} { -global ftp opt - ftp::DisplayMsg "" " ftp> Trying connect to ftp server..." - Blink on - if {[set ftp(conn) [ftp::Open $opt(Server) $opt(Username) $opt(Password) -progress {ProgressBar update} ]] == -1} { - Blink off - ShowStatus - return - } - - # remote homepage directory - if {![ftp::Cd $ftp(conn) $opt(remoteDir)]} { - tk_messageBox -parent . -title INFO -message "Directory $opt(remoteDir) on remote ftp server not found!" -type ok - Disconnect - return - } - - ftp::DisplayMsg $ftp(conn) "Connected to ftp service on $opt(Server)!" - ReadRemoteDir - .view.local.buttons.transfer configure -state normal - .view.remote.buttons.delete configure -state normal - .menu.file entryconfigure 0 -state disabled - .menu.file entryconfigure 1 -state normal - ShowStatus -} - -# Remove connection to file server -proc Disconnect {} { -global ftp - - # connected? - if {([info exists ftp(conn)]) && - ([info exists ftp::ftp${ftp(conn)}(State)])} { - ftp::Close $ftp(conn) - ftp::DisplayMsg "" "Connection closed!" - } - if {[info exists ftp(conn)]} { - unset ftp(conn) - } - set ftp(remoteSizeList) {} - .view.remote.list delete 0 end - .view.local.buttons.transfer configure -state disabled - .view.remote.buttons.delete configure -state disabled - .menu.file entryconfigure 0 -state normal - .menu.file entryconfigure 1 -state disabled - ShowStatus - ShowUsed remote - Showselected remote -} - -# Display connection status -proc ShowStatus {} { -global status - if {([info exists ftp(conn)]) && - ([info exists ftp::ftp${ftp(conn)}(State)])} { - .view.conn.led1 configure -bg $status(on) - .view.conn.lab1 configure -text "connected" - update idletasks - } else { - .view.conn.led1 configure -bg $status(off) - .view.conn.lab1 configure -text "not connected" - update idletasks - } -} - -# display used directory size -proc ShowUsed {mode} { -global ftp - set sum 0 - foreach i $ftp(${mode}SizeList) { - incr sum $i - } - -# if { $sum > [ expr {1024 * 1024}] } { -# set color #ff0000 -# } else { -# set color #0000ff -# } - - set color #0000ff - .view.$mode.status.use configure -text "[expr {round($sum / 1024.0)}] KB" -fg $color - update idletasks -} - -# display selected directory size -proc Showselected {mode} { -global ftp - set sum 0 - set count 0 - if { ([info exists ftp(${mode}SizeList)]) && ([llength $ftp(${mode}SizeList)] != 0) } { - foreach i [.view.$mode.list curselection] { - incr sum [lindex $ftp(${mode}SizeList) $i] - incr count - } - } - .view.$mode.status.mark configure -text "[expr {round($sum / 1024.0)}] KB \[$count\]" - update idletasks -} - - -# read recursive the local directory tree -proc GetLocalTree {dir} { -global ftp - foreach i [lsort [glob -nocomplain $dir/* $dir/.*]] { - regsub {\./} $i "" i - if { ([file tail $i] != ".") && ([file tail $i] != "..") } { - - # exist check - if {![file exists $i]} { - continue - } - - if {[file isdirectory $i]} { - lappend ftp(localFileList) $i - lappend ftp(localDirList) $i - GetLocalTree $i - } else { - lappend ftp(localFileList) $i - } - } - } -} - -# read local directory -proc ReadLocalDir {} { -global opt ftp - - .view.local.list delete 0 end - .view.local.list insert end "Working..." - update - - # local homepage directory - if {![file isdirectory $opt(localDir)]} { - tk_messageBox -parent . -title INFO -message "Directory $opt(localDir) not found!" -type ok - return - - } - - # read local homepage directory - set ftp(localDirList) {} - set ftp(localFileList) {} - set ftp(localSizeList) {} - cd $opt(localDir) - GetLocalTree . - - foreach name $ftp(localFileList) { - if { [string length $name] > $ftp(MaxLength) } { - set ftp(MaxLength) [string length $name] - } - } - - set max_length $ftp(MaxLength) - .view.local.list delete 0 end - update idletask - foreach i $ftp(localFileList) { - - set name $i - set size [file size $name] - set entry [format "%-${max_length}s %8s" $name $size] - .view.local.list insert end $entry - lappend ftp(localSizeList) $size - - # if updated then mark to upload - if { [file mtime $name] > $opt(Timestamp) } { - .view.local.list selection set end end - } - - # if not exist at remote machine then mark to upload - if {([info exists ftp(conn)]) && - ([info exists ftp::ftp${ftp(conn)}(State)])} { - set index [lsearch -regexp [.view.remote.list get 0 end] "^$name "] - if { $index == "-1" } { - .view.local.list selection set end end - } - } - } - - ShowUsed local - Showselected local -} - -# delete files on remote site -proc DeleteRemoteFiles {} { -global ftp - - # connected? - if {(![info exists ftp(conn)]) || - (![info exists ftp::ftp${ftp(conn)}(State)])} { - tk_messageBox -parent . -title INFO -message "No connection!" -type ok - return - } - # nothing choosed - if { [.view.remote.list curselection] == {} } { - return - } - # ask user - set count [llength [.view.remote.list curselection]] - set rc [tk_messageBox -parent . -title DELETE -message "Do you really want to delete the $count selected file(s)?" -type yesno] - if { $rc == "no" } { - return - } - - # delete selected files - focus .view.remote.list - foreach i [lsort -integer -decreasing [.view.remote.list curselection]] { - set filename [lindex [.view.remote.list get $i] 0] - .view.remote.list see $i - .view.remote.list activate $i - update idletasks - - # file or directory? - set index [lsearch -exact $ftp(remoteDirList) $filename] - if { $index == "-1" } { - set command "ftp::Delete" - } else { - set command "ftp::RmDir" - } - - if {[eval $command $ftp(conn) $filename]} { - .view.remote.list selection clear $i - update idletasks - set ftp(remoteSizeList) [lreplace $ftp(remoteSizeList) $i $i 0] - ShowUsed remote - Showselected remote - Showselected local - } else { - tk_messageBox -parent . -title ERROR -message \ - "Error deleting $filename!" -icon error -type ok - continue - } - } - BusyCommand Refresh -} - -# Progress bar displayed in status line -proc ProgressBar {state {bytes 0} {filename ""}} { -global ftp - set w .progress - switch -- $state { - init { - set ftp(Filename) "" - set ftp(ProgressProz) "0%" - toplevel $w -bd 0 -class Progressbar - wm transient $w . - wm title $w Upload - wm iconname $w Upload - wm resizable $w 0 0 - focus $w - grab $w - - frame $w.buttons - pack $w.buttons -side bottom -fill x -pady 2m - button $w.buttons.esc -text "Cancel" -command "set ftp(escaped) 1" - pack $w.buttons.esc -in $w.buttons -side top - - frame $w.frame -bd 4 - pack $w.frame -side top -fill both - label $w.frame.label -textvariable ftp(Filename) -relief flat -anchor w -bd 1 -font {Helvetica 12} - pack $w.frame.label -in $w.frame -side top -fill x -padx 10 -pady 5 - frame $w.frame.line -bd 1 -height 2 -relief sunken - pack $w.frame.line -in $w.frame -side bottom -fill x -padx 2 -pady 5 - frame $w.frame.bar -bd 1 -relief sunken -bg #ffffff - pack $w.frame.bar -in $w.frame -side left -padx 10 -pady 5 - frame $w.frame.bar.dummy -bd 0 -width 200 -height 0 - pack $w.frame.bar.dummy -in $w.frame.bar -side top -fill x - frame $w.frame.bar.pbar -bd 0 -width 0 -height 20 - pack $w.frame.bar.pbar -in $w.frame.bar -side left - label $w.frame.proz -textvariable ftp(ProgressProz) -width 5 -relief flat -anchor e -bd 1 -font {Helvetica 12} - pack $w.frame.proz -in $w.frame -side right -padx 10 -pady 5 - - wm withdraw $w - update idletasks - set x [expr {[winfo x .] + ([winfo width .] / 3) - ([winfo reqwidth $w] / 2)}] - set y [expr {[winfo y .] + ([winfo height .] / 3) - ([winfo reqheight $w] / 2)}] - wm geometry $w +$x+$y - wm deiconify $w - update idletasks - } - - reset { - set ftp(Filename) "Uploading $filename...." - set index [lsearch $ftp(localFileList) $filename] - if { $index != "-1" } { - set ftp(progress_sum) [lindex $ftp(localSizeList) $index] - if { $ftp(progress_sum) == 0 } { - set ftp(progress_sum) 1 - } - } else { - set ftp(progress_sum) 1 - } - ProgressBar update - update idletasks - } - - update { - if {![winfo exists $w]} {return} - set ftp(ProgressProz) "[expr {round( $bytes * 100 / $ftp(progress_sum))}]%" - set cur_width [expr {round($bytes * 200 / $ftp(progress_sum))}] - $w.frame.bar.pbar configure -width $cur_width -bg #000080 - focus $w.buttons.esc - update idletasks - update - } - - done { - set ftp(Filename) "Upload successful!" - $w.buttons.esc configure -text "OK" -command "destroy $w" - update idletasks - tkwait window $w - } - - escape { - destroy $w - BusyCommand Refresh - } - - error { - destroy $w - } - } -} - -# upload local files to remote site -proc UpdateRemoteFiles {} { -global ftp opt status - # connected? - if {(![info exists ftp(conn)]) || - (![info exists ftp::ftp${ftp(conn)}(State)]) } { - tk_messageBox -parent . -title INFO -message "No connection!" -type ok - return 0 - } - - # nothing selected - if { [.view.local.list curselection] == {} } { - return 0 - } - - # ask user - set count [llength [.view.local.list curselection]] - set rc [tk_messageBox -parent . -title UPLOAD -message "Do you really want to upload the $count selected file(s)?" -type yesno] - if { $rc == "no" } { - return 0 - } - - # create list of uploading files - set upload_list {} - foreach i [.view.local.list curselection] { - lappend upload_list $i - } - - # empty list? - if { $upload_list == {} } { - tk_messageBox -parent . -title INFO -type ok -message "Nothing selected for upload!!" - return 0 - } - focus .view.local.list - - # binary type for all files - ftp::Type $ftp(conn) binary - - # upload files - set ftp(escaped) 0 - ProgressBar init - set ftp(ProgressCount) 0 - foreach i $upload_list { - set filename [lindex [.view.local.list get $i] 0] - .view.local.list see $i - .view.local.list activate $i - update idletasks - - # file or directory? - set index [lsearch -exact $ftp(localDirList) $filename] - if { $index == "-1" } { - set command "ftp::Put" - } else { - - # directory already exists - if { [lsearch -exact $ftp(remoteDirList) $filename] != "-1" } { - continue - } - set command "ftp::MkDir" - } - - ProgressBar reset 0 $filename - if {[eval $command $ftp(conn) $filename]} { - incr ftp(ProgressCount) - if {$ftp(escaped)} { - ProgressBar escape - return 1 - } - .view.local.list selection clear $i - } else { - tk_messageBox -parent . -title ERROR -message "Error uploading $filename!" -icon error -type ok - ProgressBar error - continue - } - } - - ProgressBar done - - # new timestamp - Touch $opt(TsFile) - set opt(Timestamp) [file mtime $opt(TsFile)] - Refresh - set status(header) " last update: [clock format $opt(Timestamp) -format %d.%m.%Y\ %H:%M:%S\ Uhr -gmt 0]" - return 0 -} - -# Refresh -proc Refresh {} { -global ftp - set ftp(MaxLength) 0 - ReadLocalDir - ReadRemoteDir - ShowStatus - update idletasks -} - - -if {[package vcompare [info tclversion] 8.4] >= 0} { - proc Touch {filename} { - file mtime $filename [clock seconds] - } -} else { - # update timestamp - proc Touch {filename} { - set file [open $filename w] - puts -nonewline $file "" - close $file - } -} - - -# quit hpupdate -proc Quit {} { -global ftp - Disconnect - destroy . - exit 0 -} - - -# save current configuration -proc SaveConfig {} { -global opt - set file [open $opt(ConfigFile) w] - puts $file [array get opt] - close $file -} - -# accept new configuraion -proc AcceptConfig {w} { -global opt ftp - - # get ftp server options - set opt(Server) [$w.mask.server.entry get] - set opt(Username) [$w.mask.user.entry get] - set opt(Password) [$w.mask.passwd.entry get] - set opt(remoteDir) [$w.mask.remote.entry get] - - # get local homepage direction - set dir [$w.mask.local.entry get] - if { ![file isdirectory $dir] } { - tk_messageBox -parent . -title ERROR -message "Directory \"$dir\" not found!" -type ok - return - } - set opt(localDir) [$w.mask.local.entry get] - cd $opt(localDir) - - SaveConfig - tk_messageBox -parent . -title INFO -message "Configuration applied and saved!" -type ok - destroy $w -} - -# ftp configuration -proc Config {} { -global opt - - # new window - set w .config - - catch {destroy $w} - toplevel $w -bd 0 -class Config - wm transient $w . - wm title $w "options" - wm iconname $w "options" - wm transient $w . - wm minsize $w 10 10 - - frame $w.mask -bd 1 -relief raised - pack $w.mask -in $w -side top -expand 1 -fill both - frame $w.control -bd 1 -relief raised - pack $w.control -in $w -side bottom -fill x - - frame $w.mask.server -bd 1 - pack $w.mask.server -in $w.mask -side top -expand 1 -fill both -padx 3m -pady 3m - label $w.mask.server.label -text "ftp server name:" -under 0 -anchor w - pack $w.mask.server.label -in $w.mask.server -side top -fill x - entry $w.mask.server.entry -width 40 - pack $w.mask.server.entry -in $w.mask.server -expand 1 -side left -fill x - - frame $w.mask.user -bd 1 - pack $w.mask.user -in $w.mask -side top -expand 1 -fill both -padx 3m -pady 3m - label $w.mask.user.label -text "User:" -under 0 -anchor w - pack $w.mask.user.label -in $w.mask.user -side top -fill x - entry $w.mask.user.entry -width 40 - pack $w.mask.user.entry -in $w.mask.user -expand 1 -side left -fill x - - frame $w.mask.passwd -bd 1 - pack $w.mask.passwd -in $w.mask -side top -expand 1 -fill both -padx 3m -pady 3m - label $w.mask.passwd.label -text "Password:" -under 0 -anchor w - pack $w.mask.passwd.label -in $w.mask.passwd -side top -fill x - entry $w.mask.passwd.entry -show "*" -width 40 - pack $w.mask.passwd.entry -in $w.mask.passwd -expand 1 -side left -fill x - - frame $w.mask.remote -bd 1 - pack $w.mask.remote -in $w.mask -side top -expand 1 -fill both -padx 3m -pady 3m - label $w.mask.remote.label -text "Remote directory:" -under 0 -anchor w - pack $w.mask.remote.label -in $w.mask.remote -side top -fill x - entry $w.mask.remote.entry -width 40 - pack $w.mask.remote.entry -in $w.mask.remote -expand 1 -side left -fill x - - frame $w.mask.local -bd 1 - pack $w.mask.local -in $w.mask -side top -expand 1 -fill both -padx 3m -pady 3m - label $w.mask.local.label -text "Local directory:" -under 0 -anchor w - pack $w.mask.local.label -in $w.mask.local -side top -fill x - entry $w.mask.local.entry -width 40 - pack $w.mask.local.entry -in $w.mask.local -expand 1 -side left -fill x - - button $w.control.accept -width 14 -text "Apply & Save" -under 0 -command "AcceptConfig $w" - pack $w.control.accept -in $w.control -side left -expand 1 -padx 3m -pady 2m - button $w.control.quit -width 14 -text "Cancel" -under 0 -command "destroy $w" - pack $w.control.quit -in $w.control -side left -expand 1 -padx 3m -pady 2m - - - # arrange window - wm withdraw $w - update idletasks - set x [expr {[winfo x .] + ([winfo width .] / 3) - ([winfo reqwidth $w] / 2)}] - set y [expr {[winfo y .] + ([winfo height .] / 3) - ([winfo reqheight $w] / 2)}] - wm geometry $w +$x+$y - wm deiconify $w - - $w.mask.server.entry delete 0 end - $w.mask.server.entry insert 0 $opt(Server) - $w.mask.user.entry delete 0 end - $w.mask.user.entry insert 0 $opt(Username) - $w.mask.passwd.entry delete 0 end - $w.mask.passwd.entry insert 0 $opt(Password) - $w.mask.local.entry delete 0 end - $w.mask.local.entry insert 0 $opt(localDir) - $w.mask.remote.entry delete 0 end - $w.mask.remote.entry insert 0 $opt(remoteDir) - - bind $w "tkButtonInvoke $w.mask.check.debug" - bind $w "tkButtonInvoke $w.mask.check.verbose" - bind $w "focus $w.mask.server.entry" - bind $w "focus $w.mask.remote.entry" - bind $w "focus $w.mask.local.entry" - bind $w "tkButtonInvoke $w.control.accept" - bind $w "tkButtonInvoke $w.control.cancel" - - focus -force $w.mask.server.entry - update idletasks -} - -proc Usage {} { - puts "\nusage hpupdate \[-h\] \[directory\]" - puts " -h help" - puts " directory local directory" - puts " (default: current directory)\n" - exit 0 -} - -# Help -proc Help {mode} { - -set help(overview) { -OVERVIEW ---------- - -In order to simplify the transfer of the files of my homepage to the -FTP server of my Internet Service Provider, I looked at the end of -1996 for an useful tool. Linux offered only the -abilities of the ftp command line utility. As fan of -Tcl/Tk, my selection immediately fell on "expect", which was very suitable -to automate interactive processes like FTP sessions. A little bit -more Tcl source code and hpupdate 0.1 was finished, a script for -automatic updating of my homepage files. - -At the beginning of 1997, I was more intensively occupied with the -FTP protocol. At the same time I played with Tcl's socket command. -Thus the FTP library package for Tcl7.6 was developed. -This forms the basis for hpupdate. - -So far, the program runs under Linux with Tcl/Tk 8.0. I have once -tested it on Windows 3.11 (with Win32s) and Windows 95 and it runs -perfectly. Today I have no experiences with Windows NT and -Macintosh. Perhaps somebody will be found who will test it in these -environments. I would like to be informed of your experiences! -Thank you! - - usage: hpupdate - - example: hpupdate /home/user/hp - - *** -} - -set help(install) { -INSTALLATION ------------- - -The great advantage of hpupdate is its platform independence -because of using Tcl/Tk. - -If you do not have Tcl/Tk 8.0 installed already, at first you must -install it. Get it from the known locations such as http://tcl.sf.net/ -and follow the installation instructions. - -If you have not already installed the ftp library package, you must -install it. Get it from my homepage and follow the -installation instructions. - -Start up hpupdate and change the preferred options in option menu. - -"ftp Server Name" - remote FTP server hostname -"User" - valid username -"Password" - valid password for user -"Remote Directory" - remote root for homepage or empty (destination) -"Local Directory" - local homepage directory (source) - - - *** -} - -set help(usage) { -USAGE ------ - -The hpupdate application is divided into 4 areas: - - 1.) menu - 2.) local file list (source) - 3.) remote file list (destination) - 4.) status line - -1.) menu - - File / Connect -Opens a connection with the FTP server. - - File / Disconnetc -Closes an existing connection with the FTP server. - - File / Exit -Quits hpupdate, the connection to the FTP server will be -closed automatically. - - View / Refresh -Reads new file data and refreshs it in the list. - - Options / Preferences -Interface to saving your login, password, ftp server, etc. - - Help / * look there - -2.) local file list -This list contains the file names and sizes from the local -homepage directory. The file name, date and time-of-day -of the files are compared with the time stamp of the remote files. -When getting the filename for this list, the date/time entry of each file -is read and compared with the timestamp of the last update. -Files which have a date and/or time newer than the remote file's timestamp -are detected as updated and marked for upload. -It is also possible to mark/unmark the files manually per mouse click. -The capacity of all files in the directory is displayed in blue. -Besides this, the capacity of the marked files, as well as the count of files -(in parentheses) are shown. - -By pressing the button "Upload", all selected files in the local -homepage directory will be transfered to the remote FTP server. - -3.) remote file list -The files at the FTP site appear in this list after connection with -the FTP server. The remote files will be compared with the local files. -Files which are not in the local list are detected as superfluous -and marked for deletion. -It is also possible to mark/unmark files manually per mouse click. -The number of marked files is displayed in an extra frame. -Additionally, the summary disk space is shown. -The capacity of all files in the directory is displayed in blue. -Besides this, the capacity of all marked files as well as the count -(in parentheses) is shown. - -By pressing the button "Delete", all selected files in the remote homepage -directory will be deleted. - -NOTE: Synchronize the scrolling of both lists by pressing the checkbutton -"sychronize scrollbars ". - -4.) status line -The status line shows when the last update of the remote system has taken place. -This display is always updated after every file transfer. -Internally, the file "hpupdate.ts" is provided with a new timestamp. -After this moment, all modified local files are automatically detected -with the next refresh and marked for upload. - -Error and status messages for the FTP connection are also displayed in -the status line. - -EXTENSION: -The green LED shows the connection status, a lighter green means an -established connection. - - *** -} - -set help(about) { - - hpupdate - homepage update program using FTP - - Required: Tcl/Tk8.0x - - Created: 12/96 - Changed: 04/2002 - Version: 2.1 - - Copyright (C) 1997,1998, Steffen Traeger - EMAIL: Steffen.Traeger@t-online.de - URL: http://home.t-online.de/home/Steffen.Traeger -} - - set w .help - catch {destroy $w} - toplevel $w -bd 0 -class Help - wm transient $w . - wm title $w "Help - $mode" - wm iconname $w Hilfe - wm minsize $w 10 10 - frame $w.buttons -bd 1 -relief flat - pack $w.buttons -side bottom -fill x -pady 2m - button $w.buttons.close -text "OK" -command "destroy $w" - pack $w.buttons.close -side left -expand 1 - frame $w.ftp -bd 1 -relief flat - pack $w.ftp -side top -expand 1 -fill both - scrollbar $w.ftp.yscroll -command "$w.ftp.text yview" - pack $w.ftp.yscroll -in $w.ftp -side right -fill y - scrollbar $w.ftp.xscroll -relief sunken -orient horizontal -command "$w.ftp.text xview" - pack $w.ftp.xscroll -in $w.ftp -side bottom -fill x - text $w.ftp.text -relief sunken -setgrid 1 -wrap none -height 15 -width 60 -bg white -fg black\ - -state normal -xscrollcommand "$w.ftp.xscroll set" \ - -yscrollcommand "$w.ftp.yscroll set" - pack $w.ftp.text -in $w.ftp -side left -expand 1 -fill both - wm withdraw $w - update idletasks - set x [expr {[winfo x .] + ([winfo width .] / 3) - ([winfo reqwidth $w] / 2)}] - set y [expr {[winfo y .] + ([winfo height .] / 3) - ([winfo reqheight $w] / 2)}] - wm geometry $w +$x+$y - wm deiconify $w - $w.ftp.text insert 0.0 $help($mode) - $w.ftp.text configure -state disabled - update idletasks - -} -##################### main ################################################### - -# determine working directory -if { $argv != "" && $argv != "{}" } { - if { [lindex $argv 0] == "-h" } {Usage} - set dir [lindex $argv 0] - if { [file exists $dir] && [file isdirectory $dir] } { - set opt(localDir) $dir - } else { - puts "Directory \"$dir\" not found!" - Usage - } -} else { - set opt(localDir) [pwd] -} - -# init defaults -set opt(Server) "" -set opt(Username) "anonymous" -set opt(Password) "" -set opt(remoteDir) "." -set opt(ConfigFile) $env(HOME)/hpupdate.cnf -set opt(TsFile) $env(HOME)/hpupdate.ts - -# load configuration file -if { [file exists $opt(ConfigFile)] } { - set file [open $opt(ConfigFile) r] - array set opt [read $file] - close $file -} -set ftp::DEBUG 0 -set ftp::VERBOSE 0 - -# to compare older and newer files hpupdate creates -# a new timesstamp on file "hpupdate.ts" after every update -if { ![file exists $opt(TsFile)] } {Touch $opt(TsFile)} -set opt(Timestamp) [file mtime $opt(TsFile)] -set status(header) " last update: [clock format $opt(Timestamp) -format %d.%m.%Y\ %H:%M:%S\ Uhr -gmt 0]" - -BusyCommand Refresh - DELETED examples/ftp/mirror.tcl Index: examples/ftp/mirror.tcl ================================================================== --- examples/ftp/mirror.tcl +++ /dev/null @@ -1,40 +0,0 @@ -#!/bin/sh -# the next line restarts using tclsh \ -exec tclsh8.3 "$0" -- "$@" - -package require ftp 2.0 - -# user configuration -set server noname -set username anonymous -set passwd xxxxxx - -# simple progress display -proc ProgressBar {bytes} { - puts -nonewline stdout "."; flush stdout -} - -# recursive file transfer -proc GetTree {conn {dir ""}} { - catch {file mkdir $dir} - foreach line [ftp::List $conn $dir] { - set rc [scan $line "%s %s %s %s %s %s %s %s %s %s %s" \ - perm l u g size d1 d2 d3 name link linksource] - if { ($name == ".") || ($name == "..") } {continue} - set type [string range $perm 0 0] - set name [file join $dir $name] - switch -- $type { - d {GetTree $name} - l {catch {exec ln -s $linksource $name} msg} - - {ftp::Get $conn $name} - } - } -} - -# main -if {[set conn [ftp::Open $server $username $passwd -progress ProgressBar]] != -1} { - GetTree $conn - ftp::Close $conn - puts "OK!" -} - DELETED examples/ftp/newer.tcl Index: examples/ftp/newer.tcl ================================================================== --- examples/ftp/newer.tcl +++ /dev/null @@ -1,13 +0,0 @@ -#!/bin/sh -# the next line restarts using tclsh \ -exec tclsh8.3 "$0" -- "$@" - -package require ftp 2.0 - -if { [set conn [ftp::Open ftp.scriptics.com anonymous xxxx]] != -1} { - if {[ftp::Newer $conn /pub/tcl/httpd/tclhttpd.tar.gz /usr/local/src/tclhttpd.tgz]} { - exec echo "New httpd arrived!" | mailx -s ANNOUNCE root - } - ftp::Close $conn -} - DELETED examples/ftpd/ftpd Index: examples/ftpd/ftpd ================================================================== --- examples/ftpd/ftpd +++ /dev/null @@ -1,18 +0,0 @@ -#!/bin/sh -# FTP daemon -# \ -exec tclsh8.3 "$0" ${1+"$@"} - -if {[catch {package require ftpd}]} { - set here [file dirname [info script]] - source [file join .. $here ftpd.tcl] -} - -proc bgerror {args} { - global errorInfo - puts stderr "bgerror: [join $args]" - puts stderr $errorInfo -} - -::ftpd::server -vwait forever DELETED examples/ftpd/ftpd.test Index: examples/ftpd/ftpd.test ================================================================== --- examples/ftpd/ftpd.test +++ /dev/null @@ -1,42 +0,0 @@ -#!/bin/sh -# FTP daemon for testing the ftp client (modules/ftp). -# -*- tcl -*- \ -exec tclsh8.3 "$0" ${1+"$@"} - -# This ftpd runs on port 7777, uses /tmp as root dir and does not do -# any authentication at all. IOW, do not run this server for longer -# periods of time or you create a security hole on your machine. This -# server is strictly for short testing the implementation of the ftp -# module over short periods of time. - -package require ftpd -package require log - -proc bgerror {args} { - global errorInfo - puts stderr "bgerror: [join $args]" - puts stderr $errorInfo -} - -proc ftplog {level text} { - if {[string equal $level note]} {set level notice} - log::log $level $text -} - -proc noauth {args} { - return 1 -} - -proc fakefs {cmd path args} { - # Use the standard unix fs, i.e. "::ftpd::fsFile::fs", but rewrite the incoming path - # to stay in the /tmp directory. - - set path [file join / tmp [file tail $path]] - eval [linsert $args 0 ::ftpd::fsFile::fs $cmd $path] -} - -::ftpd::config -logCmd ftplog -authUsrCmd noauth -authFileCmd noauth -fsCmd fakefs -set ::ftpd::port 7777 ; # Listen on user port - -::ftpd::server -vwait forever DELETED examples/ftpd/ftpd.unix Index: examples/ftpd/ftpd.unix ================================================================== --- examples/ftpd/ftpd.unix +++ /dev/null @@ -1,19 +0,0 @@ -#!/bin/sh -# FTP daemon -# \ -exec tclsh8.3 "$0" ${1+"$@"} - -if {[catch {package require ftpd}]} { - set here [file dirname [info script]] - source [file join .. $here ftpd.tcl] -} - -proc bgerror {args} { - global errorInfo - puts stderr "bgerror: [join $args]" - puts stderr $errorInfo -} - -::ftpd::config -authUsrCmd ::ftpd::unixAuth -::ftpd::server -vwait forever DELETED examples/irc/ChangeLog Index: examples/irc/ChangeLog ================================================================== --- examples/irc/ChangeLog +++ /dev/null @@ -1,5 +0,0 @@ -2003-01-30 David N. Welton - - * irc_example.tcl (client::connect): Added some more comments, - change the startup features. Create ChangeLog. - DELETED examples/irc/irc_example.tcl Index: examples/irc/irc_example.tcl ================================================================== --- examples/irc/irc_example.tcl +++ /dev/null @@ -1,81 +0,0 @@ -#!/bin/sh -# the next line restarts using tclsh \ - exec tclsh "$0" "$@" - -# irc example script, by David N. Welton -# $Id: irc_example.tcl,v 1.4 2003/01/31 02:52:49 davidw Exp $ - -# Pick up a nick from the command line, or default to TclIrc. - -if { [lindex $argv 0] != "" } { - set nick [lindex $argv 0] -} else { - set nick TclIrc -} - -# I include these so that it can find both the irc package and the -# logger package that irc needs. - -set auto_path "[file join [file dirname [info script]] .. .. modules irc] $auto_path" -set auto_path "[file join [file dirname [info script]] .. .. modules log] $auto_path" -package require irc 0.3 - -namespace eval client { - variable channel \#tcl -} - -proc client::connect { nick } { - variable channel - set cn [::irc::connection irc.freenode.net 6667] - set ns [namespace qualifiers $cn] - - # Register an event for the PING command that comes from the - # server. - $cn registerevent PING { - network send "PONG [msg]" - set ::PING 1 - } - - - $cn registerevent 376 { - set ::PING 1 - } - - # Register a default action for commands from the server. - $cn registerevent defaultcmd { - puts "[action] [msg]" - } - - # Register a default action for numeric events from the server. - $cn registerevent defaultnumeric { - puts "[action] XXX [target] XXX [msg]" - } - - # Register a default action for events. - $cn registerevent defaultevent { - puts "[action] XXX [who] XXX [target] XXX [msg]" - } - - # Register a default action for PRIVMSG (either public or to a - # channel). - $cn registerevent PRIVMSG { - puts "[who] says to [target] [msg]" - } - - $cn registerevent KICK { - puts "[who] KICKed [target 1] from [target] : [msg]" - } - - # Connect to the server. - $cn connect - $cn user $nick localhost "www.tcl.tk" - $cn nick $nick - $cn join $channel - - vwait ::PING - $cn join $channel -} - -# Start things in motion. -client::connect $nick -vwait forever DELETED examples/mime/mbot/README.html Index: examples/mime/mbot/README.html ================================================================== --- examples/mime/mbot/README.html +++ /dev/null @@ -1,817 +0,0 @@ -The README file: The personal.tcl Mailbot - - - - -
 TOC 
-
- - - -
The README fileM. Rose
 Dover Beach Consulting, Inc.
 February 2002
-

The personal.tcl Mailbot
- - -

Abstract

- -

The personal.tcl mailbot implements a highly-specialized -filter for personal messages. -It MUST not be used by people who receive mailing list traffic in -their personal mailboxes. -


 -
 TOC 
-

Table of Contents

-
    -1.  -SYNOPSIS
     -1.1  -Requirements
     -1.2  -Copyrights
     -2.  -PHILOSOPHY
     -2.1  -Guest Lists
     -3.  -BEHAVIOR
     -3.1  -Arguments
     -3.2  -Actions
     -3.3  -The Configuration File
     -3.3.1  -Configuration Options
     -3.3.2  -Configurable Procedures
     -§  -References
     -§  -Author's Address
     -A.  -Impersonal Mail
     -A.1  -Configuration Options
     -A.1.1  -foldersDirectory
     -A.1.2  -foldersFile
     -A.1.3  -announceMailboxes
     -A.1.4  -mappingFile
     -A.2  -Configurable Procedures
     -A.2.1  -impersonalMail
     -A.2.2  -processFolder
     -B.  -An Example configFile
     -C.  -Acknowledgements
     -
-
- -
 -
 TOC 
-

1. SYNOPSIS

- -

Create a configuration file -and add this line to your ".forward" file: -

-    "| LIB/mbot-1.1/personal.tcl -config FILE -user USER"
-
- -

where "LIB" is where the Tcl library lives, -"FILE" is the name of your configuration file, -and "USER" is your username. -

-

1.1 Requirements

- -

This package requires: - -

-

-

1.2 Copyrights

- -

(c) 1999-2002 Marshall T. Rose -

-

Hold harmless the author, and any lawful use is allowed. -

-
 -
 TOC 
-

2. PHILOSOPHY

- -

The mailbot's philosophy is simple: - -

    -
  • The mailbot receives all of your incoming personal mail. -
    • -
  • You ALWAYS copy yourself on every message you send, -so that the mailbot receives all of your outgoing personal mail. -
    • -
  • The mailbot performs six tasks, all optional: - -
      -
    • makes audit copies of your incoming and outgoing mail; -
      • -
    • performs duplicate supression; -
      • -
    • performs originator supression by rejecting messages from people -who aren't your friends or on a guest list; -
      • -
    • performs content supression by rejecting messages that contain -attachments with extensions on your prohibited list; -
      • -
    • sends a textual synopsis to your PDA; and, -
      • -
    • sends a copy to your remote mailbox. -
      • -

    -

    • -

-

-

Do NOT use the personal.tcl mailbot if you receive mailing list -traffic in your personal mailbox. -When sending mail to a mailing list, -either: - -

    -
  • use a "From" address that the personal.tcl mailbot will process as -"impersonal" mail, -(e.g., "hewes+ietf.general@example.com"); or, -
    • -
  • set the "Reply-To" for the message to the mailing list. -
    • -

-Consult Impersonal Mail for information on how -"impersonal" mail is identified and processed. -

-

2.1 Guest Lists

- -

Guest lists are an effective mechanism for cutting back on -excessive mail. - -

    -
  • when the mailbot receives a message from you, -it adds any recipients it finds to a permanent-guest list; -
    • -
  • when the mailbot receives a message from someone on a guest list, -it adds any recipients it finds to a temporary-guest list; but, -
    • -
  • when the mailbot receives a message from someone not on any guest -list, -they get a rejection notice. -
    • -

-Note that in order to promote someone to the permanent-guest list, -you must send them a message (with a copy to yourself). -In most cases, -simply replying to the original message accomplishes this. -Of course, -if you don't want to promote someone to the permanent-guest list, -simply remove that address (or your address) from the list of -recipients in your reply. -

-

Here are the fine points: - -

    -
  • rejection notices contain a passphrase that may be used at most -once to bypass the guest list mechanism -(notices also contain the original message to minimize type-in -by the uninvited); -
    • -
  • a flip-flop is used to avoid mail loops; and, -
    • -
  • messages originated by an administrative address (e.g., -"Postmaster") bypass the guest list mechanism -(unless the message refers to a previously-rejected message, -in which case it is supressed). -
    • -

-

-

The rejection notice should be written carefully to minimize an -extreme negative reaction on the part of the uninvited. -Of course, -by allowing a passphrase, -this provides something of a CQ test for the uninvited -- -if someone can't pass the test... -

-
 -
 TOC 
-

3. BEHAVIOR

- -

3.1 Arguments

- -

The mailbot supports the following command line arguments: - -

-
-config configFile:
-
-specifies the name of the configuration file to use; -
-
-debug boolean:
-
-enables debug output; -
-
-file messageFile:
-
-specifies the name of the file containing the message; -
-
-originator orginatorAddress:
-
-specifies the email-address of the originator of the message; and, -
-
-user userName:
-
-specifies the user-identity of the recipient. -
-

-Note that if "-user" is given, -then the working directory is set to userName's home directory before -configFile is sourced, -and the umask is set defensively. -

-

The default values are: -

-    personal.tcl -config     .personal-config.tcl   \
-                 -debug      0                      \
-                 -file       -                      \
-                 -originator "derived from message"
-
- -

Given the default values, -only "-user" need be specified. -The reason is that if a message is being delivered to multiple local -recipients, -and if any of the ".forward" files are identical in content, -then sendmail may not deliver the message to all of the local -recipients. -

-

A few other (sendmail related) tips: - -

    -
  • If sendmail is configured with smrsh, -you'll need to symlink personal.tcl into the -/usr/libexec/sm.bin/ directory. -
    • -
  • Make sure that tclsh8.0 is in the path specified on the third-line -of personal.tcl. -
    • -
  • You should chmod your ".forward" file to 0600. -
    • -

-

-

3.2 Actions

- -

The mailbot begins by parsing its arguments, -sourcing configFile, -and then examining the incoming message: - -

    -
  1. If auditInFile is set, -a copy of the message is -saved there. -
    2. -
  2. If the message contains a previously-encountered "Message-ID", -processing terminates. -
    3. -
  3. If the message's originator can not be determined, -a copy of the message is -saved in the -defaultMaildrop and -processing terminates. -
    4. -
  4. The originator's email-address is examined: - -
      -
    1. If the originator appears to be an -automated administrative process, -and if a previously rejected email-address is found in the message, -processing terminates. -
      2. -
    2. Otherwise, -if the originator isn't the user, -or a friend, -or a permanent-access guest, -or a temporary-access guest, -and if noticeFile is set, -then the message is rejected. -
      3. -
    3. Otherwise, -each recipient email-address in the message's header is added to a guest -list. -(If the originator is the user, -the permanent-guest list is used instead of the temporary-guest -list.) -
      4. -

    -

    5. -
  5. If the originator is the the user, -then: - -
      -
    1. If auditOutFile is set, -saved there. -
      2. -
    2. Regardless, processing terminates. -
      3. -

    -

    6. -
  6. If pdaMailboxes is set, -and if any plaintext is contained in the message, -then the plaintext is sent to those email-addresses. -
    7. -
  7. If remoteMailboxes is set, -and if the message is successful resent to those email-addresses, -then processing terminates. -
    8. -
  8. A copy of the message is -saved in the -defaultMaildrop and -processing terminates. -
    9. -

-

-

3.3 The Configuration File

- -

There are two kinds of information that may be defined in configFile: -configuration options and -configurable procedures. -

-

Here's a simple example of a configFile for a user named -"example": -

-    set options(dataDirectory)   .personal
-    set options(defaultMaildrop) /var/mail/example
-    set options(logFile)         [file join .personal personal.log]
-    set options(noticeFile)      [file join .personal notice.txt]
-
- -

3.3.1 Configuration Options

- -

configFile must define -dataDirectory -and -defaultMaildrop. -All other configuration options are optional. -

-

3.3.1.1 dataDirectory

- -

The directory where the mailbot keeps its databases. -The subdirectories are: - -

-
badaddrs:
-
the directory of rejected email-addresses -
-
inaddrs:
-
the directory of originator email-addresses -
-
msgids:
-
the directory of Message-IDs -
-
outaddrs:
-
the permanent-guest list -
-
phrases:
-
the directory of at-most-once passphrases -
-
tmpaddrs:
-
the temporary-guest list -
-

-If you want to remove someone from a guest list, -simply go to that directory and delete the corresponding file. -

-

3.3.1.2 defaultMaildrop

- -

The filename where messages are -saved for later viewing by -your user agent. -

-

3.3.1.3 auditInFile

- -

The filename where messages are -saved for audit purposes. -

-

3.3.1.4 auditOutFile

- -

The filename where your outgoing messages are -saved for audit purposes. -

-

3.3.1.5 dropNames

- -

A list of filename extensions for attachments that automatically -cause the message to be rejected. -

-

3.3.1.6 friendlyDomains

- -

A list used by friendP giving -the domain names where your friends live. -

-

3.3.1.7 friendlyfire

- -

If present and true, -then someone sending a message both to you and someone you've -previously sent mail to, -is considered a friend. -

-

3.3.1.8 logFile

- -

The filename where the mailbot -logs its actions. -

-

3.3.1.9 myMailbox

- -

Your preferred email-address with commentary text, e.g., -

-    Arlington Hewes <hewes@example.com>
-
- -

3.3.1.10 noticeFile

- -

The filename containing the textual notice sent when a message is -rejected. -Note that all occurrances of "%passPhrase%" within this file are -replaced with an at-most-once passphrase allowing the originator to -bypass the mailbot's filtering. -Similarly, -any occurrences of "%subject%" are replaced by the "Subject" of the -incoming message. -

-

3.3.1.11 pdaMailboxes

- -

The email-addresses where a textual synopsis of the incoming message is -sent. -

-

3.3.1.12 remoteMailboxes

- -

The email-addresses where a copy of the incoming message is resent. -

-

3.3.2 Configurable Procedures

- -

All of these procedures are defined in personal.tcl. -You may override any of them in configFile. -

-

3.3.2.1 adminP

-
-    proc adminP {local domain}
-
- -

Returns "1" if the email-address is an automated administrative -process. -

-

3.3.2.2 friendP

-
-    proc friendP {local domain}
-
- -

Returns "1" if the email-address is from a -friendly domain or -sub-domain. -

-

3.3.2.3 ownerP

-
-    proc ownerP {local domain}
-
- -

Returns "1" if the email-address refers to the user -(as determined by looking at -myMailbox, -pdaMailboxes, and -remoteMailboxes. -

-

3.3.2.4 saveMessage

-
-    proc saveMessage {inF {outF ""}}
-
- -

Saves a copy of the message contained in the file inF. -If the destination file, -outF, -isn't specified, -it defaults to the -defaultMaildrop. -

-

3.3.2.5 findPhrase

-
-    proc findPhrase {subject}
-
- -

Returns "1" if a previously-allocated passphrase is present in the -subject. -If so, -the passphrase is forgotten. -

-

3.3.2.6 makePhrase

-
-    proc makePhrase {}
-
- -

Returns an at-most-once passphrase for use with a rejection notice. -

-

3.3.2.7 pruneDir

-
-    proc pruneDir {dir type}
-
- -

Removes old entries from one of the mailbot's -databases. -The second parameter is one of "addr", "msgid", or "phrase". -

-

3.3.2.8 tclLog

-
-    proc tclLog {message}
-
- -

Writes a message to the logFile. -

-
 -
 TOC 
-

References

- -
- -
 -
 TOC 
-

Author's Address

- - - - - - - - - - - - - - - - - -
 Marshall T. Rose
 Dover Beach Consulting, Inc.
 POB 255268
 Sacramento, CA 95865-5268
 US
Phone: +1 916 483 8878
Fax: +1 916 483 8848
EMail: mrose@dbc.mtview.ca.us
- -
 -
 TOC 
-

Appendix A. Impersonal Mail

- -

If impersonalMail -returns a non-empty string -then the message is processed differently than the algorithm given in -Actions. -Specifically: - -

    -
  1. If the message contains a previously-encountered "Message-ID", -processing terminates. -
    2. -
  2. If the message's originator can not be determined, -processing terminates. -
    3. -
  3. The value returned by -impersonalMail -is the folder's name and is broken into one or more components -seperated by dots ("."). -If there aren't at least two components, -or if any of the components are empty -(e.g., the folder is named "sys..announce"), -then the message is bounced. -
    4. -
  4. If mappingFile exists, -that file is examined to see if an entry is present for the folder. -If so, -the message is processed according to the value present, -one of: - -
    -
    "ignore":
    -
    the message is silently ignored; -
    -
    "bounce":
    -
    the message is noisily bounced; or, -
    -
    otherwise:
    -
    the message is resent to the address. -
    -

    -Regardless, -if an entry was present for the folder, -then processing terminates. -

    5. -
  5. The message is saved -in a file whose name is constructed by replacing each dot (".") in the -folder name with a directory seperator -(e.g., if the folder is named "sys.announce", -then the file is called "announce" underneath the directory "sys" -underneath the directory identified by -foldersDirectory. -
    6. -
  6. Finally, -the file identified by foldersFile -is updated as necessary. -
    7. -

-

-

A.1 Configuration Options

- -

If "impersonal" mail is received, -then foldersFile and -foldersDirectory -must exist. -

-

A.1.1 foldersDirectory

- -

The directory where the mailbot keeps private folders. -

-

A.1.2 foldersFile

- -

This file contains one line for each private folder. -

-

A.1.3 announceMailboxes

- -

The email-addresses where an announcement is sent when a new -private folder is created. -

-

A.1.4 mappingFile

- -

The file consulted by the mailbot to determine how to process -"impersonal" messages. -Each line of the file consists of a folder name and value, -seperated by a colon (":"). -There are three reserved values: "bounce", "ignore", and "store". -

-

A.2 Configurable Procedures

- -

All of these procedures are defined in personal.tcl. -You may override any of them in configFile. -

-

A.2.1 impersonalMail

-
-    proc impersonalMail {}
-
- -

If the message is deemed "impersonal", -return the name of a corresponding private folder; -otherwise, -return the empty-string. -

-

Many mail systems have a mechanism of passing additional -information when performing final delivery using a program. -With modern versions of sendmail, -for example, -if mail is sent to a local user named "user+detail", -then, -in the absense of an alias for either "user+detail" or "user+*", -then the message is delivered to "user". -The trick is to get sendmail to pass the "detail" part to the mailbot. -

-

At present, -sendmail passes this information only if procmail is your local -mailer. -Here's how I do it: -

-    *** _alias.c    Tue Dec 29 10:42:25 1998
-    --- alias.c     Sat Sep 18 21:51:35 1999
-    ***************
-    *** 813,818 ****
-    --- 813,821 ----
-            define('z', user->q_home, e);
-            define('u', user->q_user, e);
-            define('h', user->q_host, e);
-    + 
-    +       setuserenv("SUFFIX", user->q_host);
-    + 
-            if (ForwardPath == NULL)
-                    ForwardPath = newstr("\201z/.forward");
-
- -

This makes available an environment variable called -"SUFFIX" which has the "details" part. -The drawback in this approach is that this information is lost if the -message is re-queued for delivery -(what's really needed is an addition to the .forward syntax to allow -macros such as $h to be passed). -

-

The corresponding impersonalMail procedure is defined as: -

-    proc impersonalMail {} {
-        global env
-
-        return $env(SUFFIX)
-    }
-
- -

A.2.2 processFolder

-
-    proc processFolder {folderName mimeT} { return $string }
-
- -

If an entry for the folder exists in the -mappingFile, -and if the value for that entry is "process", -then this procedure is invoked to return a string indicating what -action to take -(cf., Impersonal Mail). -

-
 -
 TOC 
-

Appendix B. An Example configFile

- -

Here is the ".forward" file for the user "hewes": -

-    "|/usr/pkg/lib/mbot-1.1/personal.tcl 
-         -config .personal/config.tcl -user hewes"
-
- -

(Of course, it's all on one line.) -

-

Here is the user's ".personal/config.tcl" file: -

-    array set options [list                                          \
-        dataDirectory     .personal                                  \
-        defaultMaildrop   /var/mail/hewes                            \
-        auditInFile       [file join .personal INCOMING]             \
-        auditOutFile      [file join .personal OUTGOING]             \
-        friendlyDomains   [list tcp.int example.com]                 \
-        logFile           [file join .personal personal.log]         \
-        myMailbox         "Arlington Hewes <hewes@example.com>"      \
-        pdaMailboxes      hewes.pager@example.com                    \
-        noticeFile        [file join .personal notice.txt]           \
-        foldersDirectory  [file join .personal folders]              \
-        foldersFile       [file join .personal .mailboxlist]         \
-        announceMailboxes hewes+sys.announce@example.com             \
-        mappingFile       [file join .personal mapping]              \
-        friendlyFire      1                                          \
-        dropNames         [list *.bat *.exe *.src *.pif *.wav *.vbs] \
-    ]
-
-    proc impersonalMail {} {
-        global env
-
-        return $env(SUFFIX)
-    }
-
- -

Note that because -remoteMailboxes isn't -defined, -personal messages are ultimately stored in the user's -defaultMaildrop. -

-
 -
 TOC 
-

Appendix C. Acknowledgements

- -

The original version of this mailbot was written by the author in 1994, -implemented using the safe-tcl package -(Borenstein and Rose, circa 1993). -

 DELETED examples/mime/mbot/README.txt Index: examples/mime/mbot/README.txt ================================================================== --- examples/mime/mbot/README.txt +++ /dev/null @@ -1,1008 +0,0 @@ - - -The README file M. Rose - Dover Beach Consulting, Inc. - February 2002 - - - The personal.tcl Mailbot - - -Abstract - - The personal.tcl mailbot implements a highly-specialized filter for - personal messages. It MUST not be used by people who receive mailing - list traffic in their personal mailboxes. - -Table of Contents - - 1. SYNOPSIS . . . . . . . . . . . . . . . . . . . . . . . . . . 2 - 1.1 Requirements . . . . . . . . . . . . . . . . . . . . . . . . 2 - 1.2 Copyrights . . . . . . . . . . . . . . . . . . . . . . . . . 2 - 2. PHILOSOPHY . . . . . . . . . . . . . . . . . . . . . . . . . 3 - 2.1 Guest Lists . . . . . . . . . . . . . . . . . . . . . . . . 4 - 3. BEHAVIOR . . . . . . . . . . . . . . . . . . . . . . . . . . 5 - 3.1 Arguments . . . . . . . . . . . . . . . . . . . . . . . . . 5 - 3.2 Actions . . . . . . . . . . . . . . . . . . . . . . . . . . 6 - 3.3 The Configuration File . . . . . . . . . . . . . . . . . . . 7 - 3.3.1 Configuration Options . . . . . . . . . . . . . . . . . . . 7 - 3.3.2 Configurable Procedures . . . . . . . . . . . . . . . . . . 10 - References . . . . . . . . . . . . . . . . . . . . . . . . . 12 - Author's Address . . . . . . . . . . . . . . . . . . . . . . 12 - A. Impersonal Mail . . . . . . . . . . . . . . . . . . . . . . 13 - A.1 Configuration Options . . . . . . . . . . . . . . . . . . . 14 - A.1.1 foldersDirectory . . . . . . . . . . . . . . . . . . . . . . 14 - A.1.2 foldersFile . . . . . . . . . . . . . . . . . . . . . . . . 14 - A.1.3 announceMailboxes . . . . . . . . . . . . . . . . . . . . . 14 - A.1.4 mappingFile . . . . . . . . . . . . . . . . . . . . . . . . 14 - A.2 Configurable Procedures . . . . . . . . . . . . . . . . . . 15 - A.2.1 impersonalMail . . . . . . . . . . . . . . . . . . . . . . . 15 - A.2.2 processFolder . . . . . . . . . . . . . . . . . . . . . . . 16 - B. An Example configFile . . . . . . . . . . . . . . . . . . . 17 - C. Acknowledgements . . . . . . . . . . . . . . . . . . . . . . 18 - - - - - - - - - - - - -Rose [Page 1] - -README The personal.tcl Mailbot February 2002 - - -1. SYNOPSIS - - Create a configuration file (Section 3.3) and add this line to your - ".forward" file: - - "| LIB/mbot-1.1/personal.tcl -config FILE -user USER" - - where "LIB" is where the Tcl library lives, "FILE" is the name of - your configuration file, and "USER" is your username. - -1.1 Requirements - - This package requires: - - o Tcl version 8.3 [1] or later - - o tcl lib [2] - - o TclX version 8.0 [3] or later - - -1.2 Copyrights - - (c) 1999-2002 Marshall T. Rose - - Hold harmless the author, and any lawful use is allowed. - - - - - - - - - - - - - - - - - - - - - - - - - -Rose [Page 2] - -README The personal.tcl Mailbot February 2002 - - -2. PHILOSOPHY - - The mailbot's philosophy is simple: - - o The mailbot receives all of your incoming personal mail. - - o You ALWAYS copy yourself on every message you send, so that the - mailbot receives all of your outgoing personal mail. - - o The mailbot performs six tasks, all optional: - - * makes audit copies of your incoming and outgoing mail; - - * performs duplicate supression; - - * performs originator supression by rejecting messages from - people who aren't your friends or on a guest list; - - * performs content supression by rejecting messages that contain - attachments with extensions on your prohibited list; - - * sends a textual synopsis to your PDA; and, - - * sends a copy to your remote mailbox. - - Do NOT use the personal.tcl mailbot if you receive mailing list - traffic in your personal mailbox. When sending mail to a mailing - list, either: - - o use a "From" address that the personal.tcl mailbot will process as - "impersonal" mail, (e.g., "hewes+ietf.general@example.com"); or, - - o set the "Reply-To" for the message to the mailing list. - - Consult Appendix A for information on how "impersonal" mail is - identified and processed. - - - - - - - - - - - - - - - -Rose [Page 3] - -README The personal.tcl Mailbot February 2002 - - -2.1 Guest Lists - - Guest lists are an effective mechanism for cutting back on excessive - mail. - - o when the mailbot receives a message from you, it adds any - recipients it finds to a permanent-guest list; - - o when the mailbot receives a message from someone on a guest list, - it adds any recipients it finds to a temporary-guest list; but, - - o when the mailbot receives a message from someone not on any guest - list, they get a rejection notice. - - Note that in order to promote someone to the permanent-guest list, - you must send them a message (with a copy to yourself). In most - cases, simply replying to the original message accomplishes this. Of - course, if you don't want to promote someone to the permanent-guest - list, simply remove that address (or your address) from the list of - recipients in your reply. - - Here are the fine points: - - o rejection notices contain a passphrase that may be used at most - once to bypass the guest list mechanism (notices also contain the - original message to minimize type-in by the uninvited); - - o a flip-flop is used to avoid mail loops; and, - - o messages originated by an administrative address (e.g., - "Postmaster") bypass the guest list mechanism (unless the message - refers to a previously-rejected message, in which case it is - supressed). - - The rejection notice should be written carefully to minimize an - extreme negative reaction on the part of the uninvited. Of course, - by allowing a passphrase, this provides something of a CQ test for - the uninvited -- if someone can't pass the test... - - - - - - - - - - - - - -Rose [Page 4] - -README The personal.tcl Mailbot February 2002 - - -3. BEHAVIOR - -3.1 Arguments - - The mailbot supports the following command line arguments: - - -config configFile: specifies the name of the configuration file - to use; - - -debug boolean: enables debug output; - - -file messageFile: specifies the name of the file containing the - message; - - -originator orginatorAddress: specifies the email-address of the - originator of the message; and, - - -user userName: specifies the user-identity of the recipient. - - Note that if "-user" is given, then the working directory is set to - userName's home directory before configFile is sourced, and the umask - is set defensively. - - The default values are: - - personal.tcl -config .personal-config.tcl \ - -debug 0 \ - -file - \ - -originator "derived from message" - - Given the default values, only "-user" need be specified. The reason - is that if a message is being delivered to multiple local recipients, - and if any of the ".forward" files are identical in content, then - sendmail may not deliver the message to all of the local recipients. - - A few other (sendmail related) tips: - - o If sendmail is configured with smrsh, you'll need to symlink - personal.tcl into the /usr/libexec/sm.bin/ directory. - - o Make sure that tclsh8.0 is in the path specified on the third-line - of personal.tcl. - - o You should chmod your ".forward" file to 0600. - - - - - - - -Rose [Page 5] - -README The personal.tcl Mailbot February 2002 - - -3.2 Actions - - The mailbot begins by parsing its arguments, sourcing configFile, and - then examining the incoming message: - - 1. If auditInFile (Section 3.3.1.3) is set, a copy of the message is - saved (Section 3.3.2.4) there. - - 2. If the message contains a previously-encountered "Message-ID", - processing terminates. - - 3. If the message's originator can not be determined, a copy of the - message is saved (Section 3.3.2.4) in the defaultMaildrop - (Section 3.3.1.2) and processing terminates. - - 4. The originator's email-address is examined: - - 1. If the originator appears to be an automated administrative - process (Section 3.3.2.1), and if a previously rejected - email-address is found in the message, processing terminates. - - 2. Otherwise, if the originator isn't the user (Section - 3.3.2.3), or a friend (Section 3.3.2.2), or a permanent- - access guest, or a temporary-access guest, and if noticeFile - (Section 3.3.1.10) is set, then the message is rejected. - - 3. Otherwise, each recipient email-address in the message's - header is added to a guest list. (If the originator is the - user (Section 3.3.2.3), the permanent-guest list is used - instead of the temporary-guest list.) - - 5. If the originator is the the user (Section 3.3.2.3), then: - - 1. If auditOutFile (Section 3.3.1.4) is set, saved (Section - 3.3.2.4) there. - - 2. Regardless, processing terminates. - - 6. If pdaMailboxes (Section 3.3.1.11) is set, and if any plaintext - is contained in the message, then the plaintext is sent to those - email-addresses. - - 7. If remoteMailboxes (Section 3.3.1.12) is set, and if the message - is successful resent to those email-addresses, then processing - terminates. - - 8. A copy of the message is saved (Section 3.3.2.4) in the - defaultMaildrop (Section 3.3.1.2) and processing terminates. - - - -Rose [Page 6] - -README The personal.tcl Mailbot February 2002 - - -3.3 The Configuration File - - There are two kinds of information that may be defined in configFile: - configuration options (Section 3.3.1) and configurable procedures - (Section 3.3.2). - - Here's a simple example of a configFile for a user named "example": - - set options(dataDirectory) .personal - set options(defaultMaildrop) /var/mail/example - set options(logFile) [file join .personal personal.log] - set options(noticeFile) [file join .personal notice.txt] - - -3.3.1 Configuration Options - - configFile must define dataDirectory (Section 3.3.1.1) and - defaultMaildrop (Section 3.3.1.2). All other configuration options - are optional. - -3.3.1.1 dataDirectory - - The directory where the mailbot keeps its databases. The - subdirectories are: - - badaddrs: the directory of rejected email-addresses - - inaddrs: the directory of originator email-addresses - - msgids: the directory of Message-IDs - - outaddrs: the permanent-guest list - - phrases: the directory of at-most-once passphrases - - tmpaddrs: the temporary-guest list - - If you want to remove someone from a guest list, simply go to that - directory and delete the corresponding file. - -3.3.1.2 defaultMaildrop - - The filename where messages are saved (Section 3.3.2.4) for later - viewing by your user agent. - -3.3.1.3 auditInFile - - The filename where messages are saved (Section 3.3.2.4) for audit - - - -Rose [Page 7] - -README The personal.tcl Mailbot February 2002 - - - purposes. - -3.3.1.4 auditOutFile - - The filename where your outgoing messages are saved (Section 3.3.2.4) - for audit purposes. - -3.3.1.5 dropNames - - A list of filename extensions for attachments that automatically - cause the message to be rejected. - -3.3.1.6 friendlyDomains - - A list used by friendP (Section 3.3.2.2) giving the domain names - where your friends live. - -3.3.1.7 friendlyfire - - If present and true, then someone sending a message both to you and - someone you've previously sent mail to, is considered a friend. - -3.3.1.8 logFile - - The filename where the mailbot logs (Section 3.3.2.8) its actions. - -3.3.1.9 myMailbox - - Your preferred email-address with commentary text, e.g., - - Arlington Hewes - - -3.3.1.10 noticeFile - - The filename containing the textual notice sent when a message is - rejected. Note that all occurrances of "%passPhrase%" within this - file are replaced with an at-most-once passphrase allowing the - originator to bypass the mailbot's filtering. Similarly, any - occurrences of "%subject%" are replaced by the "Subject" of the - incoming message. - -3.3.1.11 pdaMailboxes - - The email-addresses where a textual synopsis of the incoming message - is sent. - - - - - -Rose [Page 8] - -README The personal.tcl Mailbot February 2002 - - -3.3.1.12 remoteMailboxes - - The email-addresses where a copy of the incoming message is resent. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Rose [Page 9] - -README The personal.tcl Mailbot February 2002 - - -3.3.2 Configurable Procedures - - All of these procedures are defined in personal.tcl. You may - override any of them in configFile. - -3.3.2.1 adminP - - proc adminP {local domain} - - Returns "1" if the email-address is an automated administrative - process. - -3.3.2.2 friendP - - proc friendP {local domain} - - Returns "1" if the email-address is from a friendly domain (Section - 3.3.1.6) or sub-domain. - -3.3.2.3 ownerP - - proc ownerP {local domain} - - Returns "1" if the email-address refers to the user (as determined by - looking at myMailbox (Section 3.3.1.9), pdaMailboxes (Section - 3.3.1.11), and remoteMailboxes (Section 3.3.1.12). - -3.3.2.4 saveMessage - - proc saveMessage {inF {outF ""}} - - Saves a copy of the message contained in the file inF. If the - destination file, outF, isn't specified, it defaults to the - defaultMaildrop (Section 3.3.1.2). - -3.3.2.5 findPhrase - - proc findPhrase {subject} - - Returns "1" if a previously-allocated passphrase is present in the - subject. If so, the passphrase is forgotten. - -3.3.2.6 makePhrase - - proc makePhrase {} - - Returns an at-most-once passphrase for use with a rejection notice. - - - - -Rose [Page 10] - -README The personal.tcl Mailbot February 2002 - - -3.3.2.7 pruneDir - - proc pruneDir {dir type} - - Removes old entries from one of the mailbot's databases (Section - 3.3.1.1). The second parameter is one of "addr", "msgid", or - "phrase". - -3.3.2.8 tclLog - - proc tclLog {message} - - Writes a message to the logFile (Section 3.3.1.8). - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Rose [Page 11] - -README The personal.tcl Mailbot February 2002 - - -References - - [1] - - [2] - - [3] - - -Author's Address - - Marshall T. Rose - Dover Beach Consulting, Inc. - POB 255268 - Sacramento, CA 95865-5268 - US - - Phone: +1 916 483 8878 - Fax: +1 916 483 8848 - EMail: mrose@dbc.mtview.ca.us - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Rose [Page 12] - -README The personal.tcl Mailbot February 2002 - - -Appendix A. Impersonal Mail - - If impersonalMail (Appendix A.2.1) returns a non-empty string then - the message is processed differently than the algorithm given in - Section 3.2. Specifically: - - 1. If the message contains a previously-encountered "Message-ID", - processing terminates. - - 2. If the message's originator can not be determined, processing - terminates. - - 3. The value returned by impersonalMail (Appendix A.2.1) is the - folder's name and is broken into one or more components seperated - by dots ("."). If there aren't at least two components, or if - any of the components are empty (e.g., the folder is named - "sys..announce"), then the message is bounced. - - 4. If mappingFile (Appendix A.1.4) exists, that file is examined to - see if an entry is present for the folder. If so, the message is - processed according to the value present, one of: - - "ignore": the message is silently ignored; - - "bounce": the message is noisily bounced; or, - - otherwise: the message is resent to the address. - - Regardless, if an entry was present for the folder, then - processing terminates. - - 5. The message is saved (Section 3.3.2.4) in a file whose name is - constructed by replacing each dot (".") in the folder name with a - directory seperator (e.g., if the folder is named "sys.announce", - then the file is called "announce" underneath the directory "sys" - underneath the directory identified by foldersDirectory (Appendix - A.1.1). - - 6. Finally, the file identified by foldersFile (Appendix A.1.2) is - updated as necessary. - - - - - - - - - - - -Rose [Page 13] - -README The personal.tcl Mailbot February 2002 - - -A.1 Configuration Options - - If "impersonal" mail is received, then foldersFile (Appendix A.1.2) - and foldersDirectory (Appendix A.1.1) must exist. - -A.1.1 foldersDirectory - - The directory where the mailbot keeps private folders. - -A.1.2 foldersFile - - This file contains one line for each private folder. - -A.1.3 announceMailboxes - - The email-addresses where an announcement is sent when a new private - folder is created. - -A.1.4 mappingFile - - The file consulted by the mailbot to determine how to process - "impersonal" messages. Each line of the file consists of a folder - name and value, seperated by a colon (":"). There are three reserved - values: "bounce", "ignore", and "store". - - - - - - - - - - - - - - - - - - - - - - - - - - - -Rose [Page 14] - -README The personal.tcl Mailbot February 2002 - - -A.2 Configurable Procedures - - All of these procedures are defined in personal.tcl. You may - override any of them in configFile. - -A.2.1 impersonalMail - - proc impersonalMail {} - - If the message is deemed "impersonal", return the name of a - corresponding private folder; otherwise, return the empty-string. - - Many mail systems have a mechanism of passing additional information - when performing final delivery using a program. With modern versions - of sendmail, for example, if mail is sent to a local user named - "user+detail", then, in the absense of an alias for either - "user+detail" or "user+*", then the message is delivered to "user". - The trick is to get sendmail to pass the "detail" part to the - mailbot. - - At present, sendmail passes this information only if procmail is your - local mailer. Here's how I do it: - - *** _alias.c Tue Dec 29 10:42:25 1998 - --- alias.c Sat Sep 18 21:51:35 1999 - *************** - *** 813,818 **** - --- 813,821 ---- - define('z', user->q_home, e); - define('u', user->q_user, e); - define('h', user->q_host, e); - + - + setuserenv("SUFFIX", user->q_host); - + - if (ForwardPath == NULL) - ForwardPath = newstr("\201z/.forward"); - - This makes available an environment variable called "SUFFIX" which - has the "details" part. The drawback in this approach is that this - information is lost if the message is re-queued for delivery (what's - really needed is an addition to the .forward syntax to allow macros - such as $h to be passed). - - - - - - - - - -Rose [Page 15] - -README The personal.tcl Mailbot February 2002 - - - The corresponding impersonalMail procedure is defined as: - - proc impersonalMail {} { - global env - - return $env(SUFFIX) - } - - -A.2.2 processFolder - - proc processFolder {folderName mimeT} { return $string } - - If an entry for the folder exists in the mappingFile (Appendix - A.1.4), and if the value for that entry is "process", then this - procedure is invoked to return a string indicating what action to - take (cf., Appendix A). - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Rose [Page 16] - -README The personal.tcl Mailbot February 2002 - - -Appendix B. An Example configFile - - Here is the ".forward" file for the user "hewes": - - "|/usr/pkg/lib/mbot-1.1/personal.tcl - -config .personal/config.tcl -user hewes" - - (Of course, it's all on one line.) - - Here is the user's ".personal/config.tcl" file: - - array set options [list \ - dataDirectory .personal \ - defaultMaildrop /var/mail/hewes \ - auditInFile [file join .personal INCOMING] \ - auditOutFile [file join .personal OUTGOING] \ - friendlyDomains [list tcp.int example.com] \ - logFile [file join .personal personal.log] \ - myMailbox "Arlington Hewes " \ - pdaMailboxes hewes.pager@example.com \ - noticeFile [file join .personal notice.txt] \ - foldersDirectory [file join .personal folders] \ - foldersFile [file join .personal .mailboxlist] \ - announceMailboxes hewes+sys.announce@example.com \ - mappingFile [file join .personal mapping] \ - friendlyFire 1 \ - dropNames [list *.bat *.exe *.src *.pif *.wav *.vbs] \ - ] - - proc impersonalMail {} { - global env - - return $env(SUFFIX) - } - - Note that because remoteMailboxes (Section 3.3.1.12) isn't defined, - personal messages are ultimately stored in the user's defaultMaildrop - (Section 3.3.1.2). - - - - - - - - - - - - - -Rose [Page 17] - -README The personal.tcl Mailbot February 2002 - - -Appendix C. Acknowledgements - - The original version of this mailbot was written by the author in - 1994, implemented using the safe-tcl package (Borenstein and Rose, - circa 1993). - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Rose [Page 18] - DELETED examples/mime/mbot/README.xml Index: examples/mime/mbot/README.xml ================================================================== --- examples/mime/mbot/README.xml +++ /dev/null @@ -1,720 +0,0 @@ - - - - - - - - - - -The personal.tcl Mailbot - - -Dover Beach Consulting, Inc. -
- -POB 255268 -Sacramento CA 95865-5268 -US - -+1 916 483 8878 -+1 916 483 8848 -mrose@dbc.mtview.ca.us -
- - - - -The personal.tcl mailbot implements a highly-specialized -filter for personal messages. -It MUST not be used by people who receive mailing list traffic in -their personal mailboxes. - - - -
-
-Create a configuration file -and add this line to your ".forward" file: - -where "LIB" is where the Tcl library lives, -"FILE" is the name of your configuration file, -and "USER" is your username. -
- -
-This package requires: - -Tcl version 8.3 -or later - -tcl lib - -TclX version 8.0 -or later - -
- -
-(c) 1999-2002 Marshall T. Rose - -Hold harmless the author, and any lawful use is allowed. -
-
- -
-The mailbot's philosophy is simple: - -The mailbot receives all of your incoming personal mail. - -You ALWAYS copy yourself on every message you send, -so that the mailbot receives all of your outgoing personal mail. - -The mailbot performs six tasks, all optional: - -makes audit copies of your incoming and outgoing mail; - -performs duplicate supression; - -performs originator supression by rejecting messages from people -who aren't your friends or on a guest list; - -performs content supression by rejecting messages that contain -attachments with extensions on your prohibited list; - -sends a textual synopsis to your PDA; and, - -sends a copy to your remote mailbox. - - - -Do NOT use the personal.tcl mailbot if you receive mailing list -traffic in your personal mailbox. -When sending mail to a mailing list, -either: - -use a "From" address that the personal.tcl mailbot will process as -"impersonal" mail, -(e.g., "hewes+ietf.general@example.com"); or, - -set the "Reply-To" for the message to the mailing list. - -Consult for information on how -"impersonal" mail is identified and processed. - - - -
-Guest lists are an effective mechanism for cutting back on -excessive mail. - -when the mailbot receives a message from you, -it adds any recipients it finds to a permanent-guest list; - -when the mailbot receives a message from someone on a guest list, -it adds any recipients it finds to a temporary-guest list; but, - -when the mailbot receives a message from someone not on any guest -list, -they get a rejection notice. - -Note that in order to promote someone to the permanent-guest list, -you must send them a message (with a copy to yourself). -In most cases, -simply replying to the original message accomplishes this. -Of course, -if you don't want to promote someone to the permanent-guest list, -simply remove that address (or your address) from the list of -recipients in your reply. - -Here are the fine points: - -rejection notices contain a passphrase that may be used at most -once to bypass the guest list mechanism -(notices also contain the original message to minimize type-in -by the uninvited); - -a flip-flop is used to avoid mail loops; and, - -messages originated by an administrative address (e.g., -"Postmaster") bypass the guest list mechanism -(unless the message refers to a previously-rejected message, -in which case it is supressed). - - -The rejection notice should be written carefully to minimize an -extreme negative reaction on the part of the uninvited. -Of course, -by allowing a passphrase, -this provides something of a CQ test for the uninvited -- -if someone can't pass the test... -
-
- -
-
-The mailbot supports the following command line arguments: - - -specifies the name of the configuration file to use; - - -enables debug output; - - -specifies the name of the file containing the message; - - -specifies the email-address of the originator of the message; and, - - -specifies the user-identity of the recipient. - -Note that if "-user" is given, -then the working directory is set to userName's home directory before -configFile is sourced, -and the umask is set defensively. - -
-The default values are: - -Given the default values, -only "-user" need be specified. -The reason is that if a message is being delivered to multiple local -recipients, -and if any of the ".forward" files are identical in content, -then sendmail may not deliver the message to all of the local -recipients. -
- -A few other (sendmail related) tips: - -If sendmail is configured with smrsh, -you'll need to symlink personal.tcl into the -/usr/libexec/sm.bin/ directory. - -Make sure that tclsh8.0 is in the path specified on the third-line -of personal.tcl. - -You should chmod your ".forward" file to 0600. - -
- - - -
-The mailbot begins by parsing its arguments, -sourcing configFile, -and then examining the incoming message: - -If auditInFile is set, -a copy of the message is -saved there. - -If the message contains a previously-encountered "Message-ID", -processing terminates. - -If the message's originator can not be determined, -a copy of the message is -saved in the -defaultMaildrop and -processing terminates. - -The originator's email-address is examined: - -If the originator appears to be an -automated administrative process, -and if a previously rejected email-address is found in the message, -processing terminates. - -Otherwise, -if the originator isn't the user, -or a friend, -or a permanent-access guest, -or a temporary-access guest, -and if noticeFile is set, -then the message is rejected. - -Otherwise, -each recipient email-address in the message's header is added to a guest -list. -(If the originator is the user, -the permanent-guest list is used instead of the temporary-guest -list.) - - -If the originator is the the user, -then: - -If auditOutFile is set, -saved there. - -Regardless, processing terminates. - - -If pdaMailboxes is set, -and if any plaintext is contained in the message, -then the plaintext is sent to those email-addresses. - -If remoteMailboxes is set, -and if the message is successful resent to those email-addresses, -then processing terminates. - -A copy of the message is -saved in the -defaultMaildrop and -processing terminates. - -
- -
-There are two kinds of information that may be defined in configFile: -configuration options and -configurable procedures. - -
-Here's a simple example of a configFile for a user named -"example": - -
- -
-configFile must define -dataDirectory -and -defaultMaildrop. -All other configuration options are optional. - -
-The directory where the mailbot keeps its databases. -The subdirectories are: - -the directory of rejected email-addresses - -the directory of originator email-addresses - -the directory of Message-IDs - -the permanent-guest list - -the directory of at-most-once passphrases - -the temporary-guest list - -If you want to remove someone from a guest list, -simply go to that directory and delete the corresponding file. -
- -
-The filename where messages are -saved for later viewing by -your user agent. -
- -
-The filename where messages are -saved for audit purposes. -
- -
-The filename where your outgoing messages are -saved for audit purposes. -
- -
-A list of filename extensions for attachments that automatically -cause the message to be rejected. -
- -
-A list used by friendP giving -the domain names where your friends live. -
- -
-If present and true, -then someone sending a message both to you and someone you've -previously sent mail to, -is considered a friend. -
- -
-The filename where the mailbot -logs its actions. -
- -
-
-Your preferred email-address with commentary text, e.g., - -]]> -
-
- -
-The filename containing the textual notice sent when a message is -rejected. -Note that all occurrances of "%passPhrase%" within this file are -replaced with an at-most-once passphrase allowing the originator to -bypass the mailbot's filtering. -Similarly, -any occurrences of "%subject%" are replaced by the "Subject" of the -incoming message. -
- -
-The email-addresses where a textual synopsis of the incoming message is -sent. -
- -
-The email-addresses where a copy of the incoming message is resent. -
-
- - - -
-All of these procedures are defined in personal.tcl. -You may override any of them in configFile. - -
-
- -
- -Returns "1" if the email-address is an automated administrative -process. -
- -
-
- -
- -Returns "1" if the email-address is from a -friendly domain or -sub-domain. -
- -
-
- -
- -Returns "1" if the email-address refers to the user -(as determined by looking at -myMailbox, -pdaMailboxes, and -remoteMailboxes. -
- -
-
- -
- -Saves a copy of the message contained in the file inF. -If the destination file, -outF, -isn't specified, -it defaults to the -defaultMaildrop. -
- -
-
- -
- -Returns "1" if a previously-allocated passphrase is present in the -subject. -If so, -the passphrase is forgotten. -
- -
-
- -
- -Returns an at-most-once passphrase for use with a rejection notice. -
- -
-
- -
- -Removes old entries from one of the mailbot's -databases. -The second parameter is one of "addr", "msgid", or "phrase". -
- -
-
- -
- -Writes a message to the logFile. -
-
-
- -
- - - - - - -
-If impersonalMail -returns a non-empty string -then the message is processed differently than the algorithm given in -. -Specifically: - -If the message contains a previously-encountered "Message-ID", -processing terminates. - -If the message's originator can not be determined, -processing terminates. - -The value returned by -impersonalMail -is the folder's name and is broken into one or more components -seperated by dots ("."). -If there aren't at least two components, -or if any of the components are empty -(e.g., the folder is named "sys..announce"), -then the message is bounced. - -If mappingFile exists, -that file is examined to see if an entry is present for the folder. -If so, -the message is processed according to the value present, -one of: - -the message is silently ignored; - -the message is noisily bounced; or, - -the message is resent to the address. - -Regardless, -if an entry was present for the folder, -then processing terminates. - -The message is saved -in a file whose name is constructed by replacing each dot (".") in the -folder name with a directory seperator -(e.g., if the folder is named "sys.announce", -then the file is called "announce" underneath the directory "sys" -underneath the directory identified by -foldersDirectory. - -Finally, -the file identified by foldersFile -is updated as necessary. - - - - -
-If "impersonal" mail is received, -then foldersFile and -foldersDirectory -must exist. - -
-The directory where the mailbot keeps private folders. -
- -
-This file contains one line for each private folder. -
- -
-The email-addresses where an announcement is sent when a new -private folder is created. -
- -
-The file consulted by the mailbot to determine how to process -"impersonal" messages. -Each line of the file consists of a folder name and value, -seperated by a colon (":"). -There are three reserved values: "bounce", "ignore", and "store". -
-
- - - -
-All of these procedures are defined in personal.tcl. -You may override any of them in configFile. - -
-
- -
- -If the message is deemed "impersonal", -return the name of a corresponding private folder; -otherwise, -return the empty-string. - -Many mail systems have a mechanism of passing additional -information when performing final delivery using a program. -With modern versions of sendmail, -for example, -if mail is sent to a local user named "user+detail", -then, -in the absense of an alias for either "user+detail" or "user+*", -then the message is delivered to "user". -The trick is to get sendmail to pass the "detail" part to the mailbot. - -
-At present, -sendmail passes this information only if procmail is your local -mailer. -Here's how I do it: -q_home, e); - define('u', user->q_user, e); - define('h', user->q_host, e); - + - + setuserenv("SUFFIX", user->q_host); - + - if (ForwardPath == NULL) - ForwardPath = newstr("\201z/.forward"); -]]> -This makes available an environment variable called -"SUFFIX" which has the "details" part. -The drawback in this approach is that this information is lost if the -message is re-queued for delivery -(what's really needed is an addition to the .forward syntax to allow -macros such as $h to be passed). -
- -
-The corresponding impersonalMail procedure is defined as: - -
-
- -
-
- -
- -If an entry for the folder exists in the -mappingFile, -and if the value for that entry is "process", -then this procedure is invoked to return a string indicating what -action to take -(cf., ). -
-
-
- -
-
-Here is the ".forward" file for the user "hewes": - -(Of course, it's all on one line.) -
- -
-Here is the user's ".personal/config.tcl" file: -" \ - pdaMailboxes hewes.pager@example.com \ - noticeFile [file join .personal notice.txt] \ - foldersDirectory [file join .personal folders] \ - foldersFile [file join .personal .mailboxlist] \ - announceMailboxes hewes+sys.announce@example.com \ - mappingFile [file join .personal mapping] \ - friendlyFire 1 \ - dropNames [list *.bat *.exe *.src *.pif *.wav *.vbs] \ - ] - - proc impersonalMail {} { - global env - - return $env(SUFFIX) - } -]]> -Note that because -remoteMailboxes isn't -defined, -personal messages are ultimately stored in the user's -defaultMaildrop. -
-
- -
-The original version of this mailbot was written by the author in 1994, -implemented using the safe-tcl package -(Borenstein and Rose, circa 1993). -
- - - - DELETED examples/mime/mbot/impersonal.tcl Index: examples/mime/mbot/impersonal.tcl ================================================================== --- examples/mime/mbot/impersonal.tcl +++ /dev/null @@ -1,533 +0,0 @@ -#!/bin/sh -# the next line restarts using tclsh \ -PATH=/usr/pkg/bin:/usr/local/bin:/usr/bin:/bin LD_LIBRARY_PATH=/usr/pkg/lib:/usr/local/lib:/usr/lib export PATH LD_LIBRARY_PATH; exec tclsh8.3 "$0" "$@" - -# impersonal.tcl - export impersonal mail via the web -# -# (c) 1999 Marshall T. Rose -# Hold harmless the author, and any lawful use is allowed. -# - - -global options - - -# begin of routines that may be redefined in configFile - -proc tclLog {message} { - global options - - if {([info exists options(debugP)]) && ($options(debugP) > 0)} { - puts stderr $message - } - - if {([string first "DEBUG " $message] == 0) \ - || ([catch { set fd [open $options(logFile) \ - { WRONLY CREAT APPEND }] }])} { - return - } - - regsub -all "\n" $message " " message - - catch { puts -nonewline $fd \ - [format "%s %-8.8s %06d %s\n" \ - [clock format [clock seconds] -format "%m/%d %T"] \ - personal [expr [pid]%65535] $message] } - - catch { close $fd } -} - -# end of routines that may be redefined in configFile - - -proc firstext {mime} { - array set props [mime::getproperty $mime] - - if {[info exists props(parts)]} { - foreach part $props(parts) { - if {[string compare [firstext $part] ""]} { - return $part - } - } - } else { - switch -- $props(content) { - text/plain - - - text/html { - return $mime - } - } - } -} - -proc sanitize {text} { - regsub -all "&" $text {\&} text - regsub -all "<" $text {\<} text - - return $text -} - -proc cleanup {{message ""} {code 500}} { - global errorCode errorInfo - - set ecode $errorCode - set einfo $errorInfo - - if {[string compare $message ""]} { - tclLog $message - - catch { - puts stdout "HTTP/1.0 $code Server Error -Content-Type: text/html -Status: 500 Server Error - -Service Problem -

Service Problem

-Reason: [sanitize $message]" - - if {$code == 505} { - puts stdout "
-Stack: -
[sanitize $einfo]
-
" - } - - puts stdout "" - } - } - - flush stdout - - exit 0 -} - - - -if {[catch { - - set program impersonal - - package require mbox 1.0 - package require mutl 1.0 - package require smtp 1.1 - package require Tclx 8.0 - - -# move stdin, close stdin/stderr - - dup [set null [open /dev/null { RDWR }]] stderr - set stdin [dup stdin] - dup $null stdin - close $null - - fconfigure $stdin -translation crlf - fconfigure stdout -translation crlf - - -# parse arguments and initialize environment - - set program [file tail [file rootname $argv0]] - - set configFile .${program}-config.tcl - - set debugP 0 - - set userName "" - - for {set argx 0} {$argx < $argc} {incr argx} { - set option [lindex $argv $argx] - if {[incr argx] >= $argc} { - cleanup "missing argument to $option" - } - set value [lindex $argv $argx] - - switch -- $option { - -config { - set configFile $value - } - - -debug { - set options(debugP) [set debugP [smtp::boolean $value]] - } - - -user { - set userName $value - } - - default { - cleanup "unknown option $option" - } - } - } - - if {[string compare $userName ""]} { - if {[catch { id convert user $userName }]} { - cleanup "userName doesn't exist: $userName" - } - if {([catch { file isdirectory ~$userName } result]) \ - || (!$result)} { - cleanup "userName doesn't have a home directory: $userName" - } - - umask 0077 - cd ~$userName - } - - if {![file exists $configFile]} { - cleanup "configFile file doesn't exist: $configFile" - } - source $configFile - - set options(debugP) $debugP - - foreach {k v} [array get options] { - if {![string compare $v ""]} { - unset options($k) - } - } - - foreach k [list dataDirectory foldersFile foldersDirectory] { - if {![info exists options($k)]} { - cleanup "configFile didn't define $k: $configFile" - } - } - - if {![file isdirectory $options(dataDirectory)]} { - file mkdir $options(dataDirectory) - } - - -# crack the request - - set request "" - set eol "" - while {1} { - if {[catch { gets $stdin line } result]} { - cleanup "lost connection" - } - if {$result < 0} { - break - } - - set gotP 0 - foreach c [split $line ""] { - if {($c == " ") || ($c == "\t") || [ctype print $c]} { - if {!$gotP} { - append request $eol - set gotP 1 - } - append request $c - } - } - if {!$gotP} { - break - } - - set eol "\n" - } - set request [string tolower $request] - - set getP 0 - foreach param [split $request "\n"] { - if {[string first "get " $param] == 0} { - set getP 1 - if {[catch { lindex [split $param " "] 1 } page]} { - cleanup "server supports only HTTP/1.0" 501 - } - } - } - if {!$getP} { - cleanup "server supports only GET" 405 - } - - if {[string first /news? $page] != 0} { - cleanup "page $page unavailable" 504 - } - foreach param [split [string range $page 6 end] &] { - if {[set x [string first = $param]] <= 0} { - cleanup "page $request unavailable" 504 - } - set key [string range $param 0 [expr $x-1]] - set arg($key) [string range $param [expr $x+1] end] - } - - set expires [mime::parsedatetime -now proper] - - -# /news?index=newsgroups OR /news?index=recent - - if {![catch { set arg(index) } index]} { - switch -- $index { - newsgroups { - set lastN 0 - } - - recent { - set lastN -1 - } - - default { - cleanup "page $request unavailable" 504 - } - } - catch { set lastN $arg(lastn) } - - if {[catch { open $options(foldersFile) { RDONLY } } fd]} { - cleanup $fd 505 - } - - set folders "" - set suffix [lindex [set prefix [file split \ - $options(foldersDirectory)]] \ - end] - set prefix [eval [list file join] [lreplace $prefix end end]] - - for {set lineNo 1} {[gets $fd line] >= 0} {incr lineNo} { - if {[string first $suffix $line] != 0} { - continue - } - set file [file join $prefix $line] - - if {[catch { file stat $file stat } result]} { - tclLog $result - - continue - } - if {![string compare $stat(type) file]} { - lappend folders [list [eval [list file join] \ - [lrange [file split $line] \ - 1 end]] \ - $stat(mtime)] - } - } - - catch {close $fd } - - switch -- $index { - recent { - set folders [lsort -integer -decreasing -index 1 $folders] - } - - default { - set folders [lsort -dictionary -increasing -index 0 $folders] - } - } - - puts stdout "HTTP/1.0 200 -Content-Type: text/html -Pragma: no-cache -Expires: $expires - -newsgroups -" - - foreach entry $folders { - set folder [lindex $entry 0] - set t [fmtclock [set mtime [lindex $entry 1]] "%m/%d %H:%M"] - - puts stdout "" - } - - puts stdout "
$t$folder
-" - - cleanup - } - - -# /news?folder="whatever" - - if {[catch { set arg(folder) } folder]} { - cleanup "page $request unavailable" 504 - } - - foreach p [file split $folder] { - if {(![string compare $p ""]) || ([string first . $p] >= 0)} { - cleanup "page $request unavailable" 504 - } - } - - set file [file join $options(foldersDirectory) $folder] - if {([catch { file type $file } type]) \ - || ([string compare $type file])} { - cleanup "page $request unavailable" 504 - } - if {[catch { mbox::initialize -file $file } mbox]} { - cleanup $mbox 505 - } - - -# /news?folder="whatever"&lastN="N" - - if {![catch { set arg(lastn) } lastN]} { - array set props [mbox::getproperty $mbox] - - if {$lastN < 0} { - set diff [expr -($lastN*86400)] - - set last 0 - for {set msgNo $props(last)} {$msgNo > 0} {incr msgNo -1} { - if {[catch { mbox::getmsgtoken $mbox $msgNo } mime]} { - tclLog $mime - - continue - } - - if {[catch { lindex [mime::getheader $mime Date] 0 } value]} { - set value "" - } - if {![catch { mime::parsedatetime $value rclock } rclock]} { - if {$rclock < $diff} { - if {$last == 0} { - set last $msgNo - } - set first $msgNo - } - if {$last == 0} { - break - } - } - } - if {$last > 0} { - set last $props(last) - } - } elseif {[set first \ - [expr [set last $props(last)]-($lastN+1)]] <= 0} { - set first 1 - } - - puts stdout "HTTP/1.0 200 -Content-Type: text/html -Pragma: no-cache -Expires: $expires - -$folder" - - if {$last == 0} { - puts stdout "Empty. -" - - cleanup - } - - puts stdout "" - for {set msgNo $last} {$msgNo >= $first} {incr msgNo -1} { - if {[catch { mbox::getmsgtoken $mbox $msgNo } mime]} { - tclLog $mime - - continue - } - - set date "" - catch { - set value [lindex [mime::getheader $mime Date] 0] - append date [format %02d \ - [mime::parsedatetime $value mon]] / \ - [format %02d [mime::parsedatetime $value mday]] " " \ - [format %02d [mime::parsedatetime $value hour]] : \ - [format %02d [mime::parsedatetime $value min]] - } - if {![string compare $date ""]} { - set date "unknown date" - } - - set from "" - catch { - set from [mutl::firstaddress [mime::getheader $mime From]] - - catch { unset aprops } - - array set aprops [lindex [mime::parseaddress $from] 0] - set from "$aprops(friendly)" - } - - set subject "" - catch { - set subject [lindex [mime::getheader $mime Subject] 0] - } - - puts stdout "" - } - puts stdout "
$date$from$subject
-" - - cleanup - } - - -# /news?folder="whatever"&msgNo="N" - - if {![catch { set arg(msgno) } msgNo]} { - if {[catch { mbox::getmsgtoken $mbox $msgNo } mime]} { - cleanup $mime 505 - } - - if {![string compare [set part [firstext $mime]] ""]} { - set part $mime - } - switch -- [set content [mime::getproperty $part content]] { - text/plain { - regsub -all "\n\n" [mime::getbody $part] "

" body - - set result "$folder $msgNo -$body" - - } - - text/html { - set result [mime::getbody $part] - } - - default { - set result "$folder $msgNo - -Message is $content. -" - } - } - - puts stdout "HTTP/1.0 200 -Content-Type: text/html - -$result" - - cleanup - } - - - cleanup "page $request unavailable" 504 - - -} result]} { - global errorCode errorInfo - - set ecode $errorCode - set einfo $errorInfo - - if {(![catch { info body tclLog } result2]) \ - && ([string compare [string trim $result2] \ - {catch {puts stderr $string}}])} { - catch { tclLog $result } - } - - if {![string first "POSIX EPIPE" $ecode]} { - exit 0 - } - - catch { - smtp::sendmessage \ - [mime::initialize \ - -canonical text/plain \ - -param {charset us-ascii} \ - -string "$result\n\nerrorCode: $ecode\n\n$einfo"] \ - -originator "" \ - -header [list From [id user]@[info hostname]] \ - -header [list To operator@[info hostname]] \ - -header [list Subject "[info hostname] fatal $program"] - } - - cleanup $result -} - - -exit 75 DELETED examples/mime/mbot/mbox.tcl Index: examples/mime/mbot/mbox.tcl ================================================================== --- examples/mime/mbot/mbox.tcl +++ /dev/null @@ -1,465 +0,0 @@ -# mbox.tcl - mailbox package -# -# (c) 1999 Marshall T. Rose -# Hold harmless the author, and any lawful use is allowed. -# - -# -# TODO: -# -# mbox::initialize -# add -pop server option -# add -imap server option -# along with -username, -password, and -passback -# -# mbox::getmsgproperty -# add support for deleted messages -# -# mbox::deletemsg token msgNo -# marks a message for deletion -# -# mbox::synchronize token ?-commit boolean? -# commits or rollllbacks changes - - -package provide mbox 1.0 - -package require mime 1.1 - - -# -# state variables: -# -# msgs: serialized array of messages, containing array of: -# msgNo, mime -# count: number of messages -# first: number of initial message -# last: number of final message -# value: either "file", or "directory" -# -# file: file containing mailbox -# fd: corresponding file descriptor -# fileA: serialized array of messages, containing array of: -# msgNo, offset, size -# -# directory: directory containing mailbox -# dirA: serialized array of messages, containing array of: -# msgNo, size -# - -namespace eval mbox { - variable mbox - array set mbox { uid 0 } - - namespace export initialize finalize getproperty \ - getmsgtoken getmsgproperty -} - - -proc mbox::initialize {args} { - global errorCode errorInfo - - variable mbox - - set token [namespace current]::[incr mbox(uid)] - - variable $token - upvar 0 $token state - - if {[set code [catch { eval [list mbox::initializeaux $token] $args } \ - result]]} { - set ecode $errorCode - set einfo $errorInfo - - catch { mbox::finalize $token -subordinates dynamic } - - return -code $code -errorinfo $einfo -errorcode $ecode $result - } - - return $token -} - - -proc mbox::initializeaux {token args} { - variable $token - upvar 0 $token state - - set state(msgs) "" - set state(count) 0 - set state(first) 0 - set state(last) 0 - - set argc [llength $args] - for {set argx 0} {$argx < $argc} {incr argx} { - set option [lindex $args $argx] - if {[incr argx] >= $argc} { - error "missing argument to $option" - } - set value [lindex $args $argx] - - switch -- $option { - -directory { - set state(directory) $value - } - - -file { - set state(file) $value - } - - default { - error "unknown option $option" - } - } - } - - set valueN 0 - foreach value [list directory file] { - if {[info exists state($value)]} { - set state(value) $value - incr valueN - } - } - if {$valueN != 1} { - error "specify exactly one of -directory, or -file" - } - - return [mbox::initialize_$state(value) $token] -} - - -proc mbox::initialize_file {token} { - variable $token - upvar 0 $token state - - fconfigure [set state(fd) [open $state(file) { RDONLY }]] \ - -translation binary - - array set fileA "" - set msgNo 0 - - if {[gets $state(fd) line] < 0} { - return $token - } - switch -regexp -- $line { - "^From " { - set format Mailx - set preB "From " - - set phase "" - } - - "\01\01\01\01" { - set format MMDF - set preB "\01\01\01\01" - set postB "\01\01\01\01" - - if {([gets $state(fd) line] >= 0) \ - && ([string first "From MAILER-DAEMON " $line] == 0)} { - set phase skip - } else { - set phase pre - } - } - - default { - error "unrecognized mailbox format" - } - } - seek $state(fd) 0 start - - while {[gets $state(fd) line] >= 0} { - switch -- $format/$phase { - Mailx/ { - if {[string first $preB $line] == 0} { - if {$msgNo > 0} { - set fileA($msgNo) [list msgNo $msgNo offset $offset \ - size $size] - } - - incr msgNo - set offset [tell $state(fd)] - set size 0 - } else { - incr size [expr [string length $line]+1] - } - } - - MMDF/pre { - if {![string compare $preB $line]} { - incr msgNo - set offset [tell $state(fd)] - set size 0 - - set phase post - } else { - error "invalid mailbox" - } - } - - MMDF/post { - if {![string compare $postB $line]} { - set fileA($msgNo) [list msgNo $msgNo offset $offset \ - size $size] - - set phase pre - } else { - incr size [expr [string length $line]+1] - } - } - - MMDF/skip { - if {![string compare $preB $line]} { - set phase skip2 - } - } - - MMDF/skip2 { - if {![string compare $postB $line]} { - set phase pre - } - } - } - } - - switch -- $format/$phase { - Mailx/ { - if {$msgNo > 0} { - set fileA($msgNo) [list msgNo $msgNo offset $offset \ - size $size] - } - } - - MMDF/post - - - MMDF/skip2 { - error "incomplete mailbox" - } - } - - set state(fileA) [array get fileA] - if {[set state(last) [set state(count) $msgNo]] > 0} { - set state(first) 1 - } - - return $token -} - - -proc mbox::initialize_directory {token} { - variable $token - upvar 0 $token state - - array set dirA "" - - set first 0 - set last 0 - foreach file [glob -nocomplain [file join $state(directory) *]] { - if {(![regexp {^[1-9][0-9]*$} [set msgNo [file tail $file]]]) \ - || ([catch { file size $file } size])} { - continue - } - - if {($first == 0) || ($msgNo < $first)} { - set first $msgNo - } - if {$last < $msgNo} { - set last $msgNo - } - - set dirA($msgNo) [list msgNo $msgNo size $size] - incr state(count) - } - - set state(dirA) [array get dirA] - if {[set state(last) $last] > 0} { - set state(first) $first - } - - return $token -} - -proc mbox::finalize {token args} { - variable $token - upvar 0 $token state - - array set options [list -subordinates dynamic] - array set options $args - - switch -- $options(-subordinates) { - all - - - dynamic { - array set msgs $state(msgs) - - for {set msgNo $state(first)} \ - {$msgNo <= $state(last)} \ - {incr msgNo} { - if {![catch { array set msg $msgs($msgNo) }]} { - eval [list mime::finalize $msg(mime)] $args - } - } - } - - none { - } - - default { - error "unknown value for -subordinates $options(-subordinates)" - } - } - - if {[info exists state(fd)]} { - catch { close $state(fd) } - } - - foreach name [array names state] { - unset state($name) - } - unset $token -} - - -proc mbox::getproperty {token {property ""}} { - variable $token - upvar 0 $token state - - switch -- $property { - "" { - return [list count $state(count) \ - first $state(first) \ - last $state(last) \ - messages [mbox::getmessages $token]] - } - - -names { - return [list count first last messages] - } - - count - - - first - - - last { - return $state($property) - } - - messages { - return [mbox::getmessages $token] - } - - default { - error "unknown property $property" - } - } -} - - -proc mbox::getmessages {token} { - variable $token - upvar 0 $token state - - switch -- $state(value) { - directory { - array set msgs $state(dirA) - } - - file { - array set msgs $state(fileA) - } - } - - return [lsort -integer [array names msgs]] -} - - -proc mbox::getmsgtoken {token msgNo} { - variable $token - upvar 0 $token state - - if {($msgNo < $state(first)) || ($msgNo > $state(last))} { - error "message number out of range: $state(first)..$state(last)" - } - - array set msgs $state(msgs) - if {![catch { array set msg $msgs($msgNo) }]} { - return $msg(mime) - } - - switch -- $state(value) { - directory { - set mime [mime::initialize \ - -file [file join $state(directory) $msgNo]] - } - - file { - array set fileA $state(fileA) - array set msg $fileA($msgNo) - set mime [mime::initialize -file $state(file) -root $token \ - -offset $msg(offset) -count $msg(size)] - } - } - - set msgs($msgNo) [list msgNo $msgNo mime $mime] - set state(msgs) [array get msgs] - - return $mime -} - - -proc mbox::getmsgproperty {token msgNo {property ""}} { - variable $token - upvar 0 $token state - - if {($msgNo < $state(first)) || ($msgNo > $state(last))} { - error "message number out of range: $state(first)..$state(last)" - } - - switch -- $state(value) { - directory { - array set dirA $state(dirA) - if {[catch { array set msg $dirA($msgNo) }]} { - error "message $msgNo doesn't exist" - } - } - - file { - array set fileA $state(fileA) - array set msg $fileA($msgNo) - } - } - - set props [list flags size uidl] - - switch -- $property { - "" { - array set properties "" - - foreach prop $props { - if {[info exists msg($prop)]} { - set properties($prop) $msg($prop) - } - } - - return [array get properties] - } - - -names { - set names "" - foreach prop $props { - if {[info exists msg($prop)]} { - lappend names $prop - } - } - - return $names - } - - default { - if {[lsearch -exact $props $property] < 0} { - error "unknown property $property" - } - - return $msg($property) - } - } -} DELETED examples/mime/mbot/mutl.tcl Index: examples/mime/mbot/mutl.tcl ================================================================== --- examples/mime/mbot/mutl.tcl +++ /dev/null @@ -1,123 +0,0 @@ -# mutl.tcl - messaging utilities -# -# (c) 1999 Marshall T. Rose -# Hold harmless the author, and any lawful use is allowed. -# - - -package provide mutl 1.0 - - -namespace eval mutl { - namespace export exclfile tmpfile \ - firstaddress gathertext getheader -} - - -proc mutl::exclfile {fileN {stayP 0}} { - global errorCode errorInfo - - for {set i 0} {$i < 10} {incr i} { - if {![catch { set xd [open $fileN { RDWR CREAT EXCL }] } result]} { - if {(![set code [catch { puts $xd [expr [pid]%65535] - flush $xd } result]]) \ - && (!$stayP)} { - if {![set code [catch { close $xd } result]]} { - set xd "" - } - } - - if {$code} { - set ecode $errorCode - set einfo $errorInfo - - catch { close $xd } - - file delete -- $fileN - - return -code $code -errorinfo $einfo -errorcode $ecode $result - } - - return $xd - } - set ecode $errorCode - set einfo $errorInfo - - if {(([llength $ecode] != 3) \ - || ([string compare [lindex $ecode 0] POSIX]) \ - || ([string compare [lindex $ecode 1] EEXIST]))} { - return -code 1 -errorinfo $einfo -errorcode $ecode $result - } - - after 1000 - } - - error "unable to exclusively open $fileN" -} - -proc mutl::tmpfile {prefix {tmpD ""}} { - global env - global errorCode errorInfo - - if {(![string compare $tmpD ""]) && ([catch { set tmpD $env(TMP) }])} { - set tmpD /tmp - } - set file [file join $tmpD $prefix] - - append file [expr [pid]%65535] - - for {set i 0} {$i < 10} {incr i} { - if {![set code [catch { set fd [open $file$i \ - { WRONLY CREAT EXCL }] } \ - result]]} { - return [list file $file$i fd $fd] - } - set ecode $errorCode - set einfo $errorInfo - - if {(([llength $ecode] != 3) \ - || ([string compare [lindex $ecode 0] POSIX]) \ - || ([string compare [lindex $ecode 1] EEXIST]))} { - return -code $code -errorinfo $einfo -errorcode $ecode $result - } - } - - error "unable to create temporary file" -} - -proc mutl::firstaddress {values} { - foreach value $values { - foreach addr [mime::parseaddress $value] { - catch { unset aprops } - array set aprops $addr - - if {[string compare $aprops(proper) ""]} { - return $aprops(proper) - } - } - } -} - -proc mutl::gathertext {token} { - array set props [mime::getproperty $token] - - set text "" - - if {[info exists props(parts)]} { - foreach part $props(parts) { - append text [mutl::gathertext $part] - } - } elseif {![string compare $props(content) text/plain]} { - set text [mime::getbody $token] - } - - return $text -} - -proc mutl::getheader {token key} { - if {[catch { mime::getheader $token $key } result]} { - set result "" - } - - return $result -} DELETED examples/mime/mbot/personal.tcl Index: examples/mime/mbot/personal.tcl ================================================================== --- examples/mime/mbot/personal.tcl +++ /dev/null @@ -1,984 +0,0 @@ -#!/bin/sh -# the next line restarts using tclsh \ -PATH=/usr/pkg/bin:/usr/local/bin:/usr/bin:/bin LD_LIBRARY_PATH=/usr/pkg/lib:/usr/local/lib:/usr/lib export PATH LD_LIBRARY_PATH; exec tclsh8.3 "$0" "$@" - - -# personal.tcl - process personal mail -# -# (c) 1999 Marshall T. Rose -# Hold harmless the author, and any lawful use is allowed. -# -# The original version was written in 1994! -# - - -global options - - -# begin of routines that may be redefined in configFile - -proc impersonalMail {originator} {} - -proc adminP {local domain} { - set local [string tolower $local] - - foreach lhs [list administrator \ - archive-server \ - daemon \ - failrepter \ - faxmaster \ - gateway \ - listmaster \ - listproc \ - lotus_mail_exchange \ - m400 \ - *mailer* \ - *maiser* \ - mmdf \ - mrgate \ - mx-mailer-daemon \ - numbers-info-forw \ - postman* \ - *postmast* \ - pp \ - smtp \ - sysadmin \ - ucx_smtp \ - uucp] { - if {[string match $lhs $local]} { - return 1 - } - } - - return 0 -} - -proc friendP {local domain} { - global options - - if {![info exists options(friendlyDomains)]} { - return 0 - } - - set domain [string tolower $domain] - - foreach rhs $options(friendlyDomains) { - if {(![string compare $rhs $domain]) \ - || ([string match *.$rhs $domain])} { - return 1 - } - } - - return 0 -} - -proc ownerP {local domain} { - global options - - foreach mailbox {myMailbox pdaMailboxes remoteMailboxes} { - if {![info exists options($mailbox)]} { - continue - } - - foreach addr [mime::parseaddress $options($mailbox)] { - catch { unset aprops } - - array set aprops $addr - if {![string compare [string tolower $local@$domain] \ - [string tolower $aprops(local)@$aprops(domain)]]} { - return 1 - } - } - } - - return 0 -} - -# the algorithm below is for systems that use the MMDF/MH convention - -proc saveMessage {inF {outF ""}} { - global errorCode errorInfo - global options - - set inC [open $inF { RDONLY }] - - if {![string compare $outF ""]} { - set outF $options(defaultMaildrop) - } - mutl::exclfile [set lockF $outF.lock] - - set code [catch { set outC [open $outF { WRONLY CREAT APPEND }] } result] - set ecode $errorCode - set einfo $errorInfo - - if {!$code} { - set code [catch { - puts $outC [set boundary "\001\001\001\001"] - puts $outC "Delivery-Date: [mime::parsedatetime -now proper]" - - while {[gets $inC line] >= 0} { - if {[string compare $boundary $line]} { - puts $outC $line - } else { - puts $outC "\002\001\001\001" - } - } - - puts $outC $boundary - } result] - set ecode $errorCode - set einfo $errorInfo - - if {[catch { close $outC } result2]} { - tclLog $result2 - } - } - - file delete -- $lockF - - if {[catch { close $inC } result2]} { - tclLog $result2 - } - - return -code $code -errorinfo $einfo -errorcode $ecode $result -} - -proc findPhrase {subject} { - global options - - set subject [string toupper $subject] - - foreach file [glob -nocomplain [file join $options(dataDirectory) \ - phrases *]] { - if {[catch { otp_words -mode encode \ - [base64 -mode decode -- \ - [join [split [file tail $file] _] /]] } \ - phrase]} { - tclLog "$file: $phrase" - } elseif {[string first $phrase $subject] >= 0} { - if {[catch { file delete -- $file } result]} { - tclLog $result - } - - return 1 - } - } - - return 0 -} - -proc makePhrase {} { - global options - - if {![file isdirectory \ - [set phraseD [file join $options(dataDirectory) phrases]]]} { - file mkdir $phraseD - } else { - pruneDir $phraseD phrase - } - - set key [mime::uniqueID] - set seqno 8 - while {[incr seqno -1] >= 0} { - set key [otp_md5 -- $key] - } - - set phraseF [file join $phraseD \ - [join [split [string trim \ - [base64 -mode encode -- $key]] /] _]] - if {[catch { close [open $phraseF { WRONLY CREAT TRUNC }] } result]} { - tclLog $result - } - - return [otp_words -mode encode -- $key] -} - -proc pruneDir {dir type} { - switch -- $type { - addr { - set days 14 - } - - msgid { - set days 28 - } - - phrase { - set days 7 - } - } - - set then [expr [clock seconds]-($days*86400)] - - foreach file [glob -nocomplain [file join $dir *]] { - if {(![catch { file mtime $file } result]) \ - && ($result < $then) \ - && ([catch { file delete -- $file } result])} { - tclLog $result - } - } -} - -proc tclLog {message} { - global options - - if {([info exists options(debugP)]) && ($options(debugP) > 0)} { - puts stderr $message - } - - if {([string first "DEBUG " $message] == 0) \ - || ([catch { set fd [open $options(logFile) \ - { WRONLY CREAT APPEND }] }])} { - return - } - - regsub -all "\n" $message " " message - - catch { puts -nonewline $fd \ - [format "%s %-8.8s %06d %s\n" \ - [clock format [clock seconds] -format "%m/%d %T"] \ - personal [expr [pid]%65535] $message] } - - catch { close $fd } -} - -# end of routines that may be redefined in configFile - - -global deleteFiles - -set deleteFiles {} - -proc cleanup {{message ""} {status 75}} { - global deleteFiles - - foreach file $deleteFiles { - if {[catch { file delete -- $file } result]} { - tclLog $result - } - } - - if {[string compare $message ""]} { - tclLog $message - exit $status - } - - exit 0 -} - -proc dofolder {folder inF} { - global options - - catch { unset aprops } - - array set aprops [lindex [mime::parseaddress $folder] 0] - set folder [join [split $aprops(local) /] _] - - if {[set folderN [llength [set folderL [split $folder .]]]] <= 1} { - cleanup "invalid folder: $folder" - } - - foreach f $folderL { - if {![string compare $f ""]} { - cleanup "invalid folder: $folder" 67 - } - } - - if {![file isdirectory \ - [set articleD [eval [list file join \ - $options(foldersDirectory)] \ - [lrange $folderL 0 \ - [expr $folderN-2]]]]]} { - file mkdir $articleD - } - if {![file exists [set articleF [file join $articleD \ - [lindex $folderL \ - [expr $folderN-1]]]]]} { - set newP 1 - } else { - set newP 0 - } - - set fd [open $options(foldersFile) { RDWR CREAT }] - set fl "\n[read $fd]" - - set dir [lindex [file split $options(foldersDirectory)] end] - if {[string first "\n$dir\n" $fl] < 0} { - puts $fd $dir - } - foreach f $folderL { - set dir [file join $dir $f] - if {[string first "\n$dir\n" $fl] < 0} { - puts $fd $dir - } - } - - close $fd - - if {[catch { saveMessage $inF $articleF } result]} { - cleanup "unable to save message in $articleF: $result" - } - - if {($newP) && ([info exists options(announceMailboxes)])} { - if {[catch { smtp::sendmessage \ - [mime::initialize \ - -canonical text/plain \ - -param {charset us-ascii} \ - -string ""] \ - -atleastone true \ - -originator "" \ - -header [list From $options(myMailbox)] \ - -header [list To $options(announceMailboxes)] \ - -header [list Subject "new folder $folder"] } \ - result]} { - tclLog $result - } - } -} - -proc alladdrs {mime keys} { - set result {} - - foreach key $keys { - foreach value [mutl::getheader $mime $key] { - foreach addr [mime::parseaddress $value] { - lappend result $addr - } - } - } - - return $result -} - -proc anyfriend {outD addrs} { - global options - - if {!$options(friendlyFire)} { - return "" - } - - foreach addr $addrs { - catch { unset aprops } - - array set aprops $addr - if {[catch { string tolower $aprops(local)@$aprops(domain) } \ - recipient]} { - continue - } - - if {[ownerP $aprops(local) $aprops(domain)]} { - tclLog "DEBUG: skipping $recipient" - continue - } - - set outF [file join $outD [join [split $recipient /] _]] - if {[file exists $outF]} { - return $recipient - } - - tclLog "DEBUG: unknown recipient $recipient" - } - - return "" -} - - -if {[catch { - - set program personal - - package require mutl 1.0 - package require smtp 1.1 - package require Tclx 8.0 - - -# parse arguments and initialize environment - - set program [file tail [file rootname $argv0]] - - set configFile .${program}-config.tcl - - set debugP 0 - - set messageFile - - - set originatorAddress "" - - set userName "" - - for {set argx 0} {$argx < $argc} {incr argx} { - set option [lindex $argv $argx] - if {[incr argx] >= $argc} { - cleanup "missing argument to $option" - } - set value [lindex $argv $argx] - - switch -- $option { - -config { - set configFile $value - } - - -debug { - set options(debugP) [set debugP [smtp::boolean $value]] - } - - -file { - set messageFile $value - } - - -originator { - set originatorAddress $value - } - - -user { - set userName $value - } - - default { - cleanup "unknown option $option" - } - } - } - - if {![string compare $messageFile -]} { - array set tmp [mutl::tmpfile personal] - - lappend deleteFiles [set messageFile $tmp(file)] - - catch { file attributes $messageFile -permissions 0600 } - - if {[gets stdin line] <= 0} { - cleanup "empty message" - } - if {[string first "From " $line] == 0} { - if {![string compare $originatorAddress ""]} { - set line [string range $line 5 end] - if {[set x [string first " " $line]] > 0} { - set originatorAddress [string range $line 0 [expr $x-1]] - } - } - } else { - puts $tmp(fd) $line - } - fcopy stdin $tmp(fd) - close $tmp(fd) - } - - if {[string compare $userName ""]} { - if {[catch { id convert user $userName }]} { - cleanup "userName doesn't exist: $userName" - } - if {([catch { file isdirectory ~$userName } result]) \ - || (!$result)} { - cleanup "userName doesn't have a home directory: $userName" - } - - umask 0077 - cd ~$userName - } - - if {![file exists $configFile]} { - cleanup "configFile file doesn't exist: $configFile" - } - source $configFile - - set options(debugP) $debugP - - foreach {k v} [array get options] { - if {![string compare $v ""]} { - unset options($k) - } - } - - foreach k [list dataDirectory defaultMaildrop] { - if {![info exists options($k)]} { - cleanup "configFile didn't define $k: $configFile" - } - } - - if {![file isdirectory $options(dataDirectory)]} { - file mkdir $options(dataDirectory) - } - - if {![info exists options(myMailbox)]} { - set options(myMailbox) [id user] - } - - if {![info exists options(friendlyFire)]} { - set options(friendlyFire) 0 - } - - -# crack the message - - if {[catch { set mime [mime::initialize -file $messageFile] } result]} { -# global errorCode errorInfo -# -# set ecode $errorCode -# set einfo $errorInfo -# -# if {![catch { -# smtp::sendmessage \ -# [mime::initialize \ -# -canonical multipart/mixed \ -# -parts [list [mime::initialize \ -# -canonical text/plain \ -# -param {charset us-ascii} \ -# -string "$result\n\nerrorCode: $ecode\n\n$einfo"] \ -# [mime::initialize \ -# -canonical application/octet-stream \ -# -file $messageFile]]] \ -# -originator "" \ -# -header [list From $options(myMailbox)] \ -# -header [list To $options(myMailbox)] \ -# -header [list Subject "[info hostname] alert $program"] -# }]} { -# set result "" -# } - - if {[info exists options(auditInFile)]} { - saveMessage $messageFile $options(auditInFile) - tclLog "invalid, but saved: $result" - cleanup - } - - cleanup "re-queued: $result" - } - - set origProper "" - foreach key {From Sender Return-Path} { - if {[string compare \ - [set origProper [mutl::firstaddress \ - [mutl::getheader $mime $key]]] \ - ""]} { - break - } - } - if {![string compare $origProper ""]} { - set origProper [mutl::firstaddress [list $originatorAddress]] - } - - catch { unset aprops } - - array set aprops [list local "" domain ""] - array set aprops [lindex [mime::parseaddress $origProper] 0] - set origLocal $aprops(local) - set origDomain $aprops(domain) - - regsub -all " *" \ - [set subject [string trim \ - [lindex [mutl::getheader $mime Subject] 0]]] \ - " " subject - - - if {[catch { set folderTarget [impersonalMail $origLocal@$origDomain] }]} { - set folderTarget "" - } - if {[set impersonalP [string compare $folderTarget ""]]} { - if {![info exists options(foldersDirectory)]} { - cleanup "configFile didn't define folderTarget: $configFile" - } - } elseif {[info exists options(auditInFile)]} { -# keep an audit copy of personal mail - - saveMessage $messageFile $options(auditInFile) - } - - -# perform duplicate supression - - set messageID [lindex [concat [mutl::getheader $mime Resent-Message-ID] \ - [mutl::getheader $mime Message-ID]] 0] - if {[string compare $messageID ""]} { - if {![file isdirectory \ - [set idD [file join $options(dataDirectory) msgids]]]} { - file mkdir $idD - } else { - pruneDir $idD msgid - } - - if {[set len [string length $messageID]] > 2} { - set messageID [string range $messageID 1 [expr $len-2]] - } - if {$impersonalP} { - set prefix X- - - catch { unset aprops } - - array set aprops [lindex [mime::parseaddress $folderTarget] 0] - set prefix \ - X-[lindex [split [join [split $aprops(local) /] _] .] 0]- - } else { - set prefix "" - } - - set idF [file join $idD $prefix[join [split $messageID /] _]] - if {[file exists $idF]} { - tclLog "duplicate ID: $origProper $messageID ($subject)" - - cleanup - } - - if {[catch { close [open $idF { WRONLY CREAT TRUNC }] } result]} { - tclLog $result - } - } - - -# record information about the originator - - if {![string compare \ - [set origAddress \ - [string tolower $origLocal@$origDomain]] \ - @]} { - tclLog "no originator" - - if {!$impersonalP} { - saveMessage $messageFile - } - - cleanup - } - - tclLog "DEBUG processing: $origProper <$messageID> ($subject)" - - if {![file isdirectory \ - [set inD [file join $options(dataDirectory) inaddrs]]]} { - file mkdir $inD - } - - set inF [file join $inD [join [split $origAddress /] _]] - if {[catch { set fd [open $inF { WRONLY CREAT TRUNC }] } result]} { - tclLog $result - } else { - catch { puts $fd $origProper } - if {[catch { close $fd } result]} { - tclLog $result - } - } - - -# store impersonal mail in private folder area - - if {$impersonalP} { - if {![string compare $messageID ""]} { - cleanup "no Message-ID" - } - - if {![file isdirectory $options(foldersDirectory)]} { - file mkdir $foldersDirectory - } - - array set mapping {} - - if {![catch { set fd [open $options(mappingFile) { RDONLY }] }]} { - while {[gets $fd line] >= 0} { - if {([llength [set map [split $line :]]] == 2) \ - && ([string length \ - [set k [string trim [lindex $map 0]]]] \ - > 0) \ - && ([string length \ - [set v [string trim [lindex $map 1]]]] \ - > 0)} { - set mapping($k) $v - } - } - - if {[catch { close $fd } result]} { - tclLog $result - } - } - - if {![info exists mapping($folderTarget)]} { - set mapping($folderTarget) store - } - if {![string compare $mapping($folderTarget) process]} { - catch { set mapping($folderTarget) \ - [processFolder $folderTarget $mime] } - } - switch -- $mapping($folderTarget) { - store { - dofolder $folderTarget $messageFile - } - - ignore { - tclLog "ignoring message for $folderTarget" - } - - bounce { - cleanup "rejecting message for $folderTarget" 67 - } - - default { - if {[catch { smtp::sendmessage $mime \ - -atleastone true \ - -originator "" \ - -recipients $mapping($folderTarget) } \ - result]} { - tclLog $result - } - } - } - - cleanup - } - - -# perform originator supression and guest list maintenance - - if {[string compare \ - [set resentProper \ - [mutl::firstaddress \ - [mutl::getheader $mime Resent-From]]] \ - ""]} { - catch { unset aprops } - - array set aprops [lindex [mime::parseaddress $resentProper] 0] - set resentLocal $aprops(local) - set resentDomain $aprops(domain) - - if {[string compare \ - [set resentAddress \ - [string tolower $resentLocal@$resentDomain]] \ - @]} { - foreach p {Proper Local Domain Address} { - set orig$p [set resent$p] - } - } - } - - foreach p {out tmp bad} { - if {![file isdirectory [set ${p}D [file join $options(dataDirectory) \ - ${p}addrs]]]} { - file mkdir [set ${p}D] - } - - set ${p}F [file join [set ${p}D] [join [split $origAddress /] _]] - } - - pruneDir $tmpD addr - - -# deal with Klez-inspired nonsense - if {([info exists options(dropNames)]) && ([catch { - foreach part [mime::getproperty $mime parts] { - catch { unset params } - array set params [mime::getproperty $part params] - if {[info exists params(name)]} { - foreach name $options(dropNames) { - if {[string match $name $params(name)]} { - tclLog "rejecting: $origProper <$messageID> ($subject) $params(name)" - cleanup - } - } - } - } - } result])} { - tclLog "Klez-check: $result" - } - - set friend "" - if {[adminP $origLocal $origDomain]} { - tclLog "DEBUG admin check: $origProper <$messageID> ($subject)" - -# if DSNs were the rule, it would make sense to parse it... no such luck - - set fd [open $messageFile { RDONLY }] - set text [read $fd] - if {[catch { close $fd } result]} { - tclLog $result - } - - foreach file [glob -nocomplain [file join $badD *]] { - set addr [file tail $file] - if {([string match *$addr* $text]) \ - || (([set x [string first @ $addr]] > 0) \ - && ([string match \ - *[string range $addr 0 [expr $x-1]]* \ - $text]))} { - tclLog "failure notice: $origProper ($addr)" - - cleanup - } - } - - tclLog "DEBUG admin continue: $origProper <$messageID> ($subject)" - } elseif {(![ownerP $origLocal $origDomain]) \ - && (![friendP $origLocal $origDomain]) \ - && (![file exists $outF]) \ - && (![file exists $tmpF]) \ - && (![string compare ""\ - [set friend [anyfriend $outD \ - [alladdrs $mime {To cc}]]]]) \ - && (![findPhrase $subject]) \ - && ([info exists options(noticeFile)])} { - if {[file exists $badF]} { - catch { file delete -- $badF } - } elseif {[catch { - set fd [open $options(noticeFile) { RDONLY }] - set text [read $fd] - if {[catch { close $fd } result]} { - tclLog $result - } - - regsub -all %passPhrase% $text [makePhrase] text - for {set rsubject $subject} \ - {[regexp -nocase ^re: $rsubject]} \ - {set rsubject [string trimleft \ - [string range $rsubject 3 end]]} { - } - regsub -all %subject% $text $rsubject text - - smtp::sendmessage \ - [mime::initialize \ - -canonical multipart/mixed \ - -parts [list [mime::initialize \ - -canonical text/plain \ - -param {charset us-ascii} \ - -string $text] \ - [mime::initialize \ - -canonical message/rfc822 \ - -parts [list $mime]]]] \ - -originator "" \ - -header [list From $options(myMailbox)] \ - -header [list To $origProper] \ - -header [list Subject "Re: $rsubject"] - - set fd [open $badF { WRONLY CREAT TRUNC }] - } result]} { - tclLog $result - } else { - catch { puts $fd $origProper } - if {[catch { close $fd } result]} { - tclLog $result - } - } - tclLog "rejecting: $origProper <$messageID> ($subject)" - - cleanup - } elseif {[string compare $friend ""]} { - tclLog "accepting: $origProper because of $friend" - } else { - if {[ownerP $origLocal $origDomain]} { - set addrD $outD - } else { - set addrD $tmpD - } - - foreach addr [alladdrs $mime \ - {From To cc Resent-From Resent-To Resent-cc}] { - catch { unset aprops } - - array set aprops $addr - set addrLocal $aprops(local) - set addrDomain $aprops(domain) - - if {[string compare \ - [set addrAddress \ - [string tolower $addrLocal@$addrDomain]] @]} { - set addrF [file join $addrD [join [split $addrAddress /] _]] - - if {[file exists $addrF]} { - continue - } - - if {[catch { set fd [open $addrF { WRONLY CREAT TRUNC }] } \ - result]} { - tclLog $result - } else { - catch { puts $fd $aprops(proper) } - if {[catch { close $fd } result]} { - tclLog $result - } - } - } - } - } - - -# perform final actions, if we're the originator - - if {[ownerP $origLocal $origDomain]} { - if {[info exists options(auditOutFile)]} { - saveMessage $messageFile $options(auditOutFile) - } - - cleanup - } - - -# send a copy to the pda - - if {([info exists options(pdaMailboxes)]) \ - && ([string compare [set text [mutl::gathertext $mime]] ""])} { - if {[info exists options(pdaMailsize)]} { - set text [string range $text 0 [expr $options(pdaMailsize)-1]] - } - set pda [mime::initialize \ - -canonical text/plain \ - -param {charset us-ascii} \ - -string $text] - - foreach key {From To cc Subject Date Reply-To} { - foreach value [mutl::getheader $mime $key] { - mime::setheader $pda $key $value -mode append - } - } - - if {[catch { smtp::sendmessage $pda \ - -atleastone true \ - -originator "" \ - -recipients $options(pdaMailboxes) } result]} { - tclLog $result - } - } - - -# send a copy to the remote mailbox - - if {[info exists options(remoteMailboxes)]} { - if {[catch { smtp::sendmessage $mime \ - -atleastone true \ - -originator "" \ - -recipients $options(remoteMailboxes) } result]} { - tclLog $result - } else { - cleanup - } - } - - saveMessage $messageFile - - - cleanup - - -} result]} { - global errorCode errorInfo - - set ecode $errorCode - set einfo $errorInfo - - if {(![catch { info body tclLog } result2]) \ - && ([string compare [string trim $result2] \ - {catch {puts stderr $string}}])} { - catch { tclLog $result } - } - - catch { - smtp::sendmessage \ - [mime::initialize \ - -canonical text/plain \ - -param {charset us-ascii} \ - -string "$result\n\nerrorCode: $ecode\n\n$einfo"] \ - -originator "" \ - -header [list From [id user]@[info hostname]] \ - -header [list To operator@[info hostname]] \ - -header [list Subject "[info hostname] fatal $program"] - } - - cleanup $result -} - - -exit 75 DELETED examples/mime/mbot/pkgIndex.tcl Index: examples/mime/mbot/pkgIndex.tcl ================================================================== --- examples/mime/mbot/pkgIndex.tcl +++ /dev/null @@ -1,2 +0,0 @@ -package ifneeded mutl 1.0 [list source [file join $dir mutl.tcl]] -package ifneeded mbox 1.0 [list source [file join $dir mbox.tcl]] DELETED examples/nntp/README Index: examples/nntp/README ================================================================== --- examples/nntp/README +++ /dev/null @@ -1,41 +0,0 @@ -This directory contains examples making use of the nntp module -provided by tcllib. - -The file 'nntp.examples' provides a number of very small examples on -how to use the nntp module. - -Beyond that there is currently only one application is available, -'postnews'. This application is a drop-in replacement of the 'postit' -application which came with my [1] Debian/Linux system. I wrote it -because 'postit' was unable to post articles to the host 'news' aka -'shawnews', i.e. the NNTP system provided by my new ISP here in -Vancouver. I had no big desire to look into the C code of 'postit' to -find out why it was unable to post, wrote a hack version of 'postnews' -in 15 minutes and when that worked my desire to debug 'postit' went -below zero. Another half an hour was spent the next evening with -'postnews' to polish it and make it a nice example for 'tcllib'. - -Synopsis: - - postit articlelist newsserver - -articlelist is a file in /outgoing containing a list of all -articles to push to the newsserver. It contains one line per article -to push. Each line consists of two fields, the path to the file -containing the article itself and the message id of the article. The -fields are separated by whitespace. The aformentioned path is relative -to . - -The knowledge that articlelist = /outgoing/ holds -is essential to allow 'postnews' to compute the location of the - without a third argument. - -The application carefully checks that the articlelist exists, is a -file and is readable. It also checks each articlefile in the same -manner. Only articles which are not known to the server are -posted. This check uses the message id in the articlelist, i.e. it -does not have to read the articlefile to determine this information. - - -------------------------------------------------------------- -[1] Andreas Kupries DELETED examples/nntp/nntp.examples Index: examples/nntp/nntp.examples ================================================================== --- examples/nntp/nntp.examples +++ /dev/null @@ -1,76 +0,0 @@ - -All commands require a 'package require nntp' - -1. Connecting to default news server - - nntp::nntp - -2. Connecting to non-default news server at non-default port - - nntp::nntp nntpserver.example.net 110 - -3. Connection to default nntp server and getting a list of newsgroups. - - # It might take awhile to print all the newsgroups - set connection [nntp::nntp] - set newsgroups [list ] - foreach newsgroup [$connection list] { - lappend newsgroups [lindex $newsgroup 0] - } - puts [join $newsgroups ", "] - -4. Get basic information about a newsgroup - - set connection [nntp::nntp] - foreach {total first last group} [$connection group comp.lang.tcl] { - break - } - puts " newsgroup: $group\n message count: $total\n first message: $first\n\ - last message: $last" - -5. Get your daily dose of c.l.t. from a tcl prompt - - set connection [nntp::nntp] - $connection group comp.lang.tcl - puts [join [$connection article] \n] - - # Repeat this until there are no more messages to read: - $connection next - puts [join [$connection article] \n] - -6. Get the number, who sent the message, and the subjects of the first - 10 messages in c.l.t - - set connection [nntp::nntp] - $connection group comp.lang.tcl - set messageList [list ] - - foreach {total first last group} [$connection group comp.lang.tcl] { - break - } - - # Since we only want to see the first 10 messages, set last to $first + 10 - set last [expr {$first + 10}] - set subjectList [$connection xhdr subject "$first-$last"] - set fromList [$connection xhdr from "$first-$last"] - - foreach subject $subjectList from $fromList { - if {([regexp {(\d+)\s+([^\s].*)} $from match number from] > 0) && - ([regexp {\d+\s+([^\s].*)} $subject match subject] > 0)} { - lappend messageList "$number\t$from\t$subject" - } - } - - puts [join $messageList \n] - -7. Search for all messages written by Jeff Hobbs in c.l.t - - - set connection [nntp::nntp] - $connection group comp.lang.tcl - - foreach {total first last group} [$connection group comp.lang.tcl] { - break - } - - $connection xpat from $first-$last "*Jeffrey Hobbs*" DELETED examples/nntp/postnews Index: examples/nntp/postnews ================================================================== --- examples/nntp/postnews +++ /dev/null @@ -1,145 +0,0 @@ -#!/usr/local/bin/tclsh -# -*- tcl -*- -# -# This application is like 'postit', but written in tcl. -# The only package used is 'nntp' from 'tcllib'. -# -# Takes two arguments: -# 1) The path to the file listing the articles to push -# into the NNTP network -# 2) The name of the newsserver to push the articles to. -# -# The path to the spool directory is 1 level above the -# article file. - -# Check number of arguments - -if {[llength $argv] != 2} { - puts stderr "$argv0: wrong # args, should be \"$argv0 articles newsserver\"" - exit 1 -} - -# Retrieve arguments - -set articlefile [lindex $argv 0] -set newsserver [lindex $argv 1] - -# Validate file - -if {![file exists $articlefile]} { - puts stderr "$argv0: $articlefile does not exist" - exit 1 -} -if {[file isdirectory $articlefile]} { - puts stderr "$argv0: $articlefile is not a file" - exit 1 -} -if {![file readable $articlefile]} { - puts stderr "$argv0: $articlefile is not readable" - exit 1 -} - -# Get path and article information - -set spoolpath [file dirname [file dirname [file join [pwd] $articlefile]]] -set articles [split [read [set fh [open $articlefile r]]][close $fh] \n] - -puts "spooling from $spoolpath" - -# Now we are ready to deal with the newsserver - -package require nntp ; # from tcllib - -proc nntp_cmd {exit title cmd {oktitle {}}} { - global argv0 - - puts -nonewline stdout $title - flush stdout - if {[catch { - set res [uplevel 1 $cmd] - } msg]} { - puts stdout " error: $msg" - #puts stderr "$argv0: nntp error: $msg" - if {$exit} { - exit 1 - } - return 0 - } else { - if {$oktitle != {}} { - puts stdout " $res $oktitle" - } else { - puts stdout " $res" - } - return 1 - } -} - -# Introduce us to the server - -nntp_cmd 1 {open } {set news [nntp::nntp $newsserver]} -nntp_cmd 1 {mode reader} {$news mode_reader} - -# Iterate over all articles in the file. - -set lastgroup {} - -foreach article $articles { - set article [string trim $article] - if {$article == {}} {continue} - - foreach {msgfile id} [split $article] {break} - - # We have to validate the message files too. - # Invalid files are skipped. - - set msgpath [file join $spoolpath $msgfile] - - if {![file exists $msgpath]} { - puts stderr "article error: $msgfile does not exist" - continue - } - if {[file isdirectory $msgpath]} { - puts stderr "article error: $msgfile is not a file" - continue - } - if {![file readable $msgpath]} { - puts stderr "article error: $msgfile is not readable" - continue - } - - set group [join [file split [file dirname $msgfile]] .] - - if {[string compare $group $lastgroup] != 0} { - - if {![nntp_cmd 0 {set group } {$news group $group}]} { - # Group does not exist or other error. - # Skip the article, can't post it. - continue - } - - set lastgroup $group - } - - # Group of the message is current, the message file itself is valid. - # Proceed and check for existence of the article on the server. - # mode reader - if {[nntp_cmd 0 {stat } {$news stat $id} {article is present, skip}]} { - continue - } - - #continue - - if {[catch { - set msg [read [set fh [open $msgpath r]]][close $fh] - }]} { - puts stderr "article error: $msgfile was deleted between check and actual posting" - continue - } - - puts stdout "post [llength [split $msg \n]] lines $id" - - nntp_cmd 0 {post } {$news post $msg} -} - -nntp_cmd 1 {quit } {$news quit} -exit DELETED examples/ntp/rdate.tcl Index: examples/ntp/rdate.tcl ================================================================== --- examples/ntp/rdate.tcl +++ /dev/null @@ -1,92 +0,0 @@ -# rdate.tcl - Copyright (C) 2003 Pat Thoyts -# -# NAME -# rdate - set the system's date from a remote host -# -# SYNOPSIS -# rdate [-psa] [-ut] host -# -# DESCRIPTION -# Rdate displays and sets the local date and time from the host name or ad- -# dress given as the argument. It uses the RFC868 protocol which is usually -# implemented as a built-in service of inetd(8). -# -# Available options: -# -# -p Do not set, just print the remote time -# -## -s Do not print the time. -## -## -a Use the adjtime(2) call to gradually skew the local time to the -## remote time rather than just hopping. -# -# -u Use UDP -# -# -t Use TCP -# -# ------------------------------------------------------------------------- -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# ------------------------------------------------------------------------- -# -# $Id: rdate.tcl,v 1.1 2003/03/17 23:34:58 patthoyts Exp $ - -package require time; # tcllib 1.4 - -proc rdate {args} { - # process the command line options. - array set opts {-p 0 -s 0 -a 0 -t 0 -u x} - while {[string match -* [set option [lindex $args 0]]]} { - switch -exact -- $option { - -p { set opts(-p) 1 } - -u { set opts(-t) 0 } - -t { set opts(-t) 1 } - -s { return -code error "not implemented: use rdate(8)" } - -a { return -code error "not implemented: use rdate(8)" } - -- { ::time::Pop args; break } - default { - set err [join [lsort [array names opts -*]] ", "] - return -code error "bad option $option: must be $err" - } - } - ::time::Pop args - } - - # Check that we have a host to talk to. - if {[llength $args] != 1} { - return -code error "wrong \# args: " - } - set host [lindex $args 0] - - # Construct the time command - optionally force the protocol to tcp - set cmd ::time::gettime - if {$opts(-t)} { - lappend cmd -protocol tcp - } - lappend cmd $host - - # Perform the RFC 868 query (synchronously) - set tok [eval $cmd] - - # Check for errors or extract the time in the unix epoch. - set t 0 - if {[::time::status $tok] == "ok"} { - set t [::time::unixtime $tok] - ::time::cleanup $tok - } else { - set msg [::time::error $tok] - ::time::cleanup $tok - return -code error $msg - } - - # Display the time. - if {$opts(-p)} { - puts [clock format $t] - } - - return -} - -if {! $tcl_interactive} { - eval rdate $argv -} DELETED examples/oreilly-oscon2001/README Index: examples/oreilly-oscon2001/README ================================================================== --- examples/oreilly-oscon2001/README +++ /dev/null @@ -1,37 +0,0 @@ -Example application using tcllib modules. -========================================= - -This application (oscon) extracts session, track and talk information -from the O'Reilly OSCON webpages, collates them and writes some global -reports. It uses the tcllib modules "htmlparse", "struct" ("matrix", -"tree"), "csv", "report" and "log". - -It is called as - - oscon ... - -reads the provided HTML files containing the webpages to process and -then produces the six files - - .main.csv All talks with time, location, track - information, as CSV file. - .main.txt As above, ASCII report - .main.html As above, as HTML table - - .sched.csv Track information, sorted by day and - start time, as CSV file - .sched.txt As above, ASCII report - .sched.html As above, as HTML table - -Adding other reports (like room usage, east/west usage, ...) should be -rather easy. - -If "a2ps" is available the script will additionally generate .ps files -out of the .txt files. - ----------------------------------------------------------------- - -*Note*: The webpages used to develop this application are provided -here too to allow a successful operation of the example even if the -actual webpages at O'Reilly changed their format or are not available -anymore. DELETED examples/oreilly-oscon2001/oscon Index: examples/oreilly-oscon2001/oscon ================================================================== --- examples/oreilly-oscon2001/oscon +++ /dev/null @@ -1,494 +0,0 @@ -#!/bin/sh -# use -*- tcl -*- \ -exec tclsh "$0" "$@" -# Extract and report oscon schedule - -package require struct -package require csv -package require report -package require htmlparse -package require textutil -package require log - -# Restrict logging to levels 'info' and higher. -log::lvSuppressLE debug - -# 1. CSV structure filled by the parser = main data table -# ---------------------------------------------------- -# Day Time/Start Time/End Track Tower Room Speaker Title -# -# Matrices: "dmain" and "dmainr" -# -# Difference: dmainr contains gratituous newlines in the -# speaker column which make for a better TXT report (less -# wide). -# -# This is also report 'main'. -# -# 2. Schedule report to see conflicts, CSV structure -# ---------------------------------------------- -# Day Time Location-Columns, one per Room -# (15min granularity) (Content: Speaker + Topic) -# -# Matrices: "sched" and "schedr". Difference as for dmain(r) -# and the location columns -# -# This will be report 'sched'. - -proc main {} { - global pfx argv - - set pfx [lindex $argv 0] - set files [lrange $argv 1 end] - - if {($pfx == {}) || ([llength $files] == 0)} { - usage - exit -1 - } - - initialize - foreach f $files { - log::log info "Scanning \"$f\" ..." - parse $f - } - gen_schedule - dump_main - dump_schedule - postscript - return -} - -proc usage {} { - global argv0 - puts "usage: $argv0 prefix file..." -} - - -proc initialize {} { - global rooms tracks - ::struct::matrix::matrix dmain ; # data 1 - ::struct::matrix::matrix dmainr ; # data 1r - ::struct::matrix::matrix sched ; # data 2 - ::struct::matrix::matrix schedr ; # data 2r - array set rooms {} - array set tracks {} - dmain add columns 8 - dmain add row {Day Start End Track Tower Room Speaker Title} - dmainr add columns 8 - dmainr add row {Day Start End Track Tower Room Speaker Title} - return -} - -proc parse {htmlfile} { - global rooms tracks - - ::struct::tree::tree t - - log::log info "Reading \"$htmlfile\" ..." - set html [read [set fh [open $htmlfile]]] - close $fh - - log::log info "Parsing \"$htmlfile\" ..." - htmlparse::2tree $html t - htmlparse::removeVisualFluff t - htmlparse::removeFormDefs t - - log::log info "Extracting information" - - #puts ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Navigate and extract the information - #t walk root -command {print %t %n} - #exit - - set base [walk {1 1 0 1 1 0 1 0 1 0}] - set day [walkf $base {0 0}] - set day [escape [t get $day -key data]] - log::log debug "Day = $day" - set day [string range $day 0 2] - - # Walk through the sessions of that day. - - set sess [t next $base] - while {$sess != {}} { - set start [cvtdate [escape [t get [walkf $sess {0 0}] -key data]]] - set track [string trim [escape [t get [walkf $sess {1 0}] -key data]]] - set loc [escape [t get [walkf $sess {1 1 0}] -key data]] - set loc [string trimright $loc "\n\r\t:"] - - log::log debug " $start - $track - $loc" - - # Separate Room/Tower information ... - regexp {(.*) in the (.*) Tower} $loc -> room tower - set room [string trim $room] - set tower [string trim $tower] - set rooms($tower/$room) . - set tracks($track) . - - set talk [walkf $sess {1 1 3}] - while {$talk != {}} { - set time [escape [t get $talk -key data]] - set talk [t next $talk] - set title [escape [t get [walkf $talk {0 0 0}] -key data]] - set speaker [escape [t get [walkf $talk {0 2}] -key data]] - - # Now we have everything to fill the main table ... - # (After a bit of munging of the strings we got) - - foreach {start end} [split $time -] break - set start [cvtdate $start] - set end [cvtdate $end] - - regsub -all \r $speaker \n speaker - regsub -all \n+ $speaker \n speaker - regsub -all " *\n *" $speaker "\n" speaker - set speakerc [split $speaker "\n"] - set speakerc [join $speakerc ", "] - log::log debug " $start - $end - $speakerc - $title" - - #puts >>$speakerc<< - #puts >>$speaker<< - - # Day Time/Start Time/End Tower Room Speaker Title - dmainr add row [list $day $start $end $track $tower $room $speaker $title] - dmain add row [list $day $start $end $track $tower $room $speakerc $title] - - # Forward to next talk - catch {set talk [t next $talk]} - catch {set talk [t next $talk]} - } - - set sess [t next $sess] - } - - t destroy - return -} - -proc print {t n} { - set tp [$t get $n -key type] - set d [$t depth $n] - set idx "" - catch {set idx [$t index $n]} - incr d $d - incr d $d - - switch -exact -- $tp { - a { - log::log debug "[textutil::strRepeat " " $d]$idx $tp ([$t get $n -key data]...)" - } - PCDATA { - log::log debug "[textutil::strRepeat " " $d]$idx $tp ([string range [$t get $n -key data] 0 20]...)" - } - default { - log::log debug "[textutil::strRepeat " " $d]$idx $tp" - } - } -} - -proc walkf {n p} { - #log::log info "$n + $p =" - foreach idx $p { - if {$n == ""} {break} - set n [lindex [t children $n] $idx] - #log::log info "$idx :- $n" - } - return $n -} - -proc walk {p} { - return [walkf root $p] -} - -proc cvtdate {date} { - clock format [clock scan $date] -format "%H:%M" -} - -proc escape {text} { - # Special escape for nbsp, convert into space and not the - # character specified by the standard. - - regsub -all { } $text { } text - htmlparse::mapEscapes $text -} - - -proc gen_schedule {} { - global rooms tracks - - dmain set rect 0 1 [lsort -decreasing -index 0 [lsort -index 1 [dmain get rect 0 1 end end]]] - dmainr set rect 0 1 [lsort -decreasing -index 0 [lsort -index 1 [dmainr get rect 0 1 end end]]] - - sched add columns 2 - schedr add columns 2 - #sched add columns [array size rooms] - #schedr add columns [array size rooms] - sched add columns [array size tracks] - schedr add columns [array size tracks] - - #log::log info Tracks=[array size tracks] - #log::log info Rooms.=[array size rooms] - - set res [list Day Time] - set c 2 - foreach k [lsort [array names tracks]] { - lappend res $k - set tracks($k) $c - incr c - } - - sched add row $res - schedr add row $res - - # Data in dmain is already sorted by day. By starting time only - # partially, there are back references. - # Just move them to the correct rooms and rows! - - #-- Day Time Location-Columns, one per Room -- - - set n [dmain rows] - set p 0 - - array set rmap {} - - for {set r 1} {$r < $n} {incr r} { - foreach {day start end track tower room speaker title} [dmain get row $r] break - #[list $day $start $end $tower $room $speakerc $title] - - set key $day,$start - if {![info exists rmap($key)]} { - log::log info "Track schedule $day $start" - sched add row - schedr add row - incr p - - set rmap($key) $p - sched set cell 0 $p $day - sched set cell 1 $p $start - schedr set cell 0 $p $day - schedr set cell 1 $p $start - } - - sched set cell $tracks($track) $rmap($key) "$tower; $room; $speaker; $title" - schedr set cell $tracks($track) $rmap($key) "$tower $room\n$speaker\n$title" - } - - # Squeeze the columns 2+ in the report matrix - - set cols [schedr columns] - for {set c 2} {$c < $cols} {incr c} { - - if {[schedr columnwidth $c] > 21} { - log::log debug "Squeezing $c" - set col [schedr get column $c] - set res [list] - foreach item $col { - lappend res [wrap $item 21] - } - schedr set column $c $res - } - } - - # Now sort by day (primary key) and starting time (secondary key). - # (Meaning we have to sort by time first, and then the day) - - # sched setrect 0 0 [lsort -decreasing -index 0 [lsort -index 1 [sched getrect 0 0 end end]]] - # schedr setrect 0 0 [lsort -decreasing -index 0 [lsort -index 1 [schedr getrect 0 0 end end]]] - - return -} - -proc dump_main {} { - global pfx - log::log info "Writing talk information /CSV" - - set f [open ${pfx}.main.csv w] - csv::writematrix dmain $f - close $f - - log::log info "Writing talk information /TXT" - - # Compute width of report and squeeze the title column to fit - # below 80 char/line - - # Day Time/Start Time/End Track Tower Room Speaker Title - - set total 0 - incr total [dmain columnwidth 0] - incr total [dmain columnwidth 1] - incr total [dmain columnwidth 2] - incr total [dmain columnwidth 3] - incr total [dmain columnwidth 4] - incr total [dmain columnwidth 5] - incr total [dmain columnwidth 6] - - #log::log info Total=$total - - if {$total < 80} { - set total [expr {80 - $total}] - set titles [dmain getcolumn 7] - set res [list] - foreach t $titles { - lappend res [textutil::adjust $t -length $total] - } - dmain setcolumn 7 $res - } - - ::report::report r [dmainr columns] style captionedtable 1 - set f [open ${pfx}.main.txt w] - r printmatrix2channel dmainr $f - close $f - r destroy - - # Now the HTML report, use 'dmain' as base, actually formatting - # into lines is done by the browser. - - log::log info "Writing talk information /HTML" - - ::report::report r [dmain columns] style html - - set f [open ${pfx}.main.html w] - puts $f "Talk information and schedule" - puts $f "

Talk information and schedule

" - puts $f "

" - r printmatrix2channel dmain $f - puts $f "

" - close $f - r destroy -} - -proc dump_schedule {} { - global pfx - log::log info "Writing track schedule /CSV" - - set f [open ${pfx}.sched.csv w] - csv::writematrix sched $f - close $f - - log::log info "Writing track schedule /TXT" - - ::report::report r [schedr columns] style captionedtable 1 - r datasep set [r top get] - r datasep enable - - set f [open ${pfx}.sched.txt w] - r printmatrix2channel schedr $f - close $f - r destroy - - # Now the HTML report, use 'sched' as base, actually formatting - # into lines is done by the browser. - - log::log info "Writing track schedule /HTML" - - ::report::report r [sched columns] style html - - set f [open ${pfx}.sched.html w] - puts $f "Track schedules" - puts $f "

Track schedules

" - puts $f "

" - r printmatrix2channel sched $f - puts $f "

" - close $f - r destroy -} - -proc postscript {} { - global pfx - # Transforms texts into printable postscript, using a2ps (if available) - - catch {exec a2ps -o ${pfx}.main.ps -1 -B -r -f7 ${pfx}.main.txt} - catch {exec a2ps -o ${pfx}.sched.ps -1 -B -r -f4 ${pfx}.sched.txt} - return -} - -proc wrap {text len} { - # @author Jeffrey Hobbs - # - # @c Wraps the given into multiple lines not - # @c exceeding characters each. Lines shorter - # @c than characters might get filled up. - # - # @a text: The string to operate on. - # @a len: The maximum allowed length of a single line. - # - # @r Basically , but with changed newlines to - # @r restrict the length of individual lines to at most - # @r characters. - - # @n This procedure is not checked by the testsuite. - - # @i wrap, word wrap - - # Convert all newlines into spaces and initialize the result - # see ::pool::string::oneLine too. - - regsub -all "\n" $text { } text - incr len -1 - - set out {} - - # As long as the string is longer than the intended length of - # lines in the result: - - while {[string len $text] > $len} { - # - Find position of last space in the part of the text - # which could a line in the result. - - # - We jump out of the loop if there is none and the whole - # text does not contain spaces anymore. In the latter case - # the rest of the text is one word longer than an intended - # line, we cannot avoid the longer line. - - set i [string last { } [string range $text 0 $len]] - - if {$i == -1 && [set i [string first { } $text]] == -1} { - break - } - - # Get the just fitting part of the text, remove any heading - # and trailing spaces, then append it to the result string, - # don't close it with a newline! - - append out [string trim [string range $text 0 [incr i -1]]]\n - - # Shorten the text by the length of the processed part and - # the space used to split it, then iterate. - - set text [string range $text [incr i 2] end] - } - - return $out$text -} - -# ------------------------------------------- -# Define the required reports styles - -::report::defstyle simpletable {} { - data set [split "[string repeat "| " [columns]]|"] - top set [split "[string repeat "+ - " [columns]]+"] - bottom set [top get] - top enable - bottom enable -} -::report::defstyle captionedtable {{n 1}} { - simpletable - topdata set [data get] - topcapsep set [top get] - topcapsep enable - tcaption $n -} -::report::defstyle html {} { - set c [columns] - set cl $c ; incr cl -1 - data set " [split [string repeat " " $cl] ""] " - for {set col 0} {$col < $c} {incr col} { - pad $col left "" - pad $col right "" - } - return -} - -# ------------------------------------------- - -main -exit DELETED examples/oreilly-oscon2001/osconwrap Index: examples/oreilly-oscon2001/osconwrap ================================================================== --- examples/oreilly-oscon2001/osconwrap +++ /dev/null @@ -1,6 +0,0 @@ -#!/bin/sh -rm -f [1-4]* -./oscon 1wed sessions_wednesday.html -./oscon 2tue sessions_thursday.html -./oscon 3fri sessions_friday.html -./oscon 4all sessions_wednesday.html sessions_thursday.html sessions_friday.html DELETED examples/oreilly-oscon2001/sessions_friday.html Index: examples/oreilly-oscon2001/sessions_friday.html ================================================================== --- examples/oreilly-oscon2001/sessions_friday.html +++ /dev/null @@ -1,1217 +0,0 @@ - - - - -conferences.oreilly.com -- O'Reilly Open Source Convention -- Sessions: Friday At-A-Glance - - - - - - - - - - - - - - - - - - - - -
O'Reilly Open Source Convention
oreilly.comO'Reilly Network
ConferencesSoftwareInternational -
-
- - - - - -
-
- - - - - - -
- - -
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
ArrowHome
ArrowRegistration
ArrowHotel/Travel
ArrowTutorials
ArrowSessions
ArrowBOFs
ArrowSpeakers
ArrowPress
ArrowMail List
ArrowExhibitors
ArrowSponsors
- - 
-		 - - - - - - -
-
-Innovate--Collaborate--Discover
-O'Reilly Open Source Convention
-Sheraton San Diego Hotel, San Diego, CA
-July 23-27, 2001 -
-
-
- - - - - - -
- -Hornbill -


- -
Register Now!
Save up to $400
when you register
before June 22!
- - -		 - -

Sessions: Friday At-A-Glance

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Friday, July 27
8:45amKeynote -
-Grand A in the East Tower -:
-   8:45am - 10:15am - - - -
-
10:45amZope -
-Bel Aire North in the West Tower -:
-   10:45am - 11:15am - - -   11:15am - 12:15pm - -
-
10:45amXML/XTech2001 -
-Point Loma A in the West Tower -:
-   10:45am - 12:15pm - - - -
-
10:45amXML/XTech2001 -
-Coronado A in the West Tower -:
-   10:45am - 11:15am - - -   11:15am - 11:45am - -
-
10:45amPerl 5 -
-Grand B in the East Tower -:
-   10:45am - 11:30am - - -   11:30am - 12:15pm - -
-
10:45amPerl 5 -
-Grand C in the East Tower -:
-   10:45am - 12:15pm - - - -
-
10:45amApache -
-Harbor Island II in the East Tower -:
-   10:45am - 11:30am - - -   11:30am - 12:15pm - -
-
10:45amMozilla -
-Harbor Island III in the East Tower -:
-   10:45am - 5:15pm - - - -
-
10:45amPHP 1 -
-Fairbanks C&D in the West Tower -:
-   10:45am - 12:15pm - - - -
-
10:45amPHP 1 -
-Marina II in the East Tower -:
-   10:45am - 5:15pm - - - -
-
10:45amTcl/Tk -
-Fairbanks A&B in the West Tower -:
-   10:45am - 11:15am - - -   11:15am - 11:45am -   11:45am - 12:15pm - -
-
10:45amLinux -
-Harbor Island I in the East Tower -:
-   10:45am - 11:30pm - - -   11:30pm - 12:15pm - -
-
10:45amOpen Source -
-Marina II in the East Tower -:
-   10:45am - 5:15pm - - - -
-
1:45pmZope -
-Bel Aire North in the West Tower -:
-   1:45pm - 2:30pm - - -   2:30pm - 3:15pm - -
-
1:45pmXML/XTech2001 -
-Point Loma A in the West Tower -:
-   1:45pm - 2:30pm - - -   2:30pm - 3:15pm - -
-
1:45pmXML/XTech2001 -
-Coronado A in the West Tower -:
-   1:45pm - 5:15pm - - - -
-
1:45pmPerl 5 -
-Grand A in the East Tower -:
-   1:45pm - 2:30pm - - -   2:30pm - 3:15pm - -
-
1:45pmPerl 5 -
-Grand C in the East Tower -:
-   1:45pm - 2:45pm - - -   2:45pm - 3:15pm - -
-
1:45pmApache -
-Harbor Island II in the East Tower -:
-   1:45pm - 3:15pm - - - -
-
1:45pmPHP 1 -
-Fairbanks C&D in the West Tower -:
-   1:45pm - 2:30pm - - -   2:30pm - 3:15pm - -
-
1:45pmTcl/Tk -
-Fairbanks A&B in the West Tower -:
-   1:45pm - 2:15pm - - -   2:15pm - 2:45pm -   2:45pm - 3:15pm - -
-
1:45pmLinux -
-Harbor Island I in the East Tower -:
-   1:45pm - 2:15pm - - -   2:15pm - 2:45pm -   2:45pm - 3:00pm - -
-
3:45pmZope -
-Bel Aire North in the West Tower -:
-   3:45pm - 4:45pm - - -   4:45pm - 5:15pm - -
-
3:45pmXML/XTech2001 -
-Point Loma A in the West Tower -:
-   3:45pm - 4:30pm - - -   4:30pm - 5:15pm - -
-
3:45pmPerl 5 -
-Grand A in the East Tower -:
-   3:45pm - 4:30pm - - -   4:30pm - 5:15pm - -
-
3:45pmPerl 5 -
-Grand B in the East Tower -:
-   3:45pm - 4:30pm - - -   4:30pm - 5:15pm - -
-
3:45pmPerl 5 -
-Grand C in the East Tower -:
-   3:45pm - 5:15pm - - - -
-
3:45pmApache -
-Harbor Island II in the East Tower -:
-   3:45pm - 5:15pm - - - -
-
3:45pmPHP 1 -
-Fairbanks C&D in the West Tower -:
-   3:45pm - 4:30pm - - -   4:30pm - 5:15pm - -
-
3:45pmTcl/Tk -
-Fairbanks A&B in the West Tower -:
-   3:45pm - 4:15pm - - -   4:15pm - 4:45pm -   4:45pm - 5:15pm - -
-
3:45pmLinux -
-Harbor Island I in the East Tower -:
-   3:45pm - 4:30pm - - -   4:30pm - 5:15pm - -
-
- - - - - - -
- - -
- -oreilly.com Home | -Conferences Home | -Open Source Convention Home
-Registration | -Hotels/Travel | -Tutorials | -Sessions | -Speakers
-Press | -Mail List | -Exhibitors | -Sponsors
- -

-© 2001, O'Reilly & Associates, Inc.
-conftech@oreilly.com - -
-
-
-

-WWWOFFLE - Sun, 22 Apr 2001 21:56:19 CEST (vor 1 Tag) - [Löschen| -Neu abrufen: -Optionen| -regelm. abrufen| -Index] - WWWOFFLE -

-
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DELETED examples/oreilly-oscon2001/sessions_thursday.html Index: examples/oreilly-oscon2001/sessions_thursday.html ================================================================== --- examples/oreilly-oscon2001/sessions_thursday.html +++ /dev/null @@ -1,1461 +0,0 @@ - - - - -conferences.oreilly.com -- O'Reilly Open Source Convention -- Sessions: Thursday At-A-Glance - - - - - - - - - - - - - - - - - - - - -
O'Reilly Open Source Convention
oreilly.comO'Reilly Network
ConferencesSoftwareInternational -
-
- - - - - -
-
- - - - - - -
- - -
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
ArrowHome
ArrowRegistration
ArrowHotel/Travel
ArrowTutorials
ArrowSessions
ArrowBOFs
ArrowSpeakers
ArrowPress
ArrowMail List
ArrowExhibitors
ArrowSponsors
- - 
-		 - - - - - - -
-
-Innovate--Collaborate--Discover
-O'Reilly Open Source Convention
-Sheraton San Diego Hotel, San Diego, CA
-July 23-27, 2001 -
-
-
- - - - - - -
- -Hornbill -


- -
Register Now!
Save up to $400
when you register
before June 22!
- - -		 - -

Sessions: Thursday At-A-Glance

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Thursday, July 26
8:45amKeynote -
-Grand Ballroom in the East Tower -:
-   8:45am - 10:15am - - - -
-
10:45ammod_perl -
-Harbor Island I in the East Tower -:
-   10:45am - 11:15am - - -   11:15am - 12:15pm - -
-
10:45amPostgreSQL -
-Bel Aire South in the West Tower -:
-   10:45am - 11:30am - - -   11:30am - 12:15pm - -
-
10:45amXML/XTech2001 -
-Point Loma A in the West Tower -:
-   10:45am - 12:15pm - - - -
-
10:45amXML/XTech2001 -
-Coronado A in the West Tower -:
-   10:45am - 11:30am - - -   11:30am - 12:15pm - -
-
10:45amPerl 5 -
-Grand C in the East Tower -:
-   10:45am - 11:30am - - -   11:30am - 12:15pm - -
-
10:45amPerl 5 -
-Grand A in the East Tower -:
-   10:45am - 11:15am - - -   11:15am - 11:45am -   11:45am - 12:15pm - -
-
10:45amPerl 5 -
-Grand B in the East Tower -:
-   10:45am - 11:15am - - -   11:45am - 12:15pm -   11:15am - 11:45am -
    -
  • ReBug
    - - -Michel Lambert - -
    - -     -
    • -
-
-
10:45amPython -
-Bel Aire North in the West Tower -:
-   10:45am - 12:15pm - - - -
-
10:45amMozilla -
-Harbor Island III in the East Tower -:
-   10:45am - 11:30am - - -   11:30am - 12:15pm - -
-
10:45amPHP 1 -
-Fairbanks C&D in the West Tower -:
-   10:45am - 11:30am - - -   11:30am - 12:15pm - -
-
10:45amTcl/Tk -
-Fairbanks A&B in the West Tower -:
-   10:45am - 12:15pm - - - -
-
10:45amOpen Source -
-Marina II in the East Tower -:
-   10:45am - 11:30am - - -   11:30am - 12:15pm - -
-
1:45pmPostgreSQL -
-Bel Aire South in the West Tower -:
-   1:45pm - 3:15pm - - - -
-
1:45pmXML/XTech2001 -
-Point Loma A in the West Tower -:
-   1:45pm - 3:15pm - - - -
-
1:45pmXML/XTech2001 -
-Coronado A in the West Tower -:
-   1:45pm - 2:30pm - - -   2:30pm - 3:15pm - -
-
1:45pmPerl 5 -
-Grand B in the East Tower -:
-   1:45pm - 2:15pm - - -   2:15pm - 2:45pm -   2:45pm - 3:15pm - -
-
1:45pmPerl 5 -
-Grand C in the East Tower -:
-   1:45pm - 2:15pm - - -   2:15pm - 2:45pm -   2:45pm - 3:15pm -
    -
  • Camelot
    - - -Andy Wardley - -
    - -     -
    • -
-
-
1:45pmPython -
-Bel Aire North in the West Tower -:
-   1:45pm - 2:15pm - - -   2:15pm - 2:45pm -   2:45pm - 3:15pm - -
-
1:45pmApache -
-Harbor Island II in the East Tower -:
-   1:45pm - 2:30pm - - - -
-
1:45pmMozilla -
-Harbor Island III in the East Tower -:
-   1:45pm - 2:30pm - - -   2:30pm - 3:15pm - -
-
1:45pmPHP 1 -
-Fairbanks C&D in the West Tower -:
-   1:45pm - 2:30pm - - -   2:30pm - 3:15pm - -
-
1:45pmTcl/Tk -
-Fairbanks A&B in the West Tower -:
-   1:45pm - 2:15pm - - -   2:15pm - 2:45pm -   2:45pm - 3:15pm - -
-
1:45pmOpen Source -
-Marina II in the East Tower -:
-   1:45pm - 2:15pm - - -   2:15pm - 2:45pm - -
-
3:45pmPostgreSQL -
-Bel Aire South in the West Tower -:
-   3:45pm - 4:30pm - - -   4:30pm - 5:15pm - -
-
3:45pmXML/XTech2001 -
-Point Loma A in the West Tower -:
-   3:45pm - 5:15pm - - - -
-
3:45pmXML/XTech2001 -
-Coronado A in the West Tower -:
-   3:45pm - 4:30pm - - -   4:30pm - 5:15pm - -
-
3:45pmPerl 5 -
-Grand C in the East Tower -:
-   3:45pm - 4:30pm - - -   4:30pm - 5:15pm - -
-
3:45pmPerl 5 -
-Grand B in the East Tower -:
-   3:45pm - 4:30pm - - -   4:30pm - 5:15pm - -
-
3:45pmPerl 5 -
-Grand A in the East Tower -:
-   3:45pm - 4:30pm - - -   4:30pm - 5:15pm - -
-
3:45pmPython -
-Bel Aire North in the West Tower -:
-   3:45pm - 4:15pm - - -   4:15pm - 4:45pm - -
-
3:45pmApache -
-Harbor Island II in the East Tower -:
-   3:45pm - 4:30pm - - -   4:30pm - 5:15pm - -
-
3:45pmMozilla -
-Harbor Island III in the East Tower -:
-   3:45pm - 4:30pm - - -   4:30pm - 5:15pm - -
-
3:45pmPHP 1 -
-Fairbanks C&D in the West Tower -:
-   3:45pm - 4:30pm - - -   4:30pm - 5:15pm - -
-
3:45pmTcl/Tk -
-Fairbanks A&B in the West Tower -:
-   3:45pm - 4:15pm - - -   4:15pm - 4:45pm -   4:45pm - 5:15pm - -
-
3:45pmOpen Source -
-Marina II in the East Tower -:
-   3:45pm - 4:15pm - - -   4:15pm - 4:45pm -   4:45pm - 5:15pm - -
-
- - - - - - -
- - -
- -oreilly.com Home | -Conferences Home | -Open Source Convention Home
-Registration | -Hotels/Travel | -Tutorials | -Sessions | -Speakers
-Press | -Mail List | -Exhibitors | -Sponsors
- -

-© 2001, O'Reilly & Associates, Inc.
-conftech@oreilly.com - -
-
-
-

-WWWOFFLE - Sun, 22 Apr 2001 21:56:20 CEST (vor 1 Tag) - [Löschen| -Neu abrufen: -Optionen| -regelm. abrufen| -Index] - WWWOFFLE -

-
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DELETED examples/oreilly-oscon2001/sessions_wednesday.html Index: examples/oreilly-oscon2001/sessions_wednesday.html ================================================================== --- examples/oreilly-oscon2001/sessions_wednesday.html +++ /dev/null @@ -1,1290 +0,0 @@ - - - - -conferences.oreilly.com -- O'Reilly Open Source Convention -- Sessions: Wednesday At-A-Glance - - - - - - - - - - - - - - - - - - - - -
O'Reilly Open Source Convention
oreilly.comO'Reilly Network
ConferencesSoftwareInternational -
-
- - - - - -
-
- - - - - - -
- - -
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
ArrowHome
ArrowRegistration
ArrowHotel/Travel
ArrowTutorials
ArrowSessions
ArrowBOFs
ArrowSpeakers
ArrowPress
ArrowMail List
ArrowExhibitors
ArrowSponsors
- - 
-		 - - - - - - -
-
-Innovate--Collaborate--Discover
-O'Reilly Open Source Convention
-Sheraton San Diego Hotel, San Diego, CA
-July 23-27, 2001 -
-
-
- - - - - - -
- -Hornbill -


- -
Register Now!
Save up to $400
when you register
before June 22!
- - -		 - -

Sessions: Wednesday At-A-Glance

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Wednesday, July 25
10:45amMySQL -
-Fairbanks C&D in the West Tower -:
-   10:45am - 11:30am - - -   11:30am - 12:15pm - -
-
10:45ammod_perl -
-Harbor Island I in the East Tower -:
-   10:45am - 11:30am - - -   11:30am - 12:15pm - -
-
10:45amXML/XTech2001 -
-Point Loma A in the West Tower -:
-   10:45am - 11:30am - - -   11:30am - 12:15pm - -
-
10:45amXML/XTech2001 -
-Coronado A in the West Tower -:
-   10:45am - 11:15am - - -   11:15am - 12:15pm - -
-
10:45amPerl 5 -
-Grand B in the East Tower -:
-   10:45am - 11:30am - - -   11:30am - 12:15pm - -
-
10:45amPerl 5 -
-Grand A in the East Tower -:
-   10:45am - 11:30am - - -   11:30am - 12:15pm - -
-
10:45amPerl 5 -
-Grand C in the East Tower -:
-   10:45am - 11:30am - - -   11:30am - 12:15pm - -
-
10:45amPython -
-Bel Aire North in the West Tower -:
-   10:45am - 12:15pm - - - -
-
10:45amJava -
-Harbor Island II in the East Tower -:
-   10:45am - 11:30am - - -   11:30am - 12:15pm - -
-
10:45amTcl/Tk -
-Fairbanks A&B in the West Tower -:
-   10:45am - 12:15pm - - - -
-
1:45pmMySQL -
-Fairbanks C&D in the West Tower -:
-   1:45pm - 3:15pm - - - -
-
1:45pmmod_perl -
-Harbor Island I in the East Tower -:
-   1:45pm - 2:15pm - - -   2:15pm - 2:45pm -   2:45pm - 3:15pm - -
-
1:45pmXML/XTech2001 -
-Point Loma A in the West Tower -:
-   1:45pm - 2:30pm - - -   2:30pm - 3:15pm - -
-
1:45pmXML/XTech2001 -
-Coronado A in the West Tower -:
-   1:45pm - 2:30pm - - -   2:30pm - 3:15pm - -
-
1:45pmPerl 5 -
-Grand B in the East Tower -:
-   1:45pm - 2:15pm - - -   2:15pm - 2:45pm -   2:45pm - 3:15pm - -
-
1:45pmPerl 5 -
-Grand A in the East Tower -:
-   1:45pm - 2:15pm - - - -
-
1:45pmPerl 5 -
-Grand C in the East Tower -:
-   1:45pm - 2:15pm - - - -
-
1:45pmPython -
-Bel Aire North in the West Tower -:
-   1:45pm - 2:15pm - - -   2:15pm - 2:45pm -   2:45pm - 3:15pm - -
-
1:45pmJava -
-Harbor Island II in the East Tower -:
-   1:45pm - 2:30pm - - -   2:30pm - 3:15pm - -
-
1:45pmMozilla -
-Harbor Island III in the East Tower -:
-   1:45pm - 2:30pm - - -   2:30pm - 3:15pm - -
-
1:45pmTcl/Tk -
-Fairbanks A&B in the West Tower -:
-   1:45pm - 2:15pm - - -   2:15pm - 2:45pm -   2:45pm - 3:15pm - -
-
3:45pmMySQL -
-Fairbanks C&D in the West Tower -:
-   3:45pm - 4:30pm - - -   4:30pm - 5:15pm - -
-
3:45pmXML/XTech2001 -
-Point Loma A in the West Tower -:
-   3:45pm - 4:30pm - - -   4:30pm - 5:15pm - -
-
3:45pmXML/XTech2001 -
-Coronado A in the West Tower -:
-   3:45pm - 4:30pm - - -   4:30pm - 5:15pm - -
-
3:45pmPerl 5 -
-Grand A in the East Tower -:
-   3:45pm - 4:30pm - - -   4:30pm - 5:15pm - -
-
3:45pmPerl 5 -
-Grand B in the East Tower -:
-   3:45pm - 4:30pm - - -   4:30pm - 5:15pm - -
-
3:45pmPerl 5 -
-Grand C in the East Tower -:
-   3:45pm - 4:30pm - -
    -
  • Inline
    - - - -Brian Ingerson - -
    -     -
    • -
-   4:30pm - 5:15pm - -
-
3:45pmPython -
-Bel Aire North in the West Tower -:
-   3:45pm - 4:15pm - - -   4:15pm - 4:45pm -   4:45pm - 5:15pm - -
-
3:45pmJava -
-Harbor Island II in the East Tower -:
-   3:45pm - 4:30pm - - -   4:30pm - 5:15pm - -
-
3:45pmTcl/Tk -
-Fairbanks A&B in the West Tower -:
-   3:45pm - 4:15pm - - -   4:15pm - 4:45pm -   4:45pm - 5:15pm - -
-
- - - - - - - - - - - - - - - - - - -
- - -
- -oreilly.com Home | -Conferences Home | -Open Source Convention Home
-Registration | -Hotels/Travel | -Tutorials | -Sessions | -Speakers
-Press | -Mail List | -Exhibitors | -Sponsors
- -

-© 2001, O'Reilly & Associates, Inc.
-conftech@oreilly.com - -
-
-
-

-WWWOFFLE - Sun, 22 Apr 2001 21:55:56 CEST (vor 1 Tag) - [Löschen| -Neu abrufen: -Optionen| -regelm. abrufen| -Index] - WWWOFFLE -

-
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DELETED examples/smtpd/tcl_smtpd Index: examples/smtpd/tcl_smtpd ================================================================== --- examples/smtpd/tcl_smtpd +++ /dev/null @@ -1,93 +0,0 @@ -#! /bin/sh -# -# tcl_smtpd - Copyright (C) 2001 Pat Thoyts -# -# Simple test of the mail server. All incoming messages are displayed to -# stdout. -# -# Usage tk_smtpd 0.0.0.0 8025 -# or tk_smtpd 127.0.0.1 2525 -# or tk_smtpd -# to listen to the default port 25 on all tcp/ip interfaces. -# -# ------------------------------------------------------------------------- -# This software 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 file 'license.terms' for -# more details. -# ------------------------------------------------------------------------- -# \ -exec tclsh8.3 "$0" ${1+"$@"} - -package require smtpd - -# In this example application we just print received mail to stdout. -proc deliver {sender recipients data} { - if {[catch {eval array set saddr [mime::parseaddress $sender]}]} { - error "invalid sender address \"$sender\"" - } - set mail "From $saddr(address) [clock format [clock seconds]]" - append mail "\n" [join $data "\n"] - - foreach rcpt $recipients { - if {! [catch {eval array set addr [mime::parseaddress $rcpt]}]} { - puts $mail - } - } -} - -# Deny only hosts from 192.168.1.* -proc validate_host {ipnum} { - if {[string match "192.168.1.*" $ipnum]} { - error "your domain is not allowed to post, Spammers!" - } -} - -# Only reject sender 'denied' -proc validate_sender {address} { - eval array set addr [mime::parseaddress $address] - if {[string match "denied" $addr(local)]} { - error "mailbox $addr(local) denied" - } - return -} - -# Only reject recipients beginning with 'bogus' -proc validate_recipient {address} { - eval array set addr [mime::parseaddress $address] - if {[string match "bogus*" $addr(local)]} { - error "mailbox $addr(local) denied" - } - return -} - -# Set up the server -smtpd::configure \ - -deliver ::deliver \ - -validate_host ::validate_host \ - -validate_recipient ::validate_recipient \ - -validate_sender ::validate_sender - -# Run the server on the default port 25. For unix change to -# a high numbered port eg: 2525 or 8025 etc with -# smtpd::start 127.0.0.1 8025 or smtpd::start 0.0.0.0 2525 - -set iface 0.0.0.0 -set port 25 - -if {$argc > 0} { - set iface [lindex $argv 0] -} -if {$argc > 1} { - set port [lindex $argv 1] -} - -smtpd::start $iface $port - -vwait forever - -# -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: DELETED examples/smtpd/tk_smtpd Index: examples/smtpd/tk_smtpd ================================================================== --- examples/smtpd/tk_smtpd +++ /dev/null @@ -1,95 +0,0 @@ -#! /bin/sh -# -# tk_smtpd - Copyright (C) 2001 Pat Thoyts -# -# Simple test of the mail server. All incoming messages are displayed in a -# message dialog. -# -# This example works nicely under Windows or within tkcon. -# -# Usage tk_smtpd 0.0.0.0 8025 -# or tk_smtpd 127.0.0.1 2525 -# or tk_smtpd -# to listen to the default port 25 on all tcp/ip interfaces. -# -# ------------------------------------------------------------------------- -# This software 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 file 'license.terms' for -# more details. -# ------------------------------------------------------------------------- -# \ -exec wish8.3 "$0" ${1+"$@"} - -package require smtpd -package require Tk -wm withdraw . - -# Handle new mail by raising a message dialog for each recipient. -proc deliver {sender recipients data} { - if {[catch {eval array set saddr [mime::parseaddress $sender]}]} { - error "invalid sender address \"$sender\"" - } - set mail "From $saddr(address) [clock format [clock seconds]]" - append mail "\n" [join $data "\n"] - - foreach rcpt $recipients { - if {! [catch {eval array set addr [mime::parseaddress $rcpt]}]} { - tk_messageBox -title "To: $addr(address)" -message $mail - } - } -} - -# Accept everyone except those spammers on 192.168.1.* :) -proc validate_host {ipnum} { - if {[string match "192.168.1.*" $ipnum]} { - error "your domain is not allowed to post, Spammers!" - } -} - -# Accept mail from anyone except user 'denied' -proc validate_sender {address} { - eval array set addr [mime::parseaddress $address] - if {[string match "denied" $addr(local)]} { - error "mailbox $addr(local) denied" - } - return -} - -# Only reject mail for recipients beginning with 'bogus' -proc validate_recipient {address} { - eval array set addr [mime::parseaddress $address] - if {[string match "bogus*" $addr(local)]} { - error "mailbox $addr(local) denied" - } - return -} - -# Setup the mail server -smtpd::configure \ - -deliver ::deliver \ - -validate_host ::validate_host \ - -validate_recipient ::validate_recipient \ - -validate_sender ::validate_sender - -# Run the server on the default port 25. For unix change to -# a high numbered port eg: 2525 or 8025 etc with -# smtpd::start 127.0.0.1 8025 or smtpd::start 0.0.0.0 2525 - -set iface 0.0.0.0 -set port 25 - -if {$argc > 0} { - set iface [lindex $argv 0] -} -if {$argc > 1} { - set port [lindex $argv 1] -} - -smtpd::start $iface $port - -# -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: DELETED examples/smtpd/tk_smtpdMIME Index: examples/smtpd/tk_smtpdMIME ================================================================== --- examples/smtpd/tk_smtpdMIME +++ /dev/null @@ -1,126 +0,0 @@ -#! /bin/sh -# -# tk_smtpdMIME -Copyright (C) 2002 Pat Thoyts -# -# Simple test of the mail server. All incoming messages are displayed in a -# message dialog. -# -# This uses the new MIME token passing interface to the smtpd module. -# -# This example works nicely under Windows or within tkcon. -# -# Usage tk_smtpd 0.0.0.0 8025 -# or tk_smtpd 127.0.0.1 2525 -# or tk_smtpd -# to listen to the default port 25 on all tcp/ip interfaces. -# -# ------------------------------------------------------------------------- -# This software 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 file 'license.terms' for -# more details. -# ------------------------------------------------------------------------- -# \ -exec wish "$0" ${1+"$@"} - -package require smtpd -package require mime -package require Tk -wm withdraw . -set _dlgid 0 - -# Handle new mail by raising a message dialog for each recipient. -proc deliverMIME {token} { - - set senders [mime::getheader $token From] - set recipients [mime::getheader $token To] - - if {[catch {eval array set saddr \ - [mime::parseaddress [lindex $senders 0]]}]} { - error "invalid sender address \"$senders\"" - } - set mail "From $saddr(address) [clock format [clock seconds]]\n" - append mail [mime::buildmessage $token] - foreach rcpt $recipients { - if {! [catch {eval array set addr [mime::parseaddress $rcpt]}]} { - display "To: $addr(address)" $mail - } - } -} - -proc display {title mail} { - global _dlgid - incr _dlgid - set dlg [toplevel .dlg$_dlgid] - set frm [frame ${dlg}.f -bd 0] - set txt [text ${frm}.e -yscrollcommand [list ${frm}.sb set]] - set scr [scrollbar ${frm}.sb -command [list $txt yview]] - set but [button ${dlg}.b -text "Dismiss" -command [list destroy $dlg]] - pack $scr -side right -fill y - pack $txt -side left -fill both -expand 1 - pack $frm -side top -fill both -expand 1 - pack $but -side bottom - wm title $dlg $title - $txt insert 0.0 $mail -} - -# Accept everyone except those spammers on 192.168.1.* :) -proc validate_host {ipnum} { - if {[string match "192.168.1.*" $ipnum]} { - error "your domain is not allowed to post, Spammers!" - } -} - -# Accept mail from anyone except user 'denied' -proc validate_sender {address} { - eval array set addr [mime::parseaddress $address] - if {[string match "denied" $addr(local)]} { - error "mailbox $addr(local) denied" - } - return -} - -# Only reject mail for recipients beginning with 'bogus' -proc validate_recipient {address} { - eval array set addr [mime::parseaddress $address] - if {[string match "bogus*" $addr(local)]} { - error "mailbox $addr(local) denied" - } - return -} - -# Setup the mail server -smtpd::configure \ - -deliverMIME ::deliverMIME \ - -validate_host ::validate_host \ - -validate_recipient ::validate_recipient \ - -validate_sender ::validate_sender - -# Run the server on the default port 25. For unix change to -# a high numbered port eg: 2525 or 8025 etc with -# smtpd::start 127.0.0.1 8025 or smtpd::start 0.0.0.0 2525 - -set iface 0.0.0.0 -set port 25 - -if {$tcl_interactive } { - - puts {you'll want to issue 'smtpd::start' to begin} - -} else { - - if {$argc > 0} { - set iface [lindex $argv 0] - } - if {$argc > 1} { - set port [lindex $argv 1] - } - - smtpd::start $iface $port -} - -# -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: DELETED examples/struct/README Index: examples/struct/README ================================================================== --- examples/struct/README +++ /dev/null @@ -1,16 +0,0 @@ -This directory contains some examples regarding the usage of struct -funtionality. For example a small diff tool based on - - struct::list longestCommonSubsequence. - -======================================================================= - -Example operations: - - tclsh ./diff2.tcl diff.tcl diff2.tcl - - Differences between the diff-tools in pseudo-'patch' form. - - tclsh ./diff.tcl diff.tcl diff2.tcl - - Differences between the diff-tools side by side. DELETED examples/struct/diff.tcl Index: examples/struct/diff.tcl ================================================================== --- examples/struct/diff.tcl +++ /dev/null @@ -1,57 +0,0 @@ -# MAIN PROGRAM -# -# Usage: -# diff.tcl file1 file2 -# -# Output: -# Puts out a list of lines consisting of: -# n1n2line -# -# where n1 is a line number in the first file, and n2 is a line number in the second file. -# The line is the text of the line. If a line appears in the first file but not the second, -# n2 is omitted, and conversely, if it appears in the second file but not the first, n1 -# is omitted. - -lappend auto_path \ - [file join \ - [file dirname [file dirname [file dirname [file dirname [file join [pwd] [info script]]]]]] \ - modules struct] -package require struct - -# Open the files and read the lines into memory - -set f1 [open [lindex $argv 0] r] -set lines1 [split [read $f1] \n] -close $f1 - -set f2 [open [lindex $argv 1] r] -set lines2 [split [read $f2] \n] -close $f2 - -set i 0 -set j 0 - -::struct::list assign [::struct::list longestCommonSubsequence $lines1 $lines2] x1 x2 - -foreach p $x1 q $x2 { - while { $i < $p } { - set l [lindex $lines1 $i] - puts "[incr i]\t\t$l" - } - while { $j < $q } { - set m [lindex $lines2 $j] - puts "\t[incr j]\t$m" - } - set l [lindex $lines1 $i] - puts "[incr i]\t[incr j]\t$l" -} -while { $i < [llength $lines1] } { - set l [lindex $lines1 $i] - puts "[incr i]\t\t$l" -} -while { $j < [llength $lines2] } { - set m [lindex $lines2 $j] - puts "\t[incr j]\t$m" -} - -exit DELETED examples/struct/diff2.tcl Index: examples/struct/diff2.tcl ================================================================== --- examples/struct/diff2.tcl +++ /dev/null @@ -1,60 +0,0 @@ -# MAIN PROGRAM -# -# Usage: -# diff2.tcl file1 file2 -# -# Output: -# Puts out a list of lines describing the changes from file1 to file2 -# in a format similar to 'patch'. It not the same as patch, but could -# be modified to be exactly the same. - -lappend auto_path \ - [file join \ - [file dirname [file dirname [file dirname [file dirname [file join [pwd] [info script]]]]]] \ - modules struct] -package require struct - -# Open the files and read the lines into memory - -set f1 [open [lindex $argv 0] r] -set lines1 [split [read $f1] \n] -close $f1 - -set f2 [open [lindex $argv 1] r] -set lines2 [split [read $f2] \n] -close $f2 - -set i 0 -set j 0 - -::struct::list assign [::struct::list longestCommonSubsequence $lines1 $lines2] x1 x2 - -set chunks 0 -foreach chunk [::struct::list lcsInvert2 $x1 $x2 [llength $lines1] [llength $lines2]] { - set chunks 1 - puts =========================================== - puts $chunk - puts ------------------------------------------- - - ::struct::list assign [lindex $chunk 1] b1 e1 - ::struct::list assign [lindex $chunk 2] b2 e2 - - switch -exact -- [lindex $chunk 0] { - changed { - puts "< [join [lrange $lines1 $b1 $e1] "\n< "]" - puts "---" - puts "> [join [lrange $lines2 $b2 $e2] "\n> "]" - } - added { - puts "> [join [lrange $lines2 $b2 $e2] "\n> "]" - } - deleted { - puts "< [join [lrange $lines1 $b1 $e1] "\n< "]" - } - } -} -if {$chunks} { - puts =========================================== -} - -exit DELETED installer.tcl Index: installer.tcl ================================================================== --- installer.tcl +++ /dev/null @@ -1,606 +0,0 @@ -#!/bin/sh -# -*- tcl -*- \ -exec tclsh "$0" ${1+"$@"} - -# -------------------------------------------------------------- -# Installer for Tcllib - -set distribution [file dirname [info script]] -lappend auto_path [file join $distribution modules] - -source [file join $distribution tcllib_version.tcl] ; # Get version information. - -# -------------------------------------------------------------- -# Low-level commands of the installation engine. - -proc gen_main_index {outdir package version} { - global config - - log "\nGenerating [file join $outdir pkgIndex.tcl]" - if {$config(dry)} {return} - - set index [open [file join $outdir pkgIndex.tcl] w] - - puts $index "# Tcl package index file, version 1.1" - puts $index "# Do NOT edit by hand. Let $package install generate this file." - puts $index "# Generated by $package installer for version $version" - - puts $index { -# All tcllib packages need Tcl 8 (use [namespace]) -if {![package vsatisfies [package provide Tcl] 8]} {return} - -# Extend the auto_path to make tcllib packages available -if {[lsearch -exact $::auto_path $dir] == -1} { - lappend ::auto_path $dir -} - -# For Tcl 8.3.1 and later, that's all we need -if {[package vsatisfies [package provide Tcl] 8.4]} {return} -if {(0 == [catch { - package vcompare [info patchlevel] [info patchlevel] -}]) && ( - [package vcompare [info patchlevel] 8.3.1] >= 0 -)} {return} - -# For older Tcl releases, here are equivalent contents -# of the pkgIndex.tcl files of all the modules - -if {![package vsatisfies [package provide Tcl] 8.0]} {return} -} - puts $index "" - puts $index "set maindir \$dir" - - foreach pi [lsort [glob -nocomplain [file join $outdir * pkgIndex.tcl]]] { - set subdir [file tail [file dirname $pi]] - puts $index "set dir \[file join \$maindir [list $subdir]\] ;\t source \[file join \$dir pkgIndex.tcl\]" - } - - puts $index "unset maindir" - puts $index "" - close $index - return -} - -proc xcopy {src dest recurse {pattern *}} { - run file mkdir $dest - foreach file [glob [file join $src $pattern]] { - set base [file tail $file] - set sub [file join $dest $base] - - if {0 == [string compare CVS $base]} {continue} - - if {[file isdirectory $file]} then { - if {$recurse} { - run file mkdir $sub - xcopy $file $sub $recurse $pattern - } - } else { - run file copy -force $file $sub - } - } -} - -# -------------------------------------------------------------- -# Module specific commands - -proc _null {args} {} - -proc _tcl {module libdir} { - global distribution - xcopy \ - [file join $distribution modules $module] \ - [file join $libdir $module] \ - 0 *.tcl - return -} - -proc _doc {module libdir} { - global distribution - - _tcl $module $libdir - xcopy \ - [file join $distribution modules $module mpformats] \ - [file join $libdir $module mpformats] \ - 1 - return -} - -proc _tex {module libdir} { - global distribution - - _tcl $module $libdir - xcopy \ - [file join $distribution modules $module] \ - [file join $libdir $module] \ - 0 *.tex - return -} - -proc _tci {module libdir} { - global distribution - - _tcl $module $libdir - file copy -force [file join $distribution modules $module tclIndex] \ - [file join $libdir $module] - return -} - -proc get_input {f} {return [read [set if [open $f r]]][close $if]} -proc write_out {f text} { - global config - if {$config(dry)} {log "Generate $f" ; return} - puts -nonewline [set of [open $f w]] $text - close $of -} - -proc _man {module format ext docdir} { - global distribution argv argc argv0 config - - package require doctools - ::doctools::new dt -format $format -module $module - - foreach f [glob -nocomplain [file join $distribution modules $module *.man]] { - - set out [file join $docdir [file rootname [file tail $f]]].$ext - - log "Generating $out" - if {$config(dry)} {continue} - - dt configure -file $f - file mkdir [file dirname $out] - - set data [dt format [get_input $f]] - switch -exact -- $format { - nroff { - set data [string map \ - [list \ - {.so man.macros} \ - $config(man.macros)] \ - $data] - } - html {} - } - write_out $out $data - - set warnings [dt warnings] - if {[llength $warnings] > 0} { - log [join $warnings \n] - } - } - dt destroy - return -} - -proc _exa {module exadir} { - global distribution - xcopy \ - [file join $distribution examples $module] \ - [file join $exadir $module] \ - 1 - return -} - -# -------------------------------------------------------------- -# List of modules to install (and definitions guiding the process) - -set modules [list] -array set guide {} -foreach {m pkg doc exa} { - base64 _tcl _man _null - calendar _tci _man _null - cmdline _tcl _man _null - comm _tcl _man _null - control _tci _man _null - counter _tcl _man _null - crc _tcl _man _null - csv _tcl _man _exa - des _tcl _man _null - dns _tcl _man _exa - doctools _doc _man _exa - exif _tcl _man _null - fileutil _tcl _man _null - ftp _tcl _man _exa - ftpd _tcl _man _exa - html _tcl _man _null - htmlparse _tcl _man _null - irc _tcl _man _exa - javascript _tcl _man _null - log _tcl _man _null - math _tci _man _null - md5 _tcl _man _null - md4 _tcl _man _null - mime _tcl _man _exa - ncgi _tcl _man _null - nntp _tcl _man _exa - ntp _tcl _man _exa - pop3 _tcl _man _null - pop3d _tcl _man _null - profiler _tcl _man _null - report _tcl _man _null - sha1 _tcl _man _null - smtpd _tcl _man _exa - soundex _tcl _man _null - stooop _tcl _man _null - struct _tcl _man _exa - textutil _tex _man _null - uri _tcl _man _null -} { - lappend modules $m - set guide($m,pkg) $pkg - set guide($m,doc) $doc - set guide($m,exa) $exa -} - -# -------------------------------------------------------------- -# Use configuration to perform installation - -proc clear {} {global message ; set message ""} -proc msg {text} {global message ; append message $text \n ; return} -proc get {} {global message ; return $message} - -proc log {text} { - global config - if {!$config(gui)} {puts stdout $text ; flush stdout ; return} - .l.t insert end $text\n - .l.t see end - update - return -} -proc log* {text} { - global config - if {!$config(gui)} {puts -nonewline stdout $text ; flush stdout ; return} - .l.t insert end $text - .l.t see end - update - return -} - -proc run {args} { - global config - if {$config(dry)} { - log [join $args] - return - } - eval $args - - log* . - return -} - -proc xinstall {type args} { - global modules guide - foreach m $modules { - eval $guide($m,$type) $m $args - } - return -} - -proc doinstall {} { - global config tcllib_version distribution tcllib_name - - if {$config(pkg)} { - xinstall pkg $config(pkg,path) - gen_main_index $config(pkg,path) $tcllib_name $tcllib_version - } - if {$config(doc,nroff)} { - set config(man.macros) [string trim [get_input [file join $distribution man.macros]]] - xinstall doc nroff n $config(doc,nroff,path) - } - if {$config(doc,html)} {xinstall doc html html $config(doc,html,path)} - if {$config(exa)} {xinstall exa $config(exa,path)} - log "" - return -} - - -# -------------------------------------------------------------- -# Initialize configuration. - -array set config { - pkg 1 pkg,path {} - doc,nroff 0 doc,nroff,path {} - doc,html 0 doc,html,path {} - exa 1 exa,path {} - dry 0 wait 1 valid 1 - gui 0 no-gui 0 -} - -# -------------------------------------------------------------- -# Determine a default configuration, if possible - -proc defaults {} { - global tcl_platform config tcllib_version tcllib_name distribution - - if {[string compare $distribution [info nameofexecutable]] == 0} { - # Starpack. No defaults for location. - } else { - # Starkit, or unwrapped. Derive defaults location from the - # location of the executable running the installer, or the - # location of its library. - - # For a starkit [info library] is inside the running - # tclkit. Detect this and derive the lcoation from the - # location of the executable itself for that case. - - if {[string match [info nameofexecutable]* [info library]]} { - # Starkit - set libdir [file join [file dirname [file dirname [info nameofexecutable]]] lib] - } else { - # Unwrapped. - if {[catch {set libdir [lindex $::tcl_pkgPath end]}]} { - set libdir [file dirname [info library]] - } - } - - set basedir [file dirname $libdir] - set bindir [file join $basedir bin] - - if {[string compare $tcl_platform(platform) windows] == 0} { - set mandir {} - set htmldir [file join $basedir tcllib_doc] - } else { - set mandir [file join $basedir man mann] - set htmldir [file join $libdir tcllib${tcllib_version} tcllib_doc] - } - - set config(pkg,path) [file join $libdir ${tcllib_name}${tcllib_version}] - set config(doc,nroff,path) $mandir - set config(doc,html,path) $htmldir - set config(exa,path) [file join $bindir tcllib_examples${tcllib_version}] - } - - if {[string compare $tcl_platform(platform) windows] == 0} { - set config(doc,nroff) 0 - set config(doc,html) 1 - } else { - set config(doc,nroff) 1 - set config(doc,html) 0 - } - return -} - -# -------------------------------------------------------------- -# Show configuration on stdout. - -proc showpath {prefix key} { - global config - - if {$config($key)} { - if {[string length $config($key,path)] == 0} { - puts "${prefix}Empty path, invalid." - set config(valid) 0 - msg "Invalid path: [string trim $prefix " :"]" - } else { - puts "${prefix}$config($key,path)" - } - } else { - puts "${prefix}Not installed." - } -} - -proc showconfiguration {} { - global config tcllib_version - - puts "Installing Tcllib $tcllib_version" - if {$config(dry)} { - puts "\tDry run, simulation, no actual activity." - puts "" - } - - puts "You have chosen the following configuration ..." - puts "" - - showpath "Packages: " pkg - showpath "Examples: " exa - - if {$config(doc,nroff) || $config(doc,html)} { - puts "Documentation:" - puts "" - - showpath "\tNROFF: " doc,nroff - showpath "\tHTML: " doc,html - } else { - puts "Documentation: Not installed." - } - puts "" - return -} - -# -------------------------------------------------------------- -# Setup the installer user interface - -proc browse {label key} { - global config - - set initial $config($key) - if {$initial == {}} {set initial [pwd]} - - set dir [tk_chooseDirectory \ - -title "Select directory for $label" \ - -parent . \ - -initialdir $initial \ - ] - - if {$dir == {}} {return} ; # Cancellation - - set config($key) $dir - return -} - -proc setupgui {} { - global config tcllib_name tcllib_version - set config(gui) 1 - - wm withdraw . - wm title . "Installing $tcllib_name $tcllib_version" - - foreach {w type cspan col row opts} { - .pkg checkbutton 1 0 0 {-anchor w -text {Packages:} -variable config(pkg)} - .dnr checkbutton 1 0 1 {-anchor w -text {Doc. Nroff:} -variable config(doc,nroff)} - .dht checkbutton 1 0 2 {-anchor w -text {Doc. HTML:} -variable config(doc,html)} - .exa checkbutton 1 0 3 {-anchor w -text {Examples:} -variable config(exa)} - - .spa frame 3 0 4 {-bg black -height 2} - - .dry checkbutton 2 0 6 {-anchor w -text {Simulate installation} -variable config(dry)} - - .pkge entry 1 1 0 {-width 40 -textvariable config(pkg,path)} - .dnre entry 1 1 1 {-width 40 -textvariable config(doc,nroff,path)} - .dhte entry 1 1 2 {-width 40 -textvariable config(doc,html,path)} - .exae entry 1 1 3 {-width 40 -textvariable config(exa,path)} - - .pkgb button 1 2 0 {-text ... -command {browse Packages pkg,path}} - .dnrb button 1 2 1 {-text ... -command {browse Nroff doc,nroff,path}} - .dhtb button 1 2 2 {-text ... -command {browse HTML doc,html,path}} - .exab button 1 2 3 {-text ... -command {browse Examples exa,path}} - - .sep frame 3 0 7 {-bg black -height 2} - - .run button 1 0 8 {-text {Install} -command {set ::run 1}} - .can button 1 1 8 {-text {Cancel} -command {exit}} - } { - eval [list $type $w] $opts - grid $w -column $col -row $row -sticky ew -columnspan $cspan - grid rowconfigure . $row -weight 0 - } - - grid .can -sticky e - - grid rowconfigure . 9 -weight 1 - grid columnconfigure . 0 -weight 0 - grid columnconfigure . 1 -weight 1 - - wm deiconify . - return -} - -proc handlegui {} { - setupgui - vwait ::run - showconfiguration - validate - - toplevel .l - wm title .l "Install log" - text .l.t -width 70 -height 25 -relief sunken -bd 2 - pack .l.t -expand 1 -fill both - - return -} - -# -------------------------------------------------------------- -# Handle a command line - -proc handlecmdline {} { - showconfiguration - validate - wait - return -} - -proc processargs {} { - global argv argv0 config - - while {[llength $argv] > 0} { - switch -exact -- [lindex $argv 0] { - -no-wait {set config(wait) 0} - -no-gui {set config(no-gui) 1} - -simulate - - -dry-run {set config(dry) 1} - -html {set config(doc,html) 1} - -nroff {set config(doc,nroff) 1} - -examples {set config(exa) 1} - -pkgs {set config(pkg) 1} - -no-html {set config(doc,html) 0} - -no-nroff {set config(doc,nroff) 0} - -no-examples {set config(exa) 0} - -no-pkgs {set config(pkg) 0} - -pkg-path { - set config(pkg) 1 - set config(pkg,path) [lindex $argv 1] - set argv [lrange $argv 1 end] - } - -nroff-path { - set config(doc,nroff) 1 - set config(doc,nroff,path) [lindex $argv 1] - set argv [lrange $argv 1 end] - } - -html-path { - set config(doc,html) 1 - set config(doc,html,path) [lindex $argv 1] - set argv [lrange $argv 1 end] - } - -example-path { - set config(exa) 1 - set config(exa,path) [lindex $argv 1] - set argv [lrange $argv 1 end] - } - -help - - default { - puts stderr "usage: $argv0 ?-dry-run/-simulate? ?-no-wait? ?-no-gui? ?-html|-no-html? ?-nroff|-no-nroff? ?-examples|-no-examples? ?-pkgs|-no-pkgs? ?-pkg-path path? ?-nroff-path path? ?-html-path path? ?-example-path path?" - exit 1 - } - } - set argv [lrange $argv 1 end] - } - return -} - -proc validate {} { - global config - - if {$config(valid)} {return} - - puts "Invalid configuration detected, aborting." - puts "" - puts "Please use the option -help to get more information" - puts "" - - if {$config(gui)} { - tk_messageBox \ - -icon error -type ok \ - -default ok \ - -title "Illegal configuration" \ - -parent . -message [get] - clear - } - exit 1 -} - -proc wait {} { - global config - - if {!$config(wait)} {return} - - puts -nonewline stdout "Is the chosen configuration ok ? y/N: " - flush stdout - set answer [gets stdin] - if {($answer == {}) || [string match "\[Nn\]*" $answer]} { - puts stdout "\tNo. Aborting." - puts stdout "" - exit 0 - } - return -} - -# -------------------------------------------------------------- -# Main code - -proc main {} { - global config - - defaults - processargs - if {$config(no-gui) || [catch {package require Tk}]} { - handlecmdline - } else { - handlegui - } - doinstall - return -} - -# -------------------------------------------------------------- -main -exit 0 -# -------------------------------------------------------------- DELETED license.terms Index: license.terms ================================================================== --- license.terms +++ /dev/null @@ -1,38 +0,0 @@ -This software is copyrighted by Ajuba Solutions 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 existing copyright notices are retained in all copies and that this -notice is included verbatim in any distributions. No written agreement, -license, or royalty fee is required for any of the authorized uses. -Modifications to this software may be copyrighted by their authors -and need not follow the licensing terms described here, provided that -the new terms are clearly indicated on the first page of each file where -they apply. - -IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY -FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES -ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY -DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. - -THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, -INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE -IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE -NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR -MODIFICATIONS. - -GOVERNMENT USE: If you are acquiring this software on behalf of the -U.S. government, the Government shall have only "Restricted Rights" -in the software and related documentation as defined in the Federal -Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you -are acquiring the software on behalf of the Department of Defense, the -software shall be classified as "Commercial Computer Software" and the -Government shall have only "Restricted Rights" as defined in Clause -252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the -authors grant the U.S. Government and others acting in its behalf -permission to use and distribute the software in accordance with the -terms specified in this license. DELETED main.tcl Index: main.tcl ================================================================== --- main.tcl +++ /dev/null @@ -1,4 +0,0 @@ -# -*- tcl -*- -# Entrypoint for strkit and -pack based distributions - -source [file join [file dirname [info script]] installer.tcl] DELETED man.macros Index: man.macros ================================================================== --- man.macros +++ /dev/null @@ -1,236 +0,0 @@ -'\" The definitions below are for supplemental macros used in Tcl/Tk -'\" manual entries. -'\" -'\" .AP type name in/out ?indent? -'\" Start paragraph describing an argument to a library procedure. -'\" type is type of argument (int, etc.), in/out is either "in", "out", -'\" or "in/out" to describe whether procedure reads or modifies arg, -'\" and indent is equivalent to second arg of .IP (shouldn't ever be -'\" needed; use .AS below instead) -'\" -'\" .AS ?type? ?name? -'\" Give maximum sizes of arguments for setting tab stops. Type and -'\" name are examples of largest possible arguments that will be passed -'\" to .AP later. If args are omitted, default tab stops are used. -'\" -'\" .BS -'\" Start box enclosure. From here until next .BE, everything will be -'\" enclosed in one large box. -'\" -'\" .BE -'\" End of box enclosure. -'\" -'\" .CS -'\" Begin code excerpt. -'\" -'\" .CE -'\" End code excerpt. -'\" -'\" .VS ?version? ?br? -'\" Begin vertical sidebar, for use in marking newly-changed parts -'\" of man pages. The first argument is ignored and used for recording -'\" the version when the .VS was added, so that the sidebars can be -'\" found and removed when they reach a certain age. If another argument -'\" is present, then a line break is forced before starting the sidebar. -'\" -'\" .VE -'\" End of vertical sidebar. -'\" -'\" .DS -'\" Begin an indented unfilled display. -'\" -'\" .DE -'\" End of indented unfilled display. -'\" -'\" .SO -'\" Start of list of standard options for a Tk widget. The -'\" options follow on successive lines, in four columns separated -'\" by tabs. -'\" -'\" .SE -'\" End of list of standard options for a Tk widget. -'\" -'\" .OP cmdName dbName dbClass -'\" Start of description of a specific option. cmdName gives the -'\" option's name as specified in the class command, dbName gives -'\" the option's name in the option database, and dbClass gives -'\" the option's class in the option database. -'\" -'\" .UL arg1 arg2 -'\" Print arg1 underlined, then print arg2 normally. -'\" -'\" RCS: @(#) $Id: man.macros,v 1.1 2000/03/06 21:34:53 ericm Exp $ -'\" -'\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages. -.if t .wh -1.3i ^B -.nr ^l \n(.l -.ad b -'\" # Start an argument description -.de AP -.ie !"\\$4"" .TP \\$4 -.el \{\ -. ie !"\\$2"" .TP \\n()Cu -. el .TP 15 -.\} -.ta \\n()Au \\n()Bu -.ie !"\\$3"" \{\ -\&\\$1 \\fI\\$2\\fP (\\$3) -.\".b -.\} -.el \{\ -.br -.ie !"\\$2"" \{\ -\&\\$1 \\fI\\$2\\fP -.\} -.el \{\ -\&\\fI\\$1\\fP -.\} -.\} -.. -'\" # define tabbing values for .AP -.de AS -.nr )A 10n -.if !"\\$1"" .nr )A \\w'\\$1'u+3n -.nr )B \\n()Au+15n -.\" -.if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n -.nr )C \\n()Bu+\\w'(in/out)'u+2n -.. -.AS Tcl_Interp Tcl_CreateInterp in/out -'\" # BS - start boxed text -'\" # ^y = starting y location -'\" # ^b = 1 -.de BS -.br -.mk ^y -.nr ^b 1u -.if n .nf -.if n .ti 0 -.if n \l'\\n(.lu\(ul' -.if n .fi -.. -'\" # BE - end boxed text (draw box now) -.de BE -.nf -.ti 0 -.mk ^t -.ie n \l'\\n(^lu\(ul' -.el \{\ -.\" Draw four-sided box normally, but don't draw top of -.\" box if the box started on an earlier page. -.ie !\\n(^b-1 \{\ -\h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul' -.\} -.el \}\ -\h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul' -.\} -.\} -.fi -.br -.nr ^b 0 -.. -'\" # VS - start vertical sidebar -'\" # ^Y = starting y location -'\" # ^v = 1 (for troff; for nroff this doesn't matter) -.de VS -.if !"\\$2"" .br -.mk ^Y -.ie n 'mc \s12\(br\s0 -.el .nr ^v 1u -.. -'\" # VE - end of vertical sidebar -.de VE -.ie n 'mc -.el \{\ -.ev 2 -.nf -.ti 0 -.mk ^t -\h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n' -.sp -1 -.fi -.ev -.\} -.nr ^v 0 -.. -'\" # Special macro to handle page bottom: finish off current -'\" # box/sidebar if in box/sidebar mode, then invoked standard -'\" # page bottom macro. -.de ^B -.ev 2 -'ti 0 -'nf -.mk ^t -.if \\n(^b \{\ -.\" Draw three-sided box if this is the box's first page, -.\" draw two sides but no top otherwise. -.ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c -.el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c -.\} -.if \\n(^v \{\ -.nr ^x \\n(^tu+1v-\\n(^Yu -\kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c -.\} -.bp -'fi -.ev -.if \\n(^b \{\ -.mk ^y -.nr ^b 2 -.\} -.if \\n(^v \{\ -.mk ^Y -.\} -.. -'\" # DS - begin display -.de DS -.RS -.nf -.sp -.. -'\" # DE - end display -.de DE -.fi -.RE -.sp -.. -'\" # SO - start of list of standard options -.de SO -.SH "STANDARD OPTIONS" -.LP -.nf -.ta 4c 8c 12c -.ft B -.. -'\" # SE - end of list of standard options -.de SE -.fi -.ft R -.LP -See the \\fBoptions\\fR manual entry for details on the standard options. -.. -'\" # OP - start of full description for a single option -.de OP -.LP -.nf -.ta 4c -Command-Line Name: \\fB\\$1\\fR -Database Name: \\fB\\$2\\fR -Database Class: \\fB\\$3\\fR -.fi -.IP -.. -'\" # CS - begin code excerpt -.de CS -.RS -.nf -.ta .25i .5i .75i 1i -.. -'\" # CE - end code excerpt -.de CE -.fi -.RE -.. -.de UL -\\$1\l'|0\(ul'\\$2 -.. Index: modules/base64/ChangeLog ================================================================== --- modules/base64/ChangeLog +++ modules/base64/ChangeLog @@ -1,5 +1,17 @@ +2003-04-22 Pat Thoyts + + * base64c.tcl: Added file to define the base64c C coded package. + * uuencode.tcl: Added critcl code into the package. + * yencode.tcl: Added critcl code into the package. + +2003-04-22 Pat Thoyts + + * all: Created DEVELOPMENT branch - tagged root-DEVELOPMENT. + This branch contains criticl-based C code to speed up some of the + computationally expensive functions - generates a base64c package. + 2003-04-21 Andreas Kupries * uuencode.test: Added code to suppress output from the log package during the test. Index: modules/base64/uuencode.tcl ================================================================== --- modules/base64/uuencode.tcl +++ modules/base64/uuencode.tcl @@ -4,17 +4,22 @@ # # ------------------------------------------------------------------------- # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- -# @(#)$Id: uuencode.tcl,v 1.8 2003/03/24 23:21:22 andreas_kupries Exp $ +# @(#)$Id: uuencode.tcl,v 1.8.2.2 2003/05/13 01:04:27 patthoyts Exp $ package require Tcl 8.2; # tcl minimum version -package require log; # tcllib 1.0 +catch {package require log}; # tcllib 1.0 + +# Try and get some compiled helper package. +if {[catch {package require tcllibc}]} { + catch {package require Trf} +} namespace eval ::uuencode { - variable version 1.0.2 + variable version 1.1.0 namespace export encode decode uuencode uudecode } proc ::uuencode::Enc {c} { @@ -33,10 +38,11 @@ append r [Enc [expr {(($c2 << 2) & 074) | (($c3 >> 6) & 003)}]] append r [Enc [expr {($c3 & 077)}]] } return $r } + proc ::uuencode::Decode {s} { if {[string length $s] == 0} {return ""} set r {} binary scan [pad $s] c* d @@ -49,10 +55,106 @@ append r [format %c [expr {((($c2-0x20)&0x3F) << 6) & 0xFF | (($c3-0x20)&0x3F) & 0xFF}]] } return $r } + +# ------------------------------------------------------------------------- +# C coded version of the Encode/Decode functions for base64c package. +# ------------------------------------------------------------------------- +if {[package provide critcl] != {}} { + namespace eval ::uuencode { + critcl::ccode { + #include + static unsigned char Enc(unsigned char c) { + return (c != 0) ? ((c & 0x3f) + 0x20) : 0x60; + } + } + critcl::ccommand CEncode {dummy interp objc objv} { + Tcl_Obj *inputPtr, *resultPtr; + int len, rlen, xtra; + unsigned char *input, *p, *r; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "data"); + return TCL_ERROR; + } + + inputPtr = objv[1]; + input = Tcl_GetByteArrayFromObj(inputPtr, &len); + if ((xtra = (3 - (len % 3))) != 3) { + if (Tcl_IsShared(inputPtr)) + inputPtr = Tcl_DuplicateObj(inputPtr); + input = Tcl_SetByteArrayLength(inputPtr, len + xtra); + memset(input + len, 0, xtra); + len += xtra; + } + + rlen = (len / 3) * 4; + resultPtr = Tcl_GetObjResult(interp); + if (Tcl_IsShared(resultPtr)) { + resultPtr = Tcl_DuplicateObj(resultPtr); + Tcl_SetObjResult(interp, resultPtr); + } + r = Tcl_SetByteArrayLength(resultPtr, rlen); + memset(r, 0, rlen); + + for (p = input; p < input + len; p += 3) { + char a, b, c; + a = *p; b = *(p+1), c = *(p+2); + *r++ = Enc(a >> 2); + *r++ = Enc(((a << 4) & 060) | ((b >> 4) & 017)); + *r++ = Enc(((b << 2) & 074) | ((c >> 6) & 003)); + *r++ = Enc(c & 077); + } + + return TCL_OK; + } + + critcl::ccommand CDecode {dummy interp objc objv} { + Tcl_Obj *inputPtr, *resultPtr; + int len, rlen, xtra; + unsigned char *input, *p, *r; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "data"); + return TCL_ERROR; + } + + /* if input is not mod 4, extend it with nuls */ + inputPtr = objv[1]; + input = Tcl_GetByteArrayFromObj(inputPtr, &len); + if ((xtra = (4 - (len % 4))) != 4) { + if (Tcl_IsShared(inputPtr)) + inputPtr = Tcl_DuplicateObj(inputPtr); + input = Tcl_SetByteArrayLength(inputPtr, len + xtra); + memset(input + len, 0, xtra); + len += xtra; + } + + /* output will be 1/3 smaller than input and a multiple of 3 */ + rlen = (len / 4) * 3; + resultPtr = Tcl_GetObjResult(interp); + if (Tcl_IsShared(resultPtr)) { + resultPtr = Tcl_DuplicateObj(resultPtr); + Tcl_SetObjResult(interp, resultPtr); + } + r = Tcl_SetByteArrayLength(resultPtr, rlen); + memset(r, 0, rlen); + + for (p = input; p < input + len; p += 4) { + char a, b, c, d; + a = *p; b = *(p+1), c = *(p+2), d = *(p+3); + *r++ = (((a - 0x20) & 0x3f) << 2) | (((b - 0x20) & 0x3f) >> 4); + *r++ = (((b - 0x20) & 0x3f) << 4) | (((c - 0x20) & 0x3f) >> 2); + *r++ = (((c - 0x20) & 0x3f) << 6) | (((d - 0x20) & 0x3f) ); + } + + return TCL_OK; + } + } +} # ------------------------------------------------------------------------- # Description: # Permit more tolerant decoding of invalid input strings by padding to @@ -71,20 +173,25 @@ # ------------------------------------------------------------------------- # If the Trf package is available then we shall use this by default but the # Tcllib implementations are always visible if needed (ie: for testing) -if {[catch {package require Trf 2.0}]} { - interp alias {} ::uuencode::encode {} ::uuencode::Encode - interp alias {} ::uuencode::decode {} ::uuencode::Decode -} else { +if {[info command ::uuencode::CDecode] != {}} { + # tcllib criticl package + interp alias {} ::uuencode::encode {} ::uuencode::CEncode + interp alias {} ::uuencode::decode {} ::uuencode::CDecode +} elseif {[package provide Trf] != {}} { proc ::uuencode::encode {s} { return [::uuencode -mode encode -- $s] } proc ::uuencode::decode {s} { return [::uuencode -mode decode -- [pad $s]] } +} else { + # pure-tcl then + interp alias {} ::uuencode::encode {} ::uuencode::Encode + interp alias {} ::uuencode::decode {} ::uuencode::Decode } # ------------------------------------------------------------------------- proc ::uuencode::uuencode {args} { Index: modules/base64/uuencode.test ================================================================== --- modules/base64/uuencode.test +++ modules/base64/uuencode.test @@ -4,18 +4,46 @@ # # ------------------------------------------------------------------------- # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- -# RCS: @(#) $Id: uuencode.test,v 1.6 2003/04/21 20:16:53 andreas_kupries Exp $ +# RCS: @(#) $Id: uuencode.test,v 1.6.2.1 2003/05/13 01:04:27 patthoyts Exp $ +# ------------------------------------------------------------------------- +# Initialize the test package +# if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::* } -package require uuencode +# ------------------------------------------------------------------------- +# Ensure we test _this_ local copy and one installed somewhere else. +# +package forget uuencode +catch {namespace delete ::uuencode} +if {[catch {source [file join [file dirname [info script]] uuencode.tcl]} msg]} { + puts "skipped [file tail [info script]]: $msg" + return +} + +# ------------------------------------------------------------------------- +# Setup any constraints +# + +# ------------------------------------------------------------------------- +# Now the package specific tests.... +# ------------------------------------------------------------------------- + +if {[info command ::uuencode::CEncode] != {}} { + puts "- uuencode [package provide uuencode] (critcl based)" +} elseif {[package provide Trf] != {}} { + puts "- uuencode [package provide uuencode] (Trf based)" +} else { + puts "- uuencode [package provide uuencode] (pure tcl)" +} + package require log log::lvSuppress notice # ------------------------------------------------------------------------- @@ -39,17 +67,17 @@ set result } [string repeat x 102] # Trf uses a different padding character. if {[catch {package present Trf}]} { + # critcl / pure tcl based set testdata {begin 644 data.dat 75&AE(&-A="!S870@;VX@=&AE(&UA="X` ` end} } else { - puts "Trf present" - + # Trf based set testdata {begin 644 data.dat 75&AE(&-A="!S870@;VX@=&AE(&UA="X~ ` end} } @@ -97,10 +125,22 @@ puts -nonewline $f [join $testdata "\r\n"] close $f catch {::uuencode::uudecode -file uuencode.test.data} result set result } [list [list data.dat 644 "The cat sat on the mat."]] + +foreach {n in out} { + 0 a {80``} + 1 abc {86)C} + 2 \0 {````} + 3 "\r\n\t" {#0H)} + 4 "hello world" {:&5L;&\@=V]R;&0`} +} { + test uuencode-3.$n {check the pure tcl encoder} { + list [catch {::uuencode::Encode $in} r] $r + } [list 0 $out] +} # ------------------------------------------------------------------------- file delete -force uuencode.test.data ::tcltest::cleanupTests Index: modules/base64/yencode.tcl ================================================================== --- modules/base64/yencode.tcl +++ modules/base64/yencode.tcl @@ -4,23 +4,24 @@ # # ------------------------------------------------------------------------- # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- -# @(#)$Id: yencode.tcl,v 1.3 2003/01/26 00:38:28 patthoyts Exp $ +# @(#)$Id: yencode.tcl,v 1.3.2.2 2003/05/13 01:04:27 patthoyts Exp $ package require Tcl 8.2; # tcl minimum version -package require crc32; # tcllib 1.1 +catch {package require crc32}; # tcllib 1.1 +catch {package require tcllibc}; # critcl enhancements for tcllib namespace eval ::yencode { variable version 1.0.1 namespace export encode decode yencode ydecode } # ------------------------------------------------------------------------- -proc ::yencode::encode {s} { +proc ::yencode::Encode {s} { set r {} binary scan $s c* d foreach {c} $d { set v [expr {($c + 42) % 256}] if {$v == 0x00 || $v == 0x09 || $v == 0x0A @@ -31,11 +32,11 @@ append r [format %c $v] } return $r } -proc ::yencode::decode {s} { +proc ::yencode::Decode {s} { if {[string length $s] == 0} {return ""} set r {} set esc 0 binary scan $s c* d foreach c $d { @@ -50,10 +51,113 @@ } append r [format %c $v] } return $r } + +# ------------------------------------------------------------------------- +# C coded versions for critcl built base64c package +# ------------------------------------------------------------------------- + +if {[package provide critcl] != {}} { + namespace eval ::yencode { + critcl::ccode { + #include + } + critcl::ccommand CEncode {dummy interp objc objv} { + Tcl_Obj *inputPtr, *resultPtr; + int len, rlen, xtra; + unsigned char *input, *p, *r, v; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "data"); + return TCL_ERROR; + } + + /* fetch the input data */ + inputPtr = objv[1]; + input = Tcl_GetByteArrayFromObj(inputPtr, &len); + + /* calculate the length of the encoded result */ + rlen = len; + for (p = input; p < input + len; p++) { + v = (*p + 42) % 256; + if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D) + rlen++; + } + + /* allocate the output buffer */ + resultPtr = Tcl_GetObjResult(interp); + if (Tcl_IsShared(resultPtr)) { + resultPtr = Tcl_DuplicateObj(resultPtr); + Tcl_SetObjResult(interp, resultPtr); + } + r = Tcl_SetByteArrayLength(resultPtr, rlen); + + /* encode the input */ + for (p = input; p < input + len; p++) { + v = (*p + 42) % 256; + if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D) { + *r++ = '='; + v = (v + 42) % 256; + } + *r++ = v; + } + + return TCL_OK; + } + + critcl::ccommand CDecode {dummy interp objc objv} { + Tcl_Obj *inputPtr, *resultPtr; + int len, rlen, esc; + unsigned char *input, *p, *r, v; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "data"); + return TCL_ERROR; + } + + /* fetch the input data */ + inputPtr = objv[1]; + input = Tcl_GetByteArrayFromObj(inputPtr, &len); + + /* allocate the output buffer */ + resultPtr = Tcl_GetObjResult(interp); + if (Tcl_IsShared(resultPtr)) { + resultPtr = Tcl_DuplicateObj(resultPtr); + Tcl_SetObjResult(interp, resultPtr); + } + r = Tcl_SetByteArrayLength(resultPtr, len); + + /* encode the input */ + for (p = input, esc = 0, rlen = 0; p < input + len; p++) { + if (*p == 61 && esc == 0) { + esc = 1; + continue; + } + v = (*p - 42) % 256; + if (esc) { + v = (v - 42) % 256; + esc = 0; + } + *r++ = v; + rlen++; + } + Tcl_SetByteArrayLength(resultPtr, rlen); + + return TCL_OK; + } + } +} + +if {[info command ::yencode::CEncode] != {}} { + interp alias {} ::yencode::encode {} ::yencode::CEncode + interp alias {} ::yencode::decode {} ::yencode::CDecode +} else { + interp alias {} ::yencode::encode {} ::yencode::Encode + interp alias {} ::yencode::decode {} ::yencode::Decode +} # ------------------------------------------------------------------------- # Description: # Pop the nth element off a list. Used in options processing. # Index: modules/base64/yencode.test ================================================================== --- modules/base64/yencode.test +++ modules/base64/yencode.test @@ -4,18 +4,44 @@ # # ------------------------------------------------------------------------- # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- -# RCS: @(#) $Id: yencode.test,v 1.3 2003/01/26 00:38:28 patthoyts Exp $ +# RCS: @(#) $Id: yencode.test,v 1.3.2.1 2003/05/13 01:04:27 patthoyts Exp $ +# ------------------------------------------------------------------------- +# Initialize the test package +# if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::* } -package require yencode +# ------------------------------------------------------------------------- +# Ensure we test _this_ local copy and one installed somewhere else. +# +package forget yencode +catch {namespace delete ::yencode} +if {[catch {source [file join [file dirname [info script]] yencode.tcl]} msg]} { + puts "skipped [file tail [info script]]: $msg" + return +} + +# ------------------------------------------------------------------------- +# Setup any constraints +# + +# ------------------------------------------------------------------------- +# Now the package specific tests.... +# ------------------------------------------------------------------------- + +if {[info command ::yencode::CEncode] != {}} { + puts "- yencode [package provide yencode] (critcl based)" +} else { + puts "- yencode [package provide yencode] (pure tcl)" +} + proc ::yencode::loaddata {filename {translation auto}} { set f [open $filename r] fconfigure $f -translation $translation set data [read $f] @@ -32,10 +58,44 @@ set dec [::yencode::ydecode $enc] set chk [::yencode::loaddata $datafile] string match $dec $chk } {0} + +# ------------------------------------------------------------------------- + +foreach {n in out} { + 0 A {k} + 1 ABC {klm} + 2 \0\1\2 {*+,} + 3 "\r\n\t" {743} + 4 "\xd6\xe0\xe3" {=*=4=7} +} { + test yencode-2.$n.a {check the pure tcl encode} { + list [catch {::yencode::Encode $in} r] $r + } [list 0 $out] + test yencode-2.$n.b {check the pure tcl decode} { + list [catch {::yencode::Decode $out} r] $r + } [list 0 $in] +} + +if {[info command ::yencode::CEncode] != {}} { + foreach {n in out} { + 0 A {k} + 1 ABC {klm} + 2 \0\1\2 {*+,} + 3 "\r\n\t" {743} + 4 "\xd6\xe0\xe3" {=*=4=7} + } { + test yencode-3.$n.a {check the critcl encode} { + list [catch {::yencode::Encode $in} r] $r + } [list 0 $out] + test yencode-3.$n.b {check the critcl decode} { + list [catch {::yencode::Decode $out} r] $r + } [list 0 $in] + } +} # ------------------------------------------------------------------------- catch { unset datafile DELETED modules/calendar/ChangeLog Index: modules/calendar/ChangeLog ================================================================== --- modules/calendar/ChangeLog +++ /dev/null @@ -1,25 +0,0 @@ -2003-04-11 Andreas Kupries - - * pkgIndex.tcl: - * gregorian.tcl: Fixed bug #614591. Set version of the package to - 0.2 - -2002-02-14 Andreas Kupries - - * gregorian.tcl: Frink run. - -2002-01-14 Kevin Kenny - - * gregorian.tcl, gregorian.test (EYMWDToJulianDay): - Added functionality for 'Nth weekday from the end of a month', - needed, among other things, to do DST rules in most US locales. - -2002-01-11 Kevin Kenny - - * ChangeLog, calendar.tcl, gregorian.tcl, gregorian.test: - * pkgIndex.tcl, tclIndex: - Created an initial 'calendar' module. Functionality at this - point includes conversion between Julian Day and several formats: - year/day-of-year, year/month/day, year/week/day-of-week, and - year/month/day-of-week-in-month (e.g, the second Friday of - February). DELETED modules/calendar/calendar.tcl Index: modules/calendar/calendar.tcl ================================================================== --- modules/calendar/calendar.tcl +++ /dev/null @@ -1,23 +0,0 @@ -#---------------------------------------------------------------------- -# -# calendar.tcl -- -# -# This file is the main 'package provide' script for the -# 'calendar' package. The package provides various commands for -# manipulating dates and times. -# -# RCS:$(@) $Id: calendar.tcl,v 1.2 2003/04/11 19:10:42 andreas_kupries Exp $ - -package require Tcl 8.2 - -namespace eval ::calendar { - - variable version 0.2 - - variable home [file join [pwd] [file dirname [info script]]] - if { [lsearch -exact $::auto_path $home] == -1 } { - lappend ::auto_path $home - } - - package provide [namespace tail [namespace current]] $version -} DELETED modules/calendar/gregorian.tcl Index: modules/calendar/gregorian.tcl ================================================================== --- modules/calendar/gregorian.tcl +++ /dev/null @@ -1,772 +0,0 @@ -#---------------------------------------------------------------------- -# -# gregorian.tcl -- -# -# Routines for manipulating dates on the Gregorian calendar. -# -# Copyright (c) 2002 by Kevin B. Kenny. All rights reserved. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: gregorian.tcl,v 1.4 2003/04/11 19:10:42 andreas_kupries Exp $ -# -#---------------------------------------------------------------------- - -package require Tcl 8.2; # Not tested with earlier releases - -#---------------------------------------------------------------------- -# -# Many of the routines in this file accept the name of a "date array" -# in the caller's scope. This array is used to hold the various fields -# of a civil date. While few if any routines use or set all the fields, -# the fields, where used or set, are always interpreted the same way. -# The complete listing of fields used is: -# -# ERA -- The era in the given calendar to which a year refers. -# In the Julian and Gregorian calendars, the ERA is one -# of the constants, BCE or CE (Before the Common Era, -# or Common Era). The conventional names, BC and AD -# are also accepted. In other local calendars, the ERA -# may be some other value, for instance, the name of -# an emperor, AH (anno Hegirae or anno Hebraica), AM -# (anno mundi), etc. -# -# YEAR - The number of the year within the given era. -# -# FISCAL_YEAR - The year to which 'WEEK_OF_YEAR' (see below) -# refers. Near the beginning or end of a given -# calendar year, the fiscal week may be the first -# week of the following year or the last week of the -# preceding year. -# -# MONTH - The number of the month within the given year. Month -# numbers run from 1 to 12 in the common calendar; some -# local calendars include a thirteenth month in some years. -# -# WEEK_OF_YEAR - The week number in the given year. On the usual -# fiscal calendar, the week may range from 1 to 53. -# -# DAY_OF_WEEK_IN_MONTH - The ordinal number of a weekday within -# the given month. Used in conjunction -# with DAY_OF_WEEK to express constructs like, -# 'the fourth Thursday in November'. -# Values run from 1 to the number of weeks in -# the month. Negative values are interpreted -# from the end of the month; allowing -# for 'the last Sunday of October'; 'the -# next-to-last Sunday of October', etc. -# -# DAY_OF_YEAR - The day of the given year. (The first day of a year -# is day number 1.) -# -# DAY_OF_MONTH - The day of the given month. -# -# DAY_OF_WEEK - The number of the day of the week. Sunday = 0, -# Monday = 1, ..., Saturday = 6. In locales where -# a day other than Sunday is the first day of the week, -# the values of the days before it are incremented by -# seven; thus, in an ISO locale, Monday = 1, ..., -# Sunday == 7. -# -# The following fields in a date array change the behavior of FISCAL_YEAR -# and WEEK_OF_YEAR: -# -# DAYS_IN_FIRST_WEEK - The minimum number of days that a week must -# have before it is accounted the first week -# of a year. For the ISO fiscal calendar, this -# number is 4. -# -# FIRST_DAY_OF_WEEK - The day of the week (Sunday = 0, ..., Saturday = 6) -# on which a new fiscal year begins. Days greater -# than 6 are reduced modulo 7. -# -#---------------------------------------------------------------------- - -#---------------------------------------------------------------------- -# -# The calendar::CommonCalendar namespace contains code for handling -# dates on the 'common calendar' -- the civil calendar in virtually -# the entire Western world. The common calendar is the Julian -# calendar prior to a certain date that varies with the locale, and -# the Gregorian calendar thereafter. -# -#---------------------------------------------------------------------- - -namespace eval ::calendar::CommonCalendar { - - namespace export WeekdayOnOrBefore - namespace export CivilYearToAbsolute - - # Number of days in the months in a common year and a leap year - - variable daysInMonth [list 31 28 31 30 31 30 31 31 30 31 30 31] - variable daysInMonthInLeapYear [list 31 29 31 30 31 30 31 31 30 31 30 31] - - # Number of days preceding the start of a given month in a leap year - # and common year. For convenience, these lists are zero based and - # contain a thirteenth month; [lindex $daysInPriorMonths 3], for instance - # gives the number of days preceding 1 March, and - # [lindex $daysInPriorMonths 13] gives the number of days in a common - # year. - - variable daysInPriorMonths - variable daysInPriorMonthsInLeapYear - - set dp 0 - set dply 0 - set daysInPriorMonths [list {} 0] - set daysInPriorMonthsInLeapYear [list {} 0] - foreach d $daysInMonth dly $daysInMonthInLeapYear { - lappend daysInPriorMonths [incr dp $d] - lappend daysInPriorMonthsInLeapYear [incr dply $dly] - } - unset d dly dp dply - -} - -#---------------------------------------------------------------------- -# -# ::calendar::CommonCalendar::WeekdayOnOrBefore -- -# -# Determine the last time that a given day of the week occurs -# on or before a given date (e.g., Sunday on or before January 2). -# -# Parameters: -# weekday -- Day of the week (Sunday = 0 .. Saturday = 6) -# Days greater than 6 are interpreted modulo 7. -# j -- Julian day number. -# -# Results: -# Returns the Julian day number of the desired day. -# -# Side effects: -# None. -# -#---------------------------------------------------------------------- - -proc ::calendar::CommonCalendar::WeekdayOnOrBefore { weekday j } { - # Normalize weekday, Monday=0 - set k [expr { ($weekday + 6) % 7 }] - return [expr { $j - ( $j - $k ) % 7 }] -} - -#---------------------------------------------------------------------- -# -# ::calendar::CommonCalendar::CivilYearToAbsolute -- -# -# Calculate an "absolute" year number, that is, the count of -# years from the common epoch, 1 B.C.E. -# -# Parameters: -# dateVar -- Name of an array in caller's scope containing the -# fields ERA (BCE or CE) and YEAR. -# -# Results: -# Returns an absolute year number. The years in the common era -# have their natural numbers; the year 1 BCE returns 0, 2 BCE returns -# -1, and so on. -# -# Side effects: -# None. -# -# The popular names BC and AD are accepted as synonyms for BCE and CE. -# -#---------------------------------------------------------------------- - -proc ::calendar::CommonCalendar::CivilYearToAbsolute { dateVar } { - - upvar 1 $dateVar date - switch -exact $date(ERA) { - BCE - BC { - return [expr { 1 - $date(YEAR) }] - } - CE - AD { - return $date(YEAR) - } - default { - return -code error "Unknown era \"$date(ERA)\"" - } - } -} - -#---------------------------------------------------------------------- -# -# The calendar::GregorianCalendar namespace contains codes specific to the -# Gregorian calendar. These codes deal specifically with dates after -# the conversion from the Julian to Gregorian calendars (which are -# various dates in various locales; 1582 in most Catholic countries, -# 1752 in most English-speaking countries, 1917 in Russia, ...). -# If presented with earlier dates, these codes will compute based on -# a hypothetical proleptic calendar. -# -#---------------------------------------------------------------------- - -namespace eval calendar::GregorianCalendar { - - namespace import ::calendar::CommonCalendar::WeekdayOnOrBefore - namespace import ::calendar::CommonCalendar::CivilYearToAbsolute - - namespace export IsLeapYear - - namespace export EYMDToJulianDay - namespace export EYDToJulianDay - namespace export EFYWDToJulianDay - namespace export EYMWDToJulianDay - - namespace export JulianDayToEYD - namespace export JulianDayToEYMD - namespace export JulianDayToEFYWD - namespace export JulianDayToEYMWD - - # The Gregorian epoch -- 31 December, 1 B.C.E, Gregorian, expressed - # as a Julian day number. (This date is 2 January, 1 C.E., in the - # proleptic Julian calendar.) - - variable epoch 1721425 - - # Common years - these years, mod 400, are the irregular common years - # of the Gregorian calendar - - variable commonYears - array set commonYears { 100 {} 200 {} 300 {} } - -} - -#---------------------------------------------------------------------- -# -# ::calendar::GregorianCalendar::IsLeapYear -# -# Tests whether a year is a leap year. -# -# Parameters: -# -# y - Year number of the common era. The year 0 represents -# 1 BCE of the proleptic calendar, -1 represents 2 BCE, etc. -# -# Results: -# -# Returns 1 if the given year is a leap year, 0 otherwise. -# -# Side effects: -# -# None. -# -#---------------------------------------------------------------------- - -proc ::calendar::GregorianCalendar::IsLeapYear { y } { - - variable commonYears - return [expr { ( $y % 4 ) == 0 - && ![info exists commonYears([expr { $y % 400 }])] }] - -} - -#---------------------------------------------------------------------- -# -# ::calendar::GregorianCalendar::EYMDToJulianDay -# -# Convert a date on the Gregorian calendar expressed as -# era (BCE or CE), year in the era, month number (January = 1) -# and day of the month to a Julian Day Number. -# -# Parameters: -# -# dateArray -- Name of an array in caller's scope containing -# keys ERA, YEAR, MONTH, and DAY_OF_MONTH -# -# Results: -# -# Returns the Julian Day Number of the day that starts with -# noon of the given date. -# -# Side effects: -# -# None. -# -#---------------------------------------------------------------------- - -proc ::calendar::GregorianCalendar::EYMDToJulianDay { dateArray } { - - upvar 1 $dateArray date - - variable epoch - variable ::calendar::CommonCalendar::daysInPriorMonths - variable ::calendar::CommonCalendar::daysInPriorMonthsInLeapYear - - # Convert era and year to an absolute year number - - set y [calendar::CommonCalendar::CivilYearToAbsolute date] - set ym1 [expr { $y - 1 }] - - # Calculate the Julian day - - return [expr { $epoch - + $date(DAY_OF_MONTH) - + ( [IsLeapYear $y] ? - [lindex $daysInPriorMonthsInLeapYear $date(MONTH)] - : [lindex $daysInPriorMonths $date(MONTH)] ) - + ( 365 * $ym1 ) - + ( $ym1 / 4 ) - - ( $ym1 / 100 ) - + ( $ym1 / 400 ) }] - -} - -#---------------------------------------------------------------------- -# -# ::calendar::GregorianCalendar::EYDToJulianDay -- -# -# Convert a date expressed in the Gregorian calendar as era (BCE or CE), -# year, and day-of-year to a Julian Day Number. -# -# Parameters: -# -# dateArray -- Name of an array in caller's scope containing -# keys ERA, YEAR, and DAY_OF_YEAR -# -# Results: -# -# Returns the Julian Day Number corresponding to noon of the given -# day. -# -# Side effects: -# -# None. -# -#---------------------------------------------------------------------- - -proc ::calendar::GregorianCalendar::EYDToJulianDay { dateArray } { - - upvar 1 $dateArray date - variable epoch - - set y [CivilYearToAbsolute date] - set ym1 [expr { $y - 1 }] - - return [expr { $epoch - + $date(DAY_OF_YEAR) - + ( 365 * $ym1 ) - + ( $ym1 / 4 ) - - ( $ym1 / 100 ) - + ( $ym1 / 400 ) }] - -} - -#---------------------------------------------------------------------- -# -# ::calendar::GregorianCalendar::EFYWDToJulianDay -- -# -# Convert a date expressed in the system of era, fiscal year, -# week number and day number to a Julian Day Number. -# -# Parameters: -# -# dateArray -- Name of an array in caller's scope that contains -# keys ERA, FISCAL_YEAR, WEEK_OF_YEAR, and DAY_OF_WEEK, -# and optionally contains DAYS_IN_FIRST_WEEK -# and FIRST_DAY_OF_WEEK. -# daysInFirstWeek -- Minimum number of days that a week must -# have to be considered the first week of a -# fiscal year. Default is 4, which gives -# ISO8601:1988 semantics. The parameter is -# used only if the 'dateArray' does not -# contain a DAYS_IN_FIRST_WEEK key. -# firstDayOfWeek -- Ordinal number of the first day of the week -# (Sunday = 0, Monday = 1, etc.) Default is -# 1, which gives ISO8601:1988 semantics. The -# parameter is used only if 'dateArray' does not -# contain a DAYS_IN_FIRST_WEEK key.n -# -# Results: -# -# Returns the Julian Calendar Day corresponding to noon of the given -# day. -# -# Side effects: -# -# None. -# -# The ERA element of the array is BCE or CE. -# The FISCAL_YEAR is the year number in the given era. The year is relative -# to the fiscal week; hence days that are early in January or late in -# December may belong to a different year than the calendar year. -# The WEEK_OF_YEAR is the ordinal number of the week within the year. -# Week 1 is the week beginning on the specified FIRST_DAY_OF_WEEK -# (Sunday = 0, Monday = 1, etc.) and containing at least DAYS_IN_FIRST_WEEK -# days (or, equivalently, containing January DAYS_IN_FIRST_WEEK) -# The DAY_OF_WEEK is Sunday=0, Monday=1, ..., if FIRST_DAY_OF_WEEK -# is 0, or Monday=1, Tuesday=2, ..., Sunday=7 if FIRST_DAY_OF_WEEK -# is 1. -# -#---------------------------------------------------------------------- - -proc ::calendar::GregorianCalendar::EFYWDToJulianDay { dateArray - {daysInFirstWeek 4} - {firstDayOfWeek 1} } { - upvar 1 $dateArray date - - # Use parameters to supply defaults if the array doesn't - # have conversion rules. - - if { ![info exists date(DAYS_IN_FIRST_WEEK)] } { - set date(DAYS_IN_FIRST_WEEK) $daysInFirstWeek - } - if { ![info exists date(FIRST_DAY_OF_WEEK)] } { - set date(FIRST_DAY_OF_WEEK) $firstDayOfWeek - } - - # Find the start of the fiscal year - - set date2(ERA) $date(ERA) - set date2(YEAR) $date(FISCAL_YEAR) - set date2(MONTH) 1 - set date2(DAY_OF_MONTH) $date(DAYS_IN_FIRST_WEEK) - set jd [WeekdayOnOrBefore \ - $date(FIRST_DAY_OF_WEEK) \ - [EYMDToJulianDay date2]] - - # Add the weeks and days. - - return [expr { $jd - + ( 7 * ( $date(WEEK_OF_YEAR) - 1 ) ) - + $date(DAY_OF_WEEK) - $date(FIRST_DAY_OF_WEEK) }] - -} - -#---------------------------------------------------------------------- -# -# ::calendar::GregorianCalendar::EYMWDToJulianDay -- -# -# Given era, year, month, and day of week in month (e.g. "first Tuesday") -# derive a Julian day number. -# -# Parameters: -# dateVar -- Name of an array in caller's scope containing the -# date fields. -# -# Results: -# Returns the desired Julian day number. -# -# Side effects: -# None. -# -# The 'dateVar' array is expected to contain the following keys: -# + ERA - The constant 'BCE' or 'CE'. -# + YEAR - The Gregorian calendar year -# + MONTH - The month of the year (1 = January .. 12 = December) -# + DAY_OF_WEEK - The day of the week (Sunday = 0 .. Saturday = 6) -# If day of week is 7 or greater, it is interpreted -# modulo 7. -# + DAY_OF_WEEK_IN_MONTH - The day of week within the month -# (1 = first XXXday, 2 = second XXDday, ... -# also -1 = last XXXday, -2 = next-to-last -# XXXday, ...) -# -#---------------------------------------------------------------------- - -proc ::calendar::GregorianCalendar::EYMWDToJulianDay { dateVar } { - - upvar 1 $dateVar date - - variable epoch - - # Are we counting from the beginning or the end of the month? - - array set date2 [array get date] - if { $date(DAY_OF_WEEK_IN_MONTH) >= 0 } { - - # When counting from the start of the month, begin by - # finding the 'zeroeth' - the last day of the prior month. - # Note that it's ok to give EYMDToJulianDay a zero day-of-month! - - set date2(DAY_OF_MONTH) 0 - - } else { - - # When counting from the end of the month, the 'zeroeth' - # is the seventh of the following month. Note that it's ok - # to give EYMDToJulianDay a thirteenth month! - - incr date2(MONTH) - set date2(DAY_OF_MONTH) 7 - - } - - set zeroethDayOfMonth [EYMDToJulianDay date2] - - # Find the zeroeth weekday in the given month - - set wd0 [WeekdayOnOrBefore $date(DAY_OF_WEEK) $zeroethDayOfMonth] - - # Add the requisite number of weeks - - return [expr { $wd0 + 7 * $date(DAY_OF_WEEK_IN_MONTH) }] - -} - -#---------------------------------------------------------------------- -# -# ::calendar::GregorianCalendar::JulianDayToEYD -- -# -# Given a Julian day number, compute era, year, and day of year. -# -# Parameters: -# j - Julian day number -# dateVar - Name of an array in caller's scope that will receive the -# date fields. -# -# Results: -# Returns an absolute year; that is, returns the year number for -# years in the Common Era; returns 0 for 1 B.C.E., -1 for 2 B.C.E., -# and so on. -# -# Side effects: -# The 'dateVar' array is populated with the following: -# + ERA - The era corresponding to the given Julian Day. -# (BCE or CE) -# + YEAR - The year of the given era. -# + DAY_OF_YEAR - The day within the given year (1 = 1 January, -# etc.) -# -#---------------------------------------------------------------------- - -proc ::calendar::GregorianCalendar::JulianDayToEYD { j dateVar } { - - upvar 1 $dateVar date - - variable epoch - - # Absolute day number relative to the Gregorian epoch - - set day [expr { $j - $epoch - 1}] - - # Count 400-year cycles - - set year 1 - set n [expr { $day / 146097 }] - incr year [expr { 400 * $n }] - set day [expr { $day % 146097 }] - - # Count centuries - - set n [expr { $day / 36524 }] - set day [expr { $day % 36524 }] - if { $n > 3 } { # Last day of 1600, 2000, 2400... - set n 3 - incr day 36524 - } - incr year [expr { 100 * $n }] - - # Count 4-year cycles - - set n [expr { $day / 1461 }] - set day [expr { $day % 1461 }] - incr year [expr { 4 * $n }] - - # Count years - - set n [expr { $day / 365 }] - set day [expr { $day % 365 }] - if { $n > 3 } { # December 31 of a leap year - set n 3 - incr day 365 - } - incr year $n - - # Determine the era - - if { $year <= 0 } { - set date(YEAR) [expr { 1 - $year }] - set date(ERA) BCE - } else { - set date(YEAR) $year - set date(ERA) CE - } - - # Determine day of year. - - set date(DAY_OF_YEAR) [expr { $day + 1 }] - return $year - -} - -#---------------------------------------------------------------------- -# -# ::calendar::GregorianCalendar::JulianDayToEYMD -- -# -# Given a Julian day number, compute era, year, month, and day -# of the Gregorian calendar. -# -# Parameters: -# j - Julian day number -# dateVar - Name of a variable in caller's scope that will be -# filled in with the fields, ERA, YEAR, MONTH, DAY_OF_MONTH, -# and DAY_OF_YEAR (this last comes as a side effect of how -# the calculations are performed, but is trustworthy). -# -# Results: -# None. -# -# Side effects: -# Requested fields of dateVar are filled in. -# -#---------------------------------------------------------------------- - -proc ::calendar::GregorianCalendar::JulianDayToEYMD { j dateVar } { - - upvar 1 $dateVar date - - variable ::calendar::CommonCalendar::daysInMonth - variable ::calendar::CommonCalendar::daysInMonthInLeapYear - - set year [JulianDayToEYD $j date] - set day $date(DAY_OF_YEAR) - - if { [IsLeapYear $year] } { - set hath $daysInMonthInLeapYear - } else { - set hath $daysInMonth - } - set month 1 - foreach n $hath { - if { $day <= $n } { - break - } - incr month - set day [expr { $day - $n }] - } - set date(MONTH) $month - set date(DAY_OF_MONTH) $day - - return - -} - -#---------------------------------------------------------------------- -# -# ::calendar::GregorianCalendar::JulianDayToEFYWD -- -# -# Given a julian day number, compute era, fiscal year, fiscal week, -# and day of week in a fiscal calendar based on the Gregorian calendar. -# -# Parameters: -# j - Julian day number -# dateVar - Name of an array in caller's scope that is to receive the -# fields of the date. The array may be prepared with -# DAYS_IN_FIRST_WEEK and FIRST_DAY_OF_WEEK fields to -# change the rule for computing the fiscal week. -# daysInFirstWeek - (Optional) Parameter giving the minimum number -# of days in the first week of a year. Default is 4. -# firstDayOfWeek - (Optional) Parameter giving the day number of the -# first day of a fiscal week (Sunday = 0 .. -# Saturday = 6). Default is 1 (Monday). -# -# Results: -# None. -# -# Side effects: -# The ERA, YEAR, FISCAL_YEAR, DAY_OF_YEAR, WEEK_OF_YEAR, DAY_OF_WEEK, -# DAYS_IN_FIRST_WEEK, and FIRST_DAY_OF_WEEK fields in the 'dateVar' -# array are filled in. -# -# If DAYS_IN_FIRST_WEEK or FIRST_DAY_OF_WEEK fields are present in -# 'dateVar' prior to the call, they override any values passed on the -# command line. -# -#---------------------------------------------------------------------- - -proc ::calendar::GregorianCalendar::JulianDayToEFYWD { j - dateVar - {daysInFirstWeek 4} - {firstDayOfWeek 1} } { - upvar 1 $dateVar date - - if { ![info exists date(DAYS_IN_FIRST_WEEK)] } { - set date(DAYS_IN_FIRST_WEEK) $daysInFirstWeek - } - if { ![info exists date(FIRST_DAY_OF_WEEK)] } { - set date(FIRST_DAY_OF_WEEK) $firstDayOfWeek - } - - # Determine the calendar year of $j - $daysInFirstWeek + 1. - # Guess the fiscal year - - JulianDayToEYD [expr { $j - $daysInFirstWeek + 1 }] date1 - set date1(FISCAL_YEAR) [expr { $date1(YEAR) + 1 }] - - # Determine the start of the fiscal year that we guessed - - set date1(WEEK_OF_YEAR) 1 - set date1(DAY_OF_WEEK) $firstDayOfWeek - set startOfFiscalYear [EFYWDToJulianDay \ - date1 \ - $date(DAYS_IN_FIRST_WEEK) \ - $date(FIRST_DAY_OF_WEEK)] - - # If we guessed high, fix it. - - if { $j < $startOfFiscalYear } { - incr date1(FISCAL_YEAR) -1 - set startOfFiscalYear [EFYWDToJulianDay date1] - } - - set date(FISCAL_YEAR) $date1(FISCAL_YEAR) - - # Get the week number and the day within the week - - set dayOfFiscalYear [expr { $j - $startOfFiscalYear }] - set date(WEEK_OF_YEAR) [expr { ( $dayOfFiscalYear / 7 ) + 1 }] - set date(DAY_OF_WEEK) [expr { ( $dayOfFiscalYear + 1 ) % 7 }] - if { $date(DAY_OF_WEEK) < $date(FIRST_DAY_OF_WEEK) } { - incr date(DAY_OF_WEEK) 7 - } - - return -} - -#---------------------------------------------------------------------- -# -# GregorianCalendar::JulianDayToEYMWD -- -# -# Convert a Julian day number to year, month, day-of-week-in-month -# (e.g., first Tuesday), and day of week. -# -# Parameters: -# j - Julian day number -# dateVar - Name of an array in caller's scope that holds the -# fields of the date. -# -# Results: -# None. -# -# Side effects: -# The ERA, YEAR, MONTH, DAY_OF_MONTH, DAY_OF_WEEK, and -# DAY_OF_WEEK_IN_MONTH fields of the given date are all filled -# in. -# -# Notes: -# DAY_OF_WEEK_IN_MONTH is always positive on return. -# -#---------------------------------------------------------------------- - -proc ::calendar::GregorianCalendar::JulianDayToEYMWD { j dateVar } { - - upvar 1 $dateVar date - - # Compute era, year, month and day - - JulianDayToEYMD $j date - - # Find day of week - - set date(DAY_OF_WEEK) [expr { ( $j + 1 ) % 7 }] - - # Find day of week in month - - set date(DAY_OF_WEEK_IN_MONTH) \ - [expr { ( ( $date(DAY_OF_MONTH) - 1 ) / 7) + 1 }] - - return - -} DELETED modules/calendar/gregorian.test Index: modules/calendar/gregorian.test ================================================================== --- modules/calendar/gregorian.test +++ /dev/null @@ -1,391 +0,0 @@ -#---------------------------------------------------------------------- -# -# calendar.test -- -# -# Tests for [calendar::CommonCalendar] and -# [calendar::GregorianCalendar] -# -# RCS: @(#) $Id: gregorian.test,v 1.2 2002/01/14 17:05:12 kennykb Exp $ -# -#---------------------------------------------------------------------- - -package forget calendar -catch { namespace delete calendar } - -# Direct loading of provide script -- support testing even -# when not installed. And be sure we test the local copy -# and not some later version that may be installed. -source [file join [file dirname [info script]] gregorian.tcl] - -package require tcltest -namespace import -force tcltest::test ::tcltest::cleanupTests - - -#---------------------------------------------------------------------- -# -# TEST CASES -# -#---------------------------------------------------------------------- - -# Unix epoch - -array set gregUnixEpoch { - ERA CE - YEAR 1970 - MONTH 1 - DAY_OF_MONTH 1 -} -set unixEpoch [calendar::GregorianCalendar::EYMDToJulianDay gregUnixEpoch] - -# Procedure that tests EYMDToJulianDay, EYDToJulianDay, JulianDayToEYD, -# and JulianDayToEYMD - -proc testCal { month day year } { - - global unixEpoch - - # Convert the requested date to seconds from the Posix epoch - - set seconds [clock scan $month/$day/$year -gmt true] - - # Convert to days from the Posix epoch - - set days [ expr { $seconds / 86400 }] - - # Test EYMDToJulianDay - - set dateIn(ERA) CE - set dateIn(YEAR) $year - set dateIn(MONTH) $month - set dateIn(DAY_OF_MONTH) $day - set dateIn(DAY_OF_YEAR) \ - [string trimleft [clock format $seconds -gmt true -format %j] 0] - set jcdOut [calendar::GregorianCalendar::EYMDToJulianDay dateIn] - if { $jcdOut - $unixEpoch != $days } { - error "date $month/$day/$year julian day is $jcdout\ - should be [expr $days + $unixEpoch]" - } - - # Test JulianDayToEYMD and its internal call to JulianDayToEYD - - calendar::GregorianCalendar::JulianDayToEYMD $jcdOut dateOut - foreach f {ERA YEAR DAY_OF_YEAR MONTH DAY_OF_MONTH} { - if { [string compare $dateIn($f) $dateOut($f)] } { - error "date $month/$day/$year field $f\ - is $dateOut($f) should be $dateIn($f)" - } - } - - # Test EYDToJulianDay (possible because JulianDayToEYMD leaves - # DAY_OF_YEAR - - set jcdOut2 [calendar::GregorianCalendar::EYDToJulianDay dateOut] - if { $jcdOut2 - $unixEpoch != $days } { - error "date $month/$day/$year julian day is $jcdout2\ - should be [expr $days + $unixEpoch]" - } - - -} - -# Procedure that tests EFYWDToJulianDay and JulianDayToEFYWD. Inputs are -# fiscal year, week, day, calendar year, month, and day of month. Conversion -# in both directions is tested. - -proc testISO { fy w d cy m dm } { - set date(ERA) CE - set date(FISCAL_YEAR) $fy - set date(WEEK_OF_YEAR) $w - set date(DAY_OF_WEEK) $d - set dayNo [calendar::GregorianCalendar::EFYWDToJulianDay date] - calendar::GregorianCalendar::JulianDayToEYMD $dayNo date2 - if { $date2(YEAR) != $cy - || $date2(MONTH) != $m - || $date2(DAY_OF_MONTH) != $dm } { - error "[info level 0]: bad date should be $cy-$m-$dm:\ - year $date2(YEAR) month $date2(MONTH) day $date2(DAY_OF_MONTH)" - } - - set date3(ERA) CE - set date3(YEAR) $cy - set date3(MONTH) $m - set date3(DAY_OF_MONTH) $dm - set dayNo [calendar::GregorianCalendar::EYMDToJulianDay date3] - calendar::GregorianCalendar::JulianDayToEFYWD $dayNo date4 - if { $date4(FISCAL_YEAR) != $fy - || $date4(WEEK_OF_YEAR) != $w - || $date4(DAY_OF_WEEK) != $d } { - error "[info level 0]: bad date should be $fy-W$w-$d: - year $date4(FISCAL_YEAR) week $date4(WEEK_OF_YEAR) day $date4(DAY_OF_WEEK)" - } - -} - -# Procedure that tests day-of-week-in-month for a given year-month-day. -# Assumes that days of month are presented in order. - -proc testWeekInMonth { y m d } { - global count lastYM - if { ![info exists lastYM] - || [string compare $lastYM [list $y $m]] } { - set lastYM [list $y $m] - for { set dw 0 } { $dw < 7 } { incr dw } { - set count($dw) 0 - } - } - set date(ERA) CE - set date(YEAR) $y - set date(MONTH) $m - set date(DAY_OF_MONTH) $d - set jd [calendar::GregorianCalendar::EYMDToJulianDay date] - calendar::GregorianCalendar::JulianDayToEYMWD $jd date2 - set s [clock scan "$m/$d/$y" -gmt true] - set dw [clock format $s -format "%w" -gmt true] - if { $dw != $date2(DAY_OF_WEEK) } { - error "JulianDayToEYMWD computed wrong day\ - $date2(DAY_OF_WEEK) for $y-$m-$d should be $dw" - } - incr count($dw) - if { $count($dw) != $date2(DAY_OF_WEEK_IN_MONTH) } { - error "JulianDateToEYMD computed wrong week\ - $date2(DAY_OF_WEEK_IN_MONTH) for $y-$m-$d\ - should be $count($dw)" - } - foreach field {ERA YEAR MONTH DAY_OF_WEEK_IN_MONTH DAY_OF_WEEK} { - set date3($field) $date2($field) - } - set jd2 [calendar::GregorianCalendar::EYMWDToJulianDay date3] - unset date2 date3 - if { $jd2 != $jd } { - error "EYMDToJulianDate computed wrong day $jd2\ - for $y-$m-$d should be $jd" - } - return -} - -# Procedure that tests day-of-week-from-end-ofmonth for a given year-month-day. -# Assumes that days of month are presented in reverse order. - -proc testWeekFromEndOfMonth { y m d } { - global count lastYM - if { ![info exists lastYM] - || [string compare $lastYM [list $y $m]] } { - set lastYM [list $y $m] - for { set dw 0 } { $dw < 7 } { incr dw } { - set count($dw) 0 - } - } - set date(ERA) CE - set date(YEAR) $y - set date(MONTH) $m - set date(DAY_OF_MONTH) $d - set jd [calendar::GregorianCalendar::EYMDToJulianDay date] - - set s [clock scan "$m/$d/$y" -gmt true] - set dw [clock format $s -format "%w" -gmt true] - incr count($dw) -1 - - foreach field {ERA YEAR MONTH} { - set date2($field) $date($field) - } - set date2(DAY_OF_WEEK_IN_MONTH) $count($dw) - set date2(DAY_OF_WEEK) $dw - set jd2 [calendar::GregorianCalendar::EYMWDToJulianDay date2] - if { $jd2 != $jd } { - error "EYMWDToJulianDate computed wrong day $jd2\ - for $y-$m-$d (week $count($dw), day $dw) should be $jd" - } - return -} - -test calendar-1.1 {Julian Day converting to/from Gregorian year-month-day} { - - set n 0 - for { set year 1902 } { $year < 2038 } { incr year } { - - # Test the first and last day of each month. Test 28 February - # always, 29 February of leap years. - - testCal 1 1 $year - testCal 1 31 $year - testCal 2 28 $year - if { $year % 4 == 0} { - testCal 2 29 $year - incr n - } - testCal 3 1 $year - testCal 3 31 $year - testCal 4 1 $year - testCal 4 30 $year - testCal 5 1 $year - testCal 5 31 $year - testCal 6 1 $year - testCal 6 30 $year - testCal 7 1 $year - testCal 7 31 $year - testCal 8 1 $year - testCal 8 31 $year - testCal 9 1 $year - testCal 9 30 $year - testCal 10 1 $year - testCal 10 31 $year - testCal 11 1 $year - testCal 11 30 $year - testCal 12 1 $year - testCal 12 31 $year - incr n 24 - } - - set n -} 3298 - -test calendar-2.1 {ISO date conversions} { - - # Test the first and last week of a 52- and 53-week year beginning on each - # possible day of week - - testISO 2000 52 1 2000 12 25 - testISO 2000 52 7 2000 12 31 - testISO 2001 1 1 2001 1 1 - testISO 2001 1 7 2001 1 7 - testISO 2001 2 1 2001 1 8 - - testISO 2001 52 1 2001 12 24 - testISO 2001 52 7 2001 12 30 - testISO 2002 1 1 2001 12 31 - testISO 2002 1 2 2002 1 1 - testISO 2002 1 7 2002 1 6 - testISO 2002 2 1 2002 1 7 - - testISO 2002 52 1 2002 12 23 - testISO 2002 52 7 2002 12 29 - testISO 2003 1 1 2002 12 30 - testISO 2003 1 2 2002 12 31 - testISO 2003 1 3 2003 1 1 - testISO 2003 1 7 2003 1 5 - testISO 2003 2 1 2003 1 6 - - testISO 2003 52 1 2003 12 22 - testISO 2003 52 7 2003 12 28 - testISO 2004 1 1 2003 12 29 - testISO 2004 1 3 2003 12 31 - testISO 2004 1 4 2004 1 1 - testISO 2004 1 7 2004 1 4 - testISO 2004 2 1 2004 1 5 - - testISO 2004 52 1 2004 12 20 - testISO 2004 52 7 2004 12 26 - testISO 2004 53 1 2004 12 27 - testISO 2004 53 5 2004 12 31 - testISO 2004 53 6 2005 1 1 - testISO 2004 53 7 2005 1 2 - testISO 2005 1 1 2005 1 3 - testISO 2005 1 7 2005 1 9 - testISO 2005 2 1 2005 1 10 - - testISO 2005 52 1 2005 12 26 - testISO 2005 52 6 2005 12 31 - testISO 2005 52 7 2006 1 1 - testISO 2006 1 1 2006 1 2 - testISO 2006 1 7 2006 1 8 - testISO 2006 2 1 2006 1 9 - - testISO 2009 52 1 2009 12 21 - testISO 2009 52 7 2009 12 27 - testISO 2009 53 1 2009 12 28 - testISO 2009 53 4 2009 12 31 - testISO 2009 53 5 2010 1 1 - testISO 2009 53 7 2010 1 3 - testISO 2010 1 1 2010 1 4 - testISO 2010 1 7 2010 1 10 - testISO 2010 2 1 2010 1 11 - -} {} - -test calendar-3.1 {Day-of-week-in-month} { - # Test each day of month for one month of each possible length - # starting on each day of the week. - - foreach { y m l } { - 2001 1 31 - 2001 11 30 - 2001 2 28 - 2001 3 31 - 2001 4 30 - 2001 5 31 - 2001 6 30 - 2001 7 31 - 2001 8 31 - 2001 9 30 - 2002 2 28 - 2002 3 31 - 2002 4 30 - 2003 2 28 - 2003 3 31 - 2003 4 30 - 2004 2 29 - 2004 9 30 - 2005 2 28 - 2006 2 28 - 2008 2 29 - 2009 2 28 - 2010 2 28 - 2012 2 29 - 2016 2 29 - 2020 2 29 - 2024 2 29 - 2028 2 29 - } { - for { set d 1 } { $d <= $l } { incr d } { - testWeekInMonth $y $m $d - } - } - concat -} {} - -test calendar-3.2 {Day-of-week from end of month} { - # Test each day of month for one month of each possible length - # starting on each day of the week. - - foreach { y m l } { - 2001 1 31 - 2001 11 30 - 2001 2 28 - 2001 3 31 - 2001 4 30 - 2001 5 31 - 2001 6 30 - 2001 7 31 - 2001 8 31 - 2001 9 30 - 2002 2 28 - 2002 3 31 - 2002 4 30 - 2003 2 28 - 2003 3 31 - 2003 4 30 - 2004 2 29 - 2004 9 30 - 2005 2 28 - 2006 2 28 - 2008 2 29 - 2009 2 28 - 2010 2 28 - 2012 2 29 - 2016 2 29 - 2020 2 29 - 2024 2 29 - 2028 2 29 - } { - for { set d $l } { $d >= 1 } { incr d -1 } { - testWeekFromEndOfMonth $y $m $d - } - } - concat -} {} - -cleanupTests - -# Local Variables: -# mode:tcl -# End: DELETED modules/calendar/pkgIndex.tcl Index: modules/calendar/pkgIndex.tcl ================================================================== --- modules/calendar/pkgIndex.tcl +++ /dev/null @@ -1,2 +0,0 @@ -if { ! [package vsatisfies [package provide Tcl] 8.2] } {return} -package ifneeded calendar 0.2 [list source [file join $dir calendar.tcl]] DELETED modules/calendar/tclIndex Index: modules/calendar/tclIndex ================================================================== --- modules/calendar/tclIndex +++ /dev/null @@ -1,19 +0,0 @@ -# Tcl autoload index file, version 2.0 -# This file is generated by the "auto_mkindex" command -# and sourced to set up indexing information for one or -# more commands. Typically each line is a command that -# sets an element in the auto_index array, where the -# element name is the name of a command and the value is -# a script that loads the command. - -set auto_index(::calendar::CommonCalendar::WeekdayOnOrBefore) [list source [file join $dir gregorian.tcl]] -set auto_index(::calendar::CommonCalendar::CivilYearToAbsolute) [list source [file join $dir gregorian.tcl]] -set auto_index(::calendar::GregorianCalendar::IsLeapYear) [list source [file join $dir gregorian.tcl]] -set auto_index(::calendar::GregorianCalendar::EYMDToJulianDay) [list source [file join $dir gregorian.tcl]] -set auto_index(::calendar::GregorianCalendar::EYDToJulianDay) [list source [file join $dir gregorian.tcl]] -set auto_index(::calendar::GregorianCalendar::EFYWDToJulianDay) [list source [file join $dir gregorian.tcl]] -set auto_index(::calendar::GregorianCalendar::EYMWDToJulianDay) [list source [file join $dir gregorian.tcl]] -set auto_index(::calendar::GregorianCalendar::JulianDayToEYD) [list source [file join $dir gregorian.tcl]] -set auto_index(::calendar::GregorianCalendar::JulianDayToEYMD) [list source [file join $dir gregorian.tcl]] -set auto_index(::calendar::GregorianCalendar::JulianDayToEFYWD) [list source [file join $dir gregorian.tcl]] -set auto_index(::calendar::GregorianCalendar::JulianDayToEYMWD) [list source [file join $dir gregorian.tcl]] DELETED modules/cmdline/ChangeLog Index: modules/cmdline/ChangeLog ================================================================== --- modules/cmdline/ChangeLog +++ /dev/null @@ -1,105 +0,0 @@ -2003-04-11 Andreas Kupries - - * typedCmdline.tcl: Fixed bug #614591. See also last entry, this - file was forgotten. - -2003-04-10 Andreas Kupries - - * pkgIndex.tcl: - * cmdline.tcl: - * cmdline.man: Fixed bug #648679. Fixed bug #614591. Set version - of the package to to 1.2.1 - - * urn-scheme.tcl: Fixed bug #614591. Set version - of the package to to 1.2.1 - -2003-02-23 David N. Welton - - * cmdline.tcl (cmdline::getfiles): Use string map instead of - regsub. - -2002-08-30 Andreas Kupries - - * typeCmdline.tcl: Updated 'info exist' to 'info exists'. - -2002-04-24 Andreas Kupries - - * Applied patch #540313 on behalf of Melissa Chawla - and Don Porter - . - - * cmdline.test: - * cmdline.tcl: Added getKnownOpt and getKnownOptions procedures - to the API. The procedures offer a way for arguments that are - not in the optionList to be ignored. This way, you can have - two independant locations in your application where - commandline arguments are parsed. I bumped the package - version to 1.2. - - * cmdline.man: Updated documentation. - -2002-04-14 Andreas Kupries - - * cmdline.man: Added doctools manpage. - -2001-10-16 Andreas Kupries - - * cmdline.n: - * cmdline.tcl: - * pkgIndex.tcl: Version up to 1.1.1 - -2001-10-12 Andreas Kupries - - * cmdline.tcl: Corrected the inline documentation to reflect what - is actually happening. Problem reported by Glenn Jackman - , Item #46650. - -2001-07-31 Andreas Kupries - - * cmdline.n: Added manpage [446584]. - -2001-06-21 Andreas Kupries - - * typedCmdline.tcl: - * cmdline.tcl: Fixed dubious code reported by frink. - -2000-05-03 Brent Welch - - * cmdline.tcl: Changed cmdline::getopt to set boolean arguments to - 0 or 1 explicitly. Previously it just set the value to "" if it - was present, or did nothing. This vfixes the -verbose command - line bug in connect. - -2000-04-07 Eric Melski - - * typedCmdline.test: Changed sourcing bits at start of file to - work better with updated file dependancies. - - * typedCmdline.tcl: Removed "package provide"; that should occur - only in one file per package. Reformatted function headers to - comply with Tcl coding standard. Renamed "cmdline::lsearch" to - "cmdline::prefixSearch" to avoid confusion, and removed code thus - made obsolete. - - * cmdline.tcl: Added call to source typedCmdline.tcl - -2000-04-04 Ross Mohn - - * typedCmdline.tcl: Added typed versions of getopt, getoptions, - and usage. Types supported are all character classes available - for the Tcl "string in" command. - - * typedCmdline.test: Added tests for typed procedures. - - * cmdline.tcl: Corrected some documentation errors and omissions. - -2000-03-09 Eric Melski - - * cmdline.test: Adapted tests to work with tcllib test framework. - -1999-10-29 Scott Stanton - - * cmdline.tcl: Fixed bug where options that contained regexp - special characters would cause an error. Cleaned up lots of - messy code. Added test suite. - DELETED modules/cmdline/cmdline.man Index: modules/cmdline/cmdline.man ================================================================== --- modules/cmdline/cmdline.man +++ /dev/null @@ -1,111 +0,0 @@ -[manpage_begin cmdline n 1.2.1] -[moddesc {command line / option processing}] -[titledesc {Procedures to process command lines and options.}] -[require Tcl 8.2] -[require cmdline [opt 1.2.1]] -[description] - -This package provides commands to parse command lines and options. - -[list_begin definitions] - -[call [cmd ::cmdline::getopt] [arg argvVar] [arg optstring] [arg optVar] [arg valVar]] - -This command works in a fashion like the standard C based [cmd getopt] -function. Given an option string and a pointer to an array or args -this command will process the first argument and return info on how to -proceed. The command returns 1 if an option was found, 0 if no more -options were found, and -1 if an error occurred. - -[nl] - -[arg argvVar] contains the name of the argv list to process. If -options are found the arg list is modified and the processed arguments -are removed from the start of the list. - -[nl] - -[arg optstring] contains a list of command options that the -application will accept. If the option ends in ".arg" the command -will use the next argument as an argument to the option. Otherwise -the option is a boolean that is set to 1 if present. - -[nl] - -[arg optVar] refers to the variable the command will store the found -option into (without the leading '-' and without the .arg extension). - -[nl] - -[arg valVar] refers to the variable to store either the value for the -specified option into upon success or an error message in the case of -failure. The stored value comes from the command line for .arg -options, otherwise the value is 1. - -[call [cmd ::cmdline::getKnownOpt] [arg argvVar] [arg optstring] [arg optVar] [arg valVar]] - -Like [cmd ::cmdline::getopt], but ignores any unknown options in the -input. - -[call [cmd ::cmdline::getoptions] [arg arglistVar] [arg optlist] [opt [arg usage]]] - -Processes the set of command line options found in the list variable -named by [arg arglistVar] and fills in defaults for those not -specified. This also generates an error message that lists the -allowed flags if an incorrect flag is specified. The optional -[arg usage]-argument contains a string to include in front of the -generated message. If not present it defaults to "options:". - -[nl] - -[arg optlist] contains a list of lists where each element specifies an -option in the form: [arg flag] [arg default] [arg comment]. - -[nl] - -If [arg flag] ends in ".arg" then the value is taken from the command -line. Otherwise it is a boolean and appears in the result if present -on the command line. If [arg flag] ends in ".secret", it will not be -displayed in the usage. - - -[call [cmd ::cmdline::getKnownOptions] [arg arglistVar] [arg optlist] [opt [arg usage]]] - -Like [cmd ::cmdline::getoptions], but ignores any unknown options in the -input. - - -[call [cmd ::cmdline::usage] [arg optlist] [opt [arg usage]]] - -Generates and returns an error message that lists the allowed -flags. [arg optlist] is defined as for -[cmd ::cmdline::getoptions]. The optional [arg usage]-argument -contains a string to include in front of the generated message. If not -present it defaults to "options:". - -[call [cmd ::cmdline::getfiles] [arg patterns] [arg quiet]] - -Given a list of file [arg patterns] this command computes the set of -valid files. On windows, file globbing is performed on each argument. -On Unix, only file existence is tested. If a file argument produces -no valid files, a warning is optionally generated (set [arg quiet] to -true). - -[nl] - -This code also uses the full path for each file. If not given it -prepends the current working directory to the filename. This ensures -that these files will never conflict with files in a wrapped zip -file. The last sentence refers to the pro-tools. - -[call [cmd ::cmdline::getArgv0]] - -This command returns the "sanitized" version of [arg argv0]. It will -strip off the leading path and removes the ".bin" extensions that the -pro-apps use because they must be wrapped by a shell script. - -[list_end] - -[keywords {cmdline processing}] -[manpage_end] - DELETED modules/cmdline/cmdline.n Index: modules/cmdline/cmdline.n ================================================================== --- modules/cmdline/cmdline.n +++ /dev/null @@ -1,97 +0,0 @@ -'\" -'\" Copyright (c) 2001 by Andreas Kupries -'\" All rights reserved. -'\" -'\" RCS: @(#) $Id: cmdline.n,v 1.3 2001/10/17 17:27:25 andreas_kupries Exp $ -'\" -.so man.macros -.TH cmdline n 1.0 Cmdline "command line / option processing" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -::cmdline \- Procedures to process command lines and options. -.SH SYNOPSIS -\fBpackage require Tcl 8.2\fR -.sp -\fBpackage require cmdline ?1.1.1?\fR -.sp -\fB::cmdline::getopt\fR \fIargvVar optstring optVar valVar\fR -.sp -\fB::cmdline::getoptions\fR \fIarglistVar optlist\fR ?\fIusage\fR? -.sp -\fB::cmdline::usage\fR \fIoptlist\fR ?\fIusage\fR? -.sp -\fB::cmdline::getfiles\fR \fIpatterns quiet\fR -.sp -\fB::cmdline::getArgv0\fR -.BE -.SH DESCRIPTION -.PP -This package provides commands to parse command lines and options. -.TP -\fB::cmdline::getopt\fR \fIargvVar optstring optVar valVar\fR -This command works in a fashion like the standard C based \fBgetopt\fR -function. Given an option string and a pointer to an array or args -this command will process the first argument and return info on how to -procede. The command returns 1 if an option was found, 0 if no more -options were found, and -1 if an error occurred. -.sp -\fIargvVar\fR contains the name of the argv list to process. If -options are found the arg list is modified and the processed arguments -are removed from the start of the list. -.sp -\fIoptstring\fR contains a list of command options that the -application will accept. If the option ends in ".arg" the command -will use the next argument as an argument to the option. Otherwise -the option is a boolean that is set to 1 if present. -.sp -\fIoptVar\fR refers to the variable the command will store the found -option into (without the leading '-' and without the .arg extension). -.sp -\fIvalVar\fR refers to the variable to store either the value for the -specified option into upon success or an error message in the case of -failure. The stored value comes from the command line for .arg -options, otherwise the value is 1. -.TP -\fB::cmdline::getoptions\fR \fIarglistVar optlist\fR ?\fIusage\fR? -Processes the set of command line options found in the list variable -named by \fIarglistVar\fR and fills in defaults for those not -specified. This also generates an error message that lists the -allowed flags if an incorrect flag is specified. The optional -\fIusage\fR-argument contains a string to include in front of the -generated message. If not present it defaults to "options:". -.sp -\fIoptlist\fR contains a list of lists where each element specifies an -option in the form: \fIflag default comment\fR -.sp -If \fIflag\fR ends in ".arg" then the value is taken from the command -line. Otherwise it is a boolean and appears in the result if present -on the command line. If \fIflag\fR ends in ".secret", it will not be -displayed in the usage. -.TP -\fB::cmdline::usage\fR \fIoptlist\fR ?\fIusage\fR? -Generates and returns an error message that lists the allowed -flags. \fIoptlist\fR is defined as for -\fB::cmdline::getoptions\fI. The optional \fIusage\fR-argument -contains a string to include in front of the generated message. If not -present it defaults to "options:". -.TP -\fB::cmdline::getfiles\fR \fIpatterns quiet\fR -Given a list of file \fIpatterns\fR this command computes the set of -valid files. On windows, file globbing is performed on each argument. -On Unix, only file existence is tested. If a file argument produces -no valid files, a warning is optionally generated (set \fIquiet\fR to -true). -.sp -This code also uses the full path for each file. If not given it -prepends the current working directory to the filename. This ensures -that these files will never conflict with files in a wrapped zip -file. The last sentence refers to the pro-tools. -.TP -\fB::cmdline::getArgv0\fR -This command returns the "sanitized" version of \fIargv0\fR. It will -strip off the leading path and removes the ".bin" extensions that the -pro-apps use because they must be wrapped by a shell script. - -.SH KEYWORDS -cmdline processing DELETED modules/cmdline/cmdline.tcl Index: modules/cmdline/cmdline.tcl ================================================================== --- modules/cmdline/cmdline.tcl +++ /dev/null @@ -1,420 +0,0 @@ -# cmdline.tcl -- -# -# This package provides a utility for parsing command line -# arguments that are processed by our various applications. -# It also includes a utility routine to determine the app -# name for use in command line errors. -# -# Copyright (c) 1998-2000 by Ajuba Solutions. -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: cmdline.tcl,v 1.14 2003/04/11 00:39:47 andreas_kupries Exp $ - -package require Tcl 8.2 -package provide cmdline 1.2.1 - -namespace eval ::cmdline { - namespace export getArgv0 getopt getKnownOpt getfiles getoptions \ - getKnownOptions usage -} - -# Load the typed versions of these functions -source [file join [file dirname [info script]] typedCmdline.tcl] - -# ::cmdline::getopt -- -# -# The cmdline::getopt works in a fashion like the standard -# C based getopt function. Given an option string and a -# pointer to an array or args this command will process the -# first argument and return info on how to procede. -# -# Arguments: -# argvVar Name of the argv list that you -# want to process. If options are found the -# arg list is modified and the processed arguments -# are removed from the start of the list. -# optstring A list of command options that the application -# will accept. If the option ends in ".arg" the -# getopt routine will use the next argument as -# an argument to the option. Otherwise the option -# is a boolean that is set to 1 if present. -# optVar The variable pointed to by optVar -# contains the option that was found (without the -# leading '-' and without the .arg extension). -# valVar Upon success, the variable pointed to by valVar -# contains the value for the specified option. -# This value comes from the command line for .arg -# options, otherwise the value is 1. -# If getopt fails, the valVar is filled with an -# error message. -# -# Results: -# The getopt function returns 1 if an option was found, 0 if no more -# options were found, and -1 if an error occurred. - -proc ::cmdline::getopt {argvVar optstring optVar valVar} { - upvar 1 $argvVar argsList - upvar 1 $optVar option - upvar 1 $valVar value - - set result [getKnownOpt argsList $optstring option value] - - if {$result < 0} { - # Collapse unknown-option error into any-other-error result. - set result -1 - } - return $result -} - -# ::cmdline::getKnownOpt -- -# -# The cmdline::getKnownOpt works in a fashion like the standard -# C based getopt function. Given an option string and a -# pointer to an array or args this command will process the -# first argument and return info on how to procede. -# -# Arguments: -# argvVar Name of the argv list that you -# want to process. If options are found the -# arg list is modified and the processed arguments -# are removed from the start of the list. Note that -# unknown options and the args that follow them are -# left in this list. -# optstring A list of command options that the application -# will accept. If the option ends in ".arg" the -# getopt routine will use the next argument as -# an argument to the option. Otherwise the option -# is a boolean that is set to 1 if present. -# optVar The variable pointed to by optVar -# contains the option that was found (without the -# leading '-' and without the .arg extension). -# valVar Upon success, the variable pointed to by valVar -# contains the value for the specified option. -# This value comes from the command line for .arg -# options, otherwise the value is 1. -# If getopt fails, the valVar is filled with an -# error message. -# -# Results: -# The getKnownOpt function returns 1 if an option was found, -# 0 if no more options were found, -1 if an unknown option was -# encountered, and -2 if any other error occurred. - -proc ::cmdline::getKnownOpt {argvVar optstring optVar valVar} { - upvar 1 $argvVar argsList - upvar 1 $optVar option - upvar 1 $valVar value - - # default settings for a normal return - set value "" - set option "" - set result 0 - - # check if we're past the end of the args list - if {[llength $argsList] != 0} { - - # if we got -- or an option that doesn't begin with -, return (skipping - # the --). otherwise process the option arg. - switch -glob -- [set arg [lindex $argsList 0]] { - "--" { - set argsList [lrange $argsList 1 end] - } - - "-*" { - set option [string range $arg 1 end] - - if {[lsearch -exact $optstring $option] != -1} { - # Booleans are set to 1 when present - set value 1 - set result 1 - set argsList [lrange $argsList 1 end] - } elseif {[lsearch -exact $optstring "$option.arg"] != -1} { - set result 1 - set argsList [lrange $argsList 1 end] - if {[llength $argsList] != 0} { - set value [lindex $argsList 0] - set argsList [lrange $argsList 1 end] - } else { - set value "Option \"$option\" requires an argument" - set result -2 - } - } else { - # Unknown option. - set value "Illegal option \"$option\"" - set result -1 - } - } - default { - # Skip ahead - } - } - } - - return $result -} - -# ::cmdline::getoptions -- -# -# Process a set of command line options, filling in defaults -# for those not specified. This also generates an error message -# that lists the allowed flags if an incorrect flag is specified. -# -# Arguments: -# arglistVar The name of the argument list, typically argv. -# We remove all known options and their args from it. -# optlist A list-of-lists where each element specifies an option -# in the form: -# (where flag takes no argument) -# flag comment -# -# (or where flag takes an argument) -# flag default comment -# -# If flag ends in ".arg" then the value is taken from the -# command line. Otherwise it is a boolean and appears in -# the result if present on the command line. If flag ends -# in ".secret", it will not be displayed in the usage. -# usage Text to include in the usage display. Defaults to -# "options:" -# -# Results -# Name value pairs suitable for using with array set. - -proc ::cmdline::getoptions {arglistVar optlist {usage options:}} { - upvar 1 $arglistVar argv - - set opts [GetOptionDefaults $optlist result] - - set argc [llength $argv] - while {[set err [getopt argv $opts opt arg]]} { - if {$err < 0} { - set result(?) "" - break - } - set result($opt) $arg - } - if {[info exist result(?)] || [info exists result(help)]} { - error [usage $optlist $usage] - } - return [array get result] -} - -# ::cmdline::getKnownOptions -- -# -# Process a set of command line options, filling in defaults -# for those not specified. This ignores unknown flags, but generates -# an error message that lists the correct usage if a known option -# is used incorrectly. -# -# Arguments: -# arglistVar The name of the argument list, typically argv. This -# We remove all known options and their args from it. -# optlist A list-of-lists where each element specifies an option -# in the form: -# flag default comment -# If flag ends in ".arg" then the value is taken from the -# command line. Otherwise it is a boolean and appears in -# the result if present on the command line. If flag ends -# in ".secret", it will not be displayed in the usage. -# usage Text to include in the usage display. Defaults to -# "options:" -# -# Results -# Name value pairs suitable for using with array set. - -proc ::cmdline::getKnownOptions {arglistVar optlist {usage options:}} { - upvar 1 $arglistVar argv - - set opts [GetOptionDefaults $optlist result] - - # As we encounter them, keep the unknown options and their - # arguments in this list. Before we return from this procedure, - # we'll prepend these args to the argList so that the application - # doesn't lose them. - - set unknownOptions [list] - - set argc [llength $argv] - while {[set err [getKnownOpt argv $opts opt arg]]} { - if {$err == -1} { - # Unknown option. - - # Skip over any non-option items that follow it. - # For now, add them to the list of unknownOptions. - lappend unknownOptions [lindex $argv 0] - set argv [lrange $argv 1 end] - while {([llength $argv] != 0) \ - && ![string match "-*" [lindex $argv 0]]} { - lappend unknownOptions [lindex $argv 0] - set argv [lrange $argv 1 end] - } - } elseif {$err == -2} { - set result(?) "" - break - } else { - set result($opt) $arg - } - } - - # Before returning, prepend the any unknown args back onto the - # argList so that the application doesn't lose them. - set argv [concat $unknownOptions $argv] - - if {[info exist result(?)] || [info exists result(help)]} { - error [usage $optlist $usage] - } - return [array get result] -} - -# ::cmdline::GetOptionDefaults -- -# -# This internal procdure processes the option list (that was passed to -# the getopt or getKnownOpt procedure). The defaultArray gets an index -# for each option in the option list, the value of which is the option's -# default value. -# -# Arguments: -# optlist A list-of-lists where each element specifies an option -# in the form: -# flag default comment -# If flag ends in ".arg" then the value is taken from the -# command line. Otherwise it is a boolean and appears in -# the result if present on the command line. If flag ends -# in ".secret", it will not be displayed in the usage. -# defaultArrayVar The name of the array in which to put argument defaults. -# -# Results -# Name value pairs suitable for using with array set. - -proc ::cmdline::GetOptionDefaults {optlist defaultArrayVar} { - upvar 1 $defaultArrayVar result - - set opts {? help} - foreach opt $optlist { - set name [lindex $opt 0] - if {[regsub -- .secret$ $name {} name] == 1} { - # Need to hide this from the usage display and getopt - } - lappend opts $name - if {[regsub -- .arg$ $name {} name] == 1} { - - # Set defaults for those that take values. - - set default [lindex $opt 1] - set result($name) $default - } else { - # The default for booleans is false - set result($name) 0 - } - } - return $opts -} - -# ::cmdline::usage -- -# -# Generate an error message that lists the allowed flags. -# -# Arguments: -# optlist As for cmdline::getoptions -# usage Text to include in the usage display. Defaults to -# "options:" -# -# Results -# A formatted usage message - -proc ::cmdline::usage {optlist {usage {options:}}} { - set str "[getArgv0] $usage\n" - foreach opt [concat $optlist \ - {{help "Print this message"} {? "Print this message"}}] { - set name [lindex $opt 0] - if {[regsub -- .secret$ $name {} name] == 1} { - # Hidden option - continue - } - if {[regsub -- .arg$ $name {} name] == 1} { - set default [lindex $opt 1] - set comment [lindex $opt 2] - append str [format " %-20s %s <%s>\n" "-$name value" \ - $comment $default] - } else { - set comment [lindex $opt 1] - append str [format " %-20s %s\n" "-$name" $comment] - } - } - return $str -} - -# ::cmdline::getfiles -- -# -# Given a list of file arguments from the command line, compute -# the set of valid files. On windows, file globbing is performed -# on each argument. On Unix, only file existence is tested. If -# a file argument produces no valid files, a warning is optionally -# generated. -# -# This code also uses the full path for each file. If not -# given it prepends [pwd] to the filename. This ensures that -# these files will never comflict with files in our zip file. -# -# Arguments: -# patterns The file patterns specified by the user. -# quiet If this flag is set, no warnings will be generated. -# -# Results: -# Returns the list of files that match the input patterns. - -proc ::cmdline::getfiles {patterns quiet} { - set result {} - if {$::tcl_platform(platform) == "windows"} { - foreach pattern $patterns { - set pat [string map {{\\} {\\\\}} $pattern] - set files [glob -nocomplain -- $pat] - if {$files == {}} { - if {! $quiet} { - puts stdout "warning: no files match \"$pattern\"" - } - } else { - foreach file $files { - lappend result $file - } - } - } - } else { - set result $patterns - } - set files {} - foreach file $result { - # Make file an absolute path so that we will never conflict - # with files that might be contained in our zip file. - set fullPath [file join [pwd] $file] - - if {[file isfile $fullPath]} { - lappend files $fullPath - } elseif {! $quiet} { - puts stdout "warning: no files match \"$file\"" - } - } - return $files -} - -# ::cmdline::getArgv0 -- -# -# This command returns the "sanitized" version of argv0. It will strip -# off the leading path and remove the ".bin" extensions that our apps -# use because they must be wrapped by a shell script. -# -# Arguments: -# None. -# -# Results: -# The application name that can be used in error messages. - -proc ::cmdline::getArgv0 {} { - global argv0 - - set name [file tail $argv0] - return [file rootname $name] -} - - DELETED modules/cmdline/cmdline.test Index: modules/cmdline/cmdline.test ================================================================== --- modules/cmdline/cmdline.test +++ /dev/null @@ -1,483 +0,0 @@ -# This file contains the tests for the cmdline.tcl file. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 1999 by Ajuba Solutions. -# All rights reserved. -# -# RCS: @(#) $Id: cmdline.test,v 1.6 2002/04/25 23:26:16 andreas_kupries Exp $ - -package require tcltest -namespace import -force ::tcltest::* - -set cmdLineFile [file join [file dirname [info script]] cmdline.tcl] -source $cmdLineFile -set argv0 "argv0" - -# cmdline::getopt - -test cmdline-1.1 {cmdline::getopt} { - catch {unset opt} - catch {unset arg} - set argList {} - list [cmdline::getopt argList {a} opt arg] $argList $opt $arg -} {0 {} {} {}} -test cmdline-1.2 {cmdline::getopt, multiple options} { - catch {unset opt} - catch {unset arg} - set argList {} - list [cmdline::getopt argList {a b.arg c} opt arg] $argList $opt $arg -} {0 {} {} {}} -test cmdline-1.3 {cmdline::getopt, -- option} { - catch {unset opt} - catch {unset arg} - set argList {-- -a} - list [cmdline::getopt argList {a} opt arg] $argList $opt $arg -} {0 -a {} {}} -test cmdline-1.4 {cmdline::getopt, non dash option} { - catch {unset opt} - catch {unset arg} - set argList {b -a} - list [cmdline::getopt argList {a} opt arg] $argList $opt $arg -} {0 {b -a} {} {}} -test cmdline-1.5 {cmdline::getopt, simple option} { - catch {unset opt} - catch {unset arg} - set argList {-a b} - list [cmdline::getopt argList {a} opt arg] $argList $opt $arg -} {1 b a 1} -test cmdline-1.6 {cmdline::getopt, multiple letter option} { - catch {unset opt} - catch {unset arg} - set argList {-foo b} - list [cmdline::getopt argList {foo} opt arg] $argList $opt $arg -} {1 b foo 1} -test cmdline-1.7 {cmdline::getopt, multiple letter option, no abbreviations} { - catch {unset opt} - catch {unset arg} - set argList {-f b} - list [cmdline::getopt argList {foo} opt arg] $argList $opt $arg -} {-1 {-f b} f {Illegal option "f"}} -test cmdline-1.8 {cmdline::getopt, option with argument} { - catch {unset opt} - catch {unset arg} - set argList {-foo bar baz} - list [cmdline::getopt argList {foo.arg} opt arg] $argList $opt $arg -} {1 baz foo bar} -test cmdline-1.9 {cmdline::getopt, option with argument, missing arg} { - catch {unset opt} - catch {unset arg} - set argList {-foo} - list [cmdline::getopt argList {foo.arg} opt arg] $argList $opt $arg -} {-1 {} foo {Option "foo" requires an argument}} -test cmdline-1.10 {cmdline::getopt, unknown option} { - catch {unset opt} - catch {unset arg} - set argList {-bar} - list [cmdline::getopt argList {foo.arg} opt arg] $argList $opt $arg -} {-1 -bar bar {Illegal option "bar"}} -test cmdline-1.11 {cmdline::getopt, multiple options} { - catch {unset opt} - catch {unset arg} - set argList {-foo} - list [cmdline::getopt argList {a.arg b foo c.arg} opt arg] $argList $opt $arg -} {1 {} foo 1} - -# cmdline::getoptions - -test cmdline-2.1 {cmdline::getoptions} { - set argList {foo} - list [cmdline::getoptions argList {}] $argList -} {{} foo} -test cmdline-2.2 {cmdline::getoptions, secret flag} { - set argList {-foo} - list [cmdline::getoptions argList {{foo.secret}}] $argList -} {{foo 1} {}} -test cmdline-2.3 {cmdline::getoptions, normal flag} { - set argList {-foo} - list [cmdline::getoptions argList {{foo}}] $argList -} {{foo 1} {}} -test cmdline-2.4 {cmdline::getoptions, flag with arg} { - set argList {-foo bar} - list [cmdline::getoptions argList {{foo.arg}}] $argList -} {{foo bar} {}} -test cmdline-2.5 {cmdline::getoptions, missing flag with arg, default value} { - set argList {} - list [cmdline::getoptions argList {{foo.arg blat}}] $argList -} {{foo blat} {}} -test cmdline-2.6 {cmdline::getoptions, flag with arg, default value} { - set argList {-foo bar} - list [cmdline::getoptions argList {{foo.arg blat}}] $argList -} {{foo bar} {}} -test cmdline-2.7 {cmdline::getoptions, multiple flags with arg, default value} { - set argList {} - list [cmdline::getoptions argList {{foo.arg blat} {a.arg b}}] $argList -} {{foo blat a b} {}} -test cmdline-2.8 {cmdline::getoptions, errors} { - set argList {-a -foo} - list [catch {cmdline::getoptions argList {{foo.arg blat} a}} msg] $msg $argList -} [list 1 "[cmdline::getArgv0] options: - -foo value - -a - -help Print this message - -? Print this message -" {}] -test cmdline-2.9 {cmdline::getoptions, errors} { - set argList {-a -?} - list [catch {cmdline::getoptions argList {{foo.arg blat} a}} msg] $msg \ - $argList -} [list 1 "[cmdline::getArgv0] options: - -foo value - -a - -help Print this message - -? Print this message -" {}] -test cmdline-2.10 {cmdline::getoptions, errors} { - set argList {-help} - list [catch {cmdline::getoptions argList {{foo.arg blat} a}} msg] $msg \ - $argList -} [list 1 "[cmdline::getArgv0] options: - -foo value - -a - -help Print this message - -? Print this message -" {}] -test cmdline-2.11 {cmdline::getoptions, usage string in errors} { - set argList {-help} - list [catch {cmdline::getoptions argList {{foo.arg blat} a} {testing}} msg] $msg \ - $argList -} [list 1 "[cmdline::getArgv0] testing - -foo value - -a - -help Print this message - -? Print this message -" {}] - -# cmdline::usage - -test cmdline-3.1 {cmdline::usage,hidden options} { - set argList {-help} - list [catch {cmdline::getoptions argList {{foo.secret blat} a}} msg] $msg \ - $argList -} [list 1 "[cmdline::getArgv0] options: - -a - -help Print this message - -? Print this message -" {}] -test cmdline-3.2 {cmdline::usage, with & without arg} { - set argList {-help} - list [catch {cmdline::getoptions argList \ - {{foo.arg blat testing} {a {} {line 2}}}} msg] $msg $argList -} [list 1 "[cmdline::getArgv0] options: - -foo value testing - -a - -help Print this message - -? Print this message -" {}] - -# cmdline::getfiles - -# Run the script body in a slave process so we can collect stdout. - -proc runGetFilesTest {body} { - set script " - source [list $::cmdLineFile] - cd [list $::tcltest::temporaryDirectory] -" - append script $body - makeFile $script script - - set f [open "|[list $::tcltest::tcltest \ - [file join $::tcltest::temporaryDirectory script]]" r] - set result [read $f] - close $f - removeFile script - return $result -} - - -# Create a directory with some files in it - -file mkdir [file join $::tcltest::temporaryDirectory cmdlineJunk] -close [open [file join $::tcltest::temporaryDirectory cmdlineJunk/foo1] w] -close [open [file join $::tcltest::temporaryDirectory cmdlineJunk/foo2] w] -close [open [file join $::tcltest::temporaryDirectory cmdlineJunk/bar3] w] - -test cmdline-4.1 {cmdline::getfiles} {pcOnly} { - runGetFilesTest { - cmdline::getfiles {} 0 - } -} {} -test cmdline-4.2 {cmdline::getfiles, one pattern} {pcOnly} { - runGetFilesTest { - cd cmdlineJunk - set result [cmdline::getfiles {foo*} 0] - puts -nonewline [lsort $result] - } -} [list [file join $::tcltest::temporaryDirectory cmdlineJunk/foo1] \ - [file join $::tcltest::temporaryDirectory cmdlineJunk/foo2]] -test cmdline-4.3 {cmdline::getfiles, multiple patterns} {pcOnly} { - runGetFilesTest { - cd cmdlineJunk - set result [cmdline::getfiles {foo* bar*} 0] - puts -nonewline [lsort $result] - } -} [list [file join $::tcltest::temporaryDirectory cmdlineJunk/bar3] \ - [file join $::tcltest::temporaryDirectory cmdlineJunk/foo1] \ - [file join $::tcltest::temporaryDirectory cmdlineJunk/foo2]] -test cmdline-4.4 {cmdline::getfiles, no match} {pcOnly} { - runGetFilesTest { - cd cmdlineJunk - set result [cmdline::getfiles {blat* foo*} 0] - puts -nonewline [lsort $result] - } -} "warning: no files match \"blat*\"\n[list \ - [file join $::tcltest::temporaryDirectory cmdlineJunk/foo1] \ - [file join $::tcltest::temporaryDirectory cmdlineJunk/foo2]]" -test cmdline-4.5 {cmdline::getfiles, quiet} {pcOnly} { - runGetFilesTest { - cd cmdlineJunk - set result [cmdline::getfiles {blat* foo*} 1] - puts -nonewline [lsort $result] - } -} [list \ - [file join $::tcltest::temporaryDirectory cmdlineJunk/foo1] \ - [file join $::tcltest::temporaryDirectory cmdlineJunk/foo2]] -test cmdline-4.6 {cmdline::getfiles, relative paths} { - runGetFilesTest { - cd cmdlineJunk - set result [cmdline::getfiles {foo1 foo2} 0] - puts -nonewline [lsort $result] - } -} [list \ - [file join $::tcltest::temporaryDirectory cmdlineJunk/foo1] \ - [file join $::tcltest::temporaryDirectory cmdlineJunk/foo2]] -test cmdline-4.7 {cmdline::getfiles, absolute paths} { - runGetFilesTest { - cd cmdlineJunk - set result [cmdline::getfiles [list [file join [pwd] foo1]] 0] - puts -nonewline [lsort $result] - } -} [list \ - [file join $::tcltest::temporaryDirectory cmdlineJunk/foo1]] -test cmdline-4.8 {cmdline::getfiles, no match} { - runGetFilesTest { - cd cmdlineJunk - set result [cmdline::getfiles {blat foo1} 0] - puts -nonewline [lsort $result] - } -} "warning: no files match \"blat\"\n[list \ - [file join $::tcltest::temporaryDirectory cmdlineJunk/foo1]]" -test cmdline-4.9 {cmdline::getfiles, silent no match} { - runGetFilesTest { - cd cmdlineJunk - set result [cmdline::getfiles {blat foo1} 1] - puts -nonewline [lsort $result] - } -} [list \ - [file join $::tcltest::temporaryDirectory cmdlineJunk/foo1]] - -# Remove the temporary directory and files from the previous tests - -file delete -force [file join $::tcltest::temporaryDirectory cmdlineJunk] -removeFile script - -# cmdline::getArgv0 - -test cmdline-5.1 {cmdline::getArgv0} { - set oldargv0 $argv0 - set argv0 "foo" - set result [cmdline::getArgv0] - set argv0 $oldargv0 - set result -} foo -test cmdline-5.2 {cmdline::getArgv0} { - set oldargv0 $argv0 - set argv0 "foo.exe" - set result [cmdline::getArgv0] - set argv0 $oldargv0 - set result -} foo -test cmdline-5.3 {cmdline::getArgv0} { - set oldargv0 $argv0 - set argv0 "foo.bin" - set result [cmdline::getArgv0] - set argv0 $oldargv0 - set result -} foo -test cmdline-5.4 {cmdline::getArgv0} { - set oldargv0 $argv0 - set argv0 "foo.bar.bin" - set result [cmdline::getArgv0] - set argv0 $oldargv0 - set result -} foo.bar -test cmdline-5.5 {cmdline::getArgv0} { - set oldargv0 $argv0 - set argv0 "/a/b/c/foo" - set result [cmdline::getArgv0] - set argv0 $oldargv0 - set result -} foo - -# cmdline::getKnownOpt - -test cmdline-6.1 {cmdline::getKnownOpt} { - catch {unset opt} - catch {unset arg} - set argList {} - list [cmdline::getKnownOpt argList {a} opt arg] $argList $opt $arg -} {0 {} {} {}} -test cmdline-6.2 {cmdline::getKnownOpt, multiple options} { - catch {unset opt} - catch {unset arg} - set argList {} - list [cmdline::getKnownOpt argList {a b.arg c} opt arg] $argList $opt $arg -} {0 {} {} {}} -test cmdline-6.3 {cmdline::getKnownOpt, -- option} { - catch {unset opt} - catch {unset arg} - set argList {-- -a} - list [cmdline::getKnownOpt argList {a} opt arg] $argList $opt $arg -} {0 -a {} {}} -test cmdline-6.4 {cmdline::getKnownOpt, non dash option} { - catch {unset opt} - catch {unset arg} - set argList {b -a} - list [cmdline::getKnownOpt argList {a} opt arg] $argList $opt $arg -} {0 {b -a} {} {}} -test cmdline-6.5 {cmdline::getKnownOpt, simple option} { - catch {unset opt} - catch {unset arg} - set argList {-a b} - list [cmdline::getKnownOpt argList {a} opt arg] $argList $opt $arg -} {1 b a 1} -test cmdline-6.6 {cmdline::getKnownOpt, multiple letter option} { - catch {unset opt} - catch {unset arg} - set argList {-foo b} - list [cmdline::getKnownOpt argList {foo} opt arg] $argList $opt $arg -} {1 b foo 1} -test cmdline-6.7 {cmdline::getKnownOpt, multiple letter option, no abbreviations} { - catch {unset opt} - catch {unset arg} - set argList {-f b} - list [cmdline::getKnownOpt argList {foo} opt arg] $argList $opt $arg -} {-1 {-f b} f {Illegal option "f"}} -test cmdline-6.8 {cmdline::getKnownOpt, option with argument} { - catch {unset opt} - catch {unset arg} - set argList {-foo bar baz} - list [cmdline::getKnownOpt argList {foo.arg} opt arg] $argList $opt $arg -} {1 baz foo bar} -test cmdline-6.9 {cmdline::getKnownOpt, option with argument, missing arg} { - catch {unset opt} - catch {unset arg} - set argList {-foo} - list [cmdline::getKnownOpt argList {foo.arg} opt arg] $argList $opt $arg -} {-2 {} foo {Option "foo" requires an argument}} -test cmdline-6.10 {cmdline::getKnownOpt, unknown option} { - catch {unset opt} - catch {unset arg} - set argList {-bar} - list [cmdline::getKnownOpt argList {foo.arg} opt arg] $argList $opt $arg -} {-1 -bar bar {Illegal option "bar"}} -test cmdline-6.11 {cmdline::getKnownOpt, multiple options} { - catch {unset opt} - catch {unset arg} - set argList {-foo} - list [cmdline::getKnownOpt argList {a.arg b foo c.arg} opt arg] $argList $opt $arg -} {1 {} foo 1} - -# cmdline::getKnownOptions - -test cmdline-7.1 {cmdline::getKnownOptions} { - set argList {foo} - list [cmdline::getKnownOptions argList {}] $argList -} {{} foo} -test cmdline-7.2 {cmdline::getKnownOptions, secret flag} { - set argList {-foo} - list [cmdline::getKnownOptions argList {{foo.secret}}] $argList -} {{foo 1} {}} -test cmdline-7.3 {cmdline::getKnownOptions, normal flag} { - set argList {-foo} - list [cmdline::getKnownOptions argList {{foo}}] $argList -} {{foo 1} {}} -test cmdline-7.4 {cmdline::getKnownOptions, flag with arg} { - set argList {-foo bar} - list [cmdline::getKnownOptions argList {{foo.arg}}] $argList -} {{foo bar} {}} -test cmdline-7.5 {cmdline::getKnownOptions, missing flag with arg, default value} { - set argList {} - list [cmdline::getKnownOptions argList {{foo.arg blat}}] $argList -} {{foo blat} {}} -test cmdline-7.6 {cmdline::getKnownOptions, flag with arg, default value} { - set argList {-foo bar} - list [cmdline::getKnownOptions argList {{foo.arg blat}}] $argList -} {{foo bar} {}} -test cmdline-7.7 {cmdline::getKnownOptions, multiple flags with arg, default value} { - set argList {} - list [cmdline::getKnownOptions argList {{foo.arg blat} {a.arg b}}] $argList -} {{foo blat a b} {}} -test cmdline-7.8 {cmdline::getKnownOptions, ignore unknown option} { - set argList {-unknown -foo buzz} - list [cmdline::getKnownOptions argList {{foo.arg blat}}] $argList -} {{foo buzz} -unknown} -test cmdline-7.9 {cmdline::getKnownOptions, ignore unknown option} { - set argList {-foo buzz -unknown} - list [cmdline::getKnownOptions argList {{foo.arg blat}}] $argList -} {{foo buzz} -unknown} -test cmdline-7.10 {cmdline::getKnownOptions, ignore unknown option with args} { - set argList {-unknown u1 u2 u3 -foo buzz} - list [cmdline::getKnownOptions argList {{foo.arg blat}}] $argList -} {{foo buzz} {-unknown u1 u2 u3}} -test cmdline-7.11 {cmdline::getKnownOptions, ignore unknown option with args} { - set argList {-foo buzz -unknown u1 u2 u3} - list [cmdline::getKnownOptions argList {{foo.arg blat}}] $argList -} {{foo buzz} {-unknown u1 u2 u3}} -test cmdline-7.12 {cmdline::getKnownOptions, errors} { - set argList {-a -foo} - list [catch {cmdline::getKnownOptions argList {{foo.arg blat} a}} msg] $msg $argList -} [list 1 "[cmdline::getArgv0] options: - -foo value - -a - -help Print this message - -? Print this message -" {}] -test cmdline-7.13 {cmdline::getKnownOptions, errors} { - set argList {-a -?} - list [catch {cmdline::getKnownOptions argList {{foo.arg blat} a}} msg] $msg \ - $argList -} [list 1 "[cmdline::getArgv0] options: - -foo value - -a - -help Print this message - -? Print this message -" {}] -test cmdline-7.14 {cmdline::getKnownOptions, errors} { - set argList {-help} - list [catch {cmdline::getKnownOptions argList {{foo.arg blat} a}} msg] $msg \ - $argList -} [list 1 "[cmdline::getArgv0] options: - -foo value - -a - -help Print this message - -? Print this message -" {}] -test cmdline-7.15 {cmdline::getKnownOptions, usage string in errors} { - set argList {-help} - list [catch {cmdline::getKnownOptions argList {{foo.arg blat} a} {testing}} msg] $msg \ - $argList -} [list 1 "[cmdline::getArgv0] testing - -foo value - -a - -help Print this message - -? Print this message -" {}] - -tcltest::cleanupTests -return - - DELETED modules/cmdline/pkgIndex.tcl Index: modules/cmdline/pkgIndex.tcl ================================================================== --- modules/cmdline/pkgIndex.tcl +++ /dev/null @@ -1,12 +0,0 @@ -# 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. - -if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded cmdline 1.2.1 [list source [file join $dir cmdline.tcl]] DELETED modules/cmdline/typedCmdline.tcl Index: modules/cmdline/typedCmdline.tcl ================================================================== --- modules/cmdline/typedCmdline.tcl +++ /dev/null @@ -1,455 +0,0 @@ -# typedCmdline.tcl -- -# -# This package provides a utility for parsing typed command -# line arguments that may be processed by various applications. -# -# Copyright (c) 2000 by Ross Palmer Mohn. -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: typedCmdline.tcl,v 1.6 2003/04/11 19:07:05 andreas_kupries Exp $ - -namespace eval ::cmdline { - namespace export typedGetopt typedGetoptions typedUsage - - # variable cmdline::charclasses -- - # - # Create regexp list of allowable character classes - # from "string is" error message. - # - # Results: - # String of character class names separated by "|" characters. - - variable charclasses - catch {string is . .} charclasses - regexp -- {must be (.+)$} $charclasses dummy charclasses - regsub -all -- {, (or )?} $charclasses {|} charclasses - -} - -# ::cmdline::typedGetopt -- -# -# The cmdline::typedGetopt works in a fashion like the standard -# C based getopt function. Given an option string and a -# pointer to a list of args this command will process the -# first argument and return info on how to procede. In addition, -# you may specify a type for the argument to each option. -# -# Arguments: -# argvVar Name of the argv list that you want to process. -# If options are found, the arg list is modified -# and the processed arguments are removed from the -# start of the list. -# -# optstring A list of command options that the application -# will accept. If the option ends in ".xxx", where -# xxx is any valid character class to the tcl -# command "string is", then typedGetopt routine will -# use the next argument as a typed argument to the -# option. The argument must match the specified -# character classes (e.g. integer, double, boolean, -# xdigit, etc.). Alternatively, you may specify -# ".arg" for an untyped argument. -# -# optVar Upon success, the variable pointed to by optVar -# contains the option that was found (without the -# leading '-' and without the .xxx extension). If -# typedGetopt fails the variable is set to the empty -# string. SOMETIMES! Different for each -value! -# -# argVar Upon success, the variable pointed to by argVar -# contains the argument for the specified option. -# If typedGetopt fails, the variable is filled with -# an error message. -# -# Argument type syntax: -# Option that takes no argument. -# foo -# -# Option that takes a typeless argument. -# foo.arg -# -# Option that takes a typed argument. Allowable types are all -# valid character classes to the tcl command "string is". -# Currently must be one of alnum, alpha, ascii, control, -# boolean, digit, double, false, graph, integer, lower, print, -# punct, space, true, upper, wordchar, or xdigit. -# foo.double -# -# Option that takes an argument from a list. -# foo.(bar|blat) -# -# Argument quantifier syntax: -# Option that takes an optional argument. -# foo.arg? -# -# Option that takes a list of arguments terminated by "--". -# foo.arg+ -# -# Option that takes an optional list of arguments terminated by "--". -# foo.arg* -# -# Argument quantifiers work on all argument types, so, for -# example, the following is a valid option specification. -# foo.(bar|blat|blah)? -# -# Argument syntax miscellany: -# Options may be specified on the command line using a unique, -# shortened version of the option name. Given that program foo -# has an option list of {bar.alpha blah.arg blat.double}, -# "foo -b fob" returns an error, but "foo -ba fob" -# successfully returns {bar fob} -# -# Results: -# The typedGetopt function returns one of the following: -# 1 a valid option was found -# 0 no more options found to process -# -1 invalid option -# -2 missing argument to a valid option -# -3 argument to a valid option does not match type -# -# Known Bugs: -# When using options which include special glob characters, -# you must use the exact option. Abbreviating it can cause -# an error in the "cmdline::prefixSearch" procedure. - -proc ::cmdline::typedGetopt {argvVar optstring optVar argVar} { - variable charclasses - - upvar $argvVar argsList - - upvar $optVar retvar - upvar $argVar optarg - - # default settings for a normal return - set optarg "" - set retvar "" - set retval 0 - - # check if we're past the end of the args list - if {[llength $argsList] != 0} { - - # if we got -- or an option that doesn't begin with -, return (skipping - # the --). otherwise process the option arg. - switch -glob -- [set arg [lindex $argsList 0]] { - "--" { - set argsList [lrange $argsList 1 end] - } - - "-*" { - # Create list of options without their argument extentions - - set optstr "" - foreach str $optstring { - lappend optstr [file rootname $str] - } - - set _opt [string range $arg 1 end] - - set i [prefixSearch $optstr [file rootname $_opt]] - if {$i != -1} { - set opt [lindex $optstring $i] - - set quantifier "none" - if {[regexp -- {\.[^.]+([?+*])$} $opt dummy quantifier]} { - set opt [string range $opt 0 end-1] - } - - if {[string first . $opt] == -1} { - set retval 1 - set retvar $opt - set argsList [lrange $argsList 1 end] - - } elseif {[regexp -- "\\.(arg|$charclasses)\$" $opt dummy charclass] - || [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} { - if {[string equal arg $charclass]} { - set type arg - } elseif {[regexp -- "^($charclasses)\$" $charclass]} { - set type class - } else { - set type oneof - } - - set argsList [lrange $argsList 1 end] - set opt [file rootname $opt] - - while {1} { - if {[llength $argsList] == 0 - || [string equal "--" [lindex $argsList 0]]} { - if {[string equal "--" [lindex $argsList 0]]} { - set argsList [lrange $argsList 1 end] - } - - set oneof "" - if {$type == "arg"} { - set charclass an - } elseif {$type == "oneof"} { - set oneof ", one of $charclass" - set charclass an - } - - if {$quantifier == "?"} { - set retval 1 - set retvar $opt - set optarg "" - } elseif {$quantifier == "+"} { - set retvar $opt - if {[llength $optarg] < 1} { - set retval -2 - set optarg "Option requires at least one $charclass argument$oneof -- $opt" - } else { - set retval 1 - } - } elseif {$quantifier == "*"} { - set retval 1 - set retvar $opt - } else { - set optarg "Option requires $charclass argument$oneof -- $opt" - set retvar $opt - set retval -2 - } - set quantifier "" - } elseif {($type == "arg") - || (($type == "oneof") - && [string first "|[lindex $argsList 0]|" "|$charclass|"] != -1) - || (($type == "class") - && [string is $charclass [lindex $argsList 0]])} { - set retval 1 - set retvar $opt - lappend optarg [lindex $argsList 0] - set argsList [lrange $argsList 1 end] - } else { - set oneof "" - if {$type == "arg"} { - set charclass an - } elseif {$type == "oneof"} { - set oneof ", one of $charclass" - set charclass an - } - set optarg "Option requires $charclass argument$oneof -- $opt" - set retvar $opt - set retval -3 - - if {$quantifier == "?"} { - set retval 1 - set optarg "" - } - set quantifier "" - } - if {![regexp -- {[+*]} $quantifier]} { - break; - } - } - } else { - error "Illegal option type specification:\ - must be one of $charclasses" - } - } else { - set optarg "Illegal option -- $_opt" - set retvar $_opt - set retval -1 - } - } - default { - # Skip ahead - } - } - } - - return $retval -} - -# ::cmdline::typedGetoptions -- -# -# Process a set of command line options, filling in defaults -# for those not specified. This also generates an error message -# that lists the allowed options if an incorrect option is -# specified. -# -# Arguments: -# arglistVar The name of the argument list, typically argv -# optlist A list-of-lists where each element specifies an option -# in the form: -# -# option default comment -# -# Options formatting is as described for the optstring -# argument of typedGetopt. Default is for optionally -# specifying a default value. Comment is for optionally -# specifying a comment for the usage display. The -# options "-help" and "-?" are automatically included -# in optlist. -# -# Argument syntax miscellany: -# Options formatting and syntax is as described in typedGetopt. -# There are two additional suffixes that may be applied when -# passing options to typedGetoptions. -# -# You may add ".multi" as a suffix to any option. For options -# that take an argument, this means that the option may be used -# more than once on the command line and that each additional -# argument will be appended to a list, which is then returned -# to the application. -# foo.double.multi -# -# If a non-argument option is specified as ".multi", it is -# toggled on and off for each time it is used on the command -# line. -# foo.multi -# -# If an option specification does not contain the ".multi" -# suffix, it is not an error to use an option more than once. -# In this case, the behavior for options with arguments is that -# the last argument is the one that will be returned. For -# options that do not take arguments, using them more than once -# has no additional effect. -# -# Options may also be hidden from the usage display by -# appending the suffix ".secret" to any option specification. -# Please note that the ".secret" suffix must be the last suffix, -# after any argument type specification and ".multi" suffix. -# foo.xdigit.multi.secret -# -# Results -# Name value pairs suitable for using with array set. - -proc ::cmdline::typedGetoptions {arglistVar optlist {usage options:}} { - variable charclasses - - upvar 1 $arglistVar argv - - set opts {? help} - foreach opt $optlist { - set name [lindex $opt 0] - if {[regsub -- {\.secret$} $name {} name] == 1} { - # Remove this extension before passing to typedGetopt. - } - if {[regsub -- {\.multi$} $name {} name] == 1} { - # Remove this extension before passing to typedGetopt. - - regsub -- {\..*$} $name {} temp - set multi($temp) 1 - } - lappend opts $name - if {[regsub -- "\\.(arg|$charclasses|\\(.+).?\$" $name {} name] == 1} { - # Set defaults for those that take values. - # Booleans are set just by being present, or not - - set dflt [lindex $opt 1] - if {$dflt != {}} { - set defaults($name) $dflt - } - } - } - set argc [llength $argv] - while {[set err [typedGetopt argv $opts opt arg]]} { - if {$err == 1} { - if {[info exists result($opt)] - && [info exists multi($opt)]} { - # Toggle boolean options or append new arguments - - if {$arg == ""} { - unset result($opt) - } else { - set result($opt) "$result($opt) $arg" - } - } else { - set result($opt) "$arg" - } - } elseif {($err == -1) || ($err == -3)} { - error [typedUsage $optlist $usage] - } elseif {$err == -2 && ![info exists defaults($opt)]} { - error [typedUsage $optlist $usage] - } - } - if {[info exists result(?)] || [info exists result(help)]} { - error [typedUsage $optlist $usage] - } - foreach {opt dflt} [array get defaults] { - if {![info exists result($opt)]} { - set result($opt) $dflt - } - } - return [array get result] -} - -# ::cmdline::typedUsage -- -# -# Generate an error message that lists the allowed flags, -# type of argument taken (if any), default value (if any), -# and an optional description. -# -# Arguments: -# optlist As for cmdline::typedGetoptions -# -# Results -# A formatted usage message - -proc ::cmdline::typedUsage {optlist {usage {options:}}} { - variable charclasses - - set str "[getArgv0] $usage\n" - foreach opt [concat $optlist \ - {{help "Print this message"} {? "Print this message"}}] { - set name [lindex $opt 0] - if {[regsub -- {\.secret$} $name {} name] == 1} { - # Hidden option - - } else { - if {[regsub -- {\.multi$} $name {} name] == 1} { - # Display something about multiple options - } - - if {[regexp -- "\\.(arg|$charclasses)\$" $name dummy charclass] - || [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} { - regsub -- "\\..+\$" $name {} name - set comment [lindex $opt 2] - set default "<[lindex $opt 1]>" - if {$default == "<>"} { - set default "" - } - append str [format " %-20s %s %s\n" "-$name $charclass" \ - $comment $default] - } else { - set comment [lindex $opt 1] - append str [format " %-20s %s\n" "-$name" $comment] - } - } - } - return $str -} - -# ::cmdline::prefixSearch -- -# -# Search a Tcl list for a pattern; searches first for an exact match, -# and if that fails, for a unique prefix that matches the pattern -# (ie, first "lsearch -exact", then "lsearch -glob $pattern*" -# -# Arguments: -# list list of words -# pattern word to search for -# -# Results: -# Index of found word is returned. If no exact match or -# unique short version is found then -1 is returned. - -proc ::cmdline::prefixSearch {list pattern} { - # Check for an exact match - - if {[set pos [::lsearch -exact $list $pattern]] > -1} { - return $pos - } - - # Check for a unique short version - - set slist [lsort $list] - if {[set pos [::lsearch -glob $slist $pattern*]] > -1} { - # What if there is nothting for the check variable? - - set check [lindex $slist [expr {$pos + 1}]] - if {[string first $pattern $check] != 0} { - return [::lsearch -exact $list [lindex $slist $pos]] - } - } - return -1 -} DELETED modules/cmdline/typedCmdline.test Index: modules/cmdline/typedCmdline.test ================================================================== --- modules/cmdline/typedCmdline.test +++ /dev/null @@ -1,442 +0,0 @@ -# This file contains the tests for the typedCmdline.tcl file. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 2000 by Ross Palmer Mohn. -# All rights reserved. -# -# RCS: @(#) $Id: typedCmdline.test,v 1.1 2000/04/07 16:35:44 ericm Exp $ - -package require tcltest -namespace import -force ::tcltest::* - -set cmdLineFile [file join [file dirname [info script]] cmdline.tcl] -source $cmdLineFile -set argv0 "argv0" - -# cmdline::typedGetopt - -test cmdline-6.1 {cmdline::typedGetopt} { - catch {unset opt} - catch {unset arg} - set argList {} - list [cmdline::typedGetopt argList {a} opt arg] $argList $opt $arg -} {0 {} {} {}} -test cmdline-6.2 {cmdline::typedGetopt, multiple options} { - catch {unset opt} - catch {unset arg} - set argList {} - list [cmdline::typedGetopt argList {a b.arg c} opt arg] $argList $opt $arg -} {0 {} {} {}} -test cmdline-6.3 {cmdline::typedGetopt, -- option} { - catch {unset opt} - catch {unset arg} - set argList {-- -a} - list [cmdline::typedGetopt argList {a} opt arg] $argList $opt $arg -} {0 -a {} {}} -test cmdline-6.4 {cmdline::typedGetopt, non dash option} { - catch {unset opt} - catch {unset arg} - set argList {b -a} - list [cmdline::typedGetopt argList {a} opt arg] $argList $opt $arg -} {0 {b -a} {} {}} -test cmdline-6.5 {cmdline::typedGetopt, simple option} { - catch {unset opt} - catch {unset arg} - set argList {-a b} - list [cmdline::typedGetopt argList {a} opt arg] $argList $opt $arg -} {1 b a {}} -test cmdline-6.6 {cmdline::typedGetopt, multiple letter option} { - catch {unset opt} - catch {unset arg} - set argList {-foo b} - list [cmdline::typedGetopt argList {foo} opt arg] $argList $opt $arg -} {1 b foo {}} -test cmdline-6.7 {cmdline::typedGetopt, multiple letter option, abbreviation} { - catch {unset opt} - catch {unset arg} - set argList {-f -b} - list [cmdline::typedGetopt argList {foo b} opt arg] $argList $opt $arg -} {1 -b foo {}} -test cmdline-6.8 {cmdline::typedGetopt, option with argument} { - catch {unset opt} - catch {unset arg} - set argList {-foo bar baz} - list [cmdline::typedGetopt argList {foo.arg} opt arg] $argList $opt $arg -} {1 baz foo bar} -test cmdline-6.9 {cmdline::typedGetopt, option with argument, missing arg} { - catch {unset opt} - catch {unset arg} - set argList {-foo} - list [cmdline::typedGetopt argList {foo.arg} opt arg] $argList $opt $arg -} {-2 {} foo {Option requires an argument -- foo}} -test cmdline-6.10 {cmdline::typedGetopt, multiple options} { - catch {unset opt} - catch {unset arg} - set argList {-foo} - list [cmdline::typedGetopt argList {a.arg b foo c.arg} opt arg] $argList $opt $arg -} {1 {} foo {}} -test cmdline-6.11 {cmdline::typedGetopt, unusual options} { - catch {unset opt} - catch {unset arg} - set argList {-* foo} - list [cmdline::typedGetopt argList {a.arg b *.arg c.arg} opt arg] $argList $opt $arg -} {1 {} * foo} -test cmdline-6.12 {cmdline::typedGetopt, integer options} { - catch {unset opt} - catch {unset arg} - set argList {-foo -a bar} - list [cmdline::typedGetopt argList {a.arg foo.integer b} opt arg] $argList $opt $arg -} {-3 {-a bar} foo {Option requires integer argument -- foo}} -test cmdline-6.13 {cmdline::typedGetopt, integer options} { - catch {unset opt} - catch {unset arg} - set argList {-foo 123} - list [cmdline::typedGetopt argList {a.arg foo.integer b} opt arg] $argList $opt $arg -} {1 {} foo 123} -test cmdline-6.14 {cmdline::typedGetopt, integer options} { - catch {unset opt} - catch {unset arg} - set argList {-foo 123} - list [catch {cmdline::typedGetopt argList {a.arg foo.bar b} opt arg} msg] $msg $argList $opt $arg -} [list 1 {Illegal option type specification: must be one of alnum|alpha|ascii|control|boolean|digit|double|false|graph|integer|lower|print|punct|space|true|upper|wordchar|xdigit} {-foo 123} {} {}] -test cmdline-6.15 {cmdline::typedGetopt, integer options} { - catch {unset opt} - catch {unset arg} - set argList {-foo 123 -a 234} - list [cmdline::typedGetopt argList {a.arg foo.integer b} opt arg] $argList $opt $arg -} {1 {-a 234} foo 123} -test cmdline-6.16 {cmdline::typedGetopt, unusual integer options} { - catch {unset opt} - catch {unset arg} - set argList {-* 123 -a 234} - list [cmdline::typedGetopt argList {a.arg *.integer b} opt arg] $argList $opt $arg -} {1 {-a 234} * 123} -test cmdline-6.17 {cmdline::typedGetopt, integer options} { - catch {unset opt} - catch {unset arg} - set argList {-foo} - list [cmdline::typedGetopt argList {a.arg foo.integer b} opt arg] $argList $opt $arg -} {-2 {} foo {Option requires integer argument -- foo}} -test cmdline-6.18 {cmdline::typedGetopt, xdigit options} { - catch {unset opt} - catch {unset arg} - set argList {-foo 50AC} - list [cmdline::typedGetopt argList {foo.xdigit} opt arg] $argList $opt $arg -} {1 {} foo 50AC} -test cmdline-6.19 {cmdline::typedGetopt, xdigit options} { - catch {unset opt} - catch {unset arg} - set argList {-foo 50GC} - list [cmdline::typedGetopt argList {foo.xdigit} opt arg] $argList $opt $arg -} {-3 50GC foo {Option requires xdigit argument -- foo}} -test cmdline-6.20 {cmdline::typedGetopt, xdigit options} { - catch {unset opt} - catch {unset arg} - set argList {-foo 50gc} - list [cmdline::typedGetopt argList {foo.(50GC|50gc) bar} opt arg] $argList $opt $arg -} {1 {} foo 50gc} -test cmdline-6.21 {cmdline::typedGetopt, xdigit options} { - catch {unset opt} - catch {unset arg} - set argList {-foo 50gC} - list [cmdline::typedGetopt argList {foo.(50GC|50gc) bar} opt arg] $argList $opt $arg -} {-3 50gC foo {Option requires an argument, one of 50GC|50gc -- foo}} -test cmdline-6.22 {cmdline::typedGetopt, xdigit options} { - catch {unset opt} - catch {unset arg} - set argList {-foo abc*def} - list [cmdline::typedGetopt argList {foo.(abc*def|ghi?jkl) bar} opt arg] $argList $opt $arg -} {1 {} foo abc*def} -test cmdline-6.23 {cmdline::typedGetopt, xdigit options} { - catch {unset opt} - catch {unset arg} - set argList {-foo 50gc} - list [cmdline::typedGetopt argList {foo.(x5MP|1jxR|50gc)? bar} opt arg] $argList $opt $arg -} {1 {} foo 50gc} -test cmdline-6.24 {cmdline::typedGetopt, xdigit options} { - catch {unset opt} - catch {unset arg} - set argList {-foo} - list [cmdline::typedGetopt argList {foo.(x5MP|1jxR|50gc)? bar} opt arg] $argList $opt $arg -} {1 {} foo {}} -test cmdline-6.25 {cmdline::typedGetopt, xdigit options} { - catch {unset opt} - catch {unset arg} - set argList {-foo -bar} - list [cmdline::typedGetopt argList {foo.(x5MP|1jxR|50gc)? bar} opt arg] $argList $opt $arg -} {1 -bar foo {}} -test cmdline-6.26 {cmdline::typedGetopt, xdigit options} { - catch {unset opt} - catch {unset arg} - set argList {-foo 50fc} - list [cmdline::typedGetopt argList {foo.xdigit? bar} opt arg] $argList $opt $arg -} {1 {} foo 50fc} -test cmdline-6.27 {cmdline::typedGetopt, xdigit options} { - catch {unset opt} - catch {unset arg} - set argList {-foo} - list [cmdline::typedGetopt argList {foo.xdigit? bar} opt arg] $argList $opt $arg -} {1 {} foo {}} -test cmdline-6.28 {cmdline::typedGetopt, xdigit options} { - catch {unset opt} - catch {unset arg} - set argList {-foo 1jxR -bar} - list [cmdline::typedGetopt argList {foo.xdigit? bar} opt arg] $argList $opt $arg -} {1 {1jxR -bar} foo {}} -test cmdline-6.29 {cmdline::typedGetopt, xdigit options} { - catch {unset opt} - catch {unset arg} - set argList {-foo -bar} - list [cmdline::typedGetopt argList {foo.xdigit? bar} opt arg] $argList $opt $arg -} {1 -bar foo {}} -test cmdline-6.30 {cmdline::typedGetopt, xdigit options} { - catch {unset opt} - catch {unset arg} - set argList {-foo} - list [cmdline::typedGetopt argList {foo.xdigit+ bar} opt arg] $argList $opt $arg -} {-2 {} foo {Option requires at least one xdigit argument -- foo}} -test cmdline-6.31 {cmdline::typedGetopt, xdigit options} { - catch {unset opt} - catch {unset arg} - set argList {-foo AC} - list [cmdline::typedGetopt argList {foo.xdigit+ bar} opt arg] $argList $opt $arg -} {1 {} foo AC} -test cmdline-6.32 {cmdline::typedGetopt, xdigit options} { - catch {unset opt} - catch {unset arg} - set argList {-foo AC 2F -bar} - list [cmdline::typedGetopt argList {foo.xdigit+ bar} opt arg] $argList $opt $arg -} {-3 -bar foo {Option requires xdigit argument -- foo}} -test cmdline-6.33 {cmdline::typedGetopt, xdigit options} { - catch {unset opt} - catch {unset arg} - set argList {-foo AC 2F} - list [cmdline::typedGetopt argList {foo.xdigit+ bar} opt arg] $argList $opt $arg -} {1 {} foo {AC 2F}} -test cmdline-6.34 {cmdline::typedGetopt, xdigit options} { - catch {unset opt} - catch {unset arg} - set argList {-foo AC 2F --} - list [cmdline::typedGetopt argList {foo.xdigit+ bar} opt arg] $argList $opt $arg -} {1 {} foo {AC 2F}} -test cmdline-6.35 {cmdline::typedGetopt, xdigit options} { - catch {unset opt} - catch {unset arg} - set argList {-foo} - list [cmdline::typedGetopt argList {foo.xdigit* bar} opt arg] $argList $opt $arg -} {1 {} foo {}} -test cmdline-6.36 {cmdline::typedGetopt, xdigit options} { - catch {unset opt} - catch {unset arg} - set argList {-foo AC} - list [cmdline::typedGetopt argList {foo.xdigit* bar} opt arg] $argList $opt $arg -} {1 {} foo AC} -test cmdline-6.37 {cmdline::typedGetopt, xdigit options} { - catch {unset opt} - catch {unset arg} - set argList {-foo AC 2F -bar} - list [cmdline::typedGetopt argList {foo.xdigit* bar} opt arg] $argList $opt $arg -} {-3 -bar foo {Option requires xdigit argument -- foo}} -test cmdline-6.38 {cmdline::typedGetopt, xdigit options} { - catch {unset opt} - catch {unset arg} - set argList {-foo AC 2F} - list [cmdline::typedGetopt argList {foo.xdigit* bar} opt arg] $argList $opt $arg -} {1 {} foo {AC 2F}} -test cmdline-6.39 {cmdline::typedGetopt, xdigit options} { - catch {unset opt} - catch {unset arg} - set argList {-foo AC 2F --} - list [cmdline::typedGetopt argList {foo.xdigit* bar} opt arg] $argList $opt $arg -} {1 {} foo {AC 2F}} - -# cmdline::typedGetoptions - -test cmdline-7.1 {cmdline::typedGetoptions} { - set argList {foo} - list [cmdline::typedGetoptions argList {}] $argList -} {{} foo} -test cmdline-7.2 {cmdline::typedGetoptions, secret integer flag} { - set argList {-foo 123} - list [cmdline::typedGetoptions argList {{foo.integer.secret}}] $argList -} {{foo 123} {}} -test cmdline-7.3 {cmdline::typedGetoptions, normal integer flag} { - set argList {-foo 123} - list [cmdline::typedGetoptions argList {{foo.integer}}] $argList -} {{foo 123} {}} -test cmdline-7.4 {cmdline::typedGetoptions, missing integer flag, no default value} { - set argList {} - list [cmdline::typedGetoptions argList {{foo.integer}}] $argList -} {{} {}} -test cmdline-7.5 {cmdline::typedGetoptions, missing integer flag, no default value} { - set argList {} - list [cmdline::typedGetoptions argList {{foo.integer {} {option foo with integer argument}}}] $argList -} {{} {}} -test cmdline-7.6 {cmdline::typedGetoptions, integer flag, missing arg, no default value} { - set argList {-foo} - list [catch {cmdline::typedGetoptions argList {{foo.integer {} {blah blah}}}} msg] $msg $argList -} [list 1 "[cmdline::getArgv0] options: - -foo integer blah blah - -help Print this message - -? Print this message -" {}] -test cmdline-7.7 {cmdline::typedGetoptions, integer flag, no default value} { - set argList {-foo 123} - list [cmdline::typedGetoptions argList {{foo.integer {} {option foo with integer argument}}}] $argList -} {{foo 123} {}} -test cmdline-7.8 {cmdline::typedGetoptions, missing integer flag with arg, default value} { - set argList {-* 123} - list [cmdline::typedGetoptions argList {{foo.integer 234} {*.double 5.234 {Unusual}}}] $argList -} {{foo 234 * 123} {}} -test cmdline-7.9 {cmdline::typedGetoptions, missing integer flag with arg, default value} { - set argList {-f} - list [cmdline::typedGetoptions argList {{foo.integer 234} {*.double 5.234 {Unusual}}}] $argList -} {{foo 234 * 5.234} {}} -test cmdline-7.10 {cmdline::typedGetoptions, missing integer flag with arg, default value} { - set argList {-f} - list [catch {cmdline::typedGetoptions argList {foo.integer *.double fooey}} msg] $msg $argList -} [list 1 "[cmdline::getArgv0] options: - -foo integer - -* double - -fooey - -help Print this message - -? Print this message -" -f] -test cmdline-7.11 {cmdline::typedGetoptions, missing integer flag with arg, default value} { - set argList {} - list [cmdline::typedGetoptions argList {{foo.integer 234}}] $argList -} {{foo 234} {}} -test cmdline-7.12 {cmdline::typedGetoptions, integer flag with arg, default value} { - set argList {-foo 123} - list [cmdline::typedGetoptions argList {{foo.integer 234}}] $argList -} {{foo 123} {}} -test cmdline-7.13 {cmdline::typedGetoptions, multiple flags with arg, default value} { - set argList {} - list [cmdline::typedGetoptions argList {{foo.arg blat} {a.arg b}}] $argList -} {{foo blat a b} {}} -test cmdline-7.14 {cmdline::typedGetoptions, errors} { - set argList {-a -foo} - list [cmdline::typedGetoptions argList {{foo.arg blat} a}] $argList -} {{foo blat a {}} {}} -test cmdline-7.15 {cmdline::typedGetoptions, errors} { - set argList {-a -fo} - list [cmdline::typedGetoptions argList {{foo.arg blat} a}] $argList -} {{foo blat a {}} {}} -test cmdline-7.16 {cmdline::typedGetopt, xdigit options} { - set argList {-foo 50gc} - list [cmdline::typedGetoptions argList {foo.(50GC|50gc) bar}] $argList -} {{foo 50gc} {}} -test cmdline-7.17 {cmdline::typedGetopt, xdigit options} { - set argList {-foo -bar} - list [cmdline::typedGetoptions argList {foo.(50GC|50gc)? bar}] $argList -} {{foo {} bar {}} {}} -test cmdline-7.18 {cmdline::typedGetopt, xdigit options} { - set argList {-bar -foo 123 234} - list [cmdline::typedGetoptions argList {foo.integer+ bar}] $argList -} {{foo {123 234} bar {}} {}} -test cmdline-7.19 {cmdline::typedGetopt, xdigit options} { - set argList {-bar -foo 123 234} - list [cmdline::typedGetoptions argList {foo.integer* bar}] $argList -} {{foo {123 234} bar {}} {}} -test cmdline-7.20 {cmdline::typedGetopt, xdigit options} { - set argList {-foo 50gC} - list [catch {cmdline::typedGetoptions argList {foo.(50GC|50gc) bar}} msg] $msg $argList -} [list 1 "[cmdline::getArgv0] options: - -foo 50GC|50gc - -bar - -help Print this message - -? Print this message -" 50gC] -test cmdline-7.21 {cmdline::typedGetoptions, errors} { - set argList {-b -foo} - list [catch {cmdline::typedGetoptions argList {foo.arg a}} msg] $msg $argList -} [list 1 "[cmdline::getArgv0] options: - -foo arg - -a - -help Print this message - -? Print this message -" {-b -foo}] -test cmdline-7.22 {cmdline::typedGetoptions, errors} { - set argList {-b -foo} - list [catch {cmdline::typedGetoptions argList {{foo.arg {} {blah blah}} a}} msg] $msg $argList -} [list 1 "[cmdline::getArgv0] options: - -foo arg blah blah - -a - -help Print this message - -? Print this message -" {-b -foo}] -test cmdline-7.23 {cmdline::typedGetoptions, errors} { - set argList {-a -?} - list [catch {cmdline::typedGetoptions argList {{foo.arg blat} a}} msg] $msg \ - $argList -} [list 1 "[cmdline::getArgv0] options: - -foo arg - -a - -help Print this message - -? Print this message -" {}] -test cmdline-7.24 {cmdline::typedGetoptions, errors} { - set argList {-help} - list [catch {cmdline::typedGetoptions argList {{foo.arg blat} a}} msg] $msg \ - $argList -} [list 1 "[cmdline::getArgv0] options: - -foo arg - -a - -help Print this message - -? Print this message -" {}] -test cmdline-7.25 {cmdline::typedGetoptions, usage string in errors} { - set argList {-help} - list [catch {cmdline::typedGetoptions argList {{foo.arg blat} a} {testing:}} msg] $msg \ - $argList -} [list 1 "[cmdline::getArgv0] testing: - -foo arg - -a - -help Print this message - -? Print this message -" {}] -test cmdline-7.26 {cmdline::typedGetoptions, unusual option} { - set argList {-x?y -a -foo} - list [cmdline::typedGetoptions argList {{foo.arg blat} x?y x*y a}] $argList -} {{foo blat x?y {} a {}} {}} -test cmdline-7.27 {cmdline::typedGetoptions, unusual option, abbreviation error} { - set argList {-x -a -foo} - list [catch {cmdline::typedGetoptions argList {{foo.arg blat} x?y x*y a}} msg] $msg $argList -} [list 1 "[cmdline::getArgv0] options: - -foo arg - -x?y - -x*y - -a - -help Print this message - -? Print this message -" {-x -a -foo}] -test cmdline-7.28 {cmdline::typedGetoptions, unusual option, abbreviation} { - set argList {-x -a -foo} - list [cmdline::typedGetoptions argList {{foo.arg blat} x?y a}] $argList -} {{foo blat x?y {} a {}} {}} -test cmdline-7.29 {cmdline::typedGetoptions, multiple integer flag} { - set argList {-foo 123 -foo 234} - list [cmdline::typedGetoptions argList {{foo.integer.multi}}] $argList -} {{foo {123 234}} {}} -test cmdline-7.30 {cmdline::typedGetoptions, multiple quoted arg flag} { - set argList {-foo "123 234" -foo "234 345"} - list [cmdline::typedGetoptions argList {{foo.arg.multi}}] $argList -} {{foo {{123 234} {234 345}}} {}} -test cmdline-7.31 {cmdline::typedGetoptions, multiple boolean flag} { - set argList {-foo} - list [cmdline::typedGetoptions argList {{foo.multi}}] $argList -} {{foo {}} {}} -test cmdline-7.32 {cmdline::typedGetoptions, multiple boolean flag} { - set argList {-foo -foo} - list [cmdline::typedGetoptions argList {{foo.multi}}] $argList -} {{} {}} -test cmdline-7.33 {cmdline::typedGetoptions, multiple boolean flag} { - set argList {-foo -foo -foo} - list [cmdline::typedGetoptions argList {{foo.multi}}] $argList -} {{foo {}} {}} - -tcltest::cleanupTests -return DELETED modules/comm/ChangeLog Index: modules/comm/ChangeLog ================================================================== --- modules/comm/ChangeLog +++ /dev/null @@ -1,49 +0,0 @@ -2003-04-11 Andreas Kupries - - * comm.man: - * comm.tcl: - * pkgIndex.tcl: Set version of the package to to 4.0.1. - -2003-01-28 David N. Welton - - * comm.tcl (::comm::commConfigure): Use 'string is integer' - instead of regexp's. - Require Tcl 8.2. - -2003-01-16 Andreas Kupries - - * comm.man: More semantic markup, less visual one. - -2002-08-06 Andreas Kupries - - * comm.test: Removed writing of file ~/foo, was debugging - code. Changed creation and usage of file 'spawn' to allow an - arbitrary setting of -tmpdir. Fixes SF Bug #589225 reported by - Don Porter . - -2002-03-06 Andreas Kupries - - * Bumped version number to 4.0 per request by John LoVerso. - - * comm.tcl: Applied patch #526499 improving the handling of errors - for async invoked commands. - -2002-02-14 Andreas Kupries - - * comm.tcl: Frink run. - -2002-01-15 Andreas Kupries - - * Bumped version to 3.7.1. - -2001-11-16 Andreas Kupries - - * comm.n: Updated to reflect the changes in the comm code - (namespaces). This fixes SF item #480227. - - * comm.tcl: Fixed two places where namespacing was not handled - correctly. - -2001-08-22 Andreas Kupries - - * Integrated into tcllib. DELETED modules/comm/comm.LICENSE Index: modules/comm/comm.LICENSE ================================================================== --- modules/comm/comm.LICENSE +++ /dev/null @@ -1,48 +0,0 @@ -Copyright (C) 1995-1998, The Open Group. All Rights Reserved. - -This software was developed by the Open Group Research Institute -("RI"). This software, both binary and source (hereafter, Software) -is copyrighted by The Open Group Research Institute and ownership -remains with the RI. - -The RI hereby grants you (hereafter, Licensee) permission to use, -copy, modify, distribute, and license this Software and its -documentation for any purpose, provided that existing copyright -notices are retained in all copies and that this notice is included -verbatim in any distributions. No written agreement, license, or -royalty fee is required for any of the authorized uses provided -that the RI is publicly and prominently acknowledged as the source -of this software. - -Licensee may make derivative works. However, if Licensee distributes -any derivative work based on or derived from the Software, then -Licensee will (1) notify the RI regarding its distribution of the -derivative work, (2) clearly notify users that such derivative work -is a modified version and not the original software distributed by -the RI, and (3) the RI is publicly and prominently acknowledged as -the source of this software. - -THE RI MAKES NO REPRESENTATIONS ABOUT THE SERVICEABILITY OF THIS -SOFTWARE FOR ANY PURPOSE. IT IS PROVIDED "AS IS" WITHOUT EXPRESS -OR IMPLIED WARRANTY. THE RI SHALL NOT BE LIABLE FOR ANY DAMAGES -SUFFERED BY THE USERS OF THIS SOFTWARE. - -By using or copying this Software, Licensee agrees to abide by the -copyright law and all other applicable laws of the U.S. including, -but not limited to, export control laws, and the terms of this -license. The RI shall have the right to terminate this license -immediately by written notice upon Licensee's breach of, or -non-compliance with, any of its terms. Licensee may be held legally -responsible for any copyright infringement that is caused or -encouraged by Licensee's failure to abide by the terms of this -license. - -Comments and questions on this license are welcome and can be sent to: - - ri-software@opengroup.org - -Comments and questions on this software should be sent to the author: - - j.loverso@opengroup.org - john@loverso.southborough.ma.us - DELETED modules/comm/comm.man Index: modules/comm/comm.man ================================================================== --- modules/comm/comm.man +++ /dev/null @@ -1,869 +0,0 @@ -[manpage_begin comm n 4.0.1] -[copyright {1995-1998 The Open Group. All Rights Reserved.}] -[moddesc {remote communication}] -[titledesc {A remote communications facility for Tcl (7.6, 8.0, and later)}] -[require Tcl 8.2] -[require comm [opt 4.0.1]] -[description] - -[para] - -The [package comm] command provides an inter-interpreter remote -execution facility much like Tk's [cmd send(n)], except that it uses -sockets rather than the X server for the communication path. As a -result, [package comm] works with multiple interpreters, works on -Windows and Macintosh systems, and provides control over the remote -execution path. - -[para] - -These commands work just like [cmd send] and [cmd "winfo interps"] : - -[example { - ::comm::comm send ?-async? id cmd ?arg arg ...? - ::comm::comm interps -}] - -[para] - -This is all that is really needed to know in order to use -[package comm] - -[section COMMANDS] -[para] - -The package initializes [cmd ::comm::comm] as the default [emph chan]. - -[para] -[package comm] names communication endpoints with an [emph id] unique -to each machine. Before sending commands, the [emph id] of another -interpreter is needed. Unlike Tk's send, [package comm] doesn't -implicitly know the [emph id]'s of all the interpreters on the system. - -The following four methods make up the basic [package comm] interface. - -[list_begin definitions] - -[call [cmd "::comm::comm send"] [opt -async] [arg id] [arg cmd] [opt "[arg "arg arg ..."]"]] - -This invokes the given command in the interpreter named by [arg id]. -The command waits for the result and remote errors are returned unless -the [option -async] option is given. - -[call [cmd "::comm::comm self"]] - -Returns the [emph id] for this channel. - -[call [cmd "::comm::comm interps"]] - -Returns a list of all the remote [emph id]'s to which this channel is -connected. [package comm] learns a new remote [emph id] when a command -is first issued it, or when a remote [emph id] first issues a command -to this comm channel. [cmd "::comm::comm ids"] is an alias for this -method. - -[call [cmd "::comm::comm connect"] [opt [arg id]]] - -Whereas [cmd "::comm::comm send"] will automatically connect to the -given [arg id], this forces a connection to a remote [emph id] without -sending a command. After this, the remote [emph id] will appear in -[cmd "::comm::comm interps"]. - -[list_end] - -[section "EVAL SEMANTICS"] -[para] - -The evaluation semantics of [cmd "::comm::comm send"] are intended to -match Tk's [cmd send] [emph exactly]. This means that [package comm] -evaluates arguments on the remote side. - -[para] - -If you find that [cmd "::comm::comm send"] doesn't work for a -particular command, try the same thing with Tk's send and see if the -result is different. If there is a problem, please report it. For -instance, there was had one report that this command produced an -error. Note that the equivalent [cmd send] command also produces the -same error. - -[para] -[example { - % ::comm::comm send id llength {a b c} - wrong # args: should be "llength list" - % send name llength {a b c} - wrong # args: should be "llength list" -}] - -[para] - -The [cmd eval] hook (described below) can be used to change from -[cmd send]'s double eval semantics to single eval semantics. - -[section "MULTIPLE CHANNELS"] -[para] - -More than one [cmd comm] channel (or [emph listener]) can be created -in each Tcl interpreter. This allows flexibility to create full and -restricted channels. For instance, [term hook] scripts are specific -to the channel they are defined against. - -[list_begin definitions] - -[call [cmd "::comm::comm new"] [arg chan] [opt [arg "name value ..."]]] - -This creates a new channel and Tcl command with the given channel -name. This new command controls the new channel and takes all the -same arguments as [cmd ::comm::comm]. Any remaining arguments are -passed to the [cmd config] method. - -[call [cmd "::comm::comm channels"]] - -This lists all the channels allocated in this Tcl interpreter. - -[list_end] -[para] - -The default configuration parameters for a new channel are: - -[para] -[example { - "-port 0 -local 1 -listen 0" -}] - -[para] - -The default channel [cmd ::comm::comm] is created with: - -[para] -[example { - "::comm::comm new ::comm::comm -port 0 -local 1 -listen 1" -}] - -[section "CHANNEL CONFIGURATION"] -[para] - -The [cmd config] method acts similar to [cmd fconfigure] in that it -sets or queries configuration variables associated with a channel. - -[list_begin definitions] -[call [cmd "::comm::comm config"]] -[call [cmd "::comm::comm config"] [arg name]] -[call [cmd "::comm::comm config"] [opt [arg "name value ..."]]] - -When given no arguments, [cmd config] returns a list of all variables -and their value With one argument, [cmd config] returns the value of -just that argument. With an even number of arguments, the given -variables are set to the given values. - -[list_end] - -[para] - -These configuration variables can be changed (descriptions of them are -elsewhere in this manual page): - -[list_begin definitions] -[lst_item "[option -listen] [opt [arg 0|1]]"] -[lst_item "[option -local] [opt [arg 0|1]]"] -[lst_item "[option -port] [opt [arg port]]"] -[list_end] - -[para] -These configuration variables are readonly: - -[list_begin definitions] -[lst_item "[option -chan] [arg chan]"] -[lst_item "[option -serial] [arg n]"] -[lst_item "[option -socket] sock[arg In]"] -[list_end] - -[para] - -When [cmd config] changes the parameters of an existing channel, it -closes and reopens the listening socket. An automatically assigned -channel [emph id] will change when this happens. Recycling the socket -is done by invoking [cmd "::comm::comm abort"], which causes all -active sends to terminate. - -[section "ID/PORT ASSIGNMENTS"] -[para] - -[package comm] uses a TCP port for endpoint [emph id]. The - -[method interps] (or [method ids]) method merely lists all the TCP ports -to which the channel is connected. By default, each channel's - -[emph id] is randomly assigned by the operating system (but usually -starts at a low value around 1024 and increases each time a new socket -is opened). This behavior is accomplished by giving the - -[option -port] config option a value of 0. Alternately, a specific -TCP port number may be provided for a given channel. As a special -case, comm contains code to allocate a a high-numbered TCP port -(>10000) by using [option "-port {}"]. Note that a channel won't be -created and initialized unless the specific port can be allocated. - -[para] - -As a special case, if the channel is configured with - -[option "-listen 0"], then it will not create a listening socket and -will use an id of [emph 0] for itself. Such a channel is only good -for outgoing connections (although once a connection is established, -it can carry send traffic in both directions). - -[section "REMOTE INTERPRETERS"] -[para] - -By default, each channel is restricted to accepting connections from -the local system. This can be overridden by using the - -[option "-local 0"] configuration option For such channels, the - -[emph id] parameter takes the form [emph "\{ id host \}"]. - -[para] - -[emph WARNING]: The [emph host] must always be specified in the same -form (e.g., as either a fully qualified domain name, plain hostname or -an IP address). - -[section "CLOSING CONNECTIONS"] -[para] - -These methods give control over closing connections: - -[list_begin definitions] - -[call [cmd "::comm::comm shutdown"] [arg Iid]] - -This closes the connection to [arg id], aborting all outstanding -commands in progress. Note that nothing prevents the connection from -being immediately reopened by another incoming or outgoing command. - -[call [cmd "::comm::comm abort"]] - -This invokes shutdown on all open connections in this comm channel. - -[call [cmd "::comm::comm destroy"]] - -This aborts all connections and then destroys the this comm channel -itself, including closing the listening socket. Special code allows -the default [cmd ::comm::comm] channel to be closed such that the - -[cmd ::comm::comm] command it is not destroyed. Doing so closes the -listening socket, preventing both incoming and outgoing commands on -the channel. This sequence reinitializes the default channel: - -[nl] -[example { - "::comm::comm destroy; ::comm::comm new ::comm::comm" -}] - -[list_end] - -[para] - -When a remote connection is lost (because the remote exited or called -[cmd shutdown]), [package comm] can invoke an application callback. -This can be used to cleanup or restart an ancillary process, for -instance. See the [term lost] callback below. - -[section CALLBACKS] -[para] -This is a mechanism for setting hooks for particular events: - -[list_begin definitions] - -[call [cmd "::comm::comm hook"] [arg event] [opt [const +]] [opt [arg script]]] - -This uses a syntax similar to Tk's [cmd bind] command. Prefixing - -[arg script] with a [const +] causes the new script to be appended. -Without this, a new [arg script] replaces any existing script. When -invoked without a script, no change is made. In all cases, the new -hook script is returned by the command. - -[nl] - -When an [arg event] occurs, the [arg script] associated with it is -evaluated with the listed variables in scope and available. The -return code ([emph not] the return value) of the script is commonly -used decide how to further process after the hook. - -[nl] -Common variables include: - -[list_begin definitions] - -[lst_item [var chan]] -the name of the comm channel (and command) - -[lst_item [var id]] -the id of the remote in question - -[lst_item [var fid]] -the file id for the socket of the connection - -[list_end] -[list_end] - -[para] -These are the defined [emph events]: - -[list_begin definitions] - -[lst_item [const connecting]] - -Variables: -[arg "chan id host port"] - -[nl] - -This hook is invoked before making a connection to the remote named in -[arg id]. An error return (via [cmd error]) will abort the connection -attempt with the error. Example: - -[nl] -[example { - % ::comm::comm hook connecting { - if [lb]string match {*[lb]02468[rb]} $id[rb] { - error "Can't connect to even ids" - } - } - % ::comm::comm send 10000 puts ok - Connect to remote failed: Can't connect to even ids - % -}] - -[lst_item [const connected]] - -Variables: -[arg "chan fid id host port"] -[nl] - -This hook is invoked immediately after making a remote connection to -[arg id], allowing arbitrary authentication over the socket named by -[arg fid]. An error return (via [cmd error] ) will close the -connection with the error. [arg host] and [arg port] are merely -extracted from the [arg id]; changing any of these will have no effect -on the connection, however. It is also possible to substitute and -replace [arg fid]. - -[lst_item [const incoming]] - -Variables: -[arg "chan fid addr remport"] -[nl] - -Hook invoked when receiving an incoming connection, allowing arbitrary -authentication over socket named by [arg fid]. An error return (via -[cmd error]) will close the connection with the error. Note that the -peer is named by [arg remport] and [arg addr] but that the remote -[emph id] is still unknown. Example: - -[nl] -[example { - ::comm::comm hook incoming { - if [lb]string match 127.0.0.1 $addr[rb] { - error "I don't talk to myself" - } - } -}] - - -[lst_item [const eval]] - -Variables: -[arg "chan id cmd buffer"] -[nl] - -This hook is invoked after collecting a complete script from a remote -but [emph before] evaluating it. This allows complete control over -the processing of incoming commands. [arg cmd] contains either -[const send] or [const async]. [arg buffer] holds the script to -evaluate. At the time the hook is called, [arg "\$chan remoteid"] is -identical in value to [arg id]. - -[nl] - -By changing [arg buffer], the hook can change the script to be -evaluated. The hook can short circuit evaluation and cause a value to -be immediately returned by using [cmd return] [arg result] (or, from -within a procedure, [cmd "return -code return"] [arg result]). An -error return (via [cmd error]) will return an error result, as is if -the script caused the error. Any other return will evaluate the -script in [arg buffer] as normal. For compatibility with 3.2, - -[cmd break] and [cmd "return -code break"] [arg result] is supported, -acting similarly to [cmd "return {}"] and [cmd "return -code return"] -[arg result]. - -[nl] - -Examples: - -[list_begin enum] - -[enum] -augmenting a command -[nl] -[example { - % ::comm::comm send [lb]::comm::comm self[rb] pid - 5013 - % ::comm::comm hook eval {puts "going to execute $buffer"} - % ::comm::comm send [lb]::comm::comm self[rb] pid - going to execute pid - 5013 -}] - -[enum] -short circuiting a command -[nl] -[example { - % ::comm::comm hook eval {puts "would have executed $buffer"; return 0} - % ::comm::comm send [lb]::comm::comm self[rb] pid - would have executed pid - 0 -}] - -[enum] -Replacing double eval semantics -[nl] -[example { - % ::comm::comm send [lb]::comm::comm self[rb] llength {a b c} - wrong # args: should be "llength list" - % ::comm::comm hook eval {return [uplevel #0 $buffer]} - return [lb]uplevel #0 $buffer[rb] - % ::comm::comm send [lb]::comm::comm self[rb] llength {a b c} - 3 -}] - -[enum] -Using a slave interpreter -[nl] -[example { - % interp create foo - % ::comm::comm hook eval {return [lb]foo eval $buffer[rb]} - % ::comm::comm send [lb]::comm::comm self[rb] set myvar 123 - 123 - % set myvar - can't read "myvar": no such variable - % foo eval set myvar - 123 -}] - -[enum] -Using a slave interpreter (double eval) -[nl] -[example { - % ::comm::comm hook eval {return [lb]eval foo eval $buffer[rb]} -}] - -[enum] -Subverting the script to execute -[nl] -[example { - % ::comm::comm hook eval { - switch -- $buffer { - a {return A-OK} b {return B-OK} default {error "$buffer is a no-no"} - } - } - % ::comm::comm send [lb]::comm::comm self[rb] pid - pid is a no-no - % ::comm::comm send [lb]::comm::comm self[rb] a - A-OK -}] - -[list_end] - - -[lst_item [const reply]] - -Variables: -[arg "chan id buffer ret return()"] -[nl] - -This hook is invoked after collecting a complete reply script from a -remote but [emph before] evaluating it. This allows complete -control over the processing of replies to sent commands. The reply -[arg buffer] is in one of the following forms - -[list_begin bullet] -[bullet] -return result -[bullet] -return -code code result -[bullet] -return -code code -errorinfo info -errorcode ecode msg -[list_end] - -For safety reasons, this is decomposed. The return result is in -[arg ret], and the return switches are in the return array: - -[list_begin bullet] -[bullet] -[emph return(-code)] -[bullet] -[emph return(-errorinfo)] -[bullet] -[emph return(-errordcode)] -[list_end] - -Any of these may be the empty string. Modifying these four variables -can change the return value, whereas modifying [arg buffer] has no -effect. - - -[lst_item [const lost]] - -Variables: -[arg "chan id reason"] -[nl] - -This hook is invoked when the connection to [emph id] is lost. Return -value (or thrown error) is ignored. [arg reason] is an explanatory -string indicating why the connection was lost. Example: - -[nl] - -[example { - ::comm::comm hook lost { - global myvar - if {$myvar(id) == $id} { - myfunc - return - } - } -}] - -[list_end] - -[section UNSUPPORTED] -[para] -These interfaces may change or go away in subsequence releases. - -[list_begin definitions] -[call [cmd "::comm::comm remoteid"]] - -Returns the [emph id] of the sender of the last remote command -executed on this channel. If used by a proc being invoked remotely, -it must be called before any events are processed. Otherwise, another -command may get invoked and change the value. - -[call [cmd ::comm::comm_send]] - -Invoking this procedure will substitute the Tk [cmd send] and -[cmd "winfo interps"] commands with these equivalents that use -[cmd ::comm::comm]. - -[nl] - -[example { - proc send {args} { - eval ::comm::comm send $args - } - rename winfo tk_winfo - proc winfo {cmd args} { - if ![lb]string match in* $cmd[rb] {return [lb]eval [lb]list tk_winfo $cmd[rb] $args[rb]} - return [lb]::comm::comm interps[rb] - } -}] - -[list_end] - -[section SECURITY] -[para] -Something here soon. - -[section "BLOCKING SEMANTICS"] - -[para] - -There is one outstanding difference between [package comm] and - -[cmd send]. When blocking in a synchronous remote command, [cmd send] -uses an internal C hook (Tk_RestrictEvents) to the event loop to look -ahead for send-related events and only process those without -processing any other events. In contrast, [package comm] uses the - -[cmd vwait] command as a semaphore to indicate the return message has -arrived. The difference is that a synchronous [cmd send] will block -the application and prevent all events (including window related ones) -from being processed, while a synchronous [cmd {::comm::comm send}] will block the -application but still allow other events will still get processed. In -particular, [cmd "after idle"] handlers will fire immediately when -comm blocks. - -[para] - -What can be done about this? First, note that this behavior will come -from any code using [cmd vwait] to block and wait for an event to -occur. At the cost of multiple channel support, [package comm] could -be changed to do blocking I/O on the socket, giving send-like blocking -semantics. However, multiple channel support is a very useful feature -of comm that it is deemed too important to lose. The remaining -approaches involve a new loadable module written in C (which is -somewhat against the philosophy of [cmd comm ]) One way would be to -create a modified version of the [cmd vwait] command that allow the -event flags passed to Tcl_DoOneEvent to be specified. For [cmd comm], -just the TCL_FILE_EVENTS would be processed. Another way would be to -implement a mechanism like Tk_RestrictEvents, but apply it to the Tcl -event loop (since [package comm] doesn't require Tk). One of these -approaches will be available in a future [package comm] release as an -optional component. - -[section COMPATIBILITY] -[para] - -[package comm] exports itself as a package. The package version number -is in the form [emph "major . minor"], where the major version will -only change when a non-compatible change happens to the API or -protocol. Minor bug fixes and changes will only affect the minor -version. To load [package comm] this command is usually used: - -[para] -[example { - package require comm 3 -}] - -[para] -Note that requiring no version (or a specific version) can also be done. - -[para] -The revision history of [package comm] includes these releases: - -[list_begin definitions] - -[lst_item "4.0"] - -Per request by John LoVerso. Improved handling of error for async -invoked commands. - -[lst_item "3.7"] - -Moved into tcllib and placed in a proper namespace. - -[lst_item "3.6"] - -A bug in the looking up of the remoteid for a executed command could -be triggered when the connection was closed while several asynchronous -sends were queued to be executed. - -[lst_item "3.5"] - -Internal change to how reply messages from a [cmd send] are handled. -Reply messages are now decoded into the [arg value] to pass to - -[cmd return]; a new return statement is then cons'd up to with this -value. Previously, the return code was passed in from the remote as a -command to evaluate. Since the wire protocol has not changed, this is -still the case. Instead, the reply handling code decodes the - -[const reply] message. - -[lst_item "3.4"] - -Added more source commentary, as well as documenting config variables -in this man page. Fixed bug were loss of connection would give error -about a variable named [var pending] rather than the message about -the lost connection. [cmd "comm ids"] is now an alias for - -[cmd "comm interps"] (previously, it an alias for [cmd "comm chans"]). -Since the method invocation change of 3.0, break and other exceptional -conditions were not being returned correctly from [cmd "comm send"]. -This has been fixed by removing the extra level of indirection into -the internal procedure [cmd commSend]. Also added propagation of -the [arg errorCode] variable. This means that these commands return -exactly as they would with [cmd send]: - -[example { - comm send id break - catch {comm send id break} - comm send id expr 1 / 0 -}] - -[nl] - -Added a new hook for reply messages. Reworked method invocation to -avoid the use of comm:* procedures; this also cut the invocation time -down by 40%. Documented [cmd "comm config"] (as this manual page -still listed the defunct [cmd "comm init"]!) - - -[lst_item "3.3"] - -Some minor bugs were corrected and the documentation was cleaned up. -Added some examples for hooks. The return semantics of the [cmd eval] -hook were changed. - -[lst_item "3.2"] - -A new wire protocol, version 3, was added. This is backwards -compatible with version 2 but adds an exchange of supported protocol -versions to allow protocol negotiation in the future. Several bugs -with the hook implementation were fixed. A new section of the man -page on blocking semantics was added. - -[lst_item "3.1"] - -All the documented hooks were implemented. [cmd commLostHook] was -removed. A bug in [cmd "comm new"] was fixed. - -[lst_item "3.0"] - -This is a new version of [package comm] with several major changes. -There is a new way of creating the methods available under the - -[cmd comm] command. The [cmd "comm init"] method has been retired -and is replaced by [cmd "comm configure"] which allows access to many -of the well-defined internal variables. This also generalizes the -options available to [cmd "comm new"]. Finally, there is now a -protocol version exchanged when a connection is established. This -will allow for future on-wire protocol changes. Currently, the -protocol version is set to 2. - -[lst_item "2.3"] - -[cmd "comm ids"] was renamed to [cmd "comm channels"]. General -support for [cmd "comm hook"] was fully implemented, but only the -[term lost] hook exists, and it was changed to follow the general -hook API. [cmd commLostHook] was unsupported (replaced by - -[cmd "comm hook lost"]) and [cmd commLost] was removed. - -[lst_item "2.2"] - -The [term died] hook was renamed [term lost], to be accessed by -[cmd commLostHook] and an early implementation of -[cmd "comm lost hook" ]. As such, [cmd commDied] is now -[cmd commLost]. - -[lst_item "2.1"] -Unsupported method [cmd "comm remoteid"] was added. - -[lst_item "2.0"] -[package comm] has been rewritten from scratch (but is fully compatible -with Comm 1.0, without the requirement to use obTcl). - -[list_end] - -[section AUTHOR] - -John LoVerso, John@LoVerso.Southborough.MA.US - -[para] - -[emph http://www.opengroup.org/~loverso/tcl-tk/#comm] - - -[section LICENSE] - -Please see the file [emph comm.LICENSE] that accompanied this source, -or -[uri http://www.opengroup.org/www/dist_client/caubweb/COPYRIGHT.free.html]. - -[para] - -This license for [package comm], new as of version 3.2, allows it to be -used for free, without any licensing fee or royalty. - - -[section BUGS] -[list_begin bullet] -[bullet] - -If there is a failure initializing a channel created with -[cmd "::comm::comm new"], then the channel should be destroyed. -Currently, it is left in an inconsistent state. - -[bullet] - -There should be a way to force a channel to quiesce when changing the -configuration. - -[list_end] - -[para] -The following items can be implemented with the existing hooks and are -listed here as a reminder to provide a sample hook in a future -version. - -[list_begin bullet] -[bullet] - -Allow easier use of a slave interp for actual command execution -(especially when operating in "not local" mode). - -[bullet] - -Add host list (xhost-like) or "magic cookie" (xauth-like) -authentication to initial handshake. - -[list_end] - -[para] -The following are outstanding todo items. - -[list_begin bullet] -[bullet] - -Add an interp discovery and name->port mapping. This is likely to be -in a separate, optional nameserver. (See also the related work, -below.) - -[bullet] - -Fix the [emph "{id host}"] form so as not to be dependent upon -canonical hostnames. This requires fixes to Tcl to resolve hostnames! - -[list_end] - -[para] -This man page is bigger than the source file. - - -[section "ON USING OLD VERSIONS OF TCL"] - -[para] -Tcl7.5 under Windows contains a bug that causes the interpreter to -hang when EOF is reached on non-blocking sockets. This can be -triggered with a command such as this: - -[para] -[example { - "comm send $other exit" -}] - -[para] -Always make sure the channel is quiescent before closing/exiting or -use at least Tcl7.6 under Windows. - -[para] -Tcl7.6 on the Mac contains several bugs. It is recommended you use -at least Tcl7.6p2. - -[para] -Tcl8.0 on UNIX contains a socket bug that can crash Tcl. It is recommended -you use Tcl8.0p1 (or Tcl7.6p2). - - -[section "RELATED WORK"] -[para] -Tcl-DP provides an RPC-based remote execution interface, but is a -compiled Tcl extension. See -[emph http://www.cs.cornell.edu/Info/Projects/zeno/Projects/Tcl-DP.html]. - -[para] -Michael Doyle has code that implements the Tcl-DP -RPC interface using standard Tcl sockets, much like [package comm] - -[para] -Andreas Kupries uses -[package comm] and has built a simple nameserver as part of his Pool -library. See [uri http://www.purl.org/net/akupries/soft/pool/index.htm]. - -[see_also send(n)] -[manpage_end] - DELETED modules/comm/comm.n Index: modules/comm/comm.n ================================================================== --- modules/comm/comm.n +++ /dev/null @@ -1,983 +0,0 @@ -.\" $Id: comm.n,v 1.4 2002/01/18 20:51:15 andreas_kupries Exp $ -.\" %%_OSF_FREE_COPYRIGHT_%% -.\" Copyright (C) 1995-1998 The Open Group. All Rights Reserved. -.\" (Please see the file "comm.LICENSE" that accompanied this source) -.\" -.so man.macros -.TH comm n 3.7 comm "package comm 3.7.1" -.SH NAME -comm.tcl \- A remote communications facility for Tcl (7.6, 8.0, and later) -.SH SYNOPSIS -.nf -\fBpackage require comm ?3.7.1?\fR -.sp -\fIchan \fBnew \fIchan\fR ?\fIname value ...\fR? -\fIchan \fBsend \fR?\fI-async\fR? \fIid cmd \fR?\fIarg arg ...\fR? -\fIchan \fBhook \fIevent\fR ?\fB+\fR??\fIscript\fR? -\fIchan \fIoption\fP ?\fI arg arg ...\fR? -.fi -The package initializes \fB::comm::comm\fR as the default \fIchan\fR. -.SH "INTRODUCTION" -.PP -The -.B comm -command provides an inter-interpreter remote execution facility -much like Tk's -.IR send "(n)", -except that it uses sockets rather than -the X server for the communication path. -As a result, -.B comm -works with multiple interpreters, -works on Windows and Macintosh systems, -and -provides control over the remote execution path. -.LP -These commands work just like -.B send -and -.BR "winfo interps" : -.CS - \fB::comm::comm send \fR?\fI-async\fR? \fIid cmd \fR?\fIarg arg ...\fR? - \fB::comm::comm interps\fP -.CE -.PP -This is all that is really needed to know in order to use -.BR comm . -'\" -'\" -'\" -.SH DESCRIPTION -.PP -.B comm -names communication endpoints with an -.I id -unique to each machine. -Before sending commands, the -.I id -of another interpreter is needed. -Unlike Tk's send, -.B comm -doesn't implicitly know the -.IR id 's -of all the interpreters on the system. -.TP -\fB::comm::comm send \fR?\fI-async\fR? \fIid cmd \fR?\fIarg arg ...\fR? -This invokes the given command in the interpreter named by -.IR id . -The command waits for the result and remote errors are returned -unless the -.B -async -option is given. -.TP -\fB::comm::comm self\fP -Returns the -.I id -for this channel. -.TP -\fB::comm::comm interps\fP -Returns a list of all the remote -.IR id 's -to which this channel is connected. -.B comm -learns a new remote -.I id -when a command is first issued it, -or when a remote -.I id -first issues a command to this comm channel. -\fB::comm::comm ids\fP -is an alias for this method. -.TP -\fB::comm::comm connect \fR?\fIid\fR? -Whereas -.B "::comm::comm send" -will automatically connect to the given -.IR id , -this forces a connection to a remote -.I id -without sending a command. -After this, the remote -.I id -will appear in -.BR "::comm::comm interps" . -.LP -These four methods make up the basic -.B comm -interface. -'\" -'\" -'\" -.SH "EVAL SEMANTICS" -.PP -The evaluation semantics of -.B "::comm::comm send" -are intended to match Tk's -.B send -.IR exactly . -This means that -.B comm -evaluates arguments on the remote side. -.LP -If you find that -.B "::comm::comm send" -doesn't work for a particular command, -try the same thing with Tk's send and see if the result is different. -If there is a problem, please report it. -For instance, there was had one report that this command produced an error. -Note that the equivalent -.B send -command also produces the same error. -.CS - % \fB::comm::comm send \fIid\fP llength {a b c} - \fBwrong # args: should be "llength list"\fR - % \fBsend \fIname\fP llength {a b c} - \fBwrong # args: should be "llength list"\fR -.CE -.LP -The -.B eval -hook (described below) can be used to change from -.BR send 's -double eval semantics to single eval semantics. -'\" -'\" -'\" -.SH "MULTIPLE CHANNELS" -.PP -More than one -.B comm -channel (or -.IR listener ) -can be created in each Tcl interpeter. -This allows flexibility to create full and restricted channels. -For instance, -.B hook -scripts are specific to the channel they are defined against. -.TP -\fB::comm::comm new \fIchan\fR ?\fIname value ...\fR? -This creates a new channel and Tcl command with the given channel name. -This new command controls the new channel and takes all the same -arguments as -.BR ::comm::comm . -Any remaining arguments are passed to the -.B config -method. -.TP -\fB::comm::comm channels\fR -This lists all the channels allocated in this Tcl interpreter. -.LP -The default configuration parameters for a new channel are: -.PP -.CS -.B "-port 0 -local 1 -listen 0" -.CE -.PP -The default channel -.B ::comm::comm -is created with: -.PP -.CS -.B "::comm::comm new ::comm::comm -port 0 -local 1 -listen 1" -.CE -'\" -'\" -'\" -.SH "CHANNEL CONFIGURATION" -.PP -The -.B config -method acts similar to -.B fconfigure -in that it sets or queries configuration variables associated with a channel. -.RS -\fB::comm::comm config -.br -\fB::comm::comm config \fIname\fR -.br -\fB::comm::comm config ?\fIname value ...\fR? -.RE -When given no arguments, -.B config -returns a list of all variables and their value -With one argument, -.B config -returns the value of just that argument. -With an even number of arguments, the given variables are set to the -given values. -.PP -These configuration variables can be changed -(descriptions of them are elsewhere in this manual page): -.RS --\fBlisten \fR?\fI0|1\fR? --\fBlocal \fR?\fI0|1\fR? --\fBport \fR?\fIport\fR? -.RE -.sp -These configuration variables are readonly: -.RS --\fBchan\fR \fIchan\fR --\fBserial\fR \fIn\fR --\fBsocket\fR sock\fIn\fR -.RE -.PP -When -.B config -changes the parameters of an existing channel, -it closes and reopens the listening socket. -An automatically assigned channel -.I id -will change when this happens. -Recycling the socket is done by invoking -.BR "::comm::comm abort" , -which causes all active sends to terminate. -'\" -'\" -'\" -.SH "ID/PORT ASSIGNMENTS" -.PP -.B comm -uses a TCP port for endpoint -.IR id . -The -.B interps -(or -.BR ids ) -method merely lists all the TCP ports to which the channel is connected. -By default, each channel's -.I id -is randomly assigned by the operating system -(but usually starts at a low value around 1024 and increases -each time a new socket is opened). -This behavior is accomplished by giving the -.B "-port" -config option a value of 0. -Alternately, a specific TCP port number may be provided for a given channel. -As a special case, comm contains code to allocate a -a high-numbered TCP port (>10000) by using -.BR "-port {}" . -Note that a channel won't be created and initialized -unless the specific port can be allocated. -.PP -As a special case, if the channel is configured with -.BR "-listen 0", -then it will not create a listening socket and will use an id of -.I 0 -for itself. -Such a channel is only good for outgoing connections -(although once a connection is established, it can carry send traffic -in both directions). -'\" -'\" -'\" -.SH "REMOTE INTERPRETERS" -.PP -By default, each channel is restricted to accepting connections from the -local system. This can be overriden by using the -.B "-local 0" -configuration option -For such channels, the -.I id -parameter takes the form -.BI { "id host" } -.BR "" . -.LP -.BR WARNING : -The -.I host -must always be specified in the same form -(e.g., as either a fully qualified domain name, -plain hostname or an IP address). -'\" -'\" -'\" -.SH "CLOSING CONNECTIONS" -.PP -These methods give control over closing connections: -.TP -\fB::comm::comm shutdown \fIid\fR -This closes the connection to -.IR id , -aborting all outstanding commands in progress. Note that nothing -prevents the connection from being immediately reopened by another -incoming or outgoing command. -.TP -\fB::comm::comm abort\fR -This invokes shutdown on all open connections in this comm channel. -.TP -\fB::comm::comm destroy\fR -This aborts all connections and then destroys the this comm channel itself, -including closing the listening socket. -Special code allows the default -.B ::comm::comm -channel to be closed -such that the -.B ::comm::comm -command it is not destroyed. -Doing so closes the listening socket, preventing both -incoming and outgoing commands on the channel. -This sequence reinitializes the default channel: -.CS -.B "::comm::comm destroy; ::comm::comm new ::comm::comm" -.CE -.PP -When a remote connection is lost (because the remote exited or called -.BR shutdown ), -.B comm -can invoke an application callback. -This can be used to cleanup or restart an ancillary process, -for instance. -See the -.B lost -callback below. -'\" -'\" -'\" -.SH CALLBACKS -.PP -This is a mechanism for setting hooks for particular events: -.CS - \fB::comm::comm hook \fIevent\fR ?\fB+\fR??\fIscript\fR? -.CE -.LP -This uses a syntax similar to Tk's -.B bind -command. -Prefixing -.I script -with a + causes the new script to be appended. -Without this, a new -.I script -replaces any existing script. -When invoked without a script, no change is made. -In all cases, the new hook script is returned by the command. -.LP -When an -.I event -occurs, -the -.I script -associated with it is evaluated -with the listed variables in scope and available. -The return code -.RB ( not -the return value) of the script -is commonly used decide how to further process after the hook. -.LP -Common variables include: -.RS -.IP \fBchan\fR 5 -the name of the comm channel (and command) -.IP \fBid\fR 5 -the id of the remote in question -.IP \fBfid\fR 5 -the file id for the socket of the connection -.RE -.ta 4i -These are the defined -.IR events : -.TP -\fBconnecting\fR -Variables: -.I "chan id host port" -.br -This hook is invoked before making a connection -to the remote named in -.IR id . -An error return (via -.BR error ) -will abort the connection attempt with the error. -Example: -.sp -.CS - % ::comm::comm hook connecting { - if [string match {*[02468]} $id] { - error "Can't connect to even ids" - } - } - % ::comm::comm send 10000 puts ok - Connect to remote failed: Can't connect to even ids - % -.CE -.\" -.TP -.B connected -Variables: -.I "chan fid id host port" -.br -This hook is invoked immediately after making a remote connection to -.IR id , -allowing arbitrary authentication over the socket -named by -.IR fid . -An error return (via -.BR error ) -will close the connection with the error. -.I host -and -.I port -are merely extracted from the -.IR id ; -changing any of these will have no effect on the connection, however. -It is also possible to substitute and replace \fIfid\fP. -.\" -.TP -\fBincoming\fP -Variables: -.I "chan fid addr remport" -.br -Hook invoked when receiving an incoming connection, -allowing arbitrary authentication over socket -named by -.IR fid . -An error return (via -.BR error ) -will close the connection with the error. -Note that the peer is named by -.IR remport " and " addr -but that the remote -.I id -is still unknown. Example: -.sp -.CS - ::comm::comm hook incoming { - if [string match 127.0.0.1 $addr] { - error "I don't talk to myself" - } - } -.CE -.\" -.TP -\fBeval\fP -Variables: -.I "chan id cmd buffer" -.br -This hook is invoked after collecting a complete script from a remote -but -.B before -evalutating it. -This allows complete control over the processing of incoming commands. -.I cmd -contains either -.BR send " or " async . -.I buffer -holds the script to evaluate. -At the time the hook is called, -.B "$chan remoteid" -is identical in value to -.BR id. -.sp -By changing -.IR buffer , -the hook can change the script to be evaluated. -The hook can short circuit evaluation and cause a -value to be immediately returned by using -.B return -.I result -(or, from within a procedure, -.B "return -code return" -.IR result ). -An error return (via -.BR error ) -will return an error result, as is if the script caused the error. -Any other return will evaluate the script in -.I buffer -as normal. -For compatibility with 3.2, -.B break -and -.B "return -code break" -.I result -is supported, acting similarly to -.B "return {}" -and -.B "return -code return" -.IR result . -.sp -Examples: -.RS -1. augmenting a command -.PP -.CS - % ::comm::comm send [::comm::comm self] pid - 5013 - % ::comm::comm hook eval {puts "going to execute $buffer"} - % ::comm::comm send [::comm::comm self] pid - going to execute pid - 5013 -.CE -.PP -2. short circuting a command -.PP -.CS - % ::comm::comm hook eval {puts "would have executed $buffer"; return 0} - % ::comm::comm send [::comm::comm self] pid - would have executed pid - 0 -.CE -.PP -3. Replacing double eval semantics -.PP -.CS - % ::comm::comm send [::comm::comm self] llength {a b c} - wrong # args: should be "llength list" - % ::comm::comm hook eval {return [uplevel #0 $buffer]} - return [uplevel #0 $buffer] - % ::comm::comm send [::comm::comm self] llength {a b c} - 3 -.CE -.PP -4. Using a slave interpreter -.PP -.CS - % interp create foo - % ::comm::comm hook eval {return [foo eval $buffer]} - % ::comm::comm send [::comm::comm self] set myvar 123 - 123 - % set myvar - can't read "myvar": no such variable - % foo eval set myvar - 123 -.CE -.PP -5. Using a slave interpreter (double eval) -.PP -.CS - % ::comm::comm hook eval {return [eval foo eval $buffer]} -.CE -.PP -6. Subverting the script to execute -.PP -.CS - % ::comm::comm hook eval { - switch -- $buffer { - a {return A-OK} b {return B-OK} default {error "$buffer is a no-no"} - } - } - % ::comm::comm send [::comm::comm self] pid - pid is a no-no - % ::comm::comm send [::comm::comm self] a - A-OK -.CE -.RE - -.\" -.TP -\fBreply\fP -Variables: -.I "chan id buffer ret return()" -.br -This hook is invoked after collecting a complete reply script from a remote -but -.B before -evalutating it. -This allows complete control over the processing of replies to sent commands. -The reply -.I buffer -is in one of the following forms -.RS -.CS - return \fIresult\fP - return -code \fIcode\fP \fIresult\fP - return -code \fIcode\fP -errorinfo \fIinfo\fP -errorcode \fIecode\fP \fImsg\fP -.CE -.PP -For safety reasons, this is decomposed. The return result -is in -.IR ret , -and the return switches are in the return array: -.CS -.I return(-code) -.I return(-errorinfo) -.I return(-errordcode) -.CE -.PP -Any of these may be the empty string. -Modifying -these four variables can change the return value, whereas -modifying -.I buffer -has no effect. -.RE -.\" -.TP -\fBlost\fP -Variables: -.I "chan id reason" -.br -This hook is invoked when the connection to -.I id -is lost. -Return value (or thrown error) is ignored. -.I reason -is an explanatory string indicating why the connection was lost. -Example: -.sp -.CS - ::comm::comm hook lost { - global myvar - if {$myvar(id) == $id} { - myfunc - return - } - } -.CE -.SH UNSUPPORTED -.PP -These interfaces may change or go away in subsequence releases. -.TP -\fB::comm::comm remoteid\fR -Returns the -.I id -of the sender of the last remote command executed on this channel. -If used by a proc being invoked remotely, it -must be called before any events are processed. -Otherwise, another command may get invoked and change the value. -.TP -.B "::comm::comm_send" -Invoking this procedure will substitute the Tk -.B send -and -.B "winfo interps" -commands with these equivalents that use -.BR ::comm::comm . -.sp -.CS - proc send {args} { - eval ::comm::comm send $args - } - rename winfo tk_winfo - proc winfo {cmd args} { - if ![string match in* $cmd] {return [eval [list tk_winfo $cmd] $args]} - return [::comm::comm interps] - } -.CE -'\" -'\" -'\" -.SH SECURITY -.PP -Something here soon. -'\" -'\" -'\" -.SH "BLOCKING SEMANTICS" -.PP -There is one outstanding difference between -.B comm -and -.BR send . -When blocking in a synchronous remote command, -.B send -uses an internal C hook (Tk_RestrictEvents) -to the event loop to look ahead for -send-related events and only process those without processing any other events. -In contrast, -.B comm -uses the -.B vwait -command as a semaphore to indicate the return message has arrived. -The difference is that a synchronous -.B send -will block the application and prevent all events -(including window related ones) from being processed, -while a synchronous -.B comm -will block the application but still allow -other events will still get processed. -In particular, -.B "after idle" -handlers will fire immediately when comm blocks. -.LP -What can be done about this? -First, note that this behavior will come from any code using -.B vwait -to block and wait for an event to occur. -At the cost of multiple channel support, -.B comm -could be changed to do blocking I/O on the socket, -giving send-like blocking semantics. -However, multiple channel support is a very useful feature of comm -that it is deemed too important to lose. -The remaining approaches involve a new loadable module written in C -(which is somewhat against the philosophy of -.BR comm ) -One way would be to create a modified version of the -.B vwait -command that allow the event flags passed to Tcl_DoOneEvent to be specified. -For -.BR comm , -just the TCL_FILE_EVENTS would be processed. -Another way would be to implement a mechanism like Tk_RestrictEvents, but -apply it to the Tcl event loop (since -.B comm -doesn't require Tk). -One of these approaches will be available in a future -.B comm -release as an optional component. -'\" -'\" -'\" -.SH COMPATIBILITY -.PP -.B Comm -exports itself as a package. -The package version number is in the form -.IR major . minor , -where the major version will only change when -a non-compatible change happens to the API or protocol. -Minor bug fixes and changes will only affect the minor version. -To load -.B comm -this command is usually used: -.PP -.CS - \fBpackage require comm 3\fR -.CE -.PP -Note that requiring no version (or a specific version) can also be done. -.LP -The revision history of -.B comm -includes these releases: - -.IP "3.7" 5 -Moved into tcllib and placed in a proper namespace. - -.IP "3.6" 5 -A bug in the looking up of the remoteid for a executed command -could be triggered when the connection was closed while several -asynchronous sends were queued to be executed. - -.IP "3.5" 5 -Internal change to how reply messages from a -.B send -are handled. -Reply messages are now decoded into the -.I value -to pass to -.BR return ; -a new return statement is then cons'd up to with this value. -Previously, the return code was passed in from the remote as a -command to evaluate. Since the wire protocol has not changed, -this is still the case. Instead, the reply handling code decodes the -.B reply -message. - -.IP "3.4" 5 -Added more source commentary, as well as documenting config variables -in this man page. -Fixed bug were loss of connection would give error about a variable -named -.B pending -rather than the message about the lost connection. -.B "comm ids" -is now an alias for -.B "comm interps" -(previously, it an alias for -.BR "comm chans" ). -Since the method invocation change of 3.0, break and other exceptional -conditions were not being returned correctly from -.BR "comm send" . -This has been fixed by removing the extra level of indirection into -the internal procedure -.BR commSend . -Also added propogation of the -.I errorCode -variable. -This means that these commands return exactly as they would with -.BR send : -.RS -.CS - comm send \fIid\fP break - catch {comm send \fIid\fP break} - comm send \fIid\fP expr 1 / 0 -.CE -.PP -Added a new hook for reply messages. -Reworked method invocation to avoid the use of comm:* procedures; -this also cut the invocation time down by 40%. -Documented -.B "comm config" -(as this manual page still listed the defunct -.BR "comm init" !) -.RE - -.IP "3.3" 5 -Some minor bugs were corrected and the documentation was cleaned up. -Added some examples for hooks. The return semantics of the -.B eval -hook were changed. - -.IP "3.2" 5 -A new wire protocol, version 3, was added. This is backwards compatible -with version 2 but adds an exchange of supported protocol versions to -allow protocol negotiation in the future. -Several bugs with the hook implementation were fixed. -A new section of the man page on blocking semantics was added. - -.IP "3.1" 5 -All the documented hooks were implemented. -.B commLostHook -was removed. -A bug in -.B "comm new" -was fixed. - -.IP "3.0" 5 -This is a new version of -.B comm -with several major changes. -There is a new way of creating the methods available under the -.B comm -command. -The -.B "comm init" -method has been retired and is replaced by -.B "comm configure" -which allows access to many of the well-defined internal variables. -This also generalizes the options available to -.BR "comm new" . -Finally, there is now a protocol version exchanged when a connection -is established. This will allow for future on-wire protocol changes. -Currently, the protocol version is set to 2. - -.IP "2.3" 5 -.B "comm ids" -was renamed to -.BR "comm channels" . -General support for -.B "comm hook" -was fully implemented, but -only the -.B lost -hook exists, and it was changed to follow the general hook API. -.B commLostHook -was unsupported (replaced by -.BR "comm hook lost" ) -and -.B commLost -was removed. -.IP "2.2" 5 -The -.B died -hook was renamed -.BR lost , -to be accessed by -.B commLostHook -and an early implementation of -.BR "comm lost hook" . -As such, -.B commDied -is now -.BR commLost . - -.IP "2.1" 5 -Unsupported method -.B "comm remoteid" -was added. - -.IP "2.0" 5 -.B comm -has been rewritten from scratch (but is fully compatible with Comm 1.0, -without the requirement to use obTcl). -'\" -.SH AUTHOR -John LoVerso, John@LoVerso.Southborough.MA.US -.PP -.I http://www.opengroup.org/~loverso/tcl-tk/#comm -'\" -.SH COPYRIGHT -Copyright (C) 1995-1998 The Open Group. All Rights Reserved. -Please see the file -.I comm.LICENSE -that accompanied this source, -or -.IR http://www.opengroup.org/www/dist_client/caubweb/COPYRIGHT.free.html . -.PP -This license for -.BR comm , -new as of version 3.2, -allows it to be used for free, -without any licensing fee or royalty. -'\" -'\" -'\" -.SH BUGS -.IP \(bu -If there is a failure initializing a channel created with -.BR "::comm::comm new" , -then the channel should be destroyed. -Currently, it is left in an inconsistent state. -.IP \(bu -There should be a way to force a channel to quiesce when changing the -configuration. -.LP -The following items can be implemented with the existing hooks -and are listed here as a reminder to provide a sample hook in a future version. -.IP \(bu -Allow easier use of a slave interp for actual command execution -(especially when operating in "not local" mode). -.IP \(bu -Add host list (xhost-like) or "magic cookie" (xauth-like) -authentication to initial handshake. -.LP -The following are outstanding todo items. -.IP \(bu -Add an interp discovery and name->port mapping. -This is likely to be in a separate, optional nameserver. -(See also the related work, below.) -.IP \(bu -Fix the -.I "{id host}" -form so as not to be dependent upon canonical hostnames. -This requires fixes to Tcl to resolve hostnames! -.LP -.sp 2 -This man page is bigger than the source file. -'\" -'\" -'\" -.SH "ON USING OLD VERSIONS OF TCL" -.PP -Tcl7.5 under Windows contains a bug that causes the interpreter to -hang when EOF is reached on non-blocking sockets. This can be -triggered with a command such as this: -.CS -.B "comm send $other exit" -.CE -.PP -Always make sure the channel is quiescent before closing/exiting or -use at least Tcl7.6 under Windows. -.LP -Tcl7.6 on the Mac contains several bugs. It is recommended you use -at least Tcl7.6p2. -.LP -Tcl8.0 on UNIX contains a socket bug that can crash Tcl. It is recommended -you use Tcl8.0p1 (or Tcl7.6p2). -'\" -'\" -'\" -.SH "RELATED WORK" -.PP -Tcl-DP provides an RPC-based remote execution interface, but is a compiled -Tcl extension. See -.IR http://www.cs.cornell.edu/Info/Projects/zeno/Projects/Tcl-DP.html . -.PP -Michael Doyle has code that implements the Tcl-DP RPC -interface using standard Tcl sockets, much like -.BR comm . -.PP -Andreas Kupries uses -.B comm -and has built a simple nameserver as part of his Pool library. -See -.IR http://www.purl.org/net/akupries/soft/pool/index.htm . -'\" -'\" -'\" -.SH "SEE ALSO" -send(n) -'\" -'\" eof -'\" DELETED modules/comm/comm.n.html Index: modules/comm/comm.n.html ================================================================== --- modules/comm/comm.n.html +++ /dev/null @@ -1,1067 +0,0 @@ - - - - - - - - - - - - -Manual page for comm(n) version 3.7.1 - - -

-comm.tcl - A remote communications facility for Tcl (7.6, 8.0, and later) -

-

SYNOPSIS

-package require Comm 3 -

- - - - - -chan send ?-async? id cmd ?arg arg ...? -

-chan interps -

-chan ids -

-chan self -

-chan connect ?id? -

-chan config -
-chan config name -
-chan config ?name value ...? -
-

--listen ?0|1? --local ?0|1? --port ?port? -
-

-chan new chan ?name value ...? -

-chan channels -

-chan shutdown id -

-chan abort -

-chan destroy -

-chan remoteid -

-chan hook event ?+??script? -

-The package initializes comm as the default chan. -

INTRODUCTION

-

-The -comm -command provides an inter-interpreter remote execution facility -much like Tk's -send(n), -except that it uses sockets rather than -the X server for the communication path. -As a result, -comm -works with multiple interpreters, -works on Windows and Macintosh systems, -and -provides control over the remote execution path. -

-These commands work just like -send -and -winfo interps: -

-comm send ?-async? id cmd ?arg arg ...? -
-comm interps -
-
-This is all that is really needed to know in order to use -comm. -

DESCRIPTION

-

-comm -names communication endpoints with an -id -unique to each machine. -Before sending commands, the -id -of another interpreter is needed. -Unlike Tk's send, -comm -doesn't implicitly know the -id's -of all the interpreters on the system. -

-
comm send ?-async? id cmd ?arg arg ...? -
-This invokes the given command in the interpreter named by -id. -The command waits for the result and remote errors are returned -unless the --async -option is given. -
comm self -
-Returns the -id -for this channel. -
comm interps -
-Returns a list of all the remote -id's -to which this channel is connected. -comm -learns a new remote -id -when a command is first issued it, -or when a remote -id -first issues a command to this comm channel. -comm ids -is an alias for this method. -
comm connect ?id? -
-Whereas -comm send -will automatically connect to the given -id, -this forces a connection to a remote -id -without sending a command. -After this, the remote -id -will appear in -comm interps. -
-

-These four methods make up the basic -comm -interface. -

EVAL SEMANTICS

-

-The evaluation semantics of -comm send -are intended to match Tk's -send -exactly. -This means that -comm -evaluates arguments on the remote side. -

-If you find that -comm send -doesn't work for a particular command, -try the same thing with Tk's send and see if the result is different. -If there is a problem, please report it. -For instance, there was had one report that this command produced an error. -Note that the equivalent -send -command also produces the same error. -

-% comm send id llength {a b c} -
-wrong # args: should be "llength list" -
-% send name llength {a b c} -
-wrong # args: should be "llength list" -
-
-

-The -eval -hook (described below) can be used to change from -send's -double eval semantics to single eval semantics. -

MULTIPLE CHANNELS

-

-More than one -comm -channel (or -listener) -can be created in each Tcl interpeter. -This allows flexibility to create full and restricted channels. -For instance, -hook -scripts are specific to the channel they are defined against. -

-
comm new chan ?name value ...? -
-This creates a new channel and Tcl command with the given channel name. -This new command controls the new channel and takes all the same -arguments as -comm. -Any remaining arguments are passed to the -config -method. -
comm channels -
-This lists all the channels allocated in this Tcl interpreter. -
-

-The default configuration parameters for a new channel are: -

--port 0 -local 1 -listen 0 -
-The default channel -comm -is created with: -
-comm new comm -port 0 -local 1 -listen 1 -
-

CHANNEL CONFIGURATION

-

-The -config -method acts similar to -fconfigure -in that it sets or queries configuration variables associated with a channel. -

-comm config -
-comm config name -
-comm config ?name value ...? -
-When given no arguments, -config -returns a list of all variables and their value -With one argument, -config -returns the value of just that argument. -With an even number of arguments, the given variables are set to the -given values. -

-These configuration variables can be changed -(descriptions of them are elsewhere in this manual page): -

--listen ?0|1? --local ?0|1? --port ?port? -
-

-These configuration variables are readonly: -

--chan chan --serial n --socket sockn -
-

-When -config -changes the parameters of an existing channel, -it closes and reopens the listening socket. -An automatically assigned channel -id -will change when this happens. -Recycling the socket is done by invoking -comm abort, -which causes all active sends to terminate. -

ID/PORT ASSIGNMENTS

-

-comm -uses a TCP port for endpoint -id. -The -interps -(or -ids) -method merely lists all the TCP ports to which the channel is connected. -By default, each channel's -id -is randomly assigned by the operating system -(but usually starts at a low value around 1024 and increases -each time a new socket is opened). -This behavior is accomplished by giving the --port -config option a value of 0. -Alternately, a specific TCP port number may be provided for a given channel. -As a special case, comm contains code to allocate a -a high-numbered TCP port (>10000) by using --port {}. -Note that a channel won't be created and initialized -unless the specific port can be allocated. -

-As a special case, if the channel is configured with --listen 0, -then it will not create a listening socket and will use an id of -0 -for itself. -Such a channel is only good for outgoing connections -(although once a connection is established, it can carry send traffic -in both directions). -

REMOTE INTERPRETERS

-

-By default, each channel is restricted to accepting connections from the -local system. This can be overriden by using the --local 0 -configuration option -For such channels, the -id -parameter takes the form -{id host} -. -

-WARNING: -The -host -must always be specified in the same form -(e.g., as either a fully qualified domain name, -plain hostname or an IP address). -

CLOSING CONNECTIONS

-

-These methods give control over closing connections: -

-
comm shutdown id -
-This closes the connection to -id, -aborting all outstanding commands in progress. Note that nothing -prevents the connection from being immediately reopened by another -incoming or outgoing command. -
comm abort -
-This invokes shutdown on all open connections in this comm channel. -
comm destroy -
-This aborts all connections and then destroys the this comm channel itself, -including closing the listening socket. -Special code allows the default -comm -channel to be closed -such that the -comm -command it is not destroyed. -Doing so closes the listening socket, preventing both -incoming and outgoing commands on the channel. -This sequence reinitializes the default channel: -
-
-comm destroy; comm new comm -
-

-When a remote connection is lost (because the remote exited or called -shutdown), -comm -can invoke an application callback. -This can be used to cleanup or restart an ancillary process, -for instance. -See the -lost -callback below. -

CALLBACKS

-

-This is a mechanism for setting hooks for particular events: -

-comm hook event ?+??script? -
-
-

-This uses a syntax similar to Tk's -bind -command. -Prefixing -script -with a + causes the new script to be appended. -Without this, a new -script -replaces any existing script. -When invoked without a script, no change is made. -In all cases, the new hook script is returned by the command. -

-When an -event -occurs, -the -script -associated with it is evaluated -with the listed variables in scope and available. -The return code -(not -the return value) of the script -is commonly used decide how to further process after the hook. -

-Common variables include: -

-
-
chan
-the name of the comm channel (and command) -
id
-the id of the remote in question -
fid
-the file id for the socket of the connection -
-
- - -These are the defined -events: -
-
connecting -
-Variables: -chan id host port -
-This hook is invoked before making a connection -to the remote named in -id. -An error return (via -error) -will abort the connection attempt with the error. -Example: -

-

-
-% comm hook connecting { -
- if [string match {*[02468]} $id] { -
- error "Can't connect to even ids" -
- } -
-} -
-% comm send 10000 puts ok -
-Connect to remote failed: Can't connect to even ids -
-% -
-
- -
-
connected -
-Variables: -chan fid id host port -
-This hook is invoked immediately after making a remote connection to -id, -allowing arbitrary authentication over the socket -named by -fid. -An error return (via -error) -will close the connection with the error. -host -and -port -are merely extracted from the -id; -changing any of these will have no effect on the connection, however. -It is also possible to substitute and replace -fid . - - -
incoming -
-Variables: -chan fid addr remport -
-Hook invoked when receiving an incoming connection, -allowing arbitrary authentication over socket -named by -fid. -An error return (via -error) -will close the connection with the error. -Note that the peer is named by -remport and addr -but that the remote -id -is still unknown. Example: -

-

-
-comm hook incoming { -
- if [string match 127.0.0.1 $addr] { -
- error "I don't talk to myself" -
- } -
-} -
-
- -
-
eval -
-Variables: -chan id cmd buffer -
-This hook is invoked after collecting a complete script from a remote -but -before -evalutating it. -This allows complete control over the processing of incoming commands. -cmd -contains either -send or async. -buffer -holds the script to evaluate. -At the time the hook is called, -$chan remoteid -is identical in value to -id. -

-By changing -buffer, -the hook can change the script to be evaluated. -The hook can short circuit evaluation and cause a -value to be immediately returned by using -return -result -(or, from within a procedure, -return -code return -result). -An error return (via -error) -will return an error result, as is if the script caused the error. -Any other return will evaluate the script in -buffer -as normal. -For compatibility with 3.2, -break -and -return -code break -result -is supported, acting similarly to -return {} -and -return -code return -result. -

-Examples: -

-
-1. augmenting a command -
-% comm send [comm self] pid -
-5013 -
-% comm hook eval {puts "going to execute $buffer"} -
-% comm send [comm self] pid -
-going to execute pid -
-5013 -
-
-2. short circuting a command -
-% comm hook eval {puts "would have executed $buffer"; return 0} -
-% comm send [comm self] pid -
-would have executed pid -
-0 -
-
-3. Replacing double eval semantics -
-% comm send [comm self] llength {a b c} -
-wrong # args: should be "llength list" -
-% comm hook eval {return [uplevel #0 $buffer]} -
-return [uplevel #0 $buffer] -
-% comm send [comm self] llength {a b c} -
-3 -
-
-4. Using a slave interpreter -
-% interp create foo -
-% comm hook eval {return [foo eval $buffer]} -
-% comm send [comm self] set myvar 123 -
-123 -
-% set myvar -
-can't read "myvar": no such variable -
-% foo eval set myvar -
-123 -
-
-5. Using a slave interpreter (double eval) -
-% comm hook eval {return [eval foo eval $buffer]} -
-
-6. Subverting the script to execute -
-% comm hook eval { -
- switch -- $buffer { -
- a {return A-OK} b {return B-OK} default {error "$buffer is a no-no"} -
- } -
-} -
-% comm send [comm self] pid -
-pid is a no-no -
-% comm send [comm self] a -
-A-OK -
-
-
- -
-
reply -
-Variables: -chan id buffer ret return() -
-This hook is invoked after collecting a complete reply script from a remote -but -before -evalutating it. -This allows complete control over the processing of replies to sent commands. -The reply -buffer -is in one of the following forms -
-
-
-return result -
-return -code code result -
-return -code code -errorinfo info -errorcode ecode msg -
-
-For safety reasons, this is decomposed. The return result -is in -ret, -and the return switches are in the return array: -
-return(-code) -return(-errorinfo) -return(-errordcode) -
-Any of these may be the empty string. -Modifying -these four variables can change the return value, whereas -modifying -buffer -has no effect. -
- -
-
lost -
-Variables: -chan id reason -
-This hook is invoked when the connection to -id -is lost. -Return value (or thrown error) is ignored. -reason -is an explanatory string indicating why the connection was lost. -Example: -

-

-
-comm hook lost { -
- global myvar -
- if {$myvar(id) == $id} { -
- myfunc -
- return -
- } -
-} -
-
-

UNSUPPORTED

-

-These interfaces may change or go away in subsequence releases. -

-
comm remoteid -
-Returns the -id -of the sender of the last remote command executed on this channel. -If used by a proc being invoked remotely, it -must be called before any events are processed. -Otherwise, another command may get invoked and change the value. -
comm_send -
-Invoking this procedure will substitute the Tk -send -and -winfo interps -commands with these equivalents that use -comm. -

-

-
-proc send {args} { -
- eval comm send $args -
-} -
-rename winfo tk_winfo -
-proc winfo {cmd args} { -
- if ![string match in* $cmd] {return [eval [list tk_winfo $cmd] $args]} -
- return [comm interps] -
-} -
-
-

SECURITY

-

-Something here soon. -

BLOCKING SEMANTICS

-

-There is one outstanding difference between -comm -and -send. -When blocking in a synchronous remote command, -send -uses an internal C hook (Tk_RestrictEvents) -to the event loop to look ahead for -send-related events and only process those without processing any other events. -In contrast, -comm -uses the -vwait -command as a semaphore to indicate the return message has arrived. -The difference is that a synchornous -send -will block the application and prevent all events -(including window related ones) from being processed, -while a synchronous -comm -will block the application but still allow -other events will still get processed. -In particular, -after idle -handlers will fire immediately when comm blocks. -

-What can be done about this? -First, note that this behavior will come from any code using -vwait -to block and wait for an event to occur. -At the cost of multiple channel support, -comm -could be changed to do blocking I/O on the socket, -givng send-like blocking semantics. -However, multiple channel support is a very useful feature of comm -that it is deemed too important to lose. -The remaining approaches involve a new loadable module written in C -(which is somewhat against the philosophy of -comm) -One way would be to create a modified version of the -vwait -command that allow the event flags passed to Tcl_DoOneEvent to be specified. -For -comm, -just the TCL_FILE_EVENTS would be processed. -Another way would be to implement a mechanism like Tk_RestrictEvents, but -apply it to the Tcl event loop (since -comm -doesn't require Tk). -One of these approaches will be available in a future -comm -release as an optional component. -

COMPATIBILITY

-

-Comm -exports itself as a package. -The package version number is in the form -major.minor, -where the major version will only change when -a non-compatible change happens to the API or protocol. -Minor bug fixes and changes will only affect the minor version. -To load -comm -this command is usually used: -

-package require Comm 3 -
-
-Note that requiring no version (or a specific version) can also be done. -

-The revision history of -comm -includes these releases: - -

-
3.6
-A bug in the looking up of the remoteid for a executed command -could be triggered when the connection was closed while several -asynchronous sends were queued to be executed. - -
3.5
-Internal change to how reply messages from a -send -are handled. -Reply messages are now decoded into the -value -to pass to -return; -a new return statement is then cons'd up to with this value. -Previously, the return code was passed in from the remote as a -command to evaluate. Since the wire protocol has not changed, -this is still the case. Instead, the reply handling code decodes the -reply -message. - -
3.4
-Added more source commentary, as well as documenting config variables -in this man page. -Fixed bug were loss of connection would give error about a variable -named -rather than the message about the lost connection. -comm ids -is now an alias for -comm interps -(previously, it an alias for -comm chans). -Since the method invocation change of 3.0, break and other exceptional -conditions were not being returned correctly from -comm send. -This has been fixed by removing the extra level of indirection into -the internal procedure -commSend. -Also added propogation of the -errorCode -variable. -This means that these commands return exactly as they would with -send: -
-
-
-comm send id break -
-catch {comm send id break} -
-comm send id expr 1 / 0 -
-
-Added a new hook for reply messages. -Reworked method invocation to avoid the use of comm:* procedures; -this also cut the invocation time down by 40%. -Documented -comm config -(as this manual page still listed the defunct -comm init!) -
- -
-
3.3
-Some minor bugs were corrected and the documentation was cleaned up. -Added some examples for hooks. The return semantics of the -eval -hook were changed. - -
3.2
-A new wire protocol, version 3, was added. This is backwards compatible -with version 2 but adds an exchange of supported protocol versions to -allow protocol negotiation in the future. -Several bugs with the hook implementation were fixed. -A new section of the man page on blocking semantics was added. - -
3.1
-All the documented hooks were implemented. -commLostHook -was removed. -A bug in -comm new -was fixed. - -
3.0
-This is a new version of -comm -with several major changes. -There is a new way of creating the methods available under the -comm -command. -The -comm init -method has been retired and is replaced by -comm configure -which allows access to many of the well-defined internal variables. -This also generalizes the options available to -comm new. -Finally, there is now a protocol version exchanged when a connection -is established. This will allow for future on-wire protocol changes. -Currently, the protocol version is set to 2. - -
2.3
-comm ids -was renamed to -comm channels . -General support for -comm hook -was fully implemented, but -only the -lost -hook exists, and it was changed to follow the general hook API. -commLostHook -was unsupported (replaced by -comm hook lost ) -and -commLost -was removed. - -
2.2
-The -died -hook was renamed -lost, -to be accessed by -commLostHook -and an early implementation of -comm lost hook. -As such, -commDied -is now -commLost. - -
2.1
-Unsupported method -comm remoteid -was added. - -
2.0
-comm -has been rewritten from scratch (but is fully compatible with Comm 1.0, -without the requirement to use obTcl). -
-

SEE ALSO

-send(n) -

AUTHOR

-John LoVerso, John@LoVerso.Southborough.MA.US -

-http://www.opengroup.org/~loverso/tcl-tk/#comm -

COPYRIGHT

-Copyright (C) 1995-1998 The Open Group. All Rights Reserved. -Please see the file -comm.LICENSE -that accompanied this source, -or -http://www.opengroup.org/www/dist_client/caubweb/COPYRIGHT.free.html. -

-This license for -comm, -new as of version 3.2, -allows it to be used for free, -without any licensing fee or royalty. -

BUGS

-
    -
  • -If there is a failure initializing a channel created with -comm new, -then the channel should be destroyed. -Currently, it is left in an inconsistent state. -
  • -There should be a way to force a channel to quiesce when changing the -configuration. -
-

-The following items can be implemented with the existing hooks -and are listed here as a reminder to provide a sample hook in a future version. -

    -
  • -Allow easier use of a slave interp for actual command execution -(especially when operating in "not local" mode). -
  • -Add host list (xhost-like) or "magic cookie" (xauth-like) -authentication to initial handshake. -
-

-The following are outstanding todo items. -

    -
  • -Add an interp discovery and name->port mapping. -This is likely to be in a separate, optional nameserver. -(See also the related work, below.) -
  • -Fix the -{id host} -form so as not to be dependent upon canonical hostnames. -This requires fixes to Tcl to resolve hostnames! -
-

-

-

-This man page is bigger than the source file. -

ON USING OLD VERSIONS OF TCL

-

-Tcl7.5 under Windows contains a bug that causes the interpreter to -hang when EOF is reached on non-blocking sockets. This can be -triggered with a command such as this: -

-comm send $other exit -
-Always make sure the channel is quiescent before closing/exiting or -use at least Tcl7.6 under Windows. -

-Tcl7.6 on the Mac contains several bugs. It is recommended you use -at least Tcl7.6p2. -

-Tcl8.0 on UNIX contains a socket bug that can crash Tcl. It is recommended -you use Tcl8.0p1 (or Tcl7.6p2). -

RELATED WORK

-

-Tcl-DP provides an RPC-based remote execution interface, but is a compiled -Tcl extension. See -http://www.cs.cornell.edu/Info/Projects/zeno/Projects/Tcl-DP.html. -

-Michael Doyle <miked@eolas.com> has code that implements the Tcl-DP RPC -interface using standard Tcl sockets, much like -comm. -

-Andreas Kupries <a.kupries@westend.com> uses -comm -and has built a simple nameserver as part of his Pool library. -See -http://www.westend.com/~kupries/doc/pool/index.htm. - -

-Markup created by unroff 1.0,    May 30, 1998. - - DELETED modules/comm/comm.tcl Index: modules/comm/comm.tcl ================================================================== --- modules/comm/comm.tcl +++ /dev/null @@ -1,1087 +0,0 @@ -# comm.tcl -- -# -# socket-based 'send'ing of commands between interpreters. -# -# %%_OSF_FREE_COPYRIGHT_%% -# Copyright (C) 1995-1998 The Open Group. All Rights Reserved. -# (Please see the file "comm.LICENSE" that accompanied this source, -# or http://www.opengroup.org/www/dist_client/caubweb/COPYRIGHT.free.html) -# -# This is the 'comm' package written by Jon Robert LoVerso, placed -# into its own namespace during integration into tcllib. -# -# Note that the actual code was changed in several places (Reordered, -# eval speedup) -# -# comm works just like Tk's send, except that it uses sockets. -# These commands work just like "send" and "winfo interps": -# -# comm send ?-async? ? ...? -# comm interps -# -# See the manual page comm.n for further details on this package. -# -# RCS: @(#) $Id: comm.tcl,v 1.8 2003/04/11 19:39:12 andreas_kupries Exp $ - -package require Tcl 8.2 - -namespace eval ::comm { - namespace export comm comm_send - - variable comm - array set comm {} - - if {![info exists comm(chans)]} { - array set comm { - debug 0 chans {} localhost 127.0.0.1 - connecting,hook 1 - connected,hook 1 - incoming,hook 1 - eval,hook 1 - reply,hook 1 - lost,hook 1 - offerVers {3 2} - acceptVers {3 2} - defVers 2 - } - set comm(lastport) [expr {[pid] % 32768 + 9999}] - # fast check for acceptable versions - foreach comm(_x) $comm(acceptVers) { - set comm($comm(_x),vers) 1 - } - catch {unset comm(_x)} - } - - # Class variables: - # lastport saves last default listening port allocated - # debug enable debug output - # chans list of allocated channels - # $meth,method body of method - # - # Channel instance variables: - # comm() - # $ch,port listening port (our id) - # $ch,socket listening socket - # $ch,local boolean to indicate if port is local - # $ch,serial next serial number for commands - # - # $ch,hook,$hook script for hook $hook - # - # $ch,peers,$id open connections to peers; ch,id=>fid - # $ch,fids,$fid reverse mapping for peers; ch,fid=>id - # $ch,vers,$id negotiated protocol version for id - # $ch,pending,$id list of outstanding send serial numbers for id - # - # $ch,buf,$fid buffer to collect incoming data - # $ch,result,$serial result value set here to wake up sender - # $ch,return,$serial return codes to go along with result - - # Special initialization, defines the method 'method' to be used - # for the definition of new methods (sic!). The code is executed - # in the scope of the procedure '::comm::comm''. This means that - # they have only access to the 'args' argument and the 'chan' - # variable. This includes 'method' itself. - - # Create the methods on comm - # Perhaps this shouldn't store them as procs? - - set comm(method,method) { - # args[0] = name of method - # args[1..end] = body of method - - if {[llength $args] == 1} { - # No body given, call is query for body. - if [info exists comm([lindex $args 0],method)] { - return $comm([lindex $args 0],method) - } else { - error "No such method" - } - } - # Define new method. - eval [linsert [lrange $args 1 end] 0 \ - set [list comm([lindex $args 0],method)]] - #eval set [list comm([lindex $args 0],method)] [lrange $args 1 end] - } - - if {0} { - # Propogate result, code, and errorCode. Can't just eval - # otherwise TCL_BREAK gets turrned into TCL_ERROR. - global errorInfo errorCode - set code [catch [concat commSend $args] res] - return -code $code -errorinfo $errorInfo -errorcode $errorCode $res - } -} - -# ::comm::comm_send -- -# -# Convenience command. Replaces Tk 'send' and 'winfo' with -# versions using the 'comm' variants. Multiple calls are -# allowed, only the first one will have an effect. -# -# Arguments: -# None. -# -# Results: -# None. - -proc ::comm::comm_send {} { - proc send {args} { - # Use pure lists to speed this up. - eval [linsert $args 0 ::comm::comm send] - #eval comm send $args - } - rename winfo tk_winfo - proc winfo {cmd args} { - if {![string match in* $cmd]} { - # Use pure lists to speed this up ... - return [eval [linsert $args 0 tk_winfo $cmd]] - #return [eval [list tk_winfo $cmd] $args] - } - return [::comm::comm interps] - } - proc ::comm::comm_send {} {} -} - -# ::comm::comm -- -# -# See documentation for public methods of "comm". -# This procedure is followed by the definition of -# the public methods themselves. -# -# Arguments: -# cmd Invoked method -# args Arguments to method. -# -# Results: -# As of the invoked method. - -proc ::comm::comm {cmd args} { - variable comm - set chan ::comm::comm ; # chan is used in the code of the declared methods. - - set method [array names comm $cmd*,method] ;# min unique - - if {[llength $method] == 1} { - return [eval $comm($method)] - } else { - foreach c [array names comm *,method] { - lappend cmds [lindex [split $c ,] 0] - } - error "bad subcommand \"$cmd\": should be [join [lsort $cmds] ", "]" - } -} - -::comm::comm method connect { - #eval commConnect $args - eval [linsert $args 0 commConnect] -} -::comm::comm method self { - set comm($chan,port) -} -::comm::comm method channels { - set comm(chans) -} -::comm::comm method new { - #eval commNew $args - eval [linsert $args 0 commNew] -} -::comm::comm method configure { - #eval commConfigure 0 $args - eval [linsert $args 0 commConfigure 0] -} -::comm::comm method shutdown { - eval commShutdown $args - #eval commShutdown $args -} -::comm::comm method abort { - eval [linsert $args 0 commAbort] - #eval commAbort $args -} -::comm::comm method destroy { - eval [linsert $args 0 commDestroy] - #eval commDestroy $args -} -::comm::comm method hook { - eval [linsert $args 0 commHook] - #eval commHook $args -} -::comm::comm method ids { - set res $comm($chan,port) - foreach {i id} [array get comm $chan,fids,*] {lappend res $id} - set res -} -::comm::comm method interps \ - [::comm::comm method ids] -::comm::comm method remoteid { - if {[info exists comm($chan,remoteid)]} { - set comm($chan,remoteid) - } else { - error "No remote commands processed yet" - } -} -::comm::comm method debug { - set comm(debug) \ - [switch -exact -- $args on - 1 {subst 1} default {subst 0}] -} -::comm::comm method init { - error "This method is no longer supported" -} -::comm::comm method send { - set cmd send - - # args = ?-async? id cmd ?arg arg ...? - set i 0 - if {[string match -async [lindex $args $i]]} { - set cmd async - incr i - } - # args = id cmd ?arg arg ...? - - set id [lindex $args $i] - incr i - set args [lrange $args $i end] - - if {![info complete $args]} { - return -code error "Incomplete command" - } - if {[string match "" $args]} { - return -code error \ - "wrong # args: should be \"send ?-async? id arg ?arg ...?\"" - } - if {[catch {commConnect $id} fid]} { - return -code error "Connect to remote failed: $fid" - } - - set ser [incr comm($chan,serial)] - # This is unneeded - wraps from 2147483647 to -2147483648 - ### if {$comm($chan,serial) == 0x7fffffff} {set comm($chan,serial) 0} - - commDebug {puts stderr "send <[list [list $cmd $ser $args]]>"} - - # The double list assures that the command is a single list when read. - puts $fid [list [list $cmd $ser $args]] - flush $fid - - # wait for reply if so requested - - if {[string match send $cmd]} { - upvar 0 comm($chan,pending,$id) pending ;# shorter variable name - - lappend pending $ser - set comm($chan,return,$ser) "" ;# we're waiting - - commDebug {puts stderr "--<>--"} - vwait ::comm::comm($chan,result,$ser) - - # if connection was lost, pending is gone - if {[info exists pending]} { - set pos [lsearch -exact $pending $ser] - set pending [lreplace $pending $pos $pos] - } - - commDebug { - puts stderr "result\ - <$comm($chan,return,$ser);$comm($chan,result,$ser)>" - } - after idle unset ::comm::comm($chan,result,$ser) - - array set return $comm($chan,return,$ser) - unset comm($chan,return,$ser) - switch -- $return(-code) { - "" - 0 {return $comm($chan,result,$ser)} - 1 { - return -code $return(-code) \ - -errorinfo $return(-errorinfo) \ - -errorcode $return(-errorcode) \ - $comm($chan,result,$ser) - } - default {return -code $return(-code) $comm($chan,result,$ser)} - } - } -} - -############################################################################### - -# ::comm::commDebug -- -# -# Internal command. Conditionally executes debugging -# statements. Currently this are only puts commands logging the -# various interactions. These could be replaced with calls into -# the 'log' module. -# -# Arguments: -# arg Tcl script to execute. -# -# Results: -# None. - -proc ::comm::commDebug {arg} { - variable comm - if {$comm(debug)} { - uplevel 1 $arg - } -} - -# ::comm::commNew -- -# -# Internal command. Create a new comm channel/instance. -# Implements the 'comm new' method. -# -# Arguments: -# ch Name of the new channel -# args Configuration, in the form of -option value pairs. -# -# Results: -# None. - -proc ::comm::commNew {ch args} { - variable comm - - if {[lsearch -exact $comm(chans) $ch] >= 0} { - error "Already existing channel: $ch" - } - if {([llength $args] % 2) != 0} { - error "Must have an even number of config arguments" - } - if {[string match ::comm::comm $ch]} { - # allow comm to be recreated after destroy - } elseif {![string compare $ch [info proc $ch]]} { - error "Already existing command: $ch" - } else { - regsub "set chan \[^\n\]*\n" [info body ::comm::comm] \ - "set chan $ch\n" nbody - proc $ch {cmd args} $nbody - } - lappend comm(chans) $ch - set chan $ch - set comm($chan,serial) 0 - set comm($chan,chan) $chan - set comm($chan,port) 0 - set comm($chan,listen) 0 - set comm($chan,socket) "" - set comm($chan,local) 1 - - if {[llength $args] > 0} { - eval [linsert $args 0 commConfigure 1] - #eval commConfigure 1 $args - } - # XXX need to destroy chan if config failed -} - -# ::comm::commDestroy -- -# -# Internal command. Destroy the channel invoking it. -# Implements the 'comm destroy' method. -# -# Arguments: -# None. -# -# Results: -# None. - -proc ::comm::commDestroy {} { - upvar chan chan - variable comm - catch {close $comm($chan,socket)} - commAbort - catch {unset comm($chan,port)} - catch {unset comm($chan,local)} - catch {unset comm($chan,socket)} - unset comm($chan,serial) - set pos [lsearch -exact $comm(chans) $chan] - set comm(chans) [lreplace $comm(chans) $pos $pos] - if {[string compare ::comm::comm $chan]} { - rename $chan {} - } -} - -# ::comm::commConfVars -- -# -# Internal command. Used to declare configuration options. -# -# Arguments: -# v Name of configuration option. -# t Default value. -# -# Results: -# None. - -proc ::comm::commConfVars {v t} { - variable comm - set comm($v,var) $t - set comm(vars) {} - foreach c [array names comm *,var] { - lappend comm(vars) [lindex [split $c ,] 0] - } -} -::comm::commConfVars port p -::comm::commConfVars local b -::comm::commConfVars listen b -::comm::commConfVars socket ro -::comm::commConfVars chan ro -::comm::commConfVars serial ro - -# ::comm::commConfigure -- -# -# Internal command. Implements 'comm configure'. -# -# Arguments: -# force Boolean flag. If set the socket is reinitialized. -# args New configuration, as -option value pairs. -# -# Results: -# None. - -proc ::comm::commConfigure {{force 0} args} { - upvar chan chan - variable comm - - # query - switch [llength $args] { - 0 { - foreach v $comm(vars) {lappend res -$v $comm($chan,$v)} - return $res - } - 1 { - set arg [lindex $args 0] - set var [string range $arg 1 end] - if {[string match -* $arg] && [info exists comm($var,var)]} { - return $comm($chan,$var) - } else { - error "Unknown configuration option: $arg" - } - } - } - - # set - set opt 0 - foreach arg $args { - incr opt - if {[info exists skip]} {unset skip; continue} - set var [string range $arg 1 end] - if {![string match -* $arg] || ![info exists comm($var,var)]} { - error "Unknown configuration option: $arg" - } - set optval [lindex $args $opt] - switch $comm($var,var) { - b { - # FRINK: nocheck - set $var [commBool $optval] - set skip 1 - } - v { - # FRINK: nocheck - set $var $optval - set skip 1 - } - p { - if { - [string compare $optval ""] && - ![string is integer $optval] - } { - error "Non-port to configuration option: -$var" - } - # FRINK: nocheck - set $var $optval - set skip 1 - } - i { - if {![string is integer $optval]} { - error "Non-integer to configuration option: -$var" - } - # FRINK: nocheck - set $var $optval - set skip 1 - } - ro { error "Readonly configuration option: -$var" } - } - } - if {[info exists skip]} { - error "Missing value for option: $arg" - } - - foreach var {port listen local} { - # FRINK: nocheck - if {[info exists $var] && [set $var] != $comm($chan,$var)} { - incr force - # FRINK: nocheck - set comm($chan,$var) [set $var] - } - } - - # do not re-init socket - if {!$force} {return ""} - - # User is recycling object, possibly to change from local to !local - if {[info exists comm($chan,socket)]} { - commAbort - catch {close $comm($chan,socket)} - unset comm($chan,socket) - } - - set comm($chan,socket) "" - if {!$comm($chan,listen)} { - set comm($chan,port) 0 - return "" - } - - if {[info exists port] && [string match "" $comm($chan,port)]} { - set nport [incr comm(lastport)] - } else { - set userport 1 - set nport $comm($chan,port) - } - while {1} { - set cmd [list socket -server [list ::comm::commIncoming $chan]] - if {$comm($chan,local)} { - lappend cmd -myaddr $comm(localhost) - } - lappend cmd $nport - if {![catch $cmd ret]} { - break - } - if {[info exists userport] || ![string match "*already in use" $ret]} { - # don't erradicate the class - if {![string match ::comm::comm $chan]} { - rename $chan {} - } - error $ret - } - set nport [incr comm(lastport)] - } - set comm($chan,socket) $ret - - # If port was 0, system allocated it for us - set comm($chan,port) [lindex [fconfigure $ret -sockname] 2] - return "" -} - -# ::comm::commBool -- -# -# Internal command. Used by commConfigure to process boolean values. -# -# Arguments: -# b Value to process. -# -# Results: -# bool 0 - false, 1 - true - -proc ::comm::commBool {b} { - switch -glob -- $b 0 - {[fF]*} - {[oO][fF]*} {return 0} - return 1 -} - -# ::comm::commConnect -- -# -# Internal command. Called to connect to a remote interp -# -# Arguments: -# id Specification of the location of the remote interp. -# A list containing either one or two elements. -# One element = port, host is localhost. -# Two elements = port and host, in this order. -# -# Results: -# fid channel handle of the socket the connection goes through. - -proc ::comm::commConnect {id} { - upvar chan chan - variable comm - - commDebug {puts stderr "commConnect $id"} - - # process connecting hook now - if {[info exists comm($chan,hook,connecting)]} { - eval $comm($chan,hook,connecting) - } - - if {[info exists comm($chan,peers,$id)]} { - return $comm($chan,peers,$id) - } - if {[lindex $id 0] == 0} { - error "Remote comm is anonymous; cannot connect" - } - - if {[llength $id] > 1} { - set host [lindex $id 1] - } else { - set host $comm(localhost) - } - set port [lindex $id 0] - set fid [socket $host $port] - - # process connected hook now - if {[info exists comm($chan,hook,connected)]} { - if {[catch $comm($chan,hook,connected) err]} { - global errorInfo - set ei $errorInfo - close $fid - error $err $ei - } - } - - # commit new connection - commNewConn $id $fid - - # send offered protocols versions and id to identify ourselves to remote - puts $fid [list $comm(offerVers) $comm($chan,port)] - set comm($chan,vers,$id) $comm(defVers) ;# default proto vers - flush $fid - return $fid -} - -# ::comm::commIncoming -- -# -# Internal command. Called for an incoming new connection. -# Handles connection setup and initialization. -# -# Arguments: -# chan logical channel handling the connection. -# fid channel handle of the socket running the connection. -# addr ip address of the socket channel 'fid' -# remport remote port for the socket channel 'fid' -# -# Results: -# None. - -proc ::comm::commIncoming {chan fid addr remport} { - variable comm - - commDebug {puts stderr "commIncoming $chan $fid $addr $remport"} - - # process incoming hook now - if {[info exists comm($chan,hook,incoming)]} { - if {[catch $comm($chan,hook,incoming) err]} { - global errorInfo - set ei $errorInfo - close $fid - error $err $ei - } - } - - # a list of offered proto versions is the first word of first line - # remote id is the second word of first line - # rest of first line is ignored - set protoline [gets $fid] - set offeredvers [lindex $protoline 0] - set remid [lindex $protoline 1] - - # use the first supported version in the offered list - foreach v $offeredvers { - if {[info exists comm($v,vers)]} { - set vers $v - break - } - } - if {![info exists vers]} { - close $fid - error "Unknown offered protocols \"$protoline\" from $addr/$remport" - } - - # If the remote host addr isn't our local host addr, - # then add it to the remote id. - if {[string compare [lindex [fconfigure $fid -sockname] 0] $addr]} { - set id [list $remid $addr] - } else { - set id $remid - } - - # Detect race condition of two comms connecting to each other - # simultaneously. It is OK when we are talking to ourselves. - - if {[info exists comm($chan,peers,$id)] && $id != $comm($chan,port)} { - - puts stderr "commIncoming race condition: $id" - puts stderr "peers=$comm($chan,peers,$id) port=$comm($chan,port)" - - # To avoid the race, we really want to terminate one connection. - # However, both sides are commited to using it. commConnect - # needs to be sychronous and detect the close. - # close $fid - # return $comm($chan,peers,$id) - } - - # Make a protocol response. Avoid any temptation to use {$vers > 2} - # - this forces forwards compatibility issues on protocol versions - # that haven't been invented yet. DON'T DO IT! Instead, test for - # each supported version explicitly. I.e., {$vers >2 && $vers < 5} is OK. - - switch $vers { - 3 { - # Respond with the selected version number - puts $fid [list [list vers $vers]] - flush $fid - } - } - - # commit new connection - commNewConn $id $fid - set comm($chan,vers,$id) $vers -} - -# ::comm::commNewConn -- -# -# Internal command. Common new connection processing -# -# Arguments: -# id Reference to the remote interp -# fid channel handle of the socket running the connection. -# -# Results: -# None. - -proc ::comm::commNewConn {id fid} { - upvar chan chan - variable comm - - commDebug {puts stderr "commNewConn $id $fid"} - - # There can be a race condition two where comms connect to each other - # simultaneously. This code favors our outgoing connection. - - if {[info exists comm($chan,peers,$id)]} { - # abort this connection, use the existing one - # close $fid - # return -code return $comm($chan,peers,$id) - } else { - set comm($chan,pending,$id) {} - set comm($chan,peers,$id) $fid - } - set comm($chan,fids,$fid) $id - fconfigure $fid -trans binary -blocking 0 - fileevent $fid readable [list ::comm::commCollect $chan $fid] -} - -# ::comm::commShutdown -- -# -# Internal command. Close down a peer connection. -# Implements the 'comm shutdown' method. -# -# Arguments: -# id Reference to the remote interp -# -# Results: -# None. - -proc ::comm::commShutdown {id} { - upvar chan chan - variable comm - - if {[info exists comm($chan,peers,$id)]} { - commLostConn $comm($chan,peers,$id) "Connection shutdown by request" - } -} - -# ::comm::commAbort -- -# -# Internal command. Close down all peer connections. -# Implements the 'comm abort' method. -# -# Arguments: -# None. -# -# Results: -# None. - -proc ::comm::commAbort {} { - upvar chan chan - variable comm - - foreach pid [array names comm $chan,peers,*] { - commLostConn $comm($pid) "Connection aborted by request" - } -} - -# ::comm::commLostConn -- -# -# Internal command. Called to tidy up a lost connection, -# including aborting ongoing sends. Each send should clean -# themselves up in pending/result. -# -# Arguments: -# fid Channel handle of the socket which got lost. -# reason Message describing the reason of the loss. -# -# Results: -# reason - -proc ::comm::commLostConn { - fid {reason "target application died or connection lost"} -} { - upvar chan chan - variable comm - - commDebug {puts stderr "commLostConn $fid $reason"} - - catch {close $fid} - - set id $comm($chan,fids,$fid) - - foreach s $comm($chan,pending,$id) { - set comm($chan,return,$s) {-code error} - set comm($chan,result,$s) $reason - } - unset comm($chan,pending,$id) - unset comm($chan,fids,$fid) - catch {unset comm($chan,peers,$id)} ;# race condition - catch {unset comm($chan,buf,$fid)} - - # process lost hook now - catch {catch $comm($chan,hook,lost)} - - return $reason -} - -############################################################################### - -# ::comm::commHook -- -# -# Internal command. Implements 'comm hook'. -# -# Arguments: -# hook hook to modify -# script Script to add/remove to/from the hook -# -# Results: -# None. - -proc ::comm::commHook {hook {script +}} { - upvar chan chan - variable comm - if {![info exists comm($hook,hook)]} { - error "Unknown hook invoked" - } - if {!$comm($hook,hook)} { - error "Unimplemented hook invoked" - } - if {[string match + $script]} { - if {[catch {set comm($chan,hook,$hook)} ret]} { - return "" - } - return $ret - } - if {[string match +* $script]} { - append comm($chan,hook,$hook) \n [string range $script 1 end] - } else { - set comm($chan,hook,$hook) $script - } - return "" -} - -############################################################################### - -# ::comm::commCollect -- -# -# Internal command. Called from the fileevent to read from fid -# and append to the buffer. This continues until we get a whole -# command, which we then invoke. -# -# Arguments: -# chan logical channel collecting the data -# fid channel handle of the socket we collect. -# -# Results: -# None. - -proc ::comm::commCollect {chan fid} { - variable comm - upvar #0 comm($chan,buf,$fid) data - - # Tcl8 may return an error on read after a close - if {[catch {read $fid} nbuf] || [eof $fid]} { - fileevent $fid readable {} ;# be safe - commLostConn $fid - return - } - append data $nbuf - - commDebug {puts stderr "collect <$data>"} - - # If data contains at least one complete command, we will - # be able to take off the first element, which is a list holding - # the command. This is true even if data isn't a well-formed - # list overall, with unmatched open braces. This works because - # each command in the protocol ends with a newline, thus allowing - # lindex and lreplace to work. - # - # This isn't true with Tcl8.0, which will return an error until - # the whole buffer is a valid list. This is probably OK, although - # it could potentially cause a deadlock. - - while {![catch {set cmd [lindex $data 0]}]} { - commDebug {puts stderr "cmd <$data>"} - if {[string match "" $cmd]} break - if {[info complete $cmd]} { - set data [lreplace $data 0 0] - after idle \ - [list ::comm::commExec $chan $fid $comm($chan,fids,$fid) $cmd] - } - } -} - -# ::comm::commExec -- -# -# Internal command. Receives and executes a remote command, -# returning the result and/or error. Unknown protocol commands -# are silently discarded -# -# Arguments: -# chan logical channel collecting the data -# fid channel handle of the socket we collect. -# remoteid id of the other side. -# buf buffer containing the command to execute. -# -# Results: -# None. - -proc ::comm::commExec {chan fid remoteid buf} { - - # buffer should contain: - # send # {cmd} execute cmd and send reply with serial # - # async # {cmd} execute cmd but send no reply - # reply # {cmd} execute cmd as reply to serial # - - variable comm - - # these variables are documented in the hook interface - set cmd [lindex $buf 0] - set ser [lindex $buf 1] - set buf [lrange $buf 2 end] - set buffer [lindex $buf 0] - - # Save remoteid for "comm remoteid". This will only be valid - # if retrieved before any additional events occur # on this channel. - # N.B. we could have already lost the connection to remote, making - # this id be purely informational! - set comm($chan,remoteid) [set id $remoteid] - - commDebug {puts stderr "exec <$cmd,$ser,$buf>"} - - switch -- $cmd { - send - async {} - reply { - if {![info exists comm($chan,return,$ser)]} { - commDebug {puts stderr "No one waiting for serial \"$ser\""} - return - } - - # Decompose reply command to assure it only uses "return" - # with no side effects. - - array set return {-code "" -errorinfo "" -errorcode ""} - set ret [lindex $buffer end] - set len [llength $buffer] - incr len -2 - foreach {sw val} [lrange $buffer 1 $len] { - if {![info exists return($sw)]} continue - set return($sw) $val - } - - if {[info exists comm($chan,hook,reply)]} { - catch $comm($chan,hook,reply) - } - - # this wakes up the sender - commDebug {puts stderr "--<>--"} - set comm($chan,result,$ser) $ret - set comm($chan,return,$ser) [array get return] - return - } - vers { - set ::comm::comm($chan,vers,$id) $ser - return - } - default { - commDebug {puts stderr "unknown command; discard \"$cmd\""} - return - } - } - - # process eval hook now - if {[info exists comm($chan,hook,eval)]} { - set err [catch $comm($chan,hook,eval) ret] - commDebug {puts stderr "eval hook res <$err,$ret>"} - switch $err { - 1 { ;# error - set done 1 - } - 2 - 3 { ;# return / break - set err 0 - set done 1 - } - } - } - - # exec command - if {![info exists done]} { - # Sadly, the uplevel needs to be in the catch to access the local - # variables buffer and ret. These cannot simply be global because - # commExec is reentrant (i.e., they could be linked to an allocated - # serial number). - set err [catch [concat uplevel #0 $buffer] ret] - } - - commDebug {puts stderr "res <$err,$ret>"} - - # The double list assures that the command is a single list when read. - if {[string match send $cmd]} { - # The catch here is just in case we lose the target. Consider: - # comm send $other comm send [comm self] exit - catch { - set return return - # send error or result - switch $err { - 0 {} - 1 { - global errorInfo errorCode - lappend return -code $err \ - -errorinfo $errorInfo \ - -errorcode $errorCode - } - default { lappend return -code $err} - } - lappend return $ret - puts $fid [list [list reply $ser $return]] - flush $fid - } - } - - if {$err == 1} { - # SF Tcllib Patch #526499 - # (See http://sourceforge.net/tracker/?func=detail&aid=526499&group_id=12883&atid=312883 - # for initial request and comments) - # - # Error in async call. Look for [bgerror] to report it. Same - # logic as in Tcl itself. Errors thrown by bgerror itself get - # reported to stderr. - - if {[catch { - bgerror $ret - } msg]} { - puts stderr "bgerror failed to handle background error." - puts stderr " Original error: $ret" - puts stderr " Error in bgerror: $msg" - flush stderr - } - } - return -} - -############################################################################### -# -# Finish creating "comm" using the default port for this interp. -# - -if {![info exists ::comm::comm(comm,port)]} { - if {[string match macintosh $tcl_platform(platform)]} { - ::comm::comm new ::comm::comm -port 0 -local 0 -listen 1 - set ::comm::comm(localhost) \ - [lindex [fconfigure $::comm::comm(comm,socket) -sockname] 0] - ::comm::comm config -local 1 - } else { - ::comm::comm new ::comm::comm -port 0 -local 1 -listen 1 - } -} - -#eof -package provide comm 4.0.1 DELETED modules/comm/comm.test Index: modules/comm/comm.test ================================================================== --- modules/comm/comm.test +++ /dev/null @@ -1,79 +0,0 @@ -# -*- tcl -*- -# Tests for the comm module. -# -# Sourcing this file into Tcl runs the tests and generates output for errors. -# No output means no errors were found. -# -# Copyright (c) 2001 by ActiveState Tool Corp. -# All rights reserved. -# -# RCS: @(#) $Id: comm.test,v 1.2 2002/08/06 21:29:37 andreas_kupries Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -if { [lsearch $auto_path [file dirname [info script]]] == -1 } { - set auto_path [linsert $auto_path 0 [file dirname [info script]]] -} - -package require comm -puts "comm [package present comm]" - -# ------------------------------------------------------------------------ -# -# First order of things is to spawn a separate tclsh into the background -# and have it execute comm too, with some general code to respond to our -# requests - -set path(spawn) [makeFile { - ##puts [set fh [open ~/foo w]] $argv ; close $fh - - source [lindex $argv 0].tcl ; # load 'comm' - # and wait for commands. But first send our - # own server socket to the initiator - ::comm::comm send [lindex $argv 1] [list slaveat [::comm::comm self]] - vwait forever -} spawn] - -proc slaveat {id} { - puts "Slave @ $id" - proc slave {} [list return $id] - set ::go . -} - -puts "self @ [::comm::comm self]" - -exec \ - [info nameofexecutable] $path(spawn) \ - [file rootname [info script]] [::comm::comm self] & - -puts "Waiting for spawned comm system to boot" -# Wait for the slave to initialize itself. -vwait ::go - -puts "Running tests" -#::comm::comm debug 1 -# ------------------------------------------------------------------------ - -test comm-1.0 {set remote variable} { - ::comm::comm send [slave] {set foo b} -} {b} - -test comm-1.1 {set remote variable, async} { - ::comm::comm send -async [slave] {set fox a} -} {} - -test comm-1.2 {get remote variables} { - ::comm::comm send [slave] {list $foo $fox} -} {b a} - -test comm-1.3 {close remote} { - ::comm::comm send -async [slave] {{exit}} -} {} - -::comm::comm abort - -::tcltest::cleanupTests -return DELETED modules/comm/pkgIndex.tcl Index: modules/comm/pkgIndex.tcl ================================================================== --- modules/comm/pkgIndex.tcl +++ /dev/null @@ -1,12 +0,0 @@ -# Tcl package index file, version 1.0 -# 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. - -if {![package vsatisfies [package provide Tcl] 8]} {return} -package ifneeded comm 4.0.1 [list source [file join $dir comm.tcl]] Index: modules/control/ChangeLog ================================================================== --- modules/control/ChangeLog +++ modules/control/ChangeLog @@ -1,5 +1,48 @@ +2005-05-24 Don Porter + + * do.tcl: Updates to use Tcl 8.5 [return] and [catch] extensions + * control.man: when availble to overcome LIMITATIONS. + + * wait-for-any.tcl: New command: control::waitForAny. + * wait-for-any.test: + * tclIndex: + + * control.tcl: Bump to version 0.2 + * pkgIndex.tcl: + + * do.test (do-2.3): Update to accept newer error message format. + (do-2.2): Error message refer to called command name. + +2004-10-05 Andreas Kupries + + * + * Released and tagged Tcllib 1.7 ======================== + * + +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-02-15 Andreas Kupries + + * + * Released and tagged Tcllib 1.6 ======================== + * + +2003-05-05 Andreas Kupries + + * + * Released and tagged Tcllib 1.4 ======================== + * + +2003-05-01 Pat Thoyts + + * do.test: Skip test 1.14 if tcl < 8.3. + 2003-04-11 Andreas Kupries * control.man: * control.tcl: * pkgIndex.tcl: Set version of the package to to 0.1.2. Index: modules/control/ascaller.tcl ================================================================== --- modules/control/ascaller.tcl +++ modules/control/ascaller.tcl @@ -4,11 +4,11 @@ # or a script in the context of a caller, taking care of all # the ugly details of proper return codes, errorcodes, and # a good stack trace in ::errorInfo as appropriate. # ------------------------------------------------------------------------- # -# RCS: @(#) $Id: ascaller.tcl,v 1.2 2001/11/09 04:59:45 dgp Exp $ +# RCS: @(#) $Id: ascaller.tcl,v 1.2.6.1 2005/05/24 14:20:59 dgp Exp $ namespace eval ::control { proc CommandAsCaller {cmdVar resultVar {where {}} {codeVar code}} { set x [expr {[string equal "" $where] Index: modules/control/assert.tcl ================================================================== --- modules/control/assert.tcl +++ modules/control/assert.tcl @@ -1,10 +1,10 @@ # assert.tcl -- # # The [assert] command of the package "control". # -# RCS: @(#) $Id: assert.tcl,v 1.2 2002/02/15 05:35:30 andreas_kupries Exp $ +# RCS: @(#) $Id: assert.tcl,v 1.2.2.1 2005/05/24 14:21:00 dgp Exp $ namespace eval ::control { namespace eval assert { namespace export EnabledAssert DisabledAssert Index: modules/control/control.man ================================================================== --- modules/control/control.man +++ modules/control/control.man @@ -120,12 +120,13 @@ [section LIMITATIONS] Several of the commands provided by the [cmd control] package accept arguments that are scripts to be evaluated. Due to fundamental -limitations of Tcl's [cmd catch] and [cmd return] commands, it is not -possible for these commands to properly evaluate the command +limitations of Tcl's [cmd catch] and [cmd return] commands before +Tcl release 8.5, it is not possible for these commands to properly evaluate +the command [lb][cmd "return -code \$code"][rb] within one of those script arguments for any value of [arg \$code] other than [arg ok]. In this way, the commands of the [cmd control] package are limited as compared to Tcl's built-in control flow commands (such as [cmd if], @@ -141,9 +142,12 @@ % catch a 1 % catch b 0 }] + +If the control package is used in an interpreter for Tcl 8.5 or +later, this limitation will not be present. [see_also expr if join namespace return string while break continue] [keywords control flow structure no-op assert do] [manpage_end] DELETED modules/control/control.n Index: modules/control/control.n ================================================================== --- modules/control/control.n +++ /dev/null @@ -1,140 +0,0 @@ -'\" -'\" RCS: @(#) $Id: control.n,v 1.12 2002/01/18 21:45:42 dgp Exp $ -'\" -.so man.macros -.TH control n 0.0 control "Tcl Control Flow Commands" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -control \- Procedures for control flow structures. -.SH SYNOPSIS -\fBpackage require Tcl 8.2\fR -.sp -\fBpackage require control ?0.1?\fR -.sp -\fBcontrol::control \fIcommand option \fR?\fIarg arg ...\fR? -.sp -\fBcontrol::assert \fIexpr \fR?\fIarg arg ...\fR? -.sp -\fBcontrol::do \fIbody \fR?\fIoption test\fR? -.sp -\fBcontrol::no-op \fR?\fIarg arg ...\fR? -.BE -.SH DESCRIPTION -.PP -The \fBcontrol\fR package provides a variety of commands that -provide additional flow of control structures beyond the -built-in ones provided by Tcl. These are commands that in -many programming languages might be considered \fIkeywords\fR, -or a part of the language itself. In Tcl, control flow structures -are just commands like everything else. -.SH COMMANDS -.TP -\fBcontrol::control \fIcommand option \fR?\fIarg arg ...\fR? -The \fBcontrol\fR command is used as a configuration command -for customizing the other public commands of the control package. -The \fIcommand\fR argument names the command to be customized. -The set of valid \fIoption\fR and subsequent arguments are -determined by the command being customized, and are documented -with the command. -.TP -\fBcontrol::assert \fIexpr \fR?\fIarg arg ...\fR? -When disabled, the \fBassert\fR command behaves exactly like -the \fBno-op\fR command. -.sp -When enabled, the \fBassert\fR command evaluates \fIexpr\fR as -an expression (in the same way that \fBexpr\fR evaluates its -argument). If evaluation reveals that \fIexpr\fR is not a valid -boolean expression (according to [\fBstring is boolean -strict\fR]), -an error is raised. If \fIexpr\fR evaluates to a true boolean value -(as recognized by \fBif\fR), then \fBassert\fR returns an empty string. -Otherwise, the remaining arguments to \fBassert\fR are used -to construct a message string. If there are no arguments, the -message string is "assertion failed: $expr". If there are arguments, -they are joined by \fBjoin\fR to form the message string. The -message string is then appended as an argument to a callback command, -and the completed callback command is evaluated in the global namespace. -.sp -The \fBassert\fR command can be customized by the \fBcontrol\fR -command in two ways: -.sp -[\fBcontrol::control assert enabled \fR?\fIboolean\fR?] queries or -sets whether \fBcontrol::assert\fR is enabled. When called without -a \fIboolean\fR argument, a boolean value is returned indicating -whether the \fBcontrol::assert\fR command is enabled. When called -with a valid boolean value as the \fIboolean\fR argument, the -\fBcontrol::assert\fR command is enabled or disabled to match the -argument, and an empty string is returned. -.sp -[\fBcontrol::control assert callback \fR?\fIcommand\fR?] queries or sets -the callback command that will be called by an enabled \fBassert\fR on -assertion failure. When called without a \fIcommand\fR argument, the -current callback command is returned. When called with a \fIcommand\fR -argument, that argument becomes the new assertion failure callback -command. Note that an assertion failure callback command is always -defined, even when \fBassert\fR is disabled. The default callback -command is [\fBreturn -code error\fR]. -.sp -Note that \fBcontrol::assert\fR has been written so that in -combination with [\fBnamespace import\fR], it is possible to -use enabled \fBassert\fR commands in some namespaces and disabled -\fBassert\fR commands in other namespaces at the same time. -This capability is useful so that debugging efforts can be independently -controlled module by module. -.sp -.CS -\fB% package require control -% control::control assert enabled 1 -% namespace eval one namespace import ::control::assert -% control::control assert enabled 0 -% namespace eval two namespace import ::control::assert -% one::assert {1 == 0} -assertion failed: 1 == 0 -% two::assert {1 == 0}\fR -.CE -.TP -\fBcontrol::do \fIbody \fR?\fIoption test\fR? -The \fBdo\fR command evaluates the script \fIbody\fR repeatedly -\fBuntil\fR the expression \fBtest\fR becomes true or as long as -(\fBwhile\fR) \fBtest\fR is true, depending on the value of -\fIoption\fR being \fBuntil\fR or \fBwhile\fR. If \fIoption\fR and -\fItest\fR are omitted the body is evaluated exactly once. After -normal completion, \fBdo\fR returns an empty string. Exceptional -return codes (\fBbreak\fR, \fBcontinue\fR, \fBerror\fR, etc.) during -the evaluation of \fIbody\fR are handled in the same way the -\fBwhile\fR command handles them, except as noted in -\fBLIMITATIONS\fR, below. -.TP -\fBcontrol::no-op \fR?\fIarg arg ...\fR? -The \fBno-op\fR command takes any number of arguments and does nothing. -It returns an empty string. - -.SH LIMITATIONS - -Several of the commands provided by the \fBcontrol\fR package -accept arguments that are scripts to be evaluated. Due to -fundamental limitations of Tcl's \fBcatch\fR and \fBreturn\fR -commands, it is not possible for these commands to properly -evaluate the command [\fBreturn -code $code\fR] within one -of those script arguments for any value of \fI$code\fR other -than \fIok\fR. In this way, the commands of the \fBcontrol\fR -package are limited as compared to Tcl's built-in control flow -commands (such as \fBif\fR, \fBwhile\fR, etc.) and those -control flow commands that can be provided by packages coded -in C. An example of this difference: -.sp -.CS -\fB% package require control -% proc a {} {while 1 {return -code error a}} -% proc b {} {control::do {return -code error b} while 1} -% catch a -1 -% catch b -0 -.CE - -.SH "SEE ALSO" -expr, if, join, namespace, return, string, while, break, continue - -.SH KEYWORDS -control, flow, structure, no-op, assert, do Index: modules/control/control.tcl ================================================================== --- modules/control/control.tcl +++ modules/control/control.tcl @@ -2,17 +2,17 @@ # # This is the main package provide script for the package # "control". It provides commands that govern the flow of # control of a program. # -# RCS: @(#) $Id: control.tcl,v 1.11 2003/04/11 19:41:34 andreas_kupries Exp $ +# RCS: @(#) $Id: control.tcl,v 1.9.6.2 2005/05/24 15:08:51 dgp Exp $ package require Tcl 8.2 namespace eval ::control { - variable version 0.1.2 - namespace export assert control do no-op rswitch + variable version 0.2 + namespace export assert control do no-op waitForAny proc control {command args} { # Need to add error handling here namespace eval [list $command] $args } Index: modules/control/do.tcl ================================================================== --- modules/control/do.tcl +++ modules/control/do.tcl @@ -8,26 +8,30 @@ # Copyright (c) 2001 by Reinhard Max # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: do.tcl,v 1.5 2002/02/15 05:35:30 andreas_kupries Exp $ +# RCS: @(#) $Id: do.tcl,v 1.5.2.2 2005/05/24 19:19:09 dgp Exp $ # namespace eval ::control { + variable ReturnOptions [package vsatisfies [package provide Tcl] 8.5] proc do {body args} { + variable ReturnOptions + variable DoResult + variable DoOptions # # Implements a "do body while|until test" loop # # It is almost as fast as builtin "while" command for loops with # more than just a few iterations. # + set proc [lindex [info level 0] 0] set len [llength $args] if {$len !=2 && $len != 0} { - set proc [namespace current]::[lindex [info level 0] 0] return -code error "wrong # args: should be \"$proc body\" or \"$proc body \[until|while\] test\"" } set test 0 foreach {whileOrUntil test} $args { switch -exact -- $whileOrUntil { @@ -40,14 +44,19 @@ } break } # the first invocation of the body - set code [catch { uplevel 1 $body } result] + if {$ReturnOptions} { + set code [uplevel 1 [list ::catch $body \ + [namespace which -variable DoResult] \ + [namespace which -variable DoOptions]]] + } else { + set code [catch { uplevel 1 $body } DoResult] + } # decide what to do upon the return code: - # # 0 - the body executed successfully # 1 - the body raised an error # 2 - the body invoked [return] # 3 - the body invoked [break] # 4 - the body invoked [continue] @@ -54,28 +63,62 @@ # everything else - return and pass on the results # switch -exact -- $code { 0 {} 1 { - return -errorinfo [ErrorInfoAsCaller uplevel do] \ - -errorcode $::errorCode -code error $result + if {$ReturnOptions} { + set line [dict get $DoOptions -errorline] + dict append DoOptions -errorinfo \ + "\n (\"$proc\" body line $line)" + dict incr DoOptions -level + return -options $DoOptions $DoResult + } else { + return -errorinfo [ErrorInfoAsCaller uplevel do] \ + -errorcode $::errorCode -code error $DoResult + } + } + 2 { + if {$ReturnOptions} { + dict incr DoOptions -level + return -options $DoOptions $DoResult + } else { + return -code $code $DoResult + } } 3 { # FRINK: nocheck return } 4 {} default { - return -code $code $result + return -code $code $DoResult } } # the rest of the loop - set code [catch {uplevel 1 [list while $test $body]} result] + if {$ReturnOptions} { + set code [uplevel 1 [list ::catch [list ::while $test $body] \ + [namespace which -variable DoResult] \ + [namespace which -variable DoOptions]]] + } else { + set code [catch { uplevel 1 [list ::while $test $body] } DoResult] + } if {$code == 1} { - return -errorinfo [ErrorInfoAsCaller while do] \ - -errorcode $::errorCode -code error $result + if {$ReturnOptions} { + set line [dict get $DoOptions -errorline] + dict append DoOptions -errorinfo \ + "\n (\"$proc\" body line $line)" + dict incr DoOptions -level + return -options $DoOptions $DoResult + } else { + return -errorinfo [ErrorInfoAsCaller while do] \ + -errorcode $::errorCode -code error $DoResult + } + } + if {$ReturnOptions && $code} { + dict incr DoOptions -level + return -options $DoOptions $DoResult } - return -code $code $result + return -code $code $DoResult } } Index: modules/control/do.test ================================================================== --- modules/control/do.test +++ modules/control/do.test @@ -1,10 +1,10 @@ # do.test -- # # Tests for [control::do] # -# RCS: @(#) $Id: do.test,v 1.5 2002/02/21 11:40:45 rmax Exp $ +# RCS: @(#) $Id: do.test,v 1.5.2.3 2005/05/24 19:19:09 dgp Exp $ # package forget control catch {namespace delete control} @@ -12,11 +12,11 @@ # when not installed. And be sure we test the local copy # and not some later version that may be installed. source [file join [file dirname [info script]] control.tcl] namespace import ::control::do -package require tcltest +package require tcltest 2 namespace import -force tcltest::test ::tcltest::cleanupTests # ---------------------------------------- test {do-1.0} {do ... while} { set x 0 @@ -166,11 +166,11 @@ (procedure "a" line 1) invoked from within "a"} # ---------------------------------------- -test do-1.14 {stack traces for errors in subsequent iterations} { +test do-1.14 {stack traces for errors in subsequent iterations} tcl8.3plus { proc a {} b proc b {} { set i 10 do { incr i -1 @@ -216,16 +216,16 @@ # ---------------------------------------- test do-2.2 {wrong no of arguments} { set x 0 set res [catch {do {incr x} foo} ret] list $x $res $errorInfo -} {0 1 {wrong # args: should be "::control::do body" or "::control::do body [until|while] test" +} {0 1 {wrong # args: should be "do body" or "do body [until|while] test" while executing "do {incr x} foo"}} # ---------------------------------------- -test do-2.3 {wrong no of arguments} {} { +test do-2.3 {wrong no of arguments} -body { set res [catch do] if {[string match \ {no value given for parameter "body" to "do"*} \ $::errorInfo] } then { @@ -232,11 +232,11 @@ set ::errorInfo {wrong # args: should be "do body args" while executing "do"} } list $res $::errorInfo -} {1 {wrong # args: should be "do body args" +} -match glob -result {1 {wrong # args: should be "do body *" while executing "do"}} # ---------------------------------------- test do-2.4 {one-shot do with error} { Index: modules/control/no-op.tcl ================================================================== --- modules/control/no-op.tcl +++ modules/control/no-op.tcl @@ -2,11 +2,11 @@ # # The [no-op] command of the package "control". # It accepts any number of arguments and does nothing. # It returns an empty string. # -# RCS: @(#) $Id: no-op.tcl,v 1.1 2001/08/21 22:54:15 dgp Exp $ +# RCS: @(#) $Id: no-op.tcl,v 1.1.6.1 2005/05/24 14:21:00 dgp Exp $ namespace eval ::control { proc no-op args {} Index: modules/control/no-op.test ================================================================== --- modules/control/no-op.test +++ modules/control/no-op.test @@ -3,11 +3,11 @@ # This file contains a collection of tests for the command [control::no-op] # of the package control in tcllib, the Standard Tcl Library. Sourcing this # file into Tcl runs the tests and generates output for errors. No output # means no errors were found. # -# RCS: @(#) $Id: no-op.test,v 1.1 2001/08/21 22:54:15 dgp Exp $ +# RCS: @(#) $Id: no-op.test,v 1.1.6.1 2005/05/24 14:21:00 dgp Exp $ package forget control catch {namespace delete control} # Direct loading of provide script -- support testing even Index: modules/control/pkgIndex.tcl ================================================================== --- modules/control/pkgIndex.tcl +++ modules/control/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded control 0.1.2 [list source [file join $dir control.tcl]] +package ifneeded control 0.2 [list source [file join $dir control.tcl]] ADDED modules/control/rswitch.tcl Index: modules/control/rswitch.tcl ================================================================== --- /dev/null +++ modules/control/rswitch.tcl @@ -0,0 +1,92 @@ +# rswitch.tcl - +# Originally written: 2001 Nov 2 +# Original author: Don Porter +# +# This software was developed at the National Institute of Standards +# and Technology by employees of the Federal Government in the course +# of their official duties. Pursuant to title 17 Section 105 of the +# United States Code this software is not subject to copyright +# protection and is in the public domain. +# +# The [rswitch] command of the package "control". +# Inspired by TIP 70. Amended to the syntax: +# +# rswitch $formatString { +# $sub1 $body1 +# ... +# $subN $bodyN +# } +# +# See documentation in control.n +# ------------------------------------------------------------------------- +# +# RCS: @(#) $Id: rswitch.tcl,v 1.3 2001/11/07 21:59:24 dgp Exp $ + +namespace eval ::control { + + namespace export rswitch + + proc rswitch {formatString actionList} { + if {[catch {llength $actionList} actionListLength]} { + return -code error $actionListLength + } + if {$actionListLength % 2} { + return -code error "extra substitution with no body" + } + # Check for final "default" arm + set hasDefault [string equal default [lindex $actionList end-1]] + if {$hasDefault} { + set defaultBody [lindex $actionList end] + set actionList [lrange $actionList 0 end-2] + } + set evalBody 0 + foreach {sub body} $actionList { + if {!$evalBody} { + if {[catch {linsert $sub 0 ::format $formatString} cmd]} { + return -code error -errorinfo "$cmd\n (\"$sub\"\ + arm substitution)" -errorcode $::errorCode $cmd + } + if {[catch {eval $cmd} expression]} { + return -code error -errorcode $::errorCode -errorinfo \ + "$expression\n (\"$sub\" arm substitution)" \ + $expression + } + set cmd [list ::expr $expression] + eval [CommandAsCaller cmd evalBody [format "%s\n%s" \ + {\"$sub\" arm expression)} \ + { (expression: \"$expression\"}]] + if {![string is boolean -strict $evalBody]} { + set msg "non-boolean expression" + return -code error -errorcode $::errorCode -errorinfo \ + [format "%s\n%s\n%s" $msg \ + " (\"$sub\" arm expression)" \ + " (expression: \"$expression\")"] $msg + } + if {!$evalBody} { + continue + } + set match $sub + } + # We've found a successful expression. + # Evaluate the corresponding body. + if {[string equal - $body]} { + continue + } + eval [BodyAsCaller body result code {\"$match\" arm}] + return -code $code $result + } + if {!$hasDefault && !$evalBody} { + return + } + if {!$evalBody} { + set match default + } + if {!$hasDefault || [string equal - $defaultBody]} { + return -code error \ + "no body specified for substitution \"$match\"" + } + eval [BodyAsCaller defaultBody result code {\"$match\" arm}] + return -code $code $result + } + +} ADDED modules/control/rswitch.test Index: modules/control/rswitch.test ================================================================== --- /dev/null +++ modules/control/rswitch.test @@ -0,0 +1,136 @@ +# rswitch.test - Copyright (C) 2001 Pat Thoyts +# +# Provide a set of tests to excercise the control::rswitch command of +# tcllib. +# +# @(#)$Id: rswitch.test,v 1.3 2001/11/07 05:31:42 dgp Exp $ + +# Initialize the required packages +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::test ::tcltest::cleanupTests +} + +package forget control +catch {namespace delete control} + +# Direct loading of provide script -- support testing even +# when not installed. And be sure we test the local copy +# and not some later version that may be installed. +source [file join [file dirname [info script]] control.tcl] +namespace import ::control::rswitch + +# ------------------------------------------------------------------------- + +# Test simple numeric relational switching. +proc rsinteger {value} { + rswitch {$value %s} { + <5 {set result <5} + ==5 {set result 5} + >5 {set result >5} + default {set result default} + } + return $result +} + +test rswitch-1.1 {switch < 5} { + catch {rsinteger 0} result + set result +} {<5} + +test rswitch-1.2 {switch == 5} { + catch {rsinteger 5} result + set result +} {5} + +test rswitch-1.3 {switch > 5} { + catch {rsinteger 10} result + set result +} {>5} + +test rswitch-1.4 {switch non numeric} { + catch {rsinteger A} result + set result +} {>5} + +# ------------------------------------------------------------------------- + +proc rs:compare {lhs rhs} { + rswitch {$lhs %s $rhs} { + < {return <} + == {return ==} + > {return >} + } +} + +test rswitch-2.1 {switch string comparison} { + catch {rs:compare "hello" "world"} result + set result +} {<} + +test rswitch-2.2 {switch string comparison} { + catch {rs:compare "hello" "hello"} result + set result +} {==} + +test rswitch-2.3 {switch string comparison} { + catch {rs:compare "hello" "all"} result + set result +} {>} + +# ------------------------------------------------------------------------- +# Here are the test cases I used when developing [rswitch] to check on +# its errorInfo management. They should be converted to proper tests, +# preferably checking ::errorInfo. OK, I'll do the first one: + +test rswitch-3.0 {rswitch argument checking} { + list [catch {rswitch 1 \{} msg] $msg $::errorInfo +} {1 {unmatched open brace in list} {unmatched open brace in list + while executing +"rswitch 1 \{"}} + +#rswitch {1 %s} { +# {{>[string length]}} {string length} +# }} msg] $msg] +#} +#rswitch 1 foo +#rswitch {1 %s} { +# {{&& ([string length a] +# || +# [string length]}} {string length} +#} +#rswitch {1 %s} { +# {{&& ([string length a] +# || +# [string length])}} {string length} +#} +#rswitch {1 %s} { +# {{&& ([string length] +# || +# [string length])}} {string length} +#} +#rswitch {1 %s 1} { +# == { +# set a 1 +# string length +# set b 2 +# } +#} +#rswitch {1 %s 1} { +# == { +# set a 1 +# expr {[string length]} +# set b 2 +# } +#} + +# ------------------------------------------------------------------------- +# Clean up the tests + +::tcltest::cleanupTests +return + +# Local variables: +# mode: tcl +# indent-tabs-mode: nil +# End: Index: modules/control/tclIndex ================================================================== --- modules/control/tclIndex +++ modules/control/tclIndex @@ -14,5 +14,6 @@ set auto_index(::control::assert::callback) [list source [file join $dir assert.tcl]] set auto_index(::control::AssertSwitch) [list source [file join $dir assert.tcl]] set auto_index(::control::assert) [list source [file join $dir assert.tcl]] set auto_index(::control::do) [list source [file join $dir do.tcl]] set auto_index(::control::no-op) [list source [file join $dir no-op.tcl]] +set auto_index(::control::waitForAny) [list source [file join $dir wait-for-any.tcl]] ADDED modules/control/wait-for-any.tcl Index: modules/control/wait-for-any.tcl ================================================================== --- /dev/null +++ modules/control/wait-for-any.tcl @@ -0,0 +1,115 @@ +# control.tcl -- +# +# The control package, providing a vwait that takes multiple +# variables. +# +# Taken from the tcler's wiki (http://mini.net/tcl/1302.html) by kenstir +# and enhanced. Submitted as a proposed new package to +# tcllib.sourceforge.net on 7/30/01. +# +# Original author: Donald Porter. BBH added the timeout option. Kenstir +# added the return value to detect what variables changed, the packaging, +# standard formatting, and the help text. +# +# TODO +# * Write control::unwindProtect. I've always wanted one. +# --7/30/01 kenstir +# +# $Id: wait-for-any.tcl,v 1.1.2.1 2005/05/24 15:08:51 dgp Exp $ + +namespace eval control { + variable WaitForAnyKey 0 +} + +# control::waitForAny -- +# +# Like [vwait], but takes multiple variables and/or optional +# timeout. Allows you to detect which variable or variables got set +# during the vwait. +# +# Usage: +# waitForAny ?timeout? variable ?variable ...? +# +# Arguments: +# timeout - If the first argument is an integer, it specifies a +# timeout. If the timeout expires, waitForAny returns +# "timeout". +# variable - One or more fully scoped variable names. A change to +# any of these variables will cause waitForAny to +# return. +# +# Returns: +# A list of the variables that got set, or the string "timeout" to +# indicate that the timeout expired without any variables being +# set. +# +proc control::waitForAny {args} { + variable WaitForAnyArray + variable WaitForAnyKey + + # If first arg is a number, it specifies the timeout. + if {[string is integer [lindex $args 0]]} { + set timeout [lindex $args 0] + set args [lrange $args 1 end] + } + + # Create a trigger script that will be cause vwait to return. The + # [lappend] command is used here to capture all args appended by + # [trace]. + set index Key[incr WaitForAnyKey] + set trigger [namespace code [list lappend WaitForAnyArray($index)]] + + # Create the traces. + # Note that we use [concat $trigger $var] to make sure the trace gets + # called with the original name of the variable. Otherwise, the use + # of an upvar'd alias could prevent us from knowing which variable got + # set. + foreach var $args { + uplevel \#0 [list trace variable $var w [concat $trigger $var]] + } + + # Set timer if user requested a timeout. + if {[info exists timeout]} { + set timerId [after $timeout $trigger] + } + vwait [namespace which -variable WaitForAnyArray]($index) + + # Figure out which triggers fired during the vwait. + set ret {} + if {[info exists WaitForAnyArray($index)]} { + # Looks like a variable or variables got set. But, we aren't + # sure yet; the list can be empty. The format of this list is + # determined by the trace command. + foreach {vwaitName name1 name2 op} $WaitForAnyArray($index) { + # Avoid duplicates. Sometimes the trace gets invoked + # multiple times. I would use [lsort -unique], but I have to + # support tcl8.2.3 for now. + if {[lsearch -exact $ret $vwaitName] == -1} { + lappend ret $vwaitName + } + } + } + if {[llength $ret] == 0} { + # No variables got set. We timed out. + set ret timeout + } + + # Remove all traces. + foreach var $args { + uplevel \#0 [list trace vdelete $var w [concat $trigger $var]] + } + + # Cancel the timer. + if {[info exists timerId]} { + after cancel $timerId + } + + # Cleanup. + unset WaitForAnyArray($index) + + return $ret +} + +# Local Variables: +# tcl-indent-level:4 +# End: ADDED modules/control/wait-for-any.test Index: modules/control/wait-for-any.test ================================================================== --- /dev/null +++ modules/control/wait-for-any.test @@ -0,0 +1,144 @@ +# control.test -- +# +# Unit tests for the control package. +# +# Original author: kenstir +# +# $Id: wait-for-any.test,v 1.1.2.1 2005/05/24 15:08:51 dgp Exp $ + +# Standard tcltest startup. +# 8/2/01 kenstir: Due to tcltest-1.0 strangeness, this doesn't successfully +# import the ::tcltest::test proc. Switching to fully-qualified name. +#if {[lsearch [namespace children] ::tcltest] == -1} { +# package require tcltest +# namespace import ::tcltest::* +#} +package require tcltest + +# Source our pkg file. +set dirname [file dirname [info script]] +source [file join $dirname control.tcl] +package require control +namespace import -force control::* + +::tcltest::test wait-scalar {wait for 1 scalar} { + after 0 {set ::a0 1} + waitForAny ::a0 +} {::a0} + +::tcltest::test wait-scalar-namespace {wait for a scalar in a namespace} { + after 0 {set ::control::a0 1} + waitForAny ::control::a0 +} {::control::a0} + +::tcltest::test wait-multiple-scalars {wait for multiple scalars} { + # Kick off a bunch of events to happen in the near future. Keep track + # of outstanding events in array `arr'. + after 2000 {set ::a 1} ; set arr(::a) 1 + after 2000 {set ::b 1} ; set arr(::b) 1 + after 2000 {set ::c 1} ; set arr(::c) 1 + after 1000 {set ::d 1} ; set arr(::d) 1 + after 0000 {set ::e 1} ; set arr(::e) 1 + + # Loop until no more events are outstanding. + while {[array size arr] > 0} { + puts "Waiting for: [lsort [array names arr]]" + set r [eval waitForAny [array names arr]] + puts "Got [llength $r] results: $r" + foreach e $r { + unset arr($e) + } + } + + # Any problems will manifest as errors, so we don't expect any results. +} {} + +::tcltest::test wait-timeout {wait with timeout} { + after 2000 {set ::f 1} + + set r [waitForAny 10 ::f] + puts "Got [llength $r] results: $r" + + set r2 [waitForAny ::f] + puts "Got [llength $r2] results: $r2" + + list $r $r2 +} {timeout ::f} + +::tcltest::test wait-timeout-2 {wait with timeout that doesn't generate a timeout} { + after 0 {set ::f 1} + + set r [waitForAny 1000 ::f] + puts "Got [llength $r] results: $r" + + set r +} {::f} + +::tcltest::test wait-array-index {wait on array(index)} { + after 2000 {set ::g(a) 1} + set r [waitForAny ::g(a)] + puts "Got [llength $r] results: $r" + set r +} {::g(a)} + +::tcltest::test wait-entire-array {wait on entire array} { + set outstandingEvents 0 + after 0 {set ::h(a) 1} ; incr outstandingEvents + after 0 {set ::i(a) 1} ; incr outstandingEvents + while {$outstandingEvents > 0} { + set r [waitForAny ::h ::i] + puts "Got [llength $r] results: $r" + incr outstandingEvents -[llength $r] + } + + # Any problems will manifest as errors, so we don't expect any results. +} {} + +::tcltest::test neg-extra-wait {wait when no events are outstanding} {knownBug} { + # This wait should throw with "would wait forever". I'm not sure why, + # but that error doesn't happen on Windows 2000/tcl8.3.3; instead, + # vwait waits forever. + set caught [catch {waitForAny ::a} result] + puts result=$result + list $caught [string match {*would wait forever} $result] +} {1 1} + +::tcltest::test wait-scalar-upvar {wait for 1 scalar aliased through an upvar} { + upvar 0 ::a0 my_a + after 0 {set my_a 1} + waitForAny ::a0 +} {::a0} + +::tcltest::test wait-array-upvar {wait on array(index) aliased through an upvar} { + upvar 0 ::g my_g + after 0 {set my_g(a) 1} + set r [waitForAny ::g(a)] + puts "Got [llength $r] results: $r" + set r +} {::g(a)} + +# Waiting separately for two scalars does not work. The 2nd waitForAny +# results in "would wait forever", because by that time, the 2nd `after' +# was already reaped. This needs to be handled by one call to +# waitForAny. +#::tcltest::test wait-scalar-separately {wait for 2 scalars separately} { +# after 0 {set a 1} +# after 0 {set b 1} +# set r [waitForAny a] +# set r2 [waitForAny b] +# list $r $r2 +#} {a b} + +::tcltest::test wait-no-duplicates {multiple sets still only cause a single return} { + after 0 {set a 1 ; set a 2} + after 0 {set a 3} + set r [waitForAny a] + list $r $a +} {a 3} + +::tcltest::cleanupTests +return + +# Local Variables: +# tcl-indent-level:4 +# End: DELETED modules/counter/ChangeLog Index: modules/counter/ChangeLog ================================================================== --- modules/counter/ChangeLog +++ /dev/null @@ -1,94 +0,0 @@ -2003-04-11 Andreas Kupries - - * counter.tcl: - * counter.man: - * pkgIndex.tcl: Fixed bug #614591. Set version of the package to - to 2.0.1. - -2003-02-23 David N. Welton - - * counter.tcl (counter::names): Use string map instead of regsub. - Require Tcl 8.2 as a consequence. - -2003-01-16 Andreas Kupries - - * counter.man: More semantic markup, less visual one. - -2002-08-30 Andreas Kupries - - * counter.tcl: Updated 'info exist' to 'info exists'. - -2002-04-16 Andreas Kupries - - * counter.man: Added doctools manpage. - -2001-09-05 Andreas Kupries - - * counter.tcl: Restricted export list to public API. - [456255]. Patch by Hemang Lavana - - -2001-07-10 Andreas Kupries - - * counter.tcl: Frink 2.2 run, fixed dubious code. - -2001-07-09 Brent Welch - - * counter.test: Fixed histlog test - -2001-06-21 Andreas Kupries - - * counter.tcl: Fixed dubious code reported by frink. - -2000-10-04 Brent Welch - - * counter.tcl: Fixed bug in counter::MergeDay - -2000-10-03 Brent Welch - - * counter.tcl: Fixed bug in label format for daily graph. - -2000-10-02 Brent Welch - - * NAME CHANGE from "stats" to "counter" - * counter.tcl: Changed shading of histogram labels. - -2000-10-02 Brent Welch - - * modules/stats/stats.tcl: Added stats::htmlHistDisplayRow - so that the calling page could define the overall table structure. - -2000-10-01 Brent Welch - - * modules/stats/stats.tcl: Fixed calculation of hourBase - and minuteBase when secsPerMinute was not 60. - -2000-09-23 Brent Welch - - * modules/stats/stats.tcl: Time-based histograms were - not displaying the 23rd hour nor the 59th minute. - -2000-09-22 Brent Welch - - * modules/stats/stats.tcl: Fixed initialization when the - server starts in the 59'th minute. The first after event - was an hour too long, so the first hour of data didn't - display correctly. - -2000-09-21 Brent Welch - - * modules/stats/stats.tcl: Added time labels and tick - marks to all the time-based histograms. - Fixed alignment of per-minute and per-hour histograms. - -2000-09-20 Brent Welch - - * modules/stats/stats.tcl: Refined the countGet routine to return things - needed by the TclHttpd status module. Refined the value-based histogram display. - * modules/stats/stats.tests: Added more tests. - * modules/stats/stats.n: Completed the man page. - -2000-09-15 Brent Welch - - * Created this module. - DELETED modules/counter/counter.man Index: modules/counter/counter.man ================================================================== --- modules/counter/counter.man +++ /dev/null @@ -1,244 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[manpage_begin counter n 2.0.1] -[moddesc {Counters and Histograms}] -[titledesc {Procedures for counters and histograms}] -[require Tcl 8] -[require counter [opt 2.0.1]] -[description] -[para] - -The [package counter] package provides a counter facility and can -compute statistics and histograms over the collected data. - -[list_begin definitions] - - -[call [cmd ::counter::init] [arg {tag args}]] - -This defines a counter with the name [arg tag]. The [arg args] -determines the characteristics of the counter. The [arg args] are - -[list_begin definitions] -[lst_item "[option -group] [arg name]"] - -Keep a grouped counter where the name of the histogram bucket is -passed into [cmd ::counter::count]. - -[lst_item "[option -hist] [arg bucketsize]"] - -Accumulate the counter into histogram buckets of size - -[arg bucketsize]. For example, if the samples are millisecond time -values and [arg bucketsize] is 10, then each histogram bucket -represents time values of 0 to 10 msec, 10 to 20 msec, 20 to 30 msec, -and so on. - -[lst_item "[option -hist2x] [arg bucketsize]"] - -Accumulate the statistic into histogram buckets. The size of the -first bucket is [arg bucketsize], each other bucket holds values 2 -times the size of the previous bucket. For example, if - -[arg bucketsize] is 10, then each histogram bucket represents time -values of 0 to 10 msec, 10 to 20 msec, 20 to 40 msec, 40 to 80 msec, -and so on. - -[lst_item "[option -hist10x] [arg bucketsize]"] - -Accumulate the statistic into histogram buckets. The size of the -first bucket is [arg bucketsize], each other bucket holds values 10 -times the size of the previous bucket. For example, if - -[arg bucketsize] is 10, then each histogram bucket represents time -values of 0 to 10 msec, 10 to 100 msec, 100 to 1000 msec, and so on. - -[lst_item "[option -lastn] [arg N]"] - -Save the last [arg N] values of the counter to maintain a "running -average" over the last [arg N] values. - -[lst_item "[option -timehist] [arg secsPerMinute]"] - -Keep a time-based histogram. The counter is summed into a histogram -bucket based on the current time. There are 60 per-minute buckets -that have a size determined by [arg secsPerMinute], which is normally -60, but for testing purposes can be less. Every "hour" (i.e., 60 -"minutes") the contents of the per-minute buckets are summed into the -next hourly bucket. Every 24 "hours" the contents of the per-hour -buckets are summed into the next daily bucket. The counter package -keeps all time-based histograms in sync, so the first - -[arg secsPerMinute] value seen by the package is used for all -subsequent time-based histograms. - -[list_end] - - -[call [cmd ::counter::count] [arg tag] [opt [arg delta]] [opt [arg instance]]] - -Increment the counter identified by [arg tag]. The default increment -is 1, although you can increment by any value, integer or real, by -specifying [arg delta]. You must declare each counter with - -[cmd ::counter::init] to define the characteristics of counter before -you start to use it. If the counter type is [option -group], then the -counter identified by [arg instance] is incremented. - - -[call [cmd ::counter::start] [arg {tag instance}]] - -Record the starting time of an interval. The [arg tag] is the name of -the counter defined as a [option -hist] value-based histogram. The -[arg instance] is used to distinguish this interval from any other -intervals that might be overlapping this one. - - -[call [cmd ::counter::stop] [arg {tag instance}]] - -Record the ending time of an interval. The delta time since the -corresponding [cmd ::counter::start] call for [arg instance] is -recorded in the histogram identified by [arg tag]. - - -[call [cmd ::counter::get] [arg {tag args}]] - -Return statistics about a counter identified by [arg tag]. The - -[arg args] determine what value to return: - -[list_begin definitions] -[lst_item [option -total]] - -Return the total value of the counter. This is the default if - -[arg args] is not specified. - -[lst_item [option -totalVar]] - -Return the name of the total variable. Useful for specifying with --textvariable in a Tk widget. - -[lst_item [option -N]] - -Return the number of samples accumulated into the counter. - -[lst_item [option -avg]] - -Return the average of samples accumulated into the counter. - -[lst_item [option -avgn]] - -Return the average over the last [arg N] samples taken. The [arg N] -value is set in the [cmd ::counter::init] call. - -[lst_item "[option -hist] [arg bucket]"] - -If [arg bucket] is specified, then the value in that bucket of the -histogram is returned. Otherwise the complete histogram is returned -in array get format sorted by bucket. - -[lst_item [option -histVar]] - -Return the name of the histogram array variable. - -[lst_item [option -histHour]] - -Return the complete hourly histogram in array get format sorted by -bucket. - -[lst_item [option -histHourVar]] - -Return the name of the hourly histogram array variable. - -[lst_item [option -histDay]] - -Return the complete daily histogram in array get format sorted by -bucket. - -[lst_item [option -histDayVar]] - -Return the name of the daily histogram array variable. - -[lst_item [option -resetDate]] - -Return the clock seconds value recorded when the -counter was last reset. - -[lst_item [option -all]] - -Return an array get of the array used to store the counter. This -includes the total, the number of samples (N), and any type-specific -information. This does not include the histogram array. - -[list_end] - - -[call [cmd ::counter::exists] [arg tag]] - -Returns 1 if the counter is defined. - - -[call [cmd ::counter::names]] - -Returns a list of all counters defined. - - -[call [cmd ::counter::histHtmlDisplay] [arg {tag args}]] - -Generate HTML to display a histogram for a counter. The [arg args] -control the format of the display. They are: - -[list_begin definitions] -[lst_item "[option -title] [arg string]"] - -Label to display above bar chart - -[lst_item "[option -unit] [arg unit]"] - -Specify [const minutes], [const hours], or [const days] for the -time-base histograms. For value-based histograms, the [arg unit] is -used in the title. - -[lst_item "[option -images] [arg url]"] - -URL of /images directory. - -[lst_item "[option -gif] [arg filename]"] - -Image for normal histogram bars. The [arg filename] is relative to -the [option -images] directory. - -[lst_item "[option -ongif] [arg filename]"] - -Image for the active histogram bar. The [arg filename] is relative to -the [option -images] directory. - -[lst_item "[option -max] [arg N]"] - -Maximum number of value-based buckets to display. - -[lst_item "[option -height] [arg N]"] - -Pixel height of the highest bar. - -[lst_item "[option -width] [arg N]"] - -Pixel width of each bar. - -[lst_item "[option -skip] [arg N]"] - -Buckets to skip when labeling value-based histograms. - -[lst_item "[option -format] [arg string]"] - -Format used to display labels of buckets. - -[lst_item "[option -text] [arg boolean]"] - -If 1, a text version of the histogram is dumped, otherwise a graphical -one is generated. - -[list_end] -[list_end] - -[manpage_end] DELETED modules/counter/counter.n Index: modules/counter/counter.n ================================================================== --- modules/counter/counter.n +++ /dev/null @@ -1,232 +0,0 @@ -'\" -'\" Copyright (c) 1998-2000 by Ajuba Solutions. -'\" All rights reserved. -'\" -'\" RCS: @(#) $Id: counter.n,v 1.3 2001/08/02 16:38:06 andreas_kupries Exp $ -'\" -.so man.macros -.TH counter n 1.0 Counter "Counters and Histograms" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -::counter \- Procedures for counters and histograms. -.SH SYNOPSIS -\fBpackage require Tcl 8\fR -.sp -\fBpackage require counter ?2.0?\fR -.sp -\fBcounter::init\fR \fItag\fR \fIargs\fR -.sp -\fBcounter::count\fR \fItag {delta 1} args\fR -.sp -\fBcounter::reset\fR \fItag\fR -.sp -\fBcounter::get\fR \fItag args\fR -.sp -\fBcounter::start\fR \fItag\fR -.sp -\fBcounter::stop\fR \fItag\fR -.sp -\fBcounter::exists\fR \fItag\fR -.sp -\fBcounter::names\fR \fItag\fR -.sp -\fBcounter::histHtmlDisplay\fR \fItag args\fR -.BE -.SH DESCRIPTION -.PP -The \fB::counter\fR package provides a counter facility and -can compute statistics and histograms over the collected data. - -.TP -\fBcounter::init\fR \fItag args\fR -This defines a counter with the name \fItag\fP. -The \fIargs\fP determines the characteristics of the counter. -The \fIargs\fP are - -.TP -\fB-group\fR \fIname\fR -Keep a grouped counter where the name of the histogram bucket -is passed into \fBcounter::count\fP. - -.TP -\fB-hist\fR \fIbucketsize\fR -Accumulate the counter into histogram buckets of size -\fIbucketsize\fP. For example, if the samples are millisecond -time values and \fIbucketsize\fP is 10, then each -histogram bucket represents time values of -0 to 10 msec, 10 to 20 msec, 20 to 30 msec, and so on. - -.TP -\fB-hist2x\fR \fIbucketsize\fR -Accumulate the statistic into histogram buckets. -The size of the first bucket is -\fIbucketsize\fP, each other bucket holds values -2 times the size of the previous bucket. -For example, if \fIbucketsize\fP is 10, then each -histogram bucket represents time values of -0 to 10 msec, 10 to 20 msec, 20 to 40 msec, 40 to 80 msec, and so on. - -.TP -\fB-hist10x\fR \fIbucketsize\fR -Accumulate the statistic into histogram buckets. -The size of the first bucket is -\fIbucketsize\fP, each other bucket holds values -10 times the size of the previous bucket. -For example, if \fIbucketsize\fP is 10, then each -histogram bucket represents time values of -0 to 10 msec, 10 to 100 msec, 100 to 1000 msec, and so on. - -.TP -\fB-lastn\fR \fIN\fR -Save the last \fIN\fP values of the counter to maintain -a "running average" over the last \fIN\fP values. - -.TP -\fB-timehist\fR \fIsecsPerMinute\fR -Keep a time-based histogram. -The counter is summed into a histogram bucket based on the current time. -There are 60 per-minute buckets that have a size determined by -\fIsecsPerMinute\fP, which -is normally 60, but for testing purposes can be less. -Every "hour" (i.e., 60 "minutes") the contents of the per-minute buckets are summed -into the next hourly bucket. -Every 24 "hours" the contents of the per-hour buckets are summed into -the next daily bucket. -The counter package keeps all time-based histograms in sync, so the first -\fIsecsPerMinute\fP value seen by the package is used for all subsequent -time-based histograms. - -.TP -\fBcounter::count\fR \fItag {delta 1} {instance {}}\fR -Increment the counter identified by \fItag\fP. -The default increment is 1, although you can increment -by any value, integer or real, by specifying \fIdelta\fP. -You must declare each counter with \fBcounter::init\fP to define -the characteristics of counter before you start to use it. -If the counter type is \fB-group\fP, then the counter -identified by \fIinstance\fP is incremented. - -.TP -\fBcounter::start\fR \fItag instance\fR -Record the starting time of an interval. -The \fItag\fP is the name of the counter defined as -a \fB-hist\fP value-based histogram. -The \fIinstance\fP is used to distinguish this interval from -any other intervals that might be overlapping this one. - -.TP -\fBcounter::stop\fR \fItag instance\fR -Record the ending time of an interval. -The delta time since the corresponding \fBcountStart\fP call -for \fIinstance\fP is recorded in the histogram -identified by \fItag\fP. - -.TP -\fBcounter::get\fR \fItag args\fR -Return statistics about a counter -identified by \fItag\fP. -The \fIargs\fP determine what value to return: -.TP -\fB-total\fP -Return the total value of the counter. This is the default -if \fIargs\fP is not specified. -.TP -\fB-totalVar\fP -Return the name of the total variable. Useful for -specifying with -textvariable in a Tk widget. -.TP -\fB-N\fP -Return the number of samples accumulated into the counter. -.TP -\fB-avg\fP -Return the average of samples accumulated into the counter. -.TP -\fB-avgn\fP -Return the average over the last \fIN\fP samples taken. -The \fIN\fP value is set in the \fBcounter::init\fP call. -.TP -\fB-hist\fP \fIbucket\fP -If \fIbucket\fP is specified, then the value in that bucket -of the histogram is returned. -Otherwise the complete histogram is returned -in array get format sorted by bucket. -.TP -\fB-histVar\fP -Return the name of the histogram array variable. -.TP -\fB-histHour\fP -Return the complete hourly histogram -in array get format sorted by bucket. -.TP -\fB-histHourVar\fP -Return the name of the hourly histogram array variable. -.TP -\fB-histDay\fP -Return the complete daily histogram -in array get format sorted by bucket. -.TP -\fB-histDayVar\fP -Return the name of the daily histogram array variable. -.TP -\fB-resetDate\fP -Return the clock seconds value recorded when the -counter was last reset. -.TP -\fB-all\fP -Return an array get of the array used to store the counter. -This includes the total, the number of samples (N), and any -type-specific information. This does not include the -histogram array. - -.TP -\fBcounter::exists\fR \fItag\fR -Returns 1 if the counter is defined. - -.TP -\fBcounter::names\fR -Returns a list of all counters defined. - -.TP -\fBcounter::histHtmlDisplay\fR \fItag args\fR -Generate HTML to display a histogram for a counter. -The \fIargs\fP control the format of the display. -They are: - -.TP -\fB-title\fI string\fP -Label to display above bar chart -.TP -\fB-unit\fI unit\fP -Specify \fBminutes\fP, \fBhours\fP, or \fBdays\fP for the time-base histograms. -For value-based histograms, the \fIunit\fP is used in the title. -.TP -\fB-images\fI url\fP -URL of /images directory. -.TP -\fB-gif\fI filename\fP -Image for normal histogram bars. -The \fIfilename\fP is relative to the \fP-images\fP directory. -.TP -\fB-ongif\fI filename\fP -Image for the active histogram bar. -The \fIfilename\fP is relative to the \fP-images\fP directory. -.TP -\fB-max\fI N\fP -Maximum number of value-based buckets to display. -.TP -\fB-height\fI N\fP -Pixel height of the highest bar. -.TP -\fB-width\fI N\fP -Pixel width of each bar. -.TP -\fB-skip\fI N\fP -Buckets to skip when labeling value-based histograms. -.TP -\fB-format\fI string\fP -Format used to display labels of buckets. -.TP -\fB-text\fI boolean\fP -If 1, a text version of the histogram is dumped, -otherwise a graphical one is generated. DELETED modules/counter/counter.tcl Index: modules/counter/counter.tcl ================================================================== --- modules/counter/counter.tcl +++ /dev/null @@ -1,1253 +0,0 @@ -# counter.tcl -- -# -# Procedures to manage simple counters and histograms. -# -# Copyright (c) 1998-2000 by Ajuba Solutions. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: counter.tcl,v 1.11 2003/04/11 19:01:06 andreas_kupries Exp $ - -package require Tcl 8.2 - -namespace eval ::counter { - - # Variables of name counter::T-$tagname - # are created as arrays to support each counter. - - # Time-based histograms are kept in sync with each other, - # so these variables are shared among them. - # These base times record the time corresponding to the first bucket - # of the per-minute, per-hour, and per-day time-based histograms. - - variable startTime - variable minuteBase - variable hourBase - variable hourEnd - variable dayBase - variable hourIndex - variable dayIndex - - # The time-based histogram uses an after event and a list - # of counters to do mergeing on. - - variable tagsToMerge - if {![info exists tagsToMerge]} { - set tagsToMerge {} - } - variable mergeInterval - - namespace export init reset count exists get names start stop - namespace export histHtmlDisplay histHtmlDisplayRow histHtmlDisplayBarChart -} - -# ::counter::init -- -# -# Set up a counter. -# -# Arguments: -# tag The identifier for the counter. Pass this to counter::count -# args option values pairs that define characteristics of the counter: -# See the man page for definitons. -# -# Results: -# None. -# -# Side Effects: -# Initializes state about a counter. - -proc ::counter::init {tag args} { - upvar #0 counter::T-$tag counter - if {[info exists counter]} { - unset counter - } - set counter(N) 0 ;# Number of samples - set counter(total) 0 - set counter(type) {} - - # With an empty type the counter is a simple accumulator - # for which we can compute an average. Here we loop through - # the args to determine what additional counter attributes - # we need to maintain in counter::count - - foreach {option value} $args { - switch -- $option { - -timehist { - variable tagsToMerge - variable secsPerMinute - variable startTime - variable minuteBase - variable hourBase - variable dayBase - variable hourIndex - variable dayIndex - - upvar #0 counter::H-$tag histogram - upvar #0 counter::Hour-$tag hourhist - upvar #0 counter::Day-$tag dayhist - - # Clear the histograms. - - for {set i 0} {$i < 60} {incr i} { - set histogram($i) 0 - } - for {set i 0} {$i < 24} {incr i} { - set hourhist($i) 0 - } - if {[info exists dayhist]} { - unset dayhist - } - set dayhist(0) 0 - - # Clear all-time high records - - set counter(maxPerMinute) 0 - set counter(maxPerHour) 0 - set counter(maxPerDay) 0 - - # The value associated with -timehist is the number of seconds - # in each bucket. Normally this is 60, but for - # testing, we compress minutes. The value is limited at - # 60 because the per-minute buckets are accumulated into - # per-hour buckets later. - - if {$value == "" || $value == 0 || $value > 60} { - set value 60 - } - - # Histogram state variables. - # All time-base histograms share the same bucket size - # and starting times to keep them all synchronized. - # So, we only initialize these parameters once. - - if {![info exists secsPerMinute]} { - set secsPerMinute $value - - set startTime [clock seconds] - set dayIndex 0 - - set dayStart [clock scan [clock format $startTime \ - -format 00:00]] - - # Figure out what "hour" we are - - set delta [expr {$startTime - $dayStart}] - set hourIndex [expr {$delta / ($secsPerMinute * 60)}] - set day [expr {$hourIndex / 24}] - set hourIndex [expr {$hourIndex % 24}] - - set hourBase [expr {$dayStart + $day * $secsPerMinute * 60 * 24}] - set minuteBase [expr {$hourBase + $hourIndex * 60 * $secsPerMinute}] - - set partialHour [expr {$startTime - - ($hourBase + $hourIndex * 60 * $secsPerMinute)}] - set secs [expr {(60 * $secsPerMinute) - $partialHour}] - if {$secs <= 0} { - set secs 1 - } - - # After the first timer, the event occurs once each "hour" - - set mergeInterval [expr {60 * $secsPerMinute * 1000}] - after [expr {$secs * 1000}] [list counter::MergeHour $mergeInterval] - } - if {[lsearch $tagsToMerge $tag] < 0} { - lappend tagsToMerge $tag - } - - # This records the last used slots in order to zero-out the - # buckets that are skipped during idle periods. - - set counter(lastMinute) -1 - - # The following is referenced when bugs cause histogram - # hits outside the expect range (overflow and underflow) - - set counter(bucketsize) 0 - } - -group { - # Cluster a set of counters with a single total - - upvar #0 counter::H-$tag histogram - if {[info exists histogram]} { - unset histogram - } - set counter(group) $value - } - -lastn { - # The lastN samples are kept if a vector to form a running average. - - upvar #0 counter::V-$tag vector - set counter(lastn) $value - set counter(index) 0 - if {[info exists vector]} { - unset vector - } - for {set i 0} {$i < $value} {incr i} { - set vector($i) 0 - } - } - -hist { - # A value-based histogram with buckets for different values. - - upvar #0 counter::H-$tag histogram - if {[info exists histogram]} { - unset histogram - } - set counter(bucketsize) $value - set counter(mult) 1 - } - -hist2x { - upvar #0 counter::H-$tag histogram - if {[info exists histogram]} { - unset histogram - } - set counter(bucketsize) $value - set counter(mult) 2 - } - -hist10x { - upvar #0 counter::H-$tag histogram - if {[info exists histogram]} { - unset histogram - } - set counter(bucketsize) $value - set counter(mult) 10 - } - -histlog { - upvar #0 counter::H-$tag histogram - if {[info exists histogram]} { - unset histogram - } - set counter(bucketsize) $value - } - -simple { - # Useful when disabling predefined -timehist or -group counter - } - default { - return -code error "Unsupported option $option.\ - Must be -timehist, -group, -lastn, -hist, -hist2x, -hist10x, -histlog, or -simple." - } - } - if {[string length $option]} { - # In case an option doesn't change the type, but - # this feature of the interface isn't used, etc. - - lappend counter(type) $option - } - } - - # Instead of supporting a counter that could have multiple attributes, - # we support a single type to make counting more efficient. - - if {[llength $counter(type)] > 1} { - return -code error "Multiple type attributes not supported. Use only one of\ - -timehist, -group, -lastn, -hist, -hist2x, -hist10x, -histlog, -disabled." - } - return "" -} - -# ::counter::reset -- -# -# Reset a counter. -# -# Arguments: -# tag The identifier for the counter. -# -# Results: -# None. -# -# Side Effects: -# Deletes the counter and calls counter::init again for it. - -proc ::counter::reset {tag args} { - upvar #0 counter::T-$tag counter - - # Layer reset on top of init. Here we figure out what - # we need to pass into the init procedure to recreate it. - - switch -- $counter(type) { - "" { - set args "" - } - -group { - upvar #0 counter::H-$tag histogram - if {[info exists histogram]} { - unset histogram - } - set args [list -group $counter(group)] - } - -lastn { - upvar #0 counter::V-$tag vector - if {[info exists vector]} { - unset vector - } - set args [list -lastn $counter(lastn)] - } - -hist - - -hist10x - - -histlog - - -hist2x { - upvar #0 counter::H-$tag histogram - if {[info exists histogram]} { - unset histogram - } - set args [list $counter(type) $counter(bucketsize)] - } - -timehist { - foreach h [list counter::H-$tag counter::Hour-$tag counter::Day-$tag] { - upvar #0 $h histogram - if {[info exists histogram]} { - unset histogram - } - } - set args [list -timehist $counter::secsPerMinute] - } - default {#ignore} - } - unset counter - eval {counter::init $tag} $args - set counter(resetDate) [clock seconds] - return "" -} - -# ::counter::count -- -# -# Accumulate statistics. -# -# Arguments: -# tag The counter identifier. -# delta The increment amount. Defaults to 1. -# arg For -group types, this is the histogram index. -# -# Results: -# None -# -# Side Effects: -# Accumlate statistics. - -proc ::counter::count {tag {delta 1} args} { - upvar #0 counter::T-$tag counter - set counter(total) [expr {$counter(total) + $delta}] - incr counter(N) - - # Instead of supporting a counter that could have multiple attributes, - # we support a single type to make counting a skosh more efficient. - -# foreach option $counter(type) { - switch -- $counter(type) { - "" { - # Simple counter - return - } - -group { - upvar #0 counter::H-$tag histogram - set subIndex [lindex $args 0] - if {![info exists histogram($subIndex)]} { - set histogram($subIndex) 0 - } - set histogram($subIndex) [expr {$histogram($subIndex) + $delta}] - } - -lastn { - upvar #0 counter::V-$tag vector - set vector($counter(index)) $delta - set counter(index) [expr {($counter(index) +1)%$counter(lastn)}] - } - -hist { - upvar #0 counter::H-$tag histogram - set bucket [expr {int($delta / $counter(bucketsize))}] - if {![info exists histogram($bucket)]} { - set histogram($bucket) 0 - } - incr histogram($bucket) - } - -hist10x - - -hist2x { - upvar #0 counter::H-$tag histogram - set bucket 0 - for {set max $counter(bucketsize)} {$delta > $max} \ - {set max [expr {$max * $counter(mult)}]} { - incr bucket - } - if {![info exists histogram($bucket)]} { - set histogram($bucket) 0 - } - incr histogram($bucket) - } - -histlog { - upvar #0 counter::H-$tag histogram - set bucket [expr {int(log($delta)*$counter(bucketsize))}] - if {![info exists histogram($bucket)]} { - set histogram($bucket) 0 - } - incr histogram($bucket) - } - -timehist { - upvar #0 counter::H-$tag histogram - variable minuteBase - variable secsPerMinute - - set minute [expr {([clock seconds] - $minuteBase) / $secsPerMinute}] - if {$minute > 59} { - # this occurs while debugging if the process is - # stopped at a breakpoint too long. - set minute 59 - } - - # Initialize the current bucket and - # clear any buckets we've skipped since the last sample. - - if {$minute != $counter(lastMinute)} { - set histogram($minute) 0 - for {set i [expr {$counter(lastMinute)+1}]} \ - {$i < $minute} \ - {incr i} { - set histogram($i) 0 - } - set counter(lastMinute) $minute - } - set histogram($minute) [expr {$histogram($minute) + $delta}] - } - default {#ignore} - } -# } - return -} - -# ::counter::exists -- -# -# Return true if the counter exists. -# -# Arguments: -# tag The counter identifier. -# -# Results: -# 1 if it has been defined. -# -# Side Effects: -# None. - -proc ::counter::exists {tag} { - upvar #0 counter::T-$tag counter - return [info exists counter] -} - -# ::counter::get -- -# -# Return statistics. -# -# Arguments: -# tag The counter identifier. -# option What statistic to get -# args Needed by some options. -# -# Results: -# With no args, just the counter value. -# -# Side Effects: -# None. - -proc ::counter::get {tag {option -total} args} { - upvar #0 counter::T-$tag counter - switch -- $option { - -total { - return $counter(total) - } - -totalVar { - return ::counter::T-$tag\(total) - } - -N { - return $counter(N) - } - -avg { - if {$counter(N) == 0} { - return 0 - } else { - return [expr {$counter(total) / double($counter(N))}] - } - } - -avgn { - upvar #0 counter::V-$tag vector - set sum 0 - for {set i 0} {($i < $counter(N)) && ($i < $counter(lastn))} {incr i} { - set sum [expr {$sum + $vector($i)}] - } - if {$i == 0} { - return 0 - } else { - return [expr {$sum / double($i)}] - } - } - -hist { - upvar #0 counter::H-$tag histogram - if {[llength $args]} { - # Return particular bucket - set bucket [lindex $args 0] - if {[info exists histogram($bucket)]} { - return $histogram($bucket) - } else { - return 0 - } - } else { - # Dump the whole histogram - - set result {} - if {$counter(type) == "-group"} { - set sort -dictionary - } else { - set sort -integer - } - foreach x [lsort $sort [array names histogram]] { - lappend result $x $histogram($x) - } - return $result - } - } - -histVar { - return ::counter::H-$tag - } - -histHour { - upvar #0 counter::Hour-$tag histogram - set result {} - foreach x [lsort -integer [array names histogram]] { - lappend result $x $histogram($x) - } - return $result - } - -histHourVar { - return ::counter::Hour-$tag - } - -histDay { - upvar #0 counter::Day-$tag histogram - set result {} - foreach x [lsort -integer [array names histogram]] { - lappend result $x $histogram($x) - } - return $result - } - -histDayVar { - return ::counter::Day-$tag - } - -maxPerMinute { - return $counter(maxPerMinute) - } - -maxPerHour { - return $counter(maxPerHour) - } - -maxPerDay { - return $counter(maxPerDay) - } - -resetDate { - if {[info exists counter(resetDate)]} { - return $counter(resetDate) - } else { - return "" - } - } - -all { - return [array get counter] - } - default { - return -code error "Invalid option $option.\ - Should be -all, -total, -N, -avg, -avgn, -hist, -histHour,\ - -histDay, -totalVar, -histVar, -histHourVar, -histDayVar -resetDate." - } - } -} - -# ::counter::names -- -# -# Return the list of defined counters. -# -# Arguments: -# none -# -# Results: -# A list of counter tags. -# -# Side Effects: -# None. - -proc ::counter::names {} { - set result {} - foreach v [info vars ::counter::T-*] { - if {[info exists $v]} { - # Declared arrays might not exist, yet - set v [string map {{::counter::T-} {}} $v] - lappend result $v - } - } - return $result -} - -# ::counter::MergeHour -- -# -# Sum the per-minute histogram into the next hourly bucket. -# On 24-hour boundaries, sum the hourly buckets into the next day bucket. -# This operates on all time-based histograms. -# -# Arguments: -# none -# -# Results: -# none -# -# Side Effects: -# See description. - -proc ::counter::MergeHour {interval} { - variable hourIndex - variable minuteBase - variable hourBase - variable tagsToMerge - variable secsPerMinute - - after $interval [list counter::MergeHour $interval] - if {![info exists hourBase] || $hourIndex == 0} { - set hourBase $minuteBase - } - set minuteBase [clock seconds] - - foreach tag $tagsToMerge { - upvar #0 counter::T-$tag counter - upvar #0 counter::H-$tag histogram - upvar #0 counter::Hour-$tag hourhist - - # Clear any buckets we've skipped since the last sample. - - for {set i [expr {$counter(lastMinute)+1}]} {$i < 60} {incr i} { - set histogram($i) 0 - } - set counter(lastMinute) -1 - - # Accumulate into the next hour bucket. - - set hourhist($hourIndex) 0 - set max 0 - foreach i [array names histogram] { - set hourhist($hourIndex) [expr {$hourhist($hourIndex) + $histogram($i)}] - if {$histogram($i) > $max} { - set max $histogram($i) - } - } - set perSec [expr {$max / $secsPerMinute}] - if {$perSec > $counter(maxPerMinute)} { - set counter(maxPerMinute) $perSec - } - } - set hourIndex [expr {($hourIndex + 1) % 24}] - if {$hourIndex == 0} { - counter::MergeDay - } - -} -# ::counter::MergeDay -- -# -# Sum the per-minute histogram into the next hourly bucket. -# On 24-hour boundaries, sum the hourly buckets into the next day bucket. -# This operates on all time-based histograms. -# -# Arguments: -# none -# -# Results: -# none -# -# Side Effects: -# See description. - -proc ::counter::MergeDay {} { - variable dayIndex - variable dayBase - variable hourBase - variable tagsToMerge - variable secsPerMinute - - # Save the hours histogram into a bucket for the last day - # counter(day,$day) is the starting time for that day bucket - - if {![info exists dayBase]} { - set dayBase $hourBase - } - foreach tag $tagsToMerge { - upvar #0 counter::T-$tag counter - upvar #0 counter::Day-$tag dayhist - upvar #0 counter::Hour-$tag hourhist - set dayhist($dayIndex) 0 - set max 0 - for {set i 0} {$i < 24} {incr i} { - if {[info exists hourhist($i)]} { - set dayhist($dayIndex) [expr {$dayhist($dayIndex) + $hourhist($i)}] - if {$hourhist($i) > $max} { - set mx $hourhist($i) - } - } - } - set perSec [expr {double($max) / ($secsPerMinute * 60)}] - if {$perSec > $counter(maxPerHour)} { - set counter(maxPerHour) $perSec - } - } - set perSec [expr {double($dayhist($dayIndex)) / ($secsPerMinute * 60 * 24)}] - if {$perSec > $counter(maxPerDay)} { - set counter(maxPerDay) $perSec - } - incr dayIndex -} - -# ::counter::histHtmlDisplay -- -# -# Create an html display of the histogram. -# -# Arguments: -# tag The counter tag -# args option, value pairs that affect the display: -# -title Label to display above bar chart -# -unit minutes, hours, or days select time-base histograms. -# Specify anything else for value-based histograms. -# -images URL of /images directory. -# -gif Image for normal histogram bars -# -ongif Image for the active histogram bar -# -max Maximum number of value-based buckets to display -# -height Pixel height of the highest bar -# -width Pixel width of each bar -# -skip Buckets to skip when labeling value-based histograms -# -format Format used to display labels of buckets. -# -text If 1, a text version of the histogram is dumped, -# otherwise a graphical one is generated. -# -# Results: -# HTML for the display as a complete table. -# -# Side Effects: -# None. - -proc ::counter::histHtmlDisplay {tag args} { - append result "

\n\n" - append result [eval {counter::histHtmlDisplayRow $tag} $args] - append result
- return $result -} - -# ::counter::histHtmlDisplayRow -- -# -# Create an html display of the histogram. -# -# Arguments: -# See counter::histHtmlDisplay -# -# Results: -# HTML for the display. Ths is one row of a 2-column table, -# the calling page must define the tag. -# -# Side Effects: -# None. - -proc ::counter::histHtmlDisplayRow {tag args} { - upvar #0 counter::T-$tag counter - variable secsPerMinute - variable minuteBase - variable hourBase - variable dayBase - variable hourIndex - variable dayIndex - - array set options [list \ - -title $tag \ - -unit "" \ - -images /images \ - -gif Blue.gif \ - -ongif Red.gif \ - -max -1 \ - -height 100 \ - -width 4 \ - -skip 4 \ - -format %.2f \ - -text 0 - ] - array set options $args - - # Support for self-posting pages that can clear counters. - - append result "" - if {[ncgi::value resetCounter] == $tag} { - counter::reset $tag - return "" - } - - switch -glob -- $options(-unit) { - min* { - upvar #0 counter::H-$tag histogram - set histname counter::H-$tag - if {![info exists minuteBase]} { - return "" - } - set time $minuteBase - set secsForMax $secsPerMinute - set periodMax $counter(maxPerMinute) - set curIndex [expr {([clock seconds] - $minuteBase) / $secsPerMinute}] - set options(-max) 60 - set options(-min) 0 - } - hour* { - upvar #0 counter::Hour-$tag histogram - set histname counter::Hour-$tag - if {![info exists hourBase]} { - return "" - } - set time $hourBase - set secsForMax [expr {$secsPerMinute * 60}] - set periodMax $counter(maxPerHour) - set curIndex [expr {$hourIndex - 1}] - if {$curIndex < 0} { - set curIndex 23 - } - set options(-max) 24 - set options(-min) 0 - } - day* { - upvar #0 counter::Day-$tag histogram - set histname counter::Day-$tag - if {![info exists dayBase]} { - return "" - } - set time $dayBase - set secsForMax [expr {$secsPerMinute * 60 * 24}] - set periodMax $counter(maxPerDay) - set curIndex dayIndex - set options(-max) $dayIndex - set options(-min) 0 - } - default { - # Value-based histogram with arbitrary units. - - upvar #0 counter::H-$tag histogram - set histname counter::H-$tag - - set unit $options(-unit) - set curIndex "" - set time "" - } - } - if {! [info exists histogram]} { - return "\n" - } - - set max 0 - set maxName 0 - foreach {name value} [array get histogram] { - if {$value > $max} { - set max $value - set maxName $name - } - } - - # Start 2-column HTML display. A summary table at the left, the histogram on the right. - - append result "\n - append result "\n - - return $result -} - -# ::counter::histHtmlDisplayBarChart -- -# -# Create an html display of the histogram. -# -# Arguments: -# tag The counter tag. -# histVar The name of the histogram array -# max The maximum counter value in a histogram bucket. -# curIndex The "current" histogram index, for time-base histograms. -# time The base, or starting time, for the time-based histograms. -# args The array get of the options passed into histHtmlDisplay -# -# Results: -# HTML for the bar chart. -# -# Side Effects: -# See description. - -proc ::counter::histHtmlDisplayBarChart {tag histVar max curIndex time args} { - upvar #0 counter::T-$tag counter - upvar 1 $histVar histogram - variable secsPerMinute - array set options $args - - append result "
\n" - - append result "\n" - append result "\n" - append result "" - append result "\n" - - if {[info exists secsForMax]} { - - # Time-base histogram - - set string {} - set t $secsForMax - set days [expr {$t / (60 * 60 * 24)}] - if {$days == 1} { - append string "1 Day " - } elseif {$days > 1} { - append string "$days Days " - } - set t [expr {$t - $days * (60 * 60 * 24)}] - set hours [expr {$t / (60 * 60)}] - if {$hours == 1} { - append string "1 Hour " - } elseif {$hours > 1} { - append string "$hours Hours " - } - set t [expr {$t - $hours * (60 * 60)}] - set mins [expr {$t / 60}] - if {$mins == 1} { - append string "1 Minute " - } elseif {$mins > 1} { - append string "$mins Minutes " - } - set t [expr {$t - $mins * 60}] - if {$t == 1} { - append string "1 Second " - } elseif {$t > 1} { - append string "$t Seconds " - } - append result "" - append result "\n" - - append result "" - append result "\n" - - if {$periodMax > 0} { - append result "" - append result "\n" - } - append result "" - switch -glob -- $options(-unit) { - min* { - append result "\n" - } - hour* { - append result "\n" - } - day* { - append result "\n" - } - default {#ignore} - } - - } else { - - # Value-base histogram - - set ix [lsort -integer [array names histogram]] - - set mode [expr {$counter(bucketsize) * $maxName}] - set first [expr {$counter(bucketsize) * [lindex $ix 0]}] - set last [expr {$counter(bucketsize) * [lindex $ix end]}] - - append result "" - append result "\n" - - append result "" - append result "\n" - - append result "" - append result "\n" - - append result "" - append result "\n" - - append result "" - append result "\n" - - append result "\n" - - if {$options(-max) < 0} { - set options(-max) [lindex $ix end] - } - if {![info exists options(-min)]} { - set options(-min) [lindex $ix 0] - } - } - - # End table nested inside left-hand column - - append result
[html::font]$options(-title)
[html::font]Total[html::font][format $options(-format) $counter(total)]
[html::font]Bucket Size[html::font]$string
[html::font]Max Per Sec[html::font][format %.2f [expr {$max/double($secsForMax)}]]
[html::font]Best Per Sec[html::font][format %.2f $periodMax]
[html::font]Starting Time[html::font][clock format $time \ - -format %k:%M:%S]
[html::font][clock format $time \ - -format %k:%M:%S]
[html::font][clock format $time \ - -format "%b %d %k:%M"]
[html::font]Average[html::font][format $options(-format) [counter::get $tag -avg]]
[html::font]Mode[html::font]$mode
[html::font]Minimum[html::font]$first
[html::font]Maxmum[html::font]$last
[html::font]Unit[html::font]$unit
[html::font]" - append result "Reset
\n - append result 		\n" - - - # Display the histogram - - if {$options(-text)} { - } else { - append result [eval \ - {counter::histHtmlDisplayBarChart $tag histogram $max $curIndex $time} \ - [array get options]] - } - - # Close the right hand column, but leave our caller's table open. - - append result
\n" - - set ix [lsort -integer [array names histogram]] - - for {set t $options(-min)} {$t < $options(-max)} {incr t} { - if {![info exists histogram($t)]} { - set value 0 - } else { - set value $histogram($t) - } - if {$max == 0 || $value == 0} { - set height 1 - } else { - set percent [expr {round($value * 100.0 / $max)}] - set height [expr {$percent * $options(-height) / 100}] - } - if {$t == $curIndex} { - set img src=$options(-images)/$options(-ongif) - } else { - set img src=$options(-images)/$options(-gif) - } - append result "\n" - } - append result "" - - # Count buckets outside the range requested - - set overflow 0 - set underflow 0 - foreach t [lsort -integer [array names histogram]] { - if {($options(-max) > 0) && ($t > $options(-max))} { - incr overflow - } - if {($options(-min) >= 0) && ($t < $options(-min))} { - incr underflow - } - } - - # Append a row of labels at the bottom. - - set colors {black #CCCCCC} - set bgcolors {#CCCCCC black} - set colori 0 - if {$counter(type) != "-timehist"} { - - # Label each bucket with its value - # This is probably wrong for hist2x and hist10x - - append result "" - set skip $options(-skip) - if {![info exists counter(mult)]} { - set counter(mult) 1 - } - - # These are tick marks - - set img src=$options(-images)/$options(-gif) - append result "" - for {set i $options(-min)} {$i < $options(-max)} {incr i} { - if {(($i % $skip) == 0)} { - append result "\n" - } else { - append result "" - } - } - append result - - # These are the labels - - append result "" - for {set i $options(-min)} {$i < $options(-max)} {incr i} { - if {$counter(type) == "-histlog"} { - if {[catch {expr {int(log($i) * $counter(bucketsize))}} x]} { - # Out-of-bounds - break - } - } else { - set x [expr {$i * $counter(bucketsize) * $counter(mult)}] - } - set label [format $options(-format) $x] - if {(($i % $skip) == 0)} { - set color [lindex $colors $colori] - set bg [lindex $bgcolors $colori] - set colori [expr {($colori+1) % 2}] - append result "" - } - } - append result - } else { - switch -glob -- $options(-unit) { - min* { - if {$secsPerMinute != 60} { - set format %k:%M:%S - set skip 12 - } else { - set format %k:%M - set skip 4 - } - set deltaT $secsPerMinute - set wrapDeltaT [expr {$secsPerMinute * -59}] - } - hour* { - if {$secsPerMinute != 60} { - set format %k:%M - set skip 4 - } else { - set format %k - set skip 2 - } - set deltaT [expr {$secsPerMinute * 60}] - set wrapDeltaT [expr {$secsPerMinute * 60 * -23}] - } - day* { - if {$secsPerMinute != 60} { - set format "%m/%d %k:%M" - set skip 10 - } else { - set format %k - set skip $options(-skip) - } - set deltaT [expr {$secsPerMinute * 60 * 24}] - set wrapDeltaT 0 - } - default {#ignore} - } - # These are tick marks - - set img src=$options(-images)/$options(-gif) - append result "" - foreach t [lsort -integer [array names histogram]] { - if {(($t % $skip) == 0)} { - append result "\n" - } else { - append result "" - } - } - append result - - set lastLabel "" - append result "" - foreach t [lsort -integer [array names histogram]] { - - # Label each bucket with its time - - set label [clock format $time -format $format] - if {(($t % $skip) == 0) && ($label != $lastLabel)} { - set color [lindex $colors $colori] - set bg [lindex $bgcolors $colori] - set colori [expr {($colori+1) % 2}] - append result "" - set lastLabel $label - } - if {$t == $curIndex} { - incr time $wrapDeltaT - } else { - incr time $deltaT - } - } - append result \n - } - append result "
$value
$label
$label
" - if {$underflow > 0} { - append result "
Skipped $underflow samples <\ - [expr {$options(-min) * $counter(bucketsize)}]\n" - } - if {$overflow > 0} { - append result "
Skipped $overflow samples >\ - [expr {$options(-max) * $counter(bucketsize)}]\n" - } - return $result -} - -# ::counter::start -- -# -# Start an interval timer. This should be pre-declared with -# type either -hist, -hist2x, or -hist20x -# -# Arguments: -# tag The counter identifier. -# instance There may be multiple intervals outstanding -# at any time. This serves to distinquish them. -# -# Results: -# None -# -# Side Effects: -# Records the starting time for the instance of this interval. - -proc ::counter::start {tag instance} { - upvar #0 counter::Time-$tag time - set time($instance) [list [clock clicks] \ - [clock seconds]] -} - -# ::counter::stop -- -# -# Record an interval timer. -# -# Arguments: -# tag The counter identifier. -# instance There may be multiple intervals outstanding -# at any time. This serves to distinquish them. -# func An optional function used to massage the time -# stamp before putting into the histogram. -# -# Results: -# None -# -# Side Effects: -# Computes the current interval and adds it to the histogram. - -proc ::counter::stop {tag instance {func ::counter::Identity}} { - upvar #0 counter::Time-$tag time - - if {![info exists time($instance)]} { - # Extra call. Ignore so we can debug error cases. - return - } - set now [list [clock clicks] \ - [clock seconds]] - set delMicros [expr {[lindex $now 0] - [lindex $time($instance) 0]}] - set delSecond [expr {[lindex $now 1] - [lindex $time($instance) 1]}] - unset time($instance) - - if {$delMicros < 0} { - set delMicros [expr {1000000 + $delMicros}] - incr delSecond -1 - if {$delSecond < 0} { - set delSecond 0 - } - } - counter::count $tag [$func $delSecond.[format %06d $delMicros]] -} - -# ::counter::Identity -- -# -# Return its argument. This is used as the default function -# to apply to an interval timer. -# -# Arguments: -# x Some value. -# -# Results: -# $x -# -# Side Effects: -# None - - -proc ::counter::Identity {x} { - return $x -} - -package provide counter 2.0.1 - DELETED modules/counter/counter.test Index: modules/counter/counter.test ================================================================== --- modules/counter/counter.test +++ /dev/null @@ -1,217 +0,0 @@ -# Tests for the counter module. -# -# This file contains a collection of tests for a module in the -# Standard Tcl Library. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 1998-2000 by Ajuba Solutions. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: counter.test,v 1.4 2001/08/02 16:38:06 andreas_kupries Exp $ - -package require tcltest -namespace import -force ::tcltest::* - -catch {namespace delete counter} - -proc Stamp {tag} { - puts stderr "[clock format [clock seconds]] [clock clicks -milliseconds] $tag" -} - -set myFile [file join [file dirname [info script]] counter.tcl] -source $myFile -package require counter 2.0 - -test counter-1.1 {counter::init} { - catch {counter::init} err -} {1} - -set x 0 -puts "incr scaler [time {incr x} 100]" -set a(x) 0 -puts "incr array [time {incr a(x)} 100]" -set a(x) 0 -set a(n) 0 -puts "rawcount [time { - set a(x) [expr {$a(x) + 2.4}] - incr a(n) -} 100]" - -test counter-simple {counter::count} { - counter::init simple - counter::count simple - counter::count simple - counter::count simple - counter::get simple -} {3} -puts "simple [time {counter::count simple} 100]" - -test counter-avg {counter::count} { - counter::init avg - counter::count avg 2.2 - counter::count avg 3.3 - counter::count avg 9.8 - counter::get avg -avg -} {5.1} - -test counter-avg {counter::count} { - counter::init avg - counter::get avg -avg -} {0} - -test counter-lastn {averge over lastn} { - counter::init lastn -lastn 4 - counter::count lastn 2.2 - counter::count lastn 4.6 - counter::get lastn -avgn -} {3.4} - -test counter-lastn {averge over lastn} { - counter::init lastn -lastn 4 - counter::count lastn 2.2 - counter::count lastn 3.3 - counter::count lastn 8.6 - counter::count lastn 4.1 - counter::count lastn 6.9 - counter::count lastn 0.4 - counter::get lastn -avgn -} {5.0} -puts "lastn [time {counter::count lastn 2.4} 100]" - -test counter-lastn {lifetime average} { - counter::init lastn -lastn 4 - counter::count lastn 2.2 - counter::count lastn 3.3 - counter::count lastn 8.6 - counter::count lastn 4.1 - counter::count lastn 6.9 - counter::count lastn 0.4 - counter::get lastn -avg -} {4.25} -puts "lastn [time {counter::count lastn 2.4} 100]" - -test counter-hist {basic histogram} { - counter::init hist -hist 10 - counter::count hist 2.2 - counter::count hist 18.6 - counter::count hist 14.1 - counter::count hist 26.9 - counter::count hist 20.4 - counter::count hist 23.3 - counter::count hist 53.3 - counter::get hist -hist -} {0 1 1 2 2 3 5 1} -test counter-hist {histogram average} { - counter::init hist -hist 10 - counter::count hist 2.2 - counter::count hist 18.6 - counter::count hist 14.1 - counter::count hist 26.9 - counter::count hist 20.4 - counter::count hist 23.3 - counter::count hist 53.3 - counter::get hist -avg -} {22.6857142857} -puts "hist [time {counter::count hist 2.4} 100]" - -test counter-hist2x {counter::count} { - counter::init hist -hist2x 10 - counter::count hist 8 - counter::count hist 18 - counter::count hist 28 - counter::count hist 38 - counter::count hist 48 - counter::count hist 58 - counter::count hist 68 - counter::count hist 78 - counter::count hist 178 - counter::count hist 478 - counter::get hist -hist -} {0 1 1 1 2 2 3 4 5 1 6 1} -puts "hist2x [time {counter::count hist 50} 100]" - -test counter-hist10x {counter::count} { - counter::init hist -hist10x 10 - counter::count hist 8 - counter::count hist 18 - counter::count hist 28 - counter::count hist 38 - counter::count hist 48 - counter::count hist 58 - counter::count hist 68 - counter::count hist 78 - counter::count hist 178 - counter::count hist 478 - counter::count hist 1478 - counter::count hist 1478000 - counter::get hist -hist -} {0 1 1 7 2 2 3 1 6 1} - -test counter-histlog {counter::count} { - counter::init histlog -histlog 1 - counter::count histlog 0.1 - counter::count histlog 0.5 - counter::count histlog 0.9 - counter::count histlog 1.0 - counter::count histlog 2 - counter::count histlog 3 - counter::count histlog 5 - counter::count histlog 10 - counter::count histlog 30 - counter::count histlog 50 - counter::count histlog 100 - counter::count histlog 300 - counter::count histlog 500 - counter::count histlog 1000 - counter::get histlog -hist -} {-2 1 0 4 1 2 2 1 3 2 4 1 5 1 6 2} - -test counter-timehist {counter::count} { - counter::init hits -timehist 4 - catch {puts stderr "Pausing during timehist tests"} - counter::count hits 2 - # We need to reach in and find out what bucket was used - array set info [counter::get hits -all] - set min0 $info(lastMinute) - after [expr 4000] - counter::count hits 4 - after [expr 4000] - counter::count hits 8 - set result [list] - foreach {n v} [counter::get hits -hist] { - if {$v > 0} { - lappend result [expr {$n - $min0}] $v - } - } - set result -} {0 2 1 4 2 8} - -puts "timehist [time {counter::count hits} 100]" - -test counter-countNames {counter::names} { - counter::init simple - counter::init avg - counter::init lastn -lastn 4 - counter::init hist -hist 10 - counter::init histlog -histlog 1 - counter::init hits -timehist 4 - lsort [counter::names] -} {avg hist histlog hits lastn simple} - -test counter-countExists {counter::exists} { - counter::init simple - counter::init lastn -lastn 4 - unset counter::T-lastn - list [counter::exists simple] [counter::exists lastn] -} {1 0} - -test counter-countReset {counter::reset} { - counter::init simple - counter::count simple 1 - counter::count simple 1 - counter::count simple 1 - counter::reset simple - counter::get simple -} {0} DELETED modules/counter/pkgIndex.tcl Index: modules/counter/pkgIndex.tcl ================================================================== --- modules/counter/pkgIndex.tcl +++ /dev/null @@ -1,12 +0,0 @@ -# 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. - -if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded counter 2.0.1 [list source [file join $dir counter.tcl]] DELETED modules/crc/ChangeLog Index: modules/crc/ChangeLog ================================================================== --- modules/crc/ChangeLog +++ /dev/null @@ -1,90 +0,0 @@ -2003-04-02 Pat Thoyts - - * crc32.test: Fix for bug #709375 - test failures for bigEndian - systems when using Trf crc-zlib. - * crc32bugs.test: Additional test file used to isolate byte - ordering problems. - -2003-02-11 Pat Thoyts - - * crc32.man, cksum.man, crc16.man, crc32.man: Added the new - copyright markup to the doctools pages. - * crc32.tcl: Enforce 32 bit calculations. - -2003-02-02 Pat Thoyts - - * crc16.tcl: Fixed a bug in the option handling error info. - -2003-01-25 Pat Thoyts - - * crc32.tcl: - * cksum.tcl: - * crc16.tcl: - * sum.tcl: Added tcl package requirement for 8.2+ and hiked - versions to 1.0.1 - -2003-01-16 Andreas Kupries - - * crc32.man: More semantic markup, less visual one. - * cksum.man: - * sum.man: - -2003-01-07 Pat Thoyts - - * crc32.test: Fixed another 8.3 - 8.4 wide integer problem. - -2003-01-06 Pat Thoyts - - * crc16.tcl: Fix for bug #620612: the crc16 CRC calculation failed - for 32 bit CRC widths for tcl < 8.4. Masked off high bits after shift - -2003-01-03 Pat Thoyts - - * cksum.tcl: Enabled processing in chunks to reduce memory - consumption. - -2002-09-26 Pat Thoyts - - * crc32.tcl: Fix to SF bug #579026: implementing file processing - in small chunks to reduce memory usage. - -2002-01-23 Pat Thoyts - - * crc16.tcl, crc16.test, crc16.man: Added CRC16 package - -2002-01-23 Pat Thoyts - - * crc32.test, sum.test, cksum.test: Fixed SF bug #507242: failing - tests when running 'make test' - -2002-01-17 Pat Thoyts - - * crc32.n: formatting fixes - * sum.n: added new manual page for package sum - -2002-01-16 Pat Thoyts - - * crc32.tcl: added -seed and -implementation options. - * crc32.n: updated for the -seed and -impl options - * crc32.test: added tests for the -seed and -impl options. - -2002-01-15 Pat Thoyts - - * sum.tcl: initial version of crc::sum command - * sum.test: initial version of crc::sum command tests - * cksum.tcl: intial version of crc::cksum command - * cksum.n: initial version of crc::cksum manual page - * cksum.test: initial version of crc::cksum command tests - * crc32.tcl: compatability with sum and cksum commands - * crc32.test: compatability with sum and cksum tests - * crc32.n: compatability with sum and cksum manuals - -2002-01-11 Pat Thoyts - - * crc32.tcl: implemented usage of Trf crc-zlib if available. - -2002-01-09 Pat Thoyts - - * crc32.tcl: initial version modified from the Wiki source. - * crc32.n: initial version of man page - * crc32.test: initial version of crc32 tests. DELETED modules/crc/cksum.man Index: modules/crc/cksum.man ================================================================== --- modules/crc/cksum.man +++ /dev/null @@ -1,68 +0,0 @@ -[manpage_begin cksum n 1.0.1] -[copyright {2002, Pat Thoyts}] -[moddesc {cksum}] -[titledesc {calculate a cksum(1) compatible checksum}] -[require Tcl 8.2] -[require cksum [opt 1.0.1]] -[description] -[para] - -This package provides a Tcl-only implementation of the cksum(1) -algorithm based upon information provided at in the GNU implementation -of this program as part of the GNU Textutils 2.0 package. - -[section COMMANDS] - -[list_begin definitions] - -[call [cmd ::crc::cksum] [opt "-format [arg format]"] [arg message]] -[call [cmd ::crc::cksum] [opt "-format [arg format]"] "-filename [arg file]"] - -The command takes string data or a file name and returns a checksum -value calculated using the [syscmd cksum(1)] algorithm. The result is -formatted using the [arg format](n) specifier provided or as an -unsigned integer (%u) by default. - -[list_end] - -[section OPTIONS] - -[list_begin definitions] - -[lst_item "-filename [arg name]"] - -Return a checksum for the file contents instead of for parameter data. - -[lst_item "-format [arg string]"] - -Return the checksum using an alternative format template. - -[list_end] - -[section EXAMPLES] - -[para] -[example { -% crc::cksum "Hello, World!" -2609532967 -}] - -[para] -[example { -% crc::cksum -format 0x%X "Hello, World!" -0x9B8A5027 -}] - -[para] -[example { -% crc::cksum -file cksum.tcl -1828321145 -}] - -[see_also sum(n) crc32(n)] -[section AUTHORS] -Pat Thoyts - -[keywords cksum checksum crc crc32 {cyclic redundancy check} {data integrity} security] -[manpage_end] - DELETED modules/crc/cksum.n Index: modules/crc/cksum.n ================================================================== --- modules/crc/cksum.n +++ /dev/null @@ -1,67 +0,0 @@ -'\" -'\" Generated from file 'cksum.man' by tcllib/doctools with format 'nroff' -'\" Copyright (c) 2002, Pat Thoyts -'\" -.so man.macros -.TH "cksum" n 1.0.1 "cksum" -.BS -.SH "NAME" -cksum \- calculate a cksum(1) compatible checksum -.SH "SYNOPSIS" -package require \fBTcl 8.2\fR -.sp -package require \fBcksum ?1.0.1?\fR -.sp -\fB::crc::cksum\fR ?-format \fIformat\fR? \fImessage\fR\fR -.sp -\fB::crc::cksum\fR ?-format \fIformat\fR? -filename \fIfile\fR\fR -.sp -.BE -.SH "DESCRIPTION" -.PP -This package provides a Tcl-only implementation of the cksum(1) -algorithm based upon information provided at in the GNU implementation -of this program as part of the GNU Textutils 2.0 package. -.SH "COMMANDS" -.TP -\fB::crc::cksum\fR ?-format \fIformat\fR? \fImessage\fR\fR -.TP -\fB::crc::cksum\fR ?-format \fIformat\fR? -filename \fIfile\fR\fR -The command takes string data or a file name and returns a checksum -value calculated using the \fBcksum(1)\fR algorithm. The result is -formatted using the \fIformat\fR(n) specifier provided or as an -unsigned integer (%u) by default. -.SH "OPTIONS" -.TP --filename \fIname\fR -Return a checksum for the file contents instead of for parameter data. -.TP --format \fIstring\fR -Return the checksum using an alternative format template. -.SH "EXAMPLES" -.PP -.nf -% crc::cksum "Hello, World!" -2609532967 -.fi -.PP -.nf -% crc::cksum -format 0x%X "Hello, World!" -0x9B8A5027 -.fi -.PP -.nf -% crc::cksum -file cksum.tcl -1828321145 -.fi -.SH "SEE ALSO" -sum(n), crc32(n) -.SH "AUTHORS" -Pat Thoyts -.SH "KEYWORDS" -cksum, checksum, crc, crc32, cyclic redundancy check, data integrity, security -.SH "COPYRIGHT" -.nf -Copyright (c) 2002, Pat Thoyts -.fi - DELETED modules/crc/cksum.tcl Index: modules/crc/cksum.tcl ================================================================== --- modules/crc/cksum.tcl +++ /dev/null @@ -1,186 +0,0 @@ -# cksum.tcl - Copyright (C) 2002 Pat Thoyts -# -# Provides a Tcl only implementation of the unix cksum(1) command. This is -# similar to the sum(1) command but the algorithm is better defined and -# standardized across multiple platforms by POSIX 1003.2/D11.2 -# -# This command has been verified against the cksum command from the GNU -# textutils package version 2.0 -# -# ------------------------------------------------------------------------- -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# ------------------------------------------------------------------------- -# $Id: cksum.tcl,v 1.3 2003/01/26 00:16:03 patthoyts Exp $ - -package require Tcl 8.2; # tcl minimum version - -namespace eval ::crc { - variable cksum_version 1.0.1 - - namespace export cksum - - variable cksum_tbl [list 0x0 \ - 0x04C11DB7 0x09823B6E 0x0D4326D9 0x130476DC 0x17C56B6B \ - 0x1A864DB2 0x1E475005 0x2608EDB8 0x22C9F00F 0x2F8AD6D6 \ - 0x2B4BCB61 0x350C9B64 0x31CD86D3 0x3C8EA00A 0x384FBDBD \ - 0x4C11DB70 0x48D0C6C7 0x4593E01E 0x4152FDA9 0x5F15ADAC \ - 0x5BD4B01B 0x569796C2 0x52568B75 0x6A1936C8 0x6ED82B7F \ - 0x639B0DA6 0x675A1011 0x791D4014 0x7DDC5DA3 0x709F7B7A \ - 0x745E66CD 0x9823B6E0 0x9CE2AB57 0x91A18D8E 0x95609039 \ - 0x8B27C03C 0x8FE6DD8B 0x82A5FB52 0x8664E6E5 0xBE2B5B58 \ - 0xBAEA46EF 0xB7A96036 0xB3687D81 0xAD2F2D84 0xA9EE3033 \ - 0xA4AD16EA 0xA06C0B5D 0xD4326D90 0xD0F37027 0xDDB056FE \ - 0xD9714B49 0xC7361B4C 0xC3F706FB 0xCEB42022 0xCA753D95 \ - 0xF23A8028 0xF6FB9D9F 0xFBB8BB46 0xFF79A6F1 0xE13EF6F4 \ - 0xE5FFEB43 0xE8BCCD9A 0xEC7DD02D 0x34867077 0x30476DC0 \ - 0x3D044B19 0x39C556AE 0x278206AB 0x23431B1C 0x2E003DC5 \ - 0x2AC12072 0x128E9DCF 0x164F8078 0x1B0CA6A1 0x1FCDBB16 \ - 0x018AEB13 0x054BF6A4 0x0808D07D 0x0CC9CDCA 0x7897AB07 \ - 0x7C56B6B0 0x71159069 0x75D48DDE 0x6B93DDDB 0x6F52C06C \ - 0x6211E6B5 0x66D0FB02 0x5E9F46BF 0x5A5E5B08 0x571D7DD1 \ - 0x53DC6066 0x4D9B3063 0x495A2DD4 0x44190B0D 0x40D816BA \ - 0xACA5C697 0xA864DB20 0xA527FDF9 0xA1E6E04E 0xBFA1B04B \ - 0xBB60ADFC 0xB6238B25 0xB2E29692 0x8AAD2B2F 0x8E6C3698 \ - 0x832F1041 0x87EE0DF6 0x99A95DF3 0x9D684044 0x902B669D \ - 0x94EA7B2A 0xE0B41DE7 0xE4750050 0xE9362689 0xEDF73B3E \ - 0xF3B06B3B 0xF771768C 0xFA325055 0xFEF34DE2 0xC6BCF05F \ - 0xC27DEDE8 0xCF3ECB31 0xCBFFD686 0xD5B88683 0xD1799B34 \ - 0xDC3ABDED 0xD8FBA05A 0x690CE0EE 0x6DCDFD59 0x608EDB80 \ - 0x644FC637 0x7A089632 0x7EC98B85 0x738AAD5C 0x774BB0EB \ - 0x4F040D56 0x4BC510E1 0x46863638 0x42472B8F 0x5C007B8A \ - 0x58C1663D 0x558240E4 0x51435D53 0x251D3B9E 0x21DC2629 \ - 0x2C9F00F0 0x285E1D47 0x36194D42 0x32D850F5 0x3F9B762C \ - 0x3B5A6B9B 0x0315D626 0x07D4CB91 0x0A97ED48 0x0E56F0FF \ - 0x1011A0FA 0x14D0BD4D 0x19939B94 0x1D528623 0xF12F560E \ - 0xF5EE4BB9 0xF8AD6D60 0xFC6C70D7 0xE22B20D2 0xE6EA3D65 \ - 0xEBA91BBC 0xEF68060B 0xD727BBB6 0xD3E6A601 0xDEA580D8 \ - 0xDA649D6F 0xC423CD6A 0xC0E2D0DD 0xCDA1F604 0xC960EBB3 \ - 0xBD3E8D7E 0xB9FF90C9 0xB4BCB610 0xB07DABA7 0xAE3AFBA2 \ - 0xAAFBE615 0xA7B8C0CC 0xA379DD7B 0x9B3660C6 0x9FF77D71 \ - 0x92B45BA8 0x9675461F 0x8832161A 0x8CF30BAD 0x81B02D74 \ - 0x857130C3 0x5D8A9099 0x594B8D2E 0x5408ABF7 0x50C9B640 \ - 0x4E8EE645 0x4A4FFBF2 0x470CDD2B 0x43CDC09C 0x7B827D21 \ - 0x7F436096 0x7200464F 0x76C15BF8 0x68860BFD 0x6C47164A \ - 0x61043093 0x65C52D24 0x119B4BE9 0x155A565E 0x18197087 \ - 0x1CD86D30 0x029F3D35 0x065E2082 0x0B1D065B 0x0FDC1BEC \ - 0x3793A651 0x3352BBE6 0x3E119D3F 0x3AD08088 0x2497D08D \ - 0x2056CD3A 0x2D15EBE3 0x29D4F654 0xC5A92679 0xC1683BCE \ - 0xCC2B1D17 0xC8EA00A0 0xD6AD50A5 0xD26C4D12 0xDF2F6BCB \ - 0xDBEE767C 0xE3A1CBC1 0xE760D676 0xEA23F0AF 0xEEE2ED18 \ - 0xF0A5BD1D 0xF464A0AA 0xF9278673 0xFDE69BC4 0x89B8FD09 \ - 0x8D79E0BE 0x803AC667 0x84FBDBD0 0x9ABC8BD5 0x9E7D9662 \ - 0x933EB0BB 0x97FFAD0C 0xAFB010B1 0xAB710D06 0xA6322BDF \ - 0xA2F33668 0xBCB4666D 0xB8757BDA 0xB5365D03 0xB1F740B4 ] -} - -# Description: -# Calculate a cksum(1) compatible 32 bit checksum for the input data. -# -# This procedure has been broken into two parts to permit working on -# a file in small sections. -# -proc ::crc::Cksum {s} { - set t 0 - set l 0 - Cksum_chunk s t l - return [Cksum_finalize t l] -} - -proc ::crc::Cksum_chunk {data_var sum_var len_var} { - variable cksum_tbl - upvar $data_var s - upvar $sum_var t - upvar $len_var l - - binary scan $s c* r - foreach {n} $r { - set t [expr {($t << 8) - ^ [lindex $cksum_tbl [expr { - (($t >> 24) \ - ^ ($n & 0xFF)) & 0xFF - }]]}] - incr l - } -} - -proc ::crc::Cksum_finalize {sum_var len_var} { - variable cksum_tbl - upvar $sum_var t - upvar $len_var l - for {set i $l} {$i > 0} {set i [expr {$i>>8}]} { - set t [expr {($t << 8) \ - ^ [lindex $cksum_tbl \ - [expr {(($t >> 24) ^ $i) & 0xFF}]]}] - } - return [expr {~$t & 0xFFFFFFFF}] -} - -# Description: -# Provide a Tcl equivalent of the unix cksum(1) command. -# Options: -# -filename name - return a checksum for the specified file. -# -format string - return the checksum using this format string. -# -chunksize size - set the chunking read size -# -proc ::crc::cksum {args} { - set filename {} - set format %u - set chunksize 10240 - while {[string match -* [lindex $args 0]]} { - switch -glob -- [lindex $args 0] { - -fi* { - set filename [lindex $args 1] - set args [lreplace $args 0 0] - } - -fo* { - set format [lindex $args 1] - set args [lreplace $args 0 0] - } - -ch* - - -bu* { - set chunksize [lindex $args 1] - set args [lreplace $args 0 0] - } - -- { - set args [lreplace $args 0 0] - break - } - default { - return -code error "bad option [lindex $args 0]:\ - must be -filename or -format" - } - } - set args [lreplace $args 0 0] - } - - if {$filename != {}} { - set cksum 0 - set cklen 0 - set f [open $filename r] - fconfigure $f -translation binary - while {![eof $f]} { - set chunk [read $f $chunksize] - Cksum_chunk chunk cksum cklen - } - close $f - set r [Cksum_finalize cksum cklen] - } else { - if {[llength $args] != 1} { - return -code error "wrong # args: should be \ - \"cksum ?-format string? -file name | data\"" - } - set r [Cksum [lindex $args 0]] - } - return [format $format $r] -} - -# ------------------------------------------------------------------------- - -package provide cksum $::crc::cksum_version - -# ------------------------------------------------------------------------- -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: DELETED modules/crc/cksum.test Index: modules/crc/cksum.test ================================================================== --- modules/crc/cksum.test +++ /dev/null @@ -1,105 +0,0 @@ -# cksum.test - Copyright (C) 2002 Pat Thoyts -# -# Tests for the Tcllib cksum command -# -# ------------------------------------------------------------------------- -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# ------------------------------------------------------------------------- -# RCS: @(#) $Id: cksum.test,v 1.2 2002/01/23 20:56:30 patthoyts Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -package require cksum - -# ------------------------------------------------------------------------- - -test cksum-1.0 {cksum with no parameters } { - catch {::crc::cksum} result - set result -} {wrong # args: should be "cksum ?-format string? -file name | data"} - -# ------------------------------------------------------------------------- - -foreach {n msg expected} { - 1 "" - "4294967295" - 2 "a" - "1220704766" - 3 "abc" - "1219131554" - 4 "message digest" - "3644109718" - 5 "abcdefghijklmnopqrstuvwxyz" - "2713270184" - 6 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" - "81918263" - 7 "12345678901234567890123456789012345678901234567890123456789012345678901234567890" - "1939911592" - 8 "\uFFFE\u0000\u0001\u0002" - "893385333" -} { - test cksum-2.$n {cksum and unsigned integer} { - ::crc::cksum $msg - } $expected -} - -# ------------------------------------------------------------------------- - -foreach {n msg expected} { - 1 "" - "0xFFFFFFFF" - 2 "a" - "0x48C279FE" - 3 "abc" - "0x48AA78A2" - 4 "message digest" - "0xD934B396" - 5 "abcdefghijklmnopqrstuvwxyz" - "0xA1B937A8" - 6 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" - "0x4E1F937" - 7 "12345678901234567890123456789012345678901234567890123456789012345678901234567890" - "0x73A0B3A8" - 8 "\uFFFE\u0000\u0001\u0002" - "0x353FFA75" -} { - test cksum-3.$n {cksum as hexadecimal string} { - ::crc::cksum -format 0x%X $msg - } $expected -} - -# ------------------------------------------------------------------------- - -set crc::testfile [info script] - -proc crc::loaddata {filename} { - set f [open $filename r] - fconfigure $f -translation binary - set data [read $f] - close $f - return $data -} - -test cksum-4.0 {cksum file option} { - set r1 [crc::cksum -file $crc::testfile] - set r2 [crc::cksum [crc::loaddata $crc::testfile]] - if {$r1 != $r2} { - set r "differing results: $r1 != $r2" - } else { - set r ok - } -} {ok} - -# ------------------------------------------------------------------------- - -catch {unset crc::testfile} -::tcltest::cleanupTests - -# Local Variables: -# mode: tcl -# indent-tabs-mode: nil -# End: DELETED modules/crc/crc16.man Index: modules/crc/crc16.man ================================================================== --- modules/crc/crc16.man +++ /dev/null @@ -1,100 +0,0 @@ -[manpage_begin crc16 n 1.0.1] -[copyright {2002, Pat Thoyts}] -[moddesc {Cyclic Redundancy Check (crc16)}] -[titledesc {Perform a 16bit Cyclic Redundancy Check}] -[require Tcl 8.2] -[require crc16 [opt 1.0.1]] -[description] -[para] - -This package provides a Tcl-only implementation of the CRC -algorithms based upon information provided at -http://www.microconsultants.com/tips/crc/crc.txt - -There are a number of permutations available for calculating CRC -checksums and this package can handle all of them. Defaults are set up -for the most common cases. - -[section COMMANDS] - -[list_begin definitions] - -[call [cmd ::crc::crc16] [opt "-format [arg format]"] [opt "-seed [arg value]"] [opt "-implementation [arg procname]"] [arg message]] -[call [cmd ::crc::crc16] [opt "-format [arg format]"] [opt "-seed [arg value]"] [opt "-implementation [arg procname]"] "-filename [arg file]"] -[call [cmd ::crc::crc-ccitt] [opt "-format [arg format]"] [opt "-seed [arg value]"] [opt "-implementation [arg procname]"] [arg message]] -[call [cmd ::crc::crc-ccitt] [opt "-format [arg format]"] [opt "-seed [arg value]"] [opt "-implementation [arg procname]"] "-filename [arg file]"] - -The command takes string data or a file name and returns a checksum -value calculated using the CRC algorithm. The command used sets up the -CRC polynomial, initial value and bit ordering for the desired -standard checksum calculation. The result is formatted -using the [arg format](n) specifier provided or as an unsigned integer -(%u) by default. - -[list_end] - -[section OPTIONS] - -[list_begin definitions] - -[lst_item "-filename [arg name]"] - -Return a checksum for the file contents instead of for parameter data. - -[lst_item "-format [arg string]"] - -Return the checksum using an alternative format template. - -[lst_item "-seed [arg value]"] - -Select an alternative seed value for the CRC calculation. The default -is 0 for the CRC16 calculation and 0xFFFF for the CCITT version. -This can be useful for calculating the CRC for data -structures without first converting the whole structure into a -string. The CRC of the previous member can be used as the seed for -calculating the CRC of the next member. It is also used for -accumulating a checksum from fragments of a large message (or file) - -[lst_item "-implementation [arg procname]"] - -This hook is provided to allow users to provide their own -implementation (perhaps a C compiled extension). The -procedure specfied is called with two parameters. The first is the -data to be checksummed and the second is the seed value. An -integer is expected as the result. - -[list_end] - -[section EXAMPLES] - -[para] -[example { -% crc::crc16 "Hello, World!" -64077 -}] - -[para] -[example { -% crc::crc-ccitt "Hello, World!" -26586 -}] - -[para] -[example { -% crc::crc16 -format 0x%X "Hello, World!" -0xFA4D -}] - -[para] -[example { -% crc::crc16 -file crc16.tcl -51675 -}] - -[see_also sum(n) cksum(n) crc32(n)] -[section AUTHORS] -Pat Thoyts - -[keywords cksum checksum crc crc32 crc16 {cyclic redundancy check} {data integrity} security] -[manpage_end] - DELETED modules/crc/crc16.tcl Index: modules/crc/crc16.tcl ================================================================== --- modules/crc/crc16.tcl +++ /dev/null @@ -1,267 +0,0 @@ -# crc16.tcl -- Copyright (C) 2002 Pat Thoyts -# -# Cyclic Redundancy Check - this is a Tcl implementation of a general -# table-driven CRC implementation. This code should be able to generate -# the lookup table and implement the correct algorithm for most types -# of CRC. CRC-16, CRC-32 and the CITT version of CRC-16. -# -# See http://www.microconsultants.com/tips/crc/crc.txt for the reference -# implementation and http://www.embedded.com/internet/0001/0001connect.htm -# for another good discussion of why things are the way they are. -# -# Checks: a crc for the string "123456789" should give: -# CRC16: 0xBB3D -# CRC-CCITT: 0x29B1 -# CRC-32: 0xCBF43926 -# -# eg: crc::crc16 "123456789" -# crc::crc-ccitt "123456789" -# or crc::crc16 -file tclsh.exe -# -# -# ------------------------------------------------------------------------- -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# ------------------------------------------------------------------------- -# $Id: crc16.tcl,v 1.5 2003/02/02 21:57:21 patthoyts Exp $ - -package require Tcl 8.2; # tcl minimum version - -namespace eval ::crc { - - namespace export crc16 crc-ccitt crc-32 - - variable version_crc16 1.0.1 - - # Standard CRC generator polynomials. - variable polynomial - set polynomial(crc16) [expr {(1<<16) | (1<<15) | (1<<2) | 1}] - set polynomial(citt) [expr {(1<<16) | (1<<12) | (1<<5) | 1}] - set polynomial(crc32) [expr {(1<<32) | (1<<26) | (1<<23) | (1<<22) - | (1<<16) | (1<<12) | (1<<11) | (1<<10) - | (1<<8) | (1<<7) | (1<<5) | (1<<4) - | (1<<2) | (1<<1) | 1}] - - # Array to hold the generated tables - variable table - if {![info exists table]} { array set table {}} - - # calculate the sign bit for the current platform. - variable signbit - if {![info exists signbit]} { - for {set v 1} {$v != 0} {set signbit $v; set v [expr {$v<<1}]} {} - } -} - -# ------------------------------------------------------------------------- -# Generate a CRC lookup table. -# This creates a CRC algorithm lookup lable for a 'width' bits checksum -# using the 'poly' polynomial for all values of an input byte. -# Setting 'reflected' changes the bit order for input bytes. -# Returns a list or 255 elements. -# -# CRC-32: Crc_table 32 $crc::polynomial(crc32) 1 -# CRC-16: Crc_table 16 $crc::polynomial(crc16) 1 -# CRC16/CITT: Crc_table 16 $crc::polynomial(citt) 0 -# -proc ::crc::Crc_table {width poly reflected} { - set tbl {} - if {$width < 32} { - set mask [expr {(1 << $width) - 1}] - set topbit [expr {1 << ($width - 1)}] - } else { - set mask 0xffffffff - set topbit 0x80000000 - } - - for {set i 0} {$i < 256} {incr i} { - if {$reflected} { - set r [reflect $i 8] - } else { - set r $i - } - set r [expr {$r << ($width - 8)}] - for {set k 0} {$k < 8} {incr k} { - if {[expr {$r & $topbit}] != 0} { - set r [expr {($r << 1) ^ $poly}] - } else { - set r [expr {$r << 1}] - } - } - if {$reflected} { - set r [reflect $r $width] - } - lappend tbl [expr {$r & $mask}] - } - return $tbl -} - -# ------------------------------------------------------------------------- -# Calculate the CRC checksum for the data in 's' using a precalculated -# table. -# s the input data -# width - the width in bits of the CRC algorithm -# table - the name of the variable holding the calculated table -# init - the start value (or the last CRC for sequential blocks) -# xorout - the final value may be XORd with this value -# reflected - a boolean indicating that the bit order is reversed. -# For hardware optimised CRC checks, the bits are handled -# in transmission order (ie: bit0, bit1, ..., bit7) -proc ::crc::Crc {s width table {init 0} {xorout 0} {reflected 0}} { - upvar $table tbl - variable signbit - set signmask [expr {~$signbit>>7}] - - if {$width < 32} { - set mask [expr {(1 << $width) - 1}] - set rot [expr {$width - 8}] - } else { - set mask 0xffffffff - set rot 24 - } - - set crc $init - binary scan $s c* data - foreach {datum} $data { - if {$reflected} { - set ndx [expr {($crc ^ $datum) & 0xFF}] - set lkp [lindex $tbl $ndx] - set crc [expr {($lkp ^ ($crc >> 8 & $signmask)) & $mask}] - } else { - set ndx [expr {(($crc >> $rot) ^ $datum) & 0xFF}] - set lkp [lindex $tbl $ndx] - set crc [expr {($lkp ^ ($crc << 8 & $signmask)) & $mask}] - } - } - - return [expr {$crc ^ $xorout}] -} - -# ------------------------------------------------------------------------- -# Reverse the bit ordering for 'b' bits of the input value 'v' -proc ::crc::reflect {v b} { - set t $v - for {set i 0} {$i < $b} {incr i} { - set v [expr {($t & 1) ? ($v | (1<<(($b-1)-$i))) : ($v & ~(1<<(($b-1)-$i))) }] - set t [expr {$t >> 1}] - } - return $v -} - -# ------------------------------------------------------------------------- -# Description: -# Pop the nth element off a list. Used in options processing. -# -proc ::crc::Pop {varname {nth 0}} { - upvar $varname args - set r [lindex $args $nth] - set args [lreplace $args $nth $nth] - return $r -} - -# ------------------------------------------------------------------------- -# Specialisation of the general crc procedure to perform the standard CRC16 -# checksum -proc ::crc::CRC16 {s {seed 0}} { - variable table - if {![info exists table(crc16)]} { - variable polynomial - set table(crc16) [Crc_table 16 $polynomial(crc16) 1] - } - - return [Crc $s 16 [namespace current]::table(crc16) $seed 0 1] -} - -# ------------------------------------------------------------------------- -# Specialisation of the general crc procedure to perform the CCITT telecoms -# flavour of the CRC16 checksum -proc ::crc::CRC-CCITT {s {seed 0xFFFF}} { - variable table - if {![info exists table(citt)]} { - variable polynomial - set table(citt) [Crc_table 16 $polynomial(citt) 0] - } - - return [Crc $s 16 [namespace current]::table(citt) $seed 0 0] -} - -# ------------------------------------------------------------------------- -# Demostrates the parameters used for the 32 bit checksum CRC-32. -# This can be used to show the algorithm is working right by comparison with -# other crc32 implementations -proc ::crc::CRC-32 {s {seed 0xFFFFFFFF}} { - variable table - if {![info exists table(crc32)]} { - variable polynomial - set table(crc32) [Crc_table 32 $polynomial(crc32) 1] - } - - return [Crc $s 32 [namespace current]::table(crc32) $seed 0xFFFFFFFF 1] -} - -# ------------------------------------------------------------------------- -# User level CRC command. -proc ::crc::crc {args} { - array set opts [list filename {} format %u seed 0 impl [namespace origin CRC16]] - - while {[string match -* [set option [lindex $args 0]]]} { - switch -glob -- $option { - -fi* { set opts(filename) [Pop args 1] } - -fo* { set opts(format) [Pop args 1] } - -i* { set opts(impl) [uplevel 1 namespace origin [Pop args 1]] } - -s* { set opts(seed) [Pop args 1] } - -- { Pop args ; break } - default { - set options [join [lsort [array names opts]] ", -"] - return -code error "bad option $option:\ - must be one of -$options" - } - } - Pop args - } - - if {$opts(filename) != {}} { - set r $opts(seed) - set f [open $opts(filename) r] - fconfigure $f -translation binary - while {![eof $f]} { - set chunk [read $f 4096] - set r [$opts(impl) $chunk $r] - } - close $f - } else { - if {[llength $args] != 1} { - return -code error "wrong \# args: should be\ - \"crc16 ?-format string? ?-seed value? ?-impl procname?\ - -file name | data\"" - } - set r [$opts(impl) [lindex $args 0] $opts(seed)] - } - return [format $opts(format) $r] -} - -# ------------------------------------------------------------------------- -# The user commands. See 'crc' -# -proc ::crc::crc16 {args} { - return [eval crc -impl [namespace origin CRC16] $args] -} - -proc ::crc::crc-ccitt {args} { - return [eval crc -impl [namespace origin CRC-CCITT] -seed 0xFFFF $args] -} - -proc ::crc::crc-32 {args} { - return [eval crc -impl [namespace origin CRC-32] -seed 0xFFFFFFFF $args] -} - -# ------------------------------------------------------------------------- - -package provide crc16 $crc::version_crc16 - -# ------------------------------------------------------------------------- -# -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: DELETED modules/crc/crc16.test Index: modules/crc/crc16.test ================================================================== --- modules/crc/crc16.test +++ /dev/null @@ -1,146 +0,0 @@ -# crc16.test - Copyright (C) 2002 Pat Thoyts -# -# Tests for the crc16 commands -# -# ------------------------------------------------------------------------- -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# ------------------------------------------------------------------------- -# RCS: @(#) $Id: crc16.test,v 1.1 2002/09/25 23:43:58 patthoyts Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -package require crc16 - -# ------------------------------------------------------------------------- - -test crc16-1.0 {crc16 with no parameters } { - catch {::crc::crc16} result - string match "wrong # args: *" $result -} {1} - -# ------------------------------------------------------------------------- - -foreach {n msg expected} { - 1 "" - "0" - 2 "123456789" - "47933" - 3 "abc" - "38712" - 4 "ABC" - "17697" - 5 "This is a string" - "19524" - 8 "\uFFFE\u0000\u0001\u0002" - "47537" -} { - test crc16-2.$n {crc16 and unsigned integer} { - ::crc::crc16 $msg - } $expected -} - -# ------------------------------------------------------------------------- - -foreach {n msg expected} { - 1 "" - "0x0" - 2 "123456789" - "0xBB3D" - 3 "abc" - "0x9738" - 4 "ABC" - "0x4521" - 5 "This is a string" - "0x4C44" - 6 "\uFFFE\u0000\u0001\u0002" - "0xB9B1" -} { - test crc16-3.$n {crc16 as hexadecimal string} { - ::crc::crc16 -format 0x%X $msg - } $expected -} - -# ------------------------------------------------------------------------- - -set crc::testfile [info script] - -proc crc::loaddata {filename} { - set f [open $filename r] - fconfigure $f -translation binary - set data [read $f] - close $f - return $data -} - -test crc16-4.0 {crc16 file option} { - set r1 [::crc::crc16 -file $crc::testfile] - set r2 [::crc::crc16 [crc::loaddata $crc::testfile]] - if {$r1 != $r2} { - set r "differing results: $r1 != $r2" - } else { - set r ok - } -} {ok} - -test crc16-5.0 {crc implementation option} { - proc crc::junk {s seed} { - return 0 - } - - ::crc::crc16 -impl crc::junk {Hello, World!} -} {0} - -# ------------------------------------------------------------------------- - -foreach {n msg expected} { - 1 "" - "0xFFFF" - 2 "123456789" - "0x29B1" - 3 "abc" - "0x514A" - 4 "ABC" - "0xF508" - 5 "This is a string" - "0x4BE9" - 8 "\uFFFE\u0000\u0001\u0002" - "0xAAA4" -} { - test crc16-6.$n {crc-ccitt and unsigned integer} { - ::crc::crc-ccitt -format 0x%X $msg - } $expected -} - -# ------------------------------------------------------------------------- - -foreach {n msg expected} { - 1 "" - "0x0" - 2 "123456789" - "0xCBF43926" - 3 "abc" - "0x352441C2" - 4 "ABC" - "0xA3830348" - 5 "This is a string" - "0x876633F" - 8 "\uFFFE\u0000\u0001\u0002" - "0xB0E8EEE5" -} { - test crc16-7.$n {crc-32 from the crc16 algorithms} { - ::crc::crc-32 -format 0x%X $msg - } $expected -} -# ------------------------------------------------------------------------- - -catch {unset crc::filename} -::tcltest::cleanupTests - -# Local Variables: -# mode: tcl -# indent-tabs-mode: nil -# End: DELETED modules/crc/crc32.man Index: modules/crc/crc32.man ================================================================== --- modules/crc/crc32.man +++ /dev/null @@ -1,95 +0,0 @@ -[manpage_begin crc32 n 1.0.1] -[copyright {2002, Pat Thoyts}] -[moddesc {Cyclic Redundancy Check (crc32)}] -[titledesc {Perform a 32bit Cyclic Redundancy Check}] -[require Tcl 8.2] -[require crc32 [opt 1.0.1]] -[description] -[para] - -This package provides a Tcl-only implementation of the CRC-32 -algorithm based upon information provided at -http://www.naaccr.org/standard/crc32/document.html - -If the [package Trf] package is available then the [cmd crc-zlib] -command is used to perform the calculation. - -[section COMMANDS] - -[list_begin definitions] - -[call [cmd ::crc::crc32] [opt "-format [arg format]"] [opt "-seed [arg value]"] [opt "-implementation [arg procname]"] [arg message]] -[call [cmd ::crc::crc32] [opt "-format [arg format]"] [opt "-seed [arg value]"] [opt "-implementation [arg procname]"] "-filename [arg file]"] - -The command takes string data or a file name and returns a checksum -value calculated using the CRC-32 algorithm. The result is formatted -using the [arg format](n) specifier provided or as an unsigned integer -(%u) by default. - -[list_end] - -[section OPTIONS] - -[list_begin definitions] - -[lst_item "-filename [arg name]"] - -Return a checksum for the file contents instead of for parameter data. - -[lst_item "-format [arg string]"] - -Return the checksum using an alternative format template. - -[lst_item "-seed [arg value]"] - -Select an alternative seed value for the CRC calculation. The default -is 0xffffffff. This can be useful for calculating the CRC for data -structures without first converting the whole structure into a -string. The CRC of the previous member can be used as the seed for -calculating the CRC of the next member. - -[nl] - -Note that as the [package Trf] command [cmd crc-zlib] cannot accept a -seed value, use of this option will force the use of the Tcl only -implementation. - -[lst_item "-implementation [arg procname]"] - -This hook is provided to allow users to provide their own -implementation (perhaps a C compiled extension) or to explicitly -request use of the Tcl only implementation when [package Trf] is -installed (by setting [arg "-implementation crc::Crc32_tcl"]. The -procedure specfied is called with two parameters. The first is the -data to be checksummed and the second is the seed value. A 32bit -integer is expected as the result. - -[list_end] - -[section EXAMPLES] - -[para] -[example { -% crc::crc32 "Hello, World!" -3964322768 -}] - -[para] -[example { -% crc::crc32 -format 0x%X "Hello, World!" -0xEC4AC3D0 -}] - -[para] -[example { -% crc::crc32 -file crc32.tcl -483919716 -}] - -[see_also sum(n) cksum(n) crc16(n)] -[section AUTHORS] -Pat Thoyts - -[keywords cksum checksum crc crc32 {cyclic redundancy check} {data integrity} security] -[manpage_end] - DELETED modules/crc/crc32.n Index: modules/crc/crc32.n ================================================================== --- modules/crc/crc32.n +++ /dev/null @@ -1,99 +0,0 @@ -'\" crc32.n - Copyright (c) 2002 Pat Thoyts -'\" -'\" ------------------------------------------------------------------------- -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" ------------------------------------------------------------------------- -'\" RCS: @(#) $Id: crc32.n,v 1.5 2003/01/26 00:16:03 patthoyts Exp $ -'\" -.so man.macros -.TH "crc32" n 1.0.1 tcllib "Cyclic Redundancy Check (crc32)" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -::crc::crc32 \- Perform a 32bit Cyclic Redundancy Check -.SH "SYNOPSIS" -\fBpackage require Tcl 8.2\fR -.sp -\fBpackage require crc32 ?1.0.1?\fR -.sp -\fB::crc::crc32\fR \fI?-format string?\fR \fI?-seed value?\fR -\fI?-implementation procname?\fR \fImessage\fR -.sp -\fB::crc::crc32\fR \fI?-format string?\fR \fI?-seed value?\fR -\fI?-implementation procname?\fR \fI-filename file\fR -.sp -.BE -.SH "DESCRIPTION" -.PP -This package provides a Tcl-only implementation of the CRC-32 algorithm -based upon information provided at -http://www.naaccr.org/standard/crc32/document.html -If the Trf package is available then the crc-zlib command is used -to perform the calculation. -.SH "COMMANDS" -.TP -\fB::crc::crc32\fR \fI?-format string?\fR \fI?-seed value?\fR -\fI?-implementation procname?\fR \fImessage\fR -.br -.TP -\fB::crc::crc32\fR \fI?-format string?\fR \fI?-seed value?\fR -\fI?-implementation procname?\fR \fI-filename file\fR -The command takes string data or a file name and returns -a checksum value calculated using the CRC-32 algorithm. The result is -formatted using the \fBformat\fR(n) specifier provided or as an unsigned -integer (%u) by default. -.SH "OPTIONS" -.TP -\fI-filename name\fR -Return a checksum for the file contents instead of for parameter data. -.TP -\fI-format string\fR -Return the checksum using an alternative format template. -.TP -\fI-seed value\fR -Select an alternative seed value for the CRC calculation. The default -is 0xffffffff. This can be useful for calculating the CRC for data -structures without first converting the whole structure into a -string. The CRC of the previous member can be used as the seed for -calculating the CRC of the next member. -.sp -Note that as the Trf crc-zlib cannot accept a seed value, use of this -option will force the use of the Tcl only implementation. -.TP -\fI-implementation procname\fR -This hook is provided to allow users to provide their own -implementation (perhaps a C compiled extension) or to explicitly -request use of the Tcl only implementation when Trf is installed (by -setting \fI-impl crc::Crc32_tcl\fR. The procedure specfied is called -with two parameters. The first is the data to be checksummed and the -second is the seed value. A 32bit integer is expected as the result. -.SH "EXAMPLES" -.PP -.CS -\fB% crc::crc32 "Hello, World!"\fR -3964322768 -.CE -.PP -.CS -\fB% crc::crc32 -format 0x%X "Hello, World!"\fR -0xEC4AC3D0 -.CE -.PP -.CS -\fB% crc::crc32 -file crc32.tcl\fR -483919716 -.CE -.SH "SEE ALSO" -sum(n), cksum(n) - -.SH "AUTHORS" -Wayland Augur, Pat Thoyts - -.SH "KEYWORDS" -cksum, checksum, crc, crc32, cyclic redundancy check, data integrity, security -'\" -'\" Local Variables: -'\" mode: nroff -'\" End: - DELETED modules/crc/crc32.tcl Index: modules/crc/crc32.tcl ================================================================== --- modules/crc/crc32.tcl +++ /dev/null @@ -1,228 +0,0 @@ -# crc32.tcl -- Copyright (C) 2002 Pat Thoyts -# -# CRC32 Cyclic Redundancy Check. -# (for algorithm see http://www.rad.com/networks/1994/err_con/crc.htm) -# -# From http://mini.net/tcl/2259.tcl -# Written by Wayland Augur and Pat Thoyts. -# -# ------------------------------------------------------------------------- -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# ------------------------------------------------------------------------- -# $Id: crc32.tcl,v 1.7 2003/04/02 21:24:11 patthoyts Exp $ - -namespace eval ::crc { - variable crc32_version 1.0.1 - - namespace export crc32 - - variable crc32_tbl [list 0x00000000 0x77073096 0xEE0E612C 0x990951BA \ - 0x076DC419 0x706AF48F 0xE963A535 0x9E6495A3 \ - 0x0EDB8832 0x79DCB8A4 0xE0D5E91E 0x97D2D988 \ - 0x09B64C2B 0x7EB17CBD 0xE7B82D07 0x90BF1D91 \ - 0x1DB71064 0x6AB020F2 0xF3B97148 0x84BE41DE \ - 0x1ADAD47D 0x6DDDE4EB 0xF4D4B551 0x83D385C7 \ - 0x136C9856 0x646BA8C0 0xFD62F97A 0x8A65C9EC \ - 0x14015C4F 0x63066CD9 0xFA0F3D63 0x8D080DF5 \ - 0x3B6E20C8 0x4C69105E 0xD56041E4 0xA2677172 \ - 0x3C03E4D1 0x4B04D447 0xD20D85FD 0xA50AB56B \ - 0x35B5A8FA 0x42B2986C 0xDBBBC9D6 0xACBCF940 \ - 0x32D86CE3 0x45DF5C75 0xDCD60DCF 0xABD13D59 \ - 0x26D930AC 0x51DE003A 0xC8D75180 0xBFD06116 \ - 0x21B4F4B5 0x56B3C423 0xCFBA9599 0xB8BDA50F \ - 0x2802B89E 0x5F058808 0xC60CD9B2 0xB10BE924 \ - 0x2F6F7C87 0x58684C11 0xC1611DAB 0xB6662D3D \ - 0x76DC4190 0x01DB7106 0x98D220BC 0xEFD5102A \ - 0x71B18589 0x06B6B51F 0x9FBFE4A5 0xE8B8D433 \ - 0x7807C9A2 0x0F00F934 0x9609A88E 0xE10E9818 \ - 0x7F6A0DBB 0x086D3D2D 0x91646C97 0xE6635C01 \ - 0x6B6B51F4 0x1C6C6162 0x856530D8 0xF262004E \ - 0x6C0695ED 0x1B01A57B 0x8208F4C1 0xF50FC457 \ - 0x65B0D9C6 0x12B7E950 0x8BBEB8EA 0xFCB9887C \ - 0x62DD1DDF 0x15DA2D49 0x8CD37CF3 0xFBD44C65 \ - 0x4DB26158 0x3AB551CE 0xA3BC0074 0xD4BB30E2 \ - 0x4ADFA541 0x3DD895D7 0xA4D1C46D 0xD3D6F4FB \ - 0x4369E96A 0x346ED9FC 0xAD678846 0xDA60B8D0 \ - 0x44042D73 0x33031DE5 0xAA0A4C5F 0xDD0D7CC9 \ - 0x5005713C 0x270241AA 0xBE0B1010 0xC90C2086 \ - 0x5768B525 0x206F85B3 0xB966D409 0xCE61E49F \ - 0x5EDEF90E 0x29D9C998 0xB0D09822 0xC7D7A8B4 \ - 0x59B33D17 0x2EB40D81 0xB7BD5C3B 0xC0BA6CAD \ - 0xEDB88320 0x9ABFB3B6 0x03B6E20C 0x74B1D29A \ - 0xEAD54739 0x9DD277AF 0x04DB2615 0x73DC1683 \ - 0xE3630B12 0x94643B84 0x0D6D6A3E 0x7A6A5AA8 \ - 0xE40ECF0B 0x9309FF9D 0x0A00AE27 0x7D079EB1 \ - 0xF00F9344 0x8708A3D2 0x1E01F268 0x6906C2FE \ - 0xF762575D 0x806567CB 0x196C3671 0x6E6B06E7 \ - 0xFED41B76 0x89D32BE0 0x10DA7A5A 0x67DD4ACC \ - 0xF9B9DF6F 0x8EBEEFF9 0x17B7BE43 0x60B08ED5 \ - 0xD6D6A3E8 0xA1D1937E 0x38D8C2C4 0x4FDFF252 \ - 0xD1BB67F1 0xA6BC5767 0x3FB506DD 0x48B2364B \ - 0xD80D2BDA 0xAF0A1B4C 0x36034AF6 0x41047A60 \ - 0xDF60EFC3 0xA867DF55 0x316E8EEF 0x4669BE79 \ - 0xCB61B38C 0xBC66831A 0x256FD2A0 0x5268E236 \ - 0xCC0C7795 0xBB0B4703 0x220216B9 0x5505262F \ - 0xC5BA3BBE 0xB2BD0B28 0x2BB45A92 0x5CB36A04 \ - 0xC2D7FFA7 0xB5D0CF31 0x2CD99E8B 0x5BDEAE1D \ - 0x9B64C2B0 0xEC63F226 0x756AA39C 0x026D930A \ - 0x9C0906A9 0xEB0E363F 0x72076785 0x05005713 \ - 0x95BF4A82 0xE2B87A14 0x7BB12BAE 0x0CB61B38 \ - 0x92D28E9B 0xE5D5BE0D 0x7CDCEFB7 0x0BDBDF21 \ - 0x86D3D2D4 0xF1D4E242 0x68DDB3F8 0x1FDA836E \ - 0x81BE16CD 0xF6B9265B 0x6FB077E1 0x18B74777 \ - 0x88085AE6 0xFF0F6A70 0x66063BCA 0x11010B5C \ - 0x8F659EFF 0xF862AE69 0x616BFFD3 0x166CCF45 \ - 0xA00AE278 0xD70DD2EE 0x4E048354 0x3903B3C2 \ - 0xA7672661 0xD06016F7 0x4969474D 0x3E6E77DB \ - 0xAED16A4A 0xD9D65ADC 0x40DF0B66 0x37D83BF0 \ - 0xA9BCAE53 0xDEBB9EC5 0x47B2CF7F 0x30B5FFE9 \ - 0xBDBDF21C 0xCABAC28A 0x53B39330 0x24B4A3A6 \ - 0xBAD03605 0xCDD70693 0x54DE5729 0x23D967BF \ - 0xB3667A2E 0xC4614AB8 0x5D681B02 0x2A6F2B94 \ - 0xB40BBE37 0xC30C8EA1 0x5A05DF1B 0x2D02EF8D] - - # calculate the sign bit for the current platform. - variable signbit - if {![info exists signbit]} { - for {set v 1} {$v != 0} {set signbit $v; set v [expr {$v<<1}]} {} - } -} - -# ------------------------------------------------------------------------- - -# Description: -# Calculate the CRC-32 checksum of the input data. -# -proc ::crc::Crc32_tcl {s {seed 0xFFFFFFFF}} { - variable crc32_tbl - variable signbit - set signmask [expr {~$signbit>>7}] - set crcval $seed - - binary scan $s c* nums - foreach {n} $nums { - set ndx [expr {($crcval ^ $n) & 0xFF}] - set lkp [lindex $crc32_tbl $ndx] - set crcval [expr {($lkp ^ ($crcval >> 8 & $signmask)) & 0xFFFFFFFF}] - } - - return [expr {$crcval ^ 0xFFFFFFFF}] -} - -# Select the Trf using version if Trf is available -if {![catch {package require Trf 2.0}]} { - # Description: - # Use the Trf crc-zlib function to calculate the CRC-32 checksum - # and return the correct value according to our byte order. - # - proc ::crc::Crc32_trf {s {seed 0xFFFFFFFF}} { - if {$seed != 0xFFFFFFFF} { - return -code error "invalid option: the Trf crc32 command cannot\ - accept a seed value" - } - binary scan [crc-zlib $s] i r - return $r - } - - interp alias {} ::crc::Crc32 {} ::crc::Crc32_trf -} else { - interp alias {} ::crc::Crc32 {} ::crc::Crc32_tcl -} - -# ------------------------------------------------------------------------- - -# Description: -# Provide a Tcl implementation of a crc32 checksum similar to the cksum -# and sum unix commands. -# Options: -# -filename name - return a checksum for the specified file. -# -format string - return the checksum using this format string. -# -seed value - seed the algorithm using value (default is 0xffffffff) -# -proc ::crc::crc32 {args} { - set filename {} - set format %u - set seed 0xffffffff - set impl [namespace origin Crc32] - - while {[string match -* [lindex $args 0]]} { - switch -glob -- [lindex $args 0] { - -fi* { - set filename [lindex $args 1] - set args [lreplace $args 0 0] - } - -fo* { - set format [lindex $args 1] - set args [lreplace $args 0 0] - } - -s* { - set seed [lindex $args 1] - set args [lreplace $args 0 0] - } - -i* { - set impl [uplevel 1 namespace origin [lindex $args 1]] - set args [lreplace $args 0 0] - } - -- { - set args [lreplace $args 0 0] - break - } - default { - return -code error "bad option [lindex $args 0]:\ - must be -filename, -format, -implementation or -seed" - } - } - set args [lreplace $args 0 0] - } - - # The Trf implementation doesn't accept an alternative CRC seed so - # use the Tcl implementation if this is set (unless the user has - # set it to some other impl). - if {$seed != 0xffffffff && [string match [namespace origin Crc32] $impl]} { - set impl [namespace origin Crc32_tcl] - } - - if {$filename != {}} { - set r $seed - set f [open $filename r] - fconfigure $f -translation binary - # If we are using Trf - we cannot chunk - if {[package provide Trf] != {} \ - && [string match [namespace origin Crc32] $impl]} { - set data [read $f] - set r [$impl $data $r] - } else { - # Process the chunks. We need to undo the final xor - # to obtain the seed for the following chunk. Then re-apply - # for the final result. - while {![eof $f]} { - set data [read $f 4096] - set r [$impl $data $r] - set r [expr {$r ^ 0xFFFFFFFF}] - } - set r [expr {$r ^ 0xFFFFFFFF}] - } - close $f - } else { - if {[llength $args] != 1} { - return -code error "wrong # args: should be \ - \"crc32 ?-format string? ?-seed value? ?-impl procname?\ - -file name | data\"" - } - set r [$impl [lindex $args 0] $seed] - } - - return [format $format $r] -} - -# ------------------------------------------------------------------------- - -package provide crc32 $::crc::crc32_version - -# ------------------------------------------------------------------------- -# -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: DELETED modules/crc/crc32.test Index: modules/crc/crc32.test ================================================================== --- modules/crc/crc32.test +++ /dev/null @@ -1,142 +0,0 @@ -# crc32.test - Copyright (C) 2002 Pat Thoyts -# -# Tests for the crc32 commands -# -# ------------------------------------------------------------------------- -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# ------------------------------------------------------------------------- -# RCS: @(#) $Id: crc32.test,v 1.5 2003/01/07 00:40:03 patthoyts Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -package require crc32 - -# ------------------------------------------------------------------------- - -test crc32-1.0 {crc32 with no parameters } { - catch {::crc::crc32} result - string match "wrong # args: *" $result -} {1} - -# ------------------------------------------------------------------------- - -foreach {n msg expected} { - 1 "" - "0" - 2 "a" - "3904355907" - 3 "abc" - "891568578" - 4 "message digest" - "538287487" - 5 "abcdefghijklmnopqrstuvwxyz" - "1277644989" - 6 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" - "532866770" - 7 "12345678901234567890123456789012345678901234567890123456789012345678901234567890" - "2091469426" - 8 "\uFFFE\u0000\u0001\u0002" - "2968055525" -} { - test crc32-2.$n {crc32 and unsigned integer} { - ::crc::crc32 $msg - } $expected -} - -# ------------------------------------------------------------------------- - -foreach {n msg expected} { - 1 "" - "0x0" - 2 "a" - "0xE8B7BE43" - 3 "abc" - "0x352441C2" - 4 "message digest" - "0x20159D7F" - 5 "abcdefghijklmnopqrstuvwxyz" - "0x4C2750BD" - 6 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" - "0x1FC2E6D2" - 7 "12345678901234567890123456789012345678901234567890123456789012345678901234567890" - "0x7CA94A72" - 8 "\uFFFE\u0000\u0001\u0002" - "0xB0E8EEE5" -} { - test crc32-3.$n {crc32 as hexadecimal string} { - ::crc::crc32 -format 0x%X $msg - } $expected -} - -# ------------------------------------------------------------------------- - -set crc::testfile [info script] - -proc crc::loaddata {filename} { - set f [open $filename r] - fconfigure $f -translation binary - set data [read $f] - close $f - return $data -} - -test crc32-4.0 {crc32 file option} { - set r1 [::crc::crc32 -file $crc::testfile] - set r2 [::crc::crc32 [crc::loaddata $crc::testfile]] - if {$r1 != $r2} { - set r "differing results: $r1 != $r2" - } else { - set r ok - } -} {ok} - -foreach {n seed msg expected} { - 1 0 "" - "4294967295" - 2 1 "" - "4294967294" - 3 0 "Hello, World!" - "482441901" - 4 1 "Hello, World!" - "3243746088" -} { - test crc32-4.$n {crc32 seed option} { - ::crc::crc32 -seed $seed $msg - } $expected -} - - -if {![catch {package present Trf 2.0}]} { - test crc32-5.0 {crc32 check Tcl and Trf version identity} { - set data [crc::loaddata $crc::testfile] - set r1 [::crc::Crc32_trf $data] - set r2 [::crc::Crc32_tcl $data] - if {int($r1) != int($r2)} { - set r "differing results: $r1 != $r2" - } else { - set r ok - } - } {ok} -} - -test crc32-6.0 {crc implementation option} { - proc crc::junk {s seed} { - return 0 - } - - ::crc::crc32 -impl crc::junk {Hello, World!} -} {0} - -# ------------------------------------------------------------------------- - -catch {unset crc::filename} -::tcltest::cleanupTests - -# Local Variables: -# mode: tcl -# indent-tabs-mode: nil -# End: DELETED modules/crc/crc32bugs.test Index: modules/crc/crc32bugs.test ================================================================== --- modules/crc/crc32bugs.test +++ /dev/null @@ -1,57 +0,0 @@ -# crc32bugs.test - Copyright (C) 2002 Pat Thoyts -# -# Bug finding for crc32 module. -# In particular we are looking for byte order problems, and issues between -# the trf code and tcl-only code. -# -# ------------------------------------------------------------------------- -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# ------------------------------------------------------------------------- -# RCS: @(#) $Id: crc32bugs.test,v 1.1 2003/04/02 21:24:12 patthoyts Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -package require crc32 -package require crc16 - -if {[catch {package present Trf}]} { - puts "crc32bugs (pure Tcl) $::tcl_platform(byteOrder)" -} else { - puts "crc32bugs (Trf based) $::tcl_platform(byteOrder)" -} - -foreach {n msg expected} { - 1 "" "0" - 2 "\x00" "d202ef8d" - 3 "\x00\x00" "41d912ff" - 4 "\x00\x00\x00" "ff41d912" - 5 "\x00\x00\x00\x00" "2144df1c" - 6 "\xFF" "ff000000" - 7 "\xFF\xFF" "ffff0000" - 8 "\xFF\xFF\xFF" "ffffff00" - 9 "\xFF\xFF\xFF\xFF" "ffffffff" - 10 "\x00\x00\x00\x01" "5643ef8a" - 11 "\x80\x00\x00\x00" "cc1d6927" -} { - test crc32bugs-2.$n {crc32 (Trf and and crc-32 comparison} { - list [catch { - list \ - [::crc::crc32 -format %x $msg] \ - [format %x [::crc::Crc32_tcl $msg]] \ - [::crc::crc-32 -format %x $msg] - } msg] $msg - } [list 0 [list $expected $expected $expected]] -} - -# ------------------------------------------------------------------------- - -::tcltest::cleanupTests - -# Local Variables: -# mode: tcl -# indent-tabs-mode: nil -# End: DELETED modules/crc/pkgIndex.tcl Index: modules/crc/pkgIndex.tcl ================================================================== --- modules/crc/pkgIndex.tcl +++ /dev/null @@ -1,5 +0,0 @@ -if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded cksum 1.0.1 [list source [file join $dir cksum.tcl]] -package ifneeded crc16 1.0.1 [list source [file join $dir crc16.tcl]] -package ifneeded crc32 1.0.1 [list source [file join $dir crc32.tcl]] -package ifneeded sum 1.0.1 [list source [file join $dir sum.tcl]] DELETED modules/crc/sum.man Index: modules/crc/sum.man ================================================================== --- modules/crc/sum.man +++ /dev/null @@ -1,69 +0,0 @@ -[manpage_begin sum n 1.0.1] -[copyright {2002, Pat Thoyts}] -[moddesc {sum}] -[titledesc {calculate a sum(1) compatible checksum}] -[require Tcl 8.2] -[require sum [opt 1.0.1]] -[description] -[para] - -This package provides a Tcl-only implementation of the sum(1) command -which calculates a 16 bit checksum value from the input data. The BSD -sum algorithm is used by default but the SysV algorithm is also -available. - -[section COMMANDS] - -[list_begin definitions] - -[call [cmd ::crc::sum] [opt "-format [arg format]"] [arg message]] -[call [cmd ::crc::sum] [opt "-format [arg format]"] "-filename [arg file]"] - -The command takes string data or a file name and returns a checksum -value calculated using the [syscmd sum(1)] algorithm. The result is -formatted using the [arg format](n) specifier provided or as an -unsigned integer (%u) by default. - -[list_end] - -[section OPTIONS] - -[list_begin definitions] - -[lst_item "-filename [arg name]"] - -Return a checksum for the file contents instead of for parameter data. - -[lst_item "-format [arg string]"] - -Return the checksum using an alternative format template. - -[list_end] - -[section EXAMPLES] - -[para] -[example { -% crc::sum "Hello, World!" -37287 -}] - -[para] -[example { -% crc::sum -format 0x%X "Hello, World!" -0x91A7 -}] - -[para] -[example { -% crc::sum -file sum.tcl -13392 -}] - -[see_also sum(1) cksum(n) crc32(n)] -[section AUTHORS] -Pat Thoyts - -[keywords sum cksum checksum crc crc32 {cyclic redundancy check} {data integrity} security] -[manpage_end] - DELETED modules/crc/sum.n Index: modules/crc/sum.n ================================================================== --- modules/crc/sum.n +++ /dev/null @@ -1,68 +0,0 @@ -'\" -'\" Generated from file 'sum.man' by tcllib/doctools with format 'nroff' -'\" Copyright (c) 2002, Pat Thoyts -'\" -.so man.macros -.TH "sum" n 1.0.1 "sum" -.BS -.SH "NAME" -sum \- calculate a sum(1) compatible checksum -.SH "SYNOPSIS" -package require \fBTcl 8.2\fR -.sp -package require \fBsum ?1.0.1?\fR -.sp -\fB::crc::sum\fR ?-format \fIformat\fR? \fImessage\fR\fR -.sp -\fB::crc::sum\fR ?-format \fIformat\fR? -filename \fIfile\fR\fR -.sp -.BE -.SH "DESCRIPTION" -.PP -This package provides a Tcl-only implementation of the sum(1) command -which calculates a 16 bit checksum value from the input data. The BSD -sum algorithm is used by default but the SysV algorithm is also -available. -.SH "COMMANDS" -.TP -\fB::crc::sum\fR ?-format \fIformat\fR? \fImessage\fR\fR -.TP -\fB::crc::sum\fR ?-format \fIformat\fR? -filename \fIfile\fR\fR -The command takes string data or a file name and returns a checksum -value calculated using the \fBsum(1)\fR algorithm. The result is -formatted using the \fIformat\fR(n) specifier provided or as an -unsigned integer (%u) by default. -.SH "OPTIONS" -.TP --filename \fIname\fR -Return a checksum for the file contents instead of for parameter data. -.TP --format \fIstring\fR -Return the checksum using an alternative format template. -.SH "EXAMPLES" -.PP -.nf -% crc::sum "Hello, World!" -37287 -.fi -.PP -.nf -% crc::sum -format 0x%X "Hello, World!" -0x91A7 -.fi -.PP -.nf -% crc::sum -file sum.tcl -13392 -.fi -.SH "SEE ALSO" -sum(1), cksum(n), crc32(n) -.SH "AUTHORS" -Pat Thoyts -.SH "KEYWORDS" -sum, cksum, checksum, crc, crc32, cyclic redundancy check, data integrity, security -.SH "COPYRIGHT" -.nf -Copyright (c) 2002, Pat Thoyts -.fi - DELETED modules/crc/sum.tcl Index: modules/crc/sum.tcl ================================================================== --- modules/crc/sum.tcl +++ /dev/null @@ -1,125 +0,0 @@ -# sum.tcl - Copyright (C) 2002 Pat Thoyts -# -# Provides a Tcl only implementation of the unix sum(1) command. There are -# a number of these and they use differing algorithms to get a checksum of -# the input data. We provide two: one using the BSD algorithm and the other -# using the SysV algorithm. More consistent results across multiple -# implementations can be obtained by using cksum(1). -# -# These commands have been checked against the GNU sum program from the GNU -# textutils package version 2.0 to ensure the same results. -# -# ------------------------------------------------------------------------- -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# ------------------------------------------------------------------------- -# $Id: sum.tcl,v 1.2 2003/01/26 00:16:03 patthoyts Exp $ - -package require Tcl 8.2; # tcl minimum version - -namespace eval ::crc { - variable sum_version 1.0.1 - namespace export sum -} - -# Description: -# The SysV algorithm is fairly naive. The byte values are summed and any -# overflow is discarded. The lowest 16 bits are returned as the checksum. -# Notes: -# Input with the same content but different ordering will give the same -# result. -# This is pretty dependant on using a 32 bit accumulator. -# -proc ::crc::sum-sysv {s} { - set t 0 - binary scan $s c* r - foreach n $r { - incr t [expr {$n & 0xFF}] - } - return [expr {$t % 0xFFFF}] -} - -# Description: -# This algorithm is similar to the SysV version but includes a bit rotation -# step which provides a dependency on the order of the data values. -# Notes: -# Once again this depends upon a 32 bit accumulator. -# -proc ::crc::sum-bsd {s} { - set t 0 - binary scan $s c* r - foreach n $r { - set t [expr {($t & 1) ? (($t >> 1) + 0x8000) : ($t >> 1)}] - set t [expr {($t + ($n & 0xFF)) & 0xFFFF}] - } - return $t -} - -# Description: -# Provide a Tcl equivalent of the unix sum(1) command. We default to the -# BSD algorithm and return a checkum for the input string unless a filename -# has been provided. Using sum on a file should give the same results as -# the unix sum command with equivalent algorithm. -# Options: -# -bsd - use the BSD algorithm to calculate the checksum (default) -# -sysv - use the SysV algorithm to calculate the checksum -# -filename name - return a checksum for the specified file -# -format string - return the checksum using this format string -# -proc ::crc::sum {args} { - set algorithm [namespace current]::sum-bsd - set filename {} - set format %u - while {[string match -* [lindex $args 0]]} { - switch -glob -- [lindex $args 0] { - -b* { - set algorithm [namespace current]::sum-bsd - } - -s* { - set algorithm [namespace current]::sum-sysv - } - -fi* { - set filename [lindex $args 1] - set args [lreplace $args 0 0] - } - -fo* { - set format [lindex $args 1] - set args [lreplace $args 0 0] - } - -- { - set args [lreplace $args 0 0] - break - } - default { - return -code error "bad option [lindex $args 0]:\ - must be -bsd, -sysv, -filename or -format" - } - } - set args [lreplace $args 0 0] - } - - if {$filename != {}} { - set f [open $filename r] - fconfigure $f -translation binary - set data [read $f] - close $f - set r [$algorithm $data] - } else { - if {[llength $args] != 1} { - return -code error "wrong # args: should be \ - \"sum ?-bsd|-sysv? ?-format string? -file name | data\"" - } - set r [$algorithm [lindex $args 0]] - } - return [format $format $r] -} - -# ------------------------------------------------------------------------- - -package provide sum $::crc::sum_version - -# ------------------------------------------------------------------------- -# Local Variables: -# mode: tcl -# indent-tabs-mode: nil -# End: DELETED modules/crc/sum.test Index: modules/crc/sum.test ================================================================== --- modules/crc/sum.test +++ /dev/null @@ -1,129 +0,0 @@ -# sum.test - Copyright (C) 2002 Pat Thoyts -# -# Tests for the Tcllib sum command -# -# ------------------------------------------------------------------------- -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# ------------------------------------------------------------------------- -# RCS: @(#) $Id: sum.test,v 1.2 2002/01/23 20:56:30 patthoyts Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -package require sum - -# ------------------------------------------------------------------------- - -test sum-1.0 {sum with no parameters } { - catch {::crc::sum} result - set result -} {wrong # args: should be "sum ?-bsd|-sysv? ?-format string? -file name | data"} - -# ------------------------------------------------------------------------- - -foreach {n msg expected} { - 1 "" - "0" - 2 "a" - "97" - 3 "abc" - "16556" - 4 "cba" - "49322" - 5 "message digest" - "26423" - 6 "abcdefghijklmnopqrstuvwxyz" - "53553" - 7 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" - "25587" - 8 "12345678901234567890123456789012345678901234567890123456789012345678901234567890" - "21845" - 9 "\uFFFE\u0000\u0001\u0002" - "16418" -} { - test sum-2.$n {sum using BSD algorithm and unsigned integer} { - ::crc::sum -bsd $msg - } $expected -} - -# ------------------------------------------------------------------------- -foreach {n msg expected} { - 1 "" - "0" - 2 "a" - "97" - 3 "abc" - "294" - 4 "cba" - "294" - 5 "message digest" - "1413" - 6 "abcdefghijklmnopqrstuvwxyz" - "2847" - 7 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" - "5387" - 8 "12345678901234567890123456789012345678901234567890123456789012345678901234567890" - "4200" - 9 "\uFFFE\u0000\u0001\u0002" - "257" -} { - test sum-3.$n {sum using SysV algorithm and unsigned integer} { - ::crc::sum -sysv $msg - } $expected -} - -# ------------------------------------------------------------------------- - -set crc::testfile [info script] - -proc crc::loaddata {filename} { - set f [open $filename r] - fconfigure $f -translation binary - set data [read $f] - close $f - return $data -} - -test sum-4.0 {sum file option (BSD)} { - set r1 [crc::sum -bsd -file $crc::testfile] - set r2 [crc::sum -bsd [crc::loaddata $crc::testfile]] - if {$r1 != $r2} { - set r "differing results: $r1 != $r2" - } else { - set r ok - } -} {ok} - -test sum-4.1 {sum file option (SysV)} { - set r1 [crc::sum -sysv -file $crc::testfile] - set r2 [crc::sum -sysv [crc::loaddata $crc::testfile]] - if {$r1 != $r2} { - set r "differing results: $r1 != $r2" - } else { - set r ok - } -} {ok} - -# ------------------------------------------------------------------------- - -test sum-5.0 {sum format option (BSD)} { - crc::sum -bsd -format 0x%X [string repeat x 200] -} {0xF8EE} - -test sum-5.1 {sum format option (SysV)} { - crc::sum -sysv -format 0x%X [string repeat x 200] -} {0x5DC0} - -# ------------------------------------------------------------------------- - -catch {unset crc::testfile} -::tcltest::cleanupTests - -# Local Variables: -# mode: tcl -# indent-tabs-mode: nil -# End: - DELETED modules/csv/ChangeLog Index: modules/csv/ChangeLog ================================================================== --- modules/csv/ChangeLog +++ /dev/null @@ -1,107 +0,0 @@ -2003-03-31 Andreas Kupries - - * csv.tcl (split): Fixed bug #709123 reported by Jamie Honan - . The separator character is used - in regular epxressions, but was not protected against special - interpretation by the RE engine. - -2003-01-16 Andreas Kupries - - * csv.man: More semantic markup, less visual one. - -2002-06-24 Andreas Kupries - - * csv.tcl (csv::split): Fixed bug #565051, found by Tod A. olson - . The described bug is actually - none, given the definition of the CSV format, but the examples - do contain a related bug. Just swap what is seen as ok and - bug. Because of this the provided patched code was rejected, and - a new patch created. The patched code passes the extended - testsuite (see below). - - * csv.test: Extended testsuite regarding the handling of empty - fields and quote characters. Part of the investigation into bug - #565051. - -2002-03-25 Andreas Kupries - - * csv.man: Fixed formatting errors in the doctools manpage. - -2002-02-01 Andreas Kupries - - * Version up to 0.3 to differentiate development from the - version in the tcllib 1.2 release. - - * mem_debug_bench_a.csv: New file, contains empty lines to test - that part of the code. See below. - * csv.tcl: - * csv.test: Updated code and tests to cover all paths through the - code. - -2002-01-15 Andreas Kupries - - * Bumped version to 0.2 - -2001-11-16 Andreas Kupries - - * csv.n: Applied patch #482570 correcting a typo and adding more - cross-references (see also, keywords). Patch provided by Larry - Virden . - -2001-11-12 Andreas Kupries - - * csv.test: - * cvs.n: - * csv.tcl (split2matrix, read2matrix): Implemented FR - #481023. Added additional expansion behaviours, controlled via - an optional argument. - -2001-10-14 Jeff Hobbs - - * csv.test (csv-1.7): - * csv.tcl: Fixed [Bug #469855] where starting "s could not come - out right from csv::split. - Updated to 0.2 - -2001-09-28 Andreas Kupries - - * csv.test: Added test to verify that the problem is fixed. - - * csv.tcl (joinlist): Fixed bug [#465210] "::csv::joinlist - sepChar handling". The "sepChar" was not propagated to the - actual join operation. - -2001-09-05 Andreas Kupries - - * csv.tcl: Restricted export list to public API. - [456255]. Patch by Hemang Lavana - - -2001-07-10 Andreas Kupries - - * csv.tcl: Frink 2.2 run, fixed dubious code. - -2001-06-21 Andreas Kupries - - * csv.tcl: Fixed dubious code reported by frink and procheck. - -2001-06-19 Andreas Kupries - - * csv.n: Fixed nroff trouble. - -2001-05-01 Andreas Kupries - - * Committed to CVS head at SF. - -2001-04-18 Andreas Kupries - - * csv.tcl: Added more code to read and write CSV formatted data - from and to various datastructures (queue, matrix). The basic - functionality is now complete. - - * csv.test: Extended the testsuite to cover the new code. - * csv.n: Extended the documentation to cover the new code. - -2001-04-12 Andreas Kupries - - * New module for the processing of CSV lines and files. DELETED modules/csv/csv.man Index: modules/csv/csv.man ================================================================== --- modules/csv/csv.man +++ /dev/null @@ -1,157 +0,0 @@ -[manpage_begin csv n 0.3] -[copyright {2002 Andreas Kupries }] -[moddesc {CSV processing}] -[titledesc {Procedures to handle CSV data.}] -[require Tcl 8.3] -[require csv [opt 0.3]] -[description] - -[para] - -The [package csv] package provides commands to manipulate information -in CSV [sectref FORMAT] (CSV = Comma Separated Values). - -[section COMMANDS] -[para] - -The following commands are available: - -[list_begin definitions] - -[call [cmd ::csv::join] [arg values] "{[arg sepChar] ,}"] - -Takes a list of values and returns a string in CSV format containing -these values. The separator character can be defined by the caller, -but this is optional. The default is ",". - -[call [cmd ::csv::joinlist] [arg values] "{[arg sepChar] ,}"] - -Takes a list of lists of values and returns a string in CSV format -containing these values. The separator character can be defined by the -caller, but this is optional. The default is ",". Each element of the -outer list is considered a record, these are separated by newlines in -the result. The elements of each record are formatted as usual (via -[cmd ::csv::join]). - -[call [cmd ::csv::read2matrix] [arg "chan m"] "{[arg sepChar] ,} {[arg expand] none}"] - -A wrapper around [cmd ::csv::split2matrix] (see below) reading -CSV-formatted lines from the specified channel (until EOF) and adding -them to the given matrix. For an explanation of the [arg expand] -argument see [cmd ::csv::split2matrix]. - -[call [cmd ::csv::read2queue] [arg "chan q"] "{[arg sepChar] ,}"] - -A wrapper around [cmd ::csv::split2queue] (see below) reading -CSV-formatted lines from the specified channel (until EOF) and adding -them to the given queue. - -[call [cmd ::csv::report] [arg "cmd matrix"] [opt [arg chan]]] - -A report command which can be used by the matrix methods - -[cmd "format 2string"] and [cmd "format 2chan"]. For the latter this -command delegates the work to [cmd ::csv::writematrix]. [arg cmd] is -expected to be either [method printmatrix] or - -[method printmatrix2channel]. The channel argument, [arg chan], has -to be present for the latter and must not be present for the first. - -[call [cmd ::csv::split] [arg line] "{[arg sepChar] ,}"] - -converts a [arg line] in CSV format into a list of the values -contained in the line. The character used to separate the values from -each other can be defined by the caller, via [arg sepChar], but this -is optional. The default is ",". - -[call [cmd ::csv::split2matrix] [arg "m line"] "{[arg sepChar] ,} {[arg expand] none}"] - -The same as [cmd ::csv::split], but appends the resulting list as a -new row to the matrix [arg m], using the method [cmd "add row"]. The -expansion mode specified via [arg expand] determines how the command -handles a matrix with less columns than contained in [arg line]. The -allowed modes are: - -[list_begin definitions] - -[lst_item [const none]] - -This is the default mode. In this mode it is the responsibility of the -caller to ensure that the matrix has enough columns to contain the -full line. If there are not enough columns the list of values is -silently truncated at the end to fit. - -[lst_item [const empty]] - -In this mode the command expands an empty matrix to hold all columns -of the specified line, but goes no further. The overall effect is that -the first of a series of lines determines the number of columns in the -matrix and all following lines are truncated to that size, as if mode -[const none] was set. - -[lst_item [const auto]] - -In this mode the command expands the matrix as needed to hold all -columns contained in [arg line]. The overall effect is that after -adding a series of lines the matrix will have enough columns to hold -all columns of the longest line encountered so far. - -[list_end] - -[call [cmd ::csv::split2queue] [arg "q line"] "{[arg sepChar] ,}"] - -The same as [cmd ::csv::split], but appending the resulting list as a -single item to the queue [arg q], using the method [cmd put]. - -[call [cmd ::csv::writematrix] [arg "m chan"] "{[arg sepChar] ,}"] - -A wrapper around [cmd ::csv::join] taking all rows in the matrix -[arg m] and writing them CSV formatted into the channel [arg chan]. - -[call [cmd ::csv::writequeue] [arg "q chan"] "{[arg sepChar] ,}"] - -A wrapper around [cmd ::csv::join] taking all items in the queue -[arg q] (assumes that they are lists) and writing them CSV formatted -into the channel [arg chan]. - -[list_end] - -[section FORMAT] -[para] - -Each record of a csv file (comma-separated values, as exported e.g. by -Excel) is a set of ASCII values separated by ",". For other languages -it may be ";" however, although this is not important for this case -(The functions provided here allow any separator character). - -[para] - -If a value contains itself the separator ",", then it (the value) is -put between "". - -[para] - -If a value contains ", it is replaced by "". - -[section EXAMPLE] - -The record - -[para] -[example { -123,"123,521.2","Mary says ""Hello, I am Mary""" -}] - -[para] -is parsed as follows: - -[para] -[example { -a) 123 -b) 123,521.2 -c) Mary says "Hello, I am Mary" -}] - -[see_also matrix queue] -[keywords csv matrix queue package tcllib] -[manpage_end] DELETED modules/csv/csv.n Index: modules/csv/csv.n ================================================================== --- modules/csv/csv.n +++ /dev/null @@ -1,159 +0,0 @@ -'\" -'\" Copyright (c) 2001 by Andreas Kupries -'\" All rights reserved. -'\" -'\" RCS: @(#) $Id: csv.n,v 1.9 2002/02/01 22:59:08 andreas_kupries Exp $ -'\" -.so man.macros -.TH csv n 0.3 Csv "CSV processing" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -::csv \- Procedures to handle CSV data -.SH SYNOPSIS -\fBpackage require Tcl 8.3\fR -.sp -\fBpackage require csv ?0.3?\fR -.sp -\fB::csv::join\fR \fIvalues {sepChar ,}\fR -.sp -\fB::csv::joinlist\fR \fIvalues {sepChar ,}\fR -.sp -\fB::csv::read2matrix\fR \fIchan m {sepChar ,} {expand none}\fR -.sp -\fB::csv::read2queue\fR \fIchan q {sepChar ,}\fR -.sp -\fB::csv::report\fR \fIcmd matrix ?chan?\fR -.sp -\fB::csv::split\fR \fIline {sepChar ,}\fR -.sp -\fB::csv::split2matrix\fR \fIq line {sepChar ,} {expand none}\fR -.sp -\fB::csv::split2queue\fR \fIq line {sepChar ,}\fR -.sp -\fB::csv::writematrix\fR \fIm chan {sepChar ,}\fR -.sp -\fB::csv::writequeue\fR \fIq chan {sepChar ,}\fR -.sp -.BE -.SH DESCRIPTION -.PP -The \fB::csv\fR package provides commands to manipulate information in -CSV format (CSV = Comma Separated Values). -.SH COMMANDS -.PP -The following commands are available: -.TP -\fB::csv::join\fR \fIvalues {sepChar ,}\fR -Takes a list of values and returns a string in CSV format containing -these values. The separator character can be defined by the caller, -but this is optional. The default is ",". -.TP -\fB::csv::joinlist\fR \fIvalues {sepChar ,}\fR -Takes a list of lists of values and returns a string in CSV format -containing these values. The separator character can be defined by the -caller, but this is optional. The default is ",". Each element of the -outer list is considered a record, these are separated by newlines in -the result. The elements of each record are formatted as usual (via -\fB::csv::join\fR). -.TP -\fB::csv::read2matrix\fR \fIchan m {sepChar ,} {expand none}\fR -A wrapper around \fB::csv::split2matrix\fR (see below) reading from -CSV-formatted lines from the specified channel (until EOF) and adding -it to the given matrix. For an explanation of the \fIexpand\fR -argument see \fB::csv::split2matrix\fR. -.TP -\fB::csv::read2queue\fR \fIchan q {sepChar ,}\fR -A wrapper around \fB::csv::split2queue\fR (see below) reading from -CSV-formatted lines from the specified channel (until EOF) and adding -it to the given queue. -.TP -\fB::csv::report\fR \fIcmd matrix ?chan?\fR -A report command which can be used by the matrix methods -\fBformat 2string\fR and \fBformat 2chan\fR. For the latter this -command delegates the work to \fB::csv::writematrix\fR. \fIcmd\fR is -expected to be either "printmatrix" or "printmatrix2channel". The -channel argument, \fIchan\fR, has to be present for the latter and -must not be present for the first. -.TP -\fB::csv::split\fR \fIline {sepChar ,}\fR -converts a \fIline\fR in CSV format into a list of the values -contained in the line. The character used to separate the values from -each other can be defined by the caller, via \fIsepChar\fR, but this -is optional. The default is ",". -.TP -\fB::csv::split2matrix\fR \fIm line {sepChar ,} {expand none}\fR -The same as \fB::csv::split\fR, but appends the resulting list as a -new row to the matrix \fIm\fR, using the method \fBadd row\fR. The -expansion mode specified via \fIexpand\fR determines how the command -handles a matrix with less columns than contained in \fIline\fR. The -allowed modes are: -.RS -.TP -\fBnone\fR -This is the \fBdefault mode\fR. In this mode it is the responsibility -of the caller to ensure that the matrix has enough columns to contain -the full line. If there are not enough columns the list of values is -silently truncated at the end to fit. -.TP -\fBempty\fR -In this mode the command expands an empty matrix to hold all columns -of the specified line, but goes no further. The overall effect is that -the first of a series of lines determines the number of columns in the -matrix and all following lines are truncated to that size, as if mode -\fBnone\fR was set. -.TP -\fBauto\fR -In this mode the command expands the matrix as needed to hold all -columns contained in \Iline\fR. The overall effect is that after -adding a series of lines the matrix will have enough columns to hold -all columns of the longest line encountered so far. -.RE -.TP -\fB::csv::split2queue\fR \fIq line {sepChar ,}\fR -The same as \fB::csv::split\fR, but appending the resulting list as a -single item to the queue \fIq\fR, using the method \fBput\fR. -.TP -\fB::csv::writematrix\fR \fIm chan {sepChar ,}\fR -A wrapper around \fB::csv::join\fR taking all rows in the matrix -\fIm\fR and writing them CSV formatted into the channel \fIchan\fR. -.TP -\fB::csv::writequeue\fR \fIq chan {sepChar ,}\fR -A wrapper around \fB::csv::join\fR taking all items in the queue -\fIq\fR (assumes that they are lists) and writing them CSV formatted -into the channel \fIchan\fR. -.SH FORMAT -.PP -Each record of a csv file (comma-separated values, as exported e.g. by -Excel) is a set of ASCII values separated by ",". For other languages -it may be ";" however, although this is not important for this case -(The functions provided here allow any separator character). -.PP -If a value contains itself the separator ",", then it (the value) is -put between "". -.PP -If a value contains ", it is replaced by "". -.SH EXAMPLE -.PP -The record -.TP -* -123,"123,521.2","Mary says ""Hello, I am Mary""" -.PP -is parsed as follows: -.TP -a) -123 -.TP -b) -123,521.2 -.TP -c) -Mary says "Hello, I am Mary" -.SH SEE ALSO -.PP -matrix, queue -.SH KEYWORDS -.PP -csv, matrix queue, package, tcllib -'\" -*- nroff -*- DELETED modules/csv/csv.tcl Index: modules/csv/csv.tcl ================================================================== --- modules/csv/csv.tcl +++ /dev/null @@ -1,324 +0,0 @@ -# csv.tcl -- -# -# Tcl implementations of CSV reader and writer -# -# Copyright (c) 2001 by Jeffrey Hobbs -# Copyright (c) 2001 by Andreas Kupries -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: csv.tcl,v 1.11 2003/03/31 22:24:41 andreas_kupries Exp $ - -package require Tcl 8.3 -package provide csv 0.3 - -namespace eval ::csv { - namespace export join joinlist read2matrix read2queuen report - namespace export split split2matrix split2queue writematrix writequeue -} - -# ::csv::join -- -# -# Takes a list of values and generates a string in CSV format. -# -# Arguments: -# values A list of the values to join -# sepChar The separator character, defaults to comma -# -# Results: -# A string containing the values in CSV format. - -proc ::csv::join {values {sepChar ,}} { - set out "" - set sep {} - foreach val $values { - if {[string match "*\[\"$sepChar\]*" $val]} { - append out $sep\"[string map [list \" \"\"] $val]\" - } else { - append out $sep$val - } - set sep $sepChar - } - return $out -} - -# ::csv::joinlist -- -# -# Takes a list of lists of values and generates a string in CSV -# format. Each item in the list is made into a single CSV -# formatted record in the final string, the records being -# separated by newlines. -# -# Arguments: -# values A list of the lists of the values to join -# sepChar The separator character, defaults to comma -# -# Results: -# A string containing the values in CSV format, the records -# separated by newlines. - -proc ::csv::joinlist {values {sepChar ,}} { - set out "" - foreach record $values { - # note that this is ::csv::join - append out "[join $record $sepChar]\n" - } - return $out -} - -# ::csv::read2matrix -- -# -# A wrapper around "::csv::split2matrix" reading CSV formatted -# lines from the specified channel and adding it to the given -# matrix. -# -# Arguments: -# m The matrix to add the read data too. -# chan The channel to read from. -# sepChar The separator character, defaults to comma -# expand The expansion mode. The default is none -# -# Results: -# A list of the values in 'line'. - -proc ::csv::read2matrix {chan m {sepChar ,} {expand none}} { - # FR #481023 - # See 'split2matrix' for the available expansion modes. - - while {![eof $chan]} { - if {[gets $chan line] < 0} {continue} - if {$line == {}} {continue} - split2matrix $m $line $sepChar $expand - } - return -} - -# ::csv::read2queue -- -# -# A wrapper around "::csv::split2queue" reading CSV formatted -# lines from the specified channel and adding it to the given -# queue. -# -# Arguments: -# q The queue to add the read data too. -# chan The channel to read from. -# sepChar The separator character, defaults to comma -# -# Results: -# A list of the values in 'line'. - -proc ::csv::read2queue {chan q {sepChar ,}} { - while {![eof $chan]} { - if {[gets $chan line] < 0} {continue} - if {$line == {}} {continue} - split2queue $q $line $sepChar - } - return -} - -# ::csv::report -- -# -# A report command which can be used by the matrix methods -# "format-via" and "format2chan-via". For the latter this -# command delegates the work to "::csv::writematrix". "cmd" is -# expected to be either "printmatrix" or -# "printmatrix2channel". The channel argument, "chan", has to -# be present for the latter and must not be present for the first. -# -# Arguments: -# cmd Either 'printmatrix' or 'printmatrix2channel' -# matrix The matrix to format. -# args 0 (chan): The channel to write to -# -# Results: -# None for 'printmatrix2channel', else the CSV formatted string. - -proc ::csv::report {cmd matrix args} { - switch -exact -- $cmd { - printmatrix { - if {[llength $args] > 0} { - return -code error "wrong # args:\ - ::csv::report printmatrix matrix" - } - return [joinlist [$matrix get rect 0 0 end end]] - } - printmatrix2channel { - if {[llength $args] != 1} { - return -code error "wrong # args:\ - ::csv::report printmatrix2channel matrix chan" - } - writematrix $matrix [lindex $args 0] - return "" - } - default { - return -code error "Unknown method $cmd" - } - } -} - -# ::csv::split -- -# -# Split a string according to the rules for CSV processing. -# This assumes that the string contains a single line of CSVs -# -# Arguments: -# line The string to split -# sepChar The separator character, defaults to comma -# -# Results: -# A list of the values in 'line'. - -proc ::csv::split {line {sepChar ,}} { - # Protect the sepchar from special interpretation by - # the regex calls below. - - set sepRE \\$sepChar - regsub -- "$sepRE\"\"$" $line $sepChar\0\"\"\0 line - regsub -- "^\"\"$sepRE" $line \0\"\"\0$sepChar line - regsub -all -- {(^\"|\"$)} $line \0 line - set line [string map [list \ - $sepChar\"\"\" $sepChar\0\" \ - \"\"\"$sepChar \"\0$sepChar \ - \"\" \" \ - \" \0 \ - ] $line] - set end 0 - while {[regexp -indices -start $end -- {(\0)[^\0]*(\0)} $line \ - -> start end]} { - set start [lindex $start 0] - set end [lindex $end 0] - set range [string range $line $start $end] - if {[string first $sepChar $range] >= 0} { - set line [string replace $line $start $end \ - [string map [list $sepChar \1] $range]] - } - incr end - } - set line [string map [list $sepChar \0 \1 $sepChar \0 {} ] $line] - return [::split $line \0] -} - -# ::csv::split2matrix -- -# -# Split a string according to the rules for CSV processing. -# This assumes that the string contains a single line of CSVs. -# The resulting list of values is appended to the specified -# matrix, as a new row. The code assumes that the matrix provides -# the same interface as the queue provided by the 'struct' -# module of tcllib, "add row" in particular. -# -# Arguments: -# m The matrix to write the resulting list to. -# line The string to split -# sepChar The separator character, defaults to comma -# expand The expansion mode. The default is none -# -# Results: -# A list of the values in 'line', written to 'q'. - -proc ::csv::split2matrix {m line {sepChar ,} {expand none}} { - # FR #481023 - - set csv [split $line $sepChar] - - # Expansion modes - # - none : default, behaviour of original implementation. - # no expansion is done, lines are silently truncated - # to the number of columns in the matrix. - # - # - empty : A matrix without columns is expanded to the number - # of columns in the first line added to it. All - # following lines are handled as if "mode == none" - # was set. - # - # - auto : Full auto-mode. The matrix is expanded as needed to - # hold all columns of all lines. - - switch -exact -- $expand { - none {} - empty { - if {[$m columns] == 0} { - $m add columns [llength $csv] - } - } - auto { - if {[$m columns] < [llength $csv]} { - $m add columns [expr {[llength $csv] - [$m columns]}] - } - } - } - $m add row $csv - return -} - -# ::csv::split2queue -- -# -# Split a string according to the rules for CSV processing. -# This assumes that the string contains a single line of CSVs. -# The resulting list of values is appended to the specified -# queue, as a single item. IOW each item in the queue represents -# a single CSV record. The code assumes that the queue provides -# the same interface as the queue provided by the 'struct' -# module of tcllib, "put" in particular. -# -# Arguments: -# q The queue to write the resulting list to. -# line The string to split -# sepChar The separator character, defaults to comma -# -# Results: -# A list of the values in 'line', written to 'q'. - -proc ::csv::split2queue {q line {sepChar ,}} { - $q put [split $line $sepChar] - return -} - -# ::csv::writematrix -- -# -# A wrapper around "::csv::join" taking the rows in a matrix and -# writing them as CSV formatted lines into the channel. -# -# Arguments: -# m The matrix to take the data to write from. -# chan The channel to write into. -# sepChar The separator character, defaults to comma -# -# Results: -# None. - -proc ::csv::writematrix {m chan {sepChar ,}} { - set n [$m rows] - for {set r 0} {$r < $n} {incr r} { - puts $chan [join [$m get row $r] $sepChar] - } - - # Memory intensive alternative: - # puts $chan [joinlist [m get rect 0 0 end end] $sepChar] - return -} - -# ::csv::writequeue -- -# -# A wrapper around "::csv::join" taking the rows in a queue and -# writing them as CSV formatted lines into the channel. -# -# Arguments: -# q The queue to take the data to write from. -# chan The channel to write into. -# sepChar The separator character, defaults to comma -# -# Results: -# None. - -proc ::csv::writequeue {q chan {sepChar ,}} { - while {[$q size] > 0} { - puts $chan [join [$q get] $sepChar] - } - - # Memory intensive alternative: - # puts $chan [joinlist [$q get [$q size]] $sepChar] - return -} - DELETED modules/csv/csv.test Index: modules/csv/csv.test ================================================================== --- modules/csv/csv.test +++ /dev/null @@ -1,460 +0,0 @@ -# -*- tcl -*- -# Tests for the find function. -# -# Sourcing this file into Tcl runs the tests and generates output for errors. -# No output means no errors were found. -# -# Copyright (c) 2001 by Andreas Kupries -# All rights reserved. -# -# RCS: @(#) $Id: csv.test,v 1.7 2003/03/31 22:24:41 andreas_kupries Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -if { [lsearch $auto_path [file dirname [info script]]] == -1 } { - set auto_path [linsert $auto_path 0 [file dirname [info script]]] -} - -package require csv -package require struct -puts "csv [package present csv]" -puts "- struct [package present struct]" - -set str1 {"123","""a""",,hello} -set str2 {1," o, ""a"" ,b ", 3} -set str3 {"1"," o, "","" ,b ", 3} -set str4 {1," foo,bar,baz", 3} -set str5 {1,"""""a""""",b} -set str6 {123,"123,521.2","Mary says ""Hello, I am Mary"""} - -set str1a {123,"""a""",,hello} -set str3a {1," o, "","" ,b ", 3} - -test csv-1.1 {split} { - csv::split $str1 -} {123 {"a"} {} hello} - -test csv-1.2 {split} { - csv::split $str2 -} {1 { o, "a" ,b } { 3}} - -test csv-1.3 {split} { - csv::split $str3 -} {1 { o, "," ,b } { 3}} - -test csv-1.4 {split} { - csv::split $str4 -} {1 { foo,bar,baz} { 3}} - -test csv-1.5 {split} { - csv::split $str5 -} {1 {""a""} b} - -test csv-1.6 {split} { - csv::split $str6 -} {123 123,521.2 {Mary says "Hello, I am Mary"}} - -test csv-1.7 {split on join} { - # csv 0.1 was exposed to the RE \A matching problem with regsub -all - set x [list "\"hello, you\"" a b c] - ::csv::split [::csv::join $x] -} [list "\"hello, you\"" a b c] - -test csv-1.8-1 {split empty fields} { - csv::split {1 2 "" ""} { } -} {1 2 {"} {"}} - -test csv-1.9-1 {split empty fields} { - csv::split {1 2 3 ""} { } -} {1 2 3 {"}} - -test csv-1.10-1 {split empty fields} { - csv::split {"" "" 1 2} { } -} {{"} {"} 1 2} - -test csv-1.11-1 {split empty fields} { - csv::split {"" 0 1 2} { } -} {{"} 0 1 2} - -test csv-1.12-1 {split empty fields} { - csv::split {"" ""} { } -} {{"} {"}} - -test csv-1.13-1 {split empty fields} { - csv::split {"" "" ""} { } -} {{"} {"} {"}} - -test csv-1.14-1 {split empty fields} { - csv::split {"" 0 "" 2} { } -} {{"} 0 {"} 2} - -test csv-1.15-1 {split empty fields} { - csv::split {1 "" 3 ""} { } -} {1 {"} 3 {"}} - -test csv-1.8-2 {split empty fields} { - csv::split "1,2,," -} {1 2 {} {}} - -test csv-1.9-2 {split empty fields} { - csv::split "1,2,3," -} {1 2 3 {}} - -test csv-1.10-2 {split empty fields} { - csv::split ",,1,2" -} {{} {} 1 2} - -test csv-1.11-2 {split empty fields} { - csv::split ",0,1,2" -} {{} 0 1 2} - -test csv-1.12-2 {split empty fields} { - csv::split "," -} {{} {}} - -test csv-1.13-2 {split empty fields} { - csv::split ",," -} {{} {} {}} - -test csv-1.14-2 {split empty fields} { - csv::split ",0,,2" -} {{} 0 {} 2} - -test csv-1.15-2 {split empty fields} { - csv::split "1,,3," -} {1 {} 3 {}} - -test csv-1.8-3 {split empty fields} { - csv::split {1 2 } { } -} {1 2 {} {}} - -test csv-1.9-3 {split empty fields} { - csv::split {1 2 3 } { } -} {1 2 3 {}} - -test csv-1.10-3 {split empty fields} { - csv::split { 1 2} { } -} {{} {} 1 2} - -test csv-1.11-3 {split empty fields} { - csv::split { 0 1 2} { } -} {{} 0 1 2} - -test csv-1.12-3 {split empty fields} { - csv::split { } { } -} {{} {}} - -test csv-1.13-3 {split empty fields} { - csv::split { } { } -} {{} {} {}} - -test csv-1.14-3 {split empty fields} { - csv::split { 0 2} { } -} {{} 0 {} 2} - -test csv-1.15-3 {split empty fields} { - csv::split {1 3 } { } -} {1 {} 3 {}} - - -test csv-1.8-4 {split empty fields} { - csv::split {1,2,"",""} -} {1 2 {"} {"}} - -test csv-1.9-4 {split empty fields} { - csv::split {1,2,3,""} -} {1 2 3 {"}} - -test csv-1.10-4 {split empty fields} { - csv::split {"","",1,2} -} {{"} {"} 1 2} - -test csv-1.11-4 {split empty fields} { - csv::split {"",0,1,2} -} {{"} 0 1 2} - -test csv-1.12-4 {split empty fields} { - csv::split {"",""} -} {{"} {"}} - -test csv-1.13-4 {split empty fields} { - csv::split {"","",""} -} {{"} {"} {"}} - -test csv-1.14-4 {split empty fields} { - csv::split {"",0,"",2} -} {{"} 0 {"} 2} - -test csv-1.15-4 {split empty fields} { - csv::split {1,"",3,""} -} {1 {"} 3 {"}} - -# Try various separator characters - -foreach {n sep} { - 0 | 1 + 2 * - 3 / 4 \ 5 [ - 6 ] 7 ( 8 ) - 9 ? 10 , 11 ; - 12 . 13 - 14 = - 15 : -} { - test csv-1.16-$n "split on $sep" { - ::csv::split [join [list REC DPI AD1 AD2 AD3] $sep] $sep - } {REC DPI AD1 AD2 AD3} -} - -test csv-2.1 {join} { - csv::join {123 {"a"} {} hello} -} $str1a - -test csv-2.2 {join} { - csv::join {1 { o, "a" ,b } { 3}} -} $str2 - -test csv-2.3 {join} { - csv::join {1 { o, "," ,b } { 3}} -} $str3a - -test csv-2.4 {join} { - csv::join {1 { foo,bar,baz} { 3}} -} $str4 - -test csv-2.5 {join} { - csv::join {1 {""a""} b} -} $str5 - -test csv-2.6 {join} { - csv::join {123 123,521.2 {Mary says "Hello, I am Mary"}} -} $str6 - -# Malformed inputs - -test csv-3.1 {split} { - csv::split {abcd,abc",abc} ; # " -} {abcd abc abc} - -test csv-3.2 {split} { - csv::split {abcd,abc"",abc} -} {abcd abc\" abc} - - -test csv-4.1 {joinlist} { - csv::joinlist [list \ - {123 {"a"} {} hello} \ - {1 { o, "a" ,b } { 3}} \ - {1 { o, "," ,b } { 3}} \ - {1 { foo,bar,baz} { 3}} \ - {1 {""a""} b} \ - {123 123,521.2 {Mary says "Hello, I am Mary"}}] -} "$str1a\n$str2\n$str3a\n$str4\n$str5\n$str6\n" - -test csv-4.2 {joinlist, sepChar} { - csv::joinlist [list [list a b c] [list d e f]] @ -} "a@b@c\nd@e@f\n" - - -test csv-5.1 {reading csv files} { - set f [open [file join $::tcltest::testsDirectory mem_debug_bench.csv] r] - ::struct::queue q - ::csv::read2queue $f q - close $f - set result [list [q size] [q get 2]] - q destroy - set result -} {251 {{000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} {001 {CATCH return ok} 7 13 53.85}}} - -test csv-5.2 {reading csv files} { - set f [open [file join $::tcltest::testsDirectory mem_debug_bench_a.csv] r] - ::struct::queue q - ::csv::read2queue $f q - close $f - set result [list [q size] [q get 2]] - q destroy - set result -} {251 {{000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} {001 {CATCH return ok} 7 13 53.85}}} - -test csv-5.3 {reading csv files} { - set f [open [file join $::tcltest::testsDirectory mem_debug_bench.csv] r] - ::struct::matrix m - m add columns 5 - ::csv::read2matrix $f m - close $f - set result [m get rect 0 227 end 231] - m destroy - set result -} {{227 {STR append (1MB + 1MB * 3)} 125505 327765 38.29} {228 {STR append (1MB + 1MB * 5)} 158507 855295 18.53} {229 {STR append (1MB + (1b + 1K + 1b) * 100)} 33101 174031 19.02} {230 {STR info locals match} 946 1521 62.20} {231 {TRACE no trace set} 34 121 28.10}} - -test csv-5.4 {reading csv files} { - set f [open [file join $::tcltest::testsDirectory mem_debug_bench_a.csv] r] - ::struct::matrix m - m add columns 5 - ::csv::read2matrix $f m - close $f - set result [m get rect 0 227 end 231] - m destroy - set result -} {{227 {STR append (1MB + 1MB * 3)} 125505 327765 38.29} {228 {STR append (1MB + 1MB * 5)} 158507 855295 18.53} {229 {STR append (1MB + (1b + 1K + 1b) * 100)} 33101 174031 19.02} {230 {STR info locals match} 946 1521 62.20} {231 {TRACE no trace set} 34 121 28.10}} - -test csv-5.5 {reading csv files} { - set f [open [file join $::tcltest::testsDirectory mem_debug_bench.csv] r] - ::struct::matrix m - m add columns 5 - ::csv::read2matrix $f m - close $f - - set result [list] - foreach c {0 1 2 3 4} { - lappend result [m columnwidth $c] - } - m destroy - set result -} {3 39 7 7 8} - -test csv-5.6 {reading csv files, linking} { - set f [open [file join $::tcltest::testsDirectory mem_debug_bench.csv] r] - ::struct::matrix m - m add columns 5 - ::csv::read2matrix $f m - close $f - m link a - set result [array size a] - m destroy - set result -} {1255} - - -test csv-5.7 {reading csv files, empty expansion mode} { - set f [open [file join $::tcltest::testsDirectory mem_debug_bench.csv] r] - ::struct::matrix m - ::csv::read2matrix $f m , empty - close $f - set result [m get rect 0 227 end 231] - m destroy - set result -} {{227 {STR append (1MB + 1MB * 3)} 125505 327765 38.29} {228 {STR append (1MB + 1MB * 5)} 158507 855295 18.53} {229 {STR append (1MB + (1b + 1K + 1b) * 100)} 33101 174031 19.02} {230 {STR info locals match} 946 1521 62.20} {231 {TRACE no trace set} 34 121 28.10}} - -test csv-5.8 {reading csv files, auto expansion mode} { - set f [open [file join $::tcltest::testsDirectory mem_debug_bench.csv] r] - ::struct::matrix m - m add columns 1 - ::csv::read2matrix $f m , auto - close $f - set result [m get rect 0 227 end 231] - m destroy - set result -} {{227 {STR append (1MB + 1MB * 3)} 125505 327765 38.29} {228 {STR append (1MB + 1MB * 5)} 158507 855295 18.53} {229 {STR append (1MB + (1b + 1K + 1b) * 100)} 33101 174031 19.02} {230 {STR info locals match} 946 1521 62.20} {231 {TRACE no trace set} 34 121 28.10}} - -tcltest::makeFile {} eval-out1.csv -tcltest::makeFile {} eval-out2.csv -tcltest::makeFile {} eval-out3.csv - -test csv-6.1 {writing csv files} { - set f [open [file join $::tcltest::testsDirectory eval.csv] r] - ::struct::matrix m - m add columns 5 - ::csv::read2matrix $f m - close $f - - set f [open eval-out1.csv w] - ::csv::writematrix m $f - close $f - - set result [tcltest::viewFile eval-out1.csv] - m destroy - set result -} {023,EVAL cmd eval in list obj var,26,45,57.78 -024,EVAL cmd eval as list,23,42,54.76 -025,EVAL cmd eval as string,53,92,57.61 -026,EVAL cmd and mixed lists,3805,11276,33.74 -027,EVAL list cmd and mixed lists,3812,11325,33.66 -028,EVAL list cmd and pure lists,592,1598,37.05} - -test csv-6.2 {writing csv files} { - set f [open [file join $::tcltest::testsDirectory eval.csv] r] - ::struct::queue q - ::csv::read2queue $f q - close $f - - set f [open eval-out2.csv w] - ::csv::writequeue q $f - close $f - - set result [tcltest::viewFile eval-out2.csv] - q destroy - set result -} {023,EVAL cmd eval in list obj var,26,45,57.78 -024,EVAL cmd eval as list,23,42,54.76 -025,EVAL cmd eval as string,53,92,57.61 -026,EVAL cmd and mixed lists,3805,11276,33.74 -027,EVAL list cmd and mixed lists,3812,11325,33.66 -028,EVAL list cmd and pure lists,592,1598,37.05} - - -test csv-7.1 {reporting} { - set f [open [file join $::tcltest::testsDirectory eval.csv] r] - ::struct::matrix m - m add columns 5 - ::csv::read2matrix $f m - close $f - - set result [m format 2string csv::report] - m destroy - set result -} {023,EVAL cmd eval in list obj var,26,45,57.78 -024,EVAL cmd eval as list,23,42,54.76 -025,EVAL cmd eval as string,53,92,57.61 -026,EVAL cmd and mixed lists,3805,11276,33.74 -027,EVAL list cmd and mixed lists,3812,11325,33.66 -028,EVAL list cmd and pure lists,592,1598,37.05 -} - -test csv-7.2 {reporting} { - set f [open [file join $::tcltest::testsDirectory eval.csv] r] - ::struct::matrix m - m add columns 5 - ::csv::read2matrix $f m - close $f - - set f [open eval-out3.csv w] - m format 2chan csv::report $f - close $f - - set result [tcltest::viewFile eval-out3.csv] - m destroy - set result -} {023,EVAL cmd eval in list obj var,26,45,57.78 -024,EVAL cmd eval as list,23,42,54.76 -025,EVAL cmd eval as string,53,92,57.61 -026,EVAL cmd and mixed lists,3805,11276,33.74 -027,EVAL list cmd and mixed lists,3812,11325,33.66 -028,EVAL list cmd and pure lists,592,1598,37.05} - - -test csv-7.3 {report error} { - catch {::csv::report printmatrix foomatrix blarg} msg - set msg -} {wrong # args: ::csv::report printmatrix matrix} - -test csv-7.4 {report error} { - catch {::csv::report printmatrix2channel foomatrix} msg - set msg -} {wrong # args: ::csv::report printmatrix2channel matrix chan} - -test csv-7.5 {report error} { - catch {::csv::report printmatrix2channel foomatrix foo bar} msg - set msg -} {wrong # args: ::csv::report printmatrix2channel matrix chan} - -test csv-7.6 {report error} { - catch {::csv::report foocmd foomatrix} msg - set msg -} {Unknown method foocmd} - - - -::tcltest::cleanupTests -return DELETED modules/csv/eval.csv Index: modules/csv/eval.csv ================================================================== --- modules/csv/eval.csv +++ /dev/null @@ -1,6 +0,0 @@ -023,EVAL cmd eval in list obj var,26,45,57.78 -024,EVAL cmd eval as list,23,42,54.76 -025,EVAL cmd eval as string,53,92,57.61 -026,EVAL cmd and mixed lists,3805,11276,33.74 -027,EVAL list cmd and mixed lists,3812,11325,33.66 -028,EVAL list cmd and pure lists,592,1598,37.05 DELETED modules/csv/mem_debug_bench.csv Index: modules/csv/mem_debug_bench.csv ================================================================== --- modules/csv/mem_debug_bench.csv +++ /dev/null @@ -1,251 +0,0 @@ -000,VERSIONS:,2:8.4a3,1:8.4a3,1:8.4a3% -001,CATCH return ok,7,13,53.85 -002,CATCH return error,68,91,74.73 -003,CATCH no catch used,7,14,50.00 -004,IF if true numeric,12,33,36.36 -005,IF elseif true numeric,15,47,31.91 -006,IF else true numeric,15,46,32.61 -007,IF if true num/num,13,32,40.62 -008,IF if false num/num,13,32,40.62 -009,IF if false al/num,28,57,49.12 -010,IF if true al/num,34,54,62.96 -011,IF if false al/num,34,58,58.62 -012,IF if true al/al,33,100,33.00 -013,IF elseif true al/al,50,87,57.47 -014,IF else true al/al,50,92,54.35 -015,SWITCH first true,50,81,61.73 -016,SWITCH second true,55,84,65.48 -017,SWITCH ninth true,56,96,58.33 -018,SWITCH default true,48,81,59.26 -019,DATA create in a list,5419,13514,40.10 -020,DATA create in an array,5861,15537,37.72 -021,DATA access in a list,4424,9967,44.39 -022,DATA access in an array,4373,9167,47.70 -023,EVAL cmd eval in list obj var,26,45,57.78 -024,EVAL cmd eval as list,23,42,54.76 -025,EVAL cmd eval as string,53,92,57.61 -026,EVAL cmd and mixed lists,3805,11276,33.74 -027,EVAL list cmd and mixed lists,3812,11325,33.66 -028,EVAL list cmd and pure lists,592,1598,37.05 -029,EXPR unbraced,174,250,69.60 -030,EXPR braced,27,60,45.00 -031,EXPR inline,28,51,54.90 -032,EXPR one operand,8,13,61.54 -033,EXPR ten operands,15,25,60.00 -034,EXPR fifty operands,46,73,63.01 -035,EXPR incr with incr,13,20,65.00 -036,EXPR incr with expr,8,14,57.14 -037,KLIST shuffle0 llength 1,154,260,59.23 -038,KLIST shuffle0 llength 10,521,950,54.84 -039,KLIST shuffle0 llength 100,4126,7781,53.03 -040,KLIST shuffle0 llength 1000,46309,85434,54.20 -041,KLIST shuffle0 llength 10000,612676,1000055,61.26 -042,KLIST shuffle1 llength 1,100,181,55.25 -043,KLIST shuffle1 llength 10,432,835,51.74 -044,KLIST shuffle1 llength 100,5872,14144,41.52 -045,KLIST shuffle1 llength 1000,1293956,1235661,104.72 -046,KLIST shuffle1a llength 1,115,200,57.50 -047,KLIST shuffle1a llength 10,442,1012,43.68 -048,KLIST shuffle1a llength 100,4212,9609,43.83 -049,KLIST shuffle1a llength 1000,42350,98262,43.10 -050,KLIST shuffle1a llength 10000,445084,1052460,42.29 -051,KLIST shuffle2 llength 1,123,205,60.00 -052,KLIST shuffle2 llength 10,484,922,52.49 -053,KLIST shuffle2 llength 100,4377,8347,52.44 -054,KLIST shuffle2 llength 1000,46002,89585,51.35 -055,KLIST shuffle2 llength 10000,525442,926369,56.72 -056,KLIST shuffle3 llength 1,116,196,59.18 -057,KLIST shuffle3 llength 10,420,911,46.10 -058,KLIST shuffle3 llength 100,3730,8465,44.06 -059,KLIST shuffle3 llength 1000,39397,87416,45.07 -060,KLIST shuffle3 llength 10000,949689,1391544,68.25 -061,KLIST shuffle4 llength 1,116,204,56.86 -062,KLIST shuffle4 llength 10,450,1000,45.00 -063,KLIST shuffle4 llength 100,4067,9326,43.61 -064,KLIST shuffle4 llength 1000,39142,92580,42.28 -065,KLIST shuffle4 llength 10000,421581,944205,44.65 -066,"STR/LIST length; obj shimmer",3268,6767,48.29 -067,"LIST length; pure list",17,21,80.95 -068,STR length of a LIST,12,25,48.00 -069,"LIST exact search; first item",18,24,75.00 -070,"LIST exact search; middle item",74,111,66.67 -071,"LIST exact search; last item",142,236,60.17 -072,"LIST exact search; non-item",344,603,57.05 -073,"LIST sorted search; first item",19,29,65.52 -074,"LIST sorted search; middle item",19,27,70.37 -075,"LIST sorted search; last item",19,27,70.37 -076,"LIST sorted search; non-item",19,27,70.37 -077,"LIST exact search; untyped item",148,230,64.35 -078,"LIST exact search; typed item",107,119,89.92 -079,"LIST sorted search; typed item",18,29,62.07 -080,LIST sort,3620,4994,72.49 -081,LIST typed sort,2923,3885,75.24 -082,LIST remove first element,310,763,40.63 -083,LIST remove middle element,308,761,40.47 -084,LIST remove last element,312,757,41.22 -085,LIST replace first element,291,740,39.32 -086,LIST replace middle element,295,741,39.81 -087,LIST replace last element,295,743,39.70 -088,LIST replace first el with multiple,315,770,40.91 -089,LIST replace middle el with multiple,314,764,41.10 -090,LIST replace last el with multiple,288,750,38.40 -091,LIST replace range,288,737,39.08 -092,LIST remove in mixed list,411,959,42.86 -093,LIST replace in mixed list,398,932,42.70 -094,LIST index first element,14,24,58.33 -095,LIST index middle element,14,28,50.00 -096,LIST index last element,14,28,50.00 -097,LIST insert an item at start,297,750,39.60 -098,LIST insert an item at middle,303,746,40.62 -099,"LIST insert an item at ""end""",299,746,40.08 -100,"LIST small; early range",26,41,63.41 -101,"LIST small; late range",23,33,69.70 -102,"LIST large; early range",42,94,44.68 -103,"LIST large; late range",41,106,38.68 -104,LIST append to list,406,426,95.31 -105,LIST join list,1147,1687,67.99 -106,"LOOP for; iterate list",6848,16393,41.77 -107,"LOOP foreach; iterate list",2169,5913,36.68 -108,LOOP for (to 1000),2756,8183,33.68 -109,LOOP while (to 1000),2753,8181,33.65 -110,"LOOP for; iterate string",8350,15966,52.30 -111,"LOOP foreach; iterate string",2684,7094,37.83 -112,MAP string 1 val,686,1097,62.53 -113,MAP string 2 val,1578,2375,66.44 -114,MAP string 3 val,1938,2674,72.48 -115,MAP string 4 val,2427,3324,73.01 -116,MAP string 1 val -nocase,3772,5524,68.28 -117,MAP string 2 val -nocase,6633,9624,68.92 -118,MAP string 3 val -nocase,8809,12682,69.46 -119,MAP string 4 val -nocase,10692,15353,69.64 -120,MAP regsub 1 val,3884,4345,89.39 -121,MAP regsub 2 val,16420,17435,94.18 -122,MAP regsub 3 val,22056,23287,94.71 -123,MAP regsub 4 val,27550,29333,93.92 -124,MAP regsub 1 val -nocase,4004,4322,92.64 -125,MAP regsub 2 val -nocase,16519,17289,95.55 -126,MAP regsub 3 val -nocase,22075,23427,94.23 -127,MAP regsub 4 val -nocase,27981,29438,95.05 -128,"MAP string; no match",1011,1734,58.30 -129,"MAP string -nocase; no match",7090,10589,66.96 -130,"MAP regsub; no match",1226,2328,52.66 -131,"MAP regsub -nocase; no match",1287,2295,56.08 -132,MAP string short,44,58,75.86 -133,MAP regsub short,188,219,85.84 -134,MTHD direct ns proc call,8,15,53.33 -135,MTHD imported ns proc call,8,16,50.00 -136,MTHD interp alias proc call,25,44,56.82 -137,MTHD indirect proc eval,36,58,62.07 -138,MTHD indirect proc eval #2,58,100,58.00 -139,MTHD array stored proc call,11,25,44.00 -140,MTHD switch method call,53,86,61.63 -141,MTHD ns lookup call,113,189,59.79 -142,MTHD inline call,3,9,33.33 -143,PROC explicit return,7,12,58.33 -144,PROC implicit return,7,17,41.18 -145,PROC explicit return (2),7,13,53.85 -146,PROC implicit return (2),7,15,46.67 -147,PROC explicit return (3),7,12,58.33 -148,PROC implicit return (3),7,12,58.33 -149,PROC heavily commented,7,12,58.33 -150,"PROC do-nothing; no args",6,11,54.55 -151,"PROC do-nothing; one arg",7,12,58.33 -152,PROC local links with global,1611,2827,56.99 -153,PROC local links with upvar,1308,2630,49.73 -154,PROC local links with variable,1309,2358,55.51 -155,"READ 595K; gets",386913,551429,70.17 -156,"READ 595K; read",85889,164758,52.13 -157,"READ 595K; read & size",86171,164854,52.27 -158,"READ 3050b; gets",2152,3481,61.82 -159,"READ 3050b; read",561,682,82.26 -160,"READ 3050b; read & size",606,738,82.11 -161,"BREAD 595K; gets",392519,568992,68.98 -162,"BREAD 595K; read",51133,110961,46.08 -163,"BREAD 595K; read & size",51194,110552,46.31 -164,"BREAD 3050b; gets",2213,3174,69.72 -165,"BREAD 3050b; read",329,472,69.70 -166,"BREAD 3050b; read & size",377,517,72.92 -167,REGEXP literal regexp,48,58,82.76 -168,REGEXP var-based regexp,51,60,85.00 -169,REGEXP count all matches,149,161,92.55 -170,REGEXP extract all matches,201,255,78.82 -171,STARTUP time to launch tclsh,26402,32329,81.67 -172,STR str [string compare],15,38,39.47 -173,STR str [string equal],15,38,39.47 -174,"STR str $a equal """"",13,32,40.62 -175,"STR str num == """"",15,38,39.47 -176,STR str $a eq $b,21,49,42.86 -177,STR str $a ne $b,21,49,42.86 -178,STR str $a eq $b (same obj),19,45,42.22 -179,STR str $a ne $b (same obj),19,46,41.30 -180,STR length (==4010),13,23,56.52 -181,STR index 0,19,30,63.33 -182,STR index 100,20,31,64.52 -183,STR index 500,19,30,63.33 -184,STR index2 0,20,32,62.50 -185,STR index2 100,21,30,70.00 -186,STR index2 500,20,31,64.52 -187,STR first (success),17,23,73.91 -188,STR first (failure),115,116,99.14 -189,STR first (total failure),106,103,102.91 -190,STR last (success),17,23,73.91 -191,STR last (failure),91,109,83.49 -192,STR last (total failure),82,86,95.35 -193,"STR match; simple (success early)",17,31,54.84 -194,"STR match; simple (success late)",18,30,60.00 -195,"STR match; simple (failure)",18,28,64.29 -196,"STR match; simple (total failure)",16,29,55.17 -197,"STR match; complex (success early)",18,34,52.94 -198,"STR match; complex (success late)",152,165,92.12 -199,"STR match; complex (failure)",121,134,90.30 -200,"STR match; complex (total failure)",95,101,94.06 -201,"STR range; index 100..200 of 4010",26,40,65.00 -202,"STR replace; no replacement",87,126,69.05 -203,"STR replace; equal replacement",93,133,69.92 -204,"STR replace; longer replacement",103,146,70.55 -205,"STR repeat; abcdefghij * 10",16,23,69.57 -206,"STR repeat; abcdefghij * 100",48,47,102.13 -207,"STR repeat; abcdefghij * 1000",231,257,89.88 -208,"STR repeat; 4010 chars * 10",282,744,37.90 -209,"STR repeat; 4010 chars * 100",6976,14673,47.54 -210,"STR reverse iter1; 100 chars",1534,2295,66.84 -211,"STR reverse iter1; 100 uchars",1457,2322,62.75 -212,"STR reverse iter2; 100 chars",1123,2042,55.00 -213,"STR reverse iter2; 100 uchars",1042,1972,52.84 -214,"STR reverse recur1; 100 chars",3458,7067,48.93 -215,"STR reverse recur1; 100 uchars",3523,6650,52.98 -216,"STR split; 4010 chars",2806,4605,60.93 -217,"STR split; 12100 uchars",7890,13813,57.12 -218,"STR split iter; 4010 chars",11129,28087,39.62 -219,"STR split iter; 12100 uchars",33318,86314,38.60 -220,STR append,99,160,61.88 -221,STR append (1KB + 1KB),95,134,70.90 -222,STR append (10KB + 1KB),209,537,38.92 -223,STR append (1MB + 2b * 1000),38681,190529,20.30 -224,STR append (1MB + 1KB),28344,173073,16.38 -225,STR append (1MB + 1KB * 20),29077,173622,16.75 -226,STR append (1MB + 1KB * 1000),66893,207868,32.18 -227,STR append (1MB + 1MB * 3),125505,327765,38.29 -228,STR append (1MB + 1MB * 5),158507,855295,18.53 -229,STR append (1MB + (1b + 1K + 1b) * 100),33101,174031,19.02 -230,STR info locals match,946,1521,62.20 -231,TRACE no trace set,34,121,28.10 -232,TRACE read,34,50,68.00 -233,TRACE write,33,50,66.00 -234,TRACE unset,33,48,68.75 -235,TRACE all set (rwu),34,52,65.38 -236,UNSET var exists,12,19,63.16 -237,UNSET catch var exists,13,23,56.52 -238,UNSET catch var !exist,77,105,73.33 -239,UNSET info check var exists,16,27,59.26 -240,UNSET info check var !exist,12,27,44.44 -241,UNSET nocomplain var exists,12,18,66.67 -242,UNSET nocomplain var !exist,12,16,75.00 -243,VAR access locally set,10,19,52.63 -244,VAR access local proc arg,10,20,50.00 -245,VAR access global,35,49,71.43 -246,VAR access upvar,40,54,74.07 -247,VAR set scalar,7,15,46.67 -248,VAR set array element,14,28,50.00 -249,VAR 100 'set's in array,161,272,59.19 -250,VAR 'array set' of 100 elems,306,467,65.52 DELETED modules/csv/mem_debug_bench_a.csv Index: modules/csv/mem_debug_bench_a.csv ================================================================== --- modules/csv/mem_debug_bench_a.csv +++ /dev/null @@ -1,256 +0,0 @@ -000,VERSIONS:,2:8.4a3,1:8.4a3,1:8.4a3% -001,CATCH return ok,7,13,53.85 -002,CATCH return error,68,91,74.73 -003,CATCH no catch used,7,14,50.00 -004,IF if true numeric,12,33,36.36 -005,IF elseif true numeric,15,47,31.91 - -006,IF else true numeric,15,46,32.61 -007,IF if true num/num,13,32,40.62 -008,IF if false num/num,13,32,40.62 -009,IF if false al/num,28,57,49.12 -010,IF if true al/num,34,54,62.96 -011,IF if false al/num,34,58,58.62 -012,IF if true al/al,33,100,33.00 -013,IF elseif true al/al,50,87,57.47 -014,IF else true al/al,50,92,54.35 -015,SWITCH first true,50,81,61.73 -016,SWITCH second true,55,84,65.48 -017,SWITCH ninth true,56,96,58.33 -018,SWITCH default true,48,81,59.26 -019,DATA create in a list,5419,13514,40.10 -020,DATA create in an array,5861,15537,37.72 -021,DATA access in a list,4424,9967,44.39 - -022,DATA access in an array,4373,9167,47.70 -023,EVAL cmd eval in list obj var,26,45,57.78 -024,EVAL cmd eval as list,23,42,54.76 -025,EVAL cmd eval as string,53,92,57.61 -026,EVAL cmd and mixed lists,3805,11276,33.74 -027,EVAL list cmd and mixed lists,3812,11325,33.66 -028,EVAL list cmd and pure lists,592,1598,37.05 -029,EXPR unbraced,174,250,69.60 -030,EXPR braced,27,60,45.00 -031,EXPR inline,28,51,54.90 -032,EXPR one operand,8,13,61.54 -033,EXPR ten operands,15,25,60.00 - - -034,EXPR fifty operands,46,73,63.01 -035,EXPR incr with incr,13,20,65.00 -036,EXPR incr with expr,8,14,57.14 -037,KLIST shuffle0 llength 1,154,260,59.23 -038,KLIST shuffle0 llength 10,521,950,54.84 -039,KLIST shuffle0 llength 100,4126,7781,53.03 -040,KLIST shuffle0 llength 1000,46309,85434,54.20 -041,KLIST shuffle0 llength 10000,612676,1000055,61.26 -042,KLIST shuffle1 llength 1,100,181,55.25 -043,KLIST shuffle1 llength 10,432,835,51.74 -044,KLIST shuffle1 llength 100,5872,14144,41.52 -045,KLIST shuffle1 llength 1000,1293956,1235661,104.72 -046,KLIST shuffle1a llength 1,115,200,57.50 -047,KLIST shuffle1a llength 10,442,1012,43.68 -048,KLIST shuffle1a llength 100,4212,9609,43.83 -049,KLIST shuffle1a llength 1000,42350,98262,43.10 -050,KLIST shuffle1a llength 10000,445084,1052460,42.29 -051,KLIST shuffle2 llength 1,123,205,60.00 -052,KLIST shuffle2 llength 10,484,922,52.49 - -053,KLIST shuffle2 llength 100,4377,8347,52.44 -054,KLIST shuffle2 llength 1000,46002,89585,51.35 -055,KLIST shuffle2 llength 10000,525442,926369,56.72 -056,KLIST shuffle3 llength 1,116,196,59.18 -057,KLIST shuffle3 llength 10,420,911,46.10 -058,KLIST shuffle3 llength 100,3730,8465,44.06 -059,KLIST shuffle3 llength 1000,39397,87416,45.07 -060,KLIST shuffle3 llength 10000,949689,1391544,68.25 -061,KLIST shuffle4 llength 1,116,204,56.86 -062,KLIST shuffle4 llength 10,450,1000,45.00 -063,KLIST shuffle4 llength 100,4067,9326,43.61 -064,KLIST shuffle4 llength 1000,39142,92580,42.28 -065,KLIST shuffle4 llength 10000,421581,944205,44.65 -066,"STR/LIST length; obj shimmer",3268,6767,48.29 -067,"LIST length; pure list",17,21,80.95 -068,STR length of a LIST,12,25,48.00 -069,"LIST exact search; first item",18,24,75.00 -070,"LIST exact search; middle item",74,111,66.67 -071,"LIST exact search; last item",142,236,60.17 -072,"LIST exact search; non-item",344,603,57.05 -073,"LIST sorted search; first item",19,29,65.52 -074,"LIST sorted search; middle item",19,27,70.37 -075,"LIST sorted search; last item",19,27,70.37 -076,"LIST sorted search; non-item",19,27,70.37 -077,"LIST exact search; untyped item",148,230,64.35 -078,"LIST exact search; typed item",107,119,89.92 -079,"LIST sorted search; typed item",18,29,62.07 -080,LIST sort,3620,4994,72.49 -081,LIST typed sort,2923,3885,75.24 -082,LIST remove first element,310,763,40.63 -083,LIST remove middle element,308,761,40.47 -084,LIST remove last element,312,757,41.22 -085,LIST replace first element,291,740,39.32 -086,LIST replace middle element,295,741,39.81 -087,LIST replace last element,295,743,39.70 -088,LIST replace first el with multiple,315,770,40.91 -089,LIST replace middle el with multiple,314,764,41.10 -090,LIST replace last el with multiple,288,750,38.40 -091,LIST replace range,288,737,39.08 -092,LIST remove in mixed list,411,959,42.86 -093,LIST replace in mixed list,398,932,42.70 -094,LIST index first element,14,24,58.33 -095,LIST index middle element,14,28,50.00 -096,LIST index last element,14,28,50.00 -097,LIST insert an item at start,297,750,39.60 -098,LIST insert an item at middle,303,746,40.62 -099,"LIST insert an item at ""end""",299,746,40.08 -100,"LIST small; early range",26,41,63.41 -101,"LIST small; late range",23,33,69.70 -102,"LIST large; early range",42,94,44.68 -103,"LIST large; late range",41,106,38.68 -104,LIST append to list,406,426,95.31 -105,LIST join list,1147,1687,67.99 -106,"LOOP for; iterate list",6848,16393,41.77 -107,"LOOP foreach; iterate list",2169,5913,36.68 -108,LOOP for (to 1000),2756,8183,33.68 -109,LOOP while (to 1000),2753,8181,33.65 -110,"LOOP for; iterate string",8350,15966,52.30 -111,"LOOP foreach; iterate string",2684,7094,37.83 -112,MAP string 1 val,686,1097,62.53 -113,MAP string 2 val,1578,2375,66.44 -114,MAP string 3 val,1938,2674,72.48 -115,MAP string 4 val,2427,3324,73.01 -116,MAP string 1 val -nocase,3772,5524,68.28 -117,MAP string 2 val -nocase,6633,9624,68.92 -118,MAP string 3 val -nocase,8809,12682,69.46 -119,MAP string 4 val -nocase,10692,15353,69.64 -120,MAP regsub 1 val,3884,4345,89.39 -121,MAP regsub 2 val,16420,17435,94.18 -122,MAP regsub 3 val,22056,23287,94.71 -123,MAP regsub 4 val,27550,29333,93.92 -124,MAP regsub 1 val -nocase,4004,4322,92.64 -125,MAP regsub 2 val -nocase,16519,17289,95.55 -126,MAP regsub 3 val -nocase,22075,23427,94.23 -127,MAP regsub 4 val -nocase,27981,29438,95.05 -128,"MAP string; no match",1011,1734,58.30 -129,"MAP string -nocase; no match",7090,10589,66.96 -130,"MAP regsub; no match",1226,2328,52.66 -131,"MAP regsub -nocase; no match",1287,2295,56.08 -132,MAP string short,44,58,75.86 -133,MAP regsub short,188,219,85.84 -134,MTHD direct ns proc call,8,15,53.33 -135,MTHD imported ns proc call,8,16,50.00 -136,MTHD interp alias proc call,25,44,56.82 -137,MTHD indirect proc eval,36,58,62.07 -138,MTHD indirect proc eval #2,58,100,58.00 -139,MTHD array stored proc call,11,25,44.00 -140,MTHD switch method call,53,86,61.63 -141,MTHD ns lookup call,113,189,59.79 -142,MTHD inline call,3,9,33.33 -143,PROC explicit return,7,12,58.33 -144,PROC implicit return,7,17,41.18 -145,PROC explicit return (2),7,13,53.85 -146,PROC implicit return (2),7,15,46.67 -147,PROC explicit return (3),7,12,58.33 -148,PROC implicit return (3),7,12,58.33 -149,PROC heavily commented,7,12,58.33 -150,"PROC do-nothing; no args",6,11,54.55 -151,"PROC do-nothing; one arg",7,12,58.33 -152,PROC local links with global,1611,2827,56.99 -153,PROC local links with upvar,1308,2630,49.73 -154,PROC local links with variable,1309,2358,55.51 -155,"READ 595K; gets",386913,551429,70.17 -156,"READ 595K; read",85889,164758,52.13 -157,"READ 595K; read & size",86171,164854,52.27 -158,"READ 3050b; gets",2152,3481,61.82 -159,"READ 3050b; read",561,682,82.26 -160,"READ 3050b; read & size",606,738,82.11 -161,"BREAD 595K; gets",392519,568992,68.98 -162,"BREAD 595K; read",51133,110961,46.08 -163,"BREAD 595K; read & size",51194,110552,46.31 -164,"BREAD 3050b; gets",2213,3174,69.72 -165,"BREAD 3050b; read",329,472,69.70 -166,"BREAD 3050b; read & size",377,517,72.92 -167,REGEXP literal regexp,48,58,82.76 -168,REGEXP var-based regexp,51,60,85.00 -169,REGEXP count all matches,149,161,92.55 -170,REGEXP extract all matches,201,255,78.82 -171,STARTUP time to launch tclsh,26402,32329,81.67 -172,STR str [string compare],15,38,39.47 -173,STR str [string equal],15,38,39.47 -174,"STR str $a equal """"",13,32,40.62 -175,"STR str num == """"",15,38,39.47 -176,STR str $a eq $b,21,49,42.86 -177,STR str $a ne $b,21,49,42.86 -178,STR str $a eq $b (same obj),19,45,42.22 -179,STR str $a ne $b (same obj),19,46,41.30 -180,STR length (==4010),13,23,56.52 -181,STR index 0,19,30,63.33 -182,STR index 100,20,31,64.52 -183,STR index 500,19,30,63.33 -184,STR index2 0,20,32,62.50 -185,STR index2 100,21,30,70.00 -186,STR index2 500,20,31,64.52 -187,STR first (success),17,23,73.91 -188,STR first (failure),115,116,99.14 -189,STR first (total failure),106,103,102.91 -190,STR last (success),17,23,73.91 -191,STR last (failure),91,109,83.49 -192,STR last (total failure),82,86,95.35 -193,"STR match; simple (success early)",17,31,54.84 -194,"STR match; simple (success late)",18,30,60.00 -195,"STR match; simple (failure)",18,28,64.29 -196,"STR match; simple (total failure)",16,29,55.17 -197,"STR match; complex (success early)",18,34,52.94 -198,"STR match; complex (success late)",152,165,92.12 -199,"STR match; complex (failure)",121,134,90.30 -200,"STR match; complex (total failure)",95,101,94.06 -201,"STR range; index 100..200 of 4010",26,40,65.00 -202,"STR replace; no replacement",87,126,69.05 -203,"STR replace; equal replacement",93,133,69.92 -204,"STR replace; longer replacement",103,146,70.55 -205,"STR repeat; abcdefghij * 10",16,23,69.57 -206,"STR repeat; abcdefghij * 100",48,47,102.13 -207,"STR repeat; abcdefghij * 1000",231,257,89.88 -208,"STR repeat; 4010 chars * 10",282,744,37.90 -209,"STR repeat; 4010 chars * 100",6976,14673,47.54 -210,"STR reverse iter1; 100 chars",1534,2295,66.84 -211,"STR reverse iter1; 100 uchars",1457,2322,62.75 -212,"STR reverse iter2; 100 chars",1123,2042,55.00 -213,"STR reverse iter2; 100 uchars",1042,1972,52.84 -214,"STR reverse recur1; 100 chars",3458,7067,48.93 -215,"STR reverse recur1; 100 uchars",3523,6650,52.98 -216,"STR split; 4010 chars",2806,4605,60.93 -217,"STR split; 12100 uchars",7890,13813,57.12 -218,"STR split iter; 4010 chars",11129,28087,39.62 -219,"STR split iter; 12100 uchars",33318,86314,38.60 -220,STR append,99,160,61.88 -221,STR append (1KB + 1KB),95,134,70.90 -222,STR append (10KB + 1KB),209,537,38.92 -223,STR append (1MB + 2b * 1000),38681,190529,20.30 -224,STR append (1MB + 1KB),28344,173073,16.38 -225,STR append (1MB + 1KB * 20),29077,173622,16.75 -226,STR append (1MB + 1KB * 1000),66893,207868,32.18 -227,STR append (1MB + 1MB * 3),125505,327765,38.29 -228,STR append (1MB + 1MB * 5),158507,855295,18.53 -229,STR append (1MB + (1b + 1K + 1b) * 100),33101,174031,19.02 -230,STR info locals match,946,1521,62.20 -231,TRACE no trace set,34,121,28.10 -232,TRACE read,34,50,68.00 -233,TRACE write,33,50,66.00 -234,TRACE unset,33,48,68.75 -235,TRACE all set (rwu),34,52,65.38 -236,UNSET var exists,12,19,63.16 -237,UNSET catch var exists,13,23,56.52 -238,UNSET catch var !exist,77,105,73.33 -239,UNSET info check var exists,16,27,59.26 -240,UNSET info check var !exist,12,27,44.44 -241,UNSET nocomplain var exists,12,18,66.67 -242,UNSET nocomplain var !exist,12,16,75.00 -243,VAR access locally set,10,19,52.63 -244,VAR access local proc arg,10,20,50.00 -245,VAR access global,35,49,71.43 -246,VAR access upvar,40,54,74.07 -247,VAR set scalar,7,15,46.67 -248,VAR set array element,14,28,50.00 -249,VAR 100 'set's in array,161,272,59.19 -250,VAR 'array set' of 100 elems,306,467,65.52 DELETED modules/csv/pkgIndex.tcl Index: modules/csv/pkgIndex.tcl ================================================================== --- modules/csv/pkgIndex.tcl +++ /dev/null @@ -1,12 +0,0 @@ -# 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. - -if {![package vsatisfies [package provide Tcl] 8.3]} {return} -package ifneeded csv 0.3 [list source [file join $dir csv.tcl]] DELETED modules/des/ChangeLog Index: modules/des/ChangeLog ================================================================== --- modules/des/ChangeLog +++ /dev/null @@ -1,11 +0,0 @@ -2003-04-11 Andreas Kupries - - * des.tcl: Fixed bug #614591. - -2003-02-11 Pat Thoyts - - * des.tcl: Imported and tcllib-ised the DES package - from wiki page "DES in Tcl" by Jochen Loewer. NOT added to the - main package list as it requires CBC/CFB/OFB modes for real use. - * des.test: Modified the Trfcrypt DES test suite. - * des.man: Simple documentation - needs more. DELETED modules/des/des.man Index: modules/des/des.man ================================================================== --- modules/des/des.man +++ /dev/null @@ -1,54 +0,0 @@ -[manpage_begin des n 0.8.0] -[copyright {2003, Jochen C Loewer}] -[moddesc {Data Encryption Standard (DES)}] -[titledesc {Perform DES encryption of Tcl data}] -[require Tcl 8.3] -[require des 0.8] -[description] -[para] - -This is a Tcl implementation of the Data Encryption Standard (DES) -written by Jochen Loewer and based upon an implementation by Eric -Young. - -[para] - -NOTE: this version only implements the Electronic Code Book (ECB) mode -of DES. This is NOT suitable for general use encryption of large -blocks or streams of data. Until Cipher Block Chaining (CBC) or -Cipher/Output Feed Back (CFB / OFB) modes are implemented this should -not be considered for real encryption. The Trfcrypt package has -C-based implementations of these modes. - -[section COMMANDS] - -[list_begin definitions] -[call [cmd ::DES::des] -mode [arg encode|decode] -key [arg string] "(-file [arg filename] | [opt --] [arg string])"] - -Encode or decode a string or file. - -[list_end] - -[section EXAMPLES] -[para] - -[example { -% set ciphertext [DES::des -mode encode -key $secret $plaintext] -% set plaintext [DES::des -mode decode -key $secret $ciphertext] -}] - -[para] - -[example { -% set ciphertext [DES::des -mode encode -key $secret -file $filename] -% set f [open $filename.des w] ; puts -nonewline $ciphertext ; close $f -% set plaintext [DES::des -mode decode -key $secret -file $filename.des] -}] - - -[see_also md5(n) sha1(n) ] -[section AUTHORS] -Jochen C Loewer - -[keywords DES encryption {data integrity} security] -[manpage_end] DELETED modules/des/des.tcl Index: modules/des/des.tcl ================================================================== --- modules/des/des.tcl +++ /dev/null @@ -1,606 +0,0 @@ -#----------------------------------------------------------------------------- -# Copyright (C) 1999 Jochen C. Loewer (loewerj@hotmail.com,loewerj@web.de) -#----------------------------------------------------------------------------- -# -# A pure-Tcl DES implementation. -# -# -# -# This DES class has been extracted from package Acme.Crypto for use in VNC. -# The bytebit[] array has been reversed so that the most significant bit -# in each byte of the key is ignored, not the least significant. Also the -# unnecessary odd parity code has been removed. -# -# These changes are: -# Copyright (C) 1999 AT&T Laboratories Cambridge. All Rights Reserved. -# -# This software 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. -# -# DesCipher - the DES encryption method -# -# The meat of this code is by Dave Zimmerman , and is: -# -# Copyright (c) 1996 Widget Workshop, Inc. All Rights Reserved. -# -# Permission to use, copy, modify, and distribute this software -# and its documentation for NON-COMMERCIAL or COMMERCIAL purposes and -# without fee is hereby granted, provided that this copyright notice is kept -# intact. -# WIDGET WORKSHOP MAKES NO REPRESENTATIONS OR WARRANTIES ABOUT THE SUITABILITY -# OF THE SOFTWARE, EITHER EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED -# TO THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A -# PARTICULAR PURPOSE, OR NON-INFRINGEMENT. WIDGET WORKSHOP SHALL NOT BE LIABLE -# FOR ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR -# DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. -# -# THIS SOFTWARE IS NOT DESIGNED OR INTENDED FOR USE OR RESALE AS ON-LINE -# CONTROL EQUIPMENT IN HAZARDOUS ENVIRONMENTS REQUIRING FAIL-SAFE -# PERFORMANCE, SUCH AS IN THE OPERATION OF NUCLEAR FACILITIES, AIRCRAFT -# NAVIGATION OR COMMUNICATION SYSTEMS, AIR TRAFFIC CONTROL, DIRECT LIFE -# SUPPORT MACHINES, OR WEAPONS SYSTEMS, IN WHICH THE FAILURE OF THE -# SOFTWARE COULD LEAD DIRECTLY TO DEATH, PERSONAL INJURY, OR SEVERE -# PHYSICAL OR ENVIRONMENTAL DAMAGE ("HIGH RISK ACTIVITIES"). WIDGET WORKSHOP -# SPECIFICALLY DISCLAIMS ANY EXPRESS OR IMPLIED WARRANTY OF FITNESS FOR -# HIGH RISK ACTIVITIES. -# -# The rest is: -# -# Copyright (C) 1996 by Jef Poskanzer . All rights reserved. -# -# Redistribution and use in source and binary forms, with or without -# modification, are permitted provided that the following conditions -# are met: -# 1. Redistributions of source code must retain the above copyright -# notice, this list of conditions and the following disclaimer. -# 2. Redistributions in binary form must reproduce the above copyright -# notice, this list of conditions and the following disclaimer in the -# documentation and/or other materials provided with the distribution. -# -# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS `AS IS'' AND -# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE -# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF -# SUCH DAMAGE. -# -# Visit the ACME Labs Java page for up-to-date versions of this and other -# fine Java utilities: http:# www.acme.com/java/ -# -# -# -# $Log: des.tcl,v $ -# Revision 1.2 2003/04/11 18:55:43 andreas_kupries -# -# * des.tcl: Fixed bug #614591. -# -# Revision 1.1 2003/02/11 23:32:44 patthoyts -# Initial import of des package. -# -# -# -# written by Jochen Loewer -# January 17, 2002 -# -#----------------------------------------------------------------------------- - - -#----------------------------------------------------------------------------- -# usage: -# -# to encrypt a 8 byte block: -# -------------------------- -# -# DES::GetKey -encrypt encryptKeysArray -# DES::GetKey -encryptVNC encryptKeysArray -# -# set encryptedBlock [DES::DoBlock encryptKeysArray] -# -# -# to encrypt a 8 byte block: -# -------------------------- -# -# DES::GetKey -decrypt decryptKeysArray -# -# set plainText [DES::DoBlock decryptKeysArray] -# -#----------------------------------------------------------------------------- - - -## TODO: Check for weak keys: see http://www.cs.wm.edu/~hallyn/des/weak - -namespace eval ::DES { - - variable version 0.8.0 - - namespace export GetKey DesBlock - - #------------------------------------------------------------------------- - # setup lookup tables once - # - #------------------------------------------------------------------------- - foreach { varName values } { - bytebitOrig { 0x80 0x40 0x20 0x10 0x08 0x04 0x02 0x01 } - bytebitVNC { 0x01 0x02 0x04 0x08 0x10 0x20 0x40 0x80 } - bigbyte { - 0x800000 0x400000 0x200000 0x100000 - 0x080000 0x040000 0x020000 0x010000 - 0x008000 0x004000 0x002000 0x001000 - 0x000800 0x000400 0x000200 0x000100 - 0x000080 0x000040 0x000020 0x000010 - 0x000008 0x000004 0x000002 0x000001 - } - pc1 { - 56 48 40 32 24 16 8 - 0 57 49 41 33 25 17 - 9 1 58 50 42 34 26 - 18 10 2 59 51 43 35 - 62 54 46 38 30 22 14 - 6 61 53 45 37 29 21 - 13 5 60 52 44 36 28 - 20 12 4 27 19 11 3 - } - pc2 { - 13 16 10 23 0 4 - 2 27 14 5 20 9 - 22 18 11 3 25 7 - 15 6 26 19 12 1 - 40 51 30 36 46 54 - 29 39 50 44 32 47 - 43 48 38 55 33 52 - 45 41 49 35 28 31 - } - totrot { 1 2 4 6 8 10 12 14 15 17 19 21 23 25 27 28 } - SP1A { - 0x01010400 0x00000000 0x00010000 0x01010404 - 0x01010004 0x00010404 0x00000004 0x00010000 - 0x00000400 0x01010400 0x01010404 0x00000400 - 0x01000404 0x01010004 0x01000000 0x00000004 - 0x00000404 0x01000400 0x01000400 0x00010400 - 0x00010400 0x01010000 0x01010000 0x01000404 - 0x00010004 0x01000004 0x01000004 0x00010004 - 0x00000000 0x00000404 0x00010404 0x01000000 - 0x00010000 0x01010404 0x00000004 0x01010000 - 0x01010400 0x01000000 0x01000000 0x00000400 - 0x01010004 0x00010000 0x00010400 0x01000004 - 0x00000400 0x00000004 0x01000404 0x00010404 - 0x01010404 0x00010004 0x01010000 0x01000404 - 0x01000004 0x00000404 0x00010404 0x01010400 - 0x00000404 0x01000400 0x01000400 0x00000000 - 0x00010004 0x00010400 0x00000000 0x01010004 } - SP2A { - 0x80108020 0x80008000 0x00008000 0x00108020 - 0x00100000 0x00000020 0x80100020 0x80008020 - 0x80000020 0x80108020 0x80108000 0x80000000 - 0x80008000 0x00100000 0x00000020 0x80100020 - 0x00108000 0x00100020 0x80008020 0x00000000 - 0x80000000 0x00008000 0x00108020 0x80100000 - 0x00100020 0x80000020 0x00000000 0x00108000 - 0x00008020 0x80108000 0x80100000 0x00008020 - 0x00000000 0x00108020 0x80100020 0x00100000 - 0x80008020 0x80100000 0x80108000 0x00008000 - 0x80100000 0x80008000 0x00000020 0x80108020 - 0x00108020 0x00000020 0x00008000 0x80000000 - 0x00008020 0x80108000 0x00100000 0x80000020 - 0x00100020 0x80008020 0x80000020 0x00100020 - 0x00108000 0x00000000 0x80008000 0x00008020 - 0x80000000 0x80100020 0x80108020 0x00108000 } - SP3A { - 0x00000208 0x08020200 0x00000000 0x08020008 - 0x08000200 0x00000000 0x00020208 0x08000200 - 0x00020008 0x08000008 0x08000008 0x00020000 - 0x08020208 0x00020008 0x08020000 0x00000208 - 0x08000000 0x00000008 0x08020200 0x00000200 - 0x00020200 0x08020000 0x08020008 0x00020208 - 0x08000208 0x00020200 0x00020000 0x08000208 - 0x00000008 0x08020208 0x00000200 0x08000000 - 0x08020200 0x08000000 0x00020008 0x00000208 - 0x00020000 0x08020200 0x08000200 0x00000000 - 0x00000200 0x00020008 0x08020208 0x08000200 - 0x08000008 0x00000200 0x00000000 0x08020008 - 0x08000208 0x00020000 0x08000000 0x08020208 - 0x00000008 0x00020208 0x00020200 0x08000008 - 0x08020000 0x08000208 0x00000208 0x08020000 - 0x00020208 0x00000008 0x08020008 0x00020200 } - SP4A { - 0x00802001 0x00002081 0x00002081 0x00000080 - 0x00802080 0x00800081 0x00800001 0x00002001 - 0x00000000 0x00802000 0x00802000 0x00802081 - 0x00000081 0x00000000 0x00800080 0x00800001 - 0x00000001 0x00002000 0x00800000 0x00802001 - 0x00000080 0x00800000 0x00002001 0x00002080 - 0x00800081 0x00000001 0x00002080 0x00800080 - 0x00002000 0x00802080 0x00802081 0x00000081 - 0x00800080 0x00800001 0x00802000 0x00802081 - 0x00000081 0x00000000 0x00000000 0x00802000 - 0x00002080 0x00800080 0x00800081 0x00000001 - 0x00802001 0x00002081 0x00002081 0x00000080 - 0x00802081 0x00000081 0x00000001 0x00002000 - 0x00800001 0x00002001 0x00802080 0x00800081 - 0x00002001 0x00002080 0x00800000 0x00802001 - 0x00000080 0x00800000 0x00002000 0x00802080 } - SP5A { - 0x00000100 0x02080100 0x02080000 0x42000100 - 0x00080000 0x00000100 0x40000000 0x02080000 - 0x40080100 0x00080000 0x02000100 0x40080100 - 0x42000100 0x42080000 0x00080100 0x40000000 - 0x02000000 0x40080000 0x40080000 0x00000000 - 0x40000100 0x42080100 0x42080100 0x02000100 - 0x42080000 0x40000100 0x00000000 0x42000000 - 0x02080100 0x02000000 0x42000000 0x00080100 - 0x00080000 0x42000100 0x00000100 0x02000000 - 0x40000000 0x02080000 0x42000100 0x40080100 - 0x02000100 0x40000000 0x42080000 0x02080100 - 0x40080100 0x00000100 0x02000000 0x42080000 - 0x42080100 0x00080100 0x42000000 0x42080100 - 0x02080000 0x00000000 0x40080000 0x42000000 - 0x00080100 0x02000100 0x40000100 0x00080000 - 0x00000000 0x40080000 0x02080100 0x40000100 } - SP6A { - 0x20000010 0x20400000 0x00004000 0x20404010 - 0x20400000 0x00000010 0x20404010 0x00400000 - 0x20004000 0x00404010 0x00400000 0x20000010 - 0x00400010 0x20004000 0x20000000 0x00004010 - 0x00000000 0x00400010 0x20004010 0x00004000 - 0x00404000 0x20004010 0x00000010 0x20400010 - 0x20400010 0x00000000 0x00404010 0x20404000 - 0x00004010 0x00404000 0x20404000 0x20000000 - 0x20004000 0x00000010 0x20400010 0x00404000 - 0x20404010 0x00400000 0x00004010 0x20000010 - 0x00400000 0x20004000 0x20000000 0x00004010 - 0x20000010 0x20404010 0x00404000 0x20400000 - 0x00404010 0x20404000 0x00000000 0x20400010 - 0x00000010 0x00004000 0x20400000 0x00404010 - 0x00004000 0x00400010 0x20004010 0x00000000 - 0x20404000 0x20000000 0x00400010 0x20004010 } - SP7A { - 0x00200000 0x04200002 0x04000802 0x00000000 - 0x00000800 0x04000802 0x00200802 0x04200800 - 0x04200802 0x00200000 0x00000000 0x04000002 - 0x00000002 0x04000000 0x04200002 0x00000802 - 0x04000800 0x00200802 0x00200002 0x04000800 - 0x04000002 0x04200000 0x04200800 0x00200002 - 0x04200000 0x00000800 0x00000802 0x04200802 - 0x00200800 0x00000002 0x04000000 0x00200800 - 0x04000000 0x00200800 0x00200000 0x04000802 - 0x04000802 0x04200002 0x04200002 0x00000002 - 0x00200002 0x04000000 0x04000800 0x00200000 - 0x04200800 0x00000802 0x00200802 0x04200800 - 0x00000802 0x04000002 0x04200802 0x04200000 - 0x00200800 0x00000000 0x00000002 0x04200802 - 0x00000000 0x00200802 0x04200000 0x00000800 - 0x04000002 0x04000800 0x00000800 0x00200002 } - SP8A { - 0x10001040 0x00001000 0x00040000 0x10041040 - 0x10000000 0x10001040 0x00000040 0x10000000 - 0x00040040 0x10040000 0x10041040 0x00041000 - 0x10041000 0x00041040 0x00001000 0x00000040 - 0x10040000 0x10000040 0x10001000 0x00001040 - 0x00041000 0x00040040 0x10040040 0x10041000 - 0x00001040 0x00000000 0x00000000 0x10040040 - 0x10000040 0x10001000 0x00041040 0x00040000 - 0x00041040 0x00040000 0x10041000 0x00001000 - 0x00000040 0x10040040 0x00001000 0x00041040 - 0x10001000 0x00000040 0x10000040 0x10040000 - 0x10040040 0x10000000 0x00040000 0x10001040 - 0x00000000 0x10041040 0x00040040 0x10000040 - 0x10040000 0x10001000 0x10001040 0x00000000 - 0x10041040 0x00041000 0x00041000 0x00001040 - 0x00001040 0x00040040 0x10000000 0x10041000 } - } { - set i -1 - foreach v $values { set ${varName}([incr i]) [expr $v] } - } - - #------------------------------------------------------------------------- - # get internal keys for a later de-/encrypt phase - # - #------------------------------------------------------------------------- - proc GetKey { mode keyString keys_var } { - - upvar $keys_var keys - - # fill keyString up to at least 8 bytes (pad with NULL bytes!) - append keyString "\0\0\0\0\0\0\0\0" - binary scan $keyString c8 bytes - set i -1 - foreach b $bytes { - set keyBlock([incr i]) [expr { $b & 0x0ff }] - } - switch -- $mode { - -encrypt { - array set keys [makeInternalKeys keyBlock 1 0] - } - -encryptVNC { - array set keys [makeInternalKeys keyBlock 1 1] - } - -decrypt { - array set keys [makeInternalKeys keyBlock 0 0] - } - -decryptVNC { - array set keys [makeInternalKeys keyBlock 0 1] - } - default { - error "mode must be '-encrypt|-encryptVNC|-decrypt|-decryptVNC' !" - } - } - } - - #------------------------------------------------------------------------- - # appplies DES algorithm on a 8 byte block - # - #------------------------------------------------------------------------- - proc DesBlock { in keys_var } { - - upvar $keys_var keys - - if {[info tclversion] == "8.0"} { - set l [string length $in] - } else { - #set l [string bytelength $in] - set l [string length $in] - } - if {$l != 8} { - error "DES operates only on blocks of 8 bytes, but got $l bytes!" - } - binary scan $in II left right - return [binary format I* [desAlgorithm $left $right keys]] - } - - #------------------------------------------------------------------------- - # generate internal key array - # - #------------------------------------------------------------------------- - proc makeInternalKeys { keyBlock_var encDec useVNC } { - - upvar $keyBlock_var keyBlock - - variable pc1 - variable pc2 - variable totrot - variable bigbyte - variable bytebitOrig - variable bytebitVNC - - for { set j 0 } { $j < 56 } { incr j } { - set l $pc1($j) - set m [expr $l & 07] - if {$useVNC} { - set pc1m($j) [expr { ( ($keyBlock([expr {$l >> 3}]) & $bytebitVNC($m)) != 0 ) ? 1: 0 }] - } else { - set pc1m($j) [expr { ( ($keyBlock([expr {$l >> 3}]) & $bytebitOrig($m)) != 0 ) ? 1: 0 }] - } - } - for { set i 0 } { $i < 16 } { incr i } { - - set m [expr { $encDec ? ($i << 1) : ((15-$i) << 1) }] - set n [expr $m + 1] - set kn($m) 0 - set kn($n) 0 - for { set j 0 } { $j < 28 } { incr j } { - - set l [expr { $j + $totrot($i) }] - if { $l < 28 } { - set pcr($j) $pc1m($l) - } else { - set pcr($j) $pc1m([expr { $l - 28 }]) - } - } - for { set j 28 } { $j < 56 } { incr j } { - set l [expr { $j + $totrot($i) }] - if { $l < 56 } { - set pcr($j) $pc1m($l) - } else { - set pcr($j) $pc1m([expr { $l - 28 }]) - } - } - for { set j 0 } { $j < 24 } { incr j } { - if {$pcr($pc2($j)) != 0} { - set kn($m) [expr { $kn($m) | $bigbyte($j) }] - } - if {$pcr($pc2([expr $j+24])) != 0} { - set kn($n) [expr { $kn($n) | $bigbyte($j) }] - } - } - } - for { set i 0; set rawi 0; set KnLi 0 } { $i < 16 } { incr i } { - set raw0 $kn($rawi); incr rawi - set raw1 $kn($rawi); incr rawi - set KnL($KnLi) [expr { (($raw0 & 0x00fc0000) << 6) - |(($raw0 & 0x00000fc0) << 10) - |(($raw1 & 0x00fc0000) >> 10) - |(($raw1 & 0x00000fc0) >> 6) }] - incr KnLi - set KnL($KnLi) [expr { (($raw0 & 0x0003f000) << 12) - |(($raw0 & 0x0000003f) << 16) - |(($raw1 & 0x0003f000) >> 4) - |( $raw1 & 0x0000003f) }] - incr KnLi - } - return [array get KnL] - } - - - #------------------------------------------------------------------------- - # applies the DES algorithm to two 4 byte integers (8 byte block) - # using the internal de-/encrypt keys - # - #------------------------------------------------------------------------- - proc desAlgorithm { leftt right keys_var } { - - upvar $keys_var keys - - variable SP1A - variable SP2A - variable SP3A - variable SP4A - variable SP5A - variable SP6A - variable SP7A - variable SP8A - - set keysi 0 - - set work [expr { ((($leftt >> 4)&0x0fffffff) ^ $right) & 0x0f0f0f0f }] - set right [expr { $right ^ $work }] - set leftt [expr { $leftt ^ ($work << 4) }] - - set work [expr { ((($leftt >> 16)&0x0000ffff) ^ $right) & 0x0000ffff }] - set right [expr { $right ^ $work }] - set leftt [expr { $leftt ^ ($work << 16) }] - - set work [expr { ((($right >> 2)&0x3fffffff) ^ $leftt) & 0x33333333 }] - set leftt [expr { $leftt ^ $work }] - set right [expr { $right ^ ($work << 2) }] - - set work [expr { ((($right >> 8)&0x00ffffff) ^ $leftt) & 0x00ff00ff }] - set leftt [expr { $leftt ^ $work }] - set right [expr { $right ^ ($work << 8) }] - set right [expr { ($right << 1) | (($right >> 31) & 1) }] - - set work [expr { ($leftt ^ $right) & 0xaaaaaaaa }] - set leftt [expr { $leftt ^ $work }] - set right [expr { $right ^ $work }] - set leftt [expr { ($leftt << 1) | (($leftt >> 31) & 1) }] - - for { set round 0 } { $round < 8 } { incr round } { - set work [expr { ($right << 28) | (($right >> 4)&0x0fffffff) }] - set work [expr { $work ^ $keys($keysi) } ] - incr keysi - set fval [expr { $SP7A([expr { $work & 0x0000003f }]) - | $SP5A([expr { ($work >> 8) & 0x0000003f }]) - | $SP3A([expr { ($work >> 16) & 0x0000003f }]) - | $SP1A([expr { ($work >> 24) & 0x0000003f }]) }] - set work [expr { $right ^ $keys($keysi) }] - incr keysi - set fval [expr { $fval - | $SP8A([expr { $work & 0x0000003f }]) - | $SP6A([expr { ($work >> 8) & 0x0000003f }]) - | $SP4A([expr { ($work >> 16) & 0x0000003f }]) - | $SP2A([expr { ($work >> 24) & 0x0000003f }]) }] - set leftt [expr { $leftt ^ $fval }] - set work [expr { ($leftt << 28) | (($leftt >> 4)&0x0fffffff) }] - set work [expr { $work ^ $keys($keysi) }] - incr keysi - set fval [expr { $SP7A([expr { $work & 0x0000003f }]) - | $SP5A([expr { ($work >> 8) & 0x0000003f }]) - | $SP3A([expr { ($work >> 16) & 0x0000003f }]) - | $SP1A([expr { ($work >> 24) & 0x0000003f }]) }] - set work [expr { $leftt ^ $keys($keysi) }] - incr keysi - set fval [expr { $fval - | $SP8A([expr { $work & 0x0000003f }]) - | $SP6A([expr { ($work >> 8) & 0x0000003f }]) - | $SP4A([expr { ($work >> 16) & 0x0000003f }]) - | $SP2A([expr { ($work >> 24) & 0x0000003f }]) }] - set right [expr { $right ^ $fval }] - } - set right [expr { ($right << 31) | (($right >> 1)&0x7fffffff) }] - set work [expr { ($leftt ^ $right) & 0xaaaaaaaa }] - set leftt [expr { $leftt ^ $work }] - set right [expr { $right ^ $work }] - - set leftt [expr { ($leftt << 31) | (($leftt >> 1)&0x7fffffff) }] - - set work [expr { ((($leftt >> 8)&0x00ffffff) ^ $right) & 0x00ff00ff }] - set right [expr { $right ^ $work }] - set leftt [expr { $leftt ^ ($work << 8) }] - - set work [expr { ((($leftt >> 2)&0x3fffffff) ^ $right) & 0x33333333 }] - set right [expr { $right ^ $work }] - set leftt [expr { $leftt ^ ($work << 2) }] - - set work [expr { ((($right >> 16)&0x0000ffff) ^ $leftt) & 0x0000ffff }] - set leftt [expr { $leftt ^ $work }] - set right [expr { $right ^ ($work << 16) }] - - set work [expr { ((($right >> 4)&0x0fffffff) ^ $leftt) & 0x0f0f0f0f }] - set leftt [expr { ($leftt ^ $work) &0xffffffff }] - set right [expr { ($right ^ ($work << 4)) & 0xffffffff }] - - return [list $right $leftt] - } - -} - -# ------------------------------------------------------------------------- -# Description: -# Pop the nth element off a list. Used in options processing. -# -proc ::DES::Pop {varname {nth 0}} { - upvar $varname args - set r [lindex $args $nth] - set args [lreplace $args $nth $nth] - return $r -} - -# ------------------------------------------------------------------------- - -proc ::DES::des {args} { - array set opts [list filename {} mode {encode} key {I love Tcl!}] - while {[string match -* [lindex $args 0]]} { - switch -glob -- [lindex $args 0] { - -f* {set opts(filename) [Pop args 1]} - -m* {set opts(mode) [Pop args 1]} - -k* {set opts(key) [Pop args 1]} - -- {Pop args ; break } - default { - set err [join [lsort [array names opts]] ", -"] - return -code error "bad option [lindex $args 0]:\ - must be one of -$options" - } - } - Pop args - } - - # Build the key - switch -exact -- $opts(mode) { - encode { GetKey -encrypt $opts(key) key } - decode { GetKey -decrypt $opts(key) key } - default { - return -code error "bad option \"$opts(mode)\": \ - must be either \"encode\" or \"decode\"" - } - } - - set r {} - if {$opts(filename) != {}} { - set f [open $opts(filename) r] - fconfigure $f -translation binary - while {![eof $f]} { - set d [read $f 8] - if {[set n [string length $d]] < 8} { - append d [string repeat \0 [expr {8 - $n}]] - } - append r [DesBlock $d key] - } - close $f - } else { - set data [lindex $args 0] - if {[set n [expr {[string length $data] % 8}]] != 0} { - append data [string repeat \0 [expr {8 - $n}]] - } - for {set n 0} {$n < [string length $data]} {incr n 8} { - append r [DesBlock [string range $data $n [expr {$n + 7}]] key] - } - } - - return $r -} - -# ------------------------------------------------------------------------- - -package provide des $DES::version - -# ------------------------------------------------------------------------- -# -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: DELETED modules/des/des.test Index: modules/des/des.test ================================================================== --- modules/des/des.test +++ /dev/null @@ -1,170 +0,0 @@ -# -*- tcl -*- -# Commands covered: DES (Data Encryption Standard) -# -# This file contains a collection of tests for one or more of the commands -# the BLOB-X extension. Sourcing this file into Tcl runs the -# tests and generates output for errors. No output means no errors were -# found. -# -# Original Copyright (c) 1996 Andreas Kupries (a.kupries@westend.com) -# Modifications Copyright (c) 2003 Patrick Thoyts -# -# Modified from TrfCrypt tests -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# $Id: des.test,v 1.1 2003/02/11 23:32:45 patthoyts Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -package require des - -# ------------------------------------------------------------------------- - -catch {unset in out key} - -array set key { - 1 0000000000000000 - 2 FFFFFFFFFFFFFFFF - 3 3000000000000000 - 4 1111111111111111 - 5 0123456789ABCDEF - 6 1111111111111111 - 7 0000000000000000 - 8 FEDCBA9876543210 - 9 7CA110454A1A6E57 - 10 0131D9619DC1376E - 11 07A1133E4A0B2686 - 12 3849674C2602319E - 13 04B915BA43FEB5B6 - 14 0113B970FD34F2CE - 15 0170F175468FB5E6 - 16 43297FAD38E373FE - 17 07A7137045DA2A16 - 18 04689104C2FD3B2F - 19 37D06BB516CB7546 - 20 1F08260D1AC2465E - 21 584023641ABA6176 - 22 025816164629B007 - 23 49793EBC79B3258F - 24 4FB05E1515AB73A7 - 25 49E95D6D4CA229BF - 26 018310DC409B26D6 - 27 1C587F1C13924FEF - 28 0101010101010101 - 29 1F1F1F1F0E0E0E0E - 30 E0FEE0FEF1FEF1FE - 31 0000000000000000 - 32 FFFFFFFFFFFFFFFF - 33 0123456789ABCDEF - 34 FEDCBA9876543210 -} - -array set in { - 1 0000000000000000 - 2 FFFFFFFFFFFFFFFF - 3 1000000000000001 - 4 1111111111111111 - 5 1111111111111111 - 6 0123456789ABCDEF - 7 0000000000000000 - 8 0123456789ABCDEF - 9 01A1D6D039776742 - 10 5CD54CA83DEF57DA - 11 0248D43806F67172 - 12 51454B582DDF440A - 13 42FD443059577FA2 - 14 059B5E0851CF143A - 15 0756D8E0774761D2 - 16 762514B829BF486A - 17 3BDD119049372802 - 18 26955F6835AF609A - 19 164D5E404F275232 - 20 6B056E18759F5CCA - 21 004BD6EF09176062 - 22 480D39006EE762F2 - 23 437540C8698F3CFA - 24 072D43A077075292 - 25 02FE55778117F12A - 26 1D9D5C5018F728C2 - 27 305532286D6F295A - 28 0123456789ABCDEF - 29 0123456789ABCDEF - 30 0123456789ABCDEF - 31 FFFFFFFFFFFFFFFF - 32 0000000000000000 - 33 0000000000000000 - 34 FFFFFFFFFFFFFFFF -} - -array set out { - 1 8CA64DE9C1B123A7 - 2 7359B2163E4EDC58 - 3 958E6E627A05557B - 4 F40379AB9E0EC533 - 5 17668DFC7292532D - 6 8A5AE1F81AB8F2DD - 7 8CA64DE9C1B123A7 - 8 ED39D950FA74BCC4 - 9 690F5B0D9A26939B - 10 7A389D10354BD271 - 11 868EBB51CAB4599A - 12 7178876E01F19B2A - 13 AF37FB421F8C4095 - 14 86A560F10EC6D85B - 15 0CD3DA020021DC09 - 16 EA676B2CB7DB2B7A - 17 DFD64A815CAF1A0F - 18 5C513C9C4886C088 - 19 0A2AEEAE3FF4AB77 - 20 EF1BF03E5DFA575A - 21 88BF0DB6D70DEE56 - 22 A1F9915541020B56 - 23 6FBF1CAFCFFD0556 - 24 2F22E49BAB7CA1AC - 25 5A6B612CC26CCE4A - 26 5F4C038ED12B2E41 - 27 63FAC0D034D9F793 - 28 617B3A0CE8F07100 - 29 DB958605F8C8C606 - 30 EDBFD1C66C29CCC7 - 31 355550B2150E2451 - 32 CAAAAF4DEAF1DBAE - 33 D5D44FF720683D0D - 34 2A2BB008DF97C2F2 -} - - -foreach i [lsort [array names key]] { - test des-1.$i {des encryption (ECB)} { - set k [binary format H* $key($i)] - set p [binary format H* $in($i)] - set s [DES::des -mode encode -key $k $p] - binary scan $s H* h - string toupper $h - } $out($i) -} - -foreach i [lsort [array names key]] { - test des-2.$i {des decryption (ECB)} { - set k [binary format H* $key($i)] - set p [binary format H* $out($i)] - set s [DES::des -mode decode -key $k $p] - binary scan $s H* h - string toupper $h - } $in($i) -} - -# ------------------------------------------------------------------------- - -#catch {unset in out key} -::tcltest::cleanupTests - -# Local Variables: -# mode: tcl -# indent-tabs-mode: nil -# End: DELETED modules/des/pkgIndex.tcl Index: modules/des/pkgIndex.tcl ================================================================== --- modules/des/pkgIndex.tcl +++ /dev/null @@ -1,11 +0,0 @@ -# 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 des 0.8 [list source [file join $dir des.tcl]] DELETED modules/devtools/ChangeLog Index: modules/devtools/ChangeLog ================================================================== --- modules/devtools/ChangeLog +++ /dev/null @@ -1,4 +0,0 @@ -2003-04-09 Andreas Kupries - - * New module. - * First contents are support for sub-processes in testsuites. DELETED modules/devtools/README Index: modules/devtools/README ================================================================== --- modules/devtools/README +++ /dev/null @@ -1,18 +0,0 @@ - -Right now this module only contains code to make the handling of sub -processes from within a testsuite easier in general and of minimal -protocol server especially. Things which are not directly within in -the scope of the package "tcltest". - -The initial name for the module was 'testsupport'. This was changed to -'devtools' to allow the collection other code here too. Like for -example the generation of TEA 2 compatible configure scripts and -Makefiles. - -For now the contents are considered internal to tcllib and are neither -listed in the main makefile, nor do they have a package index file. So -even if the module and its code gets installed it won't be useable -without jumping through some hoops. - -The code is used in some of the tcllib testsuites. Well, one actually, -currently, "pop3". DELETED modules/devtools/microserv.tcl Index: modules/devtools/microserv.tcl ================================================================== --- modules/devtools/microserv.tcl +++ /dev/null @@ -1,135 +0,0 @@ -#- *- tcl -*- -# MicroServer (also MicroServant) -# aka muserv (mu = greek micron) -# -# Copyright (c) 2003 by Andreas Kupries - -# #################################################################### - -# Code for a simple server listening on one part for a connection and -# then performing a fixed sequence of responses, independent of the -# queries sent to it. This should make the testing of servers and -# clients for a particular protocol easier. Especially as this -# micro-server is better suited to push data tailored to generating -# boundary conditions on the other side of the connection than a true -# client/server for the protoco. - -# #################################################################### - -package require log - -namespace eval ::muserv { - variable port ; # Port to listen on for protocol connections. - variable responses ; # Script to run for a protocol connection. - variable sock ; # Channel of the protocol connection. - variable lastline ; # Last line received on the protocol connection. - variable ctrlsock ; # Channel of the control connection. - variable trace ; # Recorded trace of activity. -} - -# #################################################################### -# Public functionality - -# ::muserv::listen -- -# -# Setup the server to listen for a connection - -proc ::muserv::listen {theport theresponses} { - variable port $theport - variable responses $theresponses - set lsock [socket -server ::muserv::New $theport] - set port [lindex [fconfigure $lsock -sockname] end] - log::log debug "muserv | Listening on :: $port" - return $port -} - -proc ::muserv::control {control} { - variable ctrlsock $control - return -} - -proc ::muserv::control {control} { - variable ctrlsock $control - return -} - -proc ::muserv::gettrace {} { - variable ctrlsock - variable trace - - puts $ctrlsock [join $trace \n] - puts $ctrlsock __EOTrace__ - flush $ctrlsock - return -} - -# #################################################################### -# Private functionality - -# ::muserv::New -- -# -# Store the connection information and setup the dialog - -proc ::muserv::New {thesock addr port} { - variable sock $thesock - log::log debug "muserv | Connected :: $addr $port :: $sock" - after 0 ::muserv::Dialog - return -} - -# ::muserv::Dialog -- -# -# Run the pre-programmed responses on the connection - -proc ::muserv::Dialog {} { - variable responses - variable sock - - log::log debug "muserv | Dialog :: ..." - catch {eval $responses} - log::log debug "muserv | Dialog :: ... done" - catch {close $sock} - set sock "" - log::log debug "muserv | Connection :: Closed" - return -} - -# #################################################################### -# Low-level interaction and configuration commands - -proc ::muserv::__Trace {line} { - variable trace - log::log debug "muserv | Logging ____ :: == $line" - lappend trace $line - return -} -proc ::muserv::__Send {line} { - log::log debug "muserv | Sending ____ :: >> $line" - variable sock ; puts $sock $line ; flush $sock - return -} -proc ::muserv::__Wait {} { - variable lastline - variable sock ; gets $sock line ; set lastline $line - log::log debug "muserv | Received ___ :: << $line" - return -} -proc ::muserv::__Reconfigure {args} { - log::log debug "muserv | Reconfigure :: [join $args]" - variable sock ; eval fconfigure $sock $args - return -} -proc ::muserv::__Got {} {variable lastline ; __Trace $lastline} - -# #################################################################### -# Semi-public functionality: Commands available to program the dialog. - -proc ::muserv::CrLf {} {__Reconfigure -translation crlf ; return} -proc ::muserv::Binary {} {__Reconfigure -translation binary ; return} -proc ::muserv::Send {line} { __Send $line ; return} -proc ::muserv::Respond {line} {__Wait ; __Send $line ; return} -proc ::muserv::Wait {} {__Wait ; return} -proc ::muserv::RespondLog {line} {__Wait ; __Got ; __Send $line ; return} -proc ::muserv::WaitLog {} {__Wait ; __Got ; return} - -# #################################################################### DELETED modules/devtools/musub.tcl Index: modules/devtools/musub.tcl ================================================================== --- modules/devtools/musub.tcl +++ /dev/null @@ -1,97 +0,0 @@ -#!/bin/sh -# -*- tcl -*- \ -exec tclsh "$0" ${1+"$@"} - -# Generic framework for a microserv.tcl based server/ -# -# Copyright (c) 2003 by Andreas Kupries - -# A server using this framework can be controlled through a socket -# connection they open to a listening socket which was opened by the -# creator of the server. The port to connect to is provided in the -# variable 'ctrlport'. -# -# The port the server will be listening on is specified through the -# contents of the variable 'port'. The actual port chosen is written -# to the control connection, as the first information. This also -# serves as a signal that the server is ready. -# -# The server will exit when the control connection is closed by the -# spawning process. -# -# | data to be set by the creator of a full server. -# | -# logfile | -# port | -# responses | -# ctrlport | - -# ########################################################## -# Setup logging -# Prevent log messages for now, or log into server log. - -set log [open $logfile w] -fconfigure $log -buffering none -proc log {txt} {global log ; puts $log $txt} -proc log__ {l t} {log "$l $t"} - -log__ debug "musub | framework entered" - -package require log ; # tcllib | logging -::log::lvCmdForall log__ -#::log::lvSuppress info -#::log::lvSuppress notice -#::log::lvSuppress debug -#::log::lvSuppress warning - -log__ debug "musub | logging activated" - -# ########################################################## -# Handle activity on the control connection -# - closing => exit server -# - read single line, evaluate command in that line ! trusted - -proc done {chan} { - if {[eof $chan]} { - log__ debug "musub | shutdown through caller, control connection was closed" - exit - } - - set n [gets $chan line] - log__ debug "musub | gets = $n ($line)" - - if {$n < 0} {return} - set line [string trim $line] - if {$line == {}} {return} - - log__ debug "musub | eval ($line)" - uplevel #0 $line - return -} - -# ########################################################## -# Setup the control connection. - -set control [socket localhost $ctrlport] -fileevent $control readable [list done $control] -fconfigure $control -blocking 0 - -muserv::control $control - -log__ debug "musub | control connection up" - -# ########################################################## -# Start server ... -# If the incoming port number is 0 the return value -# will contain the actual port the server is listening on. - -set port [muserv::listen $port $responses] -puts $control $port -flush $control - -log__ debug "musub | server ready and waiting ..." - -vwait __forever__ -log__ debug "musub | reached infinity, closing :)" -exit - DELETED modules/devtools/subserv.tcl Index: modules/devtools/subserv.tcl ================================================================== --- modules/devtools/subserv.tcl +++ /dev/null @@ -1,168 +0,0 @@ -# -*- tcl -*- -# Sub-servers, subservient -# -# Copyright (c) 2003 by Andreas Kupries - -# #################################################################### - -# Code for the easy creation of sub-processes from a testsuite to -# perform some actions on behalf of it. General sub-processes and -# socket servers, the latter are based on "microserv.tcl". - -# #################################################################### - -namespace eval ::subserv { - set here [file dirname [info script]] ; # To find muserv.tcl - - variable mPipe ; set mPipe "" - variable mCtrl ; set mCtrol 0 - variable mLog ; set mLog "" -} - -package require log ; # tracing | tcllib - -# #################################################################### -# API - -# ::subserv::pipe -- -# -# Start a generic sub-process, controllable by its pipe. - -proc ::subserv::pipe {pathToScriptFile} { - log::log debug "subserv | pipe | $pathToScriptFile" - global tcl_platform - switch -exact $tcl_platform(platform) { - windows {return [open "|\"[info nameofexecutable]\" $pathToScriptFile" r+]} - default {return [open "|[info nameofexecutable] $pathToScriptFile" r+]} - } -} - -# ::subserv::exec -- -# -# Start a generic sub-process, via plain exec, asked to listen on port for -# control commands. - -proc ::subserv::exec {pathToScriptFile port} { - global tcl_platform - exec [info nameofexecutable] $pathToScriptFile $port & - after 100 - return [socket localhost $port] -} - -# ::subserv::muserv -- -# -# Create a micro server which can be run later. - -proc ::subserv::muserv {pathToScriptFile ctrlport port responses} { - variable here - - log::log debug "subserv | muserv | $pathToScriptFile $ctrlport $port [llength $responses]" - - catch {file delete -force $pathToScriptFile} - set script [open $pathToScriptFile w] - - puts $script "" - puts $script "# -----------------------------------------------" - puts $script "# Configuration of \"musub.tcl\"" - puts $script "" - puts $script [list set logfile $pathToScriptFile.log] - puts $script [list set port $port] - puts $script [list set responses $responses] - puts $script [list set ctrlport $ctrlport] - puts $script "" - puts $script "# -----------------------------------------------" - puts $script "" - - set in [open [file join $here microserv.tcl] r] - fcopy $in $script - close $in - set in [open [file join $here musub.tcl] r] - fcopy $in $script - close $in - close $script - return -} - -# ::subserv::muservSpawn -- -# -# Create a micro server and run it immediately. - -proc ::subserv::muservSpawn {pathToScriptFile port responses} { - variable mPipe - variable mCtrl - - log::log debug "subserv | muserv spawn | $pathToScriptFile $port [llength $responses]" - - set lsock [socket -server ::subserv::muservCtrl 0] - set ctrlport [lindex [fconfigure $lsock -sockname] end] - - log::log debug "subserv | muserv spawn | control on $ctrlport" - - muserv $pathToScriptFile $ctrlport $port $responses - - muservStop - set mPipe [pipe $pathToScriptFile] - - log::log debug "subserv | muserv spawn | pipe on $mPipe" - - vwait ::subserv::mCtrl - set port [gets $mCtrl] - - log::log debug "subserv | muserv spawn | server waiting on $port" - - return $port -} - -proc ::subserv::muservCtrl {thesock addr port} { - variable mCtrl $thesock - log::log debug "subserv | muserv ctrl | $addr $port :: $mCtrl" - return -} - -# ::subserv::muservStop -- -# -# Stop a running micro server - -proc ::subserv::muservStop {} { - variable mPipe - variable mCtrl - - if {$mPipe == {}} {return} - - log::log debug "subserv | muserv stop | request" - - catch {close $mCtrl} - catch {close $mPipe} - - log::log debug "subserv | muserv stop | done" - - after 100 ; # sleep for a 1/10th second to make sure it is gone. - set mPipe {} - return -} - -# ::subserv::muservLog -- -# -# Get a trace from the micro server - -proc ::subserv::muservLog {} { - variable mCtrl - - log::log debug "subserv | muserv log | request" - - puts $mCtrl ::muserv::gettrace - flush $mCtrl - - log::log debug "subserv | muserv log | collect" - - set res [list] - while {1} { - gets $mCtrl line - log::log debug "subserv | muserv log | __ $line" - if {[string equal __EOTrace__ $line]} {break} - lappend res $line - } - - log::log debug "subserv | muserv log | ok" - return $res -} DELETED modules/dns/ChangeLog Index: modules/dns/ChangeLog ================================================================== --- modules/dns/ChangeLog +++ /dev/null @@ -1,78 +0,0 @@ -2003-04-14 Pat Thoyts - - * dns.tcl: Added error message to the timeout. - * resolv.tcl: incorporated some of Emmanuel's updated code. - -2003-04-12 Pat Thoyts - - * dns.man: *Renamed* to tcllib_dns.man to avoid a name clash with - the dns manpage from the scotty package. - -2003-04-11 Pat Thoyts - - * dns.tcl: Try to read the whole reply when using tcp. Added a - catch to avoid bgerrors within the handler. - * dns.tcl: - * dns.man: - * pkgIndex.tcl: hiked version to 1.0.4 - -2003-04-11 Andreas Kupries - - * dns.tcl: - * dns.man: - * pkgIndex.tcl: Fixed bug #614591. Set version of the package to - to 1.0.3 throughout. Added package 'resolv' to index. - -2003-03-04 Pat Thoyts - - * dns.tcl: converted from the log package to logger. Enable UDP as - the default if available. - -2003-02-27 Pat Thoyts - - * resolv.tcl: Imported Emmanuel Frecon's code from the Tclers - Wiki. Provides a name cache and simplifies usage of the dns - package. - -2003-02-25 Pat Thoyts - - * dns.tcl: Tested the UDP transmission using a fixed TclUDP. - * dns.tcl: Implemented inverse queries. (Pretty useless though). - * dns.tcl: Added errorcode procedure. - -2003-01-30 Pat Thoyts - - * dns.tcl: Implemented UDP transmission. Currently not tested - because tcludp doesn't handle binary data. - -2003-01-24 Pat Thoyts - - * pkgIndex.tcl: - * dns.man: Added Tcl 8.2 as minimum Tcl version to resolve bug - * dns.tcl: #674330. Upped version to 1.0.2 - * dns.test: Added some tests for the dns uri handling and fixed a - bug in decoding the class and type section. - -2003-01-16 Andreas Kupries - - * dns.man: More semantic markup, less visual one. - -2002-08-30 Andreas Kupries - - * dns.tcl: Updated 'info exist' to 'info exists'. - -2002-06-07 Andreas Kupries - - * dns.man: - * dns.tcl: - * pkgIndex.tcl: Version up to 1.0.1 - - * dns.tcl: moved var initialization code to the end, as it uses - the 'dns::configure' command, and thus should be called after - its definition. This is the reason for bug #564670, thus now - fixed. - -2002-06-05 Andreas Kupries - - * dns.man: Added note to manpage regarding DNS via TCP and - possible pitfalls. DELETED modules/dns/dns-url.txt Index: modules/dns/dns-url.txt ================================================================== --- modules/dns/dns-url.txt +++ /dev/null @@ -1,448 +0,0 @@ - - -Network Working Group S. Josefsson -Internet-Draft RSA Security -Expires: March 29, 2002 September 28, 2001 - - - DNS URI scheme - draft-josefsson-dns-url - -Status of this Memo - - This document is an Internet-Draft and is in full conformance with - all provisions of Section 10 of RFC2026. - - Internet-Drafts are working documents of the Internet Engineering - Task Force (IETF), its areas, and its working groups. Note that - other groups may also distribute working documents as - Internet-Drafts. - - Internet-Drafts are draft documents valid for a maximum of six - months and may be updated, replaced, or obsoleted by other documents - at any time. It is inappropriate to use Internet-Drafts as reference - material or to cite them other than as "work in progress." - - The list of current Internet-Drafts can be accessed at - http://www.ietf.org/ietf/1id-abstracts.txt. - - The list of Internet-Draft Shadow Directories can be accessed at - http://www.ietf.org/shadow.html. - - This Internet-Draft will expire on March 29, 2002. - - Distribution of this document is unlimited. Comments and - suggestions on this document are encouraged. The key words 'MUST', - 'MUST NOT', 'REQUIRED', 'SHALL', 'SHALL NOT', 'SHOULD', 'SHOULD - NOT', 'RECOMMENDED', 'MAY', and 'OPTIONAL' in this document are to - be interpreted as described in RFC 2119 [3]. - -Copyright Notice - - Copyright (C) The Internet Society (2001). All Rights Reserved. - -Abstract - - This draft describes a URI scheme to locate DNS resources. - - - - - - - - -Josefsson Expires March 29, 2002 [Page 1] - -Internet-Draft DNS URI scheme September 2001 - - -Table of Contents - - 1. Introduction and Background . . . . . . . . . . . . . . . . . 3 - 2. URI Scheme . . . . . . . . . . . . . . . . . . . . . . . . . . 3 - 3. URI Scheme Syntax . . . . . . . . . . . . . . . . . . . . . . 3 - 4. Character Encoding Considerations . . . . . . . . . . . . . . 4 - 5. Intended Usage . . . . . . . . . . . . . . . . . . . . . . . . 4 - 6. Applications and/or Protocols Using This Scheme . . . . . . . 4 - 7. Interoperability Considerations . . . . . . . . . . . . . . . 4 - 8. Security Considerations . . . . . . . . . . . . . . . . . . . 4 - 9. IANA Considerations . . . . . . . . . . . . . . . . . . . . . 5 - 10. Examples . . . . . . . . . . . . . . . . . . . . . . . . . . . 5 - Author's Address . . . . . . . . . . . . . . . . . . . . . . . 6 - References . . . . . . . . . . . . . . . . . . . . . . . . . . 5 - A. IANA URI Registration Template . . . . . . . . . . . . . . . . 6 - Full Copyright Statement . . . . . . . . . . . . . . . . . . . 8 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Josefsson Expires March 29, 2002 [Page 2] - -Internet-Draft DNS URI scheme September 2001 - - -1. Introduction and Background - - DNS [1][2] is a widely deployed protocol used to, among other - things, translate domain names into IP addresses. More recent work - has added support for storing cryptographic keys and certificates in - DNS [6][7]. To be able to locate, for example, certificates via a - network resource, URIs are often used. This document describes a - URI scheme to locate DNS information. The DNS URI scheme described - here can be used to reference any DNS data, not only certificates. - - The following sections are modelled after the Registration Template - in [8]. The template can be found in Appendix A. - -2. URI Scheme - - The name of the URI scheme defined in this document is "dns". - - A DNS URI designates a DNS resource record: By domain name, type and - class and optionally server. The DNS URI follows the generic syntax - from RFC 2396 [5], and is described using ABNF [4] in section 3. - - A DNS URI is of the following general form. This is intended to - illustrate, not define, the scheme. - - dns:[//server/]domain[?type=TYPE;class=CLASS] - -3. URI Scheme Syntax - - Strings are not case sensitive and free insertion of - linear-white-space is not permitted. - - dnsurl = "dns:" [ "//" hostport "/" ] dnsname ["?" query] - ; See RFC 2396 for "hostport" definition - - domainname = uric - ; See RFC 2396 for "uric" definition - - query = queryelement [";" query] - - queryelement = ( "CLASS=" classval ) | ( "TYPE=" typeval ) | - ( 1*alphanum "=" 1*alphanum ) - - classval = 1*digit / "IN" / "CH" / ... - ; Any standard DNS class expressed as - ; mnemonic or as decimal integer - - typeval = 1*digit / "A" / "NS" / "MD" / ... - ; Any standard DNS type expressed as - ; mnemonic or as decimal integer - - -Josefsson Expires March 29, 2002 [Page 3] - -Internet-Draft DNS URI scheme September 2001 - - - The digit representation of types and classes SHOULD NOT be used - when a defined mnemonic for the corresponding value is known. - - Of the "reserved" characters in the "dnsname" element, the "?" - character MUST be escaped, the rest MAY be escaped. Otherwise, it - would be impossible to separate a domain name containing "?" from - the "query" delimiter. - - Unless specified, the "server" is assumed to be locally - (pre-)configured, and "class" to be the Internet class ("IN"), and - "type" to be the Address (A) type. - - To resolve a DNS URI using the DNS protocol [2] a query is formed by - using the domainname, classval and typeval from the URI string (or - the previously mentioned default values if either classval or - typeval is missing from the string). If hostport is given in the - URI string, this server should receive the DNS query, otherwise the - default DNS server should receive it. - -4. Character Encoding Considerations - - The characters in the URI, in particular the "dnsname", MUST be - encoded as per the "URI Generic Syntax" RFC [5]. - - This URI specification allows all possible DNS names to be encoded - (of course following the encoding rules of [5]), however certain - applications may restrict the set of valid characters and care - should be taken so that invalid characters in these contexts does - not cause harm. In particular, hostnames in DNS often have certain - restrictions. It is up to these application to limit this subset, - this URI scheme places no restrictions. - -5. Intended Usage - - Broad usage. - -6. Applications and/or Protocols Using This Scheme - - E.g. CNRP. - -7. Interoperability Considerations - - The data referenced by this URI scheme might be transferred by - protocols that aren't URI aware (such as the DNS protocol). This is - not anticipated to have any serious interoperability impact though. - -8. Security Considerations - - A DNS URI does not embed confidential information. If it references - - -Josefsson Expires March 29, 2002 [Page 4] - -Internet-Draft DNS URI scheme September 2001 - - - domains in the Internet DNS environment, even the information - referenced by the URI is public information. If a DNS URI is used - within an "internal" DNS environment, the same security - considerations of the DNS environment apply to the use and handling - of DNS URIs themselves as well as the data returned by looking up - these URIs. - - If security related information is referenced by DNS URIs (such as - certificates stored in DNS), care must be taken to prevent for - man-in-the-middle attacks that maliciously replace the certificate. - Techniques such as Secure DNS may be used. - - This draft does not affect the security considerations related to - DNS itself. - -9. IANA Considerations - - The IANA is asked to register the DNS URI scheme using this document - as the template in accordance with RFC 2717 [8]. - -10. Examples - - The following illustrate a DNS query for "www.example.org" for the - Internet (IN) class and the Address (A) type: - - dns:www.example.org?class=IN;type=A - - The following illustrate a DNS query for "simon.example.org" for the - CERT type in the Internet (IN) class: - - dns:simon.example.org?type=CERT - - The following illustrate a DNS query for "ftp.example.org" from the - DNS server "internal-dns.example.org" server, in the Internet (IN) - class and the address (A) type: - - dns://internal-dns.example.org/ftp.example.org?type=A - - The following illustrate a strange, albeit valid, DNS query: - - dns://internal-dns.example.org/*.%3f%20 %00%25+?type=TXT - -Acknowledgement - - Thanks to Michael Mealling, Steve Mattson and Stuart Cheshire for - comments. - -References - - - -Josefsson Expires March 29, 2002 [Page 5] - -Internet-Draft DNS URI scheme September 2001 - - - [1] Mockapetris, P., "Domain Names - Concepts and Facilities", RFC - 1034, November 1987. - - [2] Mockapetris, P., "Domain Names - Implementation and - Specification", RFC 1035, November 1987. - - [3] Bradner, S., "Key words for use in RFCs to Indicate Requirement - Levels", RFC 2119, March 1997. - - [4] Crocker, D. and P. Overell, "Augmented BNF for Syntax - Specifications: ABNF", RFC 2234, November 1997. - - [5] Berners-Lee, T., Fielding, R. and L. Masinter, "Uniform - Resource Identifiers (URI): Generic Syntax", RFC 2396, August - 1998. - - [6] Eastlake, D., "Domain Name System Security Extensions", RFC - 2535, March 1999. - - [7] Eastlake, D. and O. Gudmundsson, "Storing Certificates in the - Domain Name System (DNS)", RFC 2538, March 1999. - - [8] Petke, R. and I. King, "Registration Procedures for URL Scheme - Names", RFC 2717, November 1999. - - -Author's Address - - Simon Josefsson - RSA Security - Arenavägen 29 - Stockholm 121 29 - Sweden - - Phone: +46 8 7250914 - EMail: sjosefsson@rsasecurity.com - -Appendix A. IANA URI Registration Template - - URL scheme name: dns - - URL scheme syntax: Section 3 - - Character encoding considerations: Section 4 - - Intended usage: Section 5 - - Applications and/or protocols which use this scheme: Section 5. - - - -Josefsson Expires March 29, 2002 [Page 6] - -Internet-Draft DNS URI scheme September 2001 - - - Interoperability considerations: Section 7. - - Security considerations: Section 8 - - Contact: sjosefsson@rsasecurity.com - - Author/Change Controller: IESG - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Josefsson Expires March 29, 2002 [Page 7] - -Internet-Draft DNS URI scheme September 2001 - - -Full Copyright Statement - - Copyright (C) The Internet Society (2001). All Rights Reserved. - - This document and translations of it may be copied and furnished to - others, and derivative works that comment on or otherwise explain it - or assist in its implementation may be prepared, copied, published - and distributed, in whole or in part, without restriction of any - kind, provided that the above copyright notice and this paragraph - are included on all such copies and derivative works. However, this - document itself may not be modified in any way, such as by removing - the copyright notice or references to the Internet Society or other - Internet organizations, except as needed for the purpose of - developing Internet standards in which case the procedures for - copyrights defined in the Internet Standards process must be - followed, or as required to translate it into languages other than - English. - - The limited permissions granted above are perpetual and will not be - revoked by the Internet Society or its successors or assigns. - - This document and the information contained herein is provided on an - "AS IS" basis and THE INTERNET SOCIETY AND THE INTERNET ENGINEERING - TASK FORCE DISCLAIMS ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING - BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE INFORMATION - HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF - MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. - - - - - - - - - - - - - - - - - - - - - - - - -Josefsson Expires March 29, 2002 [Page 8] - DELETED modules/dns/dns.tcl Index: modules/dns/dns.tcl ================================================================== --- modules/dns/dns.tcl +++ /dev/null @@ -1,1095 +0,0 @@ -# dns.tcl - Copyright (C) 2002 Pat Thoyts -# -# Provide a Tcl only Domain Name Service client. See RFC 1034 and RFC 1035 -# for information about the DNS protocol. This should insulate Tcl scripts -# from problems with using the system library resolver for slow name servers. -# -# This implementation uses TCP only for DNS queries. The protocol reccommends -# that UDP be used in these cases but Tcl does not include UDP sockets by -# default. The package should be simple to extend to use a TclUDP extension -# in the future. -# -# TODO: -# - When using tcp we should make better use of the open connection and -# send multiple queries along the same connection. -# -# ------------------------------------------------------------------------- -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# ------------------------------------------------------------------------- -# -# $Id: dns.tcl,v 1.13 2003/04/13 23:04:00 patthoyts Exp $ - -package require Tcl 8.2; # tcl minimum version -package require logger; # tcllib 1.3 -package require uri; # tcllib 1.1 -package require uri::urn; # tcllib 1.2 - -namespace eval ::dns { - variable version 1.0.4 - variable rcsid {$Id: dns.tcl,v 1.13 2003/04/13 23:04:00 patthoyts Exp $} - - namespace export configure resolve name address cname \ - status reset wait cleanup errorcode - - variable options - if {![info exists options]} { - array set options { - port 53 - timeout 30000 - protocol tcp - search {} - nameserver {localhost} - loglevel warn - } - variable log [logger::init dns] - ${log}::enable $options(loglevel) - } - - if {![catch {package require udp 1.0.4} msg]} { ;# tcludp 1.0.4+ - # If TclUDP 1.0.4 or better is available, use it. - set options(protocol) udp - } - - variable types - array set types { - A 1 NS 2 MD 3 MF 4 CNAME 5 SOA 6 MB 7 MG 8 MR 9 - NULL 10 WKS 11 PTR 12 HINFO 13 MINFO 14 MX 15 TXT 16 - AXFR 252 MAILB 253 MAILA 254 * 255 - } - - variable classes - array set classes { IN 1 CS 2 CH 3 HS 4 * 255} - - variable uid - if {![info exists uid]} { - set uid 0 - } -} - -# ------------------------------------------------------------------------- - -# Description: -# Configure the DNS package. In particular the local nameserver will need -# to be set. With no options, returns a list of all current settings. -# -proc ::dns::configure {args} { - variable options - variable log - - if {[llength $args] < 1} { - set r {} - foreach opt [lsort [array names options]] { - lappend r -$opt $options($opt) - } - return $r - } - - set cget 0 - if {[llength $args] == 1} { - set cget 1 - } - - while {[string match -* [lindex $args 0]]} { - switch -glob -- [lindex $args 0] { - -n* - - -ser* { - if {$cget} { - return $options(nameserver) - } else { - set options(nameserver) [Pop args 1] - } - } - -po* { - if {$cget} { - return $options(port) - } else { - set options(port) [Pop args 1] - } - } - -ti* { - if {$cget} { - return $options(timeout) - } else { - set options(timeout) [Pop args 1] - } - } - -pr* { - if {$cget} { - return $options(protocol) - } else { - set proto [string tolower [Pop args 1]] - if {[string compare udp $proto] == 0 \ - && [string compare tcp $proto] == 0} { - return -code error "invalid protocol \"$proto\":\ - protocol must be either \"udp\" or \"tcp\"" - } - set options(protocol) $proto - } - } - -sea* { - if {$cget} { - return $options(search) - } else { - set options(search) [Pop args 1] - } - } - -log* { - if {$cget} { - return $options(loglevel) - } else { - set options(loglevel) [Pop args 1] - ${log}::enable $options(loglevel) - } - } - -- { Pop args ; break } - default { - set opts [join [lsort [array names options]] ", -"] - return -code error "bad option [lindex $args 0]:\ - must be one of -$opts" - } - } - Pop args - } - - return -} - -# ------------------------------------------------------------------------- - -# Description: -# Create a DNS query and send to the specified name server. Returns a token -# to be used to obtain any further information about this query. -# -proc ::dns::resolve {query args} { - variable uid - variable options - variable log - - # get a guaranteed unique and non-present token id. - set id [incr uid] - while {[info exists [set token [namespace current]::$id]]} { - set id [incr uid] - } - variable $token - upvar 0 $token state - - # Setup token/state defaults. - set state(id) $id - set state(query) $query - set state(opcode) 0; # 0 = query, 1 = inverse query. - set state(-type) A; # DNS record type (A address) - set state(-class) IN; # IN (internet address space) - set state(-recurse) 1; # Recursion Desired - set state(-command) {}; # asynchronous handler - set state(-timeout) $options(timeout); # connection timeout default. - set state(-nameserver) $options(nameserver);# default nameserver - set state(-port) $options(port); # default namerservers port - set state(-search) $options(search); # domain search list - set state(-protocol) $options(protocol); # which protocol udp/tcp - - # Handle DNS URL's - if {[string match "dns:*" $query]} { - array set URI [uri::split $query] - foreach {opt value} [uri::split $query] { - if {$value != {} && [info exists state(-$opt)]} { - set state(-$opt) $value - } - } - set state(query) $URI(query) - ${log}::debug "parsed query: $query" - } - - while {[string match -* [lindex $args 0]]} { - switch -glob -- [lindex $args 0] { - -n* - ns - - -ser* { set state(-nameserver) [Pop args 1] } - -po* { set state(-port) [Pop args 1] } - -ti* { set state(-timeout) [Pop args 1] } - -co* { set state(-command) [Pop args 1] } - -cl* { set state(-class) [Pop args 1] } - -ty* { set state(-type) [Pop args 1] } - -pr* { set state(-protocol) [Pop args 1] } - -sea* { set state(-search) [Pop args 1] } - -re* { set state(-recurse) [Pop args 1] } - -inv* { set state(opcode) 1 } - -status {set state(opcode) 2} - default { - set opts [join [lsort [array names state -*]] ", "] - return -code error "bad option [lindex $args 0]: \ - must be $opts" - } - } - Pop args - } - - if {$state(-nameserver) == {}} { - return -code error "no nameserver specified" - } - - if {$state(-protocol) == "udp"} { - if {[package provide udp] == {}} { - return -code error "udp support is not available, get tcludp" - } - } - - BuildMessage $token - - if {$state(-protocol) == "tcp"} { - TcpTransmit $token - if {$state(-command) == {}} { - wait $token - } - } else { - UdpTransmit $token - } - - return $token -} - -# ------------------------------------------------------------------------- - -# Description: -# Return a list of domain names returned as results for the last query. -# -proc ::dns::name {token} { - set r {} - Flags $token flags - array set reply [Decode $token] - - switch -exact -- $flags(opcode) { - 0 { - # QUERY - foreach answer $reply(AN) { - array set AN $answer - if {![info exists AN(type)]} {set AN(type) {}} - switch -exact -- $AN(type) { - MX - NS { - if {[info exists AN(rdata)]} {lappend r $AN(rdata)} - } - default { - if {[info exists AN(name)]} { - lappend r $AN(name) - } - } - } - } - } - - 1 { - # IQUERY - foreach answer $reply(QD) { - array set QD $answer - lappend r $QD(name) - } - } - default { - return -code error "not supported for this query type" - } - } - return $r -} - -# Description: -# Return a list of the IP addresses returned for this query. -# -proc ::dns::address {token} { - set r {} - array set reply [Decode $token] - foreach answer $reply(AN) { - array set AN $answer - - if {[info exists AN(type)]} { - if {$AN(type) == "A"} { - lappend r $AN(rdata) - } - } - } - return $r -} - -# Description: -# Return a list of all CNAME results returned for this query. -# -proc ::dns::cname {token} { - set r {} - array set reply [Decode $token] - foreach answer $reply(AN) { - array set AN $answer - - if {[info exists AN(type)]} { - if {$AN(type) == "CNAME"} { - lappend r $AN(rdata) - } - } - } - return $r -} -# ------------------------------------------------------------------------- - -# Description: -# Get the status of the request. -# -proc ::dns::status {token} { - variable $token - upvar 0 $token state - return $state(status) -} - -# Description: -# Get the error message. Empty if no error. -# -proc ::dns::error {token} { - variable $token - upvar 0 $token state - if {[info exists state(error)]} { - return $state(error) - } - return "" -} - -# Description -# Get the error code. This is 0 for a successful transaction. -# -proc ::dns::errorcode {token} { - variable $token - upvar 0 $token state - set flags [Flags $token] - set ndx [lsearch -exact $flags errorcode] - incr ndx - return [lindex $flags $ndx] -} - -# Description: -# Reset a connection with optional reason. -# -proc ::dns::reset {token {why reset} {errormsg {}}} { - variable $token - upvar 0 $token state - set state(status) $why - if {[string length $errormsg] > 0 && ![info exists state(error)]} { - set state(error) $errormsg - } - catch {fileevent $state(sock) readable {}} - Finish $token -} - -# Description: -# Wait for a request to complete and return the status. -# -proc ::dns::wait {token} { - variable $token - upvar 0 $token state - - if {$state(status) == "connect"} { - vwait [subst $token](status) - } - - return $state(status) -} - -# Description: -# Remove any state associated with this token. -# -proc ::dns::cleanup {token} { - variable $token - upvar 0 $token state - if {[info exists state]} { - unset state - } -} - -# ------------------------------------------------------------------------- - -# Description: -# Dump the raw data of the request and reply packets. -# -proc ::dns::dump {args} { - if {[llength $args] == 1} { - set type -reply - set token [lindex $args 0] - } elseif { [llength $args] == 2 } { - set type [lindex $args 0] - set token [lindex $args 1] - } else { - error "wrong # args: should be \"dump ?option? methodName\"" - } - - variable $token - upvar 0 $token state - - set result {} - switch -glob -- $type { - -qu* - - -req* { - set result [DumpMessage $state(request)] - } - -rep* { - set result [DumpMessage $state(reply)] - } - default { - error "unrecognised option: must be one of \ - \"-query\", \"-request\" or \"-reply\"" - } - } - - return $result -} - -# Description: -# Perform a hex dump of binary data. -# -proc ::dns::DumpMessage {data} { - set result {} - binary scan $data c* r - foreach c $r { - append result [format "%02x " [expr {$c & 0xff}]] - } - return $result -} - -# ------------------------------------------------------------------------- - -# Description: -# Contruct a DNS query packet. -# -proc ::dns::BuildMessage {token} { - variable $token - upvar 0 $token state - variable types - variable classes - variable options - - if {! [info exists types($state(-type))] } { - return -code error "invalid DNS query type" - } - - if {! [info exists classes($state(-class))] } { - return -code error "invalid DNS query class" - } - - set qdcount 0 - set qsection {} - - # In theory we can send multiple queries. In practice, named doesn't - # appear to like that much. If it did work we'd do this: - # foreach domain [linsert $options(search) 0 {}] ... - - set qname [string trim $state(query) .] - - # break up the name into length tagged 'labels' - foreach part [split $qname .] { - set label [binary format c [string length $part]] - append qsection $label $part - } - # append the root label and the type flag and query class. - append qsection [binary format cSS 0 \ - $types($state(-type))\ - $classes($state(-class))] - incr qdcount - - switch -exact -- $state(opcode) { - 0 { - # QUERY - set state(request) [binary format SSSSSS $state(id) \ - [expr {($state(opcode) << 11) | ($state(-recurse) << 8)}] \ - $qdcount 0 0 0] - append state(request) $qsection - } - 1 { - # IQUERY - set state(request) [binary format SSSSSS $state(id) \ - [expr {($state(opcode) << 11) | ($state(-recurse) << 8)}] \ - 0 $qdcount 0 0 0] - append state(request) \ - [binary format cSSI 0 \ - $types($state(-type)) $classes($state(-class)) 0] - switch -exact -- $state(-type) { - A { - append state(request) \ - [binary format Sc4 4 [split $state(query) .]] - } - default { - return -code "inverse query not supported for this type" - } - } - } - default { - return -code error "operation not supported" - } - } - - return -} - -# ------------------------------------------------------------------------- - -# Description: -# Transmit a DNS request over a tcp connection. -# -proc ::dns::TcpTransmit {token} { - variable $token - upvar 0 $token state - - # For TCP the message must be prefixed with a 16bit length field. - set req [binary format S [string length $state(request)]] - append req $state(request) - - # setup the timeout - if {$state(-timeout) > 0} { - set state(after) [after $state(-timeout) \ - [list [namespace origin reset] \ - $token timeout\ - "operation timed out"]] - } - - set s [socket $state(-nameserver) $state(-port)] - fconfigure $s -blocking 0 -translation binary -buffering none - set state(sock) $s - set state(status) connect - - puts -nonewline $s $req - - fileevent $s readable [list [namespace current]::TcpEvent $token] - - return $token -} - -# ------------------------------------------------------------------------- -# Description: -# Transmit a DNS request using UDP datagrams -# -# Note: -# This requires a UDP implementation that can transmit binary data. -# As yet I have been unable to test this myself and the tcludp package -# cannot do this. -# -proc ::dns::UdpTransmit {token} { - variable $token - upvar 0 $token state - - # setup the timeout - if {$state(-timeout) > 0} { - set state(after) [after $state(-timeout) \ - [list [namespace origin reset] \ - $token timeout\ - "operation timed out"]] - } - - set state(sock) [udp_open] - udp_conf $state(sock) $state(-nameserver) $state(-port) - fconfigure $state(sock) -translation binary -buffering none - set state(status) connect - puts -nonewline $state(sock) $state(request) - - fileevent $state(sock) readable [list [namespace current]::UdpEvent $token] - - return $token -} - -# ------------------------------------------------------------------------- - -# Description: -# Tidy up after a tcp transaction. -# -proc ::dns::Finish {token {errormsg ""}} { - variable $token - upvar 0 $token state - global errorInfo errorCode - - if {[string length $errormsg] != 0} { - set state(error) $errormsg - set state(status) error - } - catch {close $state(sock)} - catch {after cancel $state(after)} - if {[info exists state(-command)] && $state(-command) != {}} { - if {[catch {eval $state(-command) {$token}} err]} { - if {[string length $errormsg] == 0} { - set state(error) [list $err $errorInfo $errorCode] - set state(status) error - } - } - if {[info exists state(-command)]} { - unset state(-command) - } - } -} - -# ------------------------------------------------------------------------- - -# Description: -# Handle end-of-file on a tcp connection. -# -proc ::dns::Eof {token} { - variable $token - upvar 0 $token state - set state(status) eof - Finish $token -} - -# ------------------------------------------------------------------------- - -# Description: -# Process a DNS reply packet (protocol independent) -# -proc ::dns::Receive {token} { - variable $token - upvar 0 $token state - - binary scan $state(reply) SS id flags - set status [expr {$flags & 0x000F}] - - switch -- $status { - 0 { - set state(status) ok - Finish $token - } - 1 { Finish $token "Format error - unable to interpret the query." } - 2 { Finish $token "Server failure - internal server error." } - 3 { Finish $token "Name Error - domain does not exist" } - 4 { Finish $token "Not implemented - the query type is not available." } - 5 { Finish $token "Refused - your request has been refused by the server." } - default { - Finish $token "unrecognised error code: $err" - } - } -} - -# ------------------------------------------------------------------------- - -# Description: -# file event handler for tcp socket. Wait for the reply data. -# -proc ::dns::TcpEvent {token} { - variable log - variable $token - upvar 0 $token state - set s $state(sock) - - if {[eof $s]} { - Eof $token - return - } - - set status [catch {read $state(sock)} result] - if {$status != 0} { - ${log}::debug "Event error: $result" - Finish $tok "error reading data: $result" - } elseif { [string length $result] >= 0 } { - if {[catch { - # Handle incomplete reads - check the size and keep reading. - if {![info exists state(size)]} { - binary scan $result S state(size) - set result [string range $result 2 end] - } - append state(reply) $result - - # check the length and flags and chop off the tcp length prefix. - if {[string length $state(reply)] >= $state(size)} { - binary scan $result S id - set id [expr {$id & 0xFFFF}] - Receive [namespace current]::$id - } else { - ${log}::debug "Incomplete tcp read:\ - [string length $state(reply)] should be $state(size)" - } - } err]} { - Finish $tok "Event error: $err" - } - } elseif { [eof $state(sock)] } { - Eof $token - } elseif { [fblocked $state(sock)] } { - ${log}::debug "Event blocked" - } else { - ${log}::critical "Event error: this can't happen!" - Finish $tok "Event error: this can't happen!" - } -} - -# ------------------------------------------------------------------------- - -# Description: -# file event handler for udp sockets. -proc ::dns::UdpEvent {token} { - variable $token - upvar 0 $token state - set s $state(sock) - - set payload [read $state(sock)] - append state(reply) $payload - - binary scan $payload S id - set id [expr {$id & 0xFFFF}] - Receive [namespace current]::$id -} - -# ------------------------------------------------------------------------- - -proc ::dns::Flags {token {varname {}}} { - variable $token - upvar 0 $token state - - if {$varname != {}} { - upvar $varname flags - } - - array set flags {query 0 opcode 0 authoritative 0 errorcode 0 - truncated 0 recursion_desired 0 recursion_allowed 0} - - binary scan $state(reply) SSSSSS mid hdr nQD nAN nNS nAR - - set flags(response) [expr {($hdr & 0x8000) >> 15}] - set flags(opcode) [expr {($hdr & 0x7800) >> 11}] - set flags(authoritative) [expr {($hdr & 0x0400) >> 10}] - set flags(truncated) [expr {($hdr & 0x0200) >> 9}] - set flags(recursion_desired) [expr {($hdr & 0x0100) >> 8}] - set flafs(recursion_allowed) [expr {($hdr & 0x0080) >> 7}] - set flags(errorcode) [expr {($hdr & 0x000F)}] - - return [array get flags] -} - -# ------------------------------------------------------------------------- - -# Description: -# Decode a DNS packet (either query or response). -# -proc ::dns::Decode {token args} { - variable log - variable $token - upvar 0 $token state - - binary scan $state(reply) SSSSSSc* mid hdr nQD nAN nNS nAR data - - set fResponse [expr {($hdr & 0x8000) >> 15}] - set fOpcode [expr {($hdr & 0x7800) >> 11}] - set fAuthoritative [expr {($hdr & 0x0400) >> 10}] - set fTrunc [expr {($hdr & 0x0200) >> 9}] - set fRecurse [expr {($hdr & 0x0100) >> 8}] - set fCanRecurse [expr {($hdr & 0x0080) >> 7}] - set fRCode [expr {($hdr & 0x000F)}] - set flags "" - - if {$fResponse} {set flags "QR"} else {set flags "Q"} - set opcodes [list QUERY IQUERY STATUS] - lappend flags [lindex $opcodes $fOpcode] - if {$fAuthoritative} {lappend flags "AA"} - if {$fTrunc} {lappend flags "TC"} - if {$fRecurse} {lappend flags "RD"} - if {$fCanRecurse} {lappend flags "RA"} - - set info "ID: $mid\ - Fl: [format 0x%02X [expr {$hdr & 0xFFFF}]] ($flags)\ - NQ: $nQD\ - NA: $nAN\ - NS: $nNS\ - AR: $nAR" - ${log}::debug $info - - set ndx 12 - set r {} - set QD [ReadQuestion $nQD $state(reply) ndx] - lappend r QD $QD - set AN [ReadAnswer $nAN $state(reply) ndx] - lappend r AN $AN - set NS [ReadAnswer $nNS $state(reply) ndx] - lappend r NS $NS - set AR [ReadAnswer $nAR $state(reply) ndx] - lappend r AR $AR - return $r -} - -# ------------------------------------------------------------------------- - -proc ::dns::Expand {data} { - set r {} - binary scan $data c* d - foreach c $d { - lappend r [expr {$c & 0xFF}] - } - return $r -} - - -# ------------------------------------------------------------------------- -# Description: -# Pop the nth element off a list. Used in options processing. -# -proc ::dns::Pop {varname {nth 0}} { - upvar $varname args - set r [lindex $args $nth] - set args [lreplace $args $nth $nth] - return $r -} - -# ------------------------------------------------------------------------- - -proc ::dns::KeyOf {arrayname value {default {}}} { - upvar $arrayname array - set lst [array get array] - set ndx [lsearch -exact $lst $value] - if {$ndx != -1} { - incr ndx -1 - set r [lindex $lst $ndx] - } else { - set r $default - } - return $r -} - - -# ------------------------------------------------------------------------- -# Read the question section from a DNS message. This always starts at index -# 12 of a message but may be of variable length. -# -proc ::dns::ReadQuestion {nitems data indexvar} { - variable types - variable classes - upvar $indexvar index - set result {} - - for {set cn 0} {$cn < $nitems} {incr cn} { - set r {} - lappend r name [ReadName data $index offset] - incr index $offset - - # Read off QTYPE and QCLASS for this query. - set ndx $index - incr index 3 - binary scan [string range $data $ndx $index] SS qtype qclass - set qtype [expr {$qtype & 0xFFFF}] - set qclass [expr {$qclass & 0xFFFF}] - incr index - lappend r type [KeyOf types $qtype $qtype] \ - class [KeyOf classes $qclass $qclass] - lappend result $r - } - return $result -} - -# ------------------------------------------------------------------------- - -# Read an answer section from a DNS message. -# -proc ::dns::ReadAnswer {nitems data indexvar} { - variable types - variable classes - upvar $indexvar index - set result {} - - for {set cn 0} {$cn < $nitems} {incr cn} { - set r {} - lappend r name [ReadName data $index offset] - incr index $offset - - # Read off TYPE, CLASS, TTL and RDLENGTH - binary scan [string range $data $index end] SSIS type class ttl rdlength - - set type [expr {$type & 0xFFFF}] - set type [KeyOf types $type $type] - - set class [expr {$class & 0xFFFF}] - set class [KeyOf classes $class $class] - - set ttl [expr {$ttl & 0xFFFFFFFF}] - set rdlength [expr {$rdlength & 0xFFFF}] - incr index 10 - set rdata [string range $data $index [expr {$index + $rdlength - 1}]] - - switch -- $type { - A { - set rdata [join [Expand $rdata] .] - } - NS - CNAME - PTR { - set rdata [ReadName data $index off] - } - MX { - binary scan $rdata S preference - set exchange [ReadName data [expr {$index + 2}] off] - set rdata [list $preference $exchange] - } - } - - incr index $rdlength - lappend r type $type class $class ttl $ttl rdlength $rdlength rdata $rdata - lappend result $r - } - return $result -} - - -# Read off the NAME or QNAME element. This reads off each label in turn, -# dereferencing pointer labels until we have finished. The length of data -# used is passed back using the usedvar variable. -# -proc ::dns::ReadName {datavar index usedvar} { - upvar $datavar data - upvar $usedvar used - set startindex $index - - set r {} - set len 1 - set max [string length $data] - - while {$len != 0 && $index < $max} { - # Read the label length (and preread the pointer offset) - binary scan [string range $data $index end] cc len lenb - set len [expr {$len & 0xFF}] - incr index - - if {$len != 0} { - if {[expr {$len & 0xc0}]} { - binary scan [binary format cc [expr {$len & 0x3f}] [expr {$lenb & 0xff}]] S offset - incr index - lappend r [ReadName data $offset junk] - set len 0 - } else { - lappend r [string range $data $index [expr {$index + $len - 1}]] - incr index $len - } - } - } - set used [expr {$index - $startindex}] - return [join $r .] -} - -# ------------------------------------------------------------------------- - -# Experimental support for finding the nameservers to use on a Windows -# machine -# For unix we can just parse the /etc/resolv.conf if it exists. -# Of couse, some unices use /etc/resolver and other things (NIS for instance) -# -if {$::tcl_platform(platform) == "Windows"} { - -proc ::dns::Win32_NameServers {} { - package require registry - set base {HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\Tcpip} - set param "$base\\Parameters" - set interfaces "$param\\Interfaces" - set nameservers {} - AppendRegistryValue $param NameServer nameservers - AppendRegistryValue $param DhcpNameServer nameservers - foreach i [registry keys $interfaces] { - AppendRegistryValue "$interfaces\\$i" NameServer nameservers - AppendRegistryValue "$interfaces\\$i" DhcpNameServer nameservers - } - - # FIX ME: this doesn't preserve the original preference ordering - return [lsort -unique $nameservers] -} - - -proc ::dns::AppendRegistryValue {key val listName} { - upvar $listName lst - if {![catch {registry get $key $val} v]} { - set lst [concat $lst $v] - } -} - -} - - -# ------------------------------------------------------------------------- -# Possible support for the DNS URL scheme. -# Ref: http://www.ietf.org/internet-drafts/draft-josefsson-dns-url-04.txt -# eg: dns:target?class=IN;type=A -# dns://nameserver/target?type=A -# -# URI quoting to be accounted for. -# - -catch { - uri::register {dns} { - set escape [set [namespace parent [namespace current]]::basic::escape] - set host [set [namespace parent [namespace current]]::basic::host] - set hostOrPort [set [namespace parent [namespace current]]::basic::hostOrPort] - - set class [string map {* \\\\*} \ - "class=([join [array names ::dns::classes] {|}])"] - set type [string map {* \\\\*} \ - "type=([join [array names ::dns::types] {|}])"] - set classOrType "(?:${class}|${type})" - set classOrTypeSpec "(?:${class}|${type})(?:;(?:${class}|${type}))?" - - set query "${host}(${classOrTypeSpec})?" - variable schemepart "(//${hostOrPort}/)?(${query})" - variable url "dns:$schemepart" - } -} - -namespace eval ::uri {} ;# needed for pkg_mkIndex. - -proc ::uri::SplitDns {uri} { - upvar \#0 [namespace current]::dns::schemepart schemepart - upvar \#0 [namespace current]::dns::class classOrType - upvar \#0 [namespace current]::dns::class classRE - upvar \#0 [namespace current]::dns::type typeRE - upvar \#0 [namespace current]::dns::classOrTypeSpec classOrTypeSpec - - array set parts {nameserver {} query {} class {} type {} port {}} - - # validate the uri - if {[regexp $dns::schemepart $uri r] == 1} { - - # deal with the optional class and type specifiers - if {[regexp -indices -- "${classOrTypeSpec}$" $uri range]} { - set spec [string range $uri [lindex $range 0] [lindex $range 1]] - set uri [string range $uri 0 [expr {[lindex $range 0] - 2}]] - - if {[regexp -- "$classRE" $spec -> class]} { - set parts(class) $class - } - if {[regexp -- "$typeRE" $spec -> type]} { - set parts(type) $type - } - } - - # Handle the nameserver specification - if {[string match "//*" $uri]} { - set uri [string range $uri 2 end] - array set tmp [GetHostPort uri] - set parts(nameserver) $tmp(host) - set parts(port) $tmp(port) - } - - # what's left is the query domain name. - set parts(query) [string trimleft $uri /] - } - - return [array get parts] -} - -proc ::uri::JoinDns {args} { - array set parts {nameserver {} port {} query {} class {} type {}} - array set parts $args - set query [::uri::urn::quote $parts(query)] - if {$parts(type) != {}} { - append query "?type=$parts(type)" - } - if {$parts(class) != {}} { - if {$parts(type) == {}} { - append query "?class=$parts(class)" - } else { - append query ";class=$parts(class)" - } - } - if {$parts(nameserver) != {}} { - set ns "$parts(nameserver)" - if {$parts(port) != {}} { - append ns ":$parts(port)" - } - set query "//${ns}/${query}" - } - return "dns:$query" -} - -# ------------------------------------------------------------------------- - -package provide dns $dns::version - -# ------------------------------------------------------------------------- -# Local Variables: -# indent-tabs-mode: nil -# End: DELETED modules/dns/dns.test Index: modules/dns/dns.test ================================================================== --- modules/dns/dns.test +++ /dev/null @@ -1,82 +0,0 @@ -# dns.test - Copyright (C) 2002 Pat Thoyts -# -# Tests for the Tcllib dns package -# -# ------------------------------------------------------------------------- -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# ------------------------------------------------------------------------- -# RCS: @(#) $Id: dns.test,v 1.1 2003/01/25 21:05:52 patthoyts Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -package require dns - -# ------------------------------------------------------------------------- -# Helpers -# ------------------------------------------------------------------------- - -proc ::OrderedArrayGet {arrayName} { - upvar $arrayName a - set result {} - foreach name [lsort [array names a]] { - lappend result $name $a($name) - } - return $result -} - -# ------------------------------------------------------------------------- -# Tests -# ------------------------------------------------------------------------- - -# Test the dns uri scheme split and join methods. - -set urls { - 1 dns:www.example.org - {class {} nameserver {} port {} query www.example.org scheme dns type {}} - 2 dns://nameserver/www.example.org - {class {} nameserver nameserver port {} query www.example.org scheme dns type {}} - 3 dns://nameserver:53/www.example.org - {class {} nameserver nameserver port 53 query www.example.org scheme dns type {}} - 4 dns:www.example.org?class=IN - {class IN nameserver {} port {} query www.example.org scheme dns type {}} - 5 dns:www.example.org?type=MX - {class {} nameserver {} port {} query www.example.org scheme dns type MX} - 6 dns:www.example.org?class=IN;type=A - {class IN nameserver {} port {} query www.example.org scheme dns type A} - 7 dns:www.example.org?type=A;class=IN - {class IN nameserver {} port {} query www.example.org scheme dns type A} -} - -foreach {ndx url check} $urls { - test dns-1.$ndx [list uri::split $url] { - if {![catch {uri::split $url} result]} { - if {![catch {array set URL $result} result]} { - set result [OrderedArrayGet URL] - } - } - set result - } $check -} - -foreach {ndx url check} $urls { - if {$ndx == 6} continue; # this test is bogus for join. - test dns-2.$ndx [list uri::join $url] { - catch {eval [list uri::join] $check} result - set result - } $url -} - - -# ------------------------------------------------------------------------- - -rename ::OrderedArrayGet {} -::tcltest::cleanupTests - -# Local Variables: -# mode: tcl -# indent-tabs-mode: nil -# End: DELETED modules/dns/pkgIndex.tcl Index: modules/dns/pkgIndex.tcl ================================================================== --- modules/dns/pkgIndex.tcl +++ /dev/null @@ -1,13 +0,0 @@ -# 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. - -if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded dns 1.0.4 [list source [file join $dir dns.tcl]] -package ifneeded resolv 1.0.2 [list source [file join $dir resolv.tcl]] DELETED modules/dns/resolv.tcl Index: modules/dns/resolv.tcl ================================================================== --- modules/dns/resolv.tcl +++ /dev/null @@ -1,254 +0,0 @@ -# resolv.tcl - Copyright (c) 2002 Emmanuel Frecon -# -# Original Author -- Emmanuel Frecon - emmanuel@sics.se -# Modified by Pat Thoyts -# -# A super module on top of the dns module for host name resolution. -# There are two services provided on top of the regular Tcl library: -# Firstly, this module attempts to automatically discover the default -# DNS server that is setup on the machine that it is run on. This -# server will be used in all further host resolutions. Secondly, this -# module offers a rudimentary cache. The cache is rudimentary since it -# has no expiration on host name resolutions, but this is probably -# enough for short lived applications. -# -# ------------------------------------------------------------------------- -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# ------------------------------------------------------------------------- -# -# $Id: resolv.tcl,v 1.4 2003/04/13 23:04:00 patthoyts Exp $ - -package require dns 1.0; # tcllib 1.3 - -namespace eval ::resolv { - variable version 1.0.2 - variable rcsid {$Id: resolv.tcl,v 1.4 2003/04/13 23:04:00 patthoyts Exp $} - - namespace export resolve init ignore hostname - - variable R - if {![info exists R]} { - array set R { - initdone 0 - dns "" - dnsdefault "" - ourhost "" - search {} - } - } -} - -# ------------------------------------------------------------------------- -# Command Name -- ignore -# Original Author -- Emmanuel Frecon - emmanuel@sics.se -# -# Remove a host name resolution from the cache, if present, so that the -# next resolution will query the DNS server again. -# -# Arguments: -# hostname - Name of host to remove from the cache. -# -proc ::resolv::ignore { hostname } { - variable Cache - catch {unset Cache($hostname)} - return -} - -# ------------------------------------------------------------------------- -# Command Name -- init -# Original Author -- Emmanuel Frecon - emmanuel@sics.se -# -# Initialise this module with a known host name. This host (not mandatory) -# will become the default if the library was not able to find a DNS server. -# This command can be called several times, its effect is double: actively -# looking for the default DNS server setup on the running machine; and -# emptying the host name resolution cache. -# -# Arguments: -# defaultdns - Default DNS server -# -proc ::resolv::init { {defaultdns ""} {search {}}} { - variable R - variable Cache - - # Clean the resolver cache - catch {unset Cache} - - # Record the default DNS server and search list. - set R(dnsdefault) $defaultdns - set R(search) $search - - # Now do some intelligent lookup. We do this on the current - # hostname to get a chance to get back some (full) information on - # ourselves. A previous version was using 127.0.0.1, not sure - # what is best. - set res [catch [list exec nslookup [info hostname]] lkup] - if { $res == 0 } { - set l [split $lkup] - set nl "" - foreach e $l { - if { [string length $e] > 0 } { - lappend nl $e - } - } - - # Now, a lot of mixture to arrange so that hostname points at the - # DNS server that we should use for any further request. This - # code is complex, but was actually tested behind a firewall - # during the SITI Winter Conference 2003. There, strangly, - # nslookup returned an error but a DNS server was actually setup - # correctly... - set hostname "" - set len [llength $nl] - for { set i 0 } { $i < $len } { incr i } { - set e [lindex $nl $i] - if { [string match -nocase "*server*" $e] } { - set hostname [lindex $nl [expr {$i + 1}]] - if { [string match -nocase "UnKnown" $hostname] } { - set hostname "" - } - break - } - } - - if { $hostname != "" } { - set R(dns) $hostname - } else { - for { set i 0 } { $i < $len } { incr i } { - set e [lindex $nl $i] - if { [string match -nocase "*address*" $e] } { - set hostname [lindex $nl [expr {$i + 1}]] - break - } - } - if { $hostname != "" } { - set R(dns) $hostname - } - } - } - - if {$R(dns) == ""} { - set R(dns) $R(dnsdefault) - } - - - # Start again to find our full name - set ourhost "" - if {$res == 0} { - set dot [string first "." [info hostname]] - if { $dot < 0 } { - for { set i 0 } { $i < $len } { incr i } { - set e [lindex $nl $i] - if { [string match -nocase "*name*" $e] } { - set ourhost [lindex $nl [expr $i + 1]] - break - } - } - if { $ourhost == "" } { - if { ! [regexp {\d+\.\d+\.\d+\.\d+} $hostname] } { - set dot [string first "." $hostname] - set ourhost [format "%s%s" [info hostname] \ - [string range $hostname $dot end]] - } - } - } else { - set ourhost [info hostname] - } - } - - if {$ourhost == ""} { - set R(ourhost) [info hostname] - } else { - set R(ourhost) $ourhost - } - - - set R(initdone) 1 - - return $R(dns) -} - -# ------------------------------------------------------------------------- -# Command Name -- resolve -# Original Author -- Emmanuel Frecon - emmanuel@sics.se -# -# Resolve a host name to an IP address. This is a wrapping procedure around -# the basic services of the dns library. -# -# Arguments: -# hostname - Name of host -# -proc ::resolv::resolve { hostname } { - variable R - variable Cache - - # Initialise if not already done. Auto initialisation cannot take - # any known DNS server (known to the caller) - if { ! $R(initdone) } { init } - - # Check whether this is not simply a raw IP address. What about - # IPv6 ?? - # - We don't have sockets in Tcl for IPv6 protocols - [PT] - # - if { [regexp {\d+\.\d+\.\d+\.\d+} $hostname] } { - return $hostname - } - - # Look for hostname in the cache, if found return. - if { [array names ::resolv::Cache $hostname] != "" } { - return $::resolv::Cache($hostname) - } - - # Scream if we don't have any DNS server setup, since we cannot do - # anything in that case. - if { $R(dns) == "" } { - return -code error "No dns server provided" - } - - set R(retries) 0 - set ip [Resolve $hostname] - - # And store the result of resolution in our cache for further use. - set Cache($hostname) $ip - - return $ip -} - -# Description: -# Attempt to resolve hostname via DNS. If the name cannot be resolved then -# iterate through the search list appending each domain in turn until we -# get one that succeeds. -# -proc ::resolv::Resolve {hostname} { - variable R - set t [::dns::resolve $hostname -server $R(dns)] - ::dns::wait $t; # wait with event processing - set status [dns::status $t] - if {$status == "ok"} { - set ip [lindex [::dns::address $t] 0] - ::dns::cleanup $t - } elseif {$status == "error" - && [::dns::errorcode $t] == 3 - && $R(retries) < [llength $R(search)]} { - ::dns::cleanup $t - set suffix [lindex $R(search) $R(retries)] - incr R(retries) - set new [lindex [split $hostname .] 0].[string trim $suffix .] - set ip [Resolve $new] - } else { - set err [dns::error $t] - ::dns::cleanup $t - return -code error "dns error: $err" - } - return $ip -} - -# ------------------------------------------------------------------------- - -package provide resolv $::resolv::version - -# ------------------------------------------------------------------------- -# Local Variables: -# indent-tabs-mode: nil -# End: DELETED modules/dns/tcllib_dns.man Index: modules/dns/tcllib_dns.man ================================================================== --- modules/dns/tcllib_dns.man +++ /dev/null @@ -1,163 +0,0 @@ -[manpage_begin dns n 1.0.4] -[copyright {2002, Pat Thoyts}] -[moddesc {dns}] -[titledesc {Tcl Domain Name Service Client}] -[require Tcl 8.2] -[require dns [opt 1.0.4]] -[description] -[para] - -The dns package provides a Tcl only Domain Name Service client. You should -refer to RFC 1034 and RFC 1035 for information about the DNS protocol or -read resolver(3) to find out how the C library resolves domain names. - -The intention of this package is to insulate Tcl scripts -from problems with using the system library resolver for slow name servers. -It may or may not be of practical use. Internet name resolution is a -complex business and DNS is only one part of the resolver. You may -find you are supposed to be using hosts files, NIS or WINS to name a -few other systems. This package is not a substitute for the C library -resolver - it does however implement name resolution over DNS. - -The package also extends the package [package uri] to support DNS URIs -or the form [uri dns:what.host.com] or - -[uri dns://my.nameserver/what.host.com]. The [cmd dns::resolve] -command can handle DNS URIs or simple domain names as a query. - -[para] - -[emph Note:] The package defaults to using DNS over TCP -connections. If you wish to use UDP you will need to get the tcludp -package and get a version that correctly handles binary -data. This should be publicly available shortly. - -[section COMMANDS] - -[list_begin definitions] - - -[call [cmd ::dns::resolve] [arg query] [opt [arg "options"]]] - -Resolve a domain name using the [term DNS] protocol. [arg query] is -the domain name to be lookup up. This should be either a fully -qualified domain name or a DNS URI. - -[list_begin definitions] -[lst_item "[cmd -nameserver] [arg hostname] or [cmd -server] [arg hostname]"] - Specify an alternative name server for this request. -[lst_item "[cmd -protocol] [arg tcp|udp]"] - Specify the network protocol to use for this request. Can be one of - [arg tcp] or [arg udp]. -[lst_item "[cmd -port] [arg portnum]"] - Specify an alternative port. -[lst_item "[cmd -search] [arg domainlist]"] -[lst_item "[cmd -timeout] [arg milliseconds]"] - Override the default timeout. -[lst_item "[cmd -type] [arg TYPE]"] - Specify the type of DNS record you are interested in. Valid values are A, NS, MD - MF, CNAME, SOA, MB, MG, MR, NULL, WKS, PTR, HINFO, MINFO, MX, TXT, AXFR, MAILB, - MAILA and *. See RFC1035 for details about the return values. -[lst_item "[cmd -class] [arg CLASS]"] - Specify the class of domain name. This is usually IN but may be one of IN for - internet domain names, CS, CH, HS or * for any class. -[lst_item "[cmd -recurse] [arg boolean]"] - Set to [arg false] if you do not want the name server to recursively act upon - your request. Normally set to [arg true]. -[lst_item "[cmd -command] [arg procname]"] - Set a procedure to be called upon request completion. The procedure will be - passed the token as its only argument. -[list_end] - -[nl] -[call [cmd ::dns::configure] [opt [arg "options"]]] - -The ::dns::configure command is used to setup the dns package. The server to -query, the protocol and domain search path are all set via this command. If -no arguments are provided then a list of all the current settings is returned. -If only one argument then it must the the name of an option and the value for -that option is returned. - -[list_begin definitions] -[lst_item "[cmd -nameserver] [arg hostname]"] - Set the default name server to be used by all queries. The default is - localhost. -[lst_item "[cmd -protocol] [arg tcp|udp]"] - Set the default network protocol to be used. Defaults to tcp. -[lst_item "[cmd -port] [arg portnum]"] - Set the default port to use on the name server. The default is 53. -[lst_item "[cmd -search] [arg domainlist]"] - Set the domain search list. This is currently not used. -[lst_item "[cmd -timeout] [arg milliseconds]"] - Set the default timeout value for DNS lookups. Defaults to 30 seconds. -[list_end] - - -[nl] -[call [cmd ::dns::name] [arg token]] - Returns a list of all domain names returned as an answer to your query. - -[nl] -[call [cmd ::dns::address] [arg token]] - Returns a list of the address records that match your query. - -[nl] -[call [cmd ::dns::cname] [arg token]] - Returns a list of canonical names (usually just one) matching your query. - -[nl] -[call [cmd ::dns::status] [arg token]] - Returns the status flag. For a successfully completed query this will be - [emph ok]. May be [emph error] or [emph timeout] or [emph eof]. - See also [cmd ::dns::error] - -[nl] -[call [cmd ::dns::error] [arg token]] - Returns the error message provided for requests whose status is [emph error]. - If there is no error message then an empty string is returned. - -[nl] -[call [cmd ::dns::reset] [arg token]] - Reset or cancel a DNS query. - -[nl] -[call [cmd ::dns::wait] [arg token]] - Wait for a DNS query to complete and return the status upon completion. - -[nl] -[call [cmd ::dns::cleanup] [arg token]] - Remove all state variables associated with the request. - -[list_end] - - - - -[section EXAMPLES] - -[para] -[example { -% set tok [dns::resolve www.tcl.tk] -::dns::1 -% dns::status $tok -ok -% dns::address $tok -199.175.6.239 -% dns::name $tok -www.tcl.tk -% dns::cleanup $tok -}] - -[para] -Using DNS URIs as queries: -[example { -% set tok [dns::resolve "dns:tcl.tk;type=MX"] -% set tok [dns::resolve "dns://l.root-servers.net/www.tcl.tk"] -}] - -[see_also resolver(5)] -[section AUTHORS] -Pat Thoyts - -[keywords DNS resolver {domain name service}] -[manpage_end] DELETED modules/doctools/ChangeLog Index: modules/doctools/ChangeLog ================================================================== --- modules/doctools/ChangeLog +++ /dev/null @@ -1,574 +0,0 @@ -2003-04-01 Andreas Kupries - - * checker_toc.tcl: Bug fixes for handling of nested toc divisions. - - * ../../examples/doctools/doctools.idx: - * ../../examples/doctools/doctools.toc: Updated to reflect latest - changes in the format definitions. - - * doctoc.tcl: - * docidx.tcl: Added the package and file ops initially created in - doctools.tcl to these packages too, so that their text engines - can use 'textutil' too. - - * mpformats/_text.tcl: - * mpformats/fmt.text: - * mpformats/toc.text: - * mpformats/idx.text: Bug fixes. - -2003-03-31 Andreas Kupries - - * mpformats/toc.text: - * mpformats/idx.text: New files, toc & index formatting in plain text. - - * mpformats/_text.tcl: - * mpformats/fmt.text: Moved processing of plain text into the generic part. - -2003-03-31 Andreas Kupries - - * cvs.tcl (scanLog): Applied fix for Bug #712951 reported by Joe - English . - -2003-03-29 Andreas Kupries - - * doctools.tcl (SetupFormatter): Moved error output command to the - front, so that the code loading the engine can use it too, and - not only the engine procedures. Added alias for 'file', and a - special command which is a shortcut for 'package require' so - that engines can load packages. This was required for the plain - text engine which makes heavy use of the formatting commands in - 'textutil'. Added setup of 'ctopandclear'. - (SetupChecker): Added setup of 'ctopandclear'. - (Package, Locate): New commands supporting package - require. Instead of trying to enable every command in the safe - interpreter required for package management we use the standard - package commands to locate the index for thr requested package - and evaluate just that in the safe interpreter, after - temporarily enabling source and load commands. - - * checker.tcl: Added code for debugging, like already present in - the files checker_doc*.tcl. - - * mpformats/_text.tcl: Core for plain text engines. - * mpformats/fmt.text: New engine. Generates output in plain text. - -2003-03-28 Andreas Kupries - - * pkgIndex.tcl: added 'doctools::cvs' and 'doctools::changelog' to - the package index. - - * changelog.man: - * changelog.tcl: New. Parsing of ChangeLogs into list structures, - merging of multiple logs, conversion into a doctools - document. The code for parsing came originally out - Makedist_SupportAku, a private package extending my Makedist - tool. Documented the code. - - * cvs.tcl (toChangeLog): Using the new textutil commands 'indent' - and 'undent' for proper alignment of the comments extracted from - the log. - -2003-03-27 Andreas Kupries - - * cvs.man: - * cvs.tcl: Added code to handle parsing and reformatting of cvs - log files. Origin of the code the tcl'ers wiki, page - http://wiki.tcl.tk/log2changelog. The actual original author is - unknown (not listed on the wiki). - -2003-03-24 Andreas Kupries - - * doctools_fmt.man: Fixed documentation bug #704187 reported by - Roy Terry . - -2003-03-13 Andreas Kupries - - * checker.tcl: Fixed incorrect signature of 'usage'. - * mpformats/fmt.null: Bugfix in naming of the procedures. - -2003-03-13 Andreas Kupries - - * mpformats/_common.tcl: Fixed initialization error for - cross-references causing unwanted suppression (leakage of - definitions between multiple pages). - - * doctoc.tcl: Bug fixes in three return statemments. - * docidx.tcl: (return -code error string, not return -code string) - * doctools.tcl: - -2003-03-11 Andreas Kupries - - * mpformats/fmt.html: Rewrite handling of [keywords] and - * mpformats/fmt.latex: [see_also] to behave like for the TMML - * mpformats/fmt.list: formatter: Collect all keywords and - * mpformats/fmt.nroff: x-references during the first pass, insert - * mpformats/fmt.wiki: the results during the second pass, in - [manpage_end]. Ensures that at most one - see_also / keyword section is present, - ensures uniform order and handling of - multiple keyword / see_also commands is - now uniform too. - - * examples/doctools.idx: Moved to the new examples/doctools - * examples/doctools.toc: directory. Thanks to Larry Virden - for - pointing out that the original location - in the doctools module violated the - principle of collecting examples in a - separate directory, instated by - myself. Stupid me. - -2003-03-04 Andreas Kupries - - * A examples/doctools.idx: Fairly extensive revamping of the - * A examples/doctools.toc: codebase. Added a format for - * A mpformats/_idx_common.tcl: indices, formatting engines, a - * A mpformats/_toc_common.tcl: package for handling it. Extended - * A mpformats/idx.html: all packages to allow engine - * A mpformats/idx.nroff: parameters and mapping from - * A mpformats/idx.null: symbolic to actual filenames or - * A mpformats/idx.wiki: urls. Right now only the HTML - * A mpformats/toc.html: engines actually provide - * A mpformats/toc.nroff: parameters. Added testsuites for - * A mpformats/toc.null: doctoc and docidx. Revamped the - * A mpformats/toc.tmml: documentation to cross-reference - * A mpformats/toc.wiki: each other better, more uniform in - * A api_idx.tcl: structure (not complete), naming of - * A api_toc.tcl: the manpages for this module is now - * A checker_idx.tcl: uniform. Added examples for doctoc - * A checker_toc.tcl: and docidx formats, both in the - * A docidx.man: manpages, and as separate files. - * A docidx.tcl: - * A docidx.test: - * A docidx_api.man: - * A docidx_fmt.man: - * A doctoc.man: - * A doctoc.tcl: - * A doctoc.test: - * A doctoc_api.man: - * A doctoc_fmt.man: - * A doctools_api.man: - * A doctools_fmt.man: - * A tocexpand: - * M ChangeLog: - * M NOTES: - * M api.tcl: - * M checker.tcl: - * M doctools.man: - * M doctools.tcl: - * M doctools.test: - * M pkgIndex.tcl: - * M mpformats/_common.tcl: - * M mpformats/_nroff.tcl: - * M mpformats/c.msg: - * M mpformats/de.msg: - * M mpformats/en.msg: - * M mpformats/fmt.html: - * M mpformats/fmt.latex: - * M mpformats/fmt.list: - * R dtformat.man: - * R dtformatter.man: - -2003-02-16 Andreas Kupries - - * mpformats/fmt.list: Modified to extract all meta information out - of the page. Changed the output format. Argument to the - 'manpage' command in the output is now a key/value list - acceptable to 'array set' instead of a simple list with fixed - positions for the various data elements. - -2003-02-16 Andreas Kupries - - * doctoc.tcl: Specified a new portable format for - * api_toc.tcl: writing a table of contents. Wrote a - * checker_toc.tcl: package to handle input that format - * dtocformat.man: and a number of formatting engines - * dtocengine.man: plugging into this package to - * mpformats/_toc_common.tcl: generate output in various formats. - * mpformats/toc.html: This required additional checker code - * mpformats/toc.nroff: and more messages in the message - * mpformats/toc.null: catalogs. - * mpformats/toc.tmml: - * mpformats/toc.wiki: - * pkgIndex.tcl: - * mpformats/c.msg: - * mpformats/en.msg: - * mpformats/de.msg: - * mpformats/_nroff.tcl: - - * doctools.tcl: Rephrased documentation of SetupChecker a bit. - -2003-02-12 Andreas Kupries - - * dtformatter.man: Updated the documentation to include the - * dtformat.man: two new commands (vset, include). - - * doctools.tcl (Eval): Added handling of new [include] - * doctools.tcl (ExpandInclude): formatting command. - - * checker.tcl (vset): New command in the formatting language for - handling variables (setting and retrieving values). Differs from - the regular in that the set value is not retruned as the result - of the command. This is necessary to avoid unwanted insertion of - data into the output stream. The command is handled in the - checker layer (although no checking is required). The engines - never see this command. - - * mpformats/fmt.nroff: Changed both engines to not use the - * mpformats/fmt.wiki: expander context stack anymore. It - interferes with handling of include - files. It was used to catch all output and - then perform last-miunte processing. for - that we have [fmt_postprocess], moved the - code to that. - -2003-01-27 Andreas Kupries - - * mpformats/fmt.html: Modified generation of section titles to - make the resulting HTML more conformant and less - troublesome. Thanks to Larry Virden - for the catch. Revised the - engine a bit. Entries in the synopsis now refer directly to the - location where they are defined ([call] command). - -2003-01-16 Andreas Kupries - - * mpformats/fmt.html: Removed 'strong' formatting. The checker - * mpformats/fmt.latex: warns if used and warnings requested, it - * mpformats/fmt.nroff: now also redirects the command to 'emph'. - * mpformats/fmt.wiki: The option -visualwarn (doctools, and - * mpformats/fmt.null: mpexpand) renamed to -deprecated. Message - * mpformats/fmt.list: 'visualmarkup' removed from the catalogs, - * mpformats/c.msg: and 'depr_strong' added instead. - * mpformats/en.msg: - * mpformats/de.msg: - * checker.tcl: - * doctools.tcl: - * mpexpand: - - * doctools.man: Updated, converted [strong] to better - * dtformat.man: formatting commands. Ditto for all manpages - * dtformatter.man: in tcllib containing 'strong'. 'strong' is now - * mpexpand.man: not present anymore. - - * mpformats/_common.tcl: Applied a patch by Joe English adding the - * mpformats/fmt.tmml: copyright information to the appropriate - place in the TMML output. This also fixes - a bug in c_get_copyright where an empty - string resulted in a incomplete line - being given to the formatter. - - * mpformats/fmt.html: Removed the phrase 'All rights reserved' - * mpformats/fmt.latex: from the code, on recommendation by - * mpformats/fmt.nroff: Joe English. - * mpformats/fmt.wiki: - - (In the way to early morrow :) - * mpformats/fmt.html: Changed to display copyright information in - * mpformats/fmt.latex: the conversion result itself and not only - * mpformats/fmt.nroff: embedded in comments. - * mpformats/fmt.wiki: - -2003-01-14 Andreas Kupries - - * doctools.tcl: Added a new formatting command, - * doctools.test: 'copyright', to declare/assign copyright - * doctools.man: for manpages. Updated both documentation - * dtformat.man: and testsuite. Extended the common code - * checker.tcl: base with convenience methods for storing - * api.tcl: and retrieving such information. The - * mpformats/fmt.html: retrieval operation also implements the - * mpformats/fmt.latex: logic giving the information in a manpage - * mpformats/fmt.list: precedence over information coming from the - * mpformats/fmt.nroff: processor. Updated all predefined engines - * mpformats/fmt.null: to handle the new command. TMML done only - * mpformats/fmt.tmml: partially, as I don't know where the copy- - * mpformats/fmt.wiki: right has to go. - * mpformats/_common.tcl: - * mpformats/_html.tcl: - * mpformats/_nroff.tcl: - * mpexpand: - -2003-01-13 Andreas Kupries - - * mpexpand: Moved format help into the package itself. - * doctools.tcl: Changed the checker. Input syntax errors are not - * checker.tcl: written to stderr anymore, but reported through - * doctools.man: an standard tcl error. Warnings are collected and - * doctools.test: can be queried after a formatting run. Made the - generic engine more robust against failures in a - formatting engine. Wrote documentation for the - package. Extended the configuration method to be - more standard. Wrote a testsuite. - -2003-01-11 Andreas Kupries - - * mpexpand: Nearly complete rewrite of the system. - * mpformats/fmt.html: The recognized input format was _not_ - * mpformats/fmt.latex: changed. The main functionality was - * mpformats/fmt.list: placed into a package, doctools. This - * mpformats/fmt.nroff: package allows the creation of multiple - * mpformats/fmt.null: formatter objects, to be used alone or - * mpformats/fmt.tmml: together. The application 'mpexpand' was - * mpformats/fmt.wiki: rewritten to use that package and is now - * mpformats/_common.tcl: much simpler. The communication between - * mpformats/_nroff.tcl: the various stages was made simpler, and - * mpformats/_xml.tcl: one slave interpreter was dropped because - * mpformats/_html.tcl: of this. It might be added back if its - * api.tcl: existence proves to be beneficial. The - * checker.tcl: API between main systen and formatter - * doctools.tcl: engine was changed, consequently all - * dtformatter.man: existing engines had to be updated. They - were also made simpler, especially in the - area of list handling, because of the - validation done by the checker subsystem. - The version number is now 1.0. - -2002-12-16 David N. Welton - - * mpexpand (format_find): Added 'argv0' as a global variable, in - order to avoid erroring out when providing a bad format. - -2002-12-05 Andreas Kupries - - * mpformats/fmt.nroff: Changed so that comments coming before - manpage_begin are moved after the standard header generated by - manpage_begin. - -2002-09-23 Andreas Kupries - - * mpexpand: Corrected example formatting, have to run argument - through plain text handling. - * mpformats/fmt.wiki: Added Wiki formatting. - -2002-07-08 Andreas Kupries - - * mpformats/fmt.html: Changed bug #578465 which caused - mis-generation of angle-brackets and quotes. - -2002-06-06 Andreas Kupries - - * mpformats/fmt.html: - * mpformats/_html.tcl: Added the missing handling of " (") to - the format. - -2002-05-27 Andreas Kupries - - * mpformats/_xml.tcl: args -> arguments, as the argument is not - the last one. The code as is was not erroneous, but a possible - trouble spot should tcl ever be more strict with 'args'. - -2002-05-21 Andreas Kupries - - * mpformats/fmt.nroff: Accepted patch for bug #556509, both by Joe - English . - -2002-05-09 Andreas Kupries - - * This completes the implementation of SF tcllib item #534334. - - * mpformats/fmt.html: See last entry, completed definitions for - the new lists. - - * format.man: Added the new commands (see last entry) to the - format specification and also added more explanations regarding - sections and paragraphs. - -2002-05-09 Joe English - - * mpexpand: - * mpformats/c.msg: - * mpformats/de.msg: - * mpformats/en.msg: - * mpformats/fmt.nroff: - * mpformats/fmt.latex: - * mpformats/fmt.list: - * mpformats/fmt.nroff: - * mpformats/fmt.null: Added new list types for arguments, options, - commands, and Tk (widget) options. - -2002-04-24 Andreas Kupries - - * mpformats/fmt.html: - * mpformats/_html.tcl: Changes analogous to TMML (see below) to - differentiate internal markup and external special characters. - -2002-04-24 Joe English - - * mpformats/_xml.tcl - * mpformats/fmt.tmml: Correctly handles XML markup characters - in macro arguments. Also correctly escapes apostrophes - in attribute values (previously-unnoticed bug). - * mpformats/fmt.tmml: TMML uses instead of , and - does not have a element; changed output accordingly. - -2002-04-23 Andreas Kupries - - * format.man: Added descriptions for all the commands performing - semantic markup. This closes bug #527025. - -2002-04-10 Andreas Kupries - - * mpexpand: Fixed error in checker of plain text. - - * mpformats/fmt.nroff: Added newlines in front of dot commands to - make sure that the formatting is correct. Superfluous newlines - are stripped in the post processor of this format, so - unconditionally adding them does not hurt. - -2002-04-02 Andreas Kupries - - * mpformats/en.msg: - * mpformats/c.msg: - * mpformats/de.msg: Added the messages required by the new code - below. - - * mpexpand: Added code to check that plain text is not used in - places where it is not allowed. - -2002-04-01 Andreas Kupries - - * Committed changes to list generation (better generation of - whitespace for HTML, allowing hints). Only the HTML formatter - currently acknowledges hints. This fixes SF Bug #535382. - -2002-03-26 Andreas Kupries - - * mpexpand: Changed the generation of error messages by the format - checker to use explicit error codes instead of trying to - construct the whole message automatically. Error codes are - mapped to textual messages using the message catalog facility, - allowing for easy i18n and l10n of mpexpand. Catalogs for the - locales "c", "en", and "de" are provided. - - * mpformats/fmt.html: Changed uri formatting to be a link. - - * mpformats/fmt.tmml: - * mpformats/fmt.html: - * mpformats/fmt.nroff: - * mpformats/fmt.latex: - * mpformats/fmt.list: - * mpformats/fmt.null: - * mpformats/_api.tcl: Added formatting commands "term" and "const" - to allow the structural markup of non-specific terminology and - of constant values. - - * mpformats/fmt.nroff (bullet): Bulleting changed, use \(bu as - bullet instead of *. - (uri): Fixed error with underlining. - -2002-03-25 Andreas Kupries - - * mpexpand: Extended with additional code checking that the - formatting commands are not used out of order and in the wrong - context. This check is independent of the format and thus - implemented outside of the format. Tcllib FR #530059. - - * mpexpand: Implemented Tcllib FR #527029 (help options). - -2002-03-13 Andreas Kupries - - * mpformats/fmt.html: Removed 'center' alignment from - examples. Tcllib Bug #528390. - -2002-03-09 Andreas Kupries - - * modules/doctools/format.man: Added documentation for [rb] and - [lb]. This partially fixes bug #527025. - - * modules/doctools/mpformats/_html.tcl: The patch for FR #527716 - also fixes a bug in the generation of HTML escapes. The table - swiped from htmlparse seems to contain some non-standard - escapes. Which are removed now. - - * modules/doctools/format.man: - * modules/doctools/mpexpand: - * modules/doctools/mpformats/fmt.html: - * modules/doctools/mpformats/fmt.latex: - * modules/doctools/mpformats/fmt.list: - * modules/doctools/mpformats/fmt.nroff: - * modules/doctools/mpformats/fmt.null: - * modules/doctools/mpformats/fmt.tmml: - * modules/doctools/mpformats/fmt.tmml: Accepted FR #527716 by - Bryan Oakley which adds a - command [usage] to the format. It allows the specification of - usage information for the synopsis without the need to be - embedded into a definition list. - -2002-02-28 Andreas Kupries - - * mpformats/fmt.nroff: Corrected problems with trimming lines and - the stripping of empty lines. - - * mpformats/fmt.html: Changed the formatting of examples. Embedded - them into a table and additionally marked them with a black bar - to the left. - -2002-02-27 Andreas Kupries - - * mpformats/fmt.null: Null format, does not produce any output. - - * mpformats/fmt.tmml: - * mpformats/fmt.nroff: - * mpformats/fmt.latex: - * mpformats/fmt.html: - * mpformats/fmt.list: Implementations of the new command. - - * mpexpand: Added the commands to the processor application. Added - option "-visualwarn". When present the processor warn about - usage of visual markup. Tcllib FR #517599. - - * mpformats/_api.tcl: Added a number of semantic markup commands - to the api as part of Tcllib FR #517599. Also added comment - command, see Tcllib FR #520269. - -2002-02-14 Andreas Kupries - - * mpformats/_common.tcl: Frink run. - -2002-02-13 Andreas Kupries - - * mpformats/fmt.html: Added detection of section cross-references - in [emph] and [strong] based on the code for TMML. - -2002-02-13 Joe English - - * mpformats/fmt.tmml: [example_begin] inside lists was - not handled correctly. - - * mpformats/fmt.tmml: Detect section cross-references - in [emph] and [strong]. - -2002-02-12 Andreas Kupries - - * mpformats/_html.tcl: Added command to map HTML special - characters to their escape sequences. - - * mpformats/fmt.latex: Added code to disable special processing of - plain text while inside of an example. - - * mpformats/fmt.tmml: Added HandleText call to [example] to handle - special XML characters inside of the example. Not requitred for - [example_begin] / [example_end] as the text will go through - HandleText automatically for that case. - - * mpformats/fmt.nroff: Added split to lsearch statement in - manpage_end to make the code robust against strings which are - not valid lists. - -2002-02-12 Joe English - - * Added [example_begin] and [example_end] commands. - Also [example { code ... }] command. - -2001-12-13 Andreas Kupries - - * Added formatter for LaTeX. - -2001-12-12 Andreas Kupries - - * New module. Application module providing a simple tcl-based - manpage markup language and a processor for converting this - format to TMML, nroff and HTML. Extensible, i.e. additional - formats can be added without to much work (Manpages for format - and internal interfaces are provided). DELETED modules/doctools/NOTES Index: modules/doctools/NOTES ================================================================== --- modules/doctools/NOTES +++ /dev/null @@ -1,34 +0,0 @@ -====== - TODO -====== - -* docidx / doctoc package documentation - sync with code -* doctools package documentation ditto - - - - -* Add a tk-based editor application which loads and generates - the format (and can invoke the processor to generate the other - formats). - -* Rewrite formatters to use generator packages for their - output format. Example: HTML => tcllib/html package - to generate the tags. Less quoting issues. Has escape - handlers. - -======= - -Note that running multiple formatters in parallel is possible, but -requires that the whole chain of expander, checker and engine are -replicated per format. The reason for this is that engine generates -some output, but always passes it up to its caller, i.e the expander, -for final composition. This is especially true for nested macro -invocations where the intermediate results generated by the engine are -passed through the expander to be sent down again into the engine. For -multiple engines we have to combine and then separate the results for -the various formats. The problem is to distinguish between data coming -from the engine and text coming from the outside, for the latter has -to be replicated instead of separated. This is possible, but I do not -believe that it is worth the additional complexity of the -implemementation. DELETED modules/doctools/api.tcl Index: modules/doctools/api.tcl ================================================================== --- modules/doctools/api.tcl +++ /dev/null @@ -1,31 +0,0 @@ -# -*- tcl -*- -# api.tcl -- API placeholders -# -# Copyright (c) 2001 Andreas Kupries -# Copyright (c) 2002 Andreas Kupries -# Copyright (c) 2003 Andreas Kupries - -################################################################ -# This file defines all commands expected from a formatter by the -# doctools library. It is loaded into the formatter interpreter before -# the code for a particular format is loaded. All commands defined -# here return an error. This ensures the generation of errors if a -# format forgets to define commands in the API. - -################################################################ -# Here it comes - -foreach __cmd { - initialize shutdown setup numpasses listvariables varset - - manpage_begin moddesc titledesc manpage_end require description - section para list_begin list_end lst_item call bullet enum see_also - keywords example example_begin example_end nl arg cmd opt emph strong - comment sectref syscmd method option widget fun type package class var - file uri term const copyright -} { - proc fmt_$__cmd {args} [list return "return -code error \"Unimplemented API command $__cmd\""] -} -unset __cmd - -################################################################ DELETED modules/doctools/api_idx.tcl Index: modules/doctools/api_idx.tcl ================================================================== --- modules/doctools/api_idx.tcl +++ /dev/null @@ -1,26 +0,0 @@ -# -*- tcl -*- -# api_idx.tcl -- API placeholders -# -# Copyright (c) 2003 Andreas Kupries - -################################################################ -# This file defines all commands expected from a docidx formatter by the -# doctools library. It is loaded into the formatter interpreter before -# the code for a particular docidx format is loaded. All commands defined -# here return an error. This ensures the generation of errors if a -# format forgets to define commands in the API. - -################################################################ -# Here it comes - -foreach __cmd { - idx_initialize idx_shutdown idx_setup idx_numpasses - idx_listvariables idx_varset - fmt_index_begin fmt_index_end fmt_key fmt_manpage fmt_url - fmt_comment fmt_plain_text -} { - proc $__cmd {args} [list return "return -code error \"Unimplemented API command $__cmd\""] -} -unset __cmd - -################################################################ DELETED modules/doctools/api_toc.tcl Index: modules/doctools/api_toc.tcl ================================================================== --- modules/doctools/api_toc.tcl +++ /dev/null @@ -1,26 +0,0 @@ -# -*- tcl -*- -# api_toc.tcl -- API placeholders -# -# Copyright (c) 2003 Andreas Kupries - -################################################################ -# This file defines all commands expected from a doctoc formatter by the -# doctools library. It is loaded into the formatter interpreter before -# the code for a particular doctoc format is loaded. All commands defined -# here return an error. This ensures the generation of errors if a -# format forgets to define commands in the API. - -################################################################ -# Here it comes - -foreach __cmd { - toc_initialize toc_shutdown toc_setup toc_numpasses - toc_listvariables toc_varset - fmt_toc_begin fmt_toc_end fmt_division_start fmt_division_end - fmt_item fmt_comment fmt_plain_text -} { - proc $__cmd {args} [list return "return -code error \"Unimplemented API command $__cmd\""] -} -unset __cmd - -################################################################ DELETED modules/doctools/changelog.man Index: modules/doctools/changelog.man ================================================================== --- modules/doctools/changelog.man +++ /dev/null @@ -1,59 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[manpage_begin doctools::changelog n 0.1] -[copyright {2003 Andreas Kupries }] -[moddesc {Documentation tools}] -[titledesc {Handle text in Emacs ChangeLog format}] -[require Tcl 8.2] -[require textutil] -[require doctools::changelog [opt 0.1]] -[description] - -This package provides tcl commands which are able to process and -reformat text in the [file ChangeLog] format generated [syscmd emacs]. - -[section COMMANDS] - - -[list_begin definitions] - -[call [cmd ::doctools::changelog::scan] [arg {text}]] - -The command takes the [arg text], parses it under the assumption that -it contains a ChangeLog as generated by [syscmd emacs] and returns a -data structure describing this ChangeLog. - -[nl] - -This data structure is a list whose elements describe one entry in the -ChangeLog each. Each entry is a list of three elements describing date -of the entry, its author, and the comments made, in this order. The -last element of each entry, the comments, is a list of sections. Each -section is described by two elements, a list of file names, and a -string containing the true comment associated with the files of the -section. - - -[call [cmd ::doctools::changelog::toDoctools] [arg {title module version entries}]] - -This command converts the pre-parsed ChangeLog [arg entries] (as -generated by [cmd ::doctools::changelog::scan]) into a document in -[term doctools] format and returns it as the result of the command. - -[nl] - -The other three arguments supply information for the header of that -document which is not available from the changelog itself. - - -[call [cmd ::doctools::changelog::merge] [arg entries]...] - -Each argument of the command is assumed to be a pre-parsed Changelog -as generated by [cmd ::doctools::changelog::scan]). The command merges -all of them into a single structure, collapsing multiple entries for -the same date and author into a single entry. The new structure is -returned as the result of the command. - -[list_end] - -[keywords changelog emacs doctools] -[manpage_end] DELETED modules/doctools/changelog.tcl Index: modules/doctools/changelog.tcl ================================================================== --- modules/doctools/changelog.tcl +++ /dev/null @@ -1,260 +0,0 @@ -# changelog.tcl -- -# -# Handling of ChangeLog's. -# -# Copyright (c) 2003 Andreas Kupries -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: changelog.tcl,v 1.1 2003/03/29 00:18:58 andreas_kupries Exp $ - - -# FUTURE -- Expand pre-parsed log (nested lists) into flat structures -# FUTURE -- => date/author/file/cref + cref/text -# FUTURE -- I.e. relational/tabular structure, useable in table displays, -# FUTURE -- sort by date, author, file to see aggregated changes -# FUTURE -- => Connectivity to 'struct::matrix', Reports! - - -package require Tcl 8.2 -package require textutil - -namespace eval ::doctools {} -namespace eval ::doctools::changelog { - namespace export scan toDoctools -} - -# ::doctools::changelog::scan -- -# -# Scan a ChangeLog generated by 'emacs' and extract the relevant information. -# -# Result -# List of entries. Each entry is a list of three elements. These -# are date, author, and commentary. The commentary is a list of -# sections. Each section is a list of two elements, a list of -# files, and the associated text. - - -proc ::doctools::changelog::scan {text} { - set text [split $text \n] - set n [llength $text] - - set entries [list] - set clist [list] - set files [list] - set comment "" - set first 1 - - for {set i 0} {$i < $n} {incr i} { - set line [lindex $text $i] - - if {[regexp "^\[^ \t\]" $line]} { - # No whitespace at the front, start a new entry - - closeEntry - - # For the upcoming entry. Quick extraction first, string - # based in case of failure. - - if {[catch { - set date [string trim [lindex $line 0]] - set author [string trim [lrange $line 1 end]] - }]} { - set pos [string first " " $line] - set date [string trim [string range $line 0 $pos]] - set author [string trim [string range $line $pos end]] - } - continue - } - - # Inside of an entry. - - set line [string trim $line] - - if {[string length $line] == 0} { - # Next comment section - closeSection - continue - } - - # Line is not empty. Split into file and comment parts, - # remember the data. - - if {[string first "* " $line] == 0} { - if {[regexp {^\* (.*):[ ]} $line full fname]} { - set line [string range $line [string length $full] end] - } elseif {[regexp {^\* (.*):$} $line full fname]} { - set line "" - } else { - # There is no filename - set fname "" - set line [string range $line 2 end] ; # Get rid of "* ". - } - - set detail "" - while {[string first "(" $fname] >= 0} { - if {[regexp {\([^)]*\)} $fname detailx]} { - regsub {\([^)]*\)} $fname {} fnameNew - } elseif {[regexp {\([^)]*} $fname detailx]} { - regsub {\([^)]*} $fname {} fnameNew - } else { - break - } - append detail " " $detailx - set fname [string trim $fnameNew] - } - if {$detail != {}} {set line "$detail $line"} - if {$fname != {}} {lappend files $fname} - } - - append comment $line\n - } - - closeEntry - return $entries -} - - -proc ::doctools::changelog::closeSection {} { - upvar clist clist comment comment files files - - if { - ([string length $comment] > 0) || - ([llength $files] > 0) - } { - lappend clist [list $files [string trim $comment]] - set files [list] - set comment "" - } - return -} - -proc ::doctools::changelog::closeEntry {} { - upvar clist clist comment comment files files first first - upvar date date author author entries entries - - if {!$first} { - closeSection - lappend entries [list $date $author $clist] - } - set first 0 - set clist [list] - set files [list] - set comment "" - return -} - -# ::doctools::changelog::merge -- -# -# Merge several preprocessed changelogs (see scan) into one structure. - - -proc ::doctools::changelog::merge {args} { - - if {[llength $args] == 0} {return {}} - if {[llength $args] == 1} {return [lindex $args 0]} - - set res [list] - array set tmp {} - - # Merge up ... - - foreach entries $args { - foreach e $entries { - foreach {date author comments} $e break - if {![info exists tmp($date,$author)]} { - lappend res [list $date $author] - set tmp($date,$author) $comments - } else { - foreach section $comments { - lappend tmp($date,$author) $section - } - } - } - } - - # ... And construct the final result - - set args $res - set res [list] - foreach key [lsort -decreasing $args] { - foreach {date author} $key break - lappend res [list $date $author $tmp($date,$author)] - } - return $res -} - - -# ::doctools::changelog::toDoctools -- -# -# Convert a preprocessed changelog log (see scan) into a doctools page. -# -# Arguments: -# evar, cvar, fvar: Name of the variables containing the preprocessed log. -# -# Results: -# A string containing a properly formatted ChangeLog. -# - -proc ::doctools::changelog::q {text} {return "\[$text\]"} - -proc ::doctools::changelog::toDoctools {title module version entries} { - - set linebuffer [list] - lappend linebuffer [q "manpage_begin [list ${title}-changelog n $version]"] - lappend linebuffer [q "titledesc [list "$title ChangeLog"]"] - lappend linebuffer [q "moddesc [list $module]"] - lappend linebuffer [q description] - lappend linebuffer [q "list_begin definitions compact"] - - foreach entry $entries { - foreach {date author commentary} $entry break - - lappend linebuffer [q "lst_item \"[q "emph [list $date]"] -- [string map {{"} {\"} {\"} {\\\"}} $author]\""] - - if {[llength $commentary] > 0} { - lappend linebuffer [q nl] - } - - foreach section $commentary { - foreach {files text} $section break - if {$text != {}} { - set text [string map {[ [lb] ] [rb]} [textutil::adjust $text]] - } - - if {[llength $files] > 0} { - lappend linebuffer [q "list_begin definitions"] - - foreach f $files { - lappend linebuffer [q "lst_item [q "file [list $f]"]"] - } - if {$text != {}} { - lappend linebuffer "" - lappend linebuffer $text - lappend linebuffer "" - } - - lappend linebuffer [q list_end] - } elseif {$text != {}} { - # No files - lappend linebuffer [q "list_begin bullet"] - lappend linebuffer [q bullet] - lappend linebuffer "" - lappend linebuffer $text - lappend linebuffer "" - lappend linebuffer [q list_end] - } - } - lappend linebuffer [q nl] - } - - lappend linebuffer [q list_end] - lappend linebuffer [q manpage_end] - return [join $linebuffer \n] -} - -#------------------------------------ -# Module initialization - -package provide doctools::changelog 0.1 DELETED modules/doctools/checker.tcl Index: modules/doctools/checker.tcl ================================================================== --- modules/doctools/checker.tcl +++ /dev/null @@ -1,476 +0,0 @@ -# -*- tcl -*- -# checker.tcl -# -# Code used inside of a checker interpreter to ensure correct usage of -# doctools formatting commands. -# -# Copyright (c) 2003 Andreas Kupries - -# L10N - -package require msgcat - -proc ::msgcat::mcunknown {locale code} { - return "unknown error code \"$code\" (for locale $locale)" -} - -if {0} { - puts stderr "Locale [::msgcat::mcpreferences]" - foreach path [dt_search] { - puts stderr "Catalogs: [::msgcat::mcload $path] - $path" - } -} else { - foreach path [dt_search] { - ::msgcat::mcload $path - } -} - -# State, and checker commands. -# ------------------------------------------------------------- -# -# Note that the code below assumes that a command XXX provided by the -# formatter engine is accessible under the name 'fmt_XXX'. -# -# ------------------------------------------------------------- - -global state lstctx lstitem - -# --------------+-----------------------+---------------------- -# state | allowed commands | new state (if any) -# --------------+-----------------------+---------------------- -# all except | arg cmd opt comment | -# for "done" | syscmd method option | -# | widget fun type class | -# | package var file uri | -# | strong emph | -# --------------+-----------------------+---------------------- -# manpage_begin | manpage_begin | header -# --------------+-----------------------+---------------------- -# header | moddesc titledesc | header -# | copyright | -# +-----------------------+----------- -# | require | requirements -# +-----------------------+----------- -# | description | body -# --------------+-----------------------+---------------------- -# requirements | require | requirements -# +-----------------------+----------- -# | description | body -# --------------+-----------------------+---------------------- -# body | section para list_end | body -# | list_begin lst_item | -# | call bullet usage nl | -# | example see_also | -# | keywords sectref enum | -# | arg_def cmd_def | -# | opt_def tkoption_def | -# +-----------------------+----------- -# | example_begin | example -# +-----------------------+----------- -# | manpage_end | done -# --------------+-----------------------+---------------------- -# example | example_end | body -# --------------+-----------------------+---------------------- -# done | | -# --------------+-----------------------+---------------------- -# -# Additional checks -# --------------------------------------+---------------------- -# list_begin/list_end | Are allowed to nest. -# --------------------------------------+---------------------- -# lst_item/call | Only in 'definition list'. -# enum | Only in 'enum list'. -# bullet | Only in 'bullet list'. -# arg_def | Only in 'argument list'. -# cmd_def | Only in 'command list'. -# opt_def | Only in 'option list'. -# tkoption_def | Only in 'tkoption list'. -# nl | Only in list item context. -# para section | Not allowed in list context -# --------------------------------------+---------------------- - -# ------------------------------------------------------------- -# Helpers -proc Error {code {text {}}} { - global state lstctx lstitem - - # Problematic command with all arguments (we strip the "ck_" prefix!) - # -*- future -*- count lines of input, maintain history buffer, use - # -*- future -*- that to provide some context here. - - set cmd [lindex [info level 1] 0] - set args [lrange [info level 1] 1 end] - if {$args != {}} {append cmd " [join $args]"} - - # Use a message catalog to map the error code into a legible message. - set msg [::msgcat::mc $code] - - if {$text != {}} { - set msg [string map [list @ $text] $msg] - } - dt_error "Manpage error ($code), \"$cmd\" : ${msg}." - return -} -proc Warn {code text} { - set msg [::msgcat::mc $code] - dt_warning "Manpage warning ($code): [join [split [format $msg $text] \n] "\nManpage warning ($code): "]" - return -} - -proc Is {s} {global state ; return [string equal $state $s]} -proc IsNot {s} {global state ; return [expr {![string equal $state $s]}]} -proc Go {s} {Log " >>\[$s\]" ; global state ; set state $s; return} -proc LPush {l} { - global lstctx lstitem - set lstctx [linsert $lstctx 0 $l $lstitem] - return -} -proc LPop {} { - global lstctx lstitem - set lstitem [lindex $lstctx 1] - set lstctx [lrange $lstctx 2 end] - return -} -proc LSItem {} {global lstitem ; set lstitem 1} -proc LIs {l} {global lstctx ; string equal $l [lindex $lstctx 0]} -proc LItem {} {global lstitem ; return $lstitem} -proc LNest {} { - global lstctx - expr {[llength $lstctx] / 2} -} -proc LOpen {} { - global lstctx - expr {$lstctx != {}} -} -proc LValid {what} { - switch -exact -- $what { - arg - definitions - - opt - bullet - - cmd - tkoption - - enum {return 1} - default {return 0} - } -} - -proc State {} {global state ; return $state} -proc Enter {cmd} {Log "\[[State]\] $cmd"} - -#proc Log* {text} {puts -nonewline $text} -#proc Log {text} {puts $text} -proc Log* {text} {} -proc Log {text} {} - - -# ------------------------------------------------------------- -# Framing -proc ck_initialize {} { - global state ; set state manpage_begin - global lstctx ; set lstctx [list] - global lstitem ; set lstitem 0 - return -} -proc ck_complete {} { - if {[Is done]} { - if {![LOpen]} { - return - } else { - Error end/open/list - } - } elseif {[Is example]} { - Error end/open/example - } else { - Error end/open/mp - } - return -} -# ------------------------------------------------------------- -# Plain text -proc plain_text {text} { - # Only in body, not between list_begin and first item. - # Ignore everything which is only whitespace ... - - set redux [string map [list " " "" "\t" "" "\n" ""] $text] - if {$redux == {}} {return [fmt_plain_text $text]} - if {[IsNot body] && [IsNot example]} {Error body} - if {[LOpen] && ![LItem]} {Error nolisttxt} - return [fmt_plain_text $text] -} - -# ------------------------------------------------------------- -# Variable handling ... - -proc vset {var args} { - switch -exact -- [llength $args] { - 0 { - # Retrieve contents of variable VAR - upvar #0 __$var data - return $data - } - 1 { - # Set contents of variable VAR - global __$var - set __$var [lindex $args 0] - return "" ; # Empty string ! Nothing for output. - } - default { - return -code error "wrong#args: set var ?value?" - } - } -} - -# ------------------------------------------------------------- -# Formatting commands -proc manpage_begin {title section version} { - Enter manpage_begin - if {[IsNot manpage_begin]} {Error mpbegin} - Go header - fmt_manpage_begin $title $section $version -} -proc moddesc {desc} { - Enter moddesc - if {[IsNot header]} {Error hdrcmd} - fmt_moddesc $desc -} -proc titledesc {desc} { - Enter titledesc - if {[IsNot header]} {Error hdrcmd} - fmt_titledesc $desc -} -proc copyright {text} { - Enter copyright - if {[IsNot header]} {Error hdrcmd} - fmt_copyright $text -} -proc manpage_end {} { - Enter manpage_end - if {[IsNot body]} {Error bodycmd} - Go done - fmt_manpage_end -} -proc require {pkg {version {}}} { - Enter require - if {[IsNot header] && [IsNot requirements]} {Error reqcmd} - Go requirements - fmt_require $pkg $version -} -proc description {} { - Enter description - if {[IsNot header] && [IsNot requirements]} {Error reqcmd} - Go body - fmt_description -} -proc section {name} { - Enter section - if {[IsNot body]} {Error bodycmd} - if {[LOpen]} {Error nolistcmd} - fmt_section $name -} -proc para {} { - Enter para - if {[IsNot body]} {Error bodycmd} - if {[LOpen]} {Error nolistcmd} - fmt_para -} -proc list_begin {what {hint {}}} { - Enter "list_begin $what $hint" - if {[IsNot body]} {Error bodycmd} - if {[LOpen] && ![LItem]} {Error nolisthdr} - if {![LValid $what]} {Error invalidlist $what} - LPush $what - fmt_list_begin $what $hint -} -proc list_end {} { - Enter list_end - if {[IsNot body]} {Error bodycmd} - if {![LOpen]} {Error listcmd} - LPop - fmt_list_end -} -proc lst_item {{text {}}} { - Enter lst_item - if {[IsNot body]} {Error bodycmd} - if {![LOpen]} {Error listcmd} - if {![LIs definitions]} {Error deflist} - LSItem - fmt_lst_item $text -} -proc arg_def {type name {mode {}}} { - Enter arg_def - if {[IsNot body]} {Error bodycmd} - if {![LOpen]} {Error listcmd} - if {![LIs arg]} {Error arg_list} - LSItem - fmt_arg_def $type $name $mode -} -proc cmd_def {command} { - Enter cmd_def - if {[IsNot body]} {Error bodycmd} - if {![LOpen]} {Error listcmd} - if {![LIs cmd]} {Error cmd_list} - LSItem - fmt_cmd_def $command -} -proc opt_def {name {arg {}}} { - Enter opt_def - if {[IsNot body]} {Error bodycmd} - if {![LOpen]} {Error listcmd} - if {![LIs opt]} {Error opt_list} - LSItem - fmt_opt_def $name $arg -} -proc tkoption_def {name dbname dbclass} { - Enter tkoption_def - if {[IsNot body]} {Error bodycmd} - if {![LOpen]} {Error listcmd} - if {![LIs tkoption]} {Error tkoption_list} - LSItem - fmt_tkoption_def $name $dbname $dbclass -} -proc call {cmd args} { - Enter call - if {[IsNot body]} {Error bodycmd} - if {![LOpen]} {Error listcmd} - if {![LIs definitions]} {Error deflist} - LSItem - eval [linsert $args 0 fmt_call $cmd] -} -proc bullet {} { - Enter bullet - if {[IsNot body]} {Error bodycmd} - if {![LOpen]} {Error listcmd} - if {![LIs bullet]} {Error bulletlist} - LSItem - fmt_bullet -} -proc enum {} { - Enter enum - if {[IsNot body]} {Error bodycmd} - if {![LOpen]} {Error listcmd} - if {![LIs enum]} {Error enumlist} - LSItem - fmt_enum -} -proc example {code} { - Enter example - return [example_begin][plain_text ${code}][example_end] -} -proc example_begin {} { - Enter example_begin - if {[IsNot body]} {Error bodycmd} - if {[LOpen] && ![LItem]} {Error nolisthdr} - Go example - fmt_example_begin -} -proc example_end {} { - Enter example_end - if {[IsNot example]} {Error examplecmd} - Go body - fmt_example_end -} -proc see_also {args} { - Enter see_also - if {[IsNot body]} {Error bodycmd} - if {[LOpen]} {Error nolistcmd} - eval [linsert $args 0 fmt_see_also] -} -proc keywords {args} { - Enter keywords - if {[IsNot body]} {Error bodycmd} - if {[LOpen]} {Error nolistcmd} - eval [linsert $args 0 fmt_keywords] -} -proc nl {} { - Enter nl - if {[IsNot body]} {Error bodycmd} - if {![LOpen]} {Error listcmd} - if {![LItem]} {Error nolisthdr} - fmt_nl -} -proc emph {text} { - if {[Is done]} {Error nodonecmd} - fmt_emph $text -} -proc strong {text} { - if {[Is done]} {Error nodonecmd} - if {[dt_deprecated]} {Warn depr_strong "\[strong \{$text\}\]"} - fmt_emph $text -} -proc arg {text} { - if {[Is done]} {Error nodonecmd} - fmt_arg $text -} -proc cmd {text} { - if {[Is done]} {Error nodonecmd} - fmt_cmd $text -} -proc opt {text} { - if {[Is done]} {Error nodonecmd} - fmt_opt $text -} -proc comment {text} { - if {[Is done]} {Error nodonecmd} - fmt_comment $text -} -proc sectref {name} { - if {[IsNot body]} {Error bodycmd} - if {[LOpen] && ![LItem]} {Error nolisthdr} - fmt_sectref $name -} -proc syscmd {text} { - if {[Is done]} {Error nodonecmd} - fmt_syscmd $text -} -proc method {text} { - if {[Is done]} {Error nodonecmd} - fmt_method $text -} -proc option {text} { - if {[Is done]} {Error nodonecmd} - fmt_option $text -} -proc widget {text} { - if {[Is done]} {Error nodonecmd} - widget $text -} -proc fun {text} { - if {[Is done]} {Error nodonecmd} - fmt_fun $text -} -proc type {text} { - if {[Is done]} {Error nodonecmd} - fmt_type $text -} -proc package {text} { - if {[Is done]} {Error nodonecmd} - fmt_package $text -} -proc class {text} { - if {[Is done]} {Error nodonecmd} - fmt_class $text -} -proc var {text} { - if {[Is done]} {Error nodonecmd} - fmt_var $text -} -proc file {text} { - if {[Is done]} {Error nodonecmd} - fmt_file $text -} -proc uri {text} { - if {[Is done]} {Error nodonecmd} - fmt_uri $text -} -proc usage {args} { - if {[Is done]} {Error nodonecmd} - eval fmt_usage $args -} -proc const {text} { - if {[Is done]} {Error nodonecmd} - fmt_const $text -} -proc term {text} { - if {[Is done]} {Error nodonecmd} - fmt_term $text -} - -# ------------------------------------------------------------- DELETED modules/doctools/checker_idx.tcl Index: modules/doctools/checker_idx.tcl ================================================================== --- modules/doctools/checker_idx.tcl +++ /dev/null @@ -1,207 +0,0 @@ -# -*- tcl -*- -# checker_idx.tcl -# -# Code used inside of a checker interpreter to ensure correct usage of -# docidx formatting commands. -# -# Copyright (c) 2003 Andreas Kupries - -# L10N - -package require msgcat - -proc ::msgcat::mcunknown {locale code} { - return "unknown error code \"$code\" (for locale $locale)" -} - -if {0} { - puts stderr "Locale [::msgcat::mcpreferences]" - foreach path [dt_search] { - puts stderr "Catalogs: [::msgcat::mcload $path] - $path" - } -} else { - foreach path [dt_search] { - ::msgcat::mcload $path - } -} - -# State, and checker commands. -# ------------------------------------------------------------- -# -# Note that the code below assumes that a command XXX provided by the -# formatter engine is accessible under the name 'fmt_XXX'. -# -# ------------------------------------------------------------- - -global state - -# State machine ... State centered -# --------------+-----------------------+---------------------- -# state | allowed commands | new state (if any) -# --------------+-----------------------+---------------------- -# all except | include vset | -# ==============+=======================+====================== -# idx_begin | idx_begin | -> contents -# --------------+-----------------------+---------------------- -# contents | key | -> ref_series -# --------------+-----------------------+---------------------- -# ref_series | manpage | -> refkey_series -# | url | -# --------------+-----------------------+---------------------- -# refkey_series | manpage | -> refkey_series -# | url | -# +-----------------------+----------- -# | key | -> ref_series -# +-----------------------+----------- -# | idx_end | -> done -# --------------+-----------------------+---------------------- - -# State machine, as above ... Command centered -# --------------+-----------------------+---------------------- -# state | allowed commands | new state (if any) -# --------------+-----------------------+---------------------- -# all except | include vset | -# ==============+=======================+====================== -# idx_begin | idx_begin | -> contents -# --------------+-----------------------+---------------------- -# contents | key | -> ref_series -# refkey_series | | -# --------------+-----------------------+---------------------- -# ref_series | manpage | -> refkey_series -# refkey_series | | -# --------------+-----------------------+---------------------- -# ref_series | url | -> refkey_series -# refkey_series | | -# --------------+-----------------------+---------------------- -# refkey_series | idx_end | -> done -# --------------+-----------------------+---------------------- - -# ------------------------------------------------------------- -# Helpers -proc Error {code {text {}}} { - global state - - # Problematic command with all arguments (we strip the "ck_" prefix!) - # -*- future -*- count lines of input, maintain history buffer, use - # -*- future -*- that to provide some context here. - - set cmd [lindex [info level 1] 0] - set args [lrange [info level 1] 1 end] - if {$args != {}} {append cmd " [join $args]"} - - # Use a message catalog to map the error code into a legible message. - set msg [::msgcat::mc $code] - - if {$text != {}} { - set msg [string map [list @ $text] $msg] - } - - dt_error "IDX error ($code), \"$cmd\" : ${msg}." - return -} -proc Warn {code text} { - set msg [::msgcat::mc $code] - dt_warning "IDX warning ($code): [join [split [format $msg $text] \n] "\nIDX warning ($code): "]" - return -} - -proc Is {s} {global state ; return [string equal $state $s]} -proc IsNot {s} {global state ; return [expr {![string equal $state $s]}]} -proc Go {s} {Log " >>\[$s\]" ; global state ; set state $s; return} -proc Push {s} {Log " //\[$s\]" ; global state stack ; lappend stack $state ; set state $s; return} -proc Pop {} {Log* " pop" ; global state stack ; set state [lindex $stack end] ; set stack [lrange $stack 0 end-1] ; Log " \\\\\[$state\]" ; return} -proc State {} {global state ; return $state} - -proc Enter {cmd} {Log* "\[[State]\] $cmd"} - -#proc Log* {text} {puts -nonewline $text} -#proc Log {text} {puts $text} -proc Log* {text} {} -proc Log {text} {} - -# ------------------------------------------------------------- -# Framing -proc ck_initialize {} { - global state ; set state idx_begin - global stack ; set stack [list] -} -proc ck_complete {} { - if {[Is done]} { - return - } else { - Error end/open/idx - } - return -} -# ------------------------------------------------------------- -# Plain text -proc plain_text {text} { - # Ignore everything which is only whitespace ... - # Beyond that plain text is not allowed. - - set redux [string map [list " " "" "\t" "" "\n" ""] $text] - if {$redux == {}} {return [fmt_plain_text $text]} - Error idx/plaintext - return "" -} - -# ------------------------------------------------------------- -# Variable handling ... - -proc vset {var args} { - switch -exact -- [llength $args] { - 0 { - # Retrieve contents of variable VAR - upvar #0 __$var data - return $data - } - 1 { - # Set contents of variable VAR - global __$var - set __$var [lindex $args 0] - return "" ; # Empty string ! Nothing for output. - } - default { - return -code error "wrong#args: set var ?value?" - } - } -} - -# ------------------------------------------------------------- -# Formatting commands -proc index_begin {label title} { - Enter index_begin - if {[IsNot idx_begin]} {Error idx/begincmd} - Go contents - fmt_index_begin $label $title -} -proc index_end {} { - Enter index_end - if {[IsNot refkey_series]} {Error idx/endcmd} - Go done - fmt_index_end -} -proc key {text} { - Enter key - if {[IsNot contents] && [IsNot refkey_series]} {Error idx/keycmd} - Go ref_series - fmt_key $text -} -proc manpage {file label} { - Enter manpage - if {[IsNot ref_series] && [IsNot refkey_series]} {Error idx/manpagecmd} - Go refkey_series - fmt_manpage $file $label -} -proc url {url label} { - Enter url - if {[IsNot ref_series] && [IsNot refkey_series]} {Error idx/urlcmd} - Go refkey_series - fmt_url $url $label -} -proc comment {text} { - if {[Is done]} {Error idx/nodonecmd} - fmt_comment $text -} - -# ------------------------------------------------------------- DELETED modules/doctools/checker_toc.tcl Index: modules/doctools/checker_toc.tcl ================================================================== --- modules/doctools/checker_toc.tcl +++ /dev/null @@ -1,228 +0,0 @@ -# -*- tcl -*- -# checker_toc.tcl -# -# Code used inside of a checker interpreter to ensure correct usage of -# doctoc formatting commands. -# -# Copyright (c) 2003 Andreas Kupries - -# L10N - -package require msgcat - -proc ::msgcat::mcunknown {locale code} { - return "unknown error code \"$code\" (for locale $locale)" -} - -if {0} { - puts stderr "Locale [::msgcat::mcpreferences]" - foreach path [dt_search] { - puts stderr "Catalogs: [::msgcat::mcload $path] - $path" - } -} else { - foreach path [dt_search] { - ::msgcat::mcload $path - } -} - -# State, and checker commands. -# ------------------------------------------------------------- -# -# Note that the code below assumes that a command XXX provided by the -# formatter engine is accessible under the name 'fmt_XXX'. -# -# ------------------------------------------------------------- - -global state - -# State machine ... State centered -# --------------+-----------------------+---------------------- -# state | allowed commands | new state (if any) -# --------------+-----------------------+---------------------- -# all except | include vset | -# ==============+=======================+====================== -# toc_begin | toc_begin | -> contents -# --------------+-----------------------+---------------------- -# contents | item | -> item_series -# +-----------------------+----------- -# | division_start | -> end, PUSH division -# --------------+-----------------------+---------------------- -# item_series | item | -> item_series -# +-----------------------+----------- -# | toc_end | -> done -# --------------+-----------------------+---------------------- -# division | item | -> div_items -# +-----------------------+----------- -# | division_start | -> div_series, PUSH division -# --------------+-----------------------+---------------------- -# div_series | division_start | -> div_series, PUSH division -# --------------+-----------------------+---------------------- -# div_items | item | -> div_items -# +-----------------------+----------- -# | division_end | POP (-> div_series / -> end) -# --------------+-----------------------+---------------------- -# end | toc_end | -> done -# +-----------------------+----------- -# | division_start | PUSH division -# --------------+-----------------------+---------------------- - -# State machine, as above ... Command centered -# --------------+-----------------------+---------------------- -# state | allowed commands | new state (if any) -# --------------+-----------------------+---------------------- -# all except | include vset | -# ==============+=======================+====================== -# toc_begin | toc_begin | -> contents -# --------------+-----------------------+---------------------- -# contents | item | -> item_series -# item_series | | -> item_series -# div_items | | -> div_items -# division | | -> div_items -# --------------+-----------------------+---------------------- -# contents | division_start | -> end, PUSH division -# div_series | | -> div_series, PUSH division -# end | | PUSH division -# division | | PUSH division -# --------------+-----------------------+---------------------- -# div_items | division_end | POP (-> div_series / -> end) -# --------------+-----------------------+---------------------- -# item_series | toc_end | -> done -# end | | -> done -# --------------+-----------------------+---------------------- - -# ------------------------------------------------------------- -# Helpers -proc Error {code {text {}}} { - global state - - # Problematic command with all arguments (we strip the "ck_" prefix!) - # -*- future -*- count lines of input, maintain history buffer, use - # -*- future -*- that to provide some context here. - - set cmd [lindex [info level 1] 0] - set args [lrange [info level 1] 1 end] - if {$args != {}} {append cmd " [join $args]"} - - # Use a message catalog to map the error code into a legible message. - set msg [::msgcat::mc $code] - - if {$text != {}} { - set msg [string map [list @ $text] $msg] - } - - dt_error "TOC error ($code), \"$cmd\" : ${msg}." - return -} -proc Warn {code text} { - set msg [::msgcat::mc $code] - dt_warning "TOC warning ($code): [join [split [format $msg $text] \n] "\nTOC warning ($code): "]" - return -} - -proc Is {s} {global state ; return [string equal $state $s]} -proc IsNot {s} {global state ; return [expr {![string equal $state $s]}]} -proc Go {s} {Log " >>\[$s\]" ; global state ; set state $s; return} -proc Push {s} {Log " //\[$s\]" ; global state stack ; lappend stack $state ; set state $s; return} -proc Pop {} {Log* " pop" ; global state stack ; set state [lindex $stack end] ; set stack [lrange $stack 0 end-1] ; Log " \\\\\[$state\]" ; return} -proc State {} {global state stack ; return "$stack || $state"} - -proc Enter {cmd} {Log* "\[[State]\] $cmd"} - -#proc Log* {text} {puts -nonewline $text} -#proc Log {text} {puts $text} -proc Log* {text} {} -proc Log {text} {} - -# ------------------------------------------------------------- -# Framing -proc ck_initialize {} { - global state ; set state toc_begin - global stack ; set stack [list] -} -proc ck_complete {} { - if {[Is done]} { - return - } else { - Error end/open/toc - } - return -} -# ------------------------------------------------------------- -# Plain text -proc plain_text {text} { - # Ignore everything which is only whitespace ... - # Beyond that plain text is not allowed. - - set redux [string map [list " " "" "\t" "" "\n" ""] $text] - if {$redux == {}} {return [fmt_plain_text $text]} - Error toc/plaintext - return "" -} - -# ------------------------------------------------------------- -# Variable handling ... - -proc vset {var args} { - switch -exact -- [llength $args] { - 0 { - # Retrieve contents of variable VAR - upvar #0 __$var data - return $data - } - 1 { - # Set contents of variable VAR - global __$var - set __$var [lindex $args 0] - return "" ; # Empty string ! Nothing for output. - } - default { - return -code error "wrong#args: set var ?value?" - } - } -} - -# ------------------------------------------------------------- -# Formatting commands -proc toc_begin {label title} { - Enter toc_begin - if {[IsNot toc_begin]} {Error toc/begincmd} - Go contents - fmt_toc_begin $label $title -} -proc toc_end {} { - Enter toc_end - if {[IsNot end] && [IsNot item_series]} {Error toc/endcmd} - Go done - fmt_toc_end -} -proc division_start {title} { - Enter division_start - if { - [IsNot contents] && [IsNot div_series] && [IsNot end] && [IsNot division] - } {Error toc/sectcmd} - if {[Is contents] || [Is end]} {Go end} else {Go div_series} - Push div_series - fmt_division_start $title -} -proc division_end {} { - Enter division_end - if {[IsNot div_items] && [IsNot div_series]} {Error toc/sectecmd [State]} - Pop - fmt_division_end -} -proc item {file label desc} { - Enter item - if { - [IsNot div_series] && [IsNot contents] && [IsNot item_series] && [IsNot div_items] - } { - Error toc/itemcmd - } - if {[Is div_items] || [Is div_series]} {Go div_items} else {Go item_series} - fmt_item $file $label $desc -} -proc comment {text} { - if {[Is done]} {Error toc/nodonecmd} - fmt_comment $text -} - -# ------------------------------------------------------------- DELETED modules/doctools/cvs.man Index: modules/doctools/cvs.man ================================================================== --- modules/doctools/cvs.man +++ /dev/null @@ -1,97 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[manpage_begin doctools::cvs n 0.1] -[copyright {2003 Andreas Kupries }] -[moddesc {Documentation tools}] -[titledesc {Handle text in 'cvs log' format}] -[require Tcl 8.2] -[require textutil] -[require doctools::cvs [opt 0.1]] -[description] - -This package provides tcl commands which are able to process and -reformat text in the format as generated by the [syscmd {cvs log}] -command. - -[para] - - -The commands [cmd scanLog] and [cmd toChangeLog] are derived from code -found on the Tcl'ers Wiki ([uri http://wiki.tcl.tk]). See the -references at the end of the page. - - -[section COMMANDS] - - -[list_begin definitions] - -[call [cmd ::doctools::cvs::scanLog] [arg {text evar cvar fvar}]] - -The command takes the [arg text] and fills the variables whose names -were specified through [arg evar], [arg cvar], and [arg fvar] with -information from the CVS log. - -[nl] - -Existing information is preserved, allowing the caller to merge data -from multiple logs into one database. - -[list_begin definitions] -[lst_item [arg evar]] - -Expected to refer to a scalar variable. After the call it contains a -list of all the entries found in the log file. An entry is identified -through the combination of date and author, and can be split over -multiple physical entries, one per touched file. - -[nl] - -Note that the entries are listed in the same order as they were found -in the [arg text]. This is not necessarily sorted by date or author. - -[nl] - -Each item in the list is a list containing two elements, the date of -the entry, and its author, in this order. The date is of the form -year/month/day - -[lst_item [arg cvar]] - -Expected to refer to an array variable. Keys into the array are the -date and author of log entries, in this order, separated by a -comma. - -[nl] - -The value per key is a list of comments made for the entry. - - - -[lst_item [arg fvar]] - -Expected to refer to an array variable. Keys into the array are the -date, author of a log entry, and a comment for that entry, in this -order, separated by commas. - -[nl] - -The value per key is a list of files the entry is touching. - -[list_end] -[nl] - -[call [cmd ::doctools::cvs::toChangeLog] [arg {evar cvar fvar}]] - -The three arguments are the same as the last three arguments of - -[cmd ::doctools::cvs::scanLog]. This command however expects them to -be filled with information about one or more logs. It takes this -information and constructs a text in the format of a ChangeLog as -accepted by [syscmd emacs]. The constructed text is returned as the -result of the command. - -[list_end] - -[see_also [uri http://wiki.tcl.tk/log2changelog]] -[keywords changelog cvs log {cvs log}] -[manpage_end] DELETED modules/doctools/cvs.tcl Index: modules/doctools/cvs.tcl ================================================================== --- modules/doctools/cvs.tcl +++ /dev/null @@ -1,138 +0,0 @@ -# cvs.tcl -- -# -# Handling of various cvs output formats. -# -# Copyright (c) 2003 Andreas Kupries -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: cvs.tcl,v 1.3 2003/03/31 22:00:13 andreas_kupries Exp $ - -package require Tcl 8.2 -package require textutil - -namespace eval ::doctools {} -namespace eval ::doctools::cvs { - namespace export scanLog toChangeLog -} - -# ::doctools::cvs::scanLog -- -# -# Scan a log generated by 'cvs log' and extract the relevant information. -# -# Arguments: -# text The text to scan -# -# Results: -# None. -# -# Sideeffects: -# None. -# -# Notes: -# Original location of code: http://wiki.tcl.tk/3638 -# aka http://wiki.tcl.tk/log2changelog -# Original author unknown. -# Bugfix by TR / Torsten Reincke - -proc ::doctools::cvs::scanLog {text evar cvar fvar} { - - set text [split $text \n] - set n [llength $text] - - upvar $evar entries ; #set entries [list] - upvar $cvar comments ; #array set comments {} - upvar $fvar files ; #array set files {} - - for {set i 0} {$i < $n} {incr i} { - set line [lindex $text $i] - switch -glob -- $line { - "*Working file:*" { - regexp {Working file: (.*)} $line -> filename - } - "date:*" { - scan $line "date: %s %s author: %s" date time author - set author [string trim $author ";"] - - # read the comment lines following date - set comment "" - incr i - set line [lindex $text $i] - # [TR]: use regexp here to see if log ends: - while {(![regexp "(-----*)|(=====*)" $line]) && ($i < $n)} { - append comment $line "\n" - incr i - set line [lindex $text $i] - } - - # Store this date/author/comment - lappend entries [list $date $author] - lappend comments($date,$author) $comment - lappend files($date,$author,$comment) $filename - } - } - } - - return -} - - -# ::doctools::cvs::toChangeLog -- - -# Convert a preprocessed cvs log (see scanLog) into a Changelog -# suitable for emacs. -# -# Arguments: -# evar, cvar, fvar: Name of the variables containing the preprocessed log. -# -# Results: -# A string containing a properly formatted ChangeLog. -# -# Sideeffects: -# None. -# -# Notes: -# Original location of code: http://wiki.tcl.tk/3638 -# aka http://wiki.tcl.tk/log2changelog -# Original author unknown. - -proc ::doctools::cvs::toChangeLog {evar cvar fvar} { - upvar $evar entries - upvar $cvar comments - upvar $fvar files - - set linebuffer [list] - - foreach e [lsort -unique -decreasing $entries] { - - # print the date/author - foreach {date author} $e {break} - lappend linebuffer "$date $author" - lappend linebuffer "" - - # Find all the comments submitted this date/author - - set clist [lsort -unique $comments($date,$author)] - - foreach c $clist { - # Print all files for a given comment - foreach f [lsort -unique $files($date,$author,$c)] { - lappend linebuffer "\t* $f:" - } - - # Format and print the comment - - lappend linebuffer [textutil::indent [textutil::undent $c] "\t "] - lappend linebuffer "" - continue - } - } - - return [join $linebuffer \n] -} - -#------------------------------------ -# Module initialization - -package provide doctools::cvs 0.1 DELETED modules/doctools/docidx.man Index: modules/doctools/docidx.man ================================================================== --- modules/doctools/docidx.man +++ /dev/null @@ -1,303 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[manpage_begin docidx n 1.0] -[copyright {2003 Andreas Kupries }] -[moddesc {Documentation tools}] -[titledesc {Create and manipulate docidx converter objects}] -[require Tcl 8.2] -[require doctools::idx [opt 1.0]] -[description] - -This package provides objects which can be used to convert text -written in the doctoc format as specified in [syscmd docidx_fmt] into -any output format X, assuming that a formatting engine for X is -available and provides the interface specified in [syscmd docidx_api]. - -[section API] - -[list_begin definitions] - -[call [cmd ::doctools::idx::new] [arg objectName] [opt [arg "option value"]...]] - -Creates a new docidx object with an associated global Tcl command -whose name is [arg objectName]. This command is explained in full -detail in the sections [sectref {OBJECT COMMAND}] and - -[sectref {OBJECT METHODS}]. - -[nl] - -The list of options and values coming after the name of the object is -used to set the initial configuration of the object. - -[call [cmd ::doctools::idx::help]] - -This is a pure convenience command for applications which want to -provide their user with a reminder of the available formatting -commands and their meanings. It returns a string containing a standard -help for this purpose. - - -[call [cmd ::doctools::idx::search] [arg path]] - -Whenever the package has to map the name of a format to the file -containing the code for its formatting engine it will search the file -in a number of directories. Three such directories are declared by the -package itself. - -[nl] - -However the list is extensible by the user of the package and the -command above is the means to do so. When given a [arg path] to an -existing and readable directory it will prepend that directory to the -existing list. This means that the path added last is searched through -first. - -[nl] - -An error will be thrown if the [arg path] either does not excist, is -not a directory, or is not readable. - -[list_end] - -[section {OBJECT COMMAND}] - -All commands created by [cmd ::doctools::idx::new] have the following -general form and may be used to invoke various operations on the -object they are associated with. - -[list_begin definitions] - -[call [cmd objectName] [arg option] [opt [arg "arg arg ..."]]] - -The [arg option] and its [arg arg]s determine the exact behavior of -the command. See section [sectref {OBJECT METHODS}] for more -explanations. - -[list_end] - -[section {OBJECT METHODS}] - -[list_begin definitions] - -[call [arg objectName] [method configure]] - -When called without argument this method returns a list of all known -options and their current values. - -[call [arg objectName] [method configure] [arg option]] - -When called with a single argument this method behaves like -[method cget]. - -[call [arg objectName] [method configure] [arg "option value"]...] - -When called with more than one argument the method reconfigures the -object using the [arg option]s and [arg value]s given to it. - -[nl] - -The legal configuration options are described in section -[sectref {OBJECT CONFIGURATION}]. - -[call [arg objectName] [method cget] [arg option]] - -This method expects a legal configuration option as argument and -returns the current value of that option for the object the method was -invoked for. - -[nl] - -The legal configuration options are described in section -[sectref {OBJECT CONFIGURATION}]. - -[call [arg objectName] [method destroy]] - -Destroys the object it is invoked for. - -[call [arg objectName] [method format] [arg text]] - -Takes the [arg text] and runs it through the configured formatting -engine. The resulting string is returned as the result of this -method. An error will be thrown if no [option -format] was configured -for the object. - -[nl] - -The method assumes that the [arg text] is in docidx format as -specified in [cmd dtformat(n)]. Errors will be thrown otherwise. - - -[call [arg objectName] [method search] [arg path]] - -This method extends the per-object list of paths searched for -formatting engines. See also [cmd ::doctools::idx::search] on how to extend -the global (per-package) list of paths. - -[nl] - -The path entered last is searched through first. - -[call [arg objectName] [method warnings]] - -Returns a list containing all the warnings generated by the engine -during the last invocation of method [method format]. - -[list_end] - -[section {OBJECT CONFIGURATION}] - -All docidx objects understand the following configuration options: - -[list_begin definitions] - -[lst_item "[option -file] [arg file]"] - -The argument of this option is stored in the object and can be -retrieved by the formatting engine via the command [cmd dt_file] (see -[cmd dtformatter(n)]). Its default value is the empty string. - -[nl] - -It will be interpreted as the name of the file containing the text -currently processed by the engine. - -[lst_item "[option -module] [arg text]"] - -The argument of this option is stored in the object and can be -retrieved by the formatting engine via the command [cmd dt_module] -(see [cmd dtformatter(n)]). Its default value is the empty string. - -[nl] - -It will be interpreted as the name of the module the file containing -the text currently processed by the engine belongs to. - -[lst_item "[option -format] [arg text]"] - -The argument of this option specifies the format and thus the engine -to use when converting text via [method format]. Its default value is -the empty string. No formatting is possible if this -option is not set at least once. - -[nl] - -The package will immediately try to map the name of the format to a -file containing the implementation of the engine for that format. An -error will be thrown if this mapping fails and a previously configured -format is left untouched. - -[nl] - -Section [sectref {FORMAT MAPPING}] explains how -the package looks for engine implementations. - -[lst_item "[option -deprecated] [arg boolean]"] - -This option is a flag. If set the object will generate warnings when -formatting a text containing the deprecated markup command [cmd strong] -Its default value is [const FALSE]. In other words, no warnings will -be generated. - -[list_end] - -[section {FORMAT MAPPING}] - -When trying to map a format name [term foo] to the file containing -the implementation of formatting engine for [term foo] the package -will perform the following algorithm: - -[list_begin enum] -[enum] - -If [term foo] is the name of an existing file this file is directly -taken as the implementation. - -[enum] - -If not, the list of per-object search paths is searched. For each -directory in the list the package checks if that directory contains a -file [file fmt.[term foo]]. If yes, that file is taken as the -implementation. - -[nl] - -This list of paths is initially empty and can be extended through the -object method [method search]. - -[enum] - -If not, the list of global (package) paths is searched. For each -directory in the list the package checks if that directory contains a -file [file idx.[term foo]]. If yes, that file is taken as the -implementation. - -[nl] - -This list of paths contains initially one path and can be extended -through the command [cmd ::doctools::idx::search]. - -[nl] - -The initial (standard) path is the sub directory [file mpformats] of -the directory the package itself is located in. In other words, if the -package implementation [file docidx.tcl] is installed in the -directory [file /usr/local/lib/tcllib/doctools] then it will by -default search the directory - -[file /usr/local/lib/tcllib/doctools/mpformats] for format -implementations. - -[enum] - -The mapping fails. - -[list_end] - - -[section {ENGINES}] - -The package comes with the following predefined formatting engines - -[list_begin definitions] -[lst_item html] - -This engine generates HTML markup, for processing by web browsers and -the like. - -[lst_item latex] - -This engine generates output suitable for the [syscmd latex] text -processor coming out of the TeX world. - -[lst_item list] - -This engine retrieves version, section and title of the manpage from -the document. As such it can be used to generate a directory listing -for a set of manpages. - -[lst_item nroff] - -This engine generates nroff output, for processing by [syscmd nroff], -or [syscmd groff]. The result will be standard man pages as they are -known in the unix world. - -[lst_item null] - -This engine generates no outout at all. This can be used if one just -wants to validate some input. - -[lst_item tmml] - -This engine generates TMML markup as specified by Joe English. The Tcl -Manpage Markup Language is a derivate of XML. - -[lst_item wiki] - -This engine generates Wiki markup as understood by Jean Claude -Wippler's [syscmd wikit] application. - -[list_end] - -[see_also docidx_api docidx_fmt] -[keywords toc {table of contents} index documentation manpage TMML HTML nroff conversion markup] -[manpage_end] DELETED modules/doctools/docidx.tcl Index: modules/doctools/docidx.tcl ================================================================== --- modules/doctools/docidx.tcl +++ /dev/null @@ -1,899 +0,0 @@ -# docidx.tcl -- -# -# Implementation of docidx objects for Tcl. -# -# Copyright (c) 2003 Andreas Kupries -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: docidx.tcl,v 1.3 2003/04/01 23:38:19 andreas_kupries Exp $ - -package require Tcl 8.2 -package require textutil::expander - -namespace eval ::doctools {} -namespace eval ::doctools::idx { - # Data storage in the doctools::idx module - # ------------------------------- - # - # One namespace per object, containing - # 1) A list of additional search paths for format definition files. - # This list extends the list of standard paths known to the module. - # The paths in the list are searched before the standard paths. - # 2) Configuration information - # a) string: The format to use when converting the input. - # 4) Name of the interpreter used to perform the syntax check of the - # input (= allowed order of formatting commands). - # 5) Name of the interpreter containing the code coming from the format - # definition file. - # 6) Name of the expander object used to interpret the input to convert. - - # commands is the list of subcommands recognized by the docidx objects - variable commands [list \ - "cget" \ - "configure" \ - "destroy" \ - "format" \ - "map" \ - "search" \ - "warnings" \ - "parameters" \ - "setparam" \ - ] - - # Only export the toplevel commands - namespace export new search help - - # Global data - - # 1) List of standard paths to look at when searching for a format - # definition. Extensible. - # 2) Location of this file in the filesystem - - variable paths [list] - variable here [file dirname [info script]] -} - -# ::doctools::idx::search -- -# -# Extend the list of paths used when searching for format definition files. -# -# Arguments: -# path Path to add to the list. The path has to exist, has to be a -# directory, and has to be readable. -# -# Results: -# None. -# -# Sideeffects: -# The specified path is added to the front of the list of search -# paths. This means that the new path is search before the -# standard paths set at module initialization time. - -proc ::doctools::idx::search {path} { - variable paths - - if {![file exists $path]} {return -code error "doctools::idx::search: path does not exist"} - if {![file isdirectory $path]} {return -code error "doctools::idx::search: path is not a directory"} - if {![file readable $path]} {return -code error "doctools::idx::search: path cannot be read"} - - set paths [linsert $paths 0 $path] - return -} - -# ::doctools::idx::help -- -# -# Return a string containing short help -# regarding the existing formatting commands. -# -# Arguments: -# None. -# -# Results: -# A string. - -proc ::doctools::idx::help {} { - return "formatting commands\n\ - * index_begin - begin of index\n\ - * index_end - end of index\n\ - * key - begin of references for key\n\ - * manpage - index reference to manpage\n\ - * url - index reference to url\n\ - * vset - set/get variable values\n\ - * include - insert external file\n\ - * lb, rb - left/right brackets\n\ - " -} - -# ::doctools::idx::new -- -# -# Create a new docidx object with a given name. May configure the object. -# -# Arguments: -# name Name of the docidx object. -# args Options configuring the new object. -# -# Results: -# name Name of the doctools created - -proc ::doctools::idx::new {name args} { - if { [llength [info commands ::$name]] } { - return -code error "command \"$name\" already exists, unable to create docidx object" - } - if {[llength $args] % 2 == 1} { - return -code error "wrong # args: doctools::new name ?opt val...??" - } - - # The arguments seem to be ok, setup the namespace for the object - - namespace eval ::doctools::idx::docidx$name { - variable paths [list] - variable file "" - variable format "" - variable formatfile "" - variable format_ip "" - variable chk_ip "" - variable expander "[namespace current]::ex" - variable ex_ok 0 - variable msg [list] - variable map ; array set map {} - variable param [list] - } - - # Create the command to manipulate the object - # $name -> ::doctools::idx::DocIdxProc $name - interp alias {} ::$name {} ::doctools::idx::DocIdxProc $name - - # If the name was followed by arguments use them to configure the - # object before returning its handle to the caller. - - if {[llength $args] > 1} { - # Use linsert trick to make the command a pure list. - eval [linsert $args 0 _configure $name] - } - return $name -} - -########################## -# Private functions follow - -# ::doctools::idx::DocIdxProc -- -# -# Command that processes all docidx object commands. -# Dispatches any object command to the appropriate internal -# command implementing its functionality. -# -# Arguments: -# name Name of the docidx object to manipulate. -# cmd Subcommand to invoke. -# args Arguments for subcommand. -# -# Results: -# Varies based on command to perform - -proc ::doctools::idx::DocIdxProc {name {cmd ""} args} { - # Do minimal args checks here - if { [llength [info level 0]] == 2 } { - error "wrong # args: should be \"$name option ?arg arg ...?\"" - } - - # Split the args into command and args components - - if { [llength [info commands ::doctools::idx::_$cmd]] == 0 } { - variable commands - set optlist [join $commands ", "] - set optlist [linsert $optlist "end-1" "or"] - return -code error "bad option \"$cmd\": must be $optlist" - } - return [eval [list ::doctools::idx::_$cmd $name] $args] -} - -########################## -# Method implementations follow (these are also private commands) - -# ::doctools::idx::_cget -- -# -# Retrieve the current value of a particular option -# -# Arguments: -# name Name of the docidx object to query -# option Name of the option whose value we are asking for. -# -# Results: -# The value of the option - -proc ::doctools::idx::_cget {name option} { - _configure $name $option -} - -# ::doctools::idx::_configure -- -# -# Configure a docidx object, or query its configuration. -# -# Arguments: -# name Name of the docidx object to configure -# args Options and their values. -# -# Results: -# None if configuring the object. -# A list of all options and their values if called without arguments. -# The value of one particular option if called with a single argument. - -proc ::doctools::idx::_configure {name args} { - if {[llength $args] == 0} { - # Retrieve the current configuration. - - upvar ::doctools::idx::docidx${name}::file file - upvar ::doctools::idx::docidx${name}::format format - - set res [list] - lappend res -file $file - lappend res -format $format - return $res - - } elseif {[llength $args] == 1} { - # Query the value of one particular option. - - switch -exact -- [lindex $args 0] { - -file { - upvar ::doctools::idx::docidx${name}::file file - return $file - } - -format { - upvar ::doctools::idx::docidx${name}::format format - return $format - } - default { - return -code error \ - "doctools::idx::_configure: Unknown option \"[lindex $args 0]\", expected\ - -file, or -format" - } - } - } else { - # Reconfigure the object. - - if {[llength $args] % 2 == 1} { - return -code error "wrong # args: doctools::idx::_configure name ?opt val...??" - } - - foreach {option value} $args { - switch -exact -- $option { - -file { - upvar ::doctools::idx::docidx${name}::file file - set file $value - } - -format { - if {[catch { - set fmtfile [LookupFormat $name $value] - SetupFormatter $name $fmtfile - upvar ::doctools::idx::docidx${name}::format format - set format $value - } msg]} { - return -code error "doctools::idx::_configure: -format: $msg" - } - } - default { - return -code error \ - "doctools::idx::_configure: Unknown option \"$option\", expected\ - -file, or -format" - } - } - } - } - return "" -} - -# ::doctools::idx::_destroy -- -# -# Destroy a docidx object, including its associated command and data storage. -# -# Arguments: -# name Name of the docidx object to destroy. -# -# Results: -# None. - -proc ::doctools::idx::_destroy {name} { - # Check the object for sub objects which have to destroyed before - # the namespace is torn down. - namespace eval ::doctools::idx::docidx$name { - if {$format_ip != ""} {interp delete $format_ip} - if {$chk_ip != ""} {interp delete $chk_ip} - - # Expander objects have no delete/destroy method. This would - # be a leak if not for the fact that an expander object is a - # namespace, and we have arranged to make it a sub namespace of - # the docidx object. Therefore tearing down our object namespace - # also cleans up the expander object. - # if {$expander != ""} {$expander destroy} - - } - namespace delete ::doctools::idx::docidx$name - interp alias {} ::$name {} - return -} - -# ::doctools::idx::_map -- -# -# Add a mapping from symbolic to actual filename to the object. -# -# Arguments: -# name Name of the docidx object to use -# sfname Symbolic filename to map -# afname Actual filename -# -# Results: -# None. - -proc ::doctools::idx::_map {name sfname afname} { - upvar ::doctools::idx::docidx${name}::map map - set map($sfname) $afname - return -} - -# ::doctools::idx::_format -- -# -# Convert some text in doctools format -# according to the configuration in the object. -# -# Arguments: -# name Name of the docidx object to use -# text Text to convert. -# -# Results: -# The conversion result. - -proc ::doctools::idx::_format {name text} { - upvar ::doctools::idx::docidx${name}::format format - if {$format == ""} { - return -code error "$name: No format was specified" - } - - upvar ::doctools::idx::docidx${name}::format_ip format_ip - upvar ::doctools::idx::docidx${name}::chk_ip chk_ip - upvar ::doctools::idx::docidx${name}::ex_ok ex_ok - upvar ::doctools::idx::docidx${name}::expander expander - upvar ::doctools::idx::docidx${name}::passes passes - upvar ::doctools::idx::docidx${name}::msg warnings - - if {!$ex_ok} {SetupExpander $name} - if {$chk_ip == ""} {SetupChecker $name} - # assert (format_ip != "") - - set warnings [list] - if {[catch {$format_ip eval idx_initialize}]} { - return -code error "Could not initialize engine" - } - set result "" - - for { - set p $passes ; set n 1 - } { - $p > 0 - } { - incr p -1 ; incr n - } { - if {[catch {$format_ip eval [list idx_setup $n]}]} { - catch {$format_ip eval idx_shutdown} - return -code error "Could not initialize pass $n of engine" - } - $chk_ip eval ck_initialize - - if {[catch {set result [$expander expand $text]} msg]} { - catch {$format_ip eval idx_shutdown} - # Filter for checker errors and reduce them to the essential message. - - if {![regexp {^Error in} $msg]} {return -code error $msg} - set msg [join [lrange [split $msg \n] 2 end]] - - if {![regexp {^--> \(FmtError\) } $msg]} {return -code error @$msg} - set msg [lindex [split $msg \n] 0] - regsub {^--> \(FmtError\) } $msg {} msg - - return -code error $msg - } - - $chk_ip eval ck_complete - } - - if {[catch {set result [$format_ip eval [list idx_postprocess $result]]}]} { - return -code error "Unable to post process final result" - } - if {[catch {$format_ip eval idx_shutdown}]} { - return -code error "Could not shut engine down" - } - return $result - -} - -# ::doctools::idx::_search -- -# -# Add a search path to the object. -# -# Arguments: -# name Name of the docidx object to extend -# path Search path to add. -# -# Results: -# None. - -proc ::doctools::idx::_search {name path} { - if {![file exists $path]} {return -code error "$name search: path does not exist"} - if {![file isdirectory $path]} {return -code error "$name search: path is not a directory"} - if {![file readable $path]} {return -code error "$name search: path cannot be read"} - - upvar ::doctools::idx::docidx${name}::paths paths - set paths [linsert $paths 0 $path] - return -} - -# ::doctools::idx::_warnings -- -# -# Return the warning accumulated during the last invocation of 'format'. -# -# Arguments: -# name Name of the docidx object to query -# -# Results: -# A list of warnings. - -proc ::doctools::idx::_warnings {name} { - upvar ::doctools::idx::docidx${name}::msg msg - return $msg -} - -# ::doctools::_parameters -- -# -# Returns a list containing the parameters provided -# by the selected formatting engine. -# -# Arguments: -# name Name of the doctools object to query -# -# Results: -# A list of parameter names - -proc ::doctools::idx::_parameters {name} { - upvar ::doctools::idx::docidx${name}::param param - return $param -} - -# ::doctools::_setparam -- -# -# Set a named engine parameter to a value. -# -# Arguments: -# name Name of the doctools object to query -# param Name of the parameter to set. -# value Value to set the parameter to. -# -# Results: -# None. - -proc ::doctools::idx::_setparam {name param value} { - upvar ::doctools::idx::docidx${name}::format_ip format_ip - - if {$format_ip == {}} { - return -code error \ - "Unable to set parameters without a valid format" - } - - $format_ip eval [list idx_varset $param $value] - return -} - -########################## -# Support commands - -# ::doctools::idx::LookupFormat -- -# -# Search a format definition file based upon its name -# -# Arguments: -# name Name of the docidx object to use -# format Name of the format to look for. -# -# Results: -# The file containing the format definition - -proc ::doctools::idx::LookupFormat {name format} { - # Order of searching - # 1) Is the name of the format an existing file ? - # If yes, take this file. - # 2) Look for the file in the directories given to the object itself.. - # 3) Look for the file in the standard directories of this package. - - if {[file exists $format]} { - return $format - } - - upvar ::doctools::idx::docidx${name}::paths opaths - foreach path $opaths { - set f [file join $path idx.$format] - if {[file exists $f]} { - return $f - } - } - - variable paths - foreach path $paths { - set f [file join $path idx.$format] - if {[file exists $f]} { - return $f - } - } - - return -code error "Unknown format \"$format\"" -} - -# ::doctools::idx::SetupFormatter -- -# -# Create and initializes an interpreter containing a -# formatting engine -# -# Arguments: -# name Name of the docidx object to manipulaye -# format Name of file containing the code of the engine -# -# Results: -# None. - -proc ::doctools::idx::SetupFormatter {name format} { - - # Create and initialize the interpreter first. - # Use a transient variable. Interrogate the - # engine and check its response. Bail out in - # case of errors. Only if we pass the checks - # we tear down the old engine and make the new - # one official. - - variable here - set mpip [interp create -safe] ; # interpreter for the formatting engine - #set mpip [interp create] ; # interpreter for the formatting engine - - $mpip invokehidden source [file join $here api_idx.tcl] - #$mpip eval [list source [file join $here api_idx.tcl]] - interp alias $mpip dt_source {} ::doctools::idx::Source $mpip [file dirname $format] - interp alias $mpip dt_package {} ::doctools::Package $mpip - interp alias $mpip file {} ::doctools::FileOp $mpip - interp alias $mpip puts_stderr {} ::puts stderr - $mpip invokehidden source $format - #$mpip eval [list source $format] - - # Check the engine for useability in doctools. - - foreach api { - idx_numpasses - idx_initialize - idx_setup - idx_postprocess - idx_shutdown - idx_listvariables - idx_varset - } { - if {[$mpip eval [list info commands $api]] == {}} { - interp delete $mpip - error "$format error: API incomplete, cannot use this engine" - } - } - if {[catch { - set passes [$mpip eval idx_numpasses] - }]} { - interp delete $mpip - error "$format error: Unable to query for number of passes" - } - if {![string is integer $passes] || ($passes < 1)} { - interp delete $mpip - error "$format error: illegal number of passes \"$passes\"" - } - if {[catch { - set parameters [$mpip eval idx_listvariables] - }]} { - interp delete $mpip - error "$format error: Unable to query for list of parameters" - } - - # Passed the tests. Tear down existing engine, - # and checker. The latter is destroyed because - # of its aliases into the formatter, which are - # now invalid. It will be recreated during the - # next call of 'format'. - - upvar ::doctools::idx::docidx${name}::formatfile formatfile - upvar ::doctools::idx::docidx${name}::format_ip format_ip - upvar ::doctools::idx::docidx${name}::chk_ip chk_ip - upvar ::doctools::idx::docidx${name}::expander expander - upvar ::doctools::idx::docidx${name}::passes xpasses - upvar ::doctools::idx::docidx${name}::param xparam - - if {$chk_ip != {}} {interp delete $chk_ip} - if {$format_ip != {}} {interp delete $format_ip} - - set chk_ip "" - set format_ip "" - - # Now link engine API into it. - - interp alias $mpip dt_format {} ::doctools::idx::GetFormat $name - interp alias $mpip dt_user {} ::doctools::idx::GetUser $name - interp alias $mpip dt_fmap {} ::doctools::idx::MapFile $name - - foreach cmd {cappend cget cis cname cpop cpush cset lb rb} { - interp alias $mpip ex_$cmd {} $expander $cmd - } - - set format_ip $mpip - set formatfile $format - set xpasses $passes - set xparam $parameters - return -} - -# ::doctools::idx::SetupChecker -- -# -# Create and initializes an interpreter for checking the usage of -# docidx formatting commands -# -# Arguments: -# name Name of the docidx object to manipulaye -# -# Results: -# None. - -proc ::doctools::idx::SetupChecker {name} { - # Create an interpreter for checking the usage of docidx formatting commands - # and initialize it: Link it to the interpreter doing the formatting, the - # expander object and the configuration information. All of which - # is accessible through the token/handle (name of state/object array). - - variable here - - upvar ::doctools::idx::docidx${name}::chk_ip chk_ip - if {$chk_ip != ""} {return} - - upvar ::doctools::idx::docidx${name}::expander expander - upvar ::doctools::idx::docidx${name}::format_ip format_ip - - set chk_ip [interp create] ; # interpreter hosting the formal format checker - - # Make configuration available through command, then load the code base. - - foreach {cmd ckcmd} { - dt_search SearchPaths - dt_error FmtError - dt_warning FmtWarning - } { - interp alias $chk_ip $cmd {} ::doctools::idx::$ckcmd $name - } - $chk_ip eval [list source [file join $here checker_idx.tcl]] - - # Simple expander commands are directly routed back into it, no - # checking required. - - foreach cmd {cappend cget cis cname cpop cpush cset lb rb} { - interp alias $chk_ip $cmd {} $expander $cmd - } - - # Link the formatter commands into the checker. We use the prefix - # 'fmt_' to distinguish them from the checking commands. - - foreach cmd { - index_begin index_end key manpage url comment plain_text - } { - interp alias $chk_ip fmt_$cmd $format_ip fmt_$cmd - } - return -} - -# ::doctools::idx::SetupExpander -- -# -# Create and initializes the expander for input -# -# Arguments: -# name Name of the docidx object to manipulaye -# -# Results: -# None. - -proc ::doctools::idx::SetupExpander {name} { - upvar ::doctools::idx::docidx${name}::ex_ok ex_ok - if {$ex_ok} {return} - - upvar ::doctools::idx::docidx${name}::expander expander - ::textutil::expander $expander - $expander evalcmd [list ::doctools::idx::Eval $name] - $expander textcmd plain_text - set ex_ok 1 - return -} - -# ::doctools::idx::SearchPaths -- -# -# API for checker. Returns list of search paths for format -# definitions. Used to look for message catalogs as well. -# -# Arguments: -# name Name of the docidx object to query. -# -# Results: -# None. - -proc ::doctools::idx::SearchPaths {name} { - upvar ::doctools::idx::docidx${name}::paths opaths - variable paths - - set p $opaths - foreach s $paths {lappend p $s} - return $p -} - -# ::doctools::idx::FmtError -- -# -# API for checker. Called when an error occured. -# -# Arguments: -# name Name of the docidx object to query. -# text Error message -# -# Results: -# None. - -proc ::doctools::idx::FmtError {name text} { - return -code error "(FmtError) $text" -} - -# ::doctools::idx::FmtWarning -- -# -# API for checker. Called when a warning was generated -# -# Arguments: -# name Name of the docidx object -# text Warning message -# -# Results: -# None. - -proc ::doctools::idx::FmtWarning {name text} { - upvar ::doctools::idx::docidx${name}::msg msg - lappend msg $text - return -} - -# ::doctools::idx::Eval -- -# -# API for expander. Routes the macro invocations -# into the checker interpreter -# -# Arguments: -# name Name of the docidx object to query. -# -# Results: -# None. - -proc ::doctools::idx::Eval {name macro} { - upvar ::doctools::idx::docidx${name}::chk_ip chk_ip - - # Handle the [include] command directly - if {[string match include* $macro]} { - foreach {cmd filename} $macro break - return [ExpandInclude $name $filename] - } - - return [$chk_ip eval $macro] -} - -# ::doctools::idx::ExpandInclude -- -# -# Handle inclusion of files. -# -# Arguments: -# name Name of the docidx object to query. -# path Name of file to include and expand. -# -# Results: -# None. - -proc ::doctools::idx::ExpandInclude {name path} { - upvar ::doctools::idx::docidx${name}::file file - - set ipath [file join [file dirname $file] $path] - if {![file exists $ipath]} { - set ipath $path - if {![file exists $ipath]} { - return -code error "Unable to fine include file \"$path\"" - } - } - - set chan [open $ipath r] - set text [read $chan] - close $chan - - upvar ::doctools::idx::docidx${name}::expander expander - - return [$expander expand $text] -} - -# ::doctools::idx::GetUser -- -# -# API for formatter. Returns name of current user -# -# Arguments: -# name Name of the docidx object to query. -# -# Results: -# String, name of current user. - -proc ::doctools::idx::GetUser {name} { - global tcl_platform - return $tcl_platform(user) -} - -# ::doctools::idx::GetFormat -- -# -# API for formatter. Returns format information -# -# Arguments: -# name Name of the docidx object to query. -# -# Results: -# Format information - -proc ::doctools::idx::GetFormat {name} { - upvar ::doctools::idx::docidx${name}::format format - return $format -} - -# ::doctools::idx::MapFile -- -# -# API for formatter. Maps symbolic to actual filename in an -# index element. If no mapping is found it is assumed that -# the symbolic name is also the actual name. -# -# Arguments: -# name Name of the docidx object to query. -# fname Symbolic name of the file. -# -# Results: -# Actual name of the file. - -proc ::doctools::idx::MapFile {name fname} { - upvar ::doctools::idx::docidx${name}::map map - if {[info exists map($fname)]} { - return $map($fname) - } - return $fname -} - -# ::doctools::idx::Source -- -# -# API for formatter. Used by engine to ask for -# additional script files support it. -# -# Arguments: -# name Name of the docidx object to change. -# -# Results: -# Boolean flag. - -proc ::doctools::idx::Source {ip path file} { - $ip invokehidden source [file join $path [file tail $file]] - #$ip eval [list source [file join $path [file tail $file]]] - return -} - -#------------------------------------ -# Module initialization - -namespace eval ::doctools::idx { - # Reverse order of searching. First to search is specified last. - - # FOO/docidx.tcl - # => FOO/mpformats - - #catch {search [file join $here lib doctools mpformats]} - #catch {search [file join [file dirname $here] lib doctools mpformats]} - catch {search [file join $here mpformats]} -} - -package provide doctools::idx 0.1 DELETED modules/doctools/docidx.test Index: modules/doctools/docidx.test ================================================================== --- modules/doctools/docidx.test +++ /dev/null @@ -1,277 +0,0 @@ -# -*- tcl -*- -# docidx.test: tests for the doctools::idx package. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 2003 by Andreas Kupries -# All rights reserved. -# -# RCS: @(#) $Id: docidx.test,v 1.1 2003/03/05 06:50:33 andreas_kupries Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -package require doctools::idx -puts "doctools::idx [package present doctools::idx]" - -namespace import ::doctools::idx::new - -# search paths ............................................................. - -test docidx-1.0 {default search paths} { - llength $::doctools::idx::paths -} 1 - -test docidx-1.1 {extend package search paths} { - ::doctools::idx::search [file dirname [info script]] - set res [list] - lappend res [llength $::doctools::idx::paths] - lappend res [lindex $::doctools::idx::paths 0] - set res -} [list 2 [file dirname [info script]]] - -test docidx-1.2 {extend package search paths, error} { - catch {::doctools::idx::search foo} result - set result -} {doctools::idx::search: path does not exist} - -# format help ............................................................. - -test docidx-2.0 {format help} { - string length [doctools::idx::help] -} 368 - -# docidx ............................................................. - -test docidx-3.0 {docidx errors} { - catch {new} msg - set msg -} [tcltest::getErrorMessage "new" "name args" 0] - -test docidx-3.1 {docidx errors} { - catch {new set} msg - set msg -} "command \"set\" already exists, unable to create docidx object" - -test docidx-3.2 {docidx errors} { - new mydocidx - catch {new mydocidx} msg - mydocidx destroy - set msg -} "command \"mydocidx\" already exists, unable to create docidx object" - -test docidx-3.3 {docidx errors} { - catch {new mydocidx -foo} msg - set msg -} {wrong # args: doctools::new name ?opt val...??} - -# docidx methods ...................................................... - -test docidx-4.0 {docidx method errors} { - new mydocidx - catch {mydocidx} msg - mydocidx destroy - set msg -} "wrong # args: should be \"mydocidx option ?arg arg ...?\"" - -test docidx-4.1 {docidx errors} { - new mydocidx - catch {mydocidx foo} msg - mydocidx destroy - set msg -} "bad option \"foo\": must be cget, configure, destroy, format, map, search, warnings, parameters, or setparam" - -# cget .................................................................. - -test docidx-5.0 {cget errors} { - new mydocidx - catch {mydocidx cget} result - mydocidx destroy - set result -} [tcltest::getErrorMessage "::doctools::idx::_cget" "name option" 1] - -test docidx-5.1 {cget errors} { - new mydocidx - catch {mydocidx cget foo bar} result - mydocidx destroy - set result -} [tcltest::tooManyMessage "::doctools::idx::_cget" "name option"] - -test docidx-5.2 {cget errors} { - new mydocidx - catch {mydocidx cget -foo} result - mydocidx destroy - set result -} {doctools::idx::_configure: Unknown option "-foo", expected -file, or -format} - -foreach {na nb option default newvalue} { - 3 4 -file {} foo - 5 6 -format {} html -} { - test docidx-5.$na {cget query} { - new mydocidx - set res [mydocidx cget $option] - mydocidx destroy - set res - } $default ; # {} - - test docidx-5.$nb {cget set & query} { - new mydocidx - mydocidx configure $option $newvalue - set res [mydocidx cget $option] - mydocidx destroy - set res - } $newvalue ; # {} -} - -# configure .................................................................. - -test docidx-6.0 {configure errors} { - new mydocidx - catch {mydocidx configure -foo bar -glub} result - mydocidx destroy - set result -} {wrong # args: doctools::idx::_configure name ?opt val...??} -# [tcltest::getErrorMessage "::doctools::idx::_configure" "name ?option?|?option value...?" 1] - -test docidx-6.1 {configure errors} { - new mydocidx - catch {mydocidx configure -foo} result - mydocidx destroy - set result -} {doctools::idx::_configure: Unknown option "-foo", expected -file, or -format} - -test docidx-6.2 {configure retrieval} { - new mydocidx - catch {mydocidx configure} result - mydocidx destroy - set result -} {-file {} -format {}} - -foreach {n option illegalvalue result} { - 3 -format barf {doctools::idx::_configure: -format: Unknown format "barf"} -} { - test docidx-6.$n {configure illegal value} { - new mydocidx - catch {mydocidx configure $option $illegalvalue} result - mydocidx destroy - set result - } $result -} - -foreach {na nb option default newvalue} { - 4 5 -file {} foo - 6 7 -format {} html -} { - test docidx-6.$na {configure query} { - new mydocidx - set res [mydocidx configure $option] - mydocidx destroy - set res - } $default ; # {} - - test docidx-6.$nb {configure set & query} { - new mydocidx - mydocidx configure $option $newvalue - set res [mydocidx configure $option] - mydocidx destroy - set res - } $newvalue ; # {} -} - -test docidx-6.8 {configure full retrieval} { - new mydocidx -file foo -format html - catch {mydocidx configure} result - mydocidx destroy - set result -} {-file foo -format html} - -# search .................................................................. - -test docidx-7.0 {search errors} { - new mydocidx - catch {mydocidx search} result - mydocidx destroy - set result -} [tcltest::getErrorMessage "::doctools::idx::_search" "name path" 1] - -test docidx-7.1 {search errors} { - new mydocidx - catch {mydocidx search foo bar} result - mydocidx destroy - set result -} [tcltest::tooManyMessage "::doctools::idx::_search" "name path"] - -test docidx-7.2 {search errors} { - new mydocidx - catch {mydocidx search foo} result - mydocidx destroy - set result -} {mydocidx search: path does not exist} - -test docidx-7.3 {search, initial} { - new mydocidx - set res [llength $::doctools::idx::docidxmydocidx::paths] - mydocidx destroy - set res -} 0 - -test docidx-7.4 {extend object search paths} { - new mydocidx - mydocidx search [file dirname [info script]] - set res [list] - lappend res [llength $::doctools::idx::docidxmydocidx::paths] - lappend res [lindex $::doctools::idx::docidxmydocidx::paths 0] - mydocidx destroy - set res -} [list 1 [file dirname [info script]]] - -# format & warnings ....................................................... - -test docidx-8.0 {format errors} { - new mydocidx - catch {mydocidx format} result - mydocidx destroy - set result -} [tcltest::getErrorMessage "::doctools::idx::_format" "name text" 1] - -test docidx-8.1 {format errors} { - new mydocidx - catch {mydocidx format foo bar} result - mydocidx destroy - set result -} [tcltest::tooManyMessage "::doctools::idx::_format" "name text"] - -test docidx-8.2 {format errors} { - new mydocidx - catch {mydocidx format foo} result - mydocidx destroy - set result -} {mydocidx: No format was specified} - - -test docidx-8.3 {format} { - new mydocidx -format wiki - set res [mydocidx format {[index_begin foo bar][key snafu][manpage at fubar][index_end]}] - lappend res [mydocidx warnings] - mydocidx destroy - set res -} {Index '''foo''' '''bar''' '''snafu''': at {}} - - -# docidx manpage syntax ....................................................... - -test docidx-9.0 {docidx syntax} { - new mydocidx -format null - catch {mydocidx format foo} result - mydocidx destroy - set result -} {IDX error (idx/plaintext), "plain_text foo" : Plain text beyond whitespace is not allowed..} - - -namespace forget ::doctools::idx::new -::tcltest::cleanupTests DELETED modules/doctools/docidx_api.man Index: modules/doctools/docidx_api.man ================================================================== --- modules/doctools/docidx_api.man +++ /dev/null @@ -1,169 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[manpage_begin docidx_api n 1.0] -[copyright {2003 Andreas Kupries }] -[moddesc {Documentation tools}] -[titledesc {Interface specification for index formatting code}] -[description] -[para] - -This manpage specifies the interface between formatting engines for -data in the [syscmd docidx] format as specified in -[syscmd docidx_fmt], and [package doctools::idx], the package for the -generic handling of such data, as described in [syscmd docidx]. - -[para] - -Each formatting engine has to implement the conversion of input in -[syscmd docidx] format to one particular output format as chosen by -the author of the formatting engine. - -[section INTERFACE] - -Each formatting engine has to provide - -[list_begin enum] -[enum] - -Implementations of all the formatting commands as specified in - -[syscmd docidx_fmt], using the defined names, but prefixed with the -string [const fmt_]. The sole exceptions to this are the formatting -commands [cmd vset] and [cmd include]. These two commands are -processed by the generic layer and will never be seen by the -formatting engine. - -[enum] -and additionally implementations for - -[list_begin definitions] - -[lst_item "[cmd idx_numpasses]"] - -This command is called immediately after the formatter is loaded and -has to return the number of passes required by this formatter to -process a manpage. This information has to be an integer number -greater or equal to one. - -[lst_item "[cmd idx_initialize]"] - -This command is called at the beginning of every conversion run and is -responsible for initializing the general state of the formatting -engine. - -[lst_item "[cmd idx_setup] [arg n]"] - -This command is called at the beginning of each pass over the input -and is given the id of the current pass as its first argument. It is -responsible for setting up the internal state of the formatting for -this particular pass. - -[lst_item "[cmd idx_postprocess] [arg text]"] - -This command is called immediately after the last pass, with the -expansion result of that pass as argument, and can do any last-ditch -modifications of the generated result. Its result will be the final -result of the conversion. - -[nl] - -Most formats will use [emph identity] here. - -[lst_item "[cmd idx_shutdown]"] - -This command is called at the end of every conversion run and is -responsible for cleaning up of all the state in the formatting engine. - -[lst_item "[cmd fmt_plain_text] [arg text]"] - -This command is called for any plain text encountered by the processor -in the input and can do any special processing required for plain -text. Its result is the string written into the expansion. - -[nl] - -Most formats will use [emph identity] here. - -[lst_item [cmd idx_listvariables]] - -The command is called after loading a formatting engine to determine -which parameters are supported by that engine. The return value is a -list containing the names of these parameters. - -[lst_item "[cmd idx_varset] [arg varname] [arg text]"] - -The command is called by the generic layer to set the value of an -engine specific parameter. The parameter to change is specified by -[arg varname], and the value to set is given in [arg text]. - -[nl] - -The command will throw an error if an unknown [arg varname] is -used. Only the names returned by [cmd idx_listvariables] are -considered known. - -[list_end] -[list_end] - -[para] - -The tcl code of a formatting engine implementing all of the above can -make the following assumptions about its environment - -[list_begin enum] -[enum] - -It has full access to its own safe interpreter. In other words, the -engine cannot damage the other parts of the processor, nor can it -damage the filesystem. - -[enum] - -The surrounding system provides the engine with the following -commands: - -[list_begin definitions] - -[lst_item "Doctools commands"] -[list_begin definitions] -[lst_item [cmd dt_format]] -Returns the name of format loaded into the engine -[lst_item "[cmd dt_fmap] [arg fname]"] -Returns the actual name to use in the output in place of the symbolic -filename [arg fname]. -[lst_item "[cmd dt_source] [arg file]"] -This command allows the engine to load additional tcl code. The file -being loaded has to be in the same directory as the file the format -engine was loaded from. Any path specified for [arg file] is ignored. -[list_end] - -[lst_item "Expander commands"] - -All of the commands below are methods of the expander object (without -the prefix [const ex_]) handling the input. Their arguments and -results are described in [package expander(n)]. - - -[list_begin definitions] -[lst_item [cmd ex_cappend]] -[lst_item [cmd ex_cget]] -[lst_item [cmd ex_cis]] -[lst_item [cmd ex_cname]] -[lst_item [cmd ex_cpop]] -[lst_item [cmd ex_cpush]] -[lst_item [cmd ex_cset]] -[lst_item [cmd ex_lb]] -[lst_item [cmd ex_rb]] -[list_end] - -[lst_item "_idx_common.tcl commands"] - -Any engine loading ([cmd dt_source]) the file [file _idx_common.tcl] has -default implementations of the [const idx_] commands explicitly -listed in this document and of [cmd fmt_plaint_text]. - -[list_end] -[list_end] - -[see_also docidx_fmt docidx] -[keywords markup {generic markup} index keywords TMML HTML nroff LaTeX] -[manpage_end] DELETED modules/doctools/docidx_fmt.man Index: modules/doctools/docidx_fmt.man ================================================================== --- modules/doctools/docidx_fmt.man +++ /dev/null @@ -1,280 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[manpage_begin docidx_fmt n 1.0] -[copyright {2003 Andreas Kupries }] -[moddesc {Documentation tools}] -[titledesc {Specification of simple tcl markup for an index}] -[description] -[para] - -This manpage specifies a documentation format for indices. It is -intended to complement both the [syscmd doctools] format for writing -manpages and the [syscmd doctoc] format for writing tables of -contents. See [syscmd doctools_fmt] and [syscmd doctoc_fmt] for the -specification of these two formats. - -[para] - -This format is called [syscmd docidx]. - -It provides all the necessary commands to write an index for a group -of manpages. - -Like for the [syscmd doctools] and [syscmd doctoc] formats a package -is provided implementing a generic framework for the conversion of -[syscmd docidx] to a number of different output formats, like HTML, -TMML, nroff, LaTeX, etc. - -The package is called [package doctools::idx], its documentation can -be found in [syscmd docidx]. - -People wishing to write a formatting engine for the conversion of -[syscmd docidx] into a new output format have to read -[syscmd docidx_api]. This manpage will explain the interface between -the generic package and such engines. - - -[section OVERVIEW] - -[syscmd docidx] is similar to LaTex in that it consists primarily of -text, with markup commands embedded into it. The format used to mark -something as command is different from LaTeX however. All text between -matching pairs of [lb] and [rb] is a command, possibly with -arguments. Note that both brackets have to be on the same line for a -command to be recognized. - -[para] - -In this format plain text is not allowed, except for whitespace, which -can be used to separate the formatting commands described in the next -section ([sectref {FORMATTING COMMANDS}]). - - -[section {FORMATTING COMMANDS}] - -First a number of generic commands useable anywhere in a -[syscmd docidx] file. - -[list_begin definitions] - -[call [cmd vset] [arg varname] [arg value] ] - -Sets the formatter variable [arg varname] to the specified -[arg value]. Returns the empty string. - -[call [cmd vset] [arg varname]] - -Returns the value associated with the formatter variable -[arg varname]. - -[call [cmd include] [arg filename]] - -Instructs the system to insert the expanded contents of the file named -[arg filename] in its own place. - -[call [cmd comment] [arg text]] - -Declares that the marked [arg text] is a comment. - -[list_end] - - -Commands to insert special plain text. These bracket commands are -necessary as plain brackets are used to denote the beginnings and -endings of the formatting commands and thus cannot be used as normal -characters anymore. - -[list_begin definitions] - -[call [cmd lb]] - -Introduces a left bracket into the output. - -[call [cmd rb]] - -Introduces a right bracket into the output. - -[list_end] - - - -And now the relevant markup commands. - -[list_begin definitions] - -[call [cmd index_begin] [arg text] [arg title]] - -This command starts an index. It has to be the very first - -[term markup] command in a [syscmd docidx] file. Plain text is not -allowed to come before this command. Only the generic commands (see -above: [cmd vset], [cmd include], [cmd comment]) can be used before -it. - -[nl] - -The [arg text] argument provides a label for the whole group of -manpages the index refers to. Often this is the name of the package -(or extension) the manpages belong to. - -[nl] - -The [arg title] argument provides the title for the index. - -[nl] - -Each index has to contain at least one [cmd key]. - - -[call [cmd index_end]] - -This command closes an index. Nothing is allowed to follow it. - - -[call [cmd key] [arg text]] - -This commands starts the list of manpages and other entities which -refer to the keyword named by the argument [arg text]. - -[nl] - -Each key section has to contain at least one index element, either -[cmd manpage] or [cmd url]. - - -[call [cmd manpage] [arg file] [arg label]] - -This command describes an individual index element. Each such element -belongs to the last occurence of a [cmd key] command coming before the -index. - -[nl] - -The [arg file] argument refers to the file containing the actual -manpage refering to that key. The second argument is used to label the -reference. - -[nl] - -To preserve convertibility of this format to various output formats -the filename argument [arg file] is considered to contain a symbolic -name. The actual name of the file will be inserted by the formatting -engine used to convert the input, based on a mapping from symbolic to -actual names given to it. - - -[call [cmd url] [arg url] [arg label]] - -This is the second command to describe an index element. The -association to the key it belongs to is done in the same way as for -the [cmd manpage] command. The first however is not the symbolic name -of the file refering to that key, but an url describing the exact -location of the document indexed here. - -[list_end] - -[section NOTES] - -[list_begin enum] -[enum] - -Using an appropriate formatting engine and some glue code it is -possible to automatically generate a document in [syscmd docidx] -format from a collection of manpages in [syscmd doctools] format. - - -[list_end] - -[section EXAMPLE] - -As an example an index for all manpages belonging to this module -(doctools) of package [package tcllib]. - -[para] - -[example { -[index_begin tcllib/doctools {Documentation tools}] - [key HTML] - [manpage didxengine] - [manpage didxformat] - [manpage doctools] - [manpage dtformat] - [manpage dtformatter] - [manpage dtocengine] - [manpage dtocformat] - [manpage mpexpand] - [key TMML] - [manpage didxengine] - [manpage didxformat] - [manpage doctools] - [manpage dtformat] - [manpage dtformatter] - [manpage dtocengine] - [manpage dtocformat] - [manpage mpexpand] - [key conversion] - [manpage didxengine] - [manpage didxformat] - [manpage doctools] - [manpage dtformat] - [manpage dtformatter] - [manpage dtocengine] - [manpage dtocformat] - [manpage mpexpand] - [key documentation] - [manpage doctools] - [manpage dtformatter] - [key index] - [manpage didxengine] - [manpage didxformat] - [manpage doctools] - [manpage dtformat] - [manpage dtocformat] - [key interface] - [manpage didxengine] - [manpage dtformatter] - [manpage dtocengine] - [key manpage] - [manpage didxengine] - [manpage didxformat] - [manpage doctools] - [manpage dtformat] - [manpage dtformatter] - [manpage dtocengine] - [manpage dtocformat] - [manpage mpexpand] - [key markup] - [manpage didxengine] - [manpage didxformat] - [manpage doctools] - [manpage dtformat] - [manpage dtformatter] - [manpage dtocengine] - [manpage dtocformat] - [manpage mpexpand] - [key nroff] - [manpage didxengine] - [manpage didxformat] - [manpage doctools] - [manpage dtformat] - [manpage dtformatter] - [manpage dtocengine] - [manpage dtocformat] - [manpage mpexpand] - [key {table of contents}] - [manpage didxformat] - [manpage doctools] - [manpage dtformat] - [manpage dtocengine] - [manpage dtocformat] - [key toc] - [manpage didxformat] - [manpage doctools] - [manpage dtformat] - [manpage dtocengine] - [manpage dtocformat] -[index_end] -}] - -[see_also doctools_fmt doctoc_fmt docidx_api docidx] -[keywords markup {generic markup} index keywords TMML HTML nroff LaTeX] -[manpage_end] DELETED modules/doctools/doctoc.man Index: modules/doctools/doctoc.man ================================================================== --- modules/doctools/doctoc.man +++ /dev/null @@ -1,303 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[manpage_begin doctoc n 1.0] -[copyright {2003 Andreas Kupries }] -[moddesc {Documentation tools}] -[titledesc {Create and manipulate doctoc converter objects}] -[require Tcl 8.2] -[require doctools::toc [opt 1.0]] -[description] - -This package provides objects which can be used to convert text -written in the doctoc format as specified in [syscmd doctoc_fmt] into -any output format X, assuming that a formatting engine for X is -available and provides the interface specified in [syscmd doctoc_api]. - -[section API] - -[list_begin definitions] - -[call [cmd ::doctools::toc::new] [arg objectName] [opt [arg "option value"]...]] - -Creates a new doctoc object with an associated global Tcl command -whose name is [arg objectName]. This command is explained in full -detail in the sections [sectref {OBJECT COMMAND}] and - -[sectref {OBJECT METHODS}]. - -[nl] - -The list of options and values coming after the name of the object is -used to set the initial configuration of the object. - -[call [cmd ::doctools::toc::help]] - -This is a pure convenience command for applications which want to -provide their user with a reminder of the available formatting -commands and their meanings. It returns a string containing a standard -help for this purpose. - - -[call [cmd ::doctools::toc::search] [arg path]] - -Whenever the package has to map the name of a format to the file -containing the code for its formatting engine it will search the file -in a number of directories. Three such directories are declared by the -package itself. - -[nl] - -However the list is extensible by the user of the package and the -command above is the means to do so. When given a [arg path] to an -existing and readable directory it will prepend that directory to the -existing list. This means that the path added last is searched through -first. - -[nl] - -An error will be thrown if the [arg path] either does not excist, is -not a directory, or is not readable. - -[list_end] - -[section {OBJECT COMMAND}] - -All commands created by [cmd ::doctools::toc::new] have the following -general form and may be used to invoke various operations on the -object they are associated with. - -[list_begin definitions] - -[call [cmd objectName] [arg option] [opt [arg "arg arg ..."]]] - -The [arg option] and its [arg arg]s determine the exact behavior of -the command. See section [sectref {OBJECT METHODS}] for more -explanations. - -[list_end] - -[section {OBJECT METHODS}] - -[list_begin definitions] - -[call [arg objectName] [method configure]] - -When called without argument this method returns a list of all known -options and their current values. - -[call [arg objectName] [method configure] [arg option]] - -When called with a single argument this method behaves like -[method cget]. - -[call [arg objectName] [method configure] [arg "option value"]...] - -When called with more than one argument the method reconfigures the -object using the [arg option]s and [arg value]s given to it. - -[nl] - -The legal configuration options are described in section -[sectref {OBJECT CONFIGURATION}]. - -[call [arg objectName] [method cget] [arg option]] - -This method expects a legal configuration option as argument and -returns the current value of that option for the object the method was -invoked for. - -[nl] - -The legal configuration options are described in section -[sectref {OBJECT CONFIGURATION}]. - -[call [arg objectName] [method destroy]] - -Destroys the object it is invoked for. - -[call [arg objectName] [method format] [arg text]] - -Takes the [arg text] and runs it through the configured formatting -engine. The resulting string is returned as the result of this -method. An error will be thrown if no [option -format] was configured -for the object. - -[nl] - -The method assumes that the [arg text] is in doctoc format as -specified in [cmd dtformat(n)]. Errors will be thrown otherwise. - - -[call [arg objectName] [method search] [arg path]] - -This method extends the per-object list of paths searched for -formatting engines. See also [cmd ::doctools::toc::search] on how to extend -the global (per-package) list of paths. - -[nl] - -The path entered last is searched through first. - -[call [arg objectName] [method warnings]] - -Returns a list containing all the warnings generated by the engine -during the last invocation of method [method format]. - -[list_end] - -[section {OBJECT CONFIGURATION}] - -All doctoc objects understand the following configuration options: - -[list_begin definitions] - -[lst_item "[option -file] [arg file]"] - -The argument of this option is stored in the object and can be -retrieved by the formatting engine via the command [cmd dt_file] (see -[cmd dtformatter(n)]). Its default value is the empty string. - -[nl] - -It will be interpreted as the name of the file containing the text -currently processed by the engine. - -[lst_item "[option -module] [arg text]"] - -The argument of this option is stored in the object and can be -retrieved by the formatting engine via the command [cmd dt_module] -(see [cmd dtformatter(n)]). Its default value is the empty string. - -[nl] - -It will be interpreted as the name of the module the file containing -the text currently processed by the engine belongs to. - -[lst_item "[option -format] [arg text]"] - -The argument of this option specifies the format and thus the engine -to use when converting text via [method format]. Its default value is -the empty string. No formatting is possible if this -option is not set at least once. - -[nl] - -The package will immediately try to map the name of the format to a -file containing the implementation of the engine for that format. An -error will be thrown if this mapping fails and a previously configured -format is left untouched. - -[nl] - -Section [sectref {FORMAT MAPPING}] explains how -the package looks for engine implementations. - -[lst_item "[option -deprecated] [arg boolean]"] - -This option is a flag. If set the object will generate warnings when -formatting a text containing the deprecated markup command [cmd strong] -Its default value is [const FALSE]. In other words, no warnings will -be generated. - -[list_end] - -[section {FORMAT MAPPING}] - -When trying to map a format name [term foo] to the file containing -the implementation of formatting engine for [term foo] the package -will perform the following algorithm: - -[list_begin enum] -[enum] - -If [term foo] is the name of an existing file this file is directly -taken as the implementation. - -[enum] - -If not, the list of per-object search paths is searched. For each -directory in the list the package checks if that directory contains a -file [file fmt.[term foo]]. If yes, that file is taken as the -implementation. - -[nl] - -This list of paths is initially empty and can be extended through the -object method [method search]. - -[enum] - -If not, the list of global (package) paths is searched. For each -directory in the list the package checks if that directory contains a -file [file toc.[term foo]]. If yes, that file is taken as the -implementation. - -[nl] - -This list of paths contains initially one path and can be extended -through the command [cmd ::doctools::toc::search]. - -[nl] - -The initial (standard) path is the sub directory [file mpformats] of -the directory the package itself is located in. In other words, if the -package implementation [file doctoc.tcl] is installed in the -directory [file /usr/local/lib/tcllib/doctools] then it will by -default search the directory - -[file /usr/local/lib/tcllib/doctools/mpformats] for format -implementations. - -[enum] - -The mapping fails. - -[list_end] - - -[section {ENGINES}] - -The package comes with the following predefined formatting engines - -[list_begin definitions] -[lst_item html] - -This engine generates HTML markup, for processing by web browsers and -the like. - -[lst_item latex] - -This engine generates output suitable for the [syscmd latex] text -processor coming out of the TeX world. - -[lst_item list] - -This engine retrieves version, section and title of the manpage from -the document. As such it can be used to generate a directory listing -for a set of manpages. - -[lst_item nroff] - -This engine generates nroff output, for processing by [syscmd nroff], -or [syscmd groff]. The result will be standard man pages as they are -known in the unix world. - -[lst_item null] - -This engine generates no outout at all. This can be used if one just -wants to validate some input. - -[lst_item tmml] - -This engine generates TMML markup as specified by Joe English. The Tcl -Manpage Markup Language is a derivate of XML. - -[lst_item wiki] - -This engine generates Wiki markup as understood by Jean Claude -Wippler's [syscmd wikit] application. - -[list_end] - -[see_also doctoc_api doctoc_fmt] -[keywords toc {table of contents} index documentation manpage TMML HTML nroff conversion markup] -[manpage_end] DELETED modules/doctools/doctoc.tcl Index: modules/doctools/doctoc.tcl ================================================================== --- modules/doctools/doctoc.tcl +++ /dev/null @@ -1,905 +0,0 @@ -# doctoc.tcl -- -# -# Implementation of doctoc objects for Tcl. -# -# Copyright (c) 2003 Andreas Kupries -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: doctoc.tcl,v 1.3 2003/04/01 23:38:19 andreas_kupries Exp $ - -package require Tcl 8.2 -package require textutil::expander - -namespace eval ::doctools {} -namespace eval ::doctools::toc { - # Data storage in the doctools::toc module - # ------------------------------- - # - # One namespace per object, containing - # 1) A list of additional search paths for format definition files. - # This list extends the list of standard paths known to the module. - # The paths in the list are searched before the standard paths. - # 2) Configuration information - # a) string: The format to use when converting the input. - # 4) Name of the interpreter used to perform the syntax check of the - # input (= allowed order of formatting commands). - # 5) Name of the interpreter containing the code coming from the format - # definition file. - # 6) Name of the expander object used to interpret the input to convert. - - # commands is the list of subcommands recognized by the doctoc objects - variable commands [list \ - "cget" \ - "configure" \ - "destroy" \ - "format" \ - "map" \ - "search" \ - "warnings" \ - "parameters" \ - "setparam" \ - ] - - # Only export the toplevel commands - namespace export new search help - - # Global data - - # 1) List of standard paths to look at when searching for a format - # definition. Extensible. - # 2) Location of this file in the filesystem - - variable paths [list] - variable here [file dirname [info script]] -} - -# ::doctools::toc::search -- -# -# Extend the list of paths used when searching for format definition files. -# -# Arguments: -# path Path to add to the list. The path has to exist, has to be a -# directory, and has to be readable. -# -# Results: -# None. -# -# Sideeffects: -# The specified path is added to the front of the list of search -# paths. This means that the new path is search before the -# standard paths set at module initialization time. - -proc ::doctools::toc::search {path} { - variable paths - - if {![file exists $path]} {return -code error "doctools::toc::search: path does not exist"} - if {![file isdirectory $path]} {return -code error "doctools::toc::search: path is not a directory"} - if {![file readable $path]} {return -code error "doctools::toc::search: path cannot be read"} - - set paths [linsert $paths 0 $path] - return -} - -# ::doctools::toc::help -- -# -# Return a string containing short help -# regarding the existing formatting commands. -# -# Arguments: -# None. -# -# Results: -# A string. - -proc ::doctools::toc::help {} { - return "formatting commands\n\ - * toc_begin - begin of table of contents\n\ - * toc_end - end of toc\n\ - * division_start - begin of toc division\n\ - * division_end - end of toc division\n\ - * item - toc element\n\ - * vset - set/get variable values\n\ - * include - insert external file\n\ - * lb, rb - left/right brackets\n\ - " -} - -# ::doctools::toc::new -- -# -# Create a new doctoc object with a given name. May configure the object. -# -# Arguments: -# name Name of the doctoc object. -# args Options configuring the new object. -# -# Results: -# name Name of the doctools created - -proc ::doctools::toc::new {name args} { - if { [llength [info commands ::$name]] } { - return -code error "command \"$name\" already exists, unable to create doctoc object" - } - if {[llength $args] % 2 == 1} { - return -code error "wrong # args: doctools::new name ?opt val...??" - } - - # The arguments seem to be ok, setup the namespace for the object - - namespace eval ::doctools::toc::doctoc$name { - variable paths [list] - variable file "" - variable format "" - variable formatfile "" - variable format_ip "" - variable chk_ip "" - variable expander "[namespace current]::ex" - variable ex_ok 0 - variable msg [list] - variable map ; array set map {} - variable param [list] - } - - # Create the command to manipulate the object - # $name -> ::doctools::toc::DocTocProc $name - interp alias {} ::$name {} ::doctools::toc::DocTocProc $name - - # If the name was followed by arguments use them to configure the - # object before returning its handle to the caller. - - if {[llength $args] > 1} { - # Use linsert trick to make the command a pure list. - eval [linsert $args 0 _configure $name] - } - return $name -} - -########################## -# Private functions follow - -# ::doctools::toc::DocTocProc -- -# -# Command that processes all doctoc object commands. -# Dispatches any object command to the appropriate internal -# command implementing its functionality. -# -# Arguments: -# name Name of the doctoc object to manipulate. -# cmd Subcommand to invoke. -# args Arguments for subcommand. -# -# Results: -# Varies based on command to perform - -proc ::doctools::toc::DocTocProc {name {cmd ""} args} { - # Do minimal args checks here - if { [llength [info level 0]] == 2 } { - error "wrong # args: should be \"$name option ?arg arg ...?\"" - } - - # Split the args into command and args components - - if { [llength [info commands ::doctools::toc::_$cmd]] == 0 } { - variable commands - set optlist [join $commands ", "] - set optlist [linsert $optlist "end-1" "or"] - return -code error "bad option \"$cmd\": must be $optlist" - } - return [eval [list ::doctools::toc::_$cmd $name] $args] -} - -########################## -# Method implementations follow (these are also private commands) - -# ::doctools::toc::_cget -- -# -# Retrieve the current value of a particular option -# -# Arguments: -# name Name of the doctoc object to query -# option Name of the option whose value we are asking for. -# -# Results: -# The value of the option - -proc ::doctools::toc::_cget {name option} { - _configure $name $option -} - -# ::doctools::toc::_configure -- -# -# Configure a doctoc object, or query its configuration. -# -# Arguments: -# name Name of the doctoc object to configure -# args Options and their values. -# -# Results: -# None if configuring the object. -# A list of all options and their values if called without arguments. -# The value of one particular option if called with a single argument. - -proc ::doctools::toc::_configure {name args} { - if {[llength $args] == 0} { - # Retrieve the current configuration. - - upvar ::doctools::toc::doctoc${name}::file file - upvar ::doctools::toc::doctoc${name}::format format - - set res [list] - lappend res -file $file - lappend res -format $format - return $res - - } elseif {[llength $args] == 1} { - # Query the value of one particular option. - - switch -exact -- [lindex $args 0] { - -file { - upvar ::doctools::toc::doctoc${name}::file file - return $file - } - -format { - upvar ::doctools::toc::doctoc${name}::format format - return $format - } - default { - return -code error \ - "doctools::toc::_configure: Unknown option \"[lindex $args 0]\", expected\ - -file, or -format" - } - } - } else { - # Reconfigure the object. - - if {[llength $args] % 2 == 1} { - return -code error "wrong # args: doctools::toc::_configure name ?opt val...??" - } - - foreach {option value} $args { - switch -exact -- $option { - -file { - upvar ::doctools::toc::doctoc${name}::file file - set file $value - } - -format { - if {[catch { - set fmtfile [LookupFormat $name $value] - SetupFormatter $name $fmtfile - upvar ::doctools::toc::doctoc${name}::format format - set format $value - } msg]} { - return -code error "doctools::toc::_configure: -format: $msg" - } - } - default { - return -code error \ - "doctools::toc::_configure: Unknown option \"$option\", expected\ - -file, or -format" - } - } - } - } - return "" -} - -# ::doctools::toc::_destroy -- -# -# Destroy a doctoc object, including its associated command and data storage. -# -# Arguments: -# name Name of the doctoc object to destroy. -# -# Results: -# None. - -proc ::doctools::toc::_destroy {name} { - # Check the object for sub objects which have to destroyed before - # the namespace is torn down. - namespace eval ::doctools::toc::doctoc$name { - if {$format_ip != ""} {interp delete $format_ip} - if {$chk_ip != ""} {interp delete $chk_ip} - - # Expander objects have no delete/destroy method. This would - # be a leak if not for the fact that an expander object is a - # namespace, and we have arranged to make it a sub namespace of - # the doctoc object. Therefore tearing down our object namespace - # also cleans up the expander object. - # if {$expander != ""} {$expander destroy} - - } - namespace delete ::doctools::toc::doctoc$name - interp alias {} ::$name {} - return -} - -# ::doctools::toc::_map -- -# -# Add a mapping from symbolic to actual filename to the object. -# -# Arguments: -# name Name of the doctoc object to use -# sfname Symbolic filename to map -# afname Actual filename -# -# Results: -# None. - -proc ::doctools::toc::_map {name sfname afname} { - upvar ::doctools::toc::doctoc${name}::map map - set map($sfname) $afname - return -} - -# ::doctools::toc::_format -- -# -# Convert some text in doctools format -# according to the configuration in the object. -# -# Arguments: -# name Name of the doctoc object to use -# text Text to convert. -# -# Results: -# The conversion result. - -proc ::doctools::toc::_format {name text} { - upvar ::doctools::toc::doctoc${name}::format format - if {$format == ""} { - return -code error "$name: No format was specified" - } - - upvar ::doctools::toc::doctoc${name}::format_ip format_ip - upvar ::doctools::toc::doctoc${name}::chk_ip chk_ip - upvar ::doctools::toc::doctoc${name}::ex_ok ex_ok - upvar ::doctools::toc::doctoc${name}::expander expander - upvar ::doctools::toc::doctoc${name}::passes passes - upvar ::doctools::toc::doctoc${name}::msg warnings - - if {!$ex_ok} {SetupExpander $name} - if {$chk_ip == ""} {SetupChecker $name} - # assert (format_ip != "") - - set warnings [list] - if {[catch {$format_ip eval toc_initialize}]} { - return -code error "Could not initialize engine" - } - set result "" - - for { - set p $passes ; set n 1 - } { - $p > 0 - } { - incr p -1 ; incr n - } { - if {[catch {$format_ip eval [list toc_setup $n]}]} { - catch {$format_ip eval toc_shutdown} - return -code error "Could not initialize pass $n of engine" - } - $chk_ip eval ck_initialize - - if {[catch {set result [$expander expand $text]} msg]} { - catch {$format_ip eval toc_shutdown} - # Filter for checker errors and reduce them to the essential message. - - if {![regexp {^Error in} $msg]} {return -code error $msg} - set msg [join [lrange [split $msg \n] 2 end]] - - if {![regexp {^--> \(FmtError\) } $msg]} {return -code error @$msg} - set msg [lindex [split $msg \n] 0] - regsub {^--> \(FmtError\) } $msg {} msg - - return -code error $msg - } - - $chk_ip eval ck_complete - } - - if {[catch {set result [$format_ip eval [list toc_postprocess $result]]}]} { - return -code error "Unable to post process final result" - } - if {[catch {$format_ip eval toc_shutdown}]} { - return -code error "Could not shut engine down" - } - return $result - -} - -# ::doctools::toc::_search -- -# -# Add a search path to the object. -# -# Arguments: -# name Name of the doctoc object to extend -# path Search path to add. -# -# Results: -# None. - -proc ::doctools::toc::_search {name path} { - if {![file exists $path]} {return -code error "$name search: path does not exist"} - if {![file isdirectory $path]} {return -code error "$name search: path is not a directory"} - if {![file readable $path]} {return -code error "$name search: path cannot be read"} - - upvar ::doctools::toc::doctoc${name}::paths paths - set paths [linsert $paths 0 $path] - return -} - -# ::doctools::toc::_warnings -- -# -# Return the warning accumulated during the last invocation of 'format'. -# -# Arguments: -# name Name of the doctoc object to query -# -# Results: -# A list of warnings. - -proc ::doctools::toc::_warnings {name} { - upvar ::doctools::toc::doctoc${name}::msg msg - return $msg -} - -# ::doctools::_parameters -- -# -# Returns a list containing the parameters provided -# by the selected formatting engine. -# -# Arguments: -# name Name of the doctools object to query -# -# Results: -# A list of parameter names - -proc ::doctools::toc::_parameters {name} { - upvar ::doctools::toc::doctoc${name}::param param - return $param -} - -# ::doctools::_setparam -- -# -# Set a named engine parameter to a value. -# -# Arguments: -# name Name of the doctools object to query -# param Name of the parameter to set. -# value Value to set the parameter to. -# -# Results: -# None. - -proc ::doctools::toc::_setparam {name param value} { - upvar ::doctools::toc::doctoc${name}::format_ip format_ip - - if {$format_ip == {}} { - return -code error \ - "Unable to set parameters without a valid format" - } - - $format_ip eval [list toc_varset $param $value] - return -} - -########################## -# Support commands - -# ::doctools::toc::LookupFormat -- -# -# Search a format definition file based upon its name -# -# Arguments: -# name Name of the doctoc object to use -# format Name of the format to look for. -# -# Results: -# The file containing the format definition - -proc ::doctools::toc::LookupFormat {name format} { - # Order of searching - # 1) Is the name of the format an existing file ? - # If yes, take this file. - # 2) Look for the file in the directories given to the object itself.. - # 3) Look for the file in the standard directories of this package. - - if {[file exists $format]} { - return $format - } - - upvar ::doctools::toc::doctoc${name}::paths opaths - foreach path $opaths { - set f [file join $path toc.$format] - if {[file exists $f]} { - return $f - } - } - - variable paths - foreach path $paths { - set f [file join $path toc.$format] - if {[file exists $f]} { - return $f - } - } - - return -code error "Unknown format \"$format\"" -} - -# ::doctools::toc::SetupFormatter -- -# -# Create and initializes an interpreter containing a -# formatting engine -# -# Arguments: -# name Name of the doctoc object to manipulaye -# format Name of file containing the code of the engine -# -# Results: -# None. - -proc ::doctools::toc::SetupFormatter {name format} { - - # Create and initialize the interpreter first. - # Use a transient variable. Interrogate the - # engine and check its response. Bail out in - # case of errors. Only if we pass the checks - # we tear down the old engine and make the new - # one official. - - variable here - set mpip [interp create -safe] ; # interpreter for the formatting engine - #set mpip [interp create] ; # interpreter for the formatting engine - - $mpip invokehidden source [file join $here api_toc.tcl] - #$mpip eval [list source [file join $here api_toc.tcl]] - interp alias $mpip dt_source {} ::doctools::toc::Source $mpip [file dirname $format] - interp alias $mpip dt_package {} ::doctools::Package $mpip - interp alias $mpip file {} ::doctools::FileOp $mpip - interp alias $mpip puts_stderr {} ::puts stderr - $mpip invokehidden source $format - #$mpip eval [list source $format] - - # Check the engine for useability in doctools. - - foreach api { - toc_numpasses - toc_initialize - toc_setup - toc_postprocess - toc_shutdown - toc_listvariables - toc_varset - } { - if {[$mpip eval [list info commands $api]] == {}} { - interp delete $mpip - error "$format error: API incomplete, cannot use this engine" - } - } - if {[catch { - set passes [$mpip eval toc_numpasses] - }]} { - interp delete $mpip - error "$format error: Unable to query for number of passes" - } - if {![string is integer $passes] || ($passes < 1)} { - interp delete $mpip - error "$format error: illegal number of passes \"$passes\"" - } - if {[catch { - set parameters [$mpip eval toc_listvariables] - }]} { - interp delete $mpip - error "$format error: Unable to query for list of parameters" - } - - # Passed the tests. Tear down existing engine, - # and checker. The latter is destroyed because - # of its aliases into the formatter, which are - # now invalid. It will be recreated during the - # next call of 'format'. - - upvar ::doctools::toc::doctoc${name}::formatfile formatfile - upvar ::doctools::toc::doctoc${name}::format_ip format_ip - upvar ::doctools::toc::doctoc${name}::chk_ip chk_ip - upvar ::doctools::toc::doctoc${name}::expander expander - upvar ::doctools::toc::doctoc${name}::passes xpasses - upvar ::doctools::toc::doctoc${name}::param xparam - - if {$chk_ip != {}} {interp delete $chk_ip} - if {$format_ip != {}} {interp delete $format_ip} - - set chk_ip "" - set format_ip "" - - # Now link engine API into it. - - interp alias $mpip dt_format {} ::doctools::toc::GetFormat $name - interp alias $mpip dt_user {} ::doctools::toc::GetUser $name - interp alias $mpip dt_fmap {} ::doctools::toc::MapFile $name - - foreach cmd {cappend cget cis cname cpop cpush cset lb rb} { - interp alias $mpip ex_$cmd {} $expander $cmd - } - - set format_ip $mpip - set formatfile $format - set xpasses $passes - set xparam $parameters - return -} - -# ::doctools::toc::SetupChecker -- -# -# Create and initializes an interpreter for checking the usage of -# doctoc formatting commands -# -# Arguments: -# name Name of the doctoc object to manipulaye -# -# Results: -# None. - -proc ::doctools::toc::SetupChecker {name} { - # Create an interpreter for checking the usage of doctoc formatting commands - # and initialize it: Link it to the interpreter doing the formatting, the - # expander object and the configuration information. All of which - # is accessible through the token/handle (name of state/object array). - - variable here - - upvar ::doctools::toc::doctoc${name}::chk_ip chk_ip - if {$chk_ip != ""} {return} - - upvar ::doctools::toc::doctoc${name}::expander expander - upvar ::doctools::toc::doctoc${name}::format_ip format_ip - - set chk_ip [interp create] ; # interpreter hosting the formal format checker - - # Make configuration available through command, then load the code base. - - foreach {cmd ckcmd} { - dt_search SearchPaths - dt_error FmtError - dt_warning FmtWarning - } { - interp alias $chk_ip $cmd {} ::doctools::toc::$ckcmd $name - } - $chk_ip eval [list source [file join $here checker_toc.tcl]] - - # Simple expander commands are directly routed back into it, no - # checking required. - - foreach cmd {cappend cget cis cname cpop cpush cset lb rb} { - interp alias $chk_ip $cmd {} $expander $cmd - } - - # Link the formatter commands into the checker. We use the prefix - # 'fmt_' to distinguish them from the checking commands. - - foreach cmd { - toc_begin toc_end division_start division_end item - comment plain_text - } { - interp alias $chk_ip fmt_$cmd $format_ip fmt_$cmd - } - return -} - -# ::doctools::toc::SetupExpander -- -# -# Create and initializes the expander for input -# -# Arguments: -# name Name of the doctoc object to manipulaye -# -# Results: -# None. - -proc ::doctools::toc::SetupExpander {name} { - upvar ::doctools::toc::doctoc${name}::ex_ok ex_ok - if {$ex_ok} {return} - - upvar ::doctools::toc::doctoc${name}::expander expander - ::textutil::expander $expander - $expander evalcmd [list ::doctools::toc::Eval $name] - $expander textcmd plain_text - set ex_ok 1 - return -} - -# ::doctools::toc::SearchPaths -- -# -# API for checker. Returns list of search paths for format -# definitions. Used to look for message catalogs as well. -# -# Arguments: -# name Name of the doctoc object to query. -# -# Results: -# None. - -proc ::doctools::toc::SearchPaths {name} { - upvar ::doctools::toc::doctoc${name}::paths opaths - variable paths - - set p $opaths - foreach s $paths {lappend p $s} - return $p -} - -# ::doctools::toc::FmtError -- -# -# API for checker. Called when an error occured. -# -# Arguments: -# name Name of the doctoc object to query. -# text Error message -# -# Results: -# None. - -proc ::doctools::toc::FmtError {name text} { - return -code error "(FmtError) $text" -} - -# ::doctools::toc::FmtWarning -- -# -# API for checker. Called when a warning was generated -# -# Arguments: -# name Name of the doctoc object -# text Warning message -# -# Results: -# None. - -proc ::doctools::toc::FmtWarning {name text} { - upvar ::doctools::toc::doctoc${name}::msg msg - lappend msg $text - return -} - -# ::doctools::toc::Eval -- -# -# API for expander. Routes the macro invocations -# into the checker interpreter -# -# Arguments: -# name Name of the doctoc object to query. -# -# Results: -# None. - -proc ::doctools::toc::Eval {name macro} { - upvar ::doctools::toc::doctoc${name}::chk_ip chk_ip - - # Handle the [include] command directly - if {[string match include* $macro]} { - foreach {cmd filename} $macro break - return [ExpandInclude $name $filename] - } - - return [$chk_ip eval $macro] -} - -# ::doctools::toc::ExpandInclude -- -# -# Handle inclusion of files. -# -# Arguments: -# name Name of the doctoc object to query. -# path Name of file to include and expand. -# -# Results: -# None. - -proc ::doctools::toc::ExpandInclude {name path} { - # Look for the file relative to the directory of the - # main file we are converting. If that fails try to - # use the current working directory. Throw an error - # if the file couldn't be found. - - upvar ::doctools::toc::doctoc${name}::file file - - set ipath [file join [file dirname $file] $path] - if {![file exists $ipath]} { - set ipath $path - if {![file exists $ipath]} { - return -code error "Unable to fine include file \"$path\"" - } - } - - set chan [open $ipath r] - set text [read $chan] - close $chan - - upvar ::doctools::toc::doctoc${name}::expander expander - - return [$expander expand $text] -} - -# ::doctools::toc::GetUser -- -# -# API for formatter. Returns name of current user -# -# Arguments: -# name Name of the doctoc object to query. -# -# Results: -# String, name of current user. - -proc ::doctools::toc::GetUser {name} { - global tcl_platform - return $tcl_platform(user) -} - -# ::doctools::toc::GetFormat -- -# -# API for formatter. Returns format information -# -# Arguments: -# name Name of the doctoc object to query. -# -# Results: -# Format information - -proc ::doctools::toc::GetFormat {name} { - upvar ::doctools::toc::doctoc${name}::format format - return $format -} - -# ::doctools::toc::MapFile -- -# -# API for formatter. Maps symbolic to actual filename in a toc -# item. If no mapping is found it is assumed that the symbolic -# name is also the actual name. -# -# Arguments: -# name Name of the doctoc object to query. -# fname Symbolic name of the file. -# -# Results: -# Actual name of the file. - -proc ::doctools::toc::MapFile {name fname} { - upvar ::doctools::toc::doctoc${name}::map map - if {[info exists map($fname)]} { - return $map($fname) - } - return $fname -} - -# ::doctools::toc::Source -- -# -# API for formatter. Used by engine to ask for -# additional script files support it. -# -# Arguments: -# name Name of the doctoc object to change. -# -# Results: -# Boolean flag. - -proc ::doctools::toc::Source {ip path file} { - $ip invokehidden source [file join $path [file tail $file]] - #$ip eval [list source [file join $path [file tail $file]]] - return -} - -#------------------------------------ -# Module initialization - -namespace eval ::doctools::toc { - # Reverse order of searching. First to search is specified last. - - # FOO/doctoc.tcl - # => FOO/mpformats - - #catch {search [file join $here lib doctools mpformats]} - #catch {search [file join [file dirname $here] lib doctools mpformats]} - catch {search [file join $here mpformats]} -} - -package provide doctools::toc 0.1 DELETED modules/doctools/doctoc.test Index: modules/doctools/doctoc.test ================================================================== --- modules/doctools/doctoc.test +++ /dev/null @@ -1,277 +0,0 @@ -# -*- tcl -*- -# doctoc.test: tests for the doctools::toc package. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 2003 by Andreas Kupries -# All rights reserved. -# -# RCS: @(#) $Id: doctoc.test,v 1.1 2003/03/05 06:50:33 andreas_kupries Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -package require doctools::toc -puts "doctools::toc [package present doctools::toc]" - -namespace import ::doctools::toc::new - -# search paths ............................................................. - -test doctoc-1.0 {default search paths} { - llength $::doctools::toc::paths -} 1 - -test doctoc-1.1 {extend package search paths} { - ::doctools::toc::search [file dirname [info script]] - set res [list] - lappend res [llength $::doctools::toc::paths] - lappend res [lindex $::doctools::toc::paths 0] - set res -} [list 2 [file dirname [info script]]] - -test doctoc-1.2 {extend package search paths, error} { - catch {::doctools::toc::search foo} result - set result -} {doctools::toc::search: path does not exist} - -# format help ............................................................. - -test doctoc-2.0 {format help} { - string length [doctools::toc::help] -} 338 - -# doctoc ............................................................. - -test doctoc-3.0 {doctoc errors} { - catch {new} msg - set msg -} [tcltest::getErrorMessage "new" "name args" 0] - -test doctoc-3.1 {doctoc errors} { - catch {new set} msg - set msg -} "command \"set\" already exists, unable to create doctoc object" - -test doctoc-3.2 {doctoc errors} { - new mydoctoc - catch {new mydoctoc} msg - mydoctoc destroy - set msg -} "command \"mydoctoc\" already exists, unable to create doctoc object" - -test doctoc-3.3 {doctoc errors} { - catch {new mydoctoc -foo} msg - set msg -} {wrong # args: doctools::new name ?opt val...??} - -# doctoc methods ...................................................... - -test doctoc-4.0 {doctoc method errors} { - new mydoctoc - catch {mydoctoc} msg - mydoctoc destroy - set msg -} "wrong # args: should be \"mydoctoc option ?arg arg ...?\"" - -test doctoc-4.1 {doctoc errors} { - new mydoctoc - catch {mydoctoc foo} msg - mydoctoc destroy - set msg -} "bad option \"foo\": must be cget, configure, destroy, format, map, search, warnings, parameters, or setparam" - -# cget .................................................................. - -test doctoc-5.0 {cget errors} { - new mydoctoc - catch {mydoctoc cget} result - mydoctoc destroy - set result -} [tcltest::getErrorMessage "::doctools::toc::_cget" "name option" 1] - -test doctoc-5.1 {cget errors} { - new mydoctoc - catch {mydoctoc cget foo bar} result - mydoctoc destroy - set result -} [tcltest::tooManyMessage "::doctools::toc::_cget" "name option"] - -test doctoc-5.2 {cget errors} { - new mydoctoc - catch {mydoctoc cget -foo} result - mydoctoc destroy - set result -} {doctools::toc::_configure: Unknown option "-foo", expected -file, or -format} - -foreach {na nb option default newvalue} { - 3 4 -file {} foo - 5 6 -format {} html -} { - test doctoc-5.$na {cget query} { - new mydoctoc - set res [mydoctoc cget $option] - mydoctoc destroy - set res - } $default ; # {} - - test doctoc-5.$nb {cget set & query} { - new mydoctoc - mydoctoc configure $option $newvalue - set res [mydoctoc cget $option] - mydoctoc destroy - set res - } $newvalue ; # {} -} - -# configure .................................................................. - -test doctoc-6.0 {configure errors} { - new mydoctoc - catch {mydoctoc configure -foo bar -glub} result - mydoctoc destroy - set result -} {wrong # args: doctools::toc::_configure name ?opt val...??} -# [tcltest::getErrorMessage "::doctools::toc::_configure" "name ?option?|?option value...?" 1] - -test doctoc-6.1 {configure errors} { - new mydoctoc - catch {mydoctoc configure -foo} result - mydoctoc destroy - set result -} {doctools::toc::_configure: Unknown option "-foo", expected -file, or -format} - -test doctoc-6.2 {configure retrieval} { - new mydoctoc - catch {mydoctoc configure} result - mydoctoc destroy - set result -} {-file {} -format {}} - -foreach {n option illegalvalue result} { - 3 -format barf {doctools::toc::_configure: -format: Unknown format "barf"} -} { - test doctoc-6.$n {configure illegal value} { - new mydoctoc - catch {mydoctoc configure $option $illegalvalue} result - mydoctoc destroy - set result - } $result -} - -foreach {na nb option default newvalue} { - 4 5 -file {} foo - 6 7 -format {} html -} { - test doctoc-6.$na {configure query} { - new mydoctoc - set res [mydoctoc configure $option] - mydoctoc destroy - set res - } $default ; # {} - - test doctoc-6.$nb {configure set & query} { - new mydoctoc - mydoctoc configure $option $newvalue - set res [mydoctoc configure $option] - mydoctoc destroy - set res - } $newvalue ; # {} -} - -test doctoc-6.8 {configure full retrieval} { - new mydoctoc -file foo -format html - catch {mydoctoc configure} result - mydoctoc destroy - set result -} {-file foo -format html} - -# search .................................................................. - -test doctoc-7.0 {search errors} { - new mydoctoc - catch {mydoctoc search} result - mydoctoc destroy - set result -} [tcltest::getErrorMessage "::doctools::toc::_search" "name path" 1] - -test doctoc-7.1 {search errors} { - new mydoctoc - catch {mydoctoc search foo bar} result - mydoctoc destroy - set result -} [tcltest::tooManyMessage "::doctools::toc::_search" "name path"] - -test doctoc-7.2 {search errors} { - new mydoctoc - catch {mydoctoc search foo} result - mydoctoc destroy - set result -} {mydoctoc search: path does not exist} - -test doctoc-7.3 {search, initial} { - new mydoctoc - set res [llength $::doctools::toc::doctocmydoctoc::paths] - mydoctoc destroy - set res -} 0 - -test doctoc-7.4 {extend object search paths} { - new mydoctoc - mydoctoc search [file dirname [info script]] - set res [list] - lappend res [llength $::doctools::toc::doctocmydoctoc::paths] - lappend res [lindex $::doctools::toc::doctocmydoctoc::paths 0] - mydoctoc destroy - set res -} [list 1 [file dirname [info script]]] - -# format & warnings ....................................................... - -test doctoc-8.0 {format errors} { - new mydoctoc - catch {mydoctoc format} result - mydoctoc destroy - set result -} [tcltest::getErrorMessage "::doctools::toc::_format" "name text" 1] - -test doctoc-8.1 {format errors} { - new mydoctoc - catch {mydoctoc format foo bar} result - mydoctoc destroy - set result -} [tcltest::tooManyMessage "::doctools::toc::_format" "name text"] - -test doctoc-8.2 {format errors} { - new mydoctoc - catch {mydoctoc format foo} result - mydoctoc destroy - set result -} {mydoctoc: No format was specified} - - -test doctoc-8.3 {format} { - new mydoctoc -format wiki - set res [mydoctoc format {[toc_begin foo bar][item at snafu gnarf][toc_end]}] - lappend res [mydoctoc warnings] - mydoctoc destroy - set res -} {Table of Contents '''foo''' '''bar''' {[[snafu]]:} at -- gnarf {}} - - -# doctoc manpage syntax ....................................................... - -test doctoc-9.0 {doctoc syntax} { - new mydoctoc -format null - catch {mydoctoc format foo} result - mydoctoc destroy - set result -} {TOC error (toc/plaintext), "plain_text foo" : Plain text beyond whitespace is not allowed..} - - -namespace forget ::doctools::toc::new -::tcltest::cleanupTests DELETED modules/doctools/doctoc_api.man Index: modules/doctools/doctoc_api.man ================================================================== --- modules/doctools/doctoc_api.man +++ /dev/null @@ -1,170 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[manpage_begin doctoc_api n 1.0] -[copyright {2003 Andreas Kupries }] -[moddesc {Documentation tools}] -[titledesc {Interface specification for toc formatting code}] -[description] -[para] - - -This manpage specifies the interface between formatting engines for -data in the [syscmd doctoc] format as specified in -[syscmd doctoc_fmt], and [package doctools::toc], the package for the -generic handling of such data, as described in [syscmd doctoc]. - -[para] - -Each formatting engine has to implement the conversion of input in -[syscmd doctoc] format to one particular output format as chosen by -the author of the formatting engine. - -[section INTERFACE] - -Each formatting engine has to provide - -[list_begin enum] -[enum] - -Implementations of all the formatting commands as specified in - -[syscmd doctoc_fmt], using the defined names, but prefixed with the -string [const fmt_]. The sole exceptions to this are the formatting -commands [cmd vset] and [cmd include]. These two commands are -processed by the generic layer and will never be seen by the -formatting engine. - -[enum] -and additionally implementations for - -[list_begin definitions] - -[lst_item "[cmd toc_numpasses]"] - -This command is called immediately after the formatter is loaded and -has to return the number of passes required by this formatter to -process a manpage. This information has to be an integer number -greater or equal to one. - -[lst_item "[cmd toc_initialize]"] - -This command is called at the beginning of every conversion run and is -responsible for initializing the general state of the formatting -engine. - -[lst_item "[cmd toc_setup] [arg n]"] - -This command is called at the beginning of each pass over the input -and is given the id of the current pass as its first argument. It is -responsible for setting up the internal state of the formatting for -this particular pass. - -[lst_item "[cmd toc_postprocess] [arg text]"] - -This command is called immediately after the last pass, with the -expansion result of that pass as argument, and can do any last-ditch -modifications of the generated result. Its result will be the final -result of the conversion. - -[nl] - -Most formats will use [emph identity] here. - -[lst_item "[cmd toc_shutdown]"] - -This command is called at the end of every conversion run and is -responsible for cleaning up of all the state in the formatting engine. - -[lst_item "[cmd fmt_plain_text] [arg text]"] - -This command is called for any plain text encountered by the processor -in the input and can do any special processing required for plain -text. Its result is the string written into the expansion. - -[nl] - -Most formats will use [emph identity] here. - -[lst_item [cmd toc_listvariables]] - -The command is called after loading a formatting engine to determine -which parameters are supported by that engine. The return value is a -list containing the names of these parameters. - -[lst_item "[cmd toc_varset] [arg varname] [arg text]"] - -The command is called by the generic layer to set the value of an -engine specific parameter. The parameter to change is specified by -[arg varname], and the value to set is given in [arg text]. - -[nl] - -The command will throw an error if an unknown [arg varname] is -used. Only the names returned by [cmd toc_listvariables] are -considered known. - -[list_end] -[list_end] - -[para] - -The tcl code of a formatting engine implementing all of the above can -make the following assumptions about its environment - -[list_begin enum] -[enum] - -It has full access to its own safe interpreter. In other words, the -engine cannot damage the other parts of the processor, nor can it -damage the filesystem. - -[enum] - -The surrounding system provides the engine with the following -commands: - -[list_begin definitions] - -[lst_item "Doctools commands"] -[list_begin definitions] -[lst_item [cmd dt_format]] -Returns the name of format loaded into the engine -[lst_item "[cmd dt_fmap] [arg fname]"] -Returns the actual name to use in the output in place of the symbolic -filename [arg fname]. -[lst_item "[cmd dt_source] [arg file]"] -This command allows the engine to load additional tcl code. The file -being loaded has to be in the same directory as the file the format -engine was loaded from. Any path specified for [arg file] is ignored. -[list_end] - -[lst_item "Expander commands"] - -All of the commands below are methods of the expander object (without -the prefix [const ex_]) handling the input. Their arguments and -results are described in [package expander(n)]. - - -[list_begin definitions] -[lst_item [cmd ex_cappend]] -[lst_item [cmd ex_cget]] -[lst_item [cmd ex_cis]] -[lst_item [cmd ex_cname]] -[lst_item [cmd ex_cpop]] -[lst_item [cmd ex_cpush]] -[lst_item [cmd ex_cset]] -[lst_item [cmd ex_lb]] -[lst_item [cmd ex_rb]] -[list_end] - -[lst_item "_toc_common.tcl commands"] - -Any engine loading ([cmd dt_source]) the file [file _toc_common.tcl] has -default implementations of the [const toc_] commands explicitly -listed in this document and of [cmd fmt_plaint_text]. - -[list_end] -[list_end] - -[see_also doctoc_fmt doctoc] -[keywords markup {generic markup} toc {table of contents} TMML HTML nroff LaTeX] -[manpage_end] DELETED modules/doctools/doctoc_fmt.man Index: modules/doctools/doctoc_fmt.man ================================================================== --- modules/doctools/doctoc_fmt.man +++ /dev/null @@ -1,227 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[manpage_begin doctoc_fmt n 1.0] -[copyright {2003 Andreas Kupries }] -[moddesc {Documentation tools}] -[titledesc {Specification of simple tcl markup for table of contents}] -[description] -[para] - -This manpage specifies a documentation format for tables of -contents. It is intended to complement both the [syscmd doctools] -format for writing manpages and the [syscmd docidx] format for writing -indices. See [syscmd doctools_fmt] and [syscmd docidx_fmt] for the -specification of these two formats - -[para] - -This format is called [syscmd doctoc]. - -It provides all the necessary commands to write a table of contents -for a group of manpages. It is simpler than TMML, but convertible into -it. - -Like for the [syscmd doctools] and [syscmd docidx] formats a package -is provided implementing a generic framework for the conversion of -[syscmd doctoc] to a number of different output formats, like HTML, -TMML, nroff, LaTeX, etc. - -The package is called [package doctools::toc], its documentation can -be found in [syscmd doctoc]. - - -People wishing to write a formatting engine for the conversion of -[syscmd doctoc] into a new output format have to read -[syscmd doctoc_api]. This manpage will explain the interface between -the generic package and such engines. - - -[section OVERVIEW] - -[syscmd doctoc] is similar to LaTex in that it consists primarily of -text, with markup commands embedded into it. The format used to mark -something as command is different from LaTeX however. All text between -matching pairs of [lb] and [rb] is a command, possibly with -arguments. Note that both brackets have to be on the same line for a -command to be recognized. - - -[para] - -In this format plain text is not allowed, except for whitespace, which -can be used to separate the formatting commands described in the next -section ([sectref {FORMATTING COMMANDS}]). - - -[section {FORMATTING COMMANDS}] - -First a number of generic commands useable anywhere in a -[syscmd doctoc] file. - -[list_begin definitions] - -[call [cmd vset] [arg varname] [arg value] ] - -Sets the formatter variable [arg varname] to the specified -[arg value]. Returns the empty string. - -[call [cmd vset] [arg varname]] - -Returns the value associated with the formatter variable -[arg varname]. - -[call [cmd include] [arg filename]] - -Instructs the system to insert the expanded contents of the file named -[arg filename] in its own place. - -[call [cmd comment] [arg text]] - -Declares that the marked [arg text] is a comment. - -[list_end] - - -Commands to insert special plain text. These bracket commands are -necessary as plain brackets are used to denote the beginnings and -endings of the formatting commands and thus cannot be used as normal -characters anymore. - -[list_begin definitions] - -[call [cmd lb]] - -Introduces a left bracket into the output. - -[call [cmd rb]] - -Introduces a right bracket into the output. - -[list_end] - - - -And now the relevant markup commands. - -[list_begin definitions] - -[call [cmd toc_begin] [arg text] [arg title]] - -This command starts a table of contents. It has to be the very first -[term markup] command in a [syscmd doctoc] file. Plain text is not -allowed to come before this command. Only the generic commands (see -above: [cmd vset], [cmd include], [cmd comment]) can be used before -it. - -[nl] - -The [arg text] argument provides a label for the whole group of -manpages listed in the table of contents. Often this is the name of -the package (or extension) the manpages belong to. - -[nl] - -The [arg title] argument provides the title for the whole table of -contents. - -[nl] - -The table of contents has to contain at least either one toc element -([cmd item]) or one division. - - -[call [cmd toc_end]] - -This command closes a table of contents. Nothing is allowed to follow -it. - - -[call [cmd division_start] [arg text]] - -This command and its counterpart [cmd division_end] can be used to give -the table of contents additional structure. - -[nl] - -Each division starts with [cmd division_start], is ended by [cmd division_end] - -and has a title provided through the argument [arg title]. The -contents of a division are like for the whole table of contents, -i.e. a series of either toc elements or divisions. The latter means -that divisions can be nested. - -[nl] - -The division has to contain at least either one toc element -([cmd item]) or one division. - - -[call [cmd division_end]] - -This command closes a toc division. See [cmd division_start] above for -the detailed explanation. - - -[call [cmd item] [arg file] [arg label] [arg desc]] - -This command describes an individual toc element. The [arg file] -argument refers to the file containing the actual manpage, and the -[arg desc] provides a short descriptive text of that manpage. The -argument [arg label] can be used by engines supporting hyperlinks to -give the link a nice text (instead of the symbolic filename). - -[nl] - -To preserve convertibility of this format to various output formats -the filename argument is considered a symbolic name. The actual name -of the file will be inserted by the formatting engine used to convert -the input, based on a mapping from symbolic to actual names given to -it. - -[list_end] - -[section NOTES] - -[list_begin enum] -[enum] -The commands for the [syscmd doctoc] format are closely modeled on the -TMML tags used for describing collections of manpages. - -[enum] - -Using an appropriate formatting engine and some glue code it is -possible to automatically generate a document in [syscmd doctoc] -format from a collection of manpages in [syscmd doctools] format. - - -[list_end] - -[section EXAMPLE] - -As an example a table of contents for all manpages belonging to this -module (doctools) of package [package tcllib]. - -[para] - -[example { -[toc_begin tcllib/doctools {Documentation tools}] -[division_start {Basic format}] -[item dtformat.man {doctools format specification}] -[item dtformatter.man {doctools engine interface}] -[item doctools.man {Package to handle doctools input and engines}] -[division_end] -[division_start {Table of Contents}] -[item dtocformat.man {doctoc format specification}] -[item dtocformatter.man {doctoc engine interface}] -[item doctoc.man {Package to handle doctoc input and engines}] -[division_end] -[division_start {Indices}] -[item dtidxformat.man {docindex format specification}] -[item dtidxformatter.man {docindex engine interface}] -[item docindex.man {Package to handle docindex input and engines}] -[division_end] -[toc_end] -}] - -[see_also doctools_fmt docidx_fmt doctoc_api doctoc] -[keywords markup {generic markup} toc {table of contents} TMML HTML nroff LaTeX] -[manpage_end] DELETED modules/doctools/doctools.man Index: modules/doctools/doctools.man ================================================================== --- modules/doctools/doctools.man +++ /dev/null @@ -1,304 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[manpage_begin doctools n 1.0] -[copyright {2003 Andreas Kupries }] -[moddesc {Documentation tools}] -[titledesc {Create and manipulate doctools converter object}] -[require Tcl 8.2] -[require doctools [opt 1.0]] -[description] - -This package provides objects which can be used to convert text -written in the doctools format as specified in [cmd dtformat(n)] -into any output format X, assuming that a formatting engine for X is -available and provides the interface specified in -[cmd dtformatter(n)]. - -[section API] - -[list_begin definitions] - -[call [cmd ::doctools::new] [arg objectName] [opt [arg "option value"]...]] - -Creates a new doctools object with an associated global Tcl command -whose name is [arg objectName]. This command is explained in full -detail in the sections [sectref {OBJECT COMMAND}] and - -[sectref {OBJECT METHODS}]. - -[nl] - -The list of options and values coming after the name of the object is -used to set the initial configuration of the object. - -[call [cmd ::doctools::help]] - -This is a pure convenience command for applications which want to -provide their user with a reminder of the available formatting -commands and their meanings. It returns a string containing a standard -help for this purpose. - - -[call [cmd ::doctools::search] [arg path]] - -Whenever the package has to map the name of a format to the file -containing the code for its formatting engine it will search the file -in a number of directories. Three such directories are declared by the -package itself. - -[nl] - -However the list is extensible by the user of the package and the -command above is the means to do so. When given a [arg path] to an -existing and readable directory it will prepend that directory to the -existing list. This means that the path added last is searched through -first. - -[nl] - -An error will be thrown if the [arg path] either does not excist, is -not a directory, or is not readable. - -[list_end] - -[section {OBJECT COMMAND}] - -All commands created by [cmd ::doctools::new] have the following -general form and may be used to invoke various operations on the -object they are associated with. - -[list_begin definitions] - -[call [cmd objectName] [arg option] [opt [arg "arg arg ..."]]] - -The [arg option] and its [arg arg]s determine the exact behavior of -the command. See section [sectref {OBJECT METHODS}] for more -explanations. - -[list_end] - -[section {OBJECT METHODS}] - -[list_begin definitions] - -[call [arg objectName] [method configure]] - -When called without argument this method returns a list of all known -options and their current values. - -[call [arg objectName] [method configure] [arg option]] - -When called with a single argument this method behaves like -[method cget]. - -[call [arg objectName] [method configure] [arg "option value"]...] - -When called with more than one argument the method reconfigures the -object using the [arg option]s and [arg value]s given to it. - -[nl] - -The legal configuration options are described in section -[sectref {OBJECT CONFIGURATION}]. - -[call [arg objectName] [method cget] [arg option]] - -This method expects a legal configuration option as argument and -returns the current value of that option for the object the method was -invoked for. - -[nl] - -The legal configuration options are described in section -[sectref {OBJECT CONFIGURATION}]. - -[call [arg objectName] [method destroy]] - -Destroys the object it is invoked for. - -[call [arg objectName] [method format] [arg text]] - -Takes the [arg text] and runs it through the configured formatting -engine. The resulting string is returned as the result of this -method. An error will be thrown if no [option -format] was configured -for the object. - -[nl] - -The method assumes that the [arg text] is in doctools format as -specified in [cmd dtformat(n)]. Errors will be thrown otherwise. - - -[call [arg objectName] [method search] [arg path]] - -This method extends the per-object list of paths searched for -formatting engines. See also [cmd ::doctools::search] on how to extend -the global (per-package) list of paths. - -[nl] - -The path entered last is searched through first. - -[call [arg objectName] [method warnings]] - -Returns a list containing all the warnings generated by the engine -during the last invocation of method [method format]. - -[list_end] - -[section {OBJECT CONFIGURATION}] - -All doctools objects understand the following configuration options: - -[list_begin definitions] - -[lst_item "[option -file] [arg file]"] - -The argument of this option is stored in the object and can be -retrieved by the formatting engine via the command [cmd dt_file] (see -[cmd dtformatter(n)]). Its default value is the empty string. - -[nl] - -It will be interpreted as the name of the file containing the text -currently processed by the engine. - -[lst_item "[option -module] [arg text]"] - -The argument of this option is stored in the object and can be -retrieved by the formatting engine via the command [cmd dt_module] -(see [cmd dtformatter(n)]). Its default value is the empty string. - -[nl] - -It will be interpreted as the name of the module the file containing -the text currently processed by the engine belongs to. - -[lst_item "[option -format] [arg text]"] - -The argument of this option specifies the format and thus the engine -to use when converting text via [method format]. Its default value is -the empty string. No formatting is possible if this -option is not set at least once. - -[nl] - -The package will immediately try to map the name of the format to a -file containing the implementation of the engine for that format. An -error will be thrown if this mapping fails and a previously configured -format is left untouched. - -[nl] - -Section [sectref {FORMAT MAPPING}] explains how -the package looks for engine implementations. - -[lst_item "[option -deprecated] [arg boolean]"] - -This option is a flag. If set the object will generate warnings when -formatting a text containing the deprecated markup command [cmd strong] -Its default value is [const FALSE]. In other words, no warnings will -be generated. - -[list_end] - -[section {FORMAT MAPPING}] - -When trying to map a format name [term foo] to the file containing -the implementation of formatting engine for [term foo] the package -will perform the following algorithm: - -[list_begin enum] -[enum] - -If [term foo] is the name of an existing file this file is directly -taken as the implementation. - -[enum] - -If not, the list of per-object search paths is searched. For each -directory in the list the package checks if that directory contains a -file [file fmt.[term foo]]. If yes, that file is taken as the -implementation. - -[nl] - -This list of paths is initially empty and can be extended through the -object method [method search]. - -[enum] - -If not, the list of global (package) paths is searched. For each -directory in the list the package checks if that directory contains a -file [file fmt.[term foo]]. If yes, that file is taken as the -implementation. - -[nl] - -This list of paths contains initially one path and can be extended -through the command [cmd ::doctools::search]. - -[nl] - -The initial (standard) path is the sub directory [file mpformats] of -the directory the package itself is located in. In other words, if the -package implementation [file doctools.tcl] is installed in the -directory [file /usr/local/lib/tcllib/doctools] then it will by -default search the directory - -[file /usr/local/lib/tcllib/doctools/mpformats] for format -implementations. - -[enum] - -The mapping fails. - -[list_end] - - -[section {ENGINES}] - -The package comes with the following predefined formatting engines - -[list_begin definitions] -[lst_item html] - -This engine generates HTML markup, for processing by web browsers and -the like. - -[lst_item latex] - -This engine generates output suitable for the [syscmd latex] text -processor coming out of the TeX world. - -[lst_item list] - -This engine retrieves version, section and title of the manpage from -the document. As such it can be used to generate a directory listing -for a set of manpages. - -[lst_item nroff] - -This engine generates nroff output, for processing by [syscmd nroff], -or [syscmd groff]. The result will be standard man pages as they are -known in the unix world. - -[lst_item null] - -This engine generates no outout at all. This can be used if one just -wants to validate some input. - -[lst_item tmml] - -This engine generates TMML markup as specified by Joe English. The Tcl -Manpage Markup Language is a derivate of XML. - -[lst_item wiki] - -This engine generates Wiki markup as understood by Jean Claude -Wippler's [syscmd wikit] application. - -[list_end] - -[see_also doctools_api doctools_fmt] -[keywords toc {table of contents} index documentation manpage TMML HTML nroff conversion markup] -[manpage_end] DELETED modules/doctools/doctools.tcl Index: modules/doctools/doctools.tcl ================================================================== --- modules/doctools/doctools.tcl +++ /dev/null @@ -1,1159 +0,0 @@ -# doctools.tcl -- -# -# Implementation of doctools objects for Tcl. -# -# Copyright (c) 2003 Andreas Kupries -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: doctools.tcl,v 1.5 2003/03/30 07:50:25 andreas_kupries Exp $ - -package require Tcl 8.2 -package require textutil::expander - -namespace eval ::doctools { - # Data storage in the doctools module - # ------------------------------- - # - # One namespace per object, containing - # 1) A list of additional search paths for format definition files. - # This list extends the list of standard paths known to the module. - # The paths in the list are searched before the standard paths. - # 2) Configuration information - # a) string: The format to use when converting the input. - # b) boolean: A flag telling us whether to warn when visual markup - # is used in the input, or not. - # c) File information associated with the input, if any. - # d) Module information associated with the input, if any. - # e) Copyright information, if any - # 4) Name of the interpreter used to perform the syntax check of the - # input (= allowed order of formatting commands). - # 5) Name of the interpreter containing the code coming from the format - # definition file. - # 6) Name of the expander object used to interpret the input to convert. - - # commands is the list of subcommands recognized by the doctools objects - variable commands [list \ - "cget" \ - "configure" \ - "destroy" \ - "format" \ - "map" \ - "search" \ - "warnings" \ - "parameters" \ - "setparam" \ - ] - - # Only export the toplevel commands - namespace export new search help - - # Global data - - # 1) List of standard paths to look at when searching for a format - # definition. Extensible. - # 2) Location of this file in the filesystem - - variable paths [list] - variable here [file dirname [info script]] -} - -# ::doctools::search -- -# -# Extend the list of paths used when searching for format definition files. -# -# Arguments: -# path Path to add to the list. The path has to exist, has to be a -# directory, and has to be readable. -# -# Results: -# None. -# -# Sideeffects: -# The specified path is added to the front of the list of search -# paths. This means that the new path is search before the -# standard paths set at module initialization time. - -proc ::doctools::search {path} { - variable paths - - if {![file exists $path]} {return -code error "doctools::search: path does not exist"} - if {![file isdirectory $path]} {return -code error "doctools::search: path is not a directory"} - if {![file readable $path]} {return -code error "doctools::search: path cannot be read"} - - set paths [linsert $paths 0 $path] - return -} - -# ::doctools::help -- -# -# Return a string containing short help -# regarding the existing formatting commands. -# -# Arguments: -# None. -# -# Results: -# A string. - -proc ::doctools::help {} { - return "formatting commands\n\ - * manpage_begin - begin of manpage\n\ - * moddesc - module description\n\ - * titledesc - manpage title\n\ - * copyright - copyright assignment\n\ - * manpage_end - end of manpage\n\ - * require - package requirement\n\ - * description - begin of manpage body\n\ - * section - begin new section of body\n\ - * para - begin new paragraph\n\ - * list_begin - begin a list\n\ - * list_end - end of a list\n\ - * lst_item - begin item of definition list\n\ - * call - command definition, adds to synopsis\n\ - * usage - see above, without adding to synopsis\n\ - * bullet - begin item in bulleted list\n\ - * enum - begin item in enumerated list\n\ - * arg_def - begin item in argument list\n\ - * cmd_def - begin item in command list\n\ - * opt_def - begin item in option list\n\ - * tkoption_def - begin item in tkoption list\n\ - * example - example block\n\ - * example_begin - begin example\n\ - * example_end - end of example\n\ - * see_also - cross reference declaration\n\ - * keywords - keyword declaration\n\ - * nl - paragraph break in list items\n\ - * arg - semantic markup - argument\n\ - * cmd - semantic markup - command\n\ - * opt - semantic markup - optional data\n\ - * comment - semantic markup - comment\n\ - * sectref - semantic markup - section reference\n\ - * syscmd - semantic markup - system command\n\ - * method - semantic markup - object method\n\ - * option - semantic markup - option\n\ - * widget - semantic markup - widget\n\ - * fun - semantic markup - function\n\ - * type - semantic markup - data type\n\ - * package - semantic markup - package\n\ - * class - semantic markup - class\n\ - * var - semantic markup - variable\n\ - * file - semantic markup - file \n\ - * uri - semantic markup - uri\n\ - * term - semantic markup - unspecific terminology\n\ - * const - semantic markup - constant value\n\ - * emph - emphasis\n\ - * strong - emphasis, deprecated, usage is discouraged\n\ - " -} - -# ::doctools::new -- -# -# Create a new doctools object with a given name. May configure the object. -# -# Arguments: -# name Name of the doctools object. -# args Options configuring the new object. -# -# Results: -# name Name of the doctools created - -proc ::doctools::new {name args} { - - if { [llength [info commands ::$name]] } { - return -code error "command \"$name\" already exists, unable to create doctools object" - } - if {[llength $args] % 2 == 1} { - return -code error "wrong # args: doctools::new name ?opt val...??" - } - - # The arguments seem to be ok, setup the namespace for the object - - namespace eval ::doctools::doctools$name { - variable paths [list] - variable format "" - variable formatfile "" - variable deprecated 0 - variable file "" - variable module "" - variable copyright "" - variable format_ip "" - variable chk_ip "" - variable expander "[namespace current]::ex" - variable ex_ok 0 - variable msg [list] - variable param [list] - variable map ; array set map {} - } - - # Create the command to manipulate the object - # $name -> ::doctools::DoctoolsProc $name - interp alias {} ::$name {} ::doctools::DoctoolsProc $name - - # If the name was followed by arguments use them to configure the - # object before returning its handle to the caller. - - if {[llength $args] > 1} { - # Use linsert trick to make the command a pure list. - eval [linsert $args 0 _configure $name] - } - return $name -} - -########################## -# Private functions follow - -# ::doctools::DoctoolsProc -- -# -# Command that processes all doctools object commands. -# Dispatches any object command to the appropriate internal -# command implementing its functionality. -# -# Arguments: -# name Name of the doctools object to manipulate. -# cmd Subcommand to invoke. -# args Arguments for subcommand. -# -# Results: -# Varies based on command to perform - -proc ::doctools::DoctoolsProc {name {cmd ""} args} { - # Do minimal args checks here - if { [llength [info level 0]] == 2 } { - error "wrong # args: should be \"$name option ?arg arg ...?\"" - } - - # Split the args into command and args components - - if { [llength [info commands ::doctools::_$cmd]] == 0 } { - variable commands - set optlist [join $commands ", "] - set optlist [linsert $optlist "end-1" "or"] - return -code error "bad option \"$cmd\": must be $optlist" - } - return [eval [list ::doctools::_$cmd $name] $args] -} - -########################## -# Method implementations follow (these are also private commands) - -# ::doctools::_cget -- -# -# Retrieve the current value of a particular option -# -# Arguments: -# name Name of the doctools object to query -# option Name of the option whose value we are asking for. -# -# Results: -# The value of the option - -proc ::doctools::_cget {name option} { - _configure $name $option -} - -# ::doctools::_configure -- -# -# Configure a doctools object, or query its configuration. -# -# Arguments: -# name Name of the doctools object to configure -# args Options and their values. -# -# Results: -# None if configuring the object. -# A list of all options and their values if called without arguments. -# The value of one particular option if called with a single argument. - -proc ::doctools::_configure {name args} { - upvar ::doctools::doctools${name}::format_ip format_ip - upvar ::doctools::doctools${name}::chk_ip chk_ip - upvar ::doctools::doctools${name}::expander expander - upvar ::doctools::doctools${name}::passes passes - - if {[llength $args] == 0} { - # Retrieve the current configuration. - - upvar ::doctools::doctools${name}::file file - upvar ::doctools::doctools${name}::module module - upvar ::doctools::doctools${name}::format format - upvar ::doctools::doctools${name}::copyright copyright - upvar ::doctools::doctools${name}::deprecated deprecated - - set res [list] - lappend res -file $file - lappend res -module $module - lappend res -format $format - lappend res -copyright $copyright - lappend res -deprecated $deprecated - return $res - - } elseif {[llength $args] == 1} { - # Query the value of one particular option. - - switch -exact -- [lindex $args 0] { - -file { - upvar ::doctools::doctools${name}::file file - return $file - } - -module { - upvar ::doctools::doctools${name}::module module - return $module - } - -copyright { - upvar ::doctools::doctools${name}::copyright copyright - return $copyright - } - -format { - upvar ::doctools::doctools${name}::format format - return $format - } - -deprecated { - upvar ::doctools::doctools${name}::deprecated deprecated - return $deprecated - } - default { - return -code error \ - "doctools::_configure: Unknown option \"[lindex $args 0]\", expected\ - -copyright, -file, -module, -format, or -deprecated" - } - } - } else { - # Reconfigure the object. - - if {[llength $args] % 2 == 1} { - return -code error "wrong # args: doctools::_configure name ?opt val...??" - } - - foreach {option value} $args { - switch -exact -- $option { - -file { - upvar ::doctools::doctools${name}::file file - set file $value - } - -module { - upvar ::doctools::doctools${name}::module module - set module $value - } - -copyright { - upvar ::doctools::doctools${name}::copyright copyright - set copyright $value - } - -format { - if {[catch { - set fmtfile [LookupFormat $name $value] - SetupFormatter $name $fmtfile - upvar ::doctools::doctools${name}::format format - set format $value - } msg]} { - return -code error "doctools::_configure: -format: $msg" - } - } - -deprecated { - if {![string is boolean $value]} { - return -code error \ - "doctools::_configure: -deprecated expected a boolean, got \"$value\"" - } - upvar ::doctools::doctools${name}::deprecated deprecated - set deprecated $value - } - default { - return -code error \ - "doctools::_configure: Unknown option \"$option\", expected\ - -copyright, -file, -module, -format, or -deprecated" - } - } - } - } - return "" -} - -# ::doctools::_destroy -- -# -# Destroy a doctools object, including its associated command and data storage. -# -# Arguments: -# name Name of the doctools object to destroy. -# -# Results: -# None. - -proc ::doctools::_destroy {name} { - # Check the object for sub objects which have to destroyed before - # the namespace is torn down. - namespace eval ::doctools::doctools$name { - if {$format_ip != ""} {interp delete $format_ip} - if {$chk_ip != ""} {interp delete $chk_ip} - - # Expander objects have no delete/destroy method. This would - # be a leak if not for the fact that an expander object is a - # namespace, and we have arranged to make it a sub namespace of - # the doctools object. Therefore tearing down our object namespace - # also cleans up the expander object. - # if {$expander != ""} {$expander destroy} - - } - namespace delete ::doctools::doctools$name - interp alias {} ::$name {} - return -} - -# ::doctools::_map -- -# -# Add a mapping from symbolic to actual filename to the object. -# -# Arguments: -# name Name of the doctools object to use -# sfname Symbolic filename to map -# afname Actual filename -# -# Results: -# None. - -proc ::doctools::_map {name sfname afname} { - upvar ::doctools::doctools${name}::map map - set map($sfname) $afname - return -} - -# ::doctools::_format -- -# -# Convert some text in doctools format -# according to the configuration in the object. -# -# Arguments: -# name Name of the doctools object to use -# text Text to convert. -# -# Results: -# The conversion result. - -proc ::doctools::_format {name text} { - upvar ::doctools::doctools${name}::format format - if {$format == ""} { - return -code error "$name: No format was specified" - } - - upvar ::doctools::doctools${name}::format_ip format_ip - upvar ::doctools::doctools${name}::chk_ip chk_ip - upvar ::doctools::doctools${name}::ex_ok ex_ok - upvar ::doctools::doctools${name}::expander expander - upvar ::doctools::doctools${name}::passes passes - upvar ::doctools::doctools${name}::msg warnings - - if {!$ex_ok} {SetupExpander $name} - if {$chk_ip == ""} {SetupChecker $name} - # assert (format_ip != "") - - set warnings [list] - if {[catch {$format_ip eval fmt_initialize}]} { - return -code error "Could not initialize engine" - } - set result "" - - for { - set p $passes ; set n 1 - } { - $p > 0 - } { - incr p -1 ; incr n - } { - if {[catch {$format_ip eval [list fmt_setup $n]}]} { - catch {$format_ip eval fmt_shutdown} - return -code error "Could not initialize pass $n of engine" - } - $chk_ip eval ck_initialize - - if {[catch {set result [$expander expand $text]} msg]} { - catch {$format_ip eval fmt_shutdown} - # Filter for checker errors and reduce them to the essential message. - - if {![regexp {^Error in} $msg]} {return -code error $msg} - set msg [join [lrange [split $msg \n] 2 end]] - - if {![regexp {^--> \(FmtError\) } $msg]} {return -code error @$msg} - set msg [lindex [split $msg \n] 0] - regsub {^--> \(FmtError\) } $msg {} msg - - return -code error $msg - } - - $chk_ip eval ck_complete - } - - if {[catch {set result [$format_ip eval [list fmt_postprocess $result]]}]} { - return -code error "Unable to post process final result" - } - if {[catch {$format_ip eval fmt_shutdown}]} { - return -code error "Could not shut engine down" - } - return $result - -} - -# ::doctools::_search -- -# -# Add a search path to the object. -# -# Arguments: -# name Name of the doctools object to extend -# path Search path to add. -# -# Results: -# None. - -proc ::doctools::_search {name path} { - if {![file exists $path]} {return -code error "$name search: path does not exist"} - if {![file isdirectory $path]} {return -code error "$name search: path is not a directory"} - if {![file readable $path]} {return -code error "$name search: path cannot be read"} - - upvar ::doctools::doctools${name}::paths paths - set paths [linsert $paths 0 $path] - return -} - -# ::doctools::_warnings -- -# -# Return the warning accumulated during the last invocation of 'format'. -# -# Arguments: -# name Name of the doctools object to query -# -# Results: -# A list of warnings. - -proc ::doctools::_warnings {name} { - upvar ::doctools::doctools${name}::msg msg - return $msg -} - -# ::doctools::_parameters -- -# -# Returns a list containing the parameters provided -# by the selected formatting engine. -# -# Arguments: -# name Name of the doctools object to query -# -# Results: -# A list of parameter names - -proc ::doctools::_parameters {name} { - upvar ::doctools::doctools${name}::param param - return $param -} - -# ::doctools::_setparam -- -# -# Set a named engine parameter to a value. -# -# Arguments: -# name Name of the doctools object to query -# param Name of the parameter to set. -# value Value to set the parameter to. -# -# Results: -# None. - -proc ::doctools::_setparam {name param value} { - upvar ::doctools::doctools${name}::format_ip format_ip - - if {$format_ip == {}} { - return -code error \ - "Unable to set parameters without a valid format" - } - - $format_ip eval [list fmt_varset $param $value] - return -} - -########################## -# Support commands - -# ::doctools::LookupFormat -- -# -# Search a format definition file based upon its name -# -# Arguments: -# name Name of the doctools object to use -# format Name of the format to look for. -# -# Results: -# The file containing the format definition - -proc ::doctools::LookupFormat {name format} { - # Order of searching - # 1) Is the name of the format an existing file ? - # If yes, take this file. - # 2) Look for the file in the directories given to the object itself.. - # 3) Look for the file in the standard directories of this package. - - if {[file exists $format]} { - return $format - } - - upvar ::doctools::doctools${name}::paths opaths - foreach path $opaths { - set f [file join $path fmt.$format] - if {[file exists $f]} { - return $f - } - } - - variable paths - foreach path $paths { - set f [file join $path fmt.$format] - if {[file exists $f]} { - return $f - } - } - - return -code error "Unknown format \"$format\"" -} - -# ::doctools::SetupFormatter -- -# -# Create and initializes an interpreter containing a -# formatting engine -# -# Arguments: -# name Name of the doctools object to manipulaye -# format Name of file containing the code of the engine -# -# Results: -# None. - -proc ::doctools::SetupFormatter {name format} { - - # Create and initialize the interpreter first. - # Use a transient variable. Interrogate the - # engine and check its response. Bail out in - # case of errors. Only if we pass the checks - # we tear down the old engine and make the new - # one official. - - variable here - set mpip [interp create -safe] ; # interpreter for the formatting engine - $mpip eval [list set auto_path $::auto_path] - #set mpip [interp create] ; # interpreter for the formatting engine - - $mpip invokehidden source [file join $here api.tcl] - #$mpip eval [list source [file join $here api.tcl]] - interp alias $mpip dt_source {} ::doctools::Source $mpip [file dirname $format] - interp alias $mpip dt_package {} ::doctools::Package $mpip - interp alias $mpip file {} ::doctools::FileOp $mpip - interp alias $mpip puts_stderr {} ::puts stderr - $mpip invokehidden source $format - #$mpip eval [list source $format] - - # Check the engine for useability in doctools. - - foreach api { - fmt_numpasses - fmt_initialize - fmt_setup - fmt_postprocess - fmt_shutdown - fmt_listvariables - fmt_varset - } { - if {[$mpip eval [list info commands $api]] == {}} { - interp delete $mpip - error "$format error: API incomplete, cannot use this engine" - } - } - if {[catch { - set passes [$mpip eval fmt_numpasses] - }]} { - interp delete $mpip - error "$format error: Unable to query for number of passes" - } - if {![string is integer $passes] || ($passes < 1)} { - interp delete $mpip - error "$format error: illegal number of passes \"$passes\"" - } - if {[catch { - set parameters [$mpip eval fmt_listvariables] - }]} { - interp delete $mpip - error "$format error: Unable to query for list of parameters" - } - - # Passed the tests. Tear down existing engine, - # and checker. The latter is destroyed because - # of its aliases into the formatter, which are - # now invalid. It will be recreated during the - # next call of 'format'. - - upvar ::doctools::doctools${name}::formatfile formatfile - upvar ::doctools::doctools${name}::format_ip format_ip - upvar ::doctools::doctools${name}::chk_ip chk_ip - upvar ::doctools::doctools${name}::expander expander - upvar ::doctools::doctools${name}::passes xpasses - upvar ::doctools::doctools${name}::param xparam - - if {$chk_ip != {}} {interp delete $chk_ip} - if {$format_ip != {}} {interp delete $format_ip} - - set chk_ip "" - set format_ip "" - - # Now link engine API into it. - - interp alias $mpip dt_file {} ::doctools::GetFile $name - interp alias $mpip dt_fileid {} ::doctools::GetFileId $name - interp alias $mpip dt_module {} ::doctools::GetModule $name - interp alias $mpip dt_copyright {} ::doctools::GetCopyright $name - interp alias $mpip dt_format {} ::doctools::GetFormat $name - interp alias $mpip dt_user {} ::doctools::GetUser $name - interp alias $mpip dt_lnesting {} ::doctools::ListLevel $name - interp alias $mpip dt_fmap {} ::doctools::MapFile $name - interp alias $mpip file {} ::doctools::FileCmd - - foreach cmd {cappend cget cis cname cpop cpush ctopandclear cset lb rb} { - interp alias $mpip ex_$cmd {} $expander $cmd - } - - set format_ip $mpip - set formatfile $format - set xpasses $passes - set xparam $parameters - return -} - -# ::doctools::SetupChecker -- -# -# Create and initializes an interpreter for checking the usage of -# doctools formatting commands -# -# Arguments: -# name Name of the doctools object to manipulaye -# -# Results: -# None. - -proc ::doctools::SetupChecker {name} { - # Create an interpreter for checking the usage of doctools formatting commands - # and initialize it: Link it to the interpreter doing the formatting, the - # expander object and the configuration information. All of which - # is accessible through the token/handle (name of state/object array). - - variable here - - upvar ::doctools::doctools${name}::chk_ip chk_ip - if {$chk_ip != ""} {return} - - upvar ::doctools::doctools${name}::expander expander - upvar ::doctools::doctools${name}::format_ip format_ip - - set chk_ip [interp create] ; # interpreter hosting the formal format checker - - # Make configuration available through command, then load the code base. - - foreach {cmd ckcmd} { - dt_search SearchPaths - dt_deprecated Deprecated - dt_error FmtError - dt_warning FmtWarning - } { - interp alias $chk_ip $cmd {} ::doctools::$ckcmd $name - } - $chk_ip eval [list source [file join $here checker.tcl]] - - # Simple expander commands are directly routed back into it, no - # checking required. - - foreach cmd {cappend cget cis cname cpop cpush ctopandclear cset lb rb} { - interp alias $chk_ip $cmd {} $expander $cmd - } - - # Link the formatter commands into the checker. We use the prefix - # 'fmt_' to distinguish them from the checking commands. - - foreach cmd { - manpage_begin moddesc titledesc copyright manpage_end require - description section para list_begin list_end lst_item call - bullet enum example example_begin example_end see_also - keywords nl arg cmd opt comment sectref syscmd method option - widget fun type package class var file uri usage term const - arg_def cmd_def opt_def tkoption_def emph strong plain_text - } { - interp alias $chk_ip fmt_$cmd $format_ip fmt_$cmd - } - return -} - -# ::doctools::SetupExpander -- -# -# Create and initializes the expander for input -# -# Arguments: -# name Name of the doctools object to manipulaye -# -# Results: -# None. - -proc ::doctools::SetupExpander {name} { - upvar ::doctools::doctools${name}::ex_ok ex_ok - if {$ex_ok} {return} - - upvar ::doctools::doctools${name}::expander expander - ::textutil::expander $expander - $expander evalcmd [list ::doctools::Eval $name] - $expander textcmd plain_text - set ex_ok 1 - return -} - -# ::doctools::SearchPaths -- -# -# API for checker. Returns list of search paths for format -# definitions. Used to look for message catalogs as well. -# -# Arguments: -# name Name of the doctools object to query. -# -# Results: -# None. - -proc ::doctools::SearchPaths {name} { - upvar ::doctools::doctools${name}::paths opaths - variable paths - - set p $opaths - foreach s $paths {lappend p $s} - return $p -} - -# ::doctools::Deprecated -- -# -# API for checker. Returns flag determining -# whether visual markup is warned against, or not. -# -# Arguments: -# name Name of the doctools object to query. -# -# Results: -# None. - -proc ::doctools::Deprecated {name} { - upvar ::doctools::doctools${name}::deprecated deprecated - return $deprecated -} - -# ::doctools::FmtError -- -# -# API for checker. Called when an error occured. -# -# Arguments: -# name Name of the doctools object to query. -# text Error message -# -# Results: -# None. - -proc ::doctools::FmtError {name text} { - return -code error "(FmtError) $text" -} - -# ::doctools::FmtWarning -- -# -# API for checker. Called when a warning was generated -# -# Arguments: -# name Name of the doctools object -# text Warning message -# -# Results: -# None. - -proc ::doctools::FmtWarning {name text} { - upvar ::doctools::doctools${name}::msg msg - lappend msg $text - return -} - -# ::doctools::Eval -- -# -# API for expander. Routes the macro invocations -# into the checker interpreter -# -# Arguments: -# name Name of the doctools object to query. -# -# Results: -# None. - -proc ::doctools::Eval {name macro} { - upvar ::doctools::doctools${name}::chk_ip chk_ip - - #puts stderr "\t\t$name [lindex [split $macro] 0]" - - # Handle the [include] command directly - if {[string match include* $macro]} { - foreach {cmd filename} $macro break - return [ExpandInclude $name $filename] - } - - return [$chk_ip eval $macro] -} - -# ::doctools::ExpandInclude -- -# -# Handle inclusion of files. -# -# Arguments: -# name Name of the doctools object to query. -# path Name of file to include and expand. -# -# Results: -# None. - -proc ::doctools::ExpandInclude {name path} { - upvar ::doctools::doctools${name}::file file - - set ipath [file join [file dirname $file] $path] - if {![file exists $ipath]} { - set ipath $path - if {![file exists $ipath]} { - return -code error "Unable to fine include file \"$path\"" - } - } - - set chan [open $ipath r] - set text [read $chan] - close $chan - - upvar ::doctools::doctools${name}::expander expander - - return [$expander expand $text] -} - -# ::doctools::GetUser -- -# -# API for formatter. Returns name of current user -# -# Arguments: -# name Name of the doctools object to query. -# -# Results: -# String, name of current user. - -proc ::doctools::GetUser {name} { - global tcl_platform - return $tcl_platform(user) -} - -# ::doctools::GetFile -- -# -# API for formatter. Returns file information -# -# Arguments: -# name Name of the doctools object to query. -# -# Results: -# File information - -proc ::doctools::GetFile {name} { - - #puts stderr "GetFile $name" - - upvar ::doctools::doctools${name}::file file - - #puts stderr "ok $file" - return $file -} - -# ::doctools::GetFileId -- -# -# API for formatter. Returns file information (truncated to stem of filename) -# -# Arguments: -# name Name of the doctools object to query. -# -# Results: -# File information - -proc ::doctools::GetFileId {name} { - return [file rootname [file tail [GetFile $name]]] -} - -# ::doctools::FileCmd -- -# -# API for formatter. Restricted implementation of file. -# -# Arguments: -# name Name of the doctools object to query. -# -# Results: -# Module information - -proc ::doctools::FileCmd {cmd args} { - switch -exact -- $cmd { - split {return [eval file split $args]} - join {return [eval file join $args]} - } - return -code error "Illegal subcommand: $cmd $args" -} - -# ::doctools::GetModule -- -# -# API for formatter. Returns module information -# -# Arguments: -# name Name of the doctools object to query. -# -# Results: -# Module information - -proc ::doctools::GetModule {name} { - upvar ::doctools::doctools${name}::module module - return $module -} - -# ::doctools::GetCopyright -- -# -# API for formatter. Returns copyright information -# -# Arguments: -# name Name of the doctools object to query. -# -# Results: -# Copyright information - -proc ::doctools::GetCopyright {name} { - upvar ::doctools::doctools${name}::copyright copyright - return $copyright -} - -# ::doctools::GetFormat -- -# -# API for formatter. Returns format information -# -# Arguments: -# name Name of the doctools object to query. -# -# Results: -# Format information - -proc ::doctools::GetFormat {name} { - upvar ::doctools::doctools${name}::format format - return $format -} - -# ::doctools::ListLevel -- -# -# API for formatter. Returns numer of open lists -# -# Arguments: -# name Name of the doctools object to query. -# -# Results: -# Boolean flag. - -proc ::doctools::ListLevel {name} { - upvar ::doctools::doctools${name}::chk_ip chk_ip - return [$chk_ip eval LNest] -} - -# ::doctools::MapFile -- -# -# API for formatter. Maps symbolic to actual filename in a toc -# item. If no mapping is found it is assumed that the symbolic -# name is also the actual name. -# -# Arguments: -# name Name of the doctoc object to query. -# fname Symbolic name of the file. -# -# Results: -# Actual name of the file. - -proc ::doctools::MapFile {name fname} { - upvar ::doctools::doctools${name}::map map - - #parray map - - if {[info exists map($fname)]} { - return $map($fname) - } - return $fname -} - -# ::doctools::Source -- -# -# API for formatter. Used by engine to ask for -# additional script files support it. -# -# Arguments: -# name Name of the doctools object to change. -# -# Results: -# Boolean flag. - -proc ::doctools::Source {ip path file} { - #puts stderr "$ip (source $path $file)" - - $ip invokehidden source [file join $path [file tail $file]] - #$ip eval [list source [file join $path [file tail $file]]] - return -} - - -proc ::doctools::Locate {p} { - catch {package require doctools::__undefined__} - - #puts stderr "auto_path = [join $::auto_path \n]" - - # Check if requested package is in the list of loadable packages. - # Then get the highest possible version, and then the index script - - if {[lsearch -exact [package names] $p] < 0} { - return -code error "Unknown package $p" - } - - set v [lindex [lsort -increasing [package versions $p]] end] - - #puts stderr "Package $p = $v" - - return [package ifneeded $p $v] -} - -proc ::doctools::FileOp {ip args} { - #puts stderr "$ip (file $args)" - # -- FUTURE -- disallow unsafe operations -- - - return [eval [linsert $args 0 file]] -} - - -proc ::doctools::Package {ip pkg} { - #puts stderr "$ip package require $pkg" - - set indexScript [Locate $pkg] - - $ip expose source - $ip expose load - $ip eval $indexScript - $ip hide source - $ip hide load - #$ip eval [list source [file join $path [file tail $file]]] - return -} - -#------------------------------------ -# Module initialization - -namespace eval ::doctools { - # Reverse order of searching. First to search is specified last. - - # FOO/doctools.tcl - # => FOO/mpformats - - #catch {search [file join $here lib doctools mpformats]} - #catch {search [file join [file dirname $here] lib doctools mpformats]} - catch {search [file join $here mpformats]} -} - -package provide doctools 1.0 DELETED modules/doctools/doctools.test Index: modules/doctools/doctools.test ================================================================== --- modules/doctools/doctools.test +++ /dev/null @@ -1,294 +0,0 @@ -# -*- tcl -*- -# doctools.test: tests for the doctools package. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 2003 by Andreas Kupries -# All rights reserved. -# -# RCS: @(#) $Id: doctools.test,v 1.2 2003/03/05 06:50:33 andreas_kupries Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -package require doctools -puts "doctools [package present doctools]" - -namespace import ::doctools::new - -# search paths ............................................................. - -test doctools-1.0 {default search paths} { - llength $::doctools::paths -} 1 - -test doctools-1.1 {extend package search paths} { - ::doctools::search [file dirname [info script]] - set res [list] - lappend res [llength $::doctools::paths] - lappend res [lindex $::doctools::paths 0] - set res -} [list 2 [file dirname [info script]]] - -test doctools-1.2 {extend package search paths, error} { - catch {::doctools::search foo} result - set result -} {doctools::search: path does not exist} - -# format help ............................................................. - -test doctools-2.0 {format help} { - string length [doctools::help] -} 2055 - -# doctools ............................................................. - -test doctools-3.0 {doctools errors} { - catch {new} msg - set msg -} [tcltest::getErrorMessage "new" "name args" 0] - -test doctools-3.1 {doctools errors} { - catch {new set} msg - set msg -} "command \"set\" already exists, unable to create doctools object" - -test doctools-3.2 {doctools errors} { - new mydoctools - catch {new mydoctools} msg - mydoctools destroy - set msg -} "command \"mydoctools\" already exists, unable to create doctools object" - -test doctools-3.3 {doctools errors} { - catch {new mydoctools -foo} msg - set msg -} {wrong # args: doctools::new name ?opt val...??} - -# doctools methods ...................................................... - -test doctools-4.0 {doctools method errors} { - new mydoctools - catch {mydoctools} msg - mydoctools destroy - set msg -} "wrong # args: should be \"mydoctools option ?arg arg ...?\"" - -test doctools-4.1 {doctools errors} { - new mydoctools - catch {mydoctools foo} msg - mydoctools destroy - set msg -} "bad option \"foo\": must be cget, configure, destroy, format, map, search, warnings, parameters, or setparam" - -# cget .................................................................. - -test doctools-5.0 {cget errors} { - new mydoctools - catch {mydoctools cget} result - mydoctools destroy - set result -} [tcltest::getErrorMessage "::doctools::_cget" "name option" 1] - -test doctools-5.1 {cget errors} { - new mydoctools - catch {mydoctools cget foo bar} result - mydoctools destroy - set result -} [tcltest::tooManyMessage "::doctools::_cget" "name option"] - -test doctools-5.2 {cget errors} { - new mydoctools - catch {mydoctools cget -foo} result - mydoctools destroy - set result -} {doctools::_configure: Unknown option "-foo", expected -copyright, -file, -module, -format, or -deprecated} - -foreach {na nb option default newvalue} { - 3 4 -deprecated 0 1 - 5 6 -file {} foo - 7 8 -module {} bar - 9 10 -format {} latex - 11 12 -copyright {} {Andreas Kupries} -} { - test doctools-5.$na {cget query} { - new mydoctools - set res [mydoctools cget $option] - mydoctools destroy - set res - } $default ; # {} - - test doctools-5.$nb {cget set & query} { - new mydoctools - mydoctools configure $option $newvalue - set res [mydoctools cget $option] - mydoctools destroy - set res - } $newvalue ; # {} -} - -# configure .................................................................. - -test doctools-6.0 {configure errors} { - new mydoctools - catch {mydoctools configure -foo bar -glub} result - mydoctools destroy - set result -} {wrong # args: doctools::_configure name ?opt val...??} -# [tcltest::getErrorMessage "::doctools::_configure" "name ?option?|?option value...?" 1] - -test doctools-6.1 {configure errors} { - new mydoctools - catch {mydoctools configure -foo} result - mydoctools destroy - set result -} {doctools::_configure: Unknown option "-foo", expected -copyright, -file, -module, -format, or -deprecated} - -test doctools-6.2 {configure retrieval} { - new mydoctools - catch {mydoctools configure} result - mydoctools destroy - set result -} {-file {} -module {} -format {} -copyright {} -deprecated 0} - -foreach {n option illegalvalue result} { - 3 -deprecated foo {doctools::_configure: -deprecated expected a boolean, got "foo"} - 4 -format barf {doctools::_configure: -format: Unknown format "barf"} -} { - test doctools-6.$n {configure illegal value} { - new mydoctools - catch {mydoctools configure $option $illegalvalue} result - mydoctools destroy - set result - } $result -} - -foreach {na nb option default newvalue} { - 5 6 -deprecated 0 1 - 7 8 -file {} foo - 9 10 -module {} bar - 11 12 -format {} latex - 13 14 -copyright {} {Andreas Kupries} -} { - test doctools-6.$na {configure query} { - new mydoctools - set res [mydoctools configure $option] - mydoctools destroy - set res - } $default ; # {} - - test doctools-6.$nb {configure set & query} { - new mydoctools - mydoctools configure $option $newvalue - set res [mydoctools configure $option] - mydoctools destroy - set res - } $newvalue ; # {} -} - -test doctools-6.13 {configure full retrieval} { - new mydoctools -file foo -module bar -format latex -deprecated 1 -copyright gnarf - catch {mydoctools configure} result - mydoctools destroy - set result -} {-file foo -module bar -format latex -copyright gnarf -deprecated 1} - -# search .................................................................. - -test doctools-7.0 {search errors} { - new mydoctools - catch {mydoctools search} result - mydoctools destroy - set result -} [tcltest::getErrorMessage "::doctools::_search" "name path" 1] - -test doctools-7.1 {search errors} { - new mydoctools - catch {mydoctools search foo bar} result - mydoctools destroy - set result -} [tcltest::tooManyMessage "::doctools::_search" "name path"] - -test doctools-7.2 {search errors} { - new mydoctools - catch {mydoctools search foo} result - mydoctools destroy - set result -} {mydoctools search: path does not exist} - -test doctools-7.3 {search, initial} { - new mydoctools - set res [llength $::doctools::doctoolsmydoctools::paths] - mydoctools destroy - set res -} 0 - -test doctools-7.4 {extend object search paths} { - new mydoctools - mydoctools search [file dirname [info script]] - set res [list] - lappend res [llength $::doctools::doctoolsmydoctools::paths] - lappend res [lindex $::doctools::doctoolsmydoctools::paths 0] - mydoctools destroy - set res -} [list 1 [file dirname [info script]]] - -# format & warnings ....................................................... - -test doctools-8.0 {format errors} { - new mydoctools - catch {mydoctools format} result - mydoctools destroy - set result -} [tcltest::getErrorMessage "::doctools::_format" "name text" 1] - -test doctools-8.1 {format errors} { - new mydoctools - catch {mydoctools format foo bar} result - mydoctools destroy - set result -} [tcltest::tooManyMessage "::doctools::_format" "name text"] - -test doctools-8.2 {format errors} { - new mydoctools - catch {mydoctools format foo} result - mydoctools destroy - set result -} {mydoctools: No format was specified} - - -test doctools-8.3 {format} { - new mydoctools -format list - set res [mydoctools format {[manpage_begin foo n 1.0][description][strong foo][manpage_end]}] - lappend res [mydoctools warnings] - mydoctools destroy - set res -} {manpage {seealso {} keywords {} file {} section n module {} version 1.0 title foo shortdesc {} desc {} fid {}} {}} - -test doctools-8.4 {format} { - new mydoctools -format list -deprecated on - set res [mydoctools format {[manpage_begin foo n 1.0][description][strong foo][manpage_end]}] - lappend res [mydoctools warnings] - mydoctools destroy - set res -} {manpage {seealso {} keywords {} file {} section n module {} version 1.0 title foo shortdesc {} desc {} fid {}} {{Manpage warning (depr_strong): Deprecated command "[strong {foo}]". -Manpage warning (depr_strong): Please consider appropriate semantic markup or [emph] instead.}}} - - - -# doctools manpage syntax ....................................................... - -test doctools-9.0 {manpage syntax} { - new mydoctools -format null - catch {mydoctools format foo} result - mydoctools destroy - set result -} {Manpage error (body), "plain_text foo" : Plain text not allowed outside of the body of the manpage.} - - -namespace forget ::doctools::new -::tcltest::cleanupTests DELETED modules/doctools/doctools_api.man Index: modules/doctools/doctools_api.man ================================================================== --- modules/doctools/doctools_api.man +++ /dev/null @@ -1,225 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[manpage_begin doctools_api n 1.0] -[copyright {2002 Andreas Kupries }] -[copyright {2003 Andreas Kupries }] -[moddesc {Documentation tools}] -[titledesc {Interface specification for formatter code}] -[description] -[para] - -This manpage specifies the interface between formatting engines for -data in the [syscmd doctools] format as specified in -[syscmd doctools_fmt], and [package doctools], the package for the -generic handling of such data, as described in [syscmd doctools]. - -[para] - -Each formatting engine has to implement the conversion of input in -[syscmd doctools] format to one particular output format as chosen by -the author of the formatting engine. - -[section INTERFACE] - -Each formatting engine has to provide - -[list_begin enum] -[enum] - -Implementations of all the formatting commands as specified in - -[syscmd doctools_fmt], using the defined names, but prefixed with the -string [const fmt_]. The sole exceptions to this are the formatting -commands [cmd vset] and [cmd include]. These two commands are -processed by the generic layer and will never be seen by the -formatting engine. - -[enum] -and additionally implementations for - -[list_begin definitions] - -[lst_item "[cmd fmt_numpasses]"] - -This command is called immediately after the formatter is loaded and -has to return the number of passes required by this formatter to -process a manpage. This information has to be an integer number -greater or equal to one. - -[lst_item "[cmd fmt_initialize]"] - -This command is called at the beginning of every conversion run and is -responsible for initializing the general state of the formatting -engine. - -[lst_item "[cmd fmt_setup] [arg n]"] - -This command is called at the beginning of each pass over the input -and is given the id of the current pass as its first argument. It is -responsible for setting up the internal state of the formatting for -this particular pass. - -[lst_item "[cmd fmt_postprocess] [arg text]"] - -This command is called immediately after the last pass, with the -expansion result of that pass as argument, and can do any last-ditch -modifications of the generated result. Its result will be the final -result of the conversion. - -[nl] - -Most formats will use [emph identity] here. - -[lst_item "[cmd fmt_shutdown]"] - -This command is called at the end of every conversion run and is -responsible for cleaning up of all the state in the formatting engine. - -[lst_item "[cmd fmt_plain_text] [arg text]"] - -This command is called for any plain text encountered by the processor -in the input and can do any special processing required for plain -text. Its result is the string written into the expansion. - -[nl] - -Most formats will use [emph identity] here. - - -[lst_item [cmd fmt_listvariables]] - -The command is called after loading a formatting engine to determine -which parameters are supported by that engine. The return value is a -list containing the names of these parameters. - -[lst_item "[cmd fmt_varset] [arg varname] [arg text]"] - -The command is called by the generic layer to set the value of an -engine specific parameter. The parameter to change is specified by -[arg varname], and the value to set is given in [arg text]. - -[nl] - -The command will throw an error if an unknown [arg varname] is -used. Only the names returned by [cmd fmt_listvariables] are -considered known. - -[list_end] -[list_end] - -[para] - -The tcl code of a formatting engine implementing all of the above can -make the following assumptions about its environment - -[list_begin enum] -[enum] - -It has full access to its own safe interpreter. In other words, the -engine cannot damage the other parts of the processor, nor can it -damage the filesystem. - -[enum] - -The surrounding system provides the engine with the following -commands: - -[list_begin definitions] - -[lst_item "Doctools commands"] -[list_begin definitions] -[lst_item [cmd dt_file]] -Returns the full name of the file currently processed by the engine. -[lst_item [cmd dt_fileid]] -Returns the name of the file currently processed by the engine, -without path, nor extension -[lst_item [cmd dt_format]] -Returns the name of format loaded into the engine -[lst_item [cmd dt_lnesting]] -Returns the number lists currently open -[lst_item [cmd dt_module]] -Returns the name of the module the file currently processed belongs to. -[lst_item "[cmd dt_source] [arg file]"] -This command allows the engine to load additional tcl code. The file -being loaded has to be in the same directory as the file the format -engine was loaded from. Any path specified for [arg file] is ignored. -[list_end] - -[lst_item "Expander commands"] - -All of the commands below are methods of the expander object (without -the prefix [const ex_]) handling the input. Their arguments and -results are described in [package expander(n)]. - - -[list_begin definitions] -[lst_item [cmd ex_cappend]] -[lst_item [cmd ex_cget]] -[lst_item [cmd ex_cis]] -[lst_item [cmd ex_cname]] -[lst_item [cmd ex_cpop]] -[lst_item [cmd ex_cpush]] -[lst_item [cmd ex_cset]] -[lst_item [cmd ex_lb]] -[lst_item [cmd ex_rb]] -[list_end] - -[lst_item "_common.tcl commands"] - -Any engine loading ([cmd dt_source]) the file [file _common.tcl] has -default implementations of the [const fmt_] commands explicitly -listed in this document, and can additionally use - -[list_begin definitions] -[lst_item [cmd c_inpass]] -Returns the id of the pass currently executing -[lst_item [cmd c_begin]] -Use this to mark that processing of the text after [cmd manpage_begin] -has begun. -[lst_item [cmd c_begun]] -Checks the flag set by [cmd c_begin]. -[lst_item "[cmd c_set_module] [arg text]"] -Remember [arg text] as module information. -[lst_item [cmd c_get_module]] -Retrieve module information stored by [cmd c_set_module]. -[lst_item "[cmd c_set_title] [arg text]"] -Remember [arg text] as title. -[lst_item [cmd c_get_title]] -Retrieve title stored by [cmd c_set_title]. -[lst_item [cmd c_provenance]] -Returns a string describing how the input was processed. -[lst_item "[cmd c_pass] [arg {pass proc arguments body}]"] -Define a procedure which is valid when pass [arg pass] of the engine -is executed. -[lst_item "[cmd c_holdBuffers] [arg args]"] -Define one or more buffers for holding data between passes. -[lst_item "[cmd c_hold] [arg {buffer entry}]"] -Add an entry to the specified buffer. The buffer has to be defined by -an earlier invocation of the command [cmd c_holdBuffers]. -[lst_item "[cmd c_held] [arg buffer]"] -Retrieves the contents of the specified buffer. The buffer is empty -afterwards. All entries in the buffer are joined by newlines. -[lst_item [cmd c_cnext]] -Increment the counter and return its current value. -[lst_item [cmd c_cinit]] -Push the current counter on the stack and reinitialize the counter to zero. -[lst_item [cmd c_creset]] -Reinitialize the counter with the value on the counter stack and -remove that value from the stack. -[lst_item "[cmd NOP] [arg args]"] -Do nothing command. Can be used in conjunction with [cmd c_pass] to -visibly declare in which passes a formatting command has nothing to do. -[lst_item "[cmd NYI] [opt [arg message]]"] -Throws the error "[arg message] [const {Not yet implemented}]". -[lst_item "[cmd c_sectionId] [arg name]"] -Remembers the name of the section for later cross-referencing -[lst_item "[cmd c_possibleReference] [arg {text gi}]"] -Checks if a section is available for [arg text]. This command is -currently tuned for use by engines like HTML and TMML. -[list_end] - -[list_end] -[list_end] - -[see_also doctools_fmt doctools] -[keywords markup {generic markup} manpage TMML HTML nroff LaTeX] -[manpage_end] DELETED modules/doctools/doctools_fmt.man Index: modules/doctools/doctools_fmt.man ================================================================== --- modules/doctools/doctools_fmt.man +++ /dev/null @@ -1,442 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[manpage_begin doctools_fmt n 1.0] -[copyright {2002 Andreas Kupries }] -[copyright {2003 Andreas Kupries }] -[moddesc {Documentation tools}] -[titledesc {Specification of simple tcl markup for manpages}] -[description] -[para] - -This manpage specifies a documentation format for manpages. It is -intended to complement both the [syscmd doctoc] format for writing -tables of contents and the [syscmd docidx] format for writing indices. -See [syscmd doctoc_fmt] and [syscmd docidx_fmt] for the specification -of these two formats. - - -[para] - -This format is called [syscmd doctools]. - -It provides all the necessary commands to write manpages. - -Like for the [syscmd doctoc] and [syscmd docidx] formats a package is -provided implementing a generic framework for the conversion of -[syscmd doctools] to a number of different output formats, like HTML, -TMML, nroff, LaTeX, etc. - -The package is called [package doctools], its documentation can be -found in [syscmd doctools]. - -People wishing to write a formatting engine for the conversion of -[syscmd doctools] into a new output format have to read -[syscmd doctools_api]. This manpage will explain the interface between -the generic package and such engines. - - -[section OVERVIEW] - -[syscmd doctoc] is similar to LaTex in that it consists primarily of -text, with markup commands embedded into it. The format used to mark -something as command is different from LaTeX however. All text between -matching pairs of [lb] and [rb] is a command, possibly with -arguments. Note that both brackets have to be on the same line for a -command to be recognized. - -[para] - -In contrast to both [syscmd doctoc] and [syscmd docidx] this format -does allow plain text beyond white space. This plain text will be the -contents of the described manpage. - - -[section {FORMATTING COMMANDS}] -[list_begin bullet] -[bullet] - -The main commands are [cmd manpage_begin], [cmd manpage_end], -[cmd moddesc], [cmd titledesc], and [cmd description]. Four of these -five are required for a manpage. The optional command is -[cmd titledesc]. The first two are the first and last commands in a -manpage. Neither text nor other commands may precede -[cmd manpage_begin] nor follow [cmd manpage_end]. The command -[cmd description] separates header and body of the manpage and may not -be omitted. - -[nl] - -The remaining commands ([cmd moddesc] and [cmd titledesc]) provide -one-line descriptions of module and specific title respectively. - -[bullet] -The only text allowed between [cmd manpage_begin] and -[cmd description] is the command [cmd require]. Other commands or -normal text are not permitted. [cmd require] is used to list the -packages the described command(s) depend(s) on for its operation. This -list can be empty. - -[bullet] -After [cmd description] text and all other commands are allowed. The -text can be separated into highlevel blocks using named -[cmd section]s. Each block can be further divided into paragraphs via -[cmd para]. - -[bullet] -The commands [cmd see_also] and [cmd keywords] define whole sections -named [emph {SEE ALSO}] and [emph KEYWORDS]. They can occur everywhere -in the manpage but making them the last section is the usual thing to -do. They can be omitted. - -[bullet] - -There are five commands available to markup words, [cmd arg], - -[cmd cmd], [cmd opt], [cmd emph] and [cmd strong]. The first three are -used to mark words as [emph {command arguments}], as - -[emph {command names}] and as [emph optional]. The other two are -visual markup to emphasize words. The term [emph words] is used in a -loose sense here, i.e application of the commands to a sequence of -words is entirely possible, if they are properly quoted. [emph Note] -that usage of [cmd strong] is discouraged as this command is -deprecated and only present for backwards compatibility - -[bullet] - -Another set of commands is available to construct (possibly nested) -lists. These are [cmd list_begin], [cmd list_end], [cmd lst_item], -[cmd bullet], [cmd enum], [cmd call], [cmd arg_def], [cmd opt_def], -[cmd cmd_def], and [cmd tkoption_def]. The first two of these begin -and end a list respectively. - -[nl] - -The argument to the first command denotes the type of the list. The -allowed values and their associated item command are explained later, -in the section detailing the [sectref Commands]. - -[nl] - -The other commands start list items and each can be used only inside a -list of their type. In other words, [cmd bullet] is allowed in -bulletted lists but nowhere else, [cmd enum] in enumerated lists and -[cmd lst_item] and [cmd call] are for definition lists. These two -commands also have some text directly associated with the item -although the major bulk of the item is the text following the item -until the next list command. - -[nl] - -The last list command, [cmd call] is special. It is used to describe -the syntax of a command and its arguments. It should not only cause -the appropriate markup of a list item at its place but also add the -syntax to the table of contents (synopsis) if supported by the output -format in question. nroff and HTML for example do. A format focused on -logical markup, like TMML, may not. - -[bullet] -The command [cmd usage] is similar to [cmd call] in that it adds the -syntax to the table of contents (synopsis) if supported by the output -format. Unlike [cmd call], this command doesn't add any text to the -output as a direct result of the command. Thus, it can be used -anywhere within the document to add usage information. Typically it is -used near the top of the document, in cases where it is not desireable -to use [cmd call] elsewhere in the document, or where additional usage -information is desired (e.g.: to document a "package require" command). - -[list_end] - -[section Commands] -[list_begin definitions] - -[call [cmd vset] [arg varname] [arg value] ] - -Sets the formatter variable [arg varname] to the specified -[arg value]. Returns the empty string. - -[call [cmd vset] [arg varname]] - -Returns the value associated with the formatter variable -[arg varname]. - -[call [cmd include] [arg filename]] - -Reads the file named [arg filename], runs it through the expansion -process and returns the expanded result. - - -[call [cmd manpage_begin] [arg command] [arg section] [arg version]] - -This command begins a manpage. Nothing is allowed to precede -it. Arguments are the name of the command described by the manpage, -the section of the manpages this manpages lives in, and the version of -the module containing the command. All have to fit on one line. - -[call [cmd manpage_end]] - -This command closes a manpage. Nothing is allowed to follow it. - -[call [cmd moddesc] [arg desc]] - -This command is required and comes after [cmd manpage_begin], but -before either [cmd require] or [cmd description]. Its argument -provides a one-line description of the module described by the manpage. - -[call [cmd titledesc] [arg desc]] - -This command is optional and comes after [cmd manpage_begin], but -before either [cmd require] or [cmd description]. Its argument -provides a one-line expansion of the title for the manpage. If this -command is not used the manpage processor has to use information from -[cmd moddesc] instead. - -[call [cmd copyright] [arg text]] - -This command is optional and comes after [cmd manpage_begin], but -before either [cmd require] or [cmd description]. Its argument -declares the copyright assignment for the manpage. When invoked more -than once the assignments are accumulated. - -[nl] - -A doctools processor is allowed to provide auch information too, but a -formatting engine has to give the accumulated arguments of this -command precedence over the data coming from the processor. - -[call [cmd description]] - -This command separates the header part of the manpage from the main -body. Only [cmd require], [cmd moddesc], or [cmd titledesc] may -precede it. - -[call [cmd require] [arg pkg] [opt [arg version]]] - -May occur only between [cmd manpage_begin] and [cmd description]. Is -used to list the packages which are required for the described command -to be operational. - -[call [cmd section] [arg name]] - -Used to structure the body of the manpage into named sections. This -command is not allowed inside of a list or example. It implicitly -closes the last [cmd para]graph before the command and also implicitly -opens the first paragraph of the new section. - -[call [cmd para]] - -Used to structure sections into paragraphs. Must not be used inside of -a list or example. - -[call [cmd see_also] [arg args]] - -Creates a section [emph {SEE ALSO}] containing the arguments as -cross-references. Must not be used inside of a list or example. - -[call [cmd keywords] [arg args]] - -Creates a section [emph KEYWORDS] containing the arguments as words -indexing the manpage. Must not be used inside of a list or example. - -[call [cmd arg] [arg text]] - -Declares that the marked [arg text] is the name of a command argument. - -[call [cmd cmd] [arg text]] - -Declares that the marked [arg text] is the name of a command. - -[call [cmd opt] [arg text]] - -Declares that the marked [arg text] is something optional. Most often used -in conjunction with [cmd arg] to denote optional command arguments. - -[call [cmd emph] [arg text]] - -Emphasize the [arg text]. - -[call [cmd strong] [arg text]] - -Emphasize the [arg text]. Same as [cmd emph]. Usage is -discouraged. The command is deprecated and present only for backward -compatibility. - -[call [cmd comment] [arg text]] - -Declares that the marked [arg text] is a comment. - -[call [cmd sectref] [arg text]] - -Declares that the marked [arg text] is a section reference. - -[call [cmd syscmd] [arg text]] - -Declares that the marked [arg text] is a system command. - -[call [cmd method] [arg text]] - -Declares that the marked [arg text] is a object method. - -[call [cmd option] [arg text]] - -Declares that the marked [arg text] is a option. - -[call [cmd widget] [arg text]] - -Declares that the marked [arg text] is a widget. - -[call [cmd fun] [arg text]] - -Declares that the marked [arg text] is a function. - -[call [cmd type] [arg text]] - -Declares that the marked [arg text] is a data type. - -[call [cmd package] [arg text]] - -Declares that the marked [arg text] is a package. - -[call [cmd class] [arg text]] - -Declares that the marked [arg text] is a class. - -[call [cmd var] [arg text]] - -Declares that the marked [arg text] is a variable. - -[call [cmd file] [arg text]] - -Declares that the marked [arg text] is a file . - -[call [cmd uri] [arg text]] - -Declares that the marked [arg text] is a uri. - -[call [cmd term] [arg text]] - -Declares that the marked [arg text] is a unspecific terminology. - -[call [cmd const] [arg text]] - -Declares that the marked [arg text] is a constant value. - -[call [cmd nl]] - -Vertical space to separate text without breaking it into a new -paragraph. - -[call [cmd lb]] - -Introduces a left bracket into the output. - -[call [cmd rb]] - -Introduces a right bracket into the output. The bracket commands are -necessary as plain brackets are used to denote the beginnings and -endings of the formatting commands. - -[call [cmd example_begin]] -Formats subsequent text as a code sample: -line breaks, spaces, and tabs are preserved and, -where appropriate, text is presented in a fixed-width font. - -[call [cmd example_end]] -End of a code sample block. - -[call [cmd example] [arg text]] - -Formats [arg text] as a multi-line block of sample code. -[arg text] should be enclosed in braces. - -[call [cmd list_begin] [arg what]] - -Starts new list of type [arg what]. The allowed types (and their -associated item commands) are: - -[list_begin definitions] -[lst_item [emph bullet]] -[cmd bullet] - -[lst_item [emph enum]] -[cmd enum] - -[lst_item [emph definitions]] -[cmd lst_item] and [cmd call] - -[lst_item [emph arg]] -[cmd arg_def] - -[lst_item [emph cmd]] -[cmd cmd_def] - -[lst_item [emph opt]] -[cmd opt_def] - -[lst_item [emph tkoption]] -[cmd tkoption_def] - -[list_end] - - -[call [cmd list_end]] - -Ends the list opened by the last [cmd list_begin]. - -[call [cmd bullet]] - -Starts a new item in a bulletted list. - -[call [cmd enum]] - -Starts a new item in an enumerated list. - -[call [cmd lst_item] [arg text]] - -Starts a new item in a definition list. The argument is the term to be -defined. - -[call [cmd call] [arg args]] - -Starts a new item in a definition list, but the term defined by it is -a command and its arguments. - -[call [cmd arg_def] [arg type] [arg name] [opt [arg mode]]] - -Starts a new item in an argument list. Specifies the data-[arg type] -of the described argument, its [arg name] and possibly its -i/o-[arg mode]. - -[call [cmd opt_def] [arg name] [opt [arg arg]]] - -Starts a new item in an option list. Specifies the [arg name] of the -option and possible (i.e. optional) [arg arg]uments. - -[call [cmd cmd_def] [arg command]] - -Starts a new item in a command list. Specifies the name of the -[arg command]. - -[call [cmd tkoption_def] [arg name] [arg dbname] [arg dbclass]] - -Starts a new item in a widget option list. Specifies the [arg name] -of the option, i.e. the name used in scripts, name used by the option -database, and the class (type) of the option. - -[call [cmd usage] [arg args]] - -Defines a term to be used in the table of contents or synopsis section, -depending on the format. This command is [emph silent], as it doesn't -add any text to the output as a direct result of the call. It merely -defines data to appear in another section. - -[list_end] - -[section EXAMPLE] - -The tcl sources of this manpage can serve as an example for all of the -markup described by it. Almost every possible construct (with the -exception of [cmd require]) is used here. - -[see_also doctoc_fmt docidx_fmt doctools_api doctools] -[keywords markup {generic markup} manpage TMML HTML nroff LaTeX] -[manpage_end] DELETED modules/doctools/mpexpand Index: modules/doctools/mpexpand ================================================================== --- modules/doctools/mpexpand +++ /dev/null @@ -1,153 +0,0 @@ -#!/bin/sh -# -*- tcl -*- \ -exec tclsh "$0" ${1+"$@"} - -lappend auto_path [file dirname [file dirname [info script]]] -package require doctools - -# --------------------------------------------------------------------- -# 1. Handle command line options, input and output -# 2. Initialize a doctools object. -# 3. Run the input through the object. -# 4. Write output. -# --------------------------------------------------------------------- - -proc usage {{exitstate 1}} { - global argv0 - puts "Usage: $argv0\ - ?-h|--help|-help|-??\ - ?-help-fmt|--help-fmt?\ - ?-module module?\ - ?-deprecated?\ - ?-copyright text?\ - format in|- ?out|-?" - exit $exitstate -} - -# --------------------------------------------------------------------- - -proc fmthelp {} { - # Tcllib FR #527029: short reference of formatting commands. - - global argv0 - puts "$argv0 [doctools::help]" - exit 0 -} - -# --------------------------------------------------------------------- -# 1. Handle command line options, input and output - -proc cmdline {} { - global argv0 argv format in out extmodule deprecated copyright - - set copyright "" - set extmodule "" - set deprecated 0 - - while {[string match -* [set opt [lindex $argv 0]]]} { - switch -exact -- $opt { - -module { - set extmodule [lindex $argv 1] - set argv [lrange $argv 2 end] - continue - } - -copyright { - set copyright [lindex $argv 1] - set argv [lrange $argv 2 end] - continue - } - -deprecated { - set deprecated 1 - set argv [lrange $argv 1 end] - } - -help - -h - --help - -? { - # Tcllib FR #527029 - usage 0 - } - -help-fmt - --help-fmt { - # Tcllib FR #527029 - fmthelp - } - default { - # Unknown option - usage - } - } - } - - if {[llength $argv] < 3} { - usage - } - foreach {format in out} $argv break - - if {$format == {} || $in == {}} { - usage - } - if {$out == {}} {set out -} - return $format -} - -# --------------------------------------------------------------------- -# 3. Read input. Also providing the namespace with file information. - -proc get_input {} { - global in - if {[string equal $in -]} { - return [read stdin] - } else { - set if [open $in r] - set text [read $if] - close $if - return $text - } -} - -# --------------------------------------------------------------------- -# 4. Write output. - -proc write_out {text} { - global out - if {[string equal $out -]} { - puts -nonewline stdout $text - } else { - set of [open $out w] - puts -nonewline $of $text - close $of - } -} - - -# --------------------------------------------------------------------- -# Get it all together - -proc main {} { - global format deprecated extmodule in copyright - - #if {[catch {} - cmdline - - ::doctools::new dt -format $format -deprecated $deprecated -file $in - if {$extmodule != {}} { - dt configure -module $extmodule - } - if {$copyright != {}} { - dt configure -copyright $copyright - } - - write_out [dt format [get_input]] - - set warnings [dt warnings] - if {[llength $warnings] > 0} { - puts stderr [join $warnings \n] - } - - #{} msg]} {} - #puts stderr "Execution error: $msg" - #{} - return -} - - -# --------------------------------------------------------------------- -main -exit DELETED modules/doctools/mpexpand.all Index: modules/doctools/mpexpand.all ================================================================== --- modules/doctools/mpexpand.all +++ /dev/null @@ -1,38 +0,0 @@ -#!/bin/sh -# -*- tcl -*- \ -exec tclsh "$0" ${1+"$@"} - -set here [file dirname [file join [pwd] [info script]]] -set verbose 0 - -set o [lindex $argv 0] -if {[string equal $o "-verbose"]} { - set verbose 1 - set argv [lrange $argv 1 end] -} elseif {[string equal $o ""] && [llength $argv] > 1} { - puts stderr "Usage: $argv0 ?-verbose? ?module?" - exit 1 -} - -set module [lindex $argv 0] -array set fmts { - nroff n - html html - tmml tmml - latex tex -} - -foreach fname [glob -nocomplain *.man] { - foreach fmt [array names fmts] { - set out [file rootname $fname].$fmts($fmt) - if {1 || $verbose} { - puts " $fname -> $out" - } - if {$module != {}} { - exec [file join $here mpexpand] -module $module $fmt $fname $out - } else { - exec [file join $here mpexpand] $fmt $fname $out - } - } -} -exit DELETED modules/doctools/mpexpand.man Index: modules/doctools/mpexpand.man ================================================================== --- modules/doctools/mpexpand.man +++ /dev/null @@ -1,88 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[manpage_begin mpexpand n 1.0] -[copyright {2002 Andreas Kupries }] -[copyright {2003 Andreas Kupries }] -[moddesc {Documentation toolbox}] -[titledesc {Markup processor}] -[description] -[para] - -This manpage describes a processor / converter for manpages in the -doctools format as specified in [cmd dtformat]. The processor is based -upon the package [package doctools]. - -[list_begin definitions] -[call [cmd mpexpand] [opt "-module [arg module]"] [arg format] [arg infile]|- [arg outfile]|-] - -The processor takes three arguments, namely the code describing which -formatting to generate as the output, the file to read the markup -from, and the file to write the generated output into. If the -[arg infile] is "[const -]" the processor will read from -[const stdin]. If [arg outfile] is "[const -]" the processor will -write to [const stdout]. - -[nl] - -If the option [arg -module] is present its value overrides the internal -definition of the module name. - -[nl] - -The currently known output formats are - -[list_begin definitions] - -[lst_item [const nroff]] - -The processor generates *roff output, the standard format for unix -manpages. - -[lst_item [const html]] - -The processor generates HTML output, for usage in and display by web -browsers. - -[lst_item [const tmml]] - -The processor generates TMML output, the Tcl Manpage Markup Language, -a derivative of XML. - -[lst_item [const latex]] - -The processor generates LaTeX output. - -[lst_item [const wiki]] - -The processor generates Wiki markup as understood by [syscmd wikit]. - -[lst_item [const list]] - -The processor extracts the information provided by [cmd manpage_begin]. - -[lst_item [const null]] - -The processor does not generate any output. - -[list_end] - -[call [cmd mpexpand.all] [opt [arg -verbose]] [opt [arg module]]] - -This command uses [syscmd mpexpand] to generate all possible output -formats for all manpages in the current directory. The manpages are -recognized through the extension [file .man]. If [arg -verbose] is -specified the command will list its actions before executing them. - -[nl] - -The [arg module] information is passed to [cmd mpexpand]. - -[list_end] - -[section NOTES] -[para] - -Possible future formats are plain text, pdf and postscript. - -[see_also expander(n) format(n) formatter(n)] -[keywords manpage TMML HTML nroff conversion markup] -[manpage_end] DELETED modules/doctools/mpformats/_common.tcl Index: modules/doctools/mpformats/_common.tcl ================================================================== --- modules/doctools/mpformats/_common.tcl +++ /dev/null @@ -1,260 +0,0 @@ -# -*- tcl -*- -# -# _common.tcl -# -# (c) 2001 Andreas Kupries -# (c) 2002 Andreas Kupries - -################################################################ -# The code here contains general definitions for API functions and -# state information. They are used by several formatters to simplify -# their own code. - -global state -array set state {} - -proc fmt_initialize {} { - global state - unset state - - set state(pass) unknown ; # Not relevant before a pass - set state(begun) unknown ; # is active - set state(mdesc) {} ; # Text, module desciption - #set state(tdesc) {} ; # Text, title of manpage - set state(copyright) {} ; # Text, copyright assignment (list) - return -} - -proc fmt_shutdown {} {return} -proc fmt_numpasses {} {return 2} -proc fmt_postprocess {text} {return $text} -proc fmt_plain_text {text} {return $text} -proc fmt_listvariables {} {return {}} -proc fmt_varset {varname text} {return} - -proc fmt_setup {n} { - # Called to setup a pass through the input. - - global state - set state(pass) $n ; # We are in pass 'n' through the text. - set state(begun) 0 ; # No manpage_begin yet - - if {$n == 1} {c_xref_init} - - SetPassProcs $n - return -} - -################################################################ -# Functions made available to the formatter to access the common -# state managed here. - -proc c_inpass {} {global state ; return $state(pass)} - -proc c_begin {} {global state ; set state(begun) 1 ; return} -proc c_begun {} {global state ; return $state(begun)} - -proc c_get_module {} {global state ; return $state(mdesc)} -proc c_set_module {text} {global state ; set state(mdesc) $text ; return} - -proc c_set_title {text} {global state ; set state(tdesc) $text ; return} -proc c_get_title {} { - global state - if {![info exists state(tdesc)]} { - return $state(mdesc) - } - return $state(tdesc) -} - -proc c_copyrightsymbol {} {return "(c)"} -proc c_set_copyright {text} {global state ; lappend state(copyright) $text ; return} -proc c_get_copyright {} { - global state - - set cc $state(copyright) - if {$cc == {}} {set cc [dt_copyright]} - if {$cc == {}} {return {}} - - return "Copyright [c_copyrightsymbol] [join $cc "\nCopyright [c_copyrightsymbol] "]" -} - -proc c_provenance {} { - return "Generated from file '[dt_file]' by tcllib/doctools with format '[dt_format]'" -} - -################################################################ -# Manage pass-dependent procedure definitions. - -global PassProcs - -# pass $passNo procName procArgs { body } -- -# Specifies procedure definition for pass $n. -# -proc c_pass {pass proc arguments body} { - global PassProcs - lappend PassProcs($pass) $proc $arguments $body -} -proc SetPassProcs {pass} { - global PassProcs - foreach {proc args body} $PassProcs($pass) { - proc $proc $args $body - } -} - - -################################################################ -# Manage a set of buffers to hold information between passes. -# Each buffer holds a list of lines. - -global Buffers - -# holdBuffers buffer ? buffer ...? -- -# Declare a list of hold buffers, -# to collect data in one pass and output it later. -# -proc c_holdBuffers {args} { - global Buffers - foreach arg $args { - set Buffers($arg) [list] - } -} - -proc c_holdRemove {args} { - global Buffers - foreach arg $args { - catch {unset Buffers($arg)} - } - return -} - -# hold buffer text -- -# Append text to named buffer -# -proc c_hold {buffer entry} { - global Buffers - lappend Buffers($buffer) $entry - - #puts "$buffer -- $entry" - return -} - -proc c_holding {buffer} { - global Buffers - set l 0 - catch {set l [llength $Buffers($buffer)]} - return $l -} - -# held buffer -- -# Returns current contents of named buffer and empty the buffer. -# -proc c_held {buffer} { - global Buffers - set content [join $Buffers($buffer) "\n"] - set Buffers($buffer) [list] - return $content -} - -###################################################################### -# Nested counter - -global counters cnt -set counters [list] -set cnt 0 - -proc c_cnext {} {global cnt ; incr cnt} -proc c_cinit {} { - global counters cnt - set counters [linsert $counters 0 $cnt] - set cnt 0 - return -} -proc c_creset {} { - global counters cnt - set cnt [lindex $counters 0] - set counters [lrange $counters 1 end] - return -} - - -###################################################################### -# Utilities. -# - -proc NOP {args} { } ;# do nothing -proc NYI {{message {}}} { - return -code error [append message " Not Yet Implemented"] -} - -###################################################################### -# Cross-reference tracking (for a single file). -# -global SectionNames ;# array mapping 'section name' to 'reference id' - -# sectionId -- -# Format section name as an XML ID. -# -proc c_sectionId {name} { - regsub -all {[^[:alnum:]]} $name {} name - return [string tolower $name] -} - -# possibleReference text gi -- -# Check if $text is a potential cross-reference; -# if so, format as a reference; -# otherwise format as a $gi element. -# -proc c_possibleReference {text gi} { - global SectionNames - if {[info exists SectionNames($text)]} { - return "[startTag ref refid $SectionNames($text)]$text[endTag ref]" - } else { - return [wrap $text $gi] - } -} - -###################################################################### -# Conversion specification. -# -# Two-pass processing. The first pass collects text for the -# SYNOPSIS, SEE ALSO, and KEYWORDS sections, and the second pass -# produces output. -# - -c_holdBuffers synopsis see_also keywords precomments - -################################################################ -# Management of see-also and keyword cross-references - -proc c_xref_init {} { - global seealso seealso__ ; set seealso [list] ; catch {unset seealso__} ; array set seealso__ {} - global keywords keywords__ ; set keywords [list] ; catch {unset keywords__} ; array set keywords__ {} -} - -proc c_xref_seealso {} {global seealso ; return $seealso} -proc c_xref_keywords {} {global keywords ; return $keywords} - -c_pass 1 fmt_see_also {args} { - global seealso seealso__ - foreach ref $args { - if {[info exists seealso__($ref)]} continue - lappend seealso $ref - set seealso__($ref) . - } - return -} - -c_pass 1 fmt_keywords {args} { - global keywords keywords__ - foreach ref $args { - if {[info exists keywords__($ref)]} continue - lappend keywords $ref - set keywords__($ref) . - } - return -} - -c_pass 2 fmt_see_also {args} NOP -c_pass 2 fmt_keywords {args} NOP - -################################################################ DELETED modules/doctools/mpformats/_html.tcl Index: modules/doctools/mpformats/_html.tcl ================================================================== --- modules/doctools/mpformats/_html.tcl +++ /dev/null @@ -1,133 +0,0 @@ -# -*- tcl -*- -# Helper rules for the creation of the memchan website from the .exp files. -# General formatting instructions ... - -# htmlEscape text -- -# Replaces HTML markup characters in $text with the -# appropriate entity references. -# - -global textMap; -set textMap { - & & < < > > - \xa0   \xb0 ° \xc0 À \xd0 Ð \xe0 à \xf0 ð - \xa1 ¡ \xb1 ± \xc1 Á \xd1 Ñ \xe1 á \xf1 ñ - \xa2 ¢ \xb2 ² \xc2 Â \xd2 Ò \xe2 â \xf2 ò - \xa3 £ \xb3 ³ \xc3 Ã \xd3 Ó \xe3 ã \xf3 ó - \xa4 ¤ \xb4 ´ \xc4 Ä \xd4 Ô \xe4 ä \xf4 ô - \xa5 ¥ \xb5 µ \xc5 Å \xd5 Õ \xe5 å \xf5 õ - \xa6 ¦ \xb6 ¶ \xc6 Æ \xd6 Ö \xe6 æ \xf6 ö - \xa7 § \xb7 · \xc7 Ç \xd7 × \xe7 ç \xf7 ÷ - \xa8 ¨ \xb8 ¸ \xc8 È \xd8 Ø \xe8 è \xf8 ø - \xa9 © \xb9 ¹ \xc9 É \xd9 Ù \xe9 é \xf9 ù - \xaa ª \xba º \xca Ê \xda Ú \xea ê \xfa ú - \xab « \xbb » \xcb Ë \xdb Û \xeb ë \xfb û - \xac ¬ \xbc ¼ \xcc Ì \xdc Ü \xec ì \xfc ü - \xad ­ \xbd ½ \xcd Í \xdd Ý \xed í \xfd ý - \xae ® \xbe ¾ \xce Î \xde Þ \xee î \xfe þ - \xaf &hibar; \xbf ¿ \xcf Ï \xdf ß \xef ï \xff ÿ - {"} " -} ; # " make the emacs highlighting code happy. - -# Handling of HTML delimiters in content: -# -# Plain text is initially passed through unescaped; -# internally-generated markup is protected by preceding it with \1. -# The final PostProcess step strips the escape character from -# real markup and replaces markup characters from content -# with entity references. -# - -global markupMap -set markupMap { {&} {\1&} {<} {\1<} {>} {\1>} {"} {\1"} } -global finalMap -set finalMap $textMap -lappend finalMap {\1&} {&} {\1<} {<} {\1>} {>} {\1"} {"} - - -proc htmlEscape {text} { - global textMap - return [string map $textMap $text] -} - -proc fmt_postprocess {text} { - global finalMap - return [string map $finalMap $text] -} - -# markup text -- -# Protect markup characters in $text with \1. -# These will be stripped out in PostProcess. -# -proc markup {text} { - global markupMap - return [string map $markupMap $text] -} - -proc use_bg {} { - set c [bgcolor] - #puts stderr "using $c" - if {$c == {}} {return ""} - return bgcolor=$c -} - - -proc nbsp {} {return [markup " "]} -proc p {} {return [markup

]} -proc ptop {} {return [markup "

"]} -proc td {} {return [markup ""]} -proc trtop {} {return [markup ""]} -proc tr {} {return [markup ""]} -proc sect {s} {return [markup "$s

"]} -proc link {text url} {return [markup "$text"]} -proc table {} {return [markup ""]} -proc btable {} {return [markup "
"]} -proc stable {} {return [markup "
"]} - - -proc tcl_cmd {cmd} {return "[markup ]\[$cmd][markup ]"} -proc wget {url} {exec /usr/bin/wget -q -O - $url 2>/dev/null} - -proc url {tag text url} { - set body { - switch -exact -- $what { - link {return {\1%text%\1}} ; ## TODO - markup - text {return {%text%}} - url {return {%url%}} - } - } - proc $tag {{what link}} [string map [list %text% $text %url% $url] $body] -} - -proc img {tag alt img} { - proc $tag {} [list return "\1\"$alt\""] -} - -proc protect {text} {return [string map [list & "&" < "<" > ">"] $text]} - - -proc tag {t} {return [markup <$t>]} -proc taga {t av} { - # av = attribute value ... - set avt [list] - foreach {a v} $av {lappend avt "$a=\"$v\""} - return [markup "<$t [join $avt]>"] -} -proc tag/ {t} {return [markup ]} -proc tag_ {t block args} { - # args = key value ... - if {$args == {}} {return "[tag $t]$block[tag/ $t]"} - return "[taga $t $args]$block[tag/ $t]" -} - - -proc ht_comment {text} {return "[markup <]! -- [join [split $text \n] " -- "]\n --[markup >]"} - -# wrap content gi -- -# Returns $content wrapped inside <$gi> ... tags. -# -proc wrap {content gi} { - return "[tag $gi]${content}[tag/ $gi]" -} -proc startTag {x args} {if {[llength $args]} {taga $x $args} else {tag $x}} -proc endTag {x} {tag/ $x} DELETED modules/doctools/mpformats/_idx_common.tcl Index: modules/doctools/mpformats/_idx_common.tcl ================================================================== --- modules/doctools/mpformats/_idx_common.tcl +++ /dev/null @@ -1,31 +0,0 @@ -# -*- tcl -*- -# -# _idx_common.tcl -# -# (c) 2003 Andreas Kupries - -################################################################ -# The code here contains general definitions for API functions and -# state information. They are used by several formatters to simplify -# their own code. - -proc idx_initialize {} {return} -proc idx_shutdown {} {return} -proc idx_numpasses {} {return 1} -proc idx_postprocess {text} {return $text} -proc idx_setup {n} {return} -proc idx_listvariables {} {return {}} -proc idx_varset {varname text} {return} - - -proc fmt_plain_text {text} {return $text} - -################################################################ -# Functions made available to the formatter to access the common -# state managed here. - -proc c_provenance {} { - return "Generated by tcllib/doctools/idx with format '[dt_format]'" -} - -################################################################ DELETED modules/doctools/mpformats/_nroff.tcl Index: modules/doctools/mpformats/_nroff.tcl ================================================================== --- modules/doctools/mpformats/_nroff.tcl +++ /dev/null @@ -1,83 +0,0 @@ -# -*- tcl -*- -# -# -- nroff commands -# -# Copyright (c) 2003 Andreas Kupries - - -################################################################ -# nroff specific commands -# -# All dot-commands (f.e. .PP) are returned with a leading \n, -# enforcing that they are on a new line. Any empty line created -# because of this is filtered out in the post-processing step. - - -proc nr_lp {} {return \n.LP} -proc nr_ta {{text {}}} {return ".ta$text"} -proc nr_bld {} {return \\fB} -proc nr_ul {} {return \\fI} -proc nr_rst {} {return \\fR} -proc nr_p {} {return \n.PP\n} -proc nr_comment {text} {return "'\\\" [join [split $text \n] "\n'\\\" "]"} ; # " -proc nr_enum {num} {nr_item " \[$num\]"} -proc nr_item {{text {}}} {return "\n.IP$text"} -proc nr_vspace {} {return \n.sp} -proc nr_blt {text} {return "\n.TP\n$text"} -proc nr_bltn {n text} {return "\n.TP $n\n$text"} -proc nr_in {} {return \n.RS} -proc nr_out {} {return \n.RE} -proc nr_nofill {} {return \n.nf} -proc nr_fill {} {return .fi} -proc nr_title {text} {return "\n.TH $text"} -proc nr_include {file} {return "\n.so $file"} -proc nr_bolds {} {return \n.BS} -proc nr_bolde {} {return \n.BE} - -proc nr_section {name} {return "\n.SH \"$name\""} - - -################################################################ - -proc nroff_postprocess {nroff} { - # Postprocessing final nroff text. - # - Strip empty lines out of the text - # - Remove leading and trailing whitespace from lines. - # - Exceptions to the above: Keep empty lines and leading - # whitespace when in verbatim sections (no-fill-mode) - - set nfMode [list .nf .CS] ; # commands which start no-fill mode - set fiMode [list .fi .CE] ; # commands which terminate no-fill mode - set lines [list] ; # Result buffer - set verbatim 0 ; # Automaton mode/state - - foreach line [split $nroff "\n"] { - if {!$verbatim} { - # Normal lines, not in no-fill mode. - - if {[lsearch -exact $nfMode [split $line]] >= 0} { - # no-fill mode starts after this line. - set verbatim 1 - } - - # Ensure that empty lines are not added. - # This also removes leading and trailing whitespace. - - if {![string length $line]} {continue} - set line [string trim $line] - if {![string length $line]} {continue} - } else { - # No-fill mode. We remove trailing whitespace, but keep - # leading whitespace and empty lines. - - if {[lsearch -exact $fiMode [split $line]] >= 0} { - # Normal mode resumes after this line. - set verbatim 0 - } - set line [string trimright $line] - } - lappend lines $line - } - # Return the modified result buffer - return [join $lines "\n"] -} DELETED modules/doctools/mpformats/_text.tcl Index: modules/doctools/mpformats/_text.tcl ================================================================== --- modules/doctools/mpformats/_text.tcl +++ /dev/null @@ -1,406 +0,0 @@ -# -*- tcl -*- -# -# _text.tcl -- Core support for text engines. - - -################################################################ - -if 0 { - catch {rename proc proc__} msg ; puts_stderr >>$msg - proc__ proc {cmd argl body} { - puts_stderr "proc $cmd $argl ..." - uplevel [list proc__ $cmd $argl $body] - } -} - -dt_package textutil - -if 0 { - puts_stderr ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - rename proc {} - rename proc__ proc - puts_stderr ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -} - - -################################################################ -# Formatting constants ... Might be engine variables in the future. - -global lmarginIncrement ; set lmarginIncrement 4 -global rmarginThreshold ; set rmarginThreshold 20 -global bulleting ; set bulleting {* - # @ ~ %} -global enumeration ; set enumeration {[%] (%) <%>} - -proc Bullet {ivar} { - global bulleting ; upvar $ivar i - set res [lindex $bulleting $i] - set i [expr {($i + 1) % [llength $bulleting]}] - return $res -} - -proc EnumBullet {ivar} { - global enumeration ; upvar $ivar i - set res [lindex $enumeration $i] - set i [expr {($i + 1) % [llength $enumeration]}] - return $res -} - -################################################################ - -# -# The engine maintains several data structures per document and pass. -# Most important is an internal representation of the text better -# suited to perform the final layouting, the display list. Elements of -# the display list are lists containing 2 elements, an operation, and -# its arguments, in this order. The arguments are a list again, its -# contents are specific to the operation. -# -# The operations are: -# -# - SECT Section. Title. -# - PARA Paragraph. Environment reference and text. -# -# The PARA operation is the workhorse of the engine, dooing all the -# formatting, using the information in an "environment" as the guide -# for doing so. The environments themselves are generated during the -# second pass through the contents. They contain the information about -# nesting (i.e. indentation), bulleting and the like. -# - -global cmds ; set cmds [list] ; # Display list -global pEnv ; array set pEnv {} ; # Defined paragraph environments (bulleting, indentation, other). -global para ; set para "" ; # Text buffer for paragraphs. - -global nextId ; set nextId 0 ; # Counter for environment generation. -global currentId ; set currentId {} ; # Id of current environment in 'pEnv' -global currentEnv ; array set currentEnv {} ; # Current environment, expanded form. -global contexts ; set contexts [list] ; # Stack of saved environments. -global off ; set off 1 ; # Supression of plain text in some places. - -################################################################ -# Management of the current context. - -proc Text {text} {global para ; append para $text ; return} -proc Store {op args} {global cmds ; lappend cmds [list $op $args] ; return} -proc Off {} {global off ; set off 1 ; return} -proc On {} {global off para ; set off 0 ; set para "" ; return} -proc IsOff {} {global off ; return [expr {$off == 1}]} - -# Debugging ... -#proc Text {text} {puts_stderr "TXT \{$text\}"; global para; append para $text ; return} -#proc Store {op args} {puts_stderr "STO $op $args"; global cmds; lappend cmds [list $op $args]; return} -#proc Off {} {puts_stderr OFF ; global off ; set off 1 ; return} -#proc On {} {puts_stderr ON_ ; global off para ; set off 0 ; set para "" ; return} - - -proc NewEnv {name script} { - global currentId nextId currentEnv - - #puts_stderr "NewEnv ($name)" - - set parentId $currentId - set currentId $nextId - incr nextId - - append currentEnv(NAME) -$parentId-$name - set currentEnv(parent) $parentId - set currentEnv(id) $currentId - - # Always squash a verbatim environment inherited from the previous - # environment ... - catch {unset currentEnv(verbenv)} - - uplevel $script - SaveEnv - return $currentId -} - -################################################################ - -proc TextInitialize {} { - global off ; set off 1 - global cmds ; set cmds [list] ; # Display list - global pEnv ; array set pEnv {} ; # Defined paragraph environments (bulleting, indentation, other). - global para ; set para "" ; # Text buffer for paragraphs. - - global nextId ; set nextId 0 ; # Counter for environment generation. - global currentId ; set currentId {} ; # Id of current environment in 'pEnv' - global currentEnv ; array set currentEnv {} ; # Current environment, expanded form. - global contexts ; set contexts [list] ; # Stack of saved environments. - - # lmargin = location of left margin for text. - # prefix = prefix string to use for all lines. - # wspfx = whitespace prefix for all but the first line - # listtype = type of list, if any - # bullet = bullet to use for unordered, bullet template for ordered. - # verbatim = flag if verbatim formatting requested. - # next = if present the environment to use after closing the paragraph using this one. - - NewEnv Base { - array set currentEnv { - lmargin 0 - prefix {} - wspfx {} - listtype {} - bullet {} - verbatim 0 - bulleting 0 - enumeration 0 - } - } - return -} - -################################################################ - -proc Section {name} {Store SECT $name ; return} - -proc CloseParagraph {{id {}}} { - global para currentId - if {$para != {}} { - if {$id == {}} {set id $currentId} - Store PARA $id $para - #puts_stderr "CloseParagraph $id" - } - set para "" - return -} - -proc SaveContext {} { - global contexts currentId - lappend contexts $currentId - - #global currentEnv ; puts_stderr "Save>> $currentId ($currentEnv(NAME))" - return -} - -proc RestoreContext {} { - global contexts - SetContext [lindex $contexts end] - set contexts [lrange $contexts 0 end-1] - - #global currentId currentEnv ; puts_stderr "<>" - - if {[IsOff]} {return} - - # Note: Whenever we get plain text it is possible that a macro for - # visual markup actually generated output before the expander got - # to the current text. This output was captured by the expander in - # its current context. Given the current organization of the - # engine we have to retrieve this formatted text from the expander - # or it will be lost. This is the purpose of the 'ctopandclear', - # which retrieves the data and also clears the capture buffer. The - # latter to prevent us from retrieving it agasin later, after the - # next macro added more data. - - set text [ex_ctopandclear]$text - - # ... TODO ... Handling of example => verbatim - - if {[string length [string trim $text]] == 0} return - - Text $text - return -} - -################################################################ - -proc text_postprocess {text} { - - #puts_stderr XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - #puts_stderr <<$text>> - #puts_stderr XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - global cmds - # The argument is not relevant. Access the display list, perform - # the final layouting and return its result. - - set linebuffer [list] - array set state {lmargin 0 rmargin 0} - foreach cmd $cmds { - foreach {op arguments} $cmd break - $op $arguments - } - - #puts_stderr XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - return [join $linebuffer \n] -} - - -proc SECT {text} { - upvar linebuffer linebuffer - #puts_stderr "SECT $text" - #puts_stderr "" - - # Write section title, underline it - - lappend linebuffer "" - lappend linebuffer $text - lappend linebuffer [textutil::strRepeat = [string length $text]] - return -} - -proc PARA {arguments} { - global pEnv - upvar linebuffer linebuffer - - foreach {env text} $arguments break - array set para $pEnv($env) - - #puts_stderr "PARA $env" - #parray_stderr para - #puts_stderr " \{$text\}" - #puts_stderr "" - - # Use the information in the referenced environment to format the paragraph. - - if {$para(verbatim)} { - set text [textutil::undent $text] - } else { - # The size is determined through the set left and right margins - # right margin is fixed at 80, left margin is variable. Size - # is at least 20. I.e. when left margin > 60 right margin is - # shifted out to the right. - - set size [expr {80 - $para(lmargin)}] - if {$size < 20} {set size 20} - - set text [textutil::adjust $text -length $size] - } - - # Now apply prefixes, (ws prefixes bulleting), at last indentation. - - if {[string length $para(prefix)] > 0} { - set text [textutil::indent $text $para(prefix)] - } - - if {$para(listtype) != {}} { - switch -exact $para(listtype) { - bullet { - # Indent for bullet, but not the first line. This is - # prefixed by the bullet itself. - - set thebullet $para(bullet) - } - enum { - # Handling the enumeration counter. Special case: An - # example as first paragraph in an item has to use the - # counter in environment it is derived from to prevent - # miscounting. - - if {[info exists para(example)]} { - set parent $para(parent) - array set __ $pEnv($parent) - if {![info exists __(counter)]} { - set __(counter) 1 - } else { - incr __(counter) - } - set pEnv($parent) [array get __] ; # Save context change ... - set n $__(counter) - } else { - if {![info exists para(counter)]} { - set para(counter) 1 - } else { - incr para(counter) - } - set pEnv($env) [array get para] ; # Save context change ... - set n $para(counter) - } - - set thebullet [string map [list % $n] $para(bullet)] - } - } - - set blen [string length $thebullet] - if {$blen >= [string length $para(wspfx)]} { - set text "$thebullet\n[textutil::indent $text $para(wspfx)]" - } else { - set fprefix $thebullet[string range $para(wspfx) $blen end] - set text "${fprefix}[textutil::indent $text $para(wspfx) 1]" - } - } - - if {$para(lmargin) > 0} { - set text [textutil::indent $text [textutil::strRepeat " " $para(lmargin)]] - } - - lappend linebuffer "" - lappend linebuffer $text - return -} - -################################################################ - -proc strong {text} {return *${text}*} -proc em {text} {return _${text}_} - -################################################################ - -proc parray_stderr {a {pattern *}} { - upvar 1 $a array - if {![array exists array]} { - error "\"$a\" isn't an array" - } - set maxl 0 - foreach name [lsort [array names array $pattern]] { - if {[string length $name] > $maxl} { - set maxl [string length $name] - } - } - set maxl [expr {$maxl + [string length $a] + 2}] - foreach name [lsort [array names array $pattern]] { - set nameString [format %s(%s) $a $name] - puts_stderr " [format "%-*s = {%s}" $maxl $nameString $array($name)]" - } -} - -################################################################ DELETED modules/doctools/mpformats/_toc_common.tcl Index: modules/doctools/mpformats/_toc_common.tcl ================================================================== --- modules/doctools/mpformats/_toc_common.tcl +++ /dev/null @@ -1,31 +0,0 @@ -# -*- tcl -*- -# -# _toc_common.tcl -# -# (c) 2003 Andreas Kupries - -################################################################ -# The code here contains general definitions for API functions and -# state information. They are used by several formatters to simplify -# their own code. - -proc toc_initialize {} {return} -proc toc_shutdown {} {return} -proc toc_numpasses {} {return 1} -proc toc_postprocess {text} {return $text} -proc toc_setup {n} {return} -proc toc_listvariables {} {return {}} -proc toc_varset {varname text} {return} - - -proc fmt_plain_text {text} {return $text} - -################################################################ -# Functions made available to the formatter to access the common -# state managed here. - -proc c_provenance {} { - return "Generated by tcllib/doctools/toc with format '[dt_format]'" -} - -################################################################ DELETED modules/doctools/mpformats/_xml.tcl Index: modules/doctools/mpformats/_xml.tcl ================================================================== --- modules/doctools/mpformats/_xml.tcl +++ /dev/null @@ -1,236 +0,0 @@ -# -*- tcl -*- -# -# $Id: _xml.tcl,v 1.7 2003/01/19 07:58:44 andreas_kupries Exp $ -# -# [expand] utilities for generating XML. -# -# Copyright (C) 2001 Joe English . -# Freely redistributable. -# -###################################################################### - - -# Handling XML delimiters in content: -# -# Plain text is initially passed through unescaped; -# internally-generated markup is protected by preceding it with \1. -# The final PostProcess step strips the escape character from -# real markup and replaces markup characters from content -# with entity references. -# - -variable attvalMap { {&} & {<} < {>} > {"} " {'} ' } ; # " -variable markupMap { {&} {\1&} {<} {\1<} {>} {\1>} } -variable finalMap { {\1&} {&} {\1<} {<} {\1>} {>} - {&} & {<} < {>} > } - -proc fmt_postprocess {text} { - variable finalMap - return [string map $finalMap $text] -} - -# markup text -- -# Protect markup characters in $text with \1. -# These will be stripped out in PostProcess. -# -proc markup {text} { - variable markupMap - return [string map $markupMap $text] -} - -# attlist { n1 v1 n2 v2 ... } -- -# Return XML-formatted attribute list. -# Does *not* escape markup -- the result must be passed through -# [markup] before returning it to the expander. -# -proc attlist {nvpairs} { - variable attvalMap - if {[llength $nvpairs] == 1} { set nvpairs [lindex $nvpairs 0] } - set attlist "" - foreach {name value} $nvpairs { - append attlist " $name='[string map $attvalMap $value]'" - } - return $attlist -} - -# startTag gi ?attname attval ... ? -- -# Return start-tag for element $gi with specified attributes. -# -proc startTag {gi args} { - return [markup "<$gi[attlist $args]>"] -} - -# endTag gi -- -# Return end-tag for element $gi. -# -proc endTag {gi} { - return [markup ""] -} - -# emptyElement gi ?attribute value ... ? -# Return empty-element tag. -# -proc emptyElement {gi args} { - return [markup "<$gi[attlist $args]/>"] -} - -# xmlComment text -- -# Return XML comment declaration containing $text. -# NB: if $text includes the sequence "--", it will be mangled. -# -proc xmlComment {text} { - return [markup ""] -} - -# wrap content gi -- -# Returns $content wrapped inside <$gi> ... tags. -# -proc wrap {content gi} { - return "[startTag $gi]${content}[endTag $gi]" -} - -# wrap? content gi -- -# Same as [wrap], but returns an empty string if $content is empty. -# -proc wrap? {content gi} { - if {![string length [string trim $content]]} { return "" } - return "[startTag $gi]${content}[endTag $gi]" -} - -# wrapLines? content gi ? gi... ? -# Same as [wrap?], but separates entries with newlines -# and supports multiple nesting levels. -# -proc wrapLines? {content args} { - if {![string length $content]} { return "" } - foreach gi $args { - set content [join [list [startTag $gi] $content [endTag $gi]] "\n"] - } - return $content -} - -# sequence args -- -# Handy combinator. -# -proc sequence {args} { join $args "\n" } - -###################################################################### -# XML context management. -# - -variable elementStack [list] - -# start gi ?attribute value ... ? -- -# Return start-tag for element $gi -# As a side-effect, pushes $gi onto the element stack. -# -proc start {gi args} { - if {[llength $args] == 1} { set args [lindex $args 0] } - variable elementStack - lappend elementStack $gi - return [startTag $gi $args] -} - -# xmlContext {gi1 ... giN} ?default? -- -# Pops elements off the element stack until one of -# the specified element types is found. -# -# Returns: sequence of end-tags for each element popped. -# -# If none of the specified elements are found, returns -# a start-tag for $default. -# -proc xmlContext {gis {default {}}} { - variable elementStack - set origStack $elementStack - set endTags [list] - while {[llength $elementStack]} { - set current [lindex $elementStack end] - if {[lsearch $gis $current] >= 0} { - return [join $endTags \n] - } - lappend endTags [endTag $current] - set elementStack [lreplace $elementStack end end] - } - # Not found: - set elementStack $origStack - if {![string length $default]} { - set where "[join $elementStack /] - [info level 1]" - puts stderr "Warning: Cannot start context $gis ($where)" - set default [lindex $gis 0] - } - lappend elementStack $default - return [startTag $default] -} - -# end ? gi ? -- -# Generate markup to close element $gi, including end-tags -# for any elements above it on the element stack. -# -# If element name is omitted, closes the current element. -# -proc end {{gi {}}} { - variable elementStack - if {![string length $gi]} { - set gi [lindex $elementStack end] - } - set prefix [xmlContext $gi] - set elementStack [lreplace $elementStack end end] - return [join [list $prefix [endTag $gi]] "\n"] -} - -###################################################################### -# Utilities for multi-pass processing. -# -# Not really XML-related, but I find them handy. -# - -variable PassProcs -variable Buffers - -# pass $passNo procName procArgs { body } -- -# Specifies procedure definition for pass $n. -# -proc pass {pass proc arguments body} { - variable PassProcs - lappend PassProcs($pass) $proc $arguments $body -} - -proc setPassProcs {pass} { - variable PassProcs - foreach {proc args body} $PassProcs($pass) { - proc $proc $args $body - } -} - -# holdBuffers buffer ? buffer ...? -- -# Declare a list of hold buffers, -# to collect data in one pass and output it later. -# -proc holdBuffers {args} { - variable Buffers - foreach arg $args { - set Buffers($arg) [list] - } -} - -# hold buffer text -- -# Append text to named buffer -# -proc hold {buffer entry} { - variable Buffers - lappend Buffers($buffer) $entry - return -} - -# held buffer -- -# Returns current contents of named buffer and empty the buffer. -# -proc held {buffer} { - variable Buffers - set content [join $Buffers($buffer) "\n"] - set Buffers($buffer) [list] - return $content -} - -#*EOF* DELETED modules/doctools/mpformats/c.msg Index: modules/doctools/mpformats/c.msg ================================================================== --- modules/doctools/mpformats/c.msg +++ /dev/null @@ -1,51 +0,0 @@ -# -*- tcl -*- -package require msgcat -namespace import ::msgcat::* - -mcset c end/open/list "End of manpage reached, \[list_end\] missing" -mcset c end/open/example "End of manpage reached, \[example_end\] missing" -mcset c end/open/mp "End of manpage reached, \[manpage_end\] missing" -mcset c mpbegin "Command must be first of manpage" -mcset c hdrcmd "Command not allowed outside of the header section" -mcset c bodycmd "Command not allowed outside of the body of the manpage" -mcset c body "Plain text not allowed outside of the body of the manpage" -mcset c reqcmd "Command not allowed outside of header or requirement section" -mcset c invalidlist "Invalid list type \"@\"" -mcset c nolistcmd "Command not allowed inside of a list" -mcset c nolisthdr "Command not allowed between beginning of a list and its first item" -mcset c nolisttxt "Plain text not allowed between beginning of a list and its first item" -mcset c listcmd "Command not allowed outside of a list" -mcset c deflist "Command restricted to usage in definition lists" -mcset c bulletlist "Command restricted to usage in itemized lists" -mcset c enumlist "Command restricted to usage in enumerated lists" -mcset c examplecmd "Command allowed only to close example section" -mcset c listcmd "Command not allowed outside of a list" -mcset c nodonecmd "Command not allowed after \[manpage_end\]" -mcset c arg_list "Command restricted to usage in argument lists" -mcset c cmd_list "Command restricted to usage in command lists" -mcset c opt_list "Command restricted to usage in option lists" -mcset c tkoption_list "Command restricted to usage in tkoption lists" -mcset c depr_strong "Deprecated command \"%s\".\n\tPlease consider appropriate semantic markup or \[emph\] instead." - -# TOC messages - -mcset c end/open/toc "\[toc_end\] missing." -mcset c toc/plaintext "Plain text beyond whitespace is not allowed." -mcset c toc/begincmd "Command not allowed here." -mcset c toc/endcmd "Command not allowed here." -mcset c toc/titlecmd "Command not allowed here." -mcset c toc/sectcmd "Command not allowed here." -mcset c toc/sectecmd "Command not allowed here." -mcset c toc/itemcmd "Command not allowed here." -mcset c toc/nodonecmd "Command not allowed after \[toc_end\]" - -# IDX messages - -mcset c end/open/idx "\[index_end\] missing." -mcset c idx/plaintext "Plain text beyond whitespace is not allowed." -mcset c idx/begincmd "Command not allowed here." -mcset c idx/endcmd "Command not allowed here." -mcset c idx/keycmd "Command not allowed here." -mcset c idx/manpagecmd "Command not allowed here." -mcset c idx/urlcmd "Command not allowed here." -mcset c idx/nodonecmd "Command not allowed after \[index_end\]" DELETED modules/doctools/mpformats/de.msg Index: modules/doctools/mpformats/de.msg ================================================================== --- modules/doctools/mpformats/de.msg +++ /dev/null @@ -1,47 +0,0 @@ -# -*- tcl -*- -package require msgcat -namespace import ::msgcat::* - -mcset de end/open/list "Dokument zu Ende, nicht alle Listen wurden geschlossen" -mcset de end/open/example "Dokument zu Ende, das letzte Beispiel wurde nicht abgeschlossen" -mcset de end/open/mp "Dokument zu Ende, es fehlt der Abschlussbefehl \[manpage_end\]" -mcset de mpbegin "Erwartete diesen Befehl als ersten in der Manpage" -mcset de hdrcmd "Dieser Befehl ist ausserhalb des Headers nicht erlaubt" -mcset de bodycmd "Dieser Befehl darf nicht ausserhalb des Hauptteils der Manpage auftreten" -mcset de body "Text darf nicht ausserhalb des Hauptteils der Manpage auftreten" -mcset de reqcmd "Dieser Befehl ist ausserhalb von Header/Requirements nicht erlaubt" -mcset de invalidlist "Die Listenart \"@\" ist dem System nicht bekannt" -mcset de nolistcmd "Dieser Befehl ist innerhalb einer Liste nicht erlaubt" -mcset de nolisthdr "Dieser Befehl darf nicht zwischen dem Beginn einer Liste und ihrem ersten Unterpunkt benutzt werden" -mcset de nolisttxt "Text darf nicht zwischen dem Beginn einer Liste und ihrem ersten Unterpunkt benutzt werden" -mcset de listcmd "Dieser Befehl ist ausserhalb einer Liste nicht erlaubt" -mcset de deflist "Dieser Befehl darf nur in Definitions-Listen benutzt werden" -mcset de bulletlist "Dieser Befehl darf nur in ungeordneten Listen benutzt werden" -mcset de enumlist "Dieser Befehl darf nur in Aufzaehlungs-Listen benutzt werden" -mcset de examplecmd "Dieser Befehl kann nur zum Schliessen eines Beispieles benutzt werden" -mcset de listcmd "Dieser Befehl ist ausserhalb einer Liste nicht erlaubt" -mcset de nodonecmd "Dieser Befehl ist nach Ausfuehrung von \[manpage_end\] nicht mehr erlaubt" -mcset de arg_list "Dieser Befehl darf nur in Argument-Listen benutzt werden" -mcset de cmd_list "Dieser Befehl darf nur in Befehls-Listen benutzt werden" -mcset de opt_list "Dieser Befehl darf nur in Options-Listen benutzt werden" -mcset de tkoption_list "Dieser Befehl darf nur in TkOptions-Listen benutzt werden" -mcset de depr_strong "Misbilligter Befehl \"%s\".\n\tBitte verwenden sie \[emph\] oder eine passende semantische Auszeichnung." - -mcset de end/open/toc "\[toc_end\] fehlt." -mcset de toc/plaintext "Normaler Text ist (mit Ausnahme von reinem Leerraum) nicht erlaubt." -mcset de toc/begincmd "Dieser Befehl ist hier nicht erlaubt." -mcset de toc/endcmd "Dieser Befehl ist hier nicht erlaubt." -mcset de toc/titlecmd "Dieser Befehl ist hier nicht erlaubt." -mcset de toc/sectcmd "Dieser Befehl ist hier nicht erlaubt." -mcset de toc/sectecmd "Dieser Befehl ist hier nicht erlaubt." -mcset de toc/itemcmd "Dieser Befehl ist hier nicht erlaubt." -mcset de toc/nodonecmd "Dieser Befehl ist nach \[toc_end\] nicht erlaubt." - -mcset de end/open/idx "\[index_end\] fehlt." -mcset de idx/plaintext "Normaler Text ist (mit Ausnahme von reinem Leerraum) nicht erlaubt." -mcset de idx/begincmd "Dieser Befehl ist hier nicht erlaubt." -mcset de idx/endcmd "Dieser Befehl ist hier nicht erlaubt." -mcset de idx/keycmd "Dieser Befehl ist hier nicht erlaubt." -mcset de idx/manpagecmd "Dieser Befehl ist hier nicht erlaubt." -mcset de idx/urlcmd "Dieser Befehl ist hier nicht erlaubt." -mcset de idx/nodonecmd "Dieser Befehl ist nach \[index_end\] nicht erlaubt." DELETED modules/doctools/mpformats/en.msg Index: modules/doctools/mpformats/en.msg ================================================================== --- modules/doctools/mpformats/en.msg +++ /dev/null @@ -1,47 +0,0 @@ -# -*- tcl -*- -package require msgcat -namespace import ::msgcat::* - -mcset en end/open/list "End of manpage reached, \[list_end\] missing" -mcset en end/open/example "End of manpage reached, \[example_end\] missing" -mcset en end/open/mp "End of manpage reached, \[manpage_end\] missing" -mcset en mpbegin "Command must be first of manpage" -mcset en hdrcmd "Command not allowed outside of the header section" -mcset en bodycmd "Command not allowed outside of the body of the manpage" -mcset en body "Plain text not allowed outside of the body of the manpage" -mcset en reqcmd "Command not allowed outside of header or requirement section" -mcset en invalidlist "Invalid list type \"@\"" -mcset en nolistcmd "Command not allowed inside of a list" -mcset en nolisthdr "Command not allowed between beginning of a list and its first item" -mcset en nolisttxt "Plain text not allowed between beginning of a list and its first item" -mcset en listcmd "Command not allowed outside of a list" -mcset en deflist "Command restricted to usage in definition lists" -mcset en bulletlist "Command restricted to usage in itemized lists" -mcset en enumlist "Command restricted to usage in enumerated lists" -mcset en examplecmd "Command allowed only to close example section" -mcset en listcmd "Command not allowed outside of a list" -mcset en nodonecmd "Command not allowed after \[manpage_end\]" -mcset en arg_list "Command restricted to usage in argument lists" -mcset en cmd_list "Command restricted to usage in command lists" -mcset en opt_list "Command restricted to usage in option lists" -mcset en tkoption_list "Command restricted to usage in tkoption lists" -mcset en depr_strong "Deprecated command \"%s\".\n\tPlease consider appropriate semantic markup or \[emph\] instead." - -mcset en end/open/toc "\[toc_end\] missing." -mcset en toc/plaintext "Plain text beyond whitespace is not allowed." -mcset en toc/begincmd "Command not allowed here." -mcset en toc/endcmd "Command not allowed here." -mcset en toc/titlecmd "Command not allowed here." -mcset en toc/sectcmd "Command not allowed here." -mcset en toc/sectecmd "Command not allowed here." -mcset en toc/itemcmd "Command not allowed here." -mcset en toc/nodonecmd "Command not allowed after \[toc_end\]" - -mcset en end/open/idx "\[index_end\] missing." -mcset en idx/plaintext "Plain text beyond whitespace is not allowed." -mcset en idx/begincmd "Command not allowed here." -mcset en idx/endcmd "Command not allowed here." -mcset en idx/keycmd "Command not allowed here." -mcset en idx/manpagecmd "Command not allowed here." -mcset en idx/urlcmd "Command not allowed here." -mcset en idx/nodonecmd "Command not allowed after \[index_end\]" DELETED modules/doctools/mpformats/fmt.html Index: modules/doctools/mpformats/fmt.html ================================================================== --- modules/doctools/mpformats/fmt.html +++ /dev/null @@ -1,408 +0,0 @@ -# -*- tcl -*- -# -# fmt.html -# -# Copyright (c) 2001-2003 Andreas Kupries -# -# Definitions to convert a tcl based manpage definition into -# a manpage based upon HTML markup. -# -################################################################ -################################################################ - -dt_source _common.tcl ; # Shared code -dt_source _html.tcl ; # HTML basic formatting - -proc c_copyrightsymbol {} {markup "©"} - -proc bgcolor {} {return ""} -proc border {} {return 0} -proc Year {} {clock format [clock seconds] -format %Y} - -# possibleReference text gi -- -# Check if $text is a potential cross-reference; -# if so, format as a reference; -# otherwise format as a $gi element. -# -proc c_possibleReference {text gi} { - global SectionNames - if {[info exists SectionNames($text)]} { - return [taga a [list href #$SectionNames($text)]]$text[tag/ a] - } else { - return [tag $gi]$text[tag/ $gi] - } -} - -c_holdBuffers require - -################################################################ -## Backend for HTML markup - -# -------------------------------------------------------------- -# Handling of lists. Simplified, the global check of nesting and -# legality of list commands allows us to throw away most of the -# existing checks. - -global liststack ; # stack of list tags to use in list_end -global hintstack ; # stack of hint information. -global chint ; # current hint settings -global lmark ; # boolean flag, 1 = list item command was last -# ; # 0 = something other than a list item command - -set liststack [list] -set hintstack [list] -set chint "" -set lmark 0 - -proc llevel {} {global liststack ; return [llength $liststack]} - -proc lpush {t hint} { - global liststack hintstack chint - lappend liststack [tag/ $t] - lappend hintstack $chint - set chint $hint - return [tag $t] -} - -proc lpop {} { - global liststack hintstack chint - set t [lindex $liststack end] - set liststack [lreplace $liststack end end] - set chint [lindex $hintstack end] - set hintstack [lreplace $hintstack end end] - return $t -} - -proc lsmark {value} { - global lmark ; set lmark $value ; return -} - -proc limark {} { - # hint and mark processing. - # hint: compact list, do not create additional whitespace - if {[lcompact]} {return ""} - - # hint: wide list, create additional whitespace. - # mark: exception: two list items following each other have no whitespace. - global lmark ; if {$lmark} {return ""} - return [tag br][tag br]\n -} - -proc lcompact {} {global chint ; string equal $chint compact} - -proc fmt_plain_text {text} { - # Control list state - set redux [string map [list " " "" "\t" "" "\n" ""] $text] - if {$redux != {}} {lsmark 0} - return $text -} - -################################################################ -# Formatting commands. - -c_pass 1 fmt_manpage_begin {title section version} {c_cinit ; return} -c_pass 2 fmt_manpage_begin {title section version} { - c_cinit - set module [dt_module] - set shortdesc [c_get_module] - set description [c_get_title] - set copyright [c_get_copyright] - - set hdr "" - append hdr "[markup ]\n" - append hdr "[markup ]$title - $shortdesc [markup ]\n" - - # Engine parameter - insert 'meta' - if {[set meta [Get meta]] != {}} {append hdr [markup $meta]\n} - - append hdr "[markup ]\n" - append hdr [ht_comment [c_provenance]]\n - if {$copyright != {}} { - append hdr [ht_comment $copyright]\n - } - append hdr [ht_comment "CVS: \$Id\$ $title.$section"]\n - append hdr \n - append hdr [markup ]\n - - # Engine parameter - insert 'header' - if {[set header [Get header]] != {}} {append hdr [markup $header]\n} - - append hdr "[markup

] [string trimleft $title :]($section) $version $module \"$shortdesc\"[markup

]\n" - append hdr [fmt_section NAME]\n - append hdr "[fmt_para] $title - $description" - return $hdr -} - -c_pass 1 fmt_moddesc {desc} {c_set_module $desc} -c_pass 2 fmt_moddesc {desc} NOP - -c_pass 1 fmt_titledesc {desc} {c_set_title $desc} -c_pass 2 fmt_titledesc {desc} NOP - -c_pass 1 fmt_copyright {desc} {c_set_copyright $desc} -c_pass 2 fmt_copyright {desc} NOP - -c_pass 1 fmt_manpage_end {} {c_creset ; return} -c_pass 2 fmt_manpage_end {} { - c_creset - set res "" - - set sa [c_xref_seealso] - set kw [c_xref_keywords] - set ct [c_get_copyright] - - if {[llength $sa] > 0} { - append res [fmt_section {SEE ALSO}] \n - append res [join [XrefList [lsort $sa] sa] ", "] \n - } - if {[llength $kw] > 0} { - append res [fmt_section KEYWORDS] \n - append res [join [XrefList [lsort $kw] kw] ", "] \n - } - if {$ct != {}} { - append res [fmt_section COPYRIGHT] \n - append res [join [split $ct \n] [tag br]\n] [tag br]\n - } - - # Engine parameter - insert 'footer' - if {[set footer [Get footer]] != {}} {append res [markup $footer]\n} - - append res [markup ] - return $res -} - -c_pass 1 fmt_section {name} { set ::SectionNames($name) [c_sectionId $name] } -c_pass 2 fmt_section {name} { - set id [c_sectionId $name] - return "[markup

<]a name=[markup \"]$id[markup \">]$name[markup

\n

]" -} - -proc fmt_para {} {return [markup

]} - -c_pass 2 fmt_require {pkg {version {}}} NOP -c_pass 1 fmt_require {pkg {version {}}} { - set result "package require [markup ]$pkg" - if {$version != {}} { - append result " $version" - } - append result [markup "
"] - c_hold require $result - return -} - -c_pass 2 fmt_usage {cmd args} NOP -c_pass 1 fmt_usage {cmd args} {c_hold synopsis "[trtop][td]$cmd [join $args " "][markup ]"} - -c_pass 1 fmt_call {cmd args} { - c_hold synopsis "[trtop][td][markup ""]$cmd [join $args " "][markup ]" -} -c_pass 2 fmt_call {cmd args} { - return "[fmt_lst_item "[markup ""]$cmd [join $args " "][markup ]"]\n" -} - -c_pass 1 fmt_description {} NOP -c_pass 2 fmt_description {} { - set result "" - set syn [c_held synopsis] - set req [c_held require] - if {$syn != {} || $req != {}} { - append result [fmt_section SYNOPSIS]\n - } - if {$req != {}} { - append result $req \n - append result [markup
] - } - if {$syn != {}} { - proc bgcolor {} {return lightyellow} - - append result [btable][tr][td][table]${syn}\n[markup

]\n - - proc bgcolor {} {return ""} - } - append result [fmt_section DESCRIPTION] - return $result -} - -################################################################ - -proc fmt_list_begin {what {hint {}}} { - switch -exact -- $what { - enum {set tag ol} - bullet {set tag ul} - arg - cmd - opt - tkoption - - definitions {set tag dl} - } - return [if {[llevel]} {limark} else {}][lpush $tag $hint][lsmark 1] -} - -proc fmt_list_end {} {return [lpop][lsmark 1]} -proc fmt_lst_item {text} {return [limark][tag dt]$text[tag dd][lsmark 1]} -proc fmt_bullet {} {return [limark][tag li][lsmark 1]} -proc fmt_enum {} {return [limark][tag li][lsmark 1]} -proc fmt_cmd_def {command} {fmt_lst_item [cmd $command]} - -proc fmt_arg_def {type name {mode {}}} { - set text "" - append text "$type [fmt_arg $name]" - if {$mode != {}} { - append text " ($mode)" - } - fmt_lst_item $text -} -proc fmt_opt_def {name {arg {}}} { - set text [fmt_option $name] - if {$arg != {}} {append text " $arg"} - fmt_lst_item $text -} -proc fmt_tkoption_def {name dbname dbclass} { - set text "" - append text "Command-Line Switch:\t[fmt_option $name][markup
]\n" - append text "Database Name:\t[strong $dbname][markup
]\n" - append text "Database Class:\t[strong $dbclass][markup
]\n" - fmt_lst_item $text -} - - -################################################################ - -proc fmt_example_begin {} { - lsmark 0 - return [markup "

 
"]
-}
-proc fmt_example_end   {} {
-    return [markup "

"] -} -proc fmt_example {code} { - return "[fmt_example_begin][fmt_plain_text $code][fmt_example_end]" -} - -proc fmt_nl {} { - if {[lcompact]} {return [tag br]} - return [tag br][tag br] -} -proc fmt_arg {text} {return "[markup ""]$text[markup ]" } -proc fmt_cmd {text} {return "[markup ""][XrefMatch $text sa][markup ]" } - -proc fmt_emph {text} { em $text } - -proc strong {text} {return "[markup ]$text[markup ]"} -proc em {text} {return "[markup ]$text[markup ]"} - - -proc fmt_opt {text} {return "?$text?" } -proc fmt_comment {text} {ht_comment $text} -proc fmt_sectref {text} { - global SectionNames - if {[info exists SectionNames($text)]} { - return "[markup <]a href=[markup \"]#$SectionNames($text)[markup \">]$text[markup ]" - } else { - return "[markup ]$text[markup ]" - } -} -proc fmt_syscmd {text} {strong [XrefMatch $text sa]} -proc fmt_method {text} {strong $text} -proc fmt_option {text} {strong $text} -proc fmt_widget {text} {strong $text} -proc fmt_fun {text} {strong $text} -proc fmt_type {text} {strong $text} -proc fmt_package {text} {strong $text} -proc fmt_class {text} {strong $text} -proc fmt_var {text} {strong $text} -proc fmt_file {text} {return "\"[strong $text]\""} -proc fmt_uri {text} {return "[markup <]a href=[markup \"]$text[markup \">]$text[markup ]"} -proc fmt_term {text} {em [XrefMatch $text kw]} -proc fmt_const {text} {strong $text} - -################################################################ - -global xref ; array set xref {} - -global __var -array set __var { - meta {} - header {} - footer {} - xref {} -} -proc Get {varname} {global __var ; return $__var($varname)} -proc fmt_listvariables {} {global __var ; return [array names __var]} -proc fmt_varset {varname text} { - global __var - if {![info exists __var($varname)]} {return -code error "Unknown engine variable \"$varname\""} - set __var($varname) $text - return -} - -################################################################ - -proc XrefInit {} { - global xref __var - foreach item $__var(xref) { - foreach {pattern fname fragment} $item break - set fname_ref [dt_fmap $fname] - if {$fragment != {}} {append fname_ref #$fragment} - set xref($pattern) $fname_ref - } - proc XrefInit {} {} - return -} - -proc XrefMatch {word ext} { - global xref - - #puts_stderr "$word $ext" - #foreach {k v} [array get xref] {puts_stderr "$k\t $v"} - - if {$ext != {}} { - if {[info exists xref($ext,$word)]} { - return [XrefLink $xref($ext,$word) $word] - } - } - if {[info exists xref($word)]} { - return [XrefLink $xref($word) $word] - } - return $word -} - -proc XrefList {list {ext {}}} { - XrefInit - set res [list] - foreach w $list {lappend res [XrefMatch $w $ext]} - return $res -} - -proc XrefLink {dest label} { - # Ensure that the link is properly done relative to this file! - - set save $dest - - #puts_stderr "XrefLink $dest $label" - - set here [file split [dt_fmap [dt_file]]] - set dest [file split $dest] - - #puts_stderr "XrefLink < $here" - #puts_stderr "XrefLink > $dest" - - while {[string equal [lindex $dest 0] [lindex $here 0]]} { - set dest [lrange $dest 1 end] - set here [lrange $here 1 end] - if {[llength $dest] == 0} {break} - } - set ul [llength $dest] - set hl [llength $here] - - if {$ul == 0} { - set dest [lindex [file split $save] end] - } else { - while {$hl > 1} { - set dest [linsert $dest 0 ..] - incr hl -1 - } - set dest [eval file join $dest] - } - - #puts_stderr "XrefLink --> $dest" - - return "[markup ""] $label [markup ]" ; # " -} DELETED modules/doctools/mpformats/fmt.latex Index: modules/doctools/mpformats/fmt.latex ================================================================== --- modules/doctools/mpformats/fmt.latex +++ /dev/null @@ -1,342 +0,0 @@ -# -*- tcl -*- -# -# fmt.latex -# -# (c) 2001 Andreas Kupries -# -# [mpexpand] definitions to convert a tcl based manpage definition into -# a manpage based upon LaTeX markup. -# -################################################################ - -## -## This engine needs a rewrite for a better handling -## of characters special to TeX / LaTeX. -## - -dt_source _common.tcl ; # Shared code - -global _in_example -set _in_example 0 - -# Called to handle plain text from the input -proc fmt_plain_text {text} { - global _in_example - if {$_in_example} { - return $text - } - return [texEscape $text] -} - -proc Year {} {clock format [clock seconds] -format %Y} - -c_holdBuffers require - -################################################################ -## Backend for LaTeX markup - -c_pass 1 fmt_manpage_begin {title section version} NOP -c_pass 2 fmt_manpage_begin {title section version} { - set module [dt_module] - set shortdesc [c_get_module] - set description [c_get_title] - set copyright [c_get_copyright] - - set hdr "" - append hdr [Comment [c_provenance]] \n - if {$copyright != {}} { - append hdr [Comment $copyright] \n - } - append hdr [Comment "CVS: \$Id\$ $title.$section"] \n - append hdr \n - append hdr "\\documentclass\{article\}" \n - append hdr "\\begin\{document\}" \n - append hdr "\\author\{[dt_user]\}" \n - - set titletext "" - append titletext "$module / $title \\\\" - append titletext "$shortdesc : $description" - - append hdr "\\title\{[texEscape $titletext]\}" \n - append hdr "\\maketitle" \n - return $hdr -} - -c_pass 1 fmt_moddesc {desc} {c_set_module $desc} -c_pass 2 fmt_moddesc {desc} NOP - -c_pass 1 fmt_titledesc {desc} {c_set_title $desc} -c_pass 2 fmt_titledesc {desc} NOP - -c_pass 1 fmt_copyright {desc} {c_set_copyright [texEscape $desc]} -c_pass 2 fmt_copyright {desc} NOP - -c_pass 1 fmt_manpage_end {} NOP -c_pass 2 fmt_manpage_end {} { - set res "" - - set sa [c_xref_seealso] - set kw [c_xref_keywords] - set ct [c_get_copyright] - - if {[llength $sa] > 0} { - append res [fmt_section {SEE ALSO}] \n - append res [join [lsort $sa] ", "] \n - } - if {[llength $kw] > 0} { - append res [fmt_section KEYWORDS] \n - append res [join [lsort $kw] ", "] \n - } - if {$ct != {}} { - append res [fmt_section COPYRIGHT] \n - append res \\begin\{flushleft\} \n - append res [join [split $ct \n] \\linebreak\n] \\linebreak\n - append res \\end\{flushleft\} \n - } - append res "\\end\{document\}" - return $res -} - - - -proc fmt_section {name} {return "\\section\{$name\}"} -proc fmt_para {} {return \n\n} - -c_pass 2 fmt_require {pkg {version {}}} NOP -c_pass 1 fmt_require {pkg {version {}}} { - if {$version != {}} { - set res "package require [Bold "$pkg $version"]\n" - } else { - set res "package require [Bold $pkg]\n" - } - c_hold require $res - return -} - -c_pass 2 fmt_usage {cmd args} NOP -c_pass 1 fmt_usage {cmd args} {c_hold synopsis "\\item\[\] $cmd [join $args " "]"} - -c_pass 2 fmt_call {cmd args} {return "[fmt_lst_item "$cmd [join $args " "]"]"} -c_pass 1 fmt_call {cmd args} {c_hold synopsis "\\item\[\] $cmd [join $args " "]"} - -c_pass 1 fmt_description {} NOP -c_pass 2 fmt_description {} { - set res "" - set req [c_held require] - set syn [c_held synopsis] - if {$req != {} || $syn != {}} { - append res [fmt_section SYNOPSIS]\n - if {$req != {}} { - append res \\begin\{flushleft\} \n - append res $req \n - append res \\end\{flushleft\} \n - } - if {$syn != {}} { - append res "\\begin\{itemize\}" \n - append res ${syn} \n\n - append res "\\end\{itemize\}" \n - } - } - append res [fmt_section DESCRIPTION] - return $res -} - -################################################################ - -global list_state -array set list_state {level -1} - -proc fmt_list_begin {what {hint {}}} { - # ignoring hints - global list_state - incr list_state(level) - set list_state(l,$list_state(level)) $what - set list_state(l,$list_state(level),item) 0 - - switch -exact -- $what { - enum { - return \\begin\{enumerate\} - } - bullet - arg - opt - cmd - tkoption - definitions { - return \\begin\{itemize\} - } - default { - return -code error "Must not happen" - } - } -} - -proc fmt_list_end {} { - global list_state - - set what $list_state(l,$list_state(level)) - set item $list_state(l,$list_state(level),item) - - catch {unset list_state(l,$list_state(level))} - catch {unset list_state(l,$list_state(level),item)} - - incr list_state(level) -1 - - switch -exact -- $what { - enum { - return \\end\{enumerate\} - } - bullet { - return \\end\{itemize\} - } - definitions - arg - opt - cmd - tkoption { - if {$item} { - return \\end\{quote\}\n\\end\{itemize\} - } else { - return \\end\{itemize\} - } - } - default { - return -code error "Must not happen" - } - } -} - -proc fmt_bullet {} {return "\\item\n"} -proc fmt_enum {} {return "\\item\n"} - -proc fmt_lst_item {text} { - global list_state - - set item $list_state(l,$list_state(level),item) - set list_state(l,$list_state(level),item) 1 - - ## set text [texEscape $text] - if {$item} { - return "\\end\{quote\}\n\\item\[\] $text\n\\begin\{quote\}\n" - } else { - return "\\item\[\] $text\n\\begin\{quote\}\n" - } -} - -proc fmt_arg_def {type name {mode {}}} { - global list_state - - set item $list_state(l,$list_state(level),item) - set list_state(l,$list_state(level),item) 1 - - set text "" - append text [fmt_arg $name] - append text " $type" - if {$mode != {}} {append text " ($mode)"} - - if {$item} { - return "\\end\{quote\}\n\\item\[\] $text\n\\begin\{quote\}\n" - } else { - return "\\item\[\] $text\n\\begin\{quote\}\n" - } -} - -proc fmt_cmd_def {command} { - global list_state - - set item $list_state(l,$list_state(level),item) - set list_state(l,$list_state(level),item) 1 - - set text [fmt_cmd $command] - - if {$item} { - return "\\end\{quote\}\n\\item\[\] $text\n\\begin\{quote\}\n" - } else { - return "\\item\[\] $text\n\\begin\{quote\}\n" - } -} - -proc fmt_opt_def {name {arg {}}} { - global list_state - - set item $list_state(l,$list_state(level),item) - set list_state(l,$list_state(level),item) 1 - - set text [fmt_option $name] - if {$arg != {}} {append text " $arg"} - - if {$item} { - return "\\end\{quote\}\n\\item\[\] $text\n\\begin\{quote\}\n" - } else { - return "\\item\[\] $text\n\\begin\{quote\}\n" - } -} - -proc fmt_tkoption_def {name dbname dbclass} { - global list_state - - set item $list_state(l,$list_state(level),item) - set list_state(l,$list_state(level),item) 1 - - set text "" - append text "Command-Line Switch: [Bold $name]\\\\\n" - append text "Database Name: [Bold $dbname]\\\\\n" - append text "Database Class: [Bold $dbclass]\\\\\n" - - if {$item} { - return "\\end\{quote\}\n\\item\[\] $text\n\\begin\{quote\}\n" - } else { - return "\\item\[\] $text\n\\begin\{quote\}\n" - } -} - -################################################################ - -proc fmt_example_begin {} { - global _in_example - set _in_example 1 - return {\begin{verbatim}} -} -proc fmt_example_end {} { - global _in_example - set _in_example 0 - return {\end{verbatim}} -} -# No mapping of special characters -proc fmt_example {code} { return "\\begin\{verbatim\}\n${code}\n\\end\{verbatim\}\n" } - -proc fmt_nl {} {return} -proc fmt_arg {text} {Underline $text} -proc fmt_cmd {text} {Bold $text} -proc fmt_emph {text} {Italic $text} -proc fmt_opt {text} {return ?$text?} - -proc fmt_comment {text} { - set res [list] - foreach l [split $text \n] { - lappend res [Comment $l] - } - return [join $res \n] -} -proc fmt_sectref {text} {Bold $text} -proc fmt_syscmd {text} {Bold $text} -proc fmt_method {text} {Bold $text} -proc fmt_option {text} {Bold $text} -proc fmt_widget {text} {Bold $text} -proc fmt_fun {text} {Bold $text} -proc fmt_type {text} {Bold $text} -proc fmt_package {text} {Bold $text} -proc fmt_class {text} {Bold $text} -proc fmt_var {text} {Bold $text} -proc fmt_file {text} {return "\"[Italic $text]\""} -proc fmt_uri {text} {Underline $text} -proc fmt_term {text} {Italic $text} -proc fmt_const {text} {Bold $text} - - -################################################################ -# latex specific commands - -proc Comment {text} {return "% [join [split $text \n] "\n% "]"} -proc Bold {text} {return "\{\\bf [texEscape $text]\}"} -proc Italic {text} {return "\{\\it [texEscape $text]\}"} -proc Underline {text} {return "\\underline\{[texEscape $text]\}"} - -################################################################ - -proc texEscape {text} { - string map {_ \\_ % \\% $ \\$ < $<$ > $>$ # \\# & \\&} $text -} - -################################################################ DELETED modules/doctools/mpformats/fmt.list Index: modules/doctools/mpformats/fmt.list ================================================================== --- modules/doctools/mpformats/fmt.list +++ /dev/null @@ -1,50 +0,0 @@ -# -*- tcl -*- -# -# -- Extraction of basic meta information (title section version) from a manpage. -# -# Copyright (c) 2001-2002 Andreas Kupries -# Copyright (c) 2003 Andreas Kupries -# -################################################################ - -# Take the null format as a base and extend it a bit. -dt_source fmt.null - -global data -array set data {} - -proc fmt_numpasses {} {return 1} -proc fmt_postprocess {text} { - global data - foreach key {seealso keywords} { - array set _ {} - foreach ref $data($key) {set _($ref) .} - set data($key) [array names _] - unset _ - } - return [list manpage [array get data]]\n -} -proc fmt_plain_text {text} {return ""} -proc fmt_setup {n} {return} - -proc fmt_manpage_begin {title section version} { - global data - set data(title) $title - set data(section) $section - set data(version) $version - set data(file) [dt_file] - set data(fid) [dt_fileid] - set data(module) [dt_module] - set data(desc) "" - set data(shortdesc) "" - set data(keywords) [list] - set data(seealso) [list] - return -} - -proc fmt_moddesc {desc} {global data ; set data(shortdesc) $desc} -proc fmt_titledesc {desc} {global data ; set data(desc) $desc} -proc fmt_keywords {args} {global data ; foreach ref $args {lappend data(keywords) $ref} ; return} -proc fmt_see_also {args} {global data ; foreach ref $args {lappend data(seealso) $ref} ; return} - -################################################################ DELETED modules/doctools/mpformats/fmt.nroff Index: modules/doctools/mpformats/fmt.nroff ================================================================== --- modules/doctools/mpformats/fmt.nroff +++ /dev/null @@ -1,222 +0,0 @@ -# -*- tcl -*- -# -# -- doctools NROFF formatting engine. -# -# Copyright (c) 2001-2003 Andreas Kupries -# -# [expand] definitions to convert a tcl based manpage definition into -# a manpage based upon *roff markup. Additional definition files allow -# the conversion into HTML and TMML. - - -################################################################ -# Load shared code, load nroff support. - -dt_source _common.tcl -dt_source _nroff.tcl - -################################################################ -# Define the API commands. - -c_pass 1 fmt_manpage_begin {title section version} c_begin -c_pass 2 fmt_manpage_begin {title section version} { - c_begin - - set module [dt_module] - set shortdesc [c_get_module] - set description [c_get_title] - set copyright [c_get_copyright] - - c_holdBuffers hdr - - c_hold hdr [nr_comment {}] - c_hold hdr [nr_comment [c_provenance]] - if {$copyright != {}} { - c_hold hdr [nr_comment $copyright] - } - c_hold hdr [nr_comment {}] - - if {[set text [c_held precomments]] != {}} { - c_hold hdr $text - } - - c_hold hdr [nr_include man.macros] - c_hold hdr [nr_title "\"[string trimleft $title :]\" $section $version $module \"$shortdesc\""] - c_hold hdr [nr_bolds] - c_hold hdr [fmt_section NAME] - c_hold hdr "$title \\- $description" - - return [c_held hdr] -} - -c_pass 1 fmt_moddesc {desc} {c_set_module $desc} -c_pass 2 fmt_moddesc {desc} NOP - -c_pass 1 fmt_titledesc {desc} {c_set_title $desc} -c_pass 2 fmt_titledesc {desc} NOP - -c_pass 1 fmt_copyright {desc} {c_set_copyright $desc} -c_pass 2 fmt_copyright {desc} NOP - -c_pass 1 fmt_manpage_end {} NOP -c_pass 2 fmt_manpage_end {} { - - # Complete the generation with a copyright - # section, if such information is available. - - set nroff "" - - set sa [c_xref_seealso] - set kw [c_xref_keywords] - set ct [c_get_copyright] - - if {[llength $sa] > 0} { - append nroff [fmt_section {SEE ALSO}] \n - append nroff [join [lsort $sa] ", "] \n - } - if {[llength $kw] > 0} { - append nroff [fmt_section KEYWORDS] \n - append nroff [join [lsort $kw] ", "] \n - } - if {$ct != {}} { - append nroff [fmt_section COPYRIGHT] \n - append nroff [nr_nofill] \n - append nroff $ct \n - append nroff [nr_fill] - } - return $nroff -} - -proc fmt_postprocess {nroff} {return [nroff_postprocess $nroff]} - -proc fmt_section {name} {return [nr_section $name]} -proc fmt_para {} {nr_p} - -c_pass 2 fmt_require {pkg {version {}}} NOP -c_pass 1 fmt_require {pkg {version {}}} { - if {$version != {}} {set version " $version"} - c_hold synopsis "package require [nr_bld]$pkg $version[nr_rst]\n[fmt_nl]" -} - -c_pass 1 fmt_usage {cmd args} {c_hold synopsis "$cmd [join $args " "][nr_rst]\n[fmt_nl]"} -c_pass 2 fmt_usage {cmd args} NOP - -c_pass 1 fmt_call {cmd args} {c_hold synopsis "$cmd [join $args " "][nr_rst]\n[fmt_nl]"} -c_pass 2 fmt_call {cmd args} {return "[fmt_lst_item "$cmd [join $args " "][nr_rst]"]"} - -c_pass 1 fmt_description {} NOP -c_pass 2 fmt_description {} { - set text "" - if {[set syn [c_held synopsis]] != {}} { - append text [fmt_section SYNOPSIS]\n - append text ${syn}\n - append text [nr_bolde]\n - } - append text [fmt_section DESCRIPTION] - return $text -} - -################################################################ - -global list_state -array set list_state {level -1} - -proc fmt_list_begin {what {hint {}}} { - c_cinit - if {[dt_lnesting] > 1} { - return [nr_in] - } - return {} -} - -proc fmt_list_end {} { - c_creset - if {[dt_lnesting] > 0} { - return [nr_out] - } - return {} -} - -proc fmt_enum {} {return [nr_item " \[[c_cnext]\]\n"]} -proc fmt_bullet {} {return [nr_item " \\(bu"]} -proc fmt_lst_item {text} {return [nr_blt $text]} -proc fmt_cmd_def {command} {return [nr_blt [cmd $command]]} - -proc fmt_arg_def {type name {mode {}}} { - set text [nr_blt ""] - append text [arg $name] - append text " $type" - if {$mode != {}} {append text " ($mode)"} - return $text -} -proc fmt_opt_def {name {arg {}}} { - if {[string match -* $name]} {set name \\-$name} - set name [option $name] - if {$arg != {}} {append name " $arg"} - return [nr_blt $name] -} -proc fmt_tkoption_def {name dbname dbclass} { - set text "" - append text "[nr_lp]\n" - append text "[nr_nofill]\n" - append text "[nr_ta " 6c"]\n" - append text "Command-Line Switch:\t[bold $name]\n" - append text "Database Name:\t[bold $dbname]\n" - append text "Database Class:\t[bold $dbclass]\n" - append text "[nr_fill]\n" - append text "[nr_item]\n" - return $text -} - -################################################################ - -proc fmt_example_begin {} { return "\n[nr_nofill]" } -proc fmt_example_end {} { nr_fill } -proc fmt_example {code} { - set lines [list "" [nr_nofill]] - foreach line [split $code "\n"] { - lappend lines [fmt_plain_text $line] - } - lappend lines [nr_fill] "" - return [join $lines "\n"] -} - -proc fmt_nl {} {nr_vspace} -proc fmt_arg {text} {underline $text} -proc fmt_cmd {text} {bold $text} -proc fmt_emph {text} {underline $text} -proc fmt_opt {text} {return ?$text?} - -proc bold {text} {return [nr_bld]$text[nr_rst]} -proc underline {text} {return [nr_ul]$text[nr_rst]} - -proc fmt_comment {text} { - set res [list] - foreach l [split $text \n] { - lappend res [nr_comment $l] - } - if {[c_begun]} { - return [join $res \n] - } else { - if {[c_inpass] == 1} { - c_hold precomments [join $res \n] - } - return "" - } -} -proc fmt_sectref {text} {bold $text} -proc fmt_syscmd {text} {bold $text} -proc fmt_method {text} {bold $text} -proc fmt_option {text} {bold $text} -proc fmt_widget {text} {bold $text} -proc fmt_fun {text} {bold $text} -proc fmt_type {text} {bold $text} -proc fmt_package {text} {bold $text} -proc fmt_class {text} {bold $text} -proc fmt_var {text} {bold $text} -proc fmt_file {text} {return "\"[underline $text]\""} -proc fmt_uri {text} {underline $text} -proc fmt_term {text} {underline $text} -proc fmt_const {text} {bold $text} - -################################################################ DELETED modules/doctools/mpformats/fmt.null Index: modules/doctools/mpformats/fmt.null ================================================================== --- modules/doctools/mpformats/fmt.null +++ /dev/null @@ -1,30 +0,0 @@ -# -*- tcl -*- -# -# -- Null format -# -# Copyright (c) 2001-2002 Andreas Kupries -# Copyright (c) 2003 Andreas Kupries - -# This is a null format which does return no output at all. - -################################################################ - -proc fmt_initialize {} {return} -proc fmt_shutdown {} {return} -proc fmt_numpasses {} {return 1} -proc fmt_postprocess {text} {return ""} -proc fmt_plain_text {text} {return ""} -proc fmt_setup {n} {return} - -foreach p { - manpage_begin moddesc titledesc manpage_end require description - section para list_begin list_end lst_item call usage bullet enum - arg_def cmd_def opt_def tkoption_def see_also keywords example - example_begin example_end nl arg cmd opt emph comment - sectref syscmd method option widget fun type package class var - file uri term const copyright -} { - proc fmt_$p {args} {return ""} -} - -################################################################ DELETED modules/doctools/mpformats/fmt.text Index: modules/doctools/mpformats/fmt.text ================================================================== --- modules/doctools/mpformats/fmt.text +++ /dev/null @@ -1,437 +0,0 @@ -# -*- tcl -*- -# -# fmt.text -- Engine to convert a doctools document into plain text. -# -# Copyright (c) 2003 Andreas Kupries -# -################################################################ -################################################################ - -# Load shared code and modify it to our needs. - -dt_source _common.tcl -dt_source _text.tcl -proc c_copyrightsymbol {} {return "(c)"} - -rename fmt_initialize BaseInitialize -proc fmt_initialize {} {BaseInitialize ; TextInitialize ; return} - -################################################################ -# Special manpage environments - -proc NewExample {} { - global currentEnv - return [NewEnv Example { - set currentEnv(verbatim) 1 - append currentEnv(prefix) "| " - set currentEnv(example) . - }] ; # {} -} - -proc Example {} { - global currentEnv - if {![info exists currentEnv(exenv)]} { - SaveContext - set verb [NewExample] - RestoreContext - - # Remember verbatim mode in the base environment - set currentEnv(exenv) $verb - SaveEnv - } - return $currentEnv(exenv) -} - -proc NewList {what} { - # List environments - # Per list several environments are required. - - switch -exact -- $what { - enum {NewOrderedList} - bullet {NewUnorderedList} - arg - cmd - opt - tkoption - definitions {NewDefinitionList} - } -} - -proc NewUnorderedList {} { - global currentEnv lmarginIncrement - - # Itemized list - unordered list - bullet - # 1. Base environment provides indentation. - # 2. First paragraph in a list item. - # 3. All other paragraphs. - - set base [NewEnv Itemized { - incr currentEnv(lmargin) $lmarginIncrement - - set bullet [Bullet currentEnv(bulleting)] - }] ; # {} - set first [NewEnv First { - set currentEnv(wspfx) [::textutil::blank $lmarginIncrement] - set currentEnv(listtype) bullet - set currentEnv(bullet) $bullet - }] ; SetContext $base ; # {} - - set next [NewEnv Next { - incr currentEnv(lmargin) $lmarginIncrement - }] ; SetContext $base ; # {} - - set currentEnv(_first) $first - set currentEnv(_next) $next - set currentEnv(pcount) 0 - SaveEnv - return -} - -proc NewOrderedList {} { - global currentEnv lmarginIncrement - - # Ordered list - enumeration - enum - # 1. Base environment provides indentation. - # 2. First paragraph in a list item. - # 3. All other paragraphs. - - set base [NewEnv Enumerated { - incr currentEnv(lmargin) $lmarginIncrement - - set bullet [EnumBullet currentEnv(enumeration)] - }] ; # {} - set first [NewEnv First { - set currentEnv(wspfx) [::textutil::blank $lmarginIncrement] - set currentEnv(listtype) enum - set currentEnv(bullet) $bullet - }] ; SetContext $base ; # {} - - set next [NewEnv Next { - incr currentEnv(lmargin) $lmarginIncrement - }] ; SetContext $base ; # {} - - set currentEnv(_first) $first - set currentEnv(_next) $next - set currentEnv(pcount) 0 - SaveEnv - return -} - -proc NewDefinitionList {} { - global currentEnv lmarginIncrement - - # Definition list - terms & definitions - # 1. Base environment provides indentation. - # 2. Term environment - # 3. Definition environment - - set base [NewEnv DefL { - incr currentEnv(lmargin) $lmarginIncrement - }] ; # {} - set term [NewEnv Term { - set currentEnv(verbatim) 1 - }] ; SetContext $base ; # {} - - set def [NewEnv Def { - incr currentEnv(lmargin) $lmarginIncrement - }] ; SetContext $base ; # {} - - set currentEnv(_term) $term - set currentEnv(_definition) $def - SaveEnv - return -} - -################################################################ -# Final layouting. - -c_holdBuffers require - -proc fmt_postprocess {text} {text_postprocess $text} - - -################################################################ -# Implementations of the formatting commands. - -c_pass 1 fmt_plain_text {text} NOP -c_pass 2 fmt_plain_text {text} {text_plain_text $text} - -c_pass 1 fmt_manpage_begin {title section version} NOP -c_pass 2 fmt_manpage_begin {title section version} { - Off - set module [dt_module] - set shortdesc [c_get_module] - set description [c_get_title] - set copyright [c_get_copyright] - - set hdr [list] - lappend hdr "$title - $shortdesc" - lappend hdr [c_provenance] - lappend hdr "[string trimleft $title :]($section) $version $module \"$shortdesc\"" - set hdr [join $hdr \n] - - Text $hdr - CloseParagraph [Verbatim] - Section NAME - Text "$title - $description" - CloseParagraph - return -} - -c_pass 1 fmt_moddesc {desc} {c_set_module $desc} -c_pass 2 fmt_moddesc {desc} NOP - -c_pass 1 fmt_titledesc {desc} {c_set_title $desc} -c_pass 2 fmt_titledesc {desc} NOP - -c_pass 1 fmt_copyright {desc} {c_set_copyright $desc} -c_pass 2 fmt_copyright {desc} NOP - -c_pass 1 fmt_manpage_end {} NOP -c_pass 2 fmt_manpage_end {} { - set sa [c_xref_seealso] - set kw [c_xref_keywords] - set ct [c_get_copyright] - - CloseParagraph - if {[llength $sa] > 0} {Section {SEE ALSO} ; Text [join [lsort $sa] ", "] ; CloseParagraph} - if {[llength $kw] > 0} {Section KEYWORDS ; Text [join [lsort $kw] ", "] ; CloseParagraph} - if {$ct != {}} {Section COPYRIGHT ; Text $ct ; CloseParagraph [Verbatim]} - return -} - -c_pass 1 fmt_section {name} NOP -c_pass 2 fmt_section {name} {CloseParagraph ; Section $name ; return} - -c_pass 1 fmt_para {} NOP -c_pass 2 fmt_para {} {CloseParagraph ; return} - -c_pass 2 fmt_require {pkg {version {}}} NOP -c_pass 1 fmt_require {pkg {version {}}} { - set result "package require $pkg" - if {$version != {}} {append result " $version"} - c_hold require $result - return -} - -c_pass 1 fmt_usage {cmd args} {c_hold synopsis "$cmd [join $args " "]"} -c_pass 2 fmt_usage {cmd args} NOP - -c_pass 1 fmt_call {cmd args} {c_hold synopsis "$cmd [join $args " "]"} -c_pass 2 fmt_call {cmd args} {fmt_lst_item "$cmd [join $args " "]"} - - -c_pass 1 fmt_description {} NOP -c_pass 2 fmt_description {} { - On - set syn [c_held synopsis] - set req [c_held require] - - if {$syn != {} || $req != {}} { - Section SYNOPSIS - if {($req != {}) && ($syn != {})} { - Text $req\n\n$syn - } else { - if {$req != {}} {Text $req} - if {$syn != {}} {Text $syn} - } - CloseParagraph [Verbatim] - } - - Section DESCRIPTION - return -} - -################################################################ - -c_pass 1 fmt_list_begin {what {hint {}}} NOP -c_pass 2 fmt_list_begin {what {hint {}}} { - #puts_stderr "<>" - - global currentEnv - if {[info exists currentEnv(_definition)]} { - CloseParagraph $currentEnv(_definition) - } elseif {[info exists currentEnv(pcount)]} { - if {$currentEnv(pcount) == 0} {CloseParagraph $currentEnv(_first)} - if {$currentEnv(pcount) > 0} {CloseParagraph $currentEnv(_next)} - incr currentEnv(pcount) - } else { - CloseParagraph - } - SaveContext - NewList $what - Off - - #puts_stderr "<>" - return -} - -c_pass 1 fmt_list_end {} NOP -c_pass 2 fmt_list_end {} { - #puts_stderr "<>" - - global currentEnv - if {[info exists currentEnv(_definition)]} { - CloseParagraph $currentEnv(_definition) - } else { - if {$currentEnv(pcount) == 0} {CloseParagraph $currentEnv(_first)} - if {$currentEnv(pcount) > 0} {CloseParagraph $currentEnv(_next)} - } - RestoreContext - - #puts_stderr "<>" - return -} - -c_pass 1 fmt_lst_item {text} NOP -c_pass 2 fmt_lst_item {text} { - global currentEnv - - #puts_stderr "<>" - - if {[IsOff]} { - On - } else { - CloseParagraph $currentEnv(_definition) - } - Text $text - CloseParagraph $currentEnv(_term) - - #puts_stderr "<>" - return -} - -c_pass 1 fmt_bullet {} NOP -c_pass 2 fmt_bullet {} { - global currentEnv - if {[IsOff]} {On ; return} - if {$currentEnv(pcount) == 0} {CloseParagraph $currentEnv(_first)} - if {$currentEnv(pcount) > 0} {CloseParagraph $currentEnv(_next)} - set currentEnv(pcount) 0 - return -} - -c_pass 1 fmt_enum {} NOP -c_pass 2 fmt_enum {} { - global currentEnv - if {[IsOff]} {On ; return} - if {$currentEnv(pcount) == 0} {CloseParagraph $currentEnv(_first)} - if {$currentEnv(pcount) > 0} {CloseParagraph $currentEnv(_next)} - set currentEnv(pcount) 0 - return -} - -c_pass 1 fmt_cmd_def {command} NOP -c_pass 2 fmt_cmd_def {command} {fmt_lst_item [cmd $command]} - -c_pass 1 fmt_arg_def {type name {mode {}}} NOP -c_pass 2 fmt_arg_def {type name {mode {}}} { - set text "$type [fmt_arg $name]" - if {$mode != {}} {append text " ($mode)"} - fmt_lst_item $text - return -} - -c_pass 1 fmt_opt_def {name {arg {}}} NOP -c_pass 2 fmt_opt_def {name {arg {}}} { - set text [fmt_option $name] - if {$arg != {}} {append text " $arg"} - fmt_lst_item $text - return -} - -c_pass 1 fmt_tkoption_def {name dbname dbclass} NOP -c_pass 2 fmt_tkoption_def {name dbname dbclass} { - set text "" - append text "Command-Line Switch:\t[fmt_option $name]\n" - append text "Database Name:\t[strong $dbname]\n" - append text "Database Class:\t[strong $dbclass]\n" - fmt_lst_item $text -} - -################################################################ - -c_pass 1 fmt_example_begin {} NOP -c_pass 2 fmt_example_begin {} { - global currentEnv para - if {[info exists currentEnv(_definition)]} { - CloseParagraph $currentEnv(_definition) - } elseif {[info exists currentEnv(pcount)]} { - if {$para != {}} { - if {$currentEnv(pcount) == 0} {CloseParagraph $currentEnv(_first)} - if {$currentEnv(pcount) > 0} {CloseParagraph $currentEnv(_next)} - incr currentEnv(pcount) - } - } else { - CloseParagraph - } - return -} - -c_pass 1 fmt_example_end {} NOP -c_pass 2 fmt_example_end {} { - global currentEnv para - set penv {} - if {[info exists currentEnv(_definition)]} { - set penv $currentEnv(_definition) - } elseif {[info exists currentEnv(pcount)]} { - if {$currentEnv(pcount) == 0} {set penv $currentEnv(_first)} - if {$currentEnv(pcount) > 0} {set penv $currentEnv(_next)} - incr currentEnv(pcount) - } - if {$penv != {}} { - # Save current list context, get chosen paragraph context and - # then create an example context form this. After closing the - # paragraph we get back our main list context. - - SaveContext - SetContext $penv - CloseParagraph [Example] - RestoreContext - } else { - CloseParagraph [Example] - } - return -} - -c_pass 1 fmt_example {code} NOP -c_pass 2 fmt_example {code} { - fmt_example_begin - fmt_plain_text $code - fmt_example_end - return -} - -c_pass 1 fmt_nl {} NOP -c_pass 2 fmt_nl {} { - global currentEnv - if {[info exists currentEnv(_definition)]} { - CloseParagraph $currentEnv(_definition) - } else { - if {$currentEnv(pcount) == 0} {CloseParagraph $currentEnv(_first)} - if {$currentEnv(pcount) > 0} {CloseParagraph $currentEnv(_next)} - incr currentEnv(pcount) - } - return -} - -################################################################ -# Visual markup of words and phrases. - -proc fmt_arg {text} {return $text} -proc fmt_cmd {text} {return $text} -proc fmt_emph {text} {em $text } -proc fmt_opt {text} {return "?$text?" } -proc fmt_comment {text} {return} -proc fmt_sectref {text} {return "-> $text"} -proc fmt_syscmd {text} {strong $text} -proc fmt_method {text} {return $text} -proc fmt_option {text} {return $text} -proc fmt_widget {text} {strong $text} -proc fmt_fun {text} {strong $text} -proc fmt_type {text} {strong $text} -proc fmt_package {text} {strong $text} -proc fmt_class {text} {strong $text} -proc fmt_var {text} {strong $text} -proc fmt_file {text} {return "\"$text\""} -proc fmt_uri {text} {return ""} -proc fmt_term {text} {em $text} -proc fmt_const {text} {strong $text} - -################################################################ DELETED modules/doctools/mpformats/fmt.tmml Index: modules/doctools/mpformats/fmt.tmml ================================================================== --- modules/doctools/mpformats/fmt.tmml +++ /dev/null @@ -1,255 +0,0 @@ -# -*- tcl -*- -# -# $Id: fmt.tmml,v 1.15 2003/03/12 04:48:44 andreas_kupries Exp $ -# -# [expand] definitions to convert a tcl based manpage definition -# into TMML. -# -# Copyright (C) 2001 Joe English . -# Freely redistributable. -# -# See also -# -# BUGS: -# + Text must be preceded by [para] or one of the -# list item macros, or else the output will be invalid. -# -###################################################################### - -dt_source _common.tcl -dt_source _xml.tcl - -###################################################################### -# Conversion specification. -# -# Two-pass processing. The first pass collects text for the -# SYNOPSIS, SEE ALSO, and KEYWORDS sections, and the second pass -# produces output. -# - -c_holdBuffers synopsis see_also keywords - -variable block {section dd li} ;# block context elements - -proc fmt_nl {} { emptyElement br } -proc fmt_arg {text} { wrap $text m } -proc fmt_cmd {text} { wrap $text cmd } -proc fmt_emph {text} { c_possibleReference $text emph } -proc fmt_opt {text} { wrap $text o } - -c_pass 1 fmt_example_begin {} NOP -c_pass 1 fmt_example_end {} NOP -c_pass 1 fmt_example {code} NOP -c_pass 2 fmt_example_begin {} { sequence [xmlContext $::block] [start example] } -c_pass 2 fmt_example_end {} { end example } -c_pass 2 fmt_example {code} { sequence [xmlContext $::block] [wrap $code example] } - -proc fmt_comment {text} {xmlComment $text} -proc fmt_sectref {text} {c_possibleReference $text emph} -proc fmt_syscmd {text} {wrap $text syscmd} -proc fmt_method {text} {wrap $text method} -proc fmt_option {text} {wrap $text option} -proc fmt_widget {text} {wrap $text widget} -proc fmt_fun {text} {wrap $text fun} -proc fmt_type {text} {wrap $text type} -proc fmt_package {text} {wrap $text package} -proc fmt_class {text} {wrap $text class} -proc fmt_var {text} {wrap $text variable} -proc fmt_file {text} {wrap $text file} -proc fmt_uri {text} {wrap $text url} -proc fmt_term {text} {wrap $text term} -proc fmt_const {text} {wrap $text l} - - -c_pass 1 fmt_manpage_begin {args} NOP -c_pass 2 fmt_manpage_begin {title section version} { - set headInfo [list] - foreach copyrightLine [split [c_get_copyright] "\n"] { - lappend headInfo [emptyElement info key copyright value $copyrightLine] - } - # ... other metadata here if needed ... - - sequence \ - [xmlComment [c_provenance]] \ - [start manpage \ - id [dt_fileid] \ - cat cmd \ - title $title \ - version $version \ - package [dt_module]] \ - [wrapLines? [join $headInfo \n] head] \ - [start namesection] \ - [wrap $title name] \ - [wrap [c_get_title] desc] \ - [end namesection] \ - ; -} - -c_pass 1 fmt_moddesc {desc} {c_set_module $desc} -c_pass 1 fmt_titledesc {desc} {c_set_title $desc} -c_pass 1 fmt_copyright {desc} {c_set_copyright $desc} - -c_pass 2 fmt_moddesc {args} NOP -c_pass 2 fmt_titledesc {args} NOP -c_pass 2 fmt_copyright {desc} NOP - -c_pass 1 fmt_description {} NOP -c_pass 2 fmt_description {} { - sequence \ - [xmlContext manpage] \ - [wrapLines? [c_held synopsis] syntax synopsis] \ - [start section] \ - [wrap "DESCRIPTION" title] \ - ; -} - -c_pass 1 fmt_section {name} { set ::SectionNames($name) [c_sectionId $name] } -c_pass 2 fmt_section {name} { - sequence \ - [xmlContext manpage] \ - [start section id [c_sectionId $name]] \ - [wrap [string toupper $name] title] \ - ; -} -c_pass 1 fmt_para {} NOP -c_pass 2 fmt_para {} { sequence [xmlContext section] [start p] } - -foreach {type gi} { - bullet ul - enum ol - definitions dl - arg arglist - cmd commandlist - opt optlist - tkoption optionlist -} { - set listTypes($type) $gi - lappend listGIs $gi -} - -c_pass 1 fmt_list_begin {what {hint {}}} NOP -c_pass 1 fmt_list_end {} NOP -c_pass 2 fmt_list_begin {what {hint {}}} { - variable listTypes - sequence \ - [xmlContext {section dd li}] \ - [start $listTypes($what)] \ - ; -} -c_pass 2 fmt_list_end {} { - variable listGIs - sequence \ - [xmlContext $listGIs] \ - [end] \ - ; -} - -c_pass 1 fmt_bullet {} NOP -c_pass 1 fmt_enum {} NOP -c_pass 2 fmt_bullet {} { sequence [xmlContext {ul ol}] [start li] } -c_pass 2 fmt_enum {} { sequence [xmlContext {ul ol}] [start li] } - -c_pass 1 fmt_lst_item {text} NOP -c_pass 2 fmt_lst_item {text} { - sequence \ - [xmlContext dl] \ - [start dle] \ - [wrap $text dt] \ - [start dd] \ - ; -} - -c_pass 1 fmt_arg_def {type name {mode {}}} NOP -c_pass 2 fmt_arg_def {type name {mode {}}} { - sequence \ - [xmlContext arglist] \ - [start argdef] \ - [wrap $type argtype] \ - [wrap $name name] \ - [wrap? $mode argmode] \ - [start desc] \ - ; -} - -c_pass 1 fmt_cmd_def {command} NOP -c_pass 2 fmt_cmd_def {command} { - sequence \ - [xmlContext commandlist] \ - [start commanddef] \ - [wrap $command command] \ - [start desc] \ - ; -} - -c_pass 1 fmt_opt_def {name {arg {}}} NOP -c_pass 2 fmt_opt_def {name {arg {}}} { - sequence \ - [xmlContext optlist] \ - [start optdef] \ - [wrap $name optname] \ - [wrap? $arg optarg] \ - [start desc] \ - ; -} - -c_pass 1 fmt_tkoption_def {name dbname dbclass} NOP -c_pass 2 fmt_tkoption_def {name dbname dbclass} { - sequence \ - [xmlContext optionlist] \ - [start optiondef] \ - [wrap $name name] \ - [wrap $dbname dbname] \ - [wrap $dbclass dbclass] \ - [start desc] \ - ; -} - -c_pass 1 fmt_usage {cmd args} { c_hold synopsis [formatCall $cmd $args] } -c_pass 2 fmt_usage {cmd args} NOP - -c_pass 1 fmt_call {cmd args} { c_hold synopsis [formatCall $cmd $args] } -c_pass 2 fmt_call {cmd args} { - sequence \ - [xmlContext dl] \ - [start dle] \ - [wrap [formatCall $cmd $args] dt] \ - [start dd] \ - ; -} -proc formatCall {cmd arglist} { - return "$cmd [join $arglist { }]" ;# OR: wrap "..." command -} - -c_pass 1 fmt_require {pkg {version {}}} { - c_hold synopsis [formatRequire $pkg $version] -} -c_pass 2 fmt_require {pkg {version {}}} NOP -proc formatRequire {pkg version} { - return "package require [wrap $pkg package] $version" -} - -c_pass 1 fmt_see_also {args} { holdWrapped see_also $args ref } -c_pass 1 fmt_keywords {args} { holdWrapped keywords $args keyword } -c_pass 2 fmt_see_also {args} NOP -c_pass 2 fmt_keywords {args} NOP - -# holdWrapped -- -# Common factor of [see_also] and [keywords]. -# -proc holdWrapped {buffer arglist gi} { - foreach arg $arglist { c_hold $buffer [wrap $arg $gi] } - return -} - -c_pass 1 fmt_manpage_end {} NOP -c_pass 2 fmt_manpage_end {} { - sequence \ - [xmlContext manpage] \ - [wrapLines? [c_held see_also] seealso] \ - [wrapLines? [c_held keywords] keywords] \ - [end manpage] \ - ; -} - -#*EOF* - DELETED modules/doctools/mpformats/fmt.wiki Index: modules/doctools/mpformats/fmt.wiki ================================================================== --- modules/doctools/mpformats/fmt.wiki +++ /dev/null @@ -1,237 +0,0 @@ -# -*- tcl -*- -# -# fmt.nroff -# -# (c) 2002 Andreas Kupries -# -# [expand] definitions to convert a tcl based manpage definition into -# Wiki markup. -# -################################################################ - -dt_source _common.tcl ; # Shared code - -proc fmt_postprocess {wiki} { - # Strip empty lines out of the generated wiki source - # and trim leading blanks, except in code samples. - # - set lines [list] - foreach line [split $wiki \n] { - if {[string match " |*" $line]} { - # Verbatim / example - lappend lines [string trimright $line] - } elseif {[string match ". *" $line]} { - # Verbatim / regular - lappend lines [string range [string trimright $line] 1 end] - } elseif {[string match " \* *" $line]} { - # Itemized lists. - lappend lines [string map {[ [[ ] ]]} [string trimright $line]] - } elseif {[string match " 1. *" $line]} { - # Enumerated lists - lappend lines [string map {[ [[ ] ]]} [string trimright $line]] - } elseif {[regexp "^ (\[^:\]): " $line]} { - # Definition list - lappend lines [string map {[ [[ ] ]]} [string trimright $line]] - } elseif {[string match " *" $line]} { - # Unwanted indentation - lappend lines [string map {[ [[ ] ]]} [string trim $line]] - } else { - # Everything else - lappend lines [string map {[ [[ ] ]]} [string trimright $line]] - } - } - set wiki [join $lines \n]\n - - regsub {^[ ]+} $wiki {} wiki - return $wiki -} - - -################################################################ -## Backend for *roff markup - -c_pass 1 fmt_manpage_begin {title section version} NOP -c_pass 2 fmt_manpage_begin {title section version} { - set module [dt_module] - set shortdesc [c_get_module] - set description [c_get_title] - - set hdr "" - append hdr "$title $version '''$module''' ''$shortdesc''" \n - append hdr \n - append hdr "$description" - append hdr \n - return $hdr -} - -c_pass 1 fmt_moddesc {desc} {c_set_module $desc} -c_pass 2 fmt_moddesc {desc} NOP - -c_pass 1 fmt_titledesc {desc} {c_set_title $desc} -c_pass 2 fmt_titledesc {desc} NOP - -c_pass 1 fmt_copyright {desc} {c_set_copyright $desc} -c_pass 2 fmt_copyright {desc} NOP - -c_pass 1 fmt_manpage_end {} NOP -c_pass 2 fmt_manpage_end {} { - # Complete the generation with a copyright - # section, if such information is available. - - set wiki "" - - set sa [c_xref_seealso] - set kw [c_xref_keywords] - set ct [c_get_copyright] - - if {[llength $sa] > 0} { - append wiki [fmt_section {SEE ALSO}] \n - append wiki [join [lsort $sa] ", "] \n - } - if {[llength $kw] > 0} { - append wiki [fmt_section KEYWORDS] \n - append wiki [join [lsort $kw] ", "] \n - } - if {$ct != {}} { - append wiki [fmt_section COPYRIGHT] - append wiki ". " [join [split $copyright \n] "\n. "] \n - } - return $wiki -} - -proc fmt_section {name} {return "\n\n----\n'''$name'''\n\n"} -proc fmt_para {} {return \n} - -c_pass 2 fmt_require {pkg {version {}}} NOP -c_pass 1 fmt_require {pkg {version {}}} { - if {$version != {}} {set version " $version"} - c_hold synopsis "package require '''$pkg$version'''\n" -} - -c_pass 2 fmt_usage {cmd args} NOP -c_pass 1 fmt_usage {cmd args} {c_hold synopsis " * $cmd [join $args " "]\n"} - -c_pass 2 fmt_call {cmd args} {return "[fmt_lst_item "$cmd [join $args " "]"]"} -c_pass 1 fmt_call {cmd args} {c_hold synopsis " * $cmd [join $args " "]\n"} - -c_pass 1 fmt_description {} NOP -c_pass 2 fmt_description {} { - set result "" - if {[set syn [c_held synopsis]] != {}} { - append result [fmt_section SYNOPSIS] \n - append result $syn \n\n - } - append result [fmt_section DESCRIPTION] - return $result -} - -################################################################ - -proc fmt_list_begin {what {hint {}}} {return {}} -proc fmt_list_end {} {return {}} - -proc fmt_bullet {} {return "\n\n * "} -proc fmt_enum {} {return "\n\n 1. "} -proc fmt_lst_item {text} {return "\n\n $text: "} -proc fmt_cmd_def {command} {return "\n\n [fmt_cmd $command]: "} - -proc fmt_arg_def {type name {mode {}}} { - set text "\n\n " - append text [fmt_arg $name] - append text " $type" - if {$mode != {}} {append text " ($mode)"} - return "${text}: " -} -proc fmt_opt_def {name {arg {}}} { - if {[string match -* $name]} {set name \\-$name} - set name [fmt_option $name] - if {$arg != {}} {append name " $arg"} - return "\n\n ${name}: " -} -proc fmt_tkoption_def {name dbname dbclass} { - set text "\n\n" - append text " Command-Line Switch:\t'''$name'''\n" - append text " Database Name:\t'''$dbname'''\n" - append text " Database Class:\t'''$dbclass'''\n" - append text " * " - return $text -} - -################################################################ - -global textmode -set textmode "" - -proc fmt_example_begin {} { - global mode_save textmode - lappend mode_save $textmode - set textmode example - return "" -} -proc fmt_example_end {} { - global mode_save textmode - set textmode [lindex $mode_save end] - set mode_save [lrange $mode_save 0 end-1] - return "" -} -proc fmt_example {code} { - set lines [list ""] - foreach line [split $code "\n"] { - set linex [string trim $line] - if {$linex == {}} {lappend lines {} ; continue} - lappend lines " | $line" - } - lappend lines "" - return [join $lines "\n"] -} - -proc emph {text} {return ''$text''} -proc strong {text} {return '''$text'''} - -proc fmt_nl {} {return ""} -proc fmt_arg {text} {return ''$text''} -proc fmt_cmd {text} {return '''$text'''} -proc fmt_emph {text} {return ''$text''} -proc fmt_opt {text} {return ?$text?} -proc fmt_comment {text} {return {}} -proc fmt_sectref {text} {strong $text} -proc fmt_syscmd {text} {strong $text} -proc fmt_method {text} {strong $text} -proc fmt_option {text} {strong $text} -proc fmt_widget {text} {strong $text} -proc fmt_fun {text} {strong $text} -proc fmt_type {text} {strong $text} -proc fmt_package {text} {strong $text} -proc fmt_class {text} {strong $text} -proc fmt_var {text} {strong $text} -proc fmt_file {text} {return "\"[emph $text]\""} -proc fmt_uri {text} {emph $text} -proc fmt_term {text} {emph $text} -proc fmt_const {text} {strong $text} - -################################################################ -# wiki specific commands - -proc fmt_plain_text {text} { - # For the wiki we have to force certain text into a single line. - # We also have to make sure that the text is on the same line as - # the initiator (i.e. list bullet). - - global textmode - - if {"$textmode" == "example"} { - set lines [list ""] - foreach line [split $text "\n"] { - set linex [string trim $line] - if {$linex == {}} {lappend lines {} ; continue} - lappend lines " | $line" - } - lappend lines "" - return [join $lines "\n"] - } - - regsub -all "\[ \t\n\]+" $text { } text - return $text -} - -################################################################ DELETED modules/doctools/mpformats/idx.html Index: modules/doctools/mpformats/idx.html ================================================================== --- modules/doctools/mpformats/idx.html +++ /dev/null @@ -1,125 +0,0 @@ -# -*- tcl -*- -# -# $Id: idx.html,v 1.1 2003/03/05 06:50:34 andreas_kupries Exp $ -# -# Engine to convert a docidx document into HTML. -# -# Copyright (c) 2003 Andreas Kupries -# Freely redistributable. -# -###################################################################### - -dt_source _idx_common.tcl -dt_source _html.tcl - -###################################################################### -# Conversion specification. -# -# One-pass processing. - -rename idx_postprocess {} -rename fmt_postprocess idx_postprocess - -proc fmt_plain_text {text} {return {}} - -################################################################ -## Backend for HTML markup - -global firstkey ; set firstkey 1 -global even ; set even 1 -global reflist ; set reflist [list] -global cnt ; set cnt 0 - -proc fmt_index_begin {label title} { - set hdr "" - append hdr "[markup ]\n" - append hdr "[markup ] $label [markup ]\n" - - # Engine parameter - insert 'meta' - if {[set meta [Get meta]] != {}} {append hdr [markup $meta]\n} - - append hdr "[markup ]\n" - append hdr [ht_comment [c_provenance]]\n - append hdr [ht_comment "CVS: \$Id\$ $label"]\n - append hdr \n - append hdr [markup ]\n - - # Engine parameter - insert 'header' - if {[set header [Get header]] != {}} {append hdr [markup $header]\n} - - if {($label != {}) && ($title != {})} { - append hdr "[markup

] $label -- $title [markup

]\n" - } elseif {$label != {}} { - append hdr "[markup

] $label [markup

]\n" - } elseif {$title != {}} { - append hdr "[markup

] $title [markup

]\n" - } - append hdr "[markup "
"]\n" - return $hdr -} -proc fmt_index_end {} { - set text [FlushReferences] - append text [tag/ table]\n - - # Engine parameter - insert 'footer' - set footer [Get footer] - if {$footer != {}} {set footer \n[markup $footer]\n} - - return $text[tag hr]${footer}[tag/ body][tag/ html]\n -} -proc fmt_key {text} { - global firstkey even reflist cnt - - set res [FlushReferences] - set firstkey 0 - - if {$even} { - append res [markup ""]\n - } else { - append res [markup ""]\n - } - set even [expr {1-$even}] - - append res " [markup "
"][markup ""] ${text} [markup ][tag/ td]\n" - append res " [markup ""]\n" - incr cnt - return $res -} - -proc FlushReferences {} { - global firstkey reflist - - set res "" - if {!$firstkey} { - set lines [list] - foreach {ref label} $reflist { - lappend lines "\t[markup ""] ${label} [tag/ a]" - } - append res "[join $lines ,\n]\n [tag /td]\n[tag/ tr]\n" - } - set reflist [list] - return $res -} - -proc fmt_manpage {file label} {global reflist ; lappend reflist [dt_fmap $file] $label ; return} -proc fmt_url {url label} {global reflist ; lappend reflist $url $label ; return} -proc fmt_comment {text} {ht_comment $text} - -################################################################ - -global __var -array set __var { - meta {} - header {} - footer {} -} -proc Get {varname} {global __var ; return $__var($varname)} -proc idx_listvariables {} {global __var ; return [array names __var]} -proc idx_varset {varname text} { - global __var - if {![info exists __var($varname)]} {return -code error "Unknown engine variable \"$varname\""} - set __var($varname) $text - return -} - -################################################################ DELETED modules/doctools/mpformats/idx.nroff Index: modules/doctools/mpformats/idx.nroff ================================================================== --- modules/doctools/mpformats/idx.nroff +++ /dev/null @@ -1,81 +0,0 @@ -# -*- tcl -*- -# -# $Id: idx.nroff,v 1.1 2003/03/05 06:50:34 andreas_kupries Exp $ -# -# Engine to convert a docidx document into nroff. -# -# Copyright (c) 2003 Andreas Kupries -# Freely redistributable. -# -###################################################################### - -dt_source _idx_common.tcl -dt_source _nroff.tcl - -###################################################################### -# Conversion specification. -# -# One-pass processing. - -proc idx_postprocess {nroff} { - # Postprocessing after generation ... - # Strip empty lines out of the generated nroff source - # and trim leading blanks, except in code samples. - - set lines [list] - foreach line [split $nroff "\n"] { - set line [string trim $line] - if {0 == [string length $line]} { - continue - } - lappend lines $line - } - return [join $lines "\n"] -} - -#proc fmt_plain_text {text} {if {$text != {}} {return \n} else {return {}}} -proc fmt_plain_text {text} {return {}} - -################################################################ -## Backend for NROFF markup - -global prec ok haskey -set prec "" -set ok 0 -set haskey 0 - -proc fmt_index_begin {label title} { - global prec ok - set ok 1 - set hdr [nr_comment {}]\n - if {$prec != {}} { - set hdr [nr_comment $prec]\n - } - append hdr [nr_comment [c_provenance]]\n - append hdr [nr_include man.macros]\n - append hdr [nr_title "\"[string trimleft $label :]\" n"]\n - append hdr [nr_bolds]\n - append hdr [nr_section INDEX]\n - append hdr $title[nr_in]\n - return $hdr -} -proc fmt_index_end {} {return [nr_out]} -proc fmt_key {text} { - global haskey - set res "" - if {$haskey} {append res [nr_out]\n} - append res $text[nr_in]\n - set haskey 1 - return $res -} -proc fmt_manpage {file label} {return [nr_blt [nr_bld]$file[nr_rst]]\n$label\n} -proc fmt_url {url label} {return [nr_blt [nr_bld]$url[nr_rst]]\n$label\n} - -proc fmt_comment {text} { - global prec ok - if {$ok} {return [nr_comment $text]} - append prec $text \n - return {} -} - -################################################################ DELETED modules/doctools/mpformats/idx.null Index: modules/doctools/mpformats/idx.null ================================================================== --- modules/doctools/mpformats/idx.null +++ /dev/null @@ -1,23 +0,0 @@ -# -*- tcl -*- -# -# -- Null format (docidx) -# -# Copyright (c) 2003 Andreas Kupries - -# This is a null format which does return no output at all. - -################################################################ - -proc idx_initialize {} {return} -proc idx_shutdown {} {return} -proc idx_numpasses {} {return 1} -proc idx_postprocess {text} {return ""} -proc idx_setup {n} {return} - -foreach p { - index_begin index_end key manpage url comment plain_text -} { - proc fmt_$p {args} {return ""} -} - -################################################################ DELETED modules/doctools/mpformats/idx.text Index: modules/doctools/mpformats/idx.text ================================================================== --- modules/doctools/mpformats/idx.text +++ /dev/null @@ -1,79 +0,0 @@ -# -*- tcl -*- -# -# $Id: idx.text,v 1.2 2003/04/01 23:38:19 andreas_kupries Exp $ -# -# Engine to convert a docidx document into plain text. -# -# Copyright (c) 2003 Andreas Kupries -# Freely redistributable. -# -###################################################################### - -dt_source _idx_common.tcl -dt_source _text.tcl -proc c_copyrightsymbol {} {return "(c)"} - -###################################################################### -# Conversion specification. -# One-pass processing. - -rename idx_postprocess {} -rename text_postprocess idx_postprocess -proc fmt_plain_text {text} {return {}} - -################################################################ -## Backend for plain text markup - -global map ; array set map {} -global key ; set key {} -global max ; set max 0 - -proc fmt_index_begin {label title} { - TextInitialize - - global map ; unset map ; array set map {} - global key ; set key {} - global max ; set max 0 - - set hdr "" - append hdr "Index [textutil::uncap [c_provenance]]\n\n" - - if {($label != {}) && ($title != {})} { - set title "$label -- $title" - } elseif {$label != {}} { - set title $label - } elseif {$title != {}} { - # title is set - } - append hdr $title \n - append hdr [textutil::strRepeat = [string length $title]] - Text $hdr - CloseParagraph [Verbatim] - return -} -proc fmt_index_end {} { - global map max - - set break 0 - set rmargin [expr {80 - $max}] - if {$rmargin < 20} {set rmargin 20} - incr max - set pfx [textutil::blank $max] - - foreach key [lsort [array names map]] { - set opfx $key[string range $pfx [string length $key] end] - Text $opfx[textutil::indent [textutil::adjust [join $map($key) ", "] -length $rmargin] $pfx 1] - CloseParagraph [Verbatim] - } - return -} -proc fmt_key {text} { - global key max ; set key $text - if {[string length $text] > $max} {set max [string length $text]} - return -} -proc fmt_manpage {file label} {global map key ; lappend map($key) $file ; return} -proc fmt_url {url label} {global map key ; lappend map($key) $url ; return} -proc fmt_comment {text} {return} - -################################################################ DELETED modules/doctools/mpformats/idx.wiki Index: modules/doctools/mpformats/idx.wiki ================================================================== --- modules/doctools/mpformats/idx.wiki +++ /dev/null @@ -1,63 +0,0 @@ -# -*- tcl -*- -# -# $Id: idx.wiki,v 1.1 2003/03/05 06:50:34 andreas_kupries Exp $ -# -# Engine to convert a docidx document into Wiki markup. -# -# Copyright (c) 2003 Andreas Kupries -# Freely redistributable. -# -###################################################################### - -dt_source _idx_common.tcl ; # Shared code - -###################################################################### - -proc idx_postprocess {wiki} { - # Strip empty lines out of the generated wiki source - # and trim leading blanks, except in code samples. - # - set lines [list] - foreach line [split $wiki \n] { - if {[string match " |*" $line]} { - # Verbatim / example - lappend lines [string trimright $line] - } elseif {[string match ". *" $line]} { - # Verbatim / regular - lappend lines [string range [string trimright $line] 1 end] - } elseif {[string match " \* *" $line]} { - # Itemized lists. - lappend lines [string map {[ [[ ] ]]} [string trimright $line]] - } elseif {[string match " 1. *" $line]} { - # Enumerated lists - lappend lines [string map {[ [[ ] ]]} [string trimright $line]] - } elseif {[regexp "^ (\[^:\]): " $line]} { - # Definition list - lappend lines [string map {[ [[ ] ]]} [string trimright $line]] - } elseif {[string match " *" $line]} { - # Unwanted indentation - lappend lines [string map {[ [[ ] ]]} [string trim $line]] - } else { - # Everything else - lappend lines [string map {[ [[ ] ]]} [string trimright $line]] - } - } - set wiki [join $lines \n]\n - - regsub {^[ ]+} $wiki {} wiki - return $wiki -} - -proc fmt_plain_text {text} {return {}} - -################################################################ -## Backend for wiki markup - -proc fmt_index_begin {label title} {return "Index '''$label'''\n'''[string trim $title]'''\n"} -proc fmt_index_end {} {return {}} -proc fmt_key {text} {return "\n '''[string trim $text]''': "} -proc fmt_manpage {file label} {return "$file "} -proc fmt_url {url label} {return "$url "} -proc fmt_comment {text} {return {}} - -################################################################ DELETED modules/doctools/mpformats/toc.html Index: modules/doctools/mpformats/toc.html ================================================================== --- modules/doctools/mpformats/toc.html +++ /dev/null @@ -1,112 +0,0 @@ -# -*- tcl -*- -# -# $Id: toc.html,v 1.1 2003/03/05 06:50:34 andreas_kupries Exp $ -# -# Engine to convert a doctoc document into HTML. -# -# Copyright (c) 2003 Andreas Kupries -# Freely redistributable. -# -###################################################################### - -dt_source _toc_common.tcl -dt_source _html.tcl - -###################################################################### -# Conversion specification. -# -# One-pass processing. - -rename toc_postprocess {} -rename fmt_postprocess toc_postprocess - -proc fmt_plain_text {text} {return {}} - -################################################################ -## Backend for TMML markup - -global firstitem ; set firstitem 1 -global maintable ; set maintable 1 -global even ; set even 1 - -proc fmt_toc_begin {label title} { - set hdr "" - append hdr "[markup ]\n" - append hdr "[markup ] $label [markup ]\n" - - # Engine parameter - insert 'meta' - if {[set meta [Get meta]] != {}} {append hdr [markup $meta]\n} - - append hdr "[markup ]\n" - append hdr [ht_comment [c_provenance]]\n - append hdr [ht_comment "CVS: \$Id\$ $label"]\n - append hdr \n - append hdr [markup ]\n - - # Engine parameter - insert 'header' - if {[set header [Get header]] != {}} {append hdr [markup $header]\n} - - append hdr "[markup

] $label [markup

]\n" - append hdr "[markup

] $title [markup

]\n" - return $hdr -} -proc fmt_toc_end {} { - global maintable - set text "\n" - if {$maintable} {append text [tag/ table]\n} - - # Engine parameter - insert 'footer' - set footer [Get footer] - if {$footer != {}} {set footer \n[markup ${footer}]\n} - - return $text[tag /dl][tag hr]${footer}[tag/ body][tag/ html]\n -} -proc fmt_division_start {title} { - global maintable ; set maintable 0 - return \n[markup
]$title[markup
] -} -proc fmt_division_end {} { - global firstitem ; set firstitem 1 - global even ; set even 1 - return [markup
] -} -proc fmt_item {file label desc} { - global firstitem even - set text "" - - if {$firstitem} { - set firstitem 0 - append text \n[markup ""]\n - } - - if {$even} { - append text [markup ""]\n - } else { - append text [markup ""]\n - } - set even [expr {1-$even}] - append text [markup "
"][markup ""]$label[tag/ a][tag/ td]\n - append text [markup ""]${desc}[tag /td]\n - append text [tag/ tr]\n - return $text -} -proc fmt_comment {text} {ht_comment $text} - -################################################################ - -global __var -array set __var { - meta {} - header {} - footer {} -} -proc Get {varname} {global __var ; return $__var($varname)} -proc toc_listvariables {} {global __var ; return [array names __var]} -proc toc_varset {varname text} { - global __var - if {![info exists __var($varname)]} {return -code error "Unknown engine variable \"$varname\""} - set __var($varname) $text - return -} - -################################################################ DELETED modules/doctools/mpformats/toc.nroff Index: modules/doctools/mpformats/toc.nroff ================================================================== --- modules/doctools/mpformats/toc.nroff +++ /dev/null @@ -1,73 +0,0 @@ -# -*- tcl -*- -# -# $Id: toc.nroff,v 1.1 2003/03/05 06:50:34 andreas_kupries Exp $ -# -# Engine to convert a doctoc document into nroff. -# -# Copyright (c) 2003 Andreas Kupries -# Freely redistributable. -# -###################################################################### - -dt_source _toc_common.tcl -dt_source _nroff.tcl - -###################################################################### -# Conversion specification. -# -# One-pass processing. - -proc toc_postprocess {nroff} { - # Postprocessing after generation ... - # Strip empty lines out of the generated nroff source - # and trim leading blanks, except in code samples. - - set lines [list] - foreach line [split $nroff "\n"] { - set line [string trim $line] - if {0 == [string length $line]} { - continue - } - lappend lines $line - } - return [join $lines "\n"] -} - -#proc fmt_plain_text {text} {if {$text != {}} {return \n} else {return {}}} -proc fmt_plain_text {text} {return {}} - -################################################################ -## Backend for TMML markup - -global prec ok -set prec "" -set ok 0 - -proc fmt_toc_begin {label title} { - global prec ok - set ok 1 - set hdr [nr_comment {}]\n - if {$prec != {}} { - set hdr [nr_comment $prec]\n - } - append hdr [nr_comment [c_provenance]]\n - append hdr [nr_include man.macros]\n - append hdr [nr_title "\"[string trimleft $label :]\" n"]\n - append hdr [nr_bolds]\n - append hdr [nr_section CONTENTS]\n - append hdr $title[nr_in]\n - return $hdr -} -proc fmt_toc_end {} {} -proc fmt_division_start {title} {return $text[nr_in]\n} -proc fmt_division_end {} {return [nr_out]\n} -proc fmt_item {file label desc} {return "[nr_blt [nr_bld]$label[nr_rst]]\n[nr_ul]$file[nr_rst]: $desc\n"} - -proc fmt_comment {text} { - global prec ok - if {$ok} {return [nr_comment $text]} - append prec $text \n - return {} -} - -################################################################ DELETED modules/doctools/mpformats/toc.null Index: modules/doctools/mpformats/toc.null ================================================================== --- modules/doctools/mpformats/toc.null +++ /dev/null @@ -1,23 +0,0 @@ -# -*- tcl -*- -# -# -- Null format (doctoc) -# -# Copyright (c) 2003 Andreas Kupries - -# This is a null format which does return no output at all. - -################################################################ - -proc toc_initialize {} {return} -proc toc_shutdown {} {return} -proc toc_numpasses {} {return 1} -proc toc_postprocess {text} {return ""} -proc toc_setup {n} {return} - -foreach p { - toc_begin toc_end item division_start division_end comment plain_text -} { - proc fmt_$p {args} {return ""} -} - -################################################################ DELETED modules/doctools/mpformats/toc.text Index: modules/doctools/mpformats/toc.text ================================================================== --- modules/doctools/mpformats/toc.text +++ /dev/null @@ -1,88 +0,0 @@ -# -*- tcl -*- -# -# $Id: toc.text,v 1.2 2003/04/01 23:38:19 andreas_kupries Exp $ -# -# Engine to convert a doctoc document into plain text. -# -# Copyright (c) 2003 Andreas Kupries -# Freely redistributable. -# -###################################################################### - -dt_source _toc_common.tcl -dt_source _text.tcl - -###################################################################### -# Conversion specification. -# One-pass processing. - -rename toc_postprocess {} -rename text_postprocess toc_postprocess - -proc fmt_plain_text {text} {return {}} - -################################################################ -## Backend for TMML markup - -global seclist ; set seclist {} -global max ; set max 0 - -proc fmt_comment {text} {return} -proc fmt_toc_end {} {return} -proc fmt_toc_begin {label title} { - TextInitialize - - set title "$label -- $title" - set hdr "" - append hdr "Table of contents [textutil::uncap [c_provenance]]\n" - append hdr \n - append hdr $title \n - append hdr [textutil::strRepeat = [string length $title]] - Text $hdr - CloseParagraph [Verbatim] -} -proc fmt_division_start {title} { - global lmarginIncrement currentEnv - global seclist ; set seclist {} - global max ; set max 0 - - Text $title\n - Text [textutil::strRepeat - [string length $title]] - CloseParagraph [Verbatim] - SaveContext - NewEnv Division { - incr currentEnv(lmargin) $lmarginIncrement - } - return -} -proc fmt_division_end {} { - global seclist max - - if {[llength $seclist] > 0} { - set break 0 - incr max 2 - set rmargin [expr {80 - $max}] - if {$rmargin < 20} {set rmargin 20} - set pfx [textutil::blank $max] - incr max -1 - set fpfx "[textutil::strRepeat . $max] " - - foreach {file desc} $seclist { - set opfx "$file [string range $fpfx [string length $file] end]" - Text $opfx[textutil::indent [textutil::adjust $desc -length $rmargin] $pfx 1] - CloseParagraph [Verbatim] - } - set seclist {} - } - - RestoreContext - return -} -proc fmt_item {file label desc} { - global seclist max - lappend seclist $file $desc - if {[string length $file] > $max} {set max [string length $file]} - return -} - -################################################################ DELETED modules/doctools/mpformats/toc.tmml Index: modules/doctools/mpformats/toc.tmml ================================================================== --- modules/doctools/mpformats/toc.tmml +++ /dev/null @@ -1,37 +0,0 @@ -# -*- tcl -*- -# -# $Id: toc.tmml,v 1.1 2003/03/05 06:50:34 andreas_kupries Exp $ -# -# Engine to convert a doctoc document into TMML. -# -# Copyright (c) 2003 Andreas Kupries -# Freely redistributable. -# -# See also -# -###################################################################### - -dt_source _toc_common.tcl -dt_source _xml.tcl - -###################################################################### -# Conversion specification. -# -# One-pass processing. - -rename toc_postprocess {} -rename fmt_postprocess toc_postprocess - -proc fmt_plain_text {text} {if {$text != {}} {return \n} else {return {}}} - -################################################################ -## Backend for TMML markup - -proc fmt_toc_begin {label title} {sequence [start manual package $label] [wrap $title title]} -proc fmt_toc_end {} {end manual} -proc fmt_division_start {title} {sequence [start division] [wrap $text title]} -proc fmt_division_end {} {end division} -proc fmt_item {file label desc} {emptyElement subdoc href [dt_fmap $file]} -proc fmt_comment {text} {xmlComment $text} - -################################################################ DELETED modules/doctools/mpformats/toc.wiki Index: modules/doctools/mpformats/toc.wiki ================================================================== --- modules/doctools/mpformats/toc.wiki +++ /dev/null @@ -1,63 +0,0 @@ -# -*- tcl -*- -# -# $Id: toc.wiki,v 1.1 2003/03/05 06:50:34 andreas_kupries Exp $ -# -# Engine to convert a doctoc document into Wiki markup. -# -# Copyright (c) 2003 Andreas Kupries -# Freely redistributable. -# -###################################################################### - -dt_source _toc_common.tcl ; # Shared code - -###################################################################### - -proc toc_postprocess {wiki} { - # Strip empty lines out of the generated wiki source - # and trim leading blanks, except in code samples. - # - set lines [list] - foreach line [split $wiki \n] { - if {[string match " |*" $line]} { - # Verbatim / example - lappend lines [string trimright $line] - } elseif {[string match ". *" $line]} { - # Verbatim / regular - lappend lines [string range [string trimright $line] 1 end] - } elseif {[string match " \* *" $line]} { - # Itemized lists. - lappend lines [string map {[ [[ ] ]]} [string trimright $line]] - } elseif {[string match " 1. *" $line]} { - # Enumerated lists - lappend lines [string map {[ [[ ] ]]} [string trimright $line]] - } elseif {[regexp "^ (\[^:\]): " $line]} { - # Definition list - lappend lines [string map {[ [[ ] ]]} [string trimright $line]] - } elseif {[string match " *" $line]} { - # Unwanted indentation - lappend lines [string map {[ [[ ] ]]} [string trim $line]] - } else { - # Everything else - lappend lines [string map {[ [[ ] ]]} [string trimright $line]] - } - } - set wiki [join $lines \n]\n - - regsub {^[ ]+} $wiki {} wiki - return $wiki -} - -proc fmt_plain_text {text} {if {$text != {}} {return \n} else {return {}}} - -################################################################ -## Backend for wiki markup - -proc fmt_toc_begin {label title} {return "Table of Contents '''$label'''\n'''[string trim $title]'''"} -proc fmt_toc_end {} {return {}} -proc fmt_division_start {title} {return '''[string trim $title]'''} -proc fmt_division_end {} {return {}} -proc fmt_item {file label desc} {return " \[$label\]: $file -- $desc"} -proc fmt_comment {text} {return {}} - -################################################################ DELETED modules/doctools/pkgIndex.tcl Index: modules/doctools/pkgIndex.tcl ================================================================== --- modules/doctools/pkgIndex.tcl +++ /dev/null @@ -1,16 +0,0 @@ -# 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. - -if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded doctools 1.0 [list source [file join $dir doctools.tcl]] -package ifneeded doctools::toc 0.1 [list source [file join $dir doctoc.tcl]] -package ifneeded doctools::idx 0.1 [list source [file join $dir docidx.tcl]] -package ifneeded doctools::cvs 0.1 [list source [file join $dir cvs.tcl]] -package ifneeded doctools::changelog 0.1 [list source [file join $dir changelog.tcl]] DELETED modules/doctools/tocexpand Index: modules/doctools/tocexpand ================================================================== --- modules/doctools/tocexpand +++ /dev/null @@ -1,136 +0,0 @@ -#!/bin/sh -# -*- tcl -*- \ -exec tclsh "$0" ${1+"$@"} - -rename source __source -proc source {path} { - set f [file join [pwd] $path] - uplevel 1 __source $path -} - - -lappend auto_path [file dirname [file dirname [info script]]] -package require doctools::toc - -# --------------------------------------------------------------------- -# 1. Handle command line options, input and output -# 2. Initialize a doctools object. -# 3. Run the input through the object. -# 4. Write output. -# --------------------------------------------------------------------- - -proc usage {{exitstate 1}} { - global argv0 - puts "Usage: $argv0\ - ?-h|--help|-help|-??\ - ?-help-fmt|--help-fmt?\ - format in|- ?out|-?" - exit $exitstate -} - -# --------------------------------------------------------------------- - -proc fmthelp {} { - # Tcllib FR #527029: short reference of formatting commands. - - global argv0 - puts "$argv0 [doctools::toc::help]" - exit 0 -} - -# --------------------------------------------------------------------- -# 1. Handle command line options, input and output - -proc cmdline {} { - global argv0 argv format in out - - set copyright "" - set extmodule "" - set deprecated 0 - - while {[string match -* [set opt [lindex $argv 0]]]} { - switch -exact -- $opt { - -help - -h - --help - -? { - # Tcllib FR #527029 - usage 0 - } - -help-fmt - --help-fmt { - # Tcllib FR #527029 - fmthelp - } - default { - # Unknown option - usage - } - } - } - - if {[llength $argv] < 3} { - usage - } - foreach {format in out} $argv break - - if {$format == {} || $in == {}} { - usage - } - if {$out == {}} {set out -} - return $format -} - -# --------------------------------------------------------------------- -# 3. Read input. Also providing the namespace with file information. - -proc get_input {} { - global in - if {[string equal $in -]} { - return [read stdin] - } else { - set if [open $in r] - set text [read $if] - close $if - return $text - } -} - -# --------------------------------------------------------------------- -# 4. Write output. - -proc write_out {text} { - global out - if {[string equal $out -]} { - puts -nonewline stdout $text - } else { - set of [open $out w] - puts -nonewline $of $text - close $of - } -} - - -# --------------------------------------------------------------------- -# Get it all together - -proc main {} { - global format in - - #if {[catch {} - cmdline - - ::doctools::toc::new dt -format $format - write_out [dt format [get_input]] - - set warnings [dt warnings] - if {[llength $warnings] > 0} { - puts stderr [join $warnings \n] - } - - #{} msg]} {} - #puts stderr "Execution error: $msg" - #{} - return -} - - -# --------------------------------------------------------------------- -main -exit DELETED modules/exif/ChangeLog Index: modules/exif/ChangeLog ================================================================== --- modules/exif/ChangeLog +++ /dev/null @@ -1,59 +0,0 @@ -2003-04-11 Andreas Kupries - - * exif.tcl: - * exif.man: - * pkgIndex.tcl: Fixed bug #614591. Set version of the package to - to 1.1. - -2003-04-01 Andreas Kupries - - * exif.man: - * exif.tcl: Applied patch for SF tcllib bug #665737 provided by - Tim J. Edwards . This not only - fixes the bug mentioned above, but also corrects some spelling - mistakes, adds support for a number of additional EXIF tags, and - provides functionality to dump a thumbnail image contained in - the data to a file. - - The change in the interface of 'analyze' (stream -> file) was - reverted and an additional file based command provided - instead. This command is a wrapper around the stream interface. - - Updated the documentation. - -2003-02-06 David N. Welton - - * exif.tcl (exif::makerNote): Use string match instead of regexp. - -2002-08-16 Andreas Kupries - - * exif.tcl: Applied patch for bug report SF #530907 partially. - - Parts of the patch are accepted and applied - * FlashPixVersion - * Construction of FlashMode - - Not applied parts: - * SubjectDistance. Patch assumes that unit is millimeter and - converts to meter. Spec says that unit _is_ meter. (*). Is it - possible that the specific camera of the submitter implements - the standard incorrectly ? - - * ShutterSpeedValue. Instead of logical inversion (1/value - seconds) I added the proper unit for frequency (Hz). - - (*) http://www.media.mit.edu/pia/Research/deepview/exif.html - 0x9206 SubjectDistance signed rational 1 Distance to focus point, unit is meter - - * exif.tcl: Applied patch SF #582828 provided by Anselm Lingnau - to make the module work with - Digital IXUS. - -2002-03-25 Andreas Kupries - - * exif.man: Fixed formatting errors in the doctools manpage. - -2002-02-18 Andreas Kupries - - * Added module on behalf of Darren New. - DELETED modules/exif/exif.html Index: modules/exif/exif.html ================================================================== --- modules/exif/exif.html +++ /dev/null @@ -1,147 +0,0 @@ -The EXIF documentation file: The EXIF Package - - - - -
 TOC 
-
- - -
The EXIF documentation fileD. New
 February 12, 2002
-

The EXIF Package
- - -

Abstract

- -

- - Tcl EXIF extracts and parses EXIF fields from digital images. - -

-
 -
 TOC 
-

Table of Contents

-
    -1.  -Synopsis
     -2.  -Details
     -3.  -Copyrights
     -4.  -Acknowledgements
     -
-
- -
 -
 TOC 
-

1. Synopsis

-
-    package provide exif 1.0
-
- -

-The EXIF package is a recoding of Chris Breeze's Perl package to do the same - thing. This version accepts a channel as input and returns a serialized - array with all the recognised fields parsed out. -

- -

- There is also a function to obtain a list of all possible field names that - might be present, which is useful in building GUIs that present such - information. -

- -
 -
 TOC 
-

2. Details

-
-    array set answer [exif::analyze $channel]
-
- -

- $channel should be an open file handle rewound - to the start. It does not need to be seekable. - $channel will be set to binary mode and is left - wherever it happens to stop being parsed, usually - at the end of the file or the start of the image - data. You must open and close the stream yourself. - If no error is thrown, the return value is a - serialized array with informative English text - about what was found in the EXIF block. Failure - during parsing or I/O throw errors. -

-
-    set names [exif::fieldnames]
-
- -

- This returns a list of all possible field names. - That is, the array returned by exif::analyze will - not contain keys that are not listed in the return - from exif::fieldnames. Of course, if information is - missing in the image file, exif::analyze may not - return all the fields listed in the return from - exif::fieldnames. This function is expected to be - primarily useful for building GUIs to display results. - N.B.: Read the implementation of exif::fieldnames - before modifying the implementation of exif::analyze. - -

- -
 -
 TOC 
-

3. Copyrights

- -

-(c) 2002 Darren New -

- -

-Hold harmless the author, and any lawful use is allowed. -

- -
 -
 TOC 
-

4. Acknowledgements

- -

- This code is a direct translation of version 1.3 of exif.pl by Chris - Breeze. See the source for full headers, references, etc. -

- DELETED modules/exif/exif.man Index: modules/exif/exif.man ================================================================== --- modules/exif/exif.man +++ /dev/null @@ -1,74 +0,0 @@ -[manpage_begin exif n 1.1] -[moddesc {EXIF parsing}] -[titledesc {Tcl EXIF extracts and parses EXIF fields from digital images}] -[require Tcl 8.2] -[require exif [opt 1.1]] -[description] -[para] - -The EXIF package is a recoding of Chris Breeze's Perl package to do -the same thing. This version accepts a channel as input and returns a -serialized array with all the recognised fields parsed out. - -[para] - -There is also a function to obtain a list of all possible field names -that might be present, which is useful in building GUIs that present -such information. - -[section COMMANDS] - -[list_begin definitions] - -[call [cmd exif::analyze] [arg channel] [opt [arg thumbnail]]] - -[arg channel] should be an open file handle rewound to the start. It -does not need to be seekable. [arg channel] will be set to binary -mode and is left wherever it happens to stop being parsed, usually at -the end of the file or the start of the image data. You must open and -close the stream yourself. If no error is thrown, the return value is -a serialized array with informative English text about what was found -in the EXIF block. Failure during parsing or I/O throw errors. - -[nl] - -If [arg thumbnail] is present and not the empty string it will be -interpreted as the name of a file, and the thumbnail image contained -in the exif data will be written into it. - -[call [cmd exif::analyzeFile] [arg filename] [opt [arg thumbnail]]] - -This is a file-based wrapper around [cmd exif::analyze]. Instead of -taking a stream it takes a [arg filename] and analyzes the contents of -the specified file. - - -[call [cmd exif::fieldnames]] - -This returns a list of all possible field names. That is, the array -returned by [cmd exif::analyze] will not contain keys that are not -listed in the return from [cmd exif::fieldnames]. Of course, if -information is missing in the image file, [cmd exif::analyze] may not -return all the fields listed in the return from exif::fieldnames. -This function is expected to be primarily useful for building GUIs to -display results. - -[nl] - -N.B.: Read the implementation of [cmd exif::fieldnames] before -modifying the implementation of [cmd exif::analyze]. - -[list_end] - -[section COPYRIGHTS] - -(c) 2002 Darren New - -Hold harmless the author, and any lawful use is allowed. - -[section ACKNOWLEDGEMENTS] - -This code is a direct translation of version 1.3 of exif.pl by Chris -Breeze. See the source for full headers, references, etc. - -[manpage_end] DELETED modules/exif/exif.n Index: modules/exif/exif.n ================================================================== --- modules/exif/exif.n +++ /dev/null @@ -1,102 +0,0 @@ -.\" automatically generated by xml2rfc v1.8 on 12 Feb 2002 23:41:15 +0000 -.\" -.pl 10.0i -.po 0 -.ll 7.2i -.lt 7.2i -.nr LL 7.2i -.nr LT 7.2i -.ds LF New -.ds RF FORMFEED[Page %] -.ds CF -.ds LH EXIF -.ds RH February 2002 -.ds CH The EXIF Package -.hy 0 -.ad l -.nf -The EXIF documentation file D. New - February 12, 2002 - - -.ce -The EXIF Package - -.in 3 - -.ti 0 -Abstract - -.fi -Tcl EXIF extracts and parses EXIF fields from digital images. - -.ti 0 -Table of Contents - -.nf -1. Synopsis . . . . . . . . . . . . . . . . . . . . . . . . . . . . 2 -2. Details . . . . . . . . . . . . . . . . . . . . . . . . . . . . 3 -3. Copyrights . . . . . . . . . . . . . . . . . . . . . . . . . . . 4 -4. Acknowledgements . . . . . . . . . . . . . . . . . . . . . . . . 5 -.bp -.fi -.in 3 -.ti 0 -1. Synopsis -.nf - - package provide exif 1.0 - -.fi -The EXIF package is a recoding of Chris Breeze's Perl package to do -the same thing. This version accepts a channel as input and returns -a serialized array with all the recognised fields parsed out. - -There is also a function to obtain a list of all possible field names -that might be present, which is useful in building GUIs that present -such information. -.bp -.in 3 -.ti 0 -2. Details -.nf - - array set answer [exif::analyze $channel] - -.fi -$channel should be an open file handle rewound to the start. It does -not need to be seekable. $channel will be set to binary mode and is -left wherever it happens to stop being parsed, usually at the end of -the file or the start of the image data. You must open and close the -stream yourself. If no error is thrown, the return value is a -serialized array with informative English text about what was found -in the EXIF block. Failure during parsing or I/O throw errors. -.nf - -.in 3 - set names [exif::fieldnames] - -.fi -This returns a list of all possible field names. That is, the array -returned by exif::analyze will not contain keys that are not listed -in the return from exif::fieldnames. Of course, if information is -missing in the image file, exif::analyze may not return all the -fields listed in the return from exif::fieldnames. This function is -expected to be primarily useful for building GUIs to display results. -N.B.: Read the implementation of exif::fieldnames before modifying -the implementation of exif::analyze. -.bp -.in 3 -.ti 0 -3. Copyrights - -(c) 2002 Darren New - -Hold harmless the author, and any lawful use is allowed. -.bp -.ti 0 -4. Acknowledgements - -This code is a direct translation of version 1.3 of exif.pl by Chris -Breeze. See the source for full headers, references, etc. -.bp DELETED modules/exif/exif.tcl Index: modules/exif/exif.tcl ================================================================== --- modules/exif/exif.tcl +++ /dev/null @@ -1,935 +0,0 @@ -# EXIF parser in Tcl -# Author: Darren New -# Translated directly from the Perl version -# by Chris Breeze -# http://www.breezesys.com -# See the original comment block, reproduced -# at the bottom. -# Most of the inline comments about the meanings of fields -# are copied verbatim and without understanding from the -# original, unless "DNew" is there. -# Much of the structure is preserved, except in -# makerNote, where I got tired of typing as verbosely -# as the original Perl. But thanks for making it so -# readable that even someone who doesn't know Perl -# could translate it, Chris! ;-) -# PLEASE read and understand exif::fieldnames -# BEFORE making any changes here! Thanks! - -# Usage of this version: -# exif::analyze $stream ?$thumbnail? -# Stream should be an open file handle -# rewound to the start. It gets set to -# binary mode and is left at EOF or -# possibly pointing at image data. -# You have to open and close the -# stream yourself. -# The return is a serialized array -# (a la [array get]) with informative -# english text about what was found. -# Errors in parsing or I/O or whatever -# throw errors. -# exif::allfields -# returns a list of all possible field names. -# Added by DNew. Funky implementation. -# -# New -# exif::analyzeFile $filename ?$thumbnail? -# -# If you find any mistakes here, feel free to correct them -# and/or send them to me. I just cribbed this - I don't even -# have a camera that puts this kind of info into the file. - -# LICENSE: Standard BSD License. - -# There's probably something here I'm using without knowing it. -package require Tcl 8.3 - -package provide exif 1.1 ; # first release - -namespace eval ::exif { - namespace export analyze analyzeFile fieldnames - variable debug 0 ; # set to 1 for puts of debug trace - variable cameraModel ; # used internally to understand options - variable jpeg_markers ; # so we only have to do it once - variable intel ; # byte order - so we don't have to pass to every read - variable cached_fieldnames ; # just what it says - array set jpeg_markers { - SOF0 \xC0 - DHT \xC4 - SOI \xD8 - EOI \xD9 - SOS \xDA - DQT \xDB - DRI \xDD - APP1 \xE1 - } -} - -proc ::exif::debug {str} { - variable debug - if {$debug} {puts $str} -} - -proc ::exif::streq {s1 s2} { - return [string equal $s1 $s2] -} - -proc ::exif::analyzeFile {file {thumbnail {}}} { - set stream [open $file] - set res [analyze $stream $thumbnail] - close $stream - return $res -} - -proc ::exif::analyze {stream {thumbnail {}}} { - variable jpeg_markers - array set result {} - fconfigure $stream -translation binary -encoding binary - while {![eof $stream]} { - set ch [read $stream 1] - if {1 != [string length $ch]} {error "End of file reached @1"} - if {![streq "\xFF" $ch]} {break} ; # skip image data - set marker [read $stream 1] - if {1 != [string length $marker]} {error "End of file reached @2"} - if {[streq $marker $jpeg_markers(SOI)]} { - debug "SOI" - } elseif {[streq $marker $jpeg_markers(EOI)]} { - debug "EOI" - } else { - set msb [read $stream 1] - set lsb [read $stream 1] - if {1 != [string length $msb] || 1 != [string length $lsb]} { - error "File truncated @1" - } - scan $msb %c msb ; scan $lsb %c lsb - set size [expr {256 * $msb + $lsb}] - set data [read $stream [expr {$size-2}]] - debug "read [expr $size - 2] bytes of data" - if {[expr {$size-2}] != [string length $data]} { - error "File truncated @2" - } - if {[streq $marker $jpeg_markers(APP1)]} { - debug "APP1\t$size" - array set result [app1 $data $thumbnail] - } elseif {[streq $marker $jpeg_markers(DQT)]} { - debug "DQT\t$size" - } elseif {[streq $marker $jpeg_markers(SOF0)]} { - debug "SOF0\t$size" - } elseif {[streq $marker $jpeg_markers(DHT)]} { - debug "DHT\t$size" - } elseif {[streq $marker $jpeg_markers(SOS)]} { - debug "SOS\t$size" - } else { - binary scan $marker H* x - debug "UNKNOWN MARKER $x" - } - } - } - return [array get result] -} - -proc ::exif::app1 {data thumbnail} { - variable intel - variable cameraModel - array set result {} - if {![string equal [string range $data 0 5] "Exif\0\0"]} { - error "APP1 does not contain EXIF" - } - debug "Reading EXIF data" - set data [string range $data 6 end] - set t [string range $data 0 1] - if {[streq $t "II"]} { - set intel 1 - debug "Intel byte alignment" - } elseif {[streq $t "MM"]} { - set intel 0 - debug "Motorola byte alignment" - } else { - error "Invalid byte alignment: $t" - } - if {[readShort $data 2]!=0x002A} {error "Invalid tag mark"} - set curoffset [readLong $data 4] ; # just called "offset" in the Perl - DNew - debug "Offset to first IFD: $curoffset" - set numEntries [readShort $data $curoffset] - incr curoffset 2 - debug "Number of directory entries: $numEntries" - for {set i 0} {$i < $numEntries} {incr i} { - set head [expr {$curoffset + 12 * $i}] - set entry [string range $data $head [expr {$head+11}]] - set tag [readShort $entry 0] - set format [readShort $entry 2] - set components [readLong $entry 4] - set offset [readLong $entry 8] - set value [readIFDEntry $data $format $components $offset] - if {$tag==0x010e} { - set result(ImageDescription) $value - } elseif {$tag==0x010f} { - set result(CameraMake) $value - } elseif {$tag==0x0110} { - set result(CameraModel) $value - set cameraModel $value - } elseif {$tag==0x0112} { - set result(Orientation) $value - } elseif {$tag == 0x011A} { - set result(XResolution) $value - } elseif {$tag == 0x011B} { - set result(YResolution) $value - } elseif {$tag == 0x0128} { - set result(ResolutionUnit) "unknown" - if {$value==2} {set result(ResolutionUnit) "inch"} - if {$value==3} {set result(ResolutionUnit) "centimeter"} - } elseif {$tag==0x0131} { - set result(Software) $value - } elseif {$tag==0x0132} { - set result(DateTime) $value - } elseif {$tag==0x0213} { - set result(YCbCrPositioning) "unknown" - if {$value==1} {set result(YCbCrPositioning) "Center of pixel array"} - if {$value==2} {set result(YCbCrPositioning) "Datum point"} - } elseif {$tag==0x8769} { - # EXIF sub IFD - debug "==CALLING exifSubIFD==" - array set result [exifSubIFD $data $offset] - } else { - debug "Unrecognized entry: Tag=$tag, value=$value" - } - } - set offset [readLong $data [expr {$curoffset + 12 * $numEntries}]] - debug "Offset to next IFD: $offset" - array set thumb_result [exifSubIFD $data $offset] - - if {$thumbnail != {}} { - set jpg [string range $data \ - $thumb_result(JpegIFOffset) \ - [expr $thumb_result(JpegIFOffset) + $thumb_result(JpegIFByteCount) - 1]] - - set to [open $thumbnail w] - fconfigure $to -translation binary -encoding binary - puts $to $jpg - close $to - - #can be used (with a JPG-aware TK) to add the image to the result array - #set result(THUMB) [image create photo -file $thumbnail] - } - - return [array get result] -} - -# Extract EXIF sub IFD info -proc ::exif::exifSubIFD {data curoffset} { - debug "EXIF: offset=$curoffset" - set numEntries [readShort $data $curoffset] - incr curoffset 2 - debug "Number of directory entries: $numEntries" - for {set i 0} {$i < $numEntries} {incr i} { - set head [expr {$curoffset + 12 * $i}] - set entry [string range $data $head [expr {$head+11}]] - set tag [readShort $entry 0] - set format [readShort $entry 2] - set components [readLong $entry 4] - set offset [readLong $entry 8] - if {$tag==0x9000} { - set result(ExifVersion) [string range $entry 8 11] - } elseif {$tag==0x9101} { - set result(ComponentsConfigured) [format 0x%08x $offset] - } elseif {$tag == 0x927C} { - array set result [makerNote $data $offset] - } elseif {$tag == 0x9286} { - # Apparently, this doesn't usually work. - set result(UserComment) "$offset - [string range $data $offset [expr {$offset+8}]]" - set result(UserComment) [string trim $result(UserComment) "\0"] - } elseif {$tag==0xA000} { - set result(FlashPixVersion) [string range $entry 8 11] - } elseif {$tag==0xA300} { - # 3 means digital camera - if {$offset == 3} { - set result(FileSource) "3 - Digital camera" - } else { - set result(FileSource) $offset - } - } else { - set value [readIFDEntry $data $format $components $offset] - if {$tag==0x829A} { - if {0.3 <= $value} { - # In seconds... - set result(ExposureTime) "$value seconds" - } else { - set result(ExposureTime) "1/[expr {1.0/$value}] seconds" - } - } elseif {$tag == 0x829D} { - set result(FNumber) $value - } elseif {$tag == 0x8827} { - # D30 stores ISO here, G1 uses MakerNote Tag 1 field 16 - set result(ISOSpeedRatings) $value - } elseif {$tag == 0x9003} { - set result(DateTimeOriginal) $value - } elseif {$tag == 0x9004} { - set result(DateTimeDigitized) $value - } elseif {$tag == 0x9102} { - if {$value == 5} { - set result(ImageQuality) "super fine" - } elseif {$value == 3} { - set result(ImageQuality) "fine" - } elseif {$value == 2} { - set result(ImageQuality) "normal" - } else { - set result(CompressedBitsPerPixel) $value - } - } elseif {$tag == 0x9201} { - # Not very accurate, use Exposure time instead. - # (That's Chris' comment. I don't know what it means.) - set value [expr {pow(2,$value)}] - if {$value < 4} { - set value [expr {1.0 / $value}] - set value [expr {int($value * 10 + 0.5) / 10.0}] - } else { - set value [expr {int($value + 0.49)}] - } - set result(ShutterSpeedValue) "$value Hz" - } elseif {$tag == 0x9202} { - set value [expr {int(pow(sqrt(2.0), $value) * 10 + 0.5) / 10.0}] - set result(AperatureValue) $value - } elseif {$tag == 0x9204} { - set value [compensationFraction $value] - set result(ExposureBiasValue) $value - } elseif {$tag == 0x9205} { - set value [expr {int(pow(sqrt(2.0), $value) * 10 + 0.5) / 10.0}] - } elseif {$tag == 0x9206} { - # May need calibration - set result(SubjectDistance) "$value m" - } elseif {$tag == 0x9207} { - set result(MeteringMode) "other" - if {$value == 0} {set result(MeteringMode) "unknown"} - if {$value == 1} {set result(MeteringMode) "average"} - if {$value == 2} {set result(MeteringMode) "center weighted average"} - if {$value == 3} {set result(MeteringMode) "spot"} - if {$value == 4} {set result(MeteringMode) "multi-spot"} - if {$value == 5} {set result(MeteringMode) "multi-segment"} - if {$value == 6} {set result(MeteringMode) "partial"} - } elseif {$tag == 0x9209} { - if {$value == 0} { - set result(Flash) no - } elseif {$value == 1} { - set result(Flash) yes - } else { - set result(Flash) "unknown: $value" - } - } elseif {$tag == 0x920a} { - set result(FocalLength) "$value mm" - } elseif {$tag == 0xA001} { - set result(ColorSpace) $value - } elseif {$tag == 0xA002} { - set result(ExifImageWidth) $value - } elseif {$tag == 0xA003} { - set result(ExifImageHeight) $value - } elseif {$tag == 0xA005} { - set result(ExifInteroperabilityOffset) $value - } elseif {$tag == 0xA20E} { - set result(FocalPlaneXResolution) $value - } elseif {$tag == 0xA20F} { - set result(FocalPlaneYResolution) $value - } elseif {$tag == 0xA210} { - set result(FocalPlaneResolutionUnit) "none" - if {$value == 2} {set result(FocalPlaneResolutionUnit) "inch"} - if {$value == 3} {set result(FocalPlaneResolutionUnit) "centimeter"} - } elseif {$tag == 0xA217} { - # 2 = 1 chip color area sensor - set result(SensingMethod) $value - } elseif {$tag == 0xA401} { - #TJE - set result(SensingMethod) "normal" - if {$value == 1} {set result(SensingMethod) "custom"} - } elseif {$tag == 0xA402} { - #TJE - set result(ExposureMode) "auto" - if {$value == 1} {set result(ExposureMode) "manual"} - if {$value == 2} {set result(ExposureMode) "auto bracket"} - } elseif {$tag == 0xA403} { - #TJE - set result(WhiteBalance) "auto" - if {$value == 1} {set result(WhiteBalance) "manual"} - } elseif {$tag == 0xA404} { - # digital zoom not used if number is zero - set result(DigitalZoomRatio) "not used" - if {$value != 0} {set result(DigitalZoomRatio) $value} - } elseif {$tag == 0xA405} { - set result(FocalLengthIn35mmFilm) "unknown" - if {$value != 0} {set result(FocalLengthIn35mmFilm) $value} - } elseif {$tag == 0xA406} { - set result(SceneCaptureType) "Standard" - if {$value == 1} {set result(SceneCaptureType) "Landscape"} - if {$value == 2} {set result(SceneCaptureType) "Portrait"} - if {$value == 3} {set result(SceneCaptureType) "Night scene"} - } elseif {$tag == 0xA407} { - set result(GainControl) "none" - if {$value == 1} {set result(GainControl) "Low gain up"} - if {$value == 2} {set result(GainControl) "High gain up"} - if {$value == 3} {set result(GainControl) "Low gain down"} - if {$value == 4} {set result(GainControl) "High gain down"} - } elseif {$tag == 0x0103} { - #TJE - set result(Compression) "unknown" - if {$value == 1} {set result(Compression) "none"} - if {$value == 6} {set result(Compression) "JPEG"} - } elseif {$tag == 0x011A} { - #TJE - set result(XResolution) $value - } elseif {$tag == 0x011B} { - #TJE - set result(YResolution) $value - } elseif {$tag == 0x0128} { - #TJE - set result(ResolutionUnit) "unknown" - if {$value == 1} {set result(ResolutionUnit) "inch"} - if {$value == 6} {set result(ResolutionUnit) "cm"} - } elseif {$tag == 0x0201} { - #TJE - set result(JpegIFOffset) $value - debug "offset = $value" - } elseif {$tag == 0x0202} { - #TJE - set result(JpegIFByteCount) $value - debug "bytecount = $value" - } else { - error "Unrecognized EXIF Tag: $tag (0x[string toupper [format %x $tag]])" - } - } - } - return [array get result] -} - -# Canon proprietary data that I didn't feel like translating to Tcl yet. -proc ::exif::makerNote {data curoffset} { - variable cameraModel - debug "MakerNote: offset=$curoffset" - - array set result {} - set numEntries [readShort $data $curoffset] - incr curoffset 2 - debug "Number of directory entries: $numEntries" - for {set i 0} {$i < $numEntries} {incr i} { - set head [expr {$curoffset + 12 * $i}] - set entry [string range $data $head [expr {$head+11}]] - set tag [readShort $entry 0] - set format [readShort $entry 2] - set components [readLong $entry 4] - set offset [readLong $entry 8] - debug "$i)\tTag: $tag, format: $format, components: $components" - - if {$tag==6} { - set value [readIFDEntry $data $format $components $offset] - set result(ImageFormat) $value - } elseif {$tag==7} { - set value [readIFDEntry $data $format $components $offset] - set result(FirmwareVersion) $value - } elseif {$tag==8} { - set value [string range $offset 0 2]-[string range $offset 3 end] - set result(ImageNumber) $value - } elseif {$tag==9} { - set value [readIFDEntry $data $format $components $offset] - set result(Owner) $value - } elseif {$tag==0x0C} { - # camera serial number - set msw [expr {($offset >> 16) & 0xFFFF}] - set lsw [expr {$offset & 0xFFFF}] - set result(CameraSerialNumber) [format %04X%05d $msw $lsw] - } elseif {$tag==0x10} { - set result(UnknownTag-0x10) $offset - } else { - if {$format == 3 && 1 < $components} { - debug "MakerNote $i: TAG=$tag" - catch {unset field} - array set field {} - for {set j 0} {$j < $components} {incr j} { - set field($j) [readShort $data [expr {$offset+2*$j}]] - debug "$j : $field($j)" - } - if {$tag == 1} { - if {![string match -nocase "*Pro90*" $cameraModel]} { - if {$field(1)==1} { - set result(MacroMode) macro - } else { - set result(MacroMode) normal - } - } - if {0 < $field(2)} { - set result(SelfTimer) "[expr {$field(2)/10.0}] seconds" - } - set result(ImageQuality) [switch $field(3) { - 2 {format Normal} - 3 {format Fine} - 4 {format "CCD Raw"} - 5 {format "Super fine"} - default {format ""} - }] - set result(FlashMode) [switch $field(4) { - 0 {format off} - 1 {format auto} - 2 {format on} - 3 {format "red eye reduction"} - 4 {format "slow synchro"} - 5 {format "auto + red eye reduction"} - 6 {format "on + red eye reduction"} - default {format ""} - }] - if {$field(5)} { - set result(ShootingMode) "Continuous" - } else { - set result(ShootingMode) "Single frame" - } - # Field 6 - don't know what it is. - set result(AutoFocusMode) [switch $field(7) { - 0 {format "One-shot"} - 1 {format "AI servo"} - 2 {format "AI focus"} - 3 - 6 {format "MF"} - 5 {format "Continuous"} - 4 { - # G1: uses field 32 to store single/continuous, - # and always sets 7 to 4. - if {[info exists field(32)] && $field(32)} { - format "Continuous" - } else { - format "Single" - } - } - default {format unknown} - }] - # Field 8 and 9 are unknown - set result(ImageSize) [switch $field(10) { - 0 {format "large"} - 1 {format "medium"} - 2 {format "small"} - default {format "unknown"} - }] - # Field 11 - easy shooting - see field 20 - # Field 12 - unknown - set NHL { - 0 {format "Normal"} - 1 {format "High"} - 65536 {format "Low"} - default {format "Unknown"} - } - set result(Contrast) [switch $field(13) $NHL] - set result(Saturation) [switch $field(14) $NHL] - set result(Sharpness) [switch $field(15) $NHL] - set result(ISO) [switch $field(16) { - 15 {format Auto} - 16 {format 50} - 17 {format 100} - 18 {format 200} - 19 {format 400} - default {format "unknown"} - }] - set result(MeteringMode) [switch $field(17) { - 3 {format evaluative} - 4 {format partial} - 5 {format center-weighted} - default {format unknown} - }] - # Field 18 - unknown - set result(AFPoint) [switch -- [expr {$field(19)-0x3000}] { - 0 {format none} - 1 {format auto-selected} - 2 {format right} - 3 {format center} - 4 {format left} - default {format unknown} - }] ; # {} - if {[info exists field(20)]} { - if {$field(20) == 0} { - set result(ExposureMode) [switch $field(11) { - 0 {format auto} - 1 {format manual} - 2 {format landscape} - 3 {format "fast shutter"} - 4 {format "slow shutter"} - 5 {format "night scene"} - 6 {format "black and white"} - 7 {format sepia} - 8 {format portrait} - 9 {format sports} - 10 {format close-up} - 11 {format "pan focus"} - default {format unknown} - }] ; # {} - } elseif {$field(20) == 1} { - set result(ExposureMode) program - } elseif {$field(20) == 2} { - set result(ExposureMode) Tv - } elseif {$field(20) == 3} { - set result(ExposureMode) Av - } elseif {$field(20) == 4} { - set result(ExposureMode) manual - } elseif {$field(20) == 5} { - set result(ExposureMode) A-DEP - } else { - set result(ExposureMode) unknown - } - } - # Field 21 and 22 are unknown - # Field 23: max focal len, 24 min focal len, 25 units per mm - if {[info exists field(23)] && [info exists field(25)]} { - set result(MaxFocalLength) \ - "[expr {1.0 * $field(23) / $field(25)}] mm" - } - if {[info exists field(24)] && [info exists field(25)]} { - set result(MinFocalLength) \ - "[expr {1.0 * $field(24) / $field(25)}] mm" - } - # Field 26-28 are unknown. - if {[info exists field(29)]} { - if {$field(29) & 0x0010} { - lappend result(FlashMode) "FP_sync_enabled" - } - if {$field(29) & 0x0800} { - lappend result(FlashMode) "FP_sync_used" - } - if {$field(29) & 0x2000} { - lappend result(FlashMode) "internal_flash" - } - if {$field(29) & 0x4000} { - lappend result(FlashMode) "external_E-TTL" - } - } - if {[info exists field(34)] \ - [string match -nocase "*pro90*" $cameraModel]} { - if {$field(34)} { - set result(ImageStabilisation) on - } else { - set result(ImageStabilisation) off - } - } - } elseif {$tag == 4} { - set result(WhiteBalance) [switch $field(7) { - 0 {format Auto} - 1 {format Daylight} - 2 {format Cloudy} - 3 {format Tungsten} - 4 {format Fluorescent} - 5 {format Flash} - 6 {format Custom} - default {format Unknown} - }] - if {$field(14) & 0x07} { - set result(AFPointsUsed) \ - [expr {($field(14)>>12) & 0x0F}] - if {$field(14)&0x04} { - append result(AFPointsUsed) " left" - } - if {$field(14)&0x02} { - append result(AFPointsUsed) " center" - } - if {$field(14)&0x01} { - append result(AFPointsUsed) " right" - } - } - if {[info exists field(15)]} { - set v $field(15) - if {32768 < $v} {incr v -65536} - set v [compensationFraction [expr {$v / 32.0}]] - set result(FlashExposureCompensation) $v - } - if {[info exists field(19)]} { - set result(SubjectDistance) "$field(19) m" - } - } elseif {$tag == 15} { - foreach k [array names field] { - set func [expr {($field($k) >> 8) & 0xFF}] - set v [expr {$field($k) & 0xFF}] - if {$func==1 && $v} { - set result(LongExposureNoiseReduction) on - } elseif {$func==1 && !$v} { - set result(LongExposureNoiseReduction) off - } elseif {$func==2} { - set result(Shutter/AE-Lock) [switch $v { - 0 {format "AF/AE lock"} - 1 {format "AE lock/AF"} - 2 {format "AF/AF lock"} - 3 {format "AE+release/AE+AF"} - default {format "Unknown"} - }] - } elseif {$func==3} { - if {$v} { - set result(MirrorLockup) enable - } else { - set result(MirrorLockup) disable - } - } elseif {$func==4} { - if {$v} { - set result(Tv/AvExposureLevel) "1/3 stop" - } else { - set result(Tv/AvExposureLevel) "1/2 stop" - } - } elseif {$func==5} { - if {$v} { - set result(AFAssistLight) off - } else { - set result(AFAssistLight) on - } - } elseif {$func==6} { - if {$v} { - set result(ShutterSpeedInAVMode) "Fixed 1/200" - } else { - set result(ShutterSpeedInAVMode) "Auto" - } - } elseif {$func==7} { - set result(AEBSeq/AutoCancel) [switch $v { - 0 {format "0, -, + enabled"} - 1 {format "0, -, + disabled"} - 2 {format "-, 0, + enabled"} - 3 {format "-, 0, + disabled"} - default {format unknown} - }] - } elseif {$func==8} { - if {$v} { - set result(ShutterCurtainSync) "2nd curtain sync" - } else { - set result(ShutterCurtainSync) "1st curtain sync" - } - } elseif {$func==9} { - set result(LensAFStopButtonFnSwitch) [switch $v { - 0 {format "AF stop"} - 1 {format "operate AF"} - 2 {format "lock AE and start timer"} - default {format unknown} - }] - } elseif {$func==10} { - if {$v} { - set result(AutoReductionOfFillFlash) disable - } else { - set result(AutoReductionOfFillFlash) enable - } - } elseif {$func==11} { - if {$v} { - set result(MenuButtonReturnPosition) previous - } else { - set result(MenuButtonReturnPosition) top - } - } elseif {$func==12} { - set result(SetButtonFuncWhenShooting) [switch $v { - 0 {format "not assigned"} - 1 {format "change quality"} - 2 {format "change ISO speed"} - 3 {format "select parameters"} - default {format unknown} - }] - } elseif {$func==13} { - if {$v} { - set result(SensorCleaning) enable - } else { - set result(SensorCleaning) disable - } - } elseif {$func==0} { - # Discovered by DNew? - set result(CameraOwner) $v - } else { - append result(UnknownCustomFunc) "$func=$v " - } - } - } - } else { - debug [format "makerNote: Unrecognized TAG: 0x%x" $tag] - } - } - } - return [array get result] -} - -proc ::exif::readShort {data offset} { - variable intel - if {[string length $data] < [expr {$offset+2}]} { - error "readShort: end of string reached" - } - set ch1 [string index $data $offset] - set ch2 [string index $data [expr {$offset+1}]] - scan $ch1 %c ch1 ; scan $ch2 %c ch2 - if {$intel} { - return [expr {$ch1 + 256 * $ch2}] - } else { - return [expr {$ch2 + 256 * $ch1}] - } -} - -proc ::exif::readLong {data offset} { - variable intel - if {[string length $data] < [expr {$offset+4}]} { - error "readLong: end of string reached" - } - set ch1 [string index $data $offset] - set ch2 [string index $data [expr {$offset+1}]] - set ch3 [string index $data [expr {$offset+2}]] - set ch4 [string index $data [expr {$offset+3}]] - scan $ch1 %c ch1 ; scan $ch2 %c ch2 - scan $ch3 %c ch3 ; scan $ch4 %c ch4 - if {$intel} { - return [expr {(((($ch4 * 256) + $ch3) * 256) + $ch2) * 256 + $ch1}] - } else { - return [expr {(((($ch1 * 256) + $ch2) * 256) + $ch3) * 256 + $ch4}] - } -} - -proc ::exif::readIFDEntry {data format components offset} { - variable intel - if {$format == 2} { - # ASCII string - set value [string range $data $offset [expr {$offset+$components-1}]] - return [string trimright $value "\0"] - } elseif {$format == 3} { - # unsigned short - if {!$intel} { - set offset [expr {0xFFFF & ($offset >> 16)}] - } - return $offset - } elseif {$format == 4} { - # unsigned long - return $offset - } elseif {$format == 5} { - # unsigned rational - # This could be messy, if either is >2**31 - set numerator [readLong $data $offset] - set denominator [readLong $data [expr {$offset + 4}]] - return [expr {(1.0*$numerator)/$denominator}] - } elseif {$format == 10} { - # signed rational - # Should work normally, since everything in Tcl is signed - set numerator [readLong $data $offset] - set denominator [readLong $data [expr {$offset + 4}]] - return [expr {(1.0*$numerator)/$denominator}] - } else { - set x [format %08x $format] - error "Invalid IFD entry format: $x" - } -} - -proc ::exif::compensationFraction {value} { - if {$value==0} {return 0} - if {$value < 0} { - set result "-" - set value [expr {0-$value}] - } else { - set result "+" - } - set value [expr {int(0.5 + $value * 6)}] - set integer [expr {int($value / 6)}] - set sixths [expr {$value % 6}] - if {$integer != 0} { - append result $integer - if {$sixths != 0} { - append result " " - } - } - if {$sixths == 2} { - append result "1/3" - } elseif {$sixths == 3} { - append result "1/2" - } elseif {$sixths == 4} { - append result "2/3" - } else { - # Added by DNew - append result "$sixths/6" - } - return $result -} - -# This returns the list of all possible fieldnames -# that analyze might return. -proc ::exif::fieldnames {} { - variable cached_fieldnames - if {[info exists cached_fieldnames]} { - return $cached_fieldnames - } - # Otherwise, parse the source to find the fieldnames. - # Cool, huh? Don'tcha just love Tcl? - # Because of this, "result(...)" should only appear - # in these functions when "..." is the literal name - # of a field to be returned. - array set namelist {} - foreach proc {analyze app1 exifSubIFD makerNote} { - set body [info body ::exif::$proc] - foreach line [split $body \n] { - if {[regexp {result\(([^)]+)\)} $line junk name]} { - set namelist($name) {} - } - } - } - set cached_fieldnames [lsort -dictionary [array names namelist]] - return $cached_fieldnames -} - - - -# # # # # # # # # # # # # # -# What follows is the original header comments -# from the Perl code from which this is -# translated. Any changes I made directly -# are marked by "DNew". - -# PERL script to extract EXIF information from JPEGs generated by Canon -# digital cameras. -# This software is free and you may do anything like with it except sell it. -# -# Current version: 1.3 -# Author: Chris Breeze -# email: chris@breezesys.com -# Web: http://www.breezesys.com -# -# Based on experimenting with my G1 and information from: -# http://www.ba.wakwak.com/~tsuruzoh/Computer/Digicams/exif-e.html -# -# Also Canon MakerNote from David Burren's page: -# http://www.burren.cx/david/canon.html -# -# More EXIF info and specs: -# http://exif.org -# -# Warnings: -# 1) The Subject distance is unreliable. It seems reasonably accurate -# for the G1 but on the D30 it is highly dependent on the lens fitted. -# -# Perl for Windows is available for free from: -# http://www.activestate.com -# -# History -# 11 Jan 2001 -# v0.1: Initial version -# -# 14 Jan 2001 -# v0.2: Updated with data from David Burren's page -# -# 15 Jan 2001 -# v0.3: Added more info for D30 (supplied by David Burren) -# 1) D30 stores ISO in EXIF tag 0x8827, G1 uses MakerNote 0x1/16 -# 2) MakerNote 0x1/10, ImageSize appears to be large, medium, small -# 3) D30 allows 1/2 or 1/3 stop exposure compensation -# 4) Added D30 custom function details, but can't test them -# -# 17 Jan 2001 -# v1.0 Tidied up AutoFocusMode for G1 vs D30 + added manual auto focus point (D30) -# -# 18 Jan 2001 -# v1.1 Removed some debug code left in by mistake -# -# 29 Jan 2001 -# v1.2 Added flash mode (MakerNote Tag 1, field 4) -# -# 7 Mar 2001 -# v1.3 Added ImageQuality (MakerNote Tag 1, field 3) -# -# 21 Apr 2001 -# v1.4 added ImageStabilisation for Pro90 IS -# -# 17 Sep 2001 -# v1.5 Incorporated D30 improvements from Jim Leonard - -if {0} { - # Trivial usage example - set x [exif::fieldnames] - puts "fieldnames = $x" - set f [open [lindex $argv 0]] - array set v [exif::analyze $f] - close $f - parray $v -} - DELETED modules/exif/exif.txt Index: modules/exif/exif.txt ================================================================== --- modules/exif/exif.txt +++ /dev/null @@ -1,280 +0,0 @@ - - -The EXIF documentation file D. New - February 12, 2002 - - - The EXIF Package - - -Abstract - - Tcl EXIF extracts and parses EXIF fields from digital images. - -Table of Contents - - 1. Synopsis . . . . . . . . . . . . . . . . . . . . . . . . . . . . 2 - 2. Details . . . . . . . . . . . . . . . . . . . . . . . . . . . . 3 - 3. Copyrights . . . . . . . . . . . . . . . . . . . . . . . . . . . 4 - 4. Acknowledgements . . . . . . . . . . . . . . . . . . . . . . . . 5 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -New [Page 1] - -EXIF The EXIF Package February 2002 - - -1. Synopsis - - package provide exif 1.0 - - The EXIF package is a recoding of Chris Breeze's Perl package to do - the same thing. This version accepts a channel as input and returns - a serialized array with all the recognised fields parsed out. - - There is also a function to obtain a list of all possible field names - that might be present, which is useful in building GUIs that present - such information. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -New [Page 2] - -EXIF The EXIF Package February 2002 - - -2. Details - - array set answer [exif::analyze $channel] - - $channel should be an open file handle rewound to the start. It does - not need to be seekable. $channel will be set to binary mode and is - left wherever it happens to stop being parsed, usually at the end of - the file or the start of the image data. You must open and close the - stream yourself. If no error is thrown, the return value is a - serialized array with informative English text about what was found - in the EXIF block. Failure during parsing or I/O throw errors. - - set names [exif::fieldnames] - - This returns a list of all possible field names. That is, the array - returned by exif::analyze will not contain keys that are not listed - in the return from exif::fieldnames. Of course, if information is - missing in the image file, exif::analyze may not return all the - fields listed in the return from exif::fieldnames. This function is - expected to be primarily useful for building GUIs to display results. - N.B.: Read the implementation of exif::fieldnames before modifying - the implementation of exif::analyze. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -New [Page 3] - -EXIF The EXIF Package February 2002 - - -3. Copyrights - - (c) 2002 Darren New - - Hold harmless the author, and any lawful use is allowed. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -New [Page 4] - -EXIF The EXIF Package February 2002 - - -4. Acknowledgements - - This code is a direct translation of version 1.3 of exif.pl by Chris - Breeze. See the source for full headers, references, etc. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -New [Page 5] - DELETED modules/exif/exif.xml Index: modules/exif/exif.xml ================================================================== --- modules/exif/exif.xml +++ /dev/null @@ -1,100 +0,0 @@ - - - - - - - - - - -The EXIF Package - - - -
- -5390 Caminito Exquisito -San Diego CA 92130 -US - -dnew@san.rr.com -
- - - - - - Tcl EXIF extracts and parses EXIF fields from digital images. - - - - - -
-
- -The EXIF package is a recoding of Chris Breeze's Perl package to do the same - thing. This version accepts a channel as input and returns a serialized - array with all the recognised fields parsed out. - - There is also a function to obtain a list of all possible field names that - might be present, which is useful in building GUIs that present such - information. - -
- -
- -
- - $channel should be an open file handle rewound - to the start. It does not need to be seekable. - $channel will be set to binary mode and is left - wherever it happens to stop being parsed, usually - at the end of the file or the start of the image - data. You must open and close the stream yourself. - If no error is thrown, the return value is a - serialized array with informative English text - about what was found in the EXIF block. Failure - during parsing or I/O throw errors. - -
- - This returns a list of all possible field names. - That is, the array returned by exif::analyze will - not contain keys that are not listed in the return - from exif::fieldnames. Of course, if information is - missing in the image file, exif::analyze may not - return all the fields listed in the return from - exif::fieldnames. This function is expected to be - primarily useful for building GUIs to display results. - N.B.: Read the implementation of exif::fieldnames - before modifying the implementation of exif::analyze. - - -
- -
-(c) 2002 Darren New - -Hold harmless the author, and any lawful use is allowed. -
- -
- - This code is a direct translation of version 1.3 of exif.pl by Chris - Breeze. See the source for full headers, references, etc. - -
- - - - - DELETED modules/exif/pkgIndex.tcl Index: modules/exif/pkgIndex.tcl ================================================================== --- modules/exif/pkgIndex.tcl +++ /dev/null @@ -1,2 +0,0 @@ -if {![package vsatisfies [package provide Tcl] 8.3]} {return} -package ifneeded exif 1.1 [list source [file join $dir exif.tcl]] DELETED modules/fileutil/ChangeLog Index: modules/fileutil/ChangeLog ================================================================== --- modules/fileutil/ChangeLog +++ /dev/null @@ -1,155 +0,0 @@ -2003-04-11 Andreas Kupries - - * fileutil.man: - * fileutil.tcl: - * pkgIndex.tcl: Set version of the package to to 1.5. - -2003-04-02 Andreas Kupries - - * fileutil.test (fileutil): Fixed tcllib SF bug #714214 reported - by Pat Thoyts, by working around the 'makeFile' command provided - with tcltest. It seems to have issues when doing binary data. - -2003-03-24 Andreas Kupries - - * fileutil.tcl (fileutil::touch): Applied patch #688965 provided - by Glenn Jackman . This patch - provides a better message when asking the [fileutil::touch] - command for help. - -2003-03-24 Andreas Kupries - - * fileutil.test: - * fileutil.man: - * fileutil.tcl: Fixed bug #707009, reported by Helmut Giese - , also updated the documentation - and the testsuite. - -2003-01-28 David N. Welton - - * fileutil.tcl (::fileutil::fileType): Use 'string match' instead - of regexp. Require Tcl 8.2. - -2003-01-16 Andreas Kupries - - * fileutil.man: More semantic markup, less visual one. - -2002-10-08 Andreas Kupries - - * fileutil.tcl: - * fileutil.man: - * fileutil.test: Accepted enhanced format detection by Philip - Ehrens . - -2002-05-21 Andreas Kupries - - * fileutil.tcl (cat): Fixed bug #556504, reported by Michael - A. Cleverly . The fix was - provided by Michael too. The problem was reading files which are - reported as size 0, but actually have content, just dynamically - generated (Linux /proc is an example of an fs containing such - files). - -2002-05-14 Andreas Kupries - - * fileutil.man: Documented the two new commands (stripN, - stripPwd). - - * fileutil.tcl: Made up my mind about SF Bug #462015. The proposed - interface change to [find] is rejected to keep the interface of - the library procedure simple and without hidden surprises = - KISS. Added a command [stripPwd] instead which can be used by - the caller of [find] to make the returned paths relative to the - current working directory. Also added [stripN] to strip a fixed - number of elements from the beginning of a path. - -2002-04-12 Andreas Kupries - - * fileutil.man: Added doctools manpage. - * fileutils.n: Updated to reflect change of version. - -2002-03-20 eric melski - - * Bumped version to 1.4 - - * fileutil.n: - * fileutil.test: - * fileutil.tcl: Added fileType command posted to comp.lang.tcl by - Phil Ehrens, with some minor modifications. - -2002-01-15 Andreas Kupries - - * Bumped version to 1.3 - -2001-12-06 Andreas Kupries - - * fileutil.test: Restricted tests 2.2 and 2.3 to the directory - structure created for the test and not the whole directory the - test is run in. Bugfix for item #486572. - -2001-11-06 Andreas Kupries - - * fileutil.test: - * fileutil.n: - * fileutil.tcl: Applied patch #477805 by Glenn Jackman - implementing the unix 'touch' - command. Contains documentation and testsuite for the new - command too. - -2001-09-05 Andreas Kupries - - * fileutil.tcl: Restricted export list to public API. - [456255]. Patch by Hemang Lavana - - -2001-08-21 Andreas Kupries - - * All of the changes below are related to tcllib Patch [449531] by - Anselm Lingnau . Instead of - taking in the proposed highlevel 'fileinput' I added some of the - more low-level commands from Tclx which can be used to - create/compose 'fileinput'. - - * pkgIndex.tcl: Moved version of fileutil to 1.2. - - * fileutil.test: Added tests for the new commands. Moved version - of fileutil to 1.2. - - * fileutil.n: Added documentation of the new commands. Moved - version of fileutil to 1.2. - - * fileutil.tcl (findByPattern, foreachLine): New commands, modeled - after TclX's 'recursive_glob' and 'for_file'. Moved version of - fileutil to 1.2. - -2001-07-31 Andreas Kupries - - * fileutil.n: Added manpage documenting the commands. tcllib Bug - [446584]. - -2001-06-21 Andreas Kupries - - * fileutil.tcl: Fixed dubious code reported by frink. - -2001-03-20 Andreas Kupries - - * fileutil.tcl: [Bug #410104, Patch #410106] - New implementation of ::fileutil::find for unixoid OSs using - stat and device/inode configuration to detect and break circular - softlink structures. This implementation also skips un'stat'able - files and directories. - - * fileutil.test: Added fileutil-1.4 testing the circle breaker - (only under unix). - -2000-03-10 Eric Melski - - * fileutil.test: - * fileutil.tcl: Added cat function, duplicates standard UNIX "cat" - utility. - -2000-03-09 Eric Melski - - * fileutil.test: Collected tests into one file; adapted tests for - use in/out of tcllib test framework. - DELETED modules/fileutil/fileutil.man Index: modules/fileutil/fileutil.man ================================================================== --- modules/fileutil/fileutil.man +++ /dev/null @@ -1,125 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[manpage_begin fileutil n 1.5] -[moddesc {file utilities}] -[titledesc {Procedures implementing some file utilities}] -[require Tcl 8] -[require fileutil [opt 1.5]] -[description] -[para] - -This package provides implementations of standard unix utilities. - -[list_begin definitions] - - -[call [cmd ::fileutil::cat] [arg filename]] - -A tcl implementation of the UNIX [syscmd cat] command. Returns the -contents of the specified file. The first argument is the name of the -file to read. - - -[call [cmd ::fileutil::fileType] [arg filename]] - -An implementation of the UNIX [syscmd file] command, which uses -various heuristics to guess the type of a file. Returns a list -specifying as much type information as can be determined about the -file, from most general (eg, "binary" or "text") to most specific (eg, -"gif"). For example, the return value for a GIF file would be "binary -graphic gif". The command will detect the following types of files: -directory, empty, binary, text, script (with interpreter), executable -elf, graphic gif, graphic jpeg, graphic png, graphic tiff, html, -xml (with doctype if available), message pgp, binary pdf, text ps, -text eps, binary gravity_wave_data_frame, compressed bzip, -compressed gzip, and link. - - -[call [cmd ::fileutil::find] [opt "[arg basedir] [opt [arg filtercmd]]"]] - -An implementation of the unix command [syscmd find]. Adapted from the -Tcler's Wiki. Takes at most two arguments, the path to the directory -to start searching from and a command to use to evaluate interest in -each file. The path defaults to [file .], i.e. the current -directory. The command defaults to the empty string, which means that -all files are of interest. The command takes care [emph not] to -loose itself in infinite loops upon encountering circular link -structures. The result of the command is a list containing the paths -to the interesting files. - - -[call [cmd ::fileutil::findByPattern] [arg basedir] [opt [option -regexp]|[option -glob]] [opt [option --]] [arg patterns]] - -This command is based upon the [package TclX] command - -[cmd recursive_glob], except that it doesn't allow recursion over more -than one directory at a time. It uses [cmd ::fileutil::find] -internally and is thus able to and does follow symbolic links, -something the [package TclX] command does not do. First argument is -the directory to start the search in, second argument is a list of -[arg patterns]. The command returns a list of all files reachable -through [arg basedir] whose names match at least one of the -patterns. The options before the pattern-list determine the style of -matching, either regexp or glob. glob-style matching is the default if -no options are given. Usage of the option [option --] stops option -processing. This allows the use of a leading '-' in the patterns. - - -[call [cmd ::fileutil::foreachLine] [arg {var filename cmd}]] - -The command reads the file [arg filename] and executes the script - -[arg cmd] for every line in the file. During the execution of the -script the variable [arg var] is set to the contents of the current -line. The return value of this command is the result of the last -invocation of the script [arg cmd] or the empty string if the file was -empty. - - -[call [cmd ::fileutil::grep] [arg pattern] [opt [arg files]]] - -Implementation of [syscmd grep]. Adapted from the Tcler's Wiki. The -first argument defines the [arg pattern] to search for. This is -followed by a list of [arg files] to search through. The list is -optional and [const stdin] will be used if it is missing. The result -of the procedures is a list containing the matches. Each match is a -single element of the list and contains filename, number and contents -of the matching line, separated by a colons. - - - -[call [cmd ::fileutil::stripN] [arg path] [arg n]] - -Removes the first [arg n] elements from the specified [arg path] and -returns the modified path. If [arg n] is greater than the number of -components in [arg path] an empty string is returned. - -[call [cmd ::fileutil::stripPwd] [arg path]] - -If the [arg path] is inside of the directory returned by - -[lb][cmd pwd][rb] (or the current working directory itself) it is made -relative to that directory. In other words, the current working -directory is stripped from the [arg path]. The possibly modified path -is returned as the result of the command. If the current working -directory itself was specified for [arg path] the result is the string -"[const .]". - - -[call [cmd ::fileutil::touch] [opt [option -a]] [opt [option -c]] [opt [option -m]] [opt "[option -r] [arg ref_file]"] [opt "[option -t] [arg time]"] [arg filename] [opt [arg ...]]] - -Implementation of [syscmd touch]. Alter the atime and mtime of the -specified files. If [option -c], do not create files if they do not -already exist. If [option -r], use the atime and mtime from - -[arg ref_file]. If [option -t], use the integer clock value - -[arg time]. It is illegal to specify both [option -r] and - -[option -t]. If [option -a], only change the atime. If [option -m], -only change the mtime. - -[list_end] - - -[keywords {file utilities}] -[manpage_end] DELETED modules/fileutil/fileutil.n Index: modules/fileutil/fileutil.n ================================================================== --- modules/fileutil/fileutil.n +++ /dev/null @@ -1,103 +0,0 @@ -'\" -'\" Copyright (c) 2001 by Andreas Kupries -'\" All rights reserved. -'\" -'\" RCS: @(#) $Id: fileutil.n,v 1.9 2002/04/13 01:37:04 andreas_kupries Exp $ -'\" -.so man.macros -.TH fileutil n 1.4 Fileutil "file utilities" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -::fileutil \- Procedures implementing some file utilities -.SH SYNOPSIS -\fBpackage require Tcl 8\fR -.sp -\fBpackage require fileutil ?1.4?\fR -.sp -\fB::fileutil::cat\fR \fIfilename\fR -.sp -\fB::fileutil::fileType\fR \fIfilename\fR -.sp -\fB::fileutil::find\fR ?\fIbasedir\fR ?\fIfiltercmd\fR?? -.sp -\fB::fileutil::findByPattern\fR \fIbasedir\fR ?\fI-regexp\fI|\fI-glob\fR? ?\fI\--\fR? \fIpatterns\fR -.sp -\fB::fileutil::foreachLine\fR \fIvar filename cmd\fR -.sp -\fB::fileutil::grep\fR \fIpattern\fR ?\fIfiles\fR? -.sp -\fB::fileutil::touch\fR ?\fI-a\fR? ?\fI-c\fR? ?\fI-m\fR? ?\fI-r ref_file\fR? ?\fI-t time\fR? \fIfilename\fR ?\fI...\fR? -.BE -.SH DESCRIPTION -.PP -This package provides implementations of standard unix utilities -.TP -\fB::fileutil::cat\fR \fIfilename\fR -A tcl implementation of the UNIX "cat" command. Returns the contents -of the specified file. The first argument is the name of the file to -read. -.TP -\fB::fileutil::fileType\fR \fIfilename\fR -An implementation of the UNIX "file" command, which uses various -heuristics to guess the type of a file. Returns a list specifying as -much type information as can be determined about the file, from most -general (eg, "binary" or "text") to most specific (eg, "gif"). For -example, the return value for a GIF file would be "binary graphic -gif". The command will detect the following types of files: -directory, empty, binary, text, script (with interpreter), executable -elf, graphic gif, graphic jpeg, html, xml (with doctype if available), -message pgp, and link. -.TP -\fB::fileutil::find\fR ?\fIbasedir\fR ?\fIfiltercmd\fR?? -An implementation of the unix command \fBfind\fR. Adapted from the -Tcler's Wiki. Takes at most two arguments, the path to the directory -to start searching from and a command to use to evaluate interest in -each file. The path defaults to \fB.\fR, i.e. the current -directory. The command defaults to the empty string, which means that -all files are of interest. The command takes care \fBnot\fR to loose -itself in infinite loops upon encountering circular link structures. -The result of the command is a list containing the paths to the -interesting files. -.TP -\fB::fileutil::findByPattern\fR \fIbasedir\fR ?\fI-regexp\fI|\fI-glob\fR? ?\fI\--\fR? \fIpatterns\fR -This command is based upon the TclX command \fBrecursive_glob\fR, -except that it doesn't allow recursion over more than one directory at -a time. It uses \fB::fileutil::find\fR internally and is thus able to -and does follow symbolic links, something the TclX command does not -do. First argument is the directory to start the search in, second -argument is a list of \fIpatterns\fR. The command returns a list of -all files reachable through \fIbasedir\fR whose names match at least -one of the patterns. The options before the pattern-list determine the -style of matching, either regexp or glob. glob-style matching is the -default if no options are given. Usage of the option \fI--\fR stops -option processing. This allows the use of a leading '-' in the -patterns. -.TP -\fB::fileutil::foreachLine\fR \fIvar filename cmd\fR -The command reads the file \fIfilename\fR and executes the script -\fIcmd\fR for every line in the file. During the execution of the -script the variable \fIvar\fR is set to the contents of the current -line. The return value of this command is the result of the last -invocation of the script \fIcmd\fR or the empty string if the file was -empty. -.TP -\fB::fileutil::grep\fR \fIpattern\fR ?\fIfiles\fR? -Implementation of grep. Adapted from the Tcler's Wiki. The first -argument defines the \fIpattern\fR to search for. This is followed by -a list of \fIfiles\fR to search through. The list is optional and -\fBstdin\fR will be used if is missing. The result of the procedures -is a list containing the matches. Each match is a single element of -the list and contains filename, number and contents of the matching -line, separated by a colons. -.TP -\fB::fileutil::touch\fR ?\fI-a\fR? ?\fI-c\fR? ?\fI-m\fR? ?\fI-r ref_file\fR? ?\fI-t time\fR? \fIfilename\fR ?\fI...\fR? -Implementation of touch. Alter the atime and mtime of the specified -files. If \fI-c\fR, do not create files if they do not already -exist. If \fI-r\fR, use the atime and mtime from \fIref_file\fR. If -\fI-t\fR, use the integer clock value \fItime\fR. It is illegal to -specify both \fI-r\fR and \fI-t\fR. If \fI-a\fR, only change the -atime. If \fI-m\fR, only change the mtime. - -.SH KEYWORDS -file utilities DELETED modules/fileutil/fileutil.tcl Index: modules/fileutil/fileutil.tcl ================================================================== --- modules/fileutil/fileutil.tcl +++ /dev/null @@ -1,578 +0,0 @@ -# fileutil.tcl -- -# -# Tcl implementations of standard UNIX utilities. -# -# Copyright (c) 1998-2000 by Ajuba Solutions. -# Copyright (c) 2002 by Phil Ehrens (fileType) -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: fileutil.tcl,v 1.21 2003/04/11 19:44:23 andreas_kupries Exp $ - -package require Tcl 8.2 -package require cmdline -package provide fileutil 1.5 - -namespace eval ::fileutil { - namespace export grep find findByPattern cat foreachLine touch -} - -# ::fileutil::grep -- -# -# Implementation of grep. Adapted from the Tcler's Wiki. -# -# Arguments: -# pattern pattern to search for. -# files list of files to search; if NULL, uses stdin. -# -# Results: -# results list of matches - -proc ::fileutil::grep {pattern {files {}}} { - set result [list] - if {[llength $files] == 0} { - # read from stdin - set lnum 0 - while {[gets stdin line] >= 0} { - incr lnum - if {[regexp -- $pattern $line]} { - lappend result "${lnum}:${line}" - } - } - } else { - foreach filename $files { - set file [open $filename r] - set lnum 0 - while {[gets $file line] >= 0} { - incr lnum - if {[regexp -- $pattern $line]} { - lappend result "${filename}:${lnum}:${line}" - } - } - close $file - } - } - return $result -} - -# ::fileutil::find == -# -# Two different implementations of this command, one for unix with its -# softlinks, the other for the Win* platform. The trouble with -# softlink is that they can generate circles in the directory and/or -# file structure, leading a simple recursion into infinity. So we -# record device/inode information for each file and directory we touch -# to be able to skip it should we happen to visit it again. - -# Note about the general implementation: The tcl interpreter sets a -# tcl stack limit of 1000 levels to prevent infinite recursions from -# running out of bounds. As this command is implemented recursively it -# will fail for very deeply nested directory structures. - -if {[string compare unix $tcl_platform(platform)]} { - # Not a unix platform => Original implementation - # Note: This may still fail for directories mounted via SAMBA, - # i.e. coming from a unix server. - - # ::fileutil::find -- - # - # Implementation of find. Adapted from the Tcler's Wiki. - # - # Arguments: - # basedir directory to start searching from; default is . - # filtercmd command to use to evaluate interest in each file. - # If NULL, all files are interesting. - # - # Results: - # files a list of interesting files. - - proc ::fileutil::find {{basedir .} {filtercmd {}}} { - set oldwd [pwd] - cd $basedir - set cwd [pwd] - set filenames [glob -nocomplain * .*] - set files {} - set filt [string length $filtercmd] - # If we don't remove . and .. from the file list, we'll get stuck in - # an infinite loop in an infinite loop in an infinite loop in an inf... - foreach special [list "." ".."] { - set index [lsearch -exact $filenames $special] - set filenames [lreplace $filenames $index $index] - } - foreach filename $filenames { - # Use uplevel to eval the command, not eval, so that variable - # substitutions occur in the right context. - if {!$filt || [uplevel $filtercmd [list $filename]]} { - lappend files [file join $cwd $filename] - } - if {[file isdirectory $filename]} { - set files [concat $files [find $filename $filtercmd]] - } - } - cd $oldwd - return $files - } -} else { - # Unix, record dev/inode to detect and break circles - - # ::fileutil::find -- - # - # Implementation of find. Adapted from the Tcler's Wiki. - # - # Arguments: - # basedir directory to start searching from; default is . - # filtercmd command to use to evaluate interest in each file. - # If NULL, all files are interesting. - # - # Results: - # files a list of interesting files. - - proc ::fileutil::find {{basedir .} {filtercmd {}} {nodeVar {}}} { - if {$nodeVar == {}} { - # Main call, setup the device/inode structure - array set inodes {} - } else { - # Recursive call, import the device/inode record from the caller. - upvar $nodeVar inodes - } - - set oldwd [pwd] - cd $basedir - set cwd [pwd] - set filenames [glob -nocomplain * .*] - set files {} - set filt [string length $filtercmd] - # If we don't remove . and .. from the file list, we'll get stuck in - # an infinite loop in an infinite loop in an infinite loop in an inf... - foreach special [list "." ".."] { - set index [lsearch -exact $filenames $special] - set filenames [lreplace $filenames $index $index] - } - foreach filename $filenames { - # Stat each file/directory get exact information about its identity - # (device, inode). Non-'stat'able files are either junk (link to - # non-existing target) or not readable, i.e. inaccessible. In both - # cases it makes sense to ignore them. - - if {[catch {file stat [file join $cwd $filename] stat}]} { - continue - } - - # No skip over previously recorded files/directories and - # record the new files/directories. - - set key "$stat(dev),$stat(ino)" - if {[info exists inodes($key)]} { - continue - } - set inodes($key) 1 - - # Use uplevel to eval the command, not eval, so that variable - # substitutions occur in the right context. - if {!$filt || [uplevel $filtercmd [list $filename]]} { - lappend files [file join $cwd $filename] - } - if {[file isdirectory $filename]} { - set files [concat $files [find $filename $filtercmd inodes]] - } - } - cd $oldwd - return $files - } - - # end if -} - -# ::fileutil::findByPattern -- -# -# Specialization of find. Finds files based on their names, -# which have to match the specified patterns. Options are used -# to specify which type of patterns (regexp-, glob-style) is -# used. -# -# Arguments: -# basedir Directory to start searching from. -# args Options (-glob, -regexp, --) followed by a -# list of patterns to search for. -# -# Results: -# files a list of interesting files. - -proc ::fileutil::findByPattern {basedir args} { - set pos 0 - set cmd ::fileutil::FindGlob - foreach a $args { - incr pos - switch -glob -- $a { - -- {break} - -regexp {set cmd ::fileutil::FindRegexp} - -glob {set cmd ::fileutil::FindGlob} - -* {return -code error "Unknown option $a"} - default {incr pos -1 ; break} - } - } - - set args [lrange $args $pos end] - - if {[llength $args] != 1} { - set pname [lindex [info level 0] 0] - return -code error \ - "wrong#args for \"$pname\", should be\ - \"$pname basedir ?-regexp|-glob? ?--? patterns\"" - } - - set patterns [lindex $args 0] - return [find $basedir [list $cmd $patterns]] -} - - -# ::fileutil::FindRegexp -- -# -# Internal helper. Filter command used by 'findByPattern' -# to match files based on regular expressions. -# -# Arguments: -# patterns List of regular expressions to match against. -# filename Name of the file to match against the patterns. -# Results: -# interesting A boolean flag. Set to true if the file -# matches at least one of the patterns. - -proc ::fileutil::FindRegexp {patterns filename} { - foreach p $patterns { - if {[regexp -- $p $filename]} { - return 1 - } - } - return 0 -} - -# ::fileutil::FindGlob -- -# -# Internal helper. Filter command used by 'findByPattern' -# to match files based on glob expressions. -# -# Arguments: -# patterns List of glob expressions to match against. -# filename Name of the file to match against the patterns. -# Results: -# interesting A boolean flag. Set to true if the file -# matches at least one of the patterns. - -proc ::fileutil::FindGlob {patterns filename} { - foreach p $patterns { - if {[string match $p $filename]} { - return 1 - } - } - return 0 -} - -# ::fileutil::stripPwd -- -# -# If the specified path references is a path in [pwd] (or [pwd] itself) it -# is made relative to [pwd]. Otherwise it is left unchanged. -# In the case of [pwd] itself the result is the string '.'. -# -# Arguments: -# path path to modify -# -# Results: -# path The (possibly) modified path. - -proc ::fileutil::stripPwd {path} { - - # [file split] is used to generate a canonical form for both - # paths, for easy comparison, and also one which is easy to modify - # using list commands. - - set pwd [pwd] - if {[string equal $pwd $path]} { - return "." - } - - set pwd [file split $pwd] - set npath [file split $path] - - if {[string match ${pwd}* $npath]} { - set path [eval file join [lrange $npath [llength $pwd] end]] - } - return $path -} - -# ::fileutil::stripN -- -# -# Removes N elements from the beginning of the path. -# -# Arguments: -# path path to modify -# n number of elements to strip -# -# Results: -# path The modified path - -proc ::fileutil::stripN {path n} { - set path [file split $path] - if {$n >= [llength $path]} { - return {} - } else { - return [eval file join [lrange $path $n end]] - } -} - -# ::fileutil::cat -- -# -# Tcl implementation of the UNIX "cat" command. Returns the contents -# of the specified file. -# -# Arguments: -# filename name of the file to read. -# -# Results: -# data data read from the file. - -proc ::fileutil::cat {filename} { - # Don't bother catching errors, just let them propagate up - set fd [open $filename r] - # Use the [file size] command to get the size, which preallocates memory, - # rather than trying to grow it as the read progresses. - set size [file size $filename] - if {$size} { - set data [read $fd $size] - } else { - # if the file has zero bytes it is either empty, or something - # where [file size] reports 0 but the file actually has data (like - # the files in the /proc filesystem on Linux) - set data [read $fd] - } - close $fd - return $data -} - -# ::fileutil::foreachLine -- -# -# Executes a script for every line in a file. -# -# Arguments: -# var name of the variable to contain the lines -# filename name of the file to read. -# cmd The script to execute. -# -# Results: -# None. - -proc ::fileutil::foreachLine {var filename cmd} { - upvar 1 $var line - set fp [open $filename r] - - # -future- Use try/eval from tcllib/control - catch { - set code 0 - set result {} - while {[gets $fp line] >= 0} { - set code [catch {uplevel 1 $cmd} result] - if {($code != 0) && ($code != 4)} {break} - } - } - close $fp - - if {($code == 0) || ($code == 3) || ($code == 4)} { - return $result - } - if {$code == 1} { - global errorCode errorInfo - return \ - -code $code \ - -errorcode $errorCode \ - -errorinfo $errorInfo \ - $result - } - return -code $code $result -} - -# ::fileutil::touch -- -# -# Tcl implementation of the UNIX "touch" command. -# -# touch [-a] [-m] [-c] [-r ref_file] [-t time] filename ... -# -# Arguments: -# -a change the access time only, unless -m also specified -# -m change the modification time only, unless -a also specified -# -c silently prevent creating a file if it did not previously exist -# -r ref_file use the ref_file's time instead of the current time -# -t time use the specified time instead of the current time -# ("time" is an integer clock value, like [clock seconds]) -# filename ... the files to modify -# -# Results -# None. -# -# Errors: -# Both of "-r" and "-t" cannot be specified. - -proc ::fileutil::touch {args} { - # Don't bother catching errors, just let them propagate up - - set options { - {a "set the atime only"} - {m "set the mtime only"} - {c "do not create non-existant files"} - {r.arg "" "use time from ref_file"} - {t.arg -1 "use specified time"} - } - set usage ": [lindex [info level 0] 0] \[options] filename ...\noptions:" - array set params [::cmdline::getoptions args $options $usage] - - # process -a and -m options - set set_atime [set set_mtime "true"] - if { $params(a) && ! $params(m)} {set set_mtime "false"} - if {! $params(a) && $params(m)} {set set_atime "false"} - - # process -r and -t - set has_t [expr {$params(t) != -1}] - set has_r [expr {[string length $params(r)] > 0}] - if {$has_t && $has_r} { - return -code error "Cannot specify both -r and -t" - } elseif {$has_t} { - set atime [set mtime $params(t)] - } elseif {$has_r} { - file stat $params(r) stat - set atime $stat(atime) - set mtime $stat(mtime) - } else { - set atime [set mtime [clock seconds]] - } - - # do it - foreach filename $args { - if {! [file exists $filename]} { - if {$params(c)} {continue} - close [open $filename w] - } - if {$set_atime} {file atime $filename $atime} - if {$set_mtime} {file mtime $filename $mtime} - } - return -} - -# ::fileutil::fileType -- -# -# Do some simple heuristics to determine file type. -# -# -# Arguments: -# filename Name of the file to test. -# -# Results -# type Type of the file. May be a list if multiple tests -# are positive (eg, a file could be both a directory -# and a link). In general, the list proceeds from most -# general (eg, binary) to most specific (eg, gif), so -# the full type for a GIF file would be -# "binary graphic gif" -# -# At present, the following types can be detected: -# -# directory -# empty -# binary -# text -# script -# executable elf -# binary graphic [gif, jpeg, png, tiff] -# ps, eps, pdf -# html -# xml -# message pgp -# bzip, gzip -# gravity_wave_data_frame -# link -# - - -proc ::fileutil::fileType {filename} { - ;## existence test - if { ! [ file exists $filename ] } { - set err "file not found: '$filename'" - return -code error $err - } - ;## directory test - if { [ file isdirectory $filename ] } { - set type directory - if { ! [ catch {file readlink $filename} ] } { - lappend type link - } - return $type - } - ;## empty file test - if { ! [ file size $filename ] } { - set type empty - if { ! [ catch {file readlink $filename} ] } { - lappend type link - } - return $type - } - set bin_rx {[\x00-\x08\x0b\x0e-\x1f]} - - if { [ catch { - set fid [ open $filename r ] - fconfigure $fid -translation binary - fconfigure $fid -buffersize 1024 - fconfigure $fid -buffering full - set test [ read $fid 1024 ] - ::close $fid - } err ] } { - catch { ::close $fid } - return -code error "::fileutil::fileType: $err" - } - - if { [ regexp $bin_rx $test ] } { - set type binary - set binary 1 - } else { - set type text - set binary 0 - } - if { [ regexp {^\#\!(\S+)} $test -> terp ] } { - lappend type script $terp - } elseif { $binary && [ regexp {^[\x7F]ELF} $test ] } { - lappend type executable elf - } elseif { $binary && [string match "BZh91AY\&SY*" $test] } { - lappend type compressed bzip - } elseif { $binary && [string match "\x1f\x8b*" $test] } { - lappend type compressed gzip - } elseif { $binary && [string match "GIF*" $test] } { - lappend type graphic gif - } elseif { $binary && [string match "\x89PNG*" $test] } { - lappend type graphic png - } elseif { $binary && [string match "\xFF\xD8\xFF\xE0\x00\x10JFIF*" $test] } { - lappend type graphic jpeg - } elseif { $binary && [string match "MM\x00\**" $test] } { - lappend type graphic tiff - } elseif { $binary && [string match "\%PDF\-*" $test] } { - lappend type pdf - } elseif { ! $binary && [string match -nocase "*\*" $test] } { - lappend type html - } elseif { [string match "\%\!PS\-*" $test] } { - lappend type ps - if { [string match "* EPSF\-*" $test] } { - lappend type eps - } - } elseif { [string match -nocase "*\<\?xml*" $test] } { - lappend type xml - if { [ regexp -nocase {\<\!DOCTYPE\s+(\S+)} $test -> doctype ] } { - lappend type $doctype - } - } elseif { [string match {*BEGIN PGP MESSAGE*} $test] } { - lappend type message pgp - } elseif { $binary && [string match {IGWD*} $test] } { - lappend type gravity_wave_data_frame - } - ;## lastly, is it a link? - if { ! [ catch {file readlink $filename} ] } { - lappend type link - } - return $type -} DELETED modules/fileutil/fileutil.test Index: modules/fileutil/fileutil.test ================================================================== --- modules/fileutil/fileutil.test +++ /dev/null @@ -1,515 +0,0 @@ -# -*- tcl -*- -# Tests for the find function. -# -# Sourcing this file into Tcl runs the tests and generates output for errors. -# No output means no errors were found. -# -# Copyright (c) 1998-2000 by Ajuba Solutions. -# Copyright (c) 2001 by ActiveState Tool Corp. -# All rights reserved. -# -# RCS: @(#) $Id: fileutil.test,v 1.12 2003/04/02 23:21:12 andreas_kupries Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} -puts "tcltest [package present tcltest]" - -if { [lsearch $auto_path [file dirname [info script]]] == -1 } { - set auto_path [linsert $auto_path 0 [file dirname [info script]]] -} - -package require fileutil -puts "fileutil [package present fileutil]" - -# Build a sample tree to search -# Structure -# -# dir -# +--find1 -# +--find2 -# | +--file2 -# +--file1 - -catch {removeDirectory find1} ; # start with a clean structure! - -makeDirectory find1 -makeDirectory [file join find1 find2] -makeFile "" [file join find1 file1] -makeFile "test" [file join find1 find2 file2] -set dir $::tcltest::temporaryDirectory - -proc fileIsBiggerThan {s f} { - expr {![file isdirectory $f] && [file size $f] > $s} -} - -test find-1.1 {standard recursive find} { - lsort [fileutil::find [file join $dir find1]] -} [list [file join $dir find1 file1] [file join $dir find1 find2] \ - [file join $dir find1 find2 file2]] -test find-1.2 {find directories} { - fileutil::find [file join $dir find1] {file isdirectory} -} [list [file join $dir find1 find2]] -test find-1.3 {find files bigger than a given size} { - fileutil::find [file join $dir find1] {fileIsBiggerThan 1} -} [list [file join $dir find1 find2 file2]] - - -# Extend the previous sample tree -# Extended structure: -# -# dir -# +--find1 -# +--find2 <----------+ -# | +--file2 | -# | +--file3 --> ../find2 -+ -# +--file1 - -test find-1.4 {handling of circular links} {unix} { - catch {file delete -force [file join $dir find1 find2 file3]} - exec ln -s ../find2 [file join $dir find1 find2 file3] - - # Find has to skip 'file3' - lsort [fileutil::find [file join $dir find1]] -} [list [file join $dir find1 file1] [file join $dir find1 find2] \ - [file join $dir find1 find2 file2]] - - -# find by pattern tests - -test find-2.0 {find by pattern} { - catch {::fileutil::findByPattern $dir -glob {fil*} foo} msg - set msg -} {wrong#args for "::fileutil::findByPattern", should be "::fileutil::findByPattern basedir ?-regexp|-glob? ?--? patterns"} - -test find-2.1 {find by pattern} { - catch {::fileutil::findByPattern $dir -glob} msg - set msg -} {wrong#args for "::fileutil::findByPattern", should be "::fileutil::findByPattern basedir ?-regexp|-glob? ?--? patterns"} - -test find-2.2 {find by pattern} { - lsort [::fileutil::findByPattern [file join $dir find1] -glob {fil*}] -} [list [file join $dir find1 file1] [file join $dir find1 find2 file2]] - -test find-2.3 {find by pattern} { - lsort [::fileutil::findByPattern [file join $dir find1] -regexp {.*1$}] -} [list [file join $dir find1 file1]] - - -catch {removeDirectory grepTest} ; # start with a clean structure! - -# Build a sample tree to search -makeDirectory grepTest -makeFile "zoop" [file join $dir grepTest file1] -makeFile "zoo\nbart" [file join $dir grepTest file2] - -test grep-1.1 {normal grep} { - lsort [fileutil::grep "zoo" [glob [file join $dir grepTest *]]] -} [list "[file join $dir grepTest file1]:1:zoop" \ - "[file join $dir grepTest file2]:1:zoo"] -test grep-1.2 {more restrictive grep} { - lsort [fileutil::grep "zoo." [glob [file join $dir grepTest *]]] -} [list "[file join $dir grepTest file1]:1:zoop"] -test grep-1.3 {more restrictive grep} { - lsort [fileutil::grep "bar" [glob [file join $dir grepTest *]]] -} [list "[file join $dir grepTest file2]:2:bart"] - -makeDirectory catTest -makeFile "foo\nbar\nbaz\n" [file join $dir catTest file1] -test cat-1.1 {cat} { - fileutil::cat [file join $dir catTest file1] -} "foo\nbar\nbaz\n" - - -test foreachline-1.0 {foreachLine} { - set res "" - ::fileutil::foreachLine line [file join $dir catTest file1] { - append res /$line - } - set res -} {/foo/bar/baz} - - - -catch {removeDirectory touchTest} ; # start with a clean structure! -makeDirectory touchTest -makeFile "blah" [file join $dir touchTest file1] - -test touch-1.1 {create file} { - set f [file join $dir touchTest here] - fileutil::touch $f - # reap this file on cleanup - lappend ::tcltest::filesmade $f - file exists $f -} 1 -test touch-1.2 {'-c' prevents file creation} { - set f [file join $dir touchTest nothere] - fileutil::touch -c $f - file exists $f -} 0 -test touch-1.3 {'-c' has no effect on existing files} { - set f [file join $dir touchTest file1] - fileutil::touch -c $f - file exists $f -} 1 -test touch-1.4 {test relative times} { - set f [file join $dir touchTest file1] - fileutil::touch $f - set a1 [file atime $f] - set m1 [file mtime $f] - after 1001 - fileutil::touch $f - set a2 [file atime $f] - set m2 [file mtime $f] - list [expr {$a1 == $m1}] [expr {$a2 == $m2}] [expr {$a1 < $a2}] [expr {$m1 < $m2}] -} [list 1 1 1 1] -test touch-1.5 {test relative times using -a} { - set f [file join $dir touchTest file1] - fileutil::touch $f - set a1 [file atime $f] - set m1 [file mtime $f] - after 1001 - fileutil::touch -a $f - set a2 [file atime $f] - set m2 [file mtime $f] - list [expr {$a1 == $m1}] [expr {$a2 == $m2}] [expr {$a1 < $a2}] [expr {$m1 < $m2}] -} [list 1 0 1 0] -test touch-1.6 {test relative times using -m} { - set f [file join $dir touchTest file1] - fileutil::touch $f - set a1 [file atime $f] - set m1 [file mtime $f] - after 1001 - fileutil::touch -m $f - set a2 [file atime $f] - set m2 [file mtime $f] - list [expr {$a1 == $m1}] [expr {$a2 == $m2}] [expr {$a1 < $a2}] [expr {$m1 < $m2}] -} [list 1 0 0 1] -test touch-1.7 {test relative times using -a and -m} { - set f [file join $dir touchTest file1] - fileutil::touch $f - set a1 [file atime $f] - set m1 [file mtime $f] - after 1001 - fileutil::touch -a -m $f - set a2 [file atime $f] - set m2 [file mtime $f] - list [expr {$a1 == $m1}] [expr {$a2 == $m2}] [expr {$a1 < $a2}] [expr {$m1 < $m2}] -} [list 1 1 1 1] -test touch-1.8 {test -t} { - set f [file join $dir touchTest file1] - fileutil::touch $f - after 1001 - fileutil::touch -t 42 $f - set a1 [file atime $f] - set m1 [file mtime $f] - list [expr {$a1 == 42}] [expr {$m1 == 42}] -} [list 1 1] -test touch-1.9 {test -t with -a} { - set f [file join $dir touchTest file1] - fileutil::touch $f - after 1001 - fileutil::touch -t 42 -a $f - set a1 [file atime $f] - set m1 [file mtime $f] - list [expr {$a1 == 42}] [expr {$m1 == 42}] -} [list 1 0] -test touch-1.10 {test -t with -m} { - set f [file join $dir touchTest file1] - fileutil::touch $f - after 1001 - fileutil::touch -t 42 -m $f - set a1 [file atime $f] - set m1 [file mtime $f] - list [expr {$a1 == 42}] [expr {$m1 == 42}] -} [list 0 1] -test touch-1.11 {test -t with -a and -m} { - set f [file join $dir touchTest file1] - fileutil::touch $f - after 1001 - fileutil::touch -t 42 -a -m $f - set a1 [file atime $f] - set m1 [file mtime $f] - list [expr {$a1 == 42}] [expr {$m1 == 42}] -} [list 1 1] -test touch-1.12 {test -r} { - set r [info script] - set f [file join $dir touchTest file1] - fileutil::touch $f - after 1001 - fileutil::touch -r $r $f - set a1 [file atime $f] - set m1 [file mtime $f] - list [expr {$a1 == [file atime $r]}] [expr {$m1 == [file mtime $r]}] -} [list 1 1] -test touch-1.13 {test -r with -a} { - set r [info script] - set f [file join $dir touchTest file1] - fileutil::touch $f - after 1001 - fileutil::touch -r $r -a $f - set a1 [file atime $f] - set m1 [file mtime $f] - list [expr {$a1 == [file atime $r]}] [expr {$m1 == [file mtime $r]}] -} [list 1 0] -test touch-1.14 {test -r with -m} { - set r [info script] - set f [file join $dir touchTest file1] - fileutil::touch $f - after 1001 - fileutil::touch -r $r -m $f - set a1 [file atime $f] - set m1 [file mtime $f] - list [expr {$a1 == [file atime $r]}] [expr {$m1 == [file mtime $r]}] -} [list 0 1] -test touch-1.15 {test -r with -a and -m} { - set r [info script] - set f [file join $dir touchTest file1] - fileutil::touch $f - after 1001 - fileutil::touch -r $r -m -a $f - set a1 [file atime $f] - set m1 [file mtime $f] - list [expr {$a1 == [file atime $r]}] [expr {$m1 == [file mtime $r]}] -} [list 1 1] - - -catch {removeDirectory fileTypeTest} ; # start with a clean structure! -makeDirectory fileTypeTest -fileutil::touch [file join $dir fileTypeTest emptyFile] - -makeFile "\u0000" [file join $dir fileTypeTest binaryFile] - -set elfData "\x7F" -append elfData "ELF" -append elfData "\x01\x01\x01\x00\x00" -makeFile $elfData [file join $dir fileTypeTest elfFile] - -set bzipData "BZh91AY&SY" -append bzipData "\x01\x01\x01\x00\x00" -makeFile $bzipData [file join $dir fileTypeTest bzipFile] - -set gzipData "\x1f\x8b" -append gzipData "\x01\x01\x01\x00\x00" -makeFile $gzipData [set f [file join $dir fileTypeTest gzipFile]] -set fh [open $f w] ; fconfigure $fh -encoding binary ; puts -nonewline $fh $gzipData ; close $fh - -set jpgData "\xFF\xD8\xFF\xE0\x00\x10JFIF" -append jpgData "\x00\x01\x02\x01\x01\x2c" -makeFile $jpgData [file join $dir fileTypeTest jpegFile] - -set gifData "GIF89a\x2b\x00\x40\x00\xf7\xff\x00" -makeFile $gifData [file join $dir fileTypeTest gifFile] - -set pngData "\x89PNG" -append pngData "\x00\x01\x02\x01\x01\x2c" -makeFile $pngData [set f [file join $dir fileTypeTest pngFile]] -set fh [open $f w] ; fconfigure $fh -encoding binary ; puts -nonewline $fh $pngData ; close $fh - -set tiffData "MM\x00\*" -append tiffData "\x00\x01\x02\x01\x01\x2c" -makeFile $tiffData [file join $dir fileTypeTest tiffFile] - -set psData "%!PS-" -append psData "ADOBO-123 EPSF-1.4" -makeFile $psData [file join $dir fileTypeTest psFile] - -set pdfData "%PDF-" -append pdfData "1.2 \x00\x01\x02\x01\x01\x2c" -makeFile $pdfData [file join $dir fileTypeTest pdfFile] - -set epsData $psData -makeFile $psData [file join $dir fileTypeTest epsFile] - -set igwdData "IGWD" -append igwdData "\x00\x01\x02\x01\x01\x2c" -makeFile $igwdData [file join $dir fileTypeTest igwdFile] - -makeFile "simple text" [file join $dir fileTypeTest textFile] -makeFile "#!/bin/tclsh" [file join $dir fileTypeTest scriptFile] -makeFile "" [file join $dir fileTypeTest htmlFile] - -set xmlData { - - -} - -set xmlDataWithDTD { - - - -} - -makeFile $xmlData [file join $dir fileTypeTest xmlFile] -makeFile $xmlDataWithDTD [file join $dir fileTypeTest xmlWithDTDFile] - -set pgpData {-----BEGIN PGP MESSAGE----- -Version: PGP 6.5.8 - -abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz -} - -makeFile $pgpData [file join $dir fileTypeTest pgpFile] - -test fileType-1.1 {test file non-existance} { - set f [file join $dir fileTypeTest bogus] - set res [catch {fileutil::fileType $f} msg] - list $res $msg -} [list 1 "file not found: '[file join $dir fileTypeTest bogus]'"] -test fileType-1.2 {test file directory} { - set f [file join $dir fileTypeTest] - set res [catch {fileutil::fileType $f} msg] - list $res $msg -} [list 0 [list directory]] -test fileType-1.3 {test file empty} { - set f [file join $dir fileTypeTest emptyFile] - set res [catch {fileutil::fileType $f} msg] - list $res $msg -} [list 0 [list empty]] -test fileType-1.4 {test simple binary} { - set f [file join $dir fileTypeTest binaryFile] - set res [catch {fileutil::fileType $f} msg] - list $res $msg -} [list 0 [list binary]] -test fileType-1.5 {test elf executable} { - set f [file join $dir fileTypeTest elfFile] - set res [catch {fileutil::fileType $f} msg] - list $res $msg -} [list 0 [list binary executable elf]] -test fileType-1.6 {test simple text} { - set f [file join $dir fileTypeTest textFile] - set res [catch {fileutil::fileType $f} msg] - list $res $msg -} [list 0 [list text]] -test fileType-1.7 {test script file} { - set f [file join $dir fileTypeTest scriptFile] - set res [catch {fileutil::fileType $f} msg] - list $res $msg -} [list 0 [list text script /bin/tclsh]] -test fileType-1.8 {test html text} { - set f [file join $dir fileTypeTest htmlFile] - set res [catch {fileutil::fileType $f} msg] - list $res $msg -} [list 0 [list text html]] -test fileType-1.9 {test xml text} { - set f [file join $dir fileTypeTest xmlFile] - set res [catch {fileutil::fileType $f} msg] - list $res $msg -} [list 0 [list text xml]] -test fileType-1.10 {test xml with dtd text} { - set f [file join $dir fileTypeTest xmlWithDTDFile] - set res [catch {fileutil::fileType $f} msg] - list $res $msg -} [list 0 [list text xml foobar]] -test fileType-1.11 {test PGP message} { - set f [file join $dir fileTypeTest pgpFile] - set res [catch {fileutil::fileType $f} msg] - list $res $msg -} [list 0 [list text message pgp]] -test fileType-1.12 {test binary graphic jpeg} { - set f [file join $dir fileTypeTest jpegFile] - set res [catch {fileutil::fileType $f} msg] - list $res $msg -} [list 0 [list binary graphic jpeg]] -test fileType-1.13 {test binary graphic gif} { - set f [file join $dir fileTypeTest gifFile] - set res [catch {fileutil::fileType $f} msg] - list $res $msg -} [list 0 [list binary graphic gif]] -test fileType-1.14 {test binary graphic png} { - set f [file join $dir fileTypeTest pngFile] - set res [catch {fileutil::fileType $f} msg] - list $res $msg -} [list 0 [list binary graphic png]] -test fileType-1.15 {test binary graphic tiff} { - set f [file join $dir fileTypeTest tiffFile] - set res [catch {fileutil::fileType $f} msg] - list $res $msg -} [list 0 [list binary graphic tiff]] -test fileType-1.16 {test binary pdf} { - set f [file join $dir fileTypeTest pdfFile] - set res [catch {fileutil::fileType $f} msg] - list $res $msg -} [list 0 [list binary pdf]] -test fileType-1.17 {test text ps} { - set f [file join $dir fileTypeTest psFile] - set res [catch {fileutil::fileType $f} msg] - list $res $msg -} [list 0 [list text ps eps]] -test fileType-1.18 {test text eps} { - set f [file join $dir fileTypeTest epsFile] - set res [catch {fileutil::fileType $f} msg] - list $res $msg -} [list 0 [list text ps eps]] -test fileType-1.19 {test binary gravity_wave_data_frame} { - set f [file join $dir fileTypeTest igwdFile] - set res [catch {fileutil::fileType $f} msg] - list $res $msg -} [list 0 [list binary gravity_wave_data_frame]] -test fileType-1.20 {test binary compressed bzip} { - set f [file join $dir fileTypeTest bzipFile] - set res [catch {fileutil::fileType $f} msg] - list $res $msg -} [list 0 [list binary compressed bzip]] -test fileType-1.21 {test binary compressed gzip} { - set f [file join $dir fileTypeTest gzipFile] - set res [catch {fileutil::fileType $f} msg] - list $res $msg -} [list 0 [list binary compressed gzip]] - - - -# stripPwd/N ----------------------------------------------------- -# dir = $::tcltest::temporaryDirectory = current working directory - -test stripPwd-1.0 {unrelated path} { - fileutil::stripPwd find1 -} find1 - -test stripPwd-1.1 {pwd-relative path} { - fileutil::stripPwd [file join [pwd] $dir find1] -} find1 - -test stripPwd-1.2 {pwd-relative path} { - fileutil::stripPwd [file join [pwd] $dir find1 find2] -} [file join find1 find2] - -test stripPwd-1.3 {pwd itself} { - fileutil::stripPwd [pwd] -} . - - -test stripN-1.0 {remove nothing} { - fileutil::stripN find1 0 -} find1 - -test stripN-1.1 {remove all} { - fileutil::stripN find1 1 -} {} - -test stripN-1.2 {remove more than existing} { - fileutil::stripN find1 2 -} {} - -test stripN-2.0 {remove nothing} { - fileutil::stripN [file join find1 find2] 0 -} [file join find1 find2] - -test stripN-2.1 {remove part} { - fileutil::stripN [file join find1 find2] 1 -} find2 - -test stripN-2.2 {remove all} { - fileutil::stripN [file join find1 find2] 2 -} {} - -test stripN-2.3 {remove more than existing} { - fileutil::stripN [file join find1 find2] 3 -} {} - - -# ---------------------------------------------------------------- - -::tcltest::cleanupTests -return DELETED modules/fileutil/pkgIndex.tcl Index: modules/fileutil/pkgIndex.tcl ================================================================== --- modules/fileutil/pkgIndex.tcl +++ /dev/null @@ -1,12 +0,0 @@ -# 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. - -if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded fileutil 1.5 [list source [file join $dir fileutil.tcl]] DELETED modules/ftp/ChangeLog Index: modules/ftp/ChangeLog ================================================================== --- modules/ftp/ChangeLog +++ /dev/null @@ -1,407 +0,0 @@ -2003-04-11 Andreas Kupries - - * ftp.tcl: - * ftp.man: - * ftp_geturl.tcl: - * pkgIndex.tcl: Fixed bug #614591. Set version of the package to - to 2.4. Set version of geturl package to 0.2. - -2003-03-31 Andreas Kupries - - * ftp.tcl (ModTime): Applied patch #659238 supplied by Dan Rogahn - to allow setting the - modification time of a file, assuming the server allows this as - well. - -2003-03-18 Pat Thoyts - - * ftp.tcl (ftp::InitDataConn): revert -regexp to fix bug 701288. - -2003-02-24 David N. Welton - - * ftp.tcl (ftp::OpenControlConn): Use string map instead of - regsub. - -2003-01-28 David N. Welton - - * ftp.tcl (ftp::InitDataConn): Use 'string match' instead of - regexp. - -2003-01-16 Andreas Kupries - - * ftp.man: More semantic markup, less visual one. - -2002-08-30 Andreas Kupries - - * examples (hpupdate.tcl): Updated 'info exist' to 'info exists'. - -2002-08-21 Andreas Kupries - - * ftpdemo.tcl (Examples): Changed ftp.tcl to ftpdemo.tcl in - [test_40afile] and [test_70append]. Problem found and reported - by Jussi Kuosa . - -2002-08-06 Andreas Kupries - - * ftp.tcl: Fixed SF Bug #582668, reported by Frank Richter - . - -2002-03-21 Andreas Kupries - - * ftp.man: New, doctools manpage. - -2002-02-14 Andreas Kupries - - * ftp.tcl: Frink run. - - * ftp: Version is now 2.3.1 to distinguish this from the code in - tcllib release 1.2 - -2002-01-26 Pat Thoyts - - * ftp_geturl.tcl: Re-opened FR #476804 to add support for - username and password and for non-unix based FTP servers. - -2002-01-16 Andreas Kupries - - * Bumped version to 2.3 - -2002-01-16 Andreas Kupries - - * ftp.tcl: Fix for bug #503471. The commands Get, Reget, and Newer - now check if the directory the local file is to be placed in - does exist. They now immediately throw an error if the directory - does not exist instead of starting the download and getting - confused. - - * ftp.n: Typo fix. Updates in the descriptions of Get, Reget, and - Newer explaining the new behaviour, s.a. - -2001-11-20 Joe English - - * ftp.n: (r1.6 -> r1.8) Update for bug report #474999 - "ftp man page description typo" -- attempt to clarify - description of "ftp::List" command. Also fixed minor - markup errors. - -2001-11-19 Andreas Kupries - - * ftp.tcl: Tested implementation of FR #481161. Fixed the errors - found that way (incomplete cleanup by 'Get', interfered with the - following 'Put' command). - -2001-11-16 Andreas Kupries - - * ftp.tcl, ftp.n: Implemented and documented FR #481161. - - * ftp.tcl: Applied patch #428053 provided by Sreangsu Acharyya - . The patch extends 'Reget' to allow - download of an exactly specified slice of the the source - file. This enables the implementation of a 'resume' after a - partial download and also the parallel download of - non-overlaping parts of the same file from different servers. - - * ftp.n: updated documentation to cover the new code above and - below. - - * ftp_geturl.tcl: New file, provides a geturl command for use by - uri. Declared in a separate package to avoid a cyclic dependency - between the ftp and uri packages. The uri package is changed to - try for a scheme::geturl package first and then for a scheme - package to get the desired functionality. Implements FR #476804. - -2001-11-06 Andreas Kupries - - * ftp.tcl: Applied patch in #478478 to handle non-standard date - information from servers with a buggy y2k patch. 2001 is - rendered as 19101 (19*100 + 101 = 2001). - -2001-11-04 Andreas Kupries - - * ftp.n: Updated description of DisplayMsg to the changed - behaviour and added a discussion of what happens should it throw - errors. Also added a description of option -output to the - description of ftp::Open. - - * ftp.tcl: Fixed bug #476729. Instead of describing the behaviour - of the default 'DisplayMsg' the procedure is changed instead to - throw no errors, and to use the log module of tcllib. Thanks to - Larry Virden for pointing out - the deficiencies in the documentation. - -2001-10-20 Andreas Kupries - - * ftp.tcl: Fixed bug #466746. Reporter of bug unknown, provided - fix too. Problem was incomplete handling of [gets] return - values. Value -1 signaling an incomplete line was not handled. - -2001-10-16 Andreas Kupries - - * ftp.n: - * ftp.tcl: - * pkgIndex.tcl: Version up to 2.2.1. - -2001-09-17 Andreas Kupries - - * example/hpupdate.tcl: Some cleanups in the example code, - provided by Larry Virden . This - fixes [440064]. - -2001-09-12 Andreas Kupries - - * Added manpages for ftp package. - -2001-08-01 Don Porter - - * example/hpupdate.tcl: Workaround for moving Tk internal - command [tkButtonInvoke]. [Bug 450914] - -2001-08-01 Jeff Hobbs - - * ftp.tcl: added eval in ftp::List wrapper when used in tkcon. - [Bug: #439779] (loring) - -2001-07-10 Andreas Kupries - - * ftp.tcl: Frink 2.2 run, fixed dubious code. - -2001-06-21 Andreas Kupries - - * ftpdemo.tcl: - * ftp.tcl: Fixed dubious code reported by frink. - -2000-10-01 Dan Kuchler - - * ftp.tcl: Moved the call to 'DisplayMsg' from inside of the - fileevent loop (in ftp::StateHandler) to WaitorTimeout. Now - errors that occur in StateHandler won't be thrown until after the - the asynchronous (fileevent) portion of the code has completed. - ftp::OpenActiveConn and ftp::OpenPassiveConn can both still generate - errors in the event loop, which will cause a bgerror to be thrown. - Added some (untested) code to support Tenex mode ftp transfers. So - far tenex mode sends across 'TYPE L', and then does the transfer with - a binary encoded channel. Since I don't have a tenex system to test - it with, this feature is very alpha at this point. - -2000-09-28 Dan Kuchler - - * ftp.tcl: Fixed a line of code in the "list_close" state of StateHandler, - switching a ![info exists... to [info exists... - -2000-09-25 Sandeep Tamhankar - - * ftp.tcl: Fixed a line of code in the "connect" state of StateHandler, - switching a ![info exists... to [info exists... It was originally - stack tracing when opening a connection. - -2000-08-29 Steve Ball - - * README - * ftp.tcl - * pkgIndex.tcl - * docs/Open.html: Added '-command' configuration to the Open - command. This option indicates that all operations performed - on this connection are to be made asynchronously. The value - given to the option is a script which is invoked when operations - have finished. Updated documentation and bumped the version - number from 2.1 to 2.2 because a new feature was added. - -2000-08-16 Dan Kuchler - - * README - * ftp.tcl - * pkgIndex.tcl - * docs/*.html: Added new optional arguments to the Get, Put, and - Append commands. The Append and Put commands have a new optional - argument '-data "data"' that can be used to specify data to transfer - instead of transferring data from a local file. The Get command has - a new optional argument '-variable varname' that specifies a variable - to store the retrieved data into, that can be used instead of - specifying a local filename. Updated the documentation to reflect - the changes and bumped the version number from 2.0 to 2.1 because - new features were added. - - -2000-08-10 Dan Kuchler - - * ftp.tcl - * pkgIndex.tcl: Fixed the ftp package to allow for - the destination location of the ftp::Get command to - be a directory as well as a file. - -2000-07-08 Dan Kuchler - - * README - * ftp.tcl - * ftpdemo.tcl - * pkgIndex.tcl - * example/README - * example/hpupdate.tcl - * example/mirror.tcl - * example/newer.tcl - * docs/*.html: Updated for the change of ftp_lib.tcl -> ftp.tcl, for - the change of ftp_demo.tcl to ftpdemo.tcl, and for the FTP namespace - change. Made lots of fixes to complete the partially done work to - make ftp handle multiple concurrent ftps at the same time. Updated the - version in the docs, examples, source, and pkgIndex to be version 2.0 - -2000-06-02 Eric Melski - - * ftp.tcl: Changed namespace to ftp (from FTP). Updated license - information. Renamed ftp_lib.tcl to ftp.tcl in preparation for - inclusion in tcllib. - -1999-12-31 Peter MacDonald - * ftp_lib.tcl: Modified to allow multiple concurrent ftps at the same - time. Unfortunately this is incompatible with the old procs. - Rewrite proc headers to be declared outside namespace eval. - Incremented version to 2.0. - --------------------------- Released 1.2 ----------------------------- - -1999-04-30 Steffen Traeger - - * ftp_lib.tcl: added new FTP command FTP::Append to append local - files to remote files. - - * ftp_lib.tcl: Added TkCon support to make FTP::List inside TkCon - more readable. - - * ftp_lib.tcl: In some strange cases ftp_lib overlaps the state - machine, to prevent this the state handler disables fileevents on - control socket a the beginning and enables it again at the end - (this failure comes with an earlier release of tkcon, it is only a - debugging feature now and commented). - - * examples/*.tcl: Store the example files in a separate directory. - --------------------------- Released 1.12 ---------------------------- - -1999-02-28 Steffen Traeger - - * ftp_lib.tcl: Disabled remote Abort command, it doesn't work. - Insert an internal CloseDataConn command instaed of Abort. - Get/Reget: create local file only if the remote file really - exist. Fix major bug for passive mode that ftp_lib blocks in - every cases if file or directory doesn't exist at the remote - machine, THANKS to Brian Lalo - for his investigation. Added current namespace prefix to - InitDataConn procedure. - -1999-01-31 Steffen Traeger - - * ftp_lib.tcl: Changed return values of the FTP::Quote command, - sent back the string it received instead of any parsing THANKS - Keith Vetter for his patch. Improved - buffer mechanism in StateHandler, buffer represents the whole - received data. VERBOSE variable controlled output now will be - handled by the package not by the application. New online HTML - help files are available under the directory docs. - -1998-11-30 Steffen Traeger - - * ftp_lib.tcl: Can now also operate in the passive data transfer - mode, added "PASV" ability for every command that uses data - connection. Improved procedure return codes for a better error - handling. Restore correct type after switching to ascii mode in - FTP::List and FTP::NList. Insert a hook for using a graphical - progress bar that shows the elapsed time. Added new command - FTP::FileSize which gets the file size of the file on the remote - machine. FTP::Newer now is able to compare the modification date - of a remote file with the date of any local file. Enabled DEBUG - variable displays in additional the real FTP commands (old VERBOSE - feature). Signification of the VERBOSE variable is changed, if - enabled it shows the responses from the remote server. Allows to - call FTP::Cd without any parameter. Include some examples in - ftp_lib distribution. - -1998-05-31 Steffen Traeger - - * ftp_lib.tcl: Fixed a little bug in FTP::Open that makes it not - possible to use this procedure in a proc (upvar #0 ..) - -1998-03-31 Steffen Traeger - - * ftp_lib.tcl: Non-Blocking I/O of the control channel doesn't - work on Windows, changed to block the I/O channel - --------------------------- Released 1.0 ----------------------------- - -1998-03-30 Steffen Traeger - - * ftp_lib.tcl: Complete redesign to handle timeouts after - specified amount of time. Added new FTP command FTP::Quote for - sending verbatim commands to the FTP server THANKS to Ron Zajac - for inspiration - --------------------------- Released 0.9 ----------------------------- - -1998-02-28 Steffen Traeger - - * ftp_lib.tcl: Uses only the highest-order digit of the 3-digit - reply code for switching in procedure StateHandler. Added new FTP - command FTP::ModTime to show the last modification time of a file - on the remote machine. THANKS to Bill Thorson - for the patch. Added new - FTP command FTP::Newer to get remote file only if it is newer than - local file. DEBUG flag. VERBOSE flag. Added two options for - FTP::Open command: -timeout seconds, sets up timeout; -blocksize - size, writes "size" bytes at once. Procedure DisplayMsg now is - provided to display in different colors. - -0.84 (02/98) ------------ -- FTP commands now runs only if control connection is available -- changed ls-output, removed "total"-line and blank lines from - the list - -0.83 (02/98) ------------ -- changed the FTP::NList command to query data of empty directories -- added new FTP command FTP::Reget to skip over big files after - broken file transfer - THANKS to Paulo da Silva for help -- specially interpretation of the 421 reply code ("Service - not available, closing control connection"), it is necessary - for reget - -0.82 (12/97) ------------ -- added current namespace prefix to CopyNext procedure, - because of ftp_lib doesn't work correctly with tlc/tk8.0p2 - -0.81 (08/97) ------------ -- replaced tkwait with vwait, this allows only to use - tcl shell for FTP library - -0.8 (07/97) ------------ -- redesigned to support namespace -- added simple installation program -- modified to support the tcl package specification - -0.7 (06/97) ------------ -- changed to tcl/tk version 8.0 -- used the new fcopy command to transfer binary data - -0.6 (02/97) ------------ -- bugfix: close data socket after every data transfer -- added the rename command - -0.5 (02/97) ------------ -- bugfixes -- added directory manipulation commands - -0.4 (02/97) ------------ -- changed to tcl7.6/tk4.2 -- added put/get commands - -0.1 - 0.3 (01/97) ------------------ -- ??? - DELETED modules/ftp/README Index: modules/ftp/README ================================================================== --- modules/ftp/README +++ /dev/null @@ -1,80 +0,0 @@ -========================= -ftp 2.3 (08/16/2000) -========================= - -files: - - README - this file - ChangeLog - change log - - ftp.tcl - ftp library package - ftpdemo.tcl - ftp test program - pkgIndex.tcl - package index file for ftp package - - example/README - Overview of the example scripts - example/hpupdate.tcl - ftp example "homepage update" - example/mirror.tcl - ftp example "directoy mirror" - example/newer.tcl - ftp example "software update" - - docs/*html - HTML manual pages - -1. Introduction -=============== - -In order to speed up the update of homepage files on the ftp server of -my ISP, in spring of 1996 I looked for a useful solution. In those days -I worked with Linux and used the Linux inside ftp tool. -As fan of Tcl/Tk 'expect' was my next choice. It is excelently -suitabled to control interactive processes like ftp sessions. -A little bit more Tcl/Tk source and hpupdate 0.1 was ready, a script -for the automatical update of homepage files without subdirectories. - -In the beginning of 1997 I was intense employed with RFC 959. -Simultaneous I played with the Tcl socket command. Thus the -FTP library for Tcl was developed... - - -2. Overview -=============== - -The FTP Library Package extends tcl/tk with commands to support the -FTP protocol. The library package is 100% tcl code, no extensions, no -C stuff. It is easily to include in programs with - - package require ftp 2.2 - -Now everybody can write an own ftp program with an own GUI. It works -with Windows, UNIX, and also, but not tested on Mac. The ftp package -makes it comfortable and quick to create small tcl scripts for downloading -files or directory trees. The ftp::Open command creates a session handle for -each connection, and that handle is then used as the first argument to the -rest of the commands. - - Supports the following commands: - - ftp::Open - ftp::Close - ftp::Cd - ftp::Pwd - ftp::Type - ftp::List - ftp::NList - ftp::FileSize - ftp::ModTime - ftp::Delete - ftp::Rename - ftp::Put <(local | -data "data")> - ftp::Append <(local | -data "data")> - ftp::Get - ftp::Reget - ftp::Newer - ftp::MkDir - ftp::RmDir - ftp::Quote ... - -This new Releases use the new "fcopy" command to transfer binary data -between two channels. There is also a version 0.4 of ftp for -tcl7.6/tk4.2, which works stable using the undocumented command -"unsupported0" for binary data transfer. - - DELETED modules/ftp/docs/fhelp1.html Index: modules/ftp/docs/fhelp1.html ================================================================== --- modules/ftp/docs/fhelp1.html +++ /dev/null @@ -1,126 +0,0 @@ - - -ftp Library Package 2.2 for Tcl/Tk help file - - - - -

-

-
-

ftp Library Package 2.1 for Tcl/Tk Manual Pages

-
- -
COMMAND
-
-
ftp::Open  server  user  passwd  ?options?
-
 
-
- The ftp::Open command is used to start the FTP session by - establishing a control connection to the FTP server. If no - options are specified, then the defaults are used. - -

The ftp::Open command takes a host name server, a user name - user and a password password as its parameters and returns - a session handle that is an integer greater than or equal to 0 if the - connection is successfully established, otherwise it returns "-1".
- The server parameter must be the name or internet address (in dotted decimal - notation) of the ftp server. The user and passwd parameters must contain a - valid user name and password to complete the login process.

- - The options overwrite some default values or set special - abilities: - -

-blocksize size

- The blocksize is used during data transfer. At most size - bytes are transfered at once. After each block, a call to the "-progress callback" is made. - The default value for this option is 4096.

- -

-timeout seconds

- If seconds is non-zero, then ftp::Open sets up a timeout - to occur after the specified number of seconds. The default value is 600.

- -

-port number

- The port number specifies an alternative remote port on - the ftp server on which the ftp service resides. Most - ftp services listen for connection requests on default - port 21. Sometimes, usually for security reasons, port - numbers other than 21 are used for ftp connections.

- -

-mode mode

- The transfer mode option determines if a file transfer - occurs in an active or passive way. In passive mode the - client session may want to request the ftp Server to - listen for a data port and wait for the connection - rather than initiate the process when a data transfer - request comes in. Passive mode is normally a requirement - when accessing sites via a firewall. The default mode is active.

- -

-progress callback

- The callback is made after each transfer of a data - block specified in blocksize. The callback gets as - additional argument the current number of bytes transferred so far. - Here is a template for the progress callback:
- - 
proc Progress {total} {
-	puts "$total bytes transfered!"
-}

- -

-command callback

- Specifying this option puts the connection in asynchronous mode. - The callback is made after each operation has been - completed. The callback gets as an additional argument - a keyword of the operation that has completed plus - additional arguments specific to the operation. - If an error occurs the callback is made with the keyword - "error". When an operation, such as "Cd", "Get", and so on, - has been started no further operations should be started - until a callback has been received for the current - operation. - A template for the callback is:
- - 
proc Callback {what args} {
-    puts "Operation $what $args completed"
-}

- -
-
- -
EXAMPLE
-
-
- 
set server "ftp.server.com"
-set user "anonymous"
-set passwd "mist@foo.com"
-
-# define callback
-proc Progress {total} {
-	puts "$total bytes transfered!"
-}
-
-# open a new connection
-if {[set conn [ftp::Open $server $user $passwd -progress Progress -blocksize 1024 -mode passive]] == -1} {
-	puts "Connection refused!"
-	exit 1
-}
-
-# get a file
-ftp::Get $conn index.html
-
-# close connection
-ftp::Close $conn
-
- -
-
- -
-

-

-[Contents]  -[Next: ftp::Close] -

- -

© 1999 Steffen Traeger

- - DELETED modules/ftp/docs/fhelp10.html Index: modules/ftp/docs/fhelp10.html ================================================================== --- modules/ftp/docs/fhelp10.html +++ /dev/null @@ -1,54 +0,0 @@ - - -ftp Library Package 2.1 for Tcl/Tk help file - - - - -

-

-
-

ftp Library Package 2.1 for Tcl/Tk Manual Pages

-
- -
COMMAND
-
-
ftp::Delete  handle  file
-
 
-
- - The ftp::Delete command deletes the specified file on the ftp - server. The command returns 1 if the specified file can be - successfully deleted or 0 if it fails. - -

- -

-
- -
EXAMPLE
-
-
- 
# delete file
-if {![ftp::Delete $conn index.htm]} {
-	puts "File couldn't be deleted!"
-}
-
-# delete all like "rm *"
-foreach file [ftp::NList $conn] {
-	ftp::Delete $conn $file
-}
-
- -
-
-
-

-

-[Contents]  -[Previous: ftp::ModTime]  -[Next: ftp::Rename] -

-

© 1999 Steffen Traeger

- - DELETED modules/ftp/docs/fhelp11.html Index: modules/ftp/docs/fhelp11.html ================================================================== --- modules/ftp/docs/fhelp11.html +++ /dev/null @@ -1,52 +0,0 @@ - - -ftp Library Package 2.1 for Tcl/Tk help file - - - - -

-

-
-

ftp Library Package 2.1 for Tcl/Tk Manual Pages

-
- -
COMMAND
-
-
ftp::Rename  handle  from  to
-
 
-
- - The ftp::Rename command renames the file in the current - directory of the ftp server with the specified file name from - to the specified new file name to. This new file name cannot - be the same as any existing subdirectory or file name. - -

The command returns 1 if the specified file can be successfully - renamed or 0 if it fails.

- -
-
- -
EXAMPLE
-
-
- 
# rename file
-ftp::Rename $conn index.htm index.htm.org
-
-# with fully qualified path name
-ftp::Rename $conn /usr/htdocs/index.htm /usr/htdocs/index.htm.org
-
- -
-
-
-

-

-[Contents]  -[Previous: ftp::Delete]  -[Next: ftp::Put] -

-

© 1999 Steffen Traeger

- - DELETED modules/ftp/docs/fhelp12.html Index: modules/ftp/docs/fhelp12.html ================================================================== --- modules/ftp/docs/fhelp12.html +++ /dev/null @@ -1,58 +0,0 @@ - - -ftp Library Package 2.1 for Tcl/Tk help file - - - - -

-

-
-

ftp Library Package 2.1 for Tcl/Tk Manual Pages

-
- -
COMMAND
-
-
ftp::Put  handle  (local | -data "data")  ?remote?
-
 
-
- - The ftp::Put command stores a local file local to a remote - file remote on the ftp server. The file parameters passed must - contain a fully qualified path name, otherwise the command uses - the current directory. If '-data "data"' is specified, then rather than - transferring a file, the data passed in is used as the data to transfer. - If remote file name is unspecified, the local file name is assigned to - the remote file name. - -

If the file was successfully transferred, then the command - returns 1, if it fails 0.

- -
-
- -
EXAMPLE
-
-
- 
# store unique file name
-ftp::Put $conn index.htm
-
-# store different file names
-ftp::Put $conn test.htm index.htm
-
-# with different fully qualified path name
-ftp::Put $conn /usr/local/src/my.tar.gz /incoming/foo.tar.gz
-
- -
-
-
-

-

-[Contents]  -[Previous: ftp::Rename]  -[Next: ftp::Append] -

-

© 1999 Steffen Traeger

- - DELETED modules/ftp/docs/fhelp125.html Index: modules/ftp/docs/fhelp125.html ================================================================== --- modules/ftp/docs/fhelp125.html +++ /dev/null @@ -1,58 +0,0 @@ - - -ftp Library Package 2.1 for Tcl/Tk help file - - - - -

-

-
-

ftp Library Package 2.1 for Tcl/Tk Manual Pages

-
- -
COMMAND
-
-
ftp::Append  handle  (local | -data "data")  ?remote?
-
 
-
- - The ftp::Append command appends a local file local to an - existing remote file remote on the ftp server. If the file - not exists at the server site, the file shall be created at the server - site. If '-data "data"' is specified, then rather than - transferring a file, the data passed in is used as the data to transfer. -
- The file parameters passed must - contain a fully qualified path name, otherwise the command uses - the current directory. If remote file name is unspecified, the - local file name is assigned to the remote file name. - -

If the file was successfully transferred, then the command - returns 1, if it fails 0.

- -
-
- -
EXAMPLE
-
-
- 
# store data
-ftp::Put $conn data.log
-
-# append new data
-ftp::Append $conn logfile data.log
-
- -
-
-
-

-

-[Contents]  -[Previous: ftp::Put]  -[Next: ftp::Get] -

-

© 1999 Steffen Traeger

- - DELETED modules/ftp/docs/fhelp13.html Index: modules/ftp/docs/fhelp13.html ================================================================== --- modules/ftp/docs/fhelp13.html +++ /dev/null @@ -1,62 +0,0 @@ - - -ftp Library Package 2.1 for Tcl/Tk help file - - - - -

-

-
-

ftp Library Package 2.1 for Tcl/Tk Manual Pages

-
- -
COMMAND
-
-
ftp::Get  handle  remote  ?(local | -variable varname)?
-
 
-
- - The ftp::Get command retrieves a remote file remote on the - ftp server to a local file local. If '-variable varname' is - specified, then the variable 'varname' will get the retreived data - stored in it, rather than storing the data in a file. The file - parameters passed must contain a fully qualified path name, otherwise - the command uses the current directory. If local file name is - unspecified, the remote file name is assigned to the remote file name. - -

If the file was successfully transferred, then the command - returns 1, if it fails 0.

- -
-
- -
EXAMPLE
-
-
- 
# retrieve unique file name
-ftp::Get $conn index.htm
-
-# retrieve different file names
-ftp::Get $conn index.htm new.htm
-
-# with different fully qualified path name
-if [ftp::Get $conn /incoming/foo.tar.gz /usr/local/src] {
-	cd /usr/local/src
-	exec gunzip foo.tar.gz
-	exec tar xf foo.tar
-}
-
- -
-
-
-

-

-[Contents]  -[Previous: ftp::Append]  -[Next: ftp::Reget] -

-

© 1999 Steffen Traeger

- - DELETED modules/ftp/docs/fhelp14.html Index: modules/ftp/docs/fhelp14.html ================================================================== --- modules/ftp/docs/fhelp14.html +++ /dev/null @@ -1,51 +0,0 @@ - - -ftp Library Package 2.1 for Tcl/Tk help file - - - - -

-

-
-

ftp Library Package 2.1 for Tcl/Tk Manual Pages

-
- -
COMMAND
-
-
ftp::Newer  handle  remote  ?local?
-
 
-
- - The ftp::Newer command has the same behavior as ftp::Get, except - that it gets the remote file only if the modification time of - the remote file is more recent that the file on the local - system. If the file does not exist on the current system, the - remote file is considered newer. - -

If the file was successfully transferred, then the command - returns 1, if it fails 0.

- -
-
- -
EXAMPLE
-
-
- 
# package update
-if {[ftp::Newer $conn /pub/tcl/httpd/tclhttpd.tar.gz /usr/local/src/tclhttpd.tgz]} {
-        exec echo "New httpd arrived!" | mailx -s ANNOUNCE root
-}
-
-
-
-
-

-

-[Contents]  -[Previous: ftp::Get]  -[Next: ftp::Newer] -

-

© 1999 Steffen Traeger

- - DELETED modules/ftp/docs/fhelp15.html Index: modules/ftp/docs/fhelp15.html ================================================================== --- modules/ftp/docs/fhelp15.html +++ /dev/null @@ -1,57 +0,0 @@ - - -ftp Library Package 2.1 for Tcl/Tk help file - - - - -

-

-
-

ftp Library Package 2.1 for Tcl/Tk Manual Pages

-
- -
COMMAND
-
-
ftp::Reget  handle  remote  ?local?
-
 
-
- - The ftp::Reget command has the same behavior as ftp::Get, except - that if local file local exists and is smaller than remote - file remote, the local file is presumed to be a partially - transferred copy of the remote file and the transfer is - continued from the apparent point of failure. This command is - useful when transferring very large files over networks that - tend to drop connections. - -

If the file was successfully transferred, then the command - returns 1, if it fails 0.

- -
-
- -
EXAMPLE
-
-
- 
# retrieve a large file name (12 MByte)
-ftp::Get $conn foo.tar
-
-.... after 1 hour and 11.9 transfered MBytes the connection is broken :-(
-
-# restart file transfer at the broken position and
-# retrieve only the remaining 0.1 MByte
-ftp::Reget $conn foo.tar
-
-
-
-
-

-

-[Contents]  -[Previous: ftp::Reget]  -[Next: ftp::MkDir] -

-

© 1999 Steffen Traeger

- - DELETED modules/ftp/docs/fhelp16.html Index: modules/ftp/docs/fhelp16.html ================================================================== --- modules/ftp/docs/fhelp16.html +++ /dev/null @@ -1,53 +0,0 @@ - - -ftp Library Package 2.1 for Tcl/Tk help file - - - - -

-

-
-

FTP Library Package 2.1 for Tcl/Tk Manual Pages

-
- -
COMMAND
-
-
ftp::MkDir  handle  directory
-
 
-
- - The ftp::MkDir causes the directory specified in directory to - be created as a directory (if the directory is absolute) or as - a subdirectory of the current working directory (if directory - is relative). - -

If the directory was successfully created, then the command - returns 1, if it fails 0.

- -
-
- -
EXAMPLE
-
-
- 
# create directory
-ftp::MkDir $conn /incoming/newdir
-
-# or
-ftp::Cd $conn /incoming
-ftp::MkDir $conn newdir
-
- -
-
-
-

-

-[Contents]  -[Previous: ftp::Newer]  -[Next: ftp::RmDir] -

-

© 1999 Steffen Traeger

- - DELETED modules/ftp/docs/fhelp17.html Index: modules/ftp/docs/fhelp17.html ================================================================== --- modules/ftp/docs/fhelp17.html +++ /dev/null @@ -1,51 +0,0 @@ - - -ftp Library Package 2.1 for Tcl/Tk help file - - - - -

-

-
-

ftp Library Package 2.1 for Tcl/Tk Manual Pages

-
- -
COMMAND
-
-
ftp::RmDir  handle  directory
-
 
-
- - The ftp::RmDir command removes the specified directory on the - ftp server. The remote directory must be empty. - -

The command returns 1 if the specified directory can be successfully - removed or 0 if it fails.

- -
-
- -
EXAMPLE
-
-
- 
# remove directory
-ftp::RmDir $conn /incoming/newdir
-
-# or
-ftp::Cd $conn /incoming
-ftp::RmDir $conn newdir
-
- -
-
-
-

-

-[Contents]  -[Previous: ftp::MkDir]  -[Next: ftp::Quote] -

-

© 1999 Steffen Traeger

- - DELETED modules/ftp/docs/fhelp18.html Index: modules/ftp/docs/fhelp18.html ================================================================== --- modules/ftp/docs/fhelp18.html +++ /dev/null @@ -1,52 +0,0 @@ - - -ftp Library Package 2.1 for Tcl/Tk help file - - - - -

-

-
-

ftp Library Package 2.1 for Tcl/Tk Manual Pages

-
- -
COMMAND
-
-
ftp::Quote  handle  arg1  arg2  ...
-
 
-
- - The ftp::Quote command is used to send the specified arguments - verbatim, as is, to the remote ftp server. This command cannot - be used to obtain a directory listing or for transferring files, - but it can be used for any other ftp commands. It is typically - used to execute commands on the server that are not directly - available from the ftp_lib itself. - -

The command sent back the string it received instead of any parsing

- -
-
- -
EXAMPLE
-
-
- 
# change the mode settings on UNIX systems
-ftp::Quote $conn site chmod 644 index.htm
-
-# request supported ftp server commands
-puts [ftp::Quote $conn help]
-
- -
-
-
-

-

-[Contents]  -[Previous: ftp::RmDir] -

-

© 1999 Steffen Traeger

- - DELETED modules/ftp/docs/fhelp2.html Index: modules/ftp/docs/fhelp2.html ================================================================== --- modules/ftp/docs/fhelp2.html +++ /dev/null @@ -1,57 +0,0 @@ - - -ftp Library Package 2.1 for Tcl/Tk help file - - - - -

-

-
-

ftp Library Package 2.1 for Tcl/Tk Manual Pages

-
- -
COMMAND
-
-
ftp::Close handle
-
 
-
- The ftp::Close command terminates the ftp session and if file - transfer is not in progress, the server closes the control - connection. If file transfer is in progress, the connection - will remain open for result response and the server will then - close it. -
-
 
-
- -
EXAMPLE
-
-
- 
# open a new connection
-if {[set conn [ftp::Open ...]] == -1} {
-	puts "Connection refused!"
-	exit 1
-}
-
-# get file
-ftp::Get $conn index.html
-
-# close connection
-ftp::Close $conn
-
- -
-
- -
-

- -

-[Contents]  -[Previous: ftp::Open]  -[Next: ftp::Cd] -

-

© 1999 Steffen Traeger

- - DELETED modules/ftp/docs/fhelp3.html Index: modules/ftp/docs/fhelp3.html ================================================================== --- modules/ftp/docs/fhelp3.html +++ /dev/null @@ -1,54 +0,0 @@ - - -ftp Library Package 2.1 for Tcl/Tk help file - - - - -

-

-
-

ftp Library Package 2.1 for Tcl/Tk Manual Pages

-
- -
COMMAND
-
-
ftp::CD  handle directory
-
 
-
- - The ftp::Cd command changes the current working directory on - the ftp server to a specified target directory. This target - directory can be a subdirectory of the current directory, ".." - (for the parent directory) or a fully qualified path to a new - working directory. - -

The command returns 1 if the current working directory can be - successfully changed to the specified directory or 0 if it fails.

- -
-
- -
EXAMPLE
-
-
- 
# change directory
-ftp::Cd $conn pub/tcl
-ftp::Cd $conn ..
-
-
- -
-
- -
-

- -

-[Contents]  -[Previous: ftp::Close]  -[Next: ftp::Pwd] -

-

© 1999 Steffen Traeger

- - DELETED modules/ftp/docs/fhelp4.html Index: modules/ftp/docs/fhelp4.html ================================================================== --- modules/ftp/docs/fhelp4.html +++ /dev/null @@ -1,47 +0,0 @@ - - -ftp Library Package 2.1 for Tcl/Tk help file - - - - -

-

-
-

ftp Library Package 2.1 for Tcl/Tk Manual Pages

-
- -
COMMAND
-
-
ftp::Pwd handle
-
 
-
- - The ftp::Pwd command gets the complete path of the current - working directory on the ftp server or an empty string if an - error occurs. - -

- -

-
- -
EXAMPLE
-
-
- 
# get directory path
-set current_path [ftp::Pwd $conn]
-
- -
-
-
-

-

-[Contents]  -[Previous: ftp::Cd]  -[Next: ftp::Type] -

-

© 1999 Steffen Traeger

- - DELETED modules/ftp/docs/fhelp5.html Index: modules/ftp/docs/fhelp5.html ================================================================== --- modules/ftp/docs/fhelp5.html +++ /dev/null @@ -1,57 +0,0 @@ - - -ftp Library Package 2.1 for Tcl/Tk help file - - - - -

-

-
-

ftp Library Package 2.1 for Tcl/Tk Manual Pages

-
- -
COMMAND
-
-
ftp::Type  handle  ?ascii|binary?
-
 
-
- - The ftp::Type command sets the ftp file transfer type either - to ascii, binary, or to tenex. In every - case, also if the type name is unspecified, it returns the current type. - -

Only ascii and binary types are currently supported. - There is some early (alhpa) support for Tenex mode. The ascii - type is normally used to convert text files to a format suitable - for text editors on the platform depended destination machine. - The binary type allows undisturbed transfers of non-text files, - such as compressed files, images and executables.

- -
-
- -
EXAMPLE
-
-
- 
# get file transfer type
-set current_type [ftp::Type $conn]
-
-# set file transfer type
-ftp::Type $conn ascii
-
-
-
- -
-
-
-

-

-[Contents]  -[Previous: ftp::Pwd]  -[Next: ftp::List] -

-

© 1999 Steffen Traeger

- - DELETED modules/ftp/docs/fhelp6.html Index: modules/ftp/docs/fhelp6.html ================================================================== --- modules/ftp/docs/fhelp6.html +++ /dev/null @@ -1,74 +0,0 @@ - - -ftp Library Package 2.1 for Tcl/Tk help file - - - - -

-

-
-

ftp Library Package 2.1 for Tcl/Tk Manual Pages

-
- -
COMMAND
-
-
ftp::List  handle  ?directory?
-
 
-
- - The ftp::List command lists the contents of the current remote - directory or if the directory parameter is specified a directory - or other group of files. Also wildcard expression, such as - "*.tcl", can be specified. The directory or file name must be - fully qualified, otherwise the it takes entries in the current - remote directory. - -

The listing includes any system-dependent information that the - server chooses to include; for example, most UNIX systems - produce output from the command "ls -l". ftp::List returns - these information as a tcl list with one line for every entry. - Empty lines and UNIX's "total" lines are ignored. So it should - offer only usable informations.

- -

If the command fails an empty list is returned.

- -
-
- -
EXAMPLE
-
-
- 
# list current directory
-foreach line [ftp::List $conn]
-	puts $line
-}
-
-# list only tcl files
-foreach line [ftp::List $conn *.tcl]
-	puts $line
-}
-
-# list specified directory
-set dir_list [ftp::List $conn /pub/usr/lib]
-
-# list if directory exist
-if {[ftp::Cd $conn /pub/usr/lib]} {
-	set dir_list [ftp::List $conn]
-} else {
-	puts "Directory doesn't exist!"
-}	
-
- -
-
-
-

-

-[Contents]  -[Previous: ftp::Type]  -[Next: ftp::NList] -

-

© 1999 Steffen Traeger

- - DELETED modules/ftp/docs/fhelp7.html Index: modules/ftp/docs/fhelp7.html ================================================================== --- modules/ftp/docs/fhelp7.html +++ /dev/null @@ -1,48 +0,0 @@ - - -ftp Library Package 2.1 for Tcl/Tk help file - - - - -

-

-
-

ftp Library Package 2.1 for Tcl/Tk Manual Pages

-
- -
COMMAND
-
-
ftp::NList  handle  ?directory?
-
 
-
- - This command has the same behavior as previous ftp::List command, except that it - only gets a abbreviated listing. This means only file names are - returned in a sorted list. - -

- -

-
- -
EXAMPLE
-
-
- 
# list current directory
-set file_names [ftp::NList $conn]
-
-
- -
-
-
-

-

-[Contents]  -[Previous: ftp::List]  -[Next: ftp::FileSize] -

-

© 1999 Steffen Traeger

- - DELETED modules/ftp/docs/fhelp8.html Index: modules/ftp/docs/fhelp8.html ================================================================== --- modules/ftp/docs/fhelp8.html +++ /dev/null @@ -1,50 +0,0 @@ - - -ftp Library Package 2.1 for Tcl/Tk help file - - - - -

-

-
-

ftp Library Package 2.1 for Tcl/Tk Manual Pages

-
- -
COMMAND
-
-
ftp::FileSize  handle  file
-
 
-
- - The ftp::FileSize command gets the file size of the specified - file on the ftp server.
ATTENTION! It doesn't work properly in - ascci mode and isn't supported by all ftp server implementations. - -

If the command fails an empty string is returned.

- -
-
- -
EXAMPLE
-
-
- 
# get file size
-set old_type [ftp::Type $conn]
-ftp::Type $conn binary	
-set size [ftp::FileSize $conn index.htm]
-ftp::Type $conn $old_type
-
- -
-
-
-

-

-[Contents]  -[Previous: ftp::NList]  -[Next: ftp::ModTime] -

-

© 1999 Steffen Traeger

- - DELETED modules/ftp/docs/fhelp9.html Index: modules/ftp/docs/fhelp9.html ================================================================== --- modules/ftp/docs/fhelp9.html +++ /dev/null @@ -1,49 +0,0 @@ - - -ftp Library Package 2.1 for Tcl/Tk help file - - - - -

-

-
-

ftp Library Package 2.1 for Tcl/Tk Manual Pages

-
- -
COMMAND
-
-
ftp::ModTime  handle  file
-
 
-
- - The ftp::ModTime command gets the last modification time of the - file on the ftp server as a system dependent integer value in - seconds (see tcl's clock command) or an empty string in error cases. - -

- -

-
- -
EXAMPLE
-
-
- 
# get modification time
-puts [clock format [ftp::ModTime $conn index.htm]]
-
-set year [clock format [ftp::ModTime $conn index.htm] -format %y]
-
- -
-
-
-

-

-[Contents]  -[Previous: ftp::FileSize]  -[Next: ftp::Delete] -

-

© 1999 Steffen Traeger

- - DELETED modules/ftp/docs/index.html Index: modules/ftp/docs/index.html ================================================================== --- modules/ftp/docs/index.html +++ /dev/null @@ -1,107 +0,0 @@ - - -ftp Library Package 2.2 for Tcl/Tk help file - - - - -

-

-
-

ftp Library Package 2.1 for Tcl/Tk Manual Pages

-
- -
NAME
-
-
ftp - Client-side tcl implementation of the ftp protocol
-
-
 
- -
SYNOPSIS
-
-
package require ftp ?2.2?
-
 
-
ftp::Open  server  user  passwd  ?options?
-
ftp::Close  handle
-
ftp::Cd  handle  directory
-
ftp::Pwd  handle
-
ftp::Type  handle  ?ascii|binary|tenex?
-
ftp::List  handle  ?directory?
-
ftp::NList  handle  ?directory?
-
ftp::FileSize  handle  file
-
ftp::ModTime  handle  from  to
-
ftp::Delete  handle  file
-
ftp::Rename  handle  from  to
-
ftp::Put  handle  (local | -data "data")  ?remote?
-
ftp::Append  handle  (local | -data "data")  ?remote?
-
ftp::Get  handle  remote  ?(local | -variable varname)?
-
ftp::Reget  handle  remote  ?local?
-
ftp::Newer  handle  remote  ?local?
-
ftp::MkDir  handle  directory
-
ftp::RmDir  handle  directory
-
ftp::Quote  handle  arg1  arg2  ...
-
ftp::DisplayMsg  handle  msg  ?state?
-
 
-
variable ftp::VERBOSE
-
variable ftp::DEBUG
-
-
 
- -
DESCRIPTION
-
-
- The ftp library package provides the client side of the ftp protocol. - The package implements active (default) and passive ftp sessions. - -

A new ftp session is started with the Open command. Quitting an - existing ftp session is done by Close. All other commands can - only be used in an opened ftp session else an error will occured. - The ftp package includes file and directory manipulating commands for - remote sites. To do the same stuff to the local site the built-in tcl - commands like "cd" or "file command" are the best choice.

- - Two state variables controls the output of ftp. Setting VERBOSE - to "1" forces to show all responses from the remote server. The default value is "0". - Setting DEBUG to "1" enables debugging to show all the return code, states - and "real" ftp commands. The default value is "0". - -

The procedure DisplayMsg is used to show the different messages from - the ftp session. It is simple declared in ftp and must be overwritten - by the programmer to make it more comfortable. A state variable for different - states assigned to different colors is recommended by the author. For - example:

- - 
.msg.text tag configure error -foreground red
-.msg.text tag configure data -foreground brown
-.msg.text tag configure control -foreground blue
-
-namespace ftp {
-    proc DisplayMsg {s msg {state ""}} {
-        switch $state {
-            data	{.msg.text insert end "$msg\n" data}
-            control	{.msg.text insert end "$msg\n" control}
-	    error	{.msg.f.text insert end "$msg\n" error}
-        }	   
-    }
-}
-
-
- -
BUGS
-
-
- Correct execution of many commands depends upon proper behavior by the remote server, network - and router configuration.

- - An update command placed in the procedure DisplayMsg run into persistent errors or infinite loops. - The solution to this problem is to use "update idletasks", rather than a single update. -

-
- -
-

-

© 1999 Steffen Traeger

- - - - DELETED modules/ftp/ftp.man Index: modules/ftp/ftp.man ================================================================== --- modules/ftp/ftp.man +++ /dev/null @@ -1,459 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[manpage_begin ftp n 2.4] -[moddesc {ftp client}] -[titledesc {Client-side tcl implementation of the ftp protocol}] -[require Tcl 8.2] -[require ftp [opt 2.4]] -[require ftp::geturl [opt 0.2]] -[description] - - -[para] - -The ftp package provides the client side of the ftp protocol. The -package implements both active (default) and passive ftp sessions. - -[para] - -A new ftp session is started with the [cmd ::ftp::Open] command. To -shutdown an existing ftp session use [cmd ::ftp::Close]. All other -commands are restricted to usage in an an open ftp session. They will -generate errors if they are used out of context. The ftp package -includes file and directory manipulating commands for remote sites. To -perform the same operations on the local site use commands built into -the core, like [cmd cd] or [cmd file]. - -[para] - -The output of the package is controlled by two state variables, - -[var ::ftp::VERBOSE] and [var ::ftp::DEBUG]. Setting - -[var ::ftp::VERBOSE] to "1" forces the package to show all responses -from a remote server. The default value is "0". Setting - -[var ::ftp::DEBUG] to "1" enables debugging and forces the package to -show all return codes, states, state changes and "real" ftp -commands. The default value is "0". - -[para] - -The command [cmd ::ftp::DisplayMsg] is used to show the different -messages from the ftp session. The setting of [var ::ftp::VERBOSE] -determines if this command is called or not. The current -implementation of the command uses the [package log] package of tcllib -to write the messages to their final destination. This means that the -behaviour of [cmd ::ftp::DisplayMsg] can be customized without -changing its implementation. For more radical changes overwriting its -implementation by the application is of course still possible. Note -that the default implementation honors the option [option -output] to - -[cmd ::ftp::Open] for a session specific log command. - -[para] - -[emph Caution]: The default implementation logs error messages like -all other messages. If this behaviour is changed to throwing an error -instead all commands in the API will change their behaviour too. In -such a case they will not return a failure code as described below but -pass the thrown error to their caller. - -[section API] - -[list_begin definitions] - -[call [cmd ::ftp::geturl] [arg url]] - -This command lives in its own package, [cmd ::ftp::geturl], and can be -used by the generic command [cmd ::uri::geturl] to retrieve the -contents of ftp urls. Internally it uses the ftp commands described -below to fulfill the request. - -[nl] - -The contents of an ftp url are defined as follows: - -[list_begin definitions] - -[lst_item [term file]] - -The contents of the specified file itself. - -[lst_item [term directory]] - -A listing of the contents of the directory in key value notation where -the file name is the key and its attributes the associated value. - -[lst_item [term link]] - -The attributes of the link, including the path it refers to. - -[list_end] - -[call [cmd ::ftp::Open] [arg server] [arg user] [arg passwd] [opt [arg options]]] - -This command is used to start a FTP session by establishing a control -connection to the FTP server. The defaults are used for any option not -specified by the caller. - -[nl] - -The command takes a host name [arg server], a user name [arg user] and -a password [arg password] as its parameters and returns a session -handle that is an integer number greater than or equal to "0", if the -connection is successfully established. Otherwise it returns "-1". -The [arg server] parameter must be the name or internet address (in -dotted decimal notation) of the ftp server to connect to. The - -[arg user] and [arg passwd] parameters must contain a valid user name -and password to complete the login process. - -[nl] - -The options overwrite some default values or set special abilities: - -[list_begin definitions] - -[lst_item "[option -blocksize] [arg size]"] - -The blocksize is used during data transfer. At most [arg size] bytes -are transfered at once. The default value for this option is 4096. -The package will evaluate the [cmd {-progress callback}] for the -session after the transfer of each block. - -[lst_item "[option -timeout] [arg seconds]"] - -If [arg seconds] is non-zero, then [cmd ::ftp::Open] sets up a timeout -which will occur after the specified number of seconds. The default -value is 600. - -[lst_item "[option -port] [arg number]"] - -The port [arg number] specifies an alternative remote port on the ftp -server on which the ftp service resides. Most ftp services listen for -connection requests on the default port 21. Sometimes, usually for -security reasons, port numbers other than 21 are used for ftp -connections. - -[lst_item "[option -mode] [arg mode]"] - -The transfer [arg mode] option determines if a file transfer occurs in -[const active] or [const passive] mode. In passive mode the client -will ask the ftp server to listen on a data port and wait for the -connection rather than to initiate the process by itself when a data -transfer request comes in. Passive mode is normally a requirement when -accessing sites via a firewall. The default mode is [const active]. - -[lst_item "[option -progress] [arg callback]"] - -This [arg callback] is evaluated whenever a block of data was -transfered. See the option [option -blocksize] for how to specify the -size of the transfered blocks. - -[nl] - -When evaluating the [arg callback] one argument is appended to the -callback script, the current accumulated number of bytes transferred -so far. - -[lst_item "[option -command] [arg callback]"] - -Specifying this option places the connection into asynchronous -mode. The [arg callback] is evaluated after the completion of any -operation. When an operation is running no further operations must be -started until a callback has been received for the currently executing -operation. - -[nl] - -When evaluating the [arg callback] several arguments are appended to -the callback script, namely the keyword of the operation that has -completed and any additional arguments specific to the operation. If -an error occurred during the execution of the operation the callback is -given the keyword [const error]. - -[lst_item "[option -output] [arg callback]"] - -This option has no default. If it is set the default implementation of -[cmd ::ftp::DisplayMsg] will use its value as command prefix to log -all internal messages. The callback will have three arguments appended -to it before evaluation, the id of the session, the message itself, -and the connection state, in this order. - -[list_end] - -[call [cmd ::ftp::Close] [arg handle]] - -This command terminates the specified ftp session. If no file transfer -is in progress, the server will close the control connection -immediately. If a file transfer is in progress however, the control -connection will remain open until the transfers completes. When that -happens the server will write the result response for the transfer to -it and close the connection afterward. - -[call [cmd ::ftp::Cd] [arg handle] [arg directory]] - -This command changes the current working directory on the ftp server -to a specified target [arg directory]. The command returns 1 if the -current working directory was successfully changed to the specified -directory or 0 if it fails. The target directory can be - -[list_begin bullet] -[bullet] - -a subdirectory of the current directory, - -[bullet] - -Two dots, [const ..] (as an indicator for the parent directory of -the current directory) - -[bullet] - -or a fully qualified path to a new working directory. - -[list_end] - -[call [cmd ::ftp::Pwd] [arg handle]] - -This command returns the complete path of the current working -directory on the ftp server, or an empty string in case of an error. - -[call [cmd ::ftp::Type] [arg handle] [opt [const ascii|binary|tenex]]] - -This command sets the ftp file transfer type to either [const ascii], -[const binary], or [const tenex]. The command always returns the -currently set type. If called without type no change is made. - -[nl] - -Currently only [const ascii] and [const binary] types are -supported. There is some early (alpha) support for Tenex mode. The -type [const ascii] is normally used to convert text files into a -format suitable for text editors on the platform of the destination -machine. This mainly affects end-of-line markers. The type - -[const binary] on the other hand allows the undisturbed transfer of -non-text files, such as compressed files, images and executables. - -[call [cmd ::ftp::List] [arg handle] [opt [arg pattern]]] - -This command returns a human-readable list of files. Wildcard -expressions such as [file *.tcl] are allowed. If [arg pattern] -refers to a specific directory, then the contents of that directory -are returned. If the [arg pattern] is not a fully-qualified path -name, the command lists entries relative to the current remote -directory. If no [arg pattern] is specified, the contents of the -current remote directory is returned. - -[nl] - -The listing includes any system-dependent information that the server -chooses to include. For example most UNIX systems produce output from -the command [syscmd {ls -l}]. The command returns the retrieved -information as a tcl list with one item per entry. Empty lines and -UNIX's "total" lines are ignored and not included in the result as -reported by this command. - -[nl] - -If the command fails an empty list is returned. - -[call [cmd ::ftp::NList] [arg handle] [opt [arg directory]]] - -This command has the same behavior as the [cmd ::ftp::List] command, -except that it only retrieves an abbreviated listing. This means only -file names are returned in a sorted list. - -[call [cmd ::ftp::FileSize] [arg handle] [arg file]] - -This command returns the size of the specified [arg file] on the ftp -server. If the command fails an empty string is returned. - -[nl] - -[emph ATTENTION!] It will not work properly when in ascii mode and -is not supported by all ftp server implementations. - -[call [cmd ::ftp::ModTime] [arg handle] [arg file]] - -This command retrieves the time of the last modification of the - -[arg file] on the ftp server as a system dependent integer value in -seconds or an empty string if an error occurred. Use the built-in -command [cmd clock] to convert the retrieves value into other formats. - -[call [cmd ::ftp::Delete] [arg handle] [arg file]] - -This command deletes the specified [arg file] on the ftp server. The -command returns 1 if the specified file was successfully deleted or 0 -if it failed. - -[call [cmd ::ftp::Rename] [arg handle] [arg from] [arg to]] - -This command renames the file [arg from] in the current directory of -the ftp server to the specified new file name [arg to]. This new file -name must not be the same as any existing subdirectory or file name. -The command returns 1 if the specified file was successfully renamed -or 0 if it failed. - -[call [cmd ::ftp::Put] [arg handle] ([arg local] | -data [arg data] | -channel [arg chan]) [opt [arg remote]]] - -This command transfers a local file [arg local] to a remote file - -[arg remote] on the ftp server. If the file parameters passed to the -command do not fully qualified path names the command will use the -current directory on local and remote host. If the remote file name is -unspecified, the server will use the name of the local file as the -name of the remote file. The command returns 1 to indicate a successful -transfer and 0 in the case of a failure. - -[nl] - -If [option -data] [arg data] is specified instead of a local file, the -system will not transfer a file, but the [arg data] passed into it. In -this case the name of the remote file has to be specified. - -[nl] - -If [option -channel] [arg chan] is specified instead of a local file, -the system will not transfer a file, but read the contents of the -channel [arg chan] and write this to the remote file. In this case the -name of the remote file has to be specified. After the transfer - -[arg chan] will be closed. - -[call [cmd ::ftp::Append] [arg handle] ([arg local] | -data [arg data] | -channel [arg chan]) [opt [arg remote]]] - -This command behaves like [cmd ::ftp::Puts], but appends the -transfered information to the remote file. If the file did not exist -on the server it will be created. - -[call [cmd ::ftp::Get] [arg handle] [arg remote] [opt "([arg local] | -variable [arg varname] | -channel [arg chan])"]] - -This command retrieves a remote file [arg remote] on the ftp server -and stores its contents into the local file [arg local]. If the file -parameters passed to the command are not fully qualified path names -the command will use the current directory on local and remote -host. If the local file name is unspecified, the server will use the -name of the remote file as the name of the local file. The command -returns 1 to indicate a successful transfer and 0 in the case of a -failure. The command will throw an error if the directory the file -[arg local] is to be placed in does not exist. - -[nl] - -If [option -variable] [arg varname] is specified, the system will -store the retrieved data into the variable [arg varname] instead of a -file. - -[nl] - -If [option -channel] [arg chan] is specified, the system will write -the retrieved data into the channel [arg chan] instead of a file. The -system will [emph not] close [arg chan] after the transfer, this is -the responsibility of the caller to [cmd ::ftp::Get]. - -[call [cmd ::ftp::Reget] [arg handle] [arg remote] [opt [arg local]] [opt [arg from]] [opt [arg to]]] - -This command behaves like [cmd ::ftp::Get], except that if local file -[arg local] exists and is smaller than remote file [arg remote], the -local file is presumed to be a partially transferred copy of the -remote file and the transfer is continued from the apparent point of -failure. The command will throw an error if the directory the file -[arg local] is to be placed in does not exist. This command is useful -when transferring very large files over networks that tend to drop -connections. - -[nl] - -Specifying the additional byte offsets [arg from] and [arg to] will -cause the command to change its behaviour and to download exactly the -specified slice of the remote file. This mode is possible only if a -local destination is explicitly provided. Omission of [arg to] leads -to downloading till the end of the file. - -[call [cmd ::ftp::Newer] [arg handle] [arg remote] [opt [arg local]]] - -This command behaves like [cmd ::ftp::Get], except that it retrieves -the remote file only if the modification time of the remote file is -more recent than the file on the local system. If the file does not -exist on the local system, the remote file is considered newer. The -command will throw an error if the directory the file [arg local] is -to be placed in does not exist. - -[call [cmd ::ftp::MkDir] [arg handle] [arg directory]] - -This command creates the specified [arg directory] on the ftp -server. If the specified path is relative the new directory will be -created as a subdirectory of the current working directory. Else the -created directory will have the specified path name. The command -returns 1 to indicate a successful creation of the directory and 0 in -the case of a failure. - -[call [cmd ::ftp::RmDir] [arg handle] [arg directory]] - -This command removes the specified directory on the ftp server. The -remote directory has to be empty or the command will fail. The command -returns 1 to indicate a successful removal of the directory and 0 in -the case of a failure. - -[call [cmd ::ftp::Quote] [arg handle] [arg arg1] [arg arg2] [arg ...]] - -This command is used to send an arbitrary ftp command to the -server. It cannot be used to obtain a directory listing or for -transferring files. It is included to allow an application to execute -commands on the ftp server which are not provided by this package. -The arguments are sent verbatim, i.e. as is, with no changes. - -[nl] - -In contrast to the other commands in this package this command will -not parse the response it got from the ftp server but return it -verbatim to the caller. - -[call [cmd ::ftp::DisplayMsg] [arg handle] [arg msg] [opt [arg state]]] - -This command is used by the package itself to show the different -messages from the ftp sessions. The package itself declares this -command very simple, writing the messages to [const stdout] (if - -[var ::ftp::VERBOSE] was set, see below) and throwing tcl errors for -error messages. It is the responsibility of the application to -overwrite it as needed. A state variable for different states assigned -to different colors is recommended by the author. The package - -[package log] is useful for this. - -[lst_item [var ::ftp::VERBOSE]] - -A state variable controlling the output of the package. Setting - -[var ::ftp::VERBOSE] to "1" forces the package to show all responses -from a remote server. The default value is "0". - -[lst_item [var ::ftp::DEBUG]] - -A state variable controlling the output of ftp. Setting - -[var ::ftp::DEBUG] to "1" enables debugging and forces the package to -show all return codes, states, state changes and "real" ftp -commands. The default value is "0". - -[list_end] - -[section BUGS] -[para] - -The correct execution of many commands depends upon the proper -behavior by the remote server, network and router configuration. - -[para] - -An update command placed in the procedure [cmd ::ftp::DisplayMsg] may -run into persistent errors or infinite loops. The solution to this -problem is to use [cmd {update idletasks}] instead of [cmd update]. - -[see_also ftpd smtp pop3 mime] -[keywords ftp rfc959 internet net] -[manpage_end] DELETED modules/ftp/ftp.n Index: modules/ftp/ftp.n ================================================================== --- modules/ftp/ftp.n +++ /dev/null @@ -1,391 +0,0 @@ -'\" -'\" Copyright (c) 2000 Andreas Kupries -'\" All right reserved -'\" -'\" CVS: $Id: ftp.n,v 1.11 2002/02/15 05:35:30 andreas_kupries Exp $ ftp.n -'\" -.so man.macros -.TH "ftp" n 2.3.1 tcllib "ftp client" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -ftp \- Client-side tcl implementation of the ftp protocol -.SH "SYNOPSIS" -.nf -package require \fBTcl\fR -.sp -package require \fBftp\fR ?\fB2.3.1\fR? -package require \fBftp::geturl\fR ?\fB0.1\fR? ; # for ftp::geturl command -.sp -\fBftp::Open\fR \fIserver\fR \fIuser\fR \fIpasswd\fR ?\fIoptions\fR? -\fBftp::Close\fR \fIhandle\fR -.sp -\fBftp::Cd\fR \fIhandle\fR \fIdirectory\fR -\fBftp::Pwd\fR \fIhandle\fR -\fBftp::Type\fR \fIhandle\fR ?\fIascii|binary|tenex\fR? -\fBftp::List\fR \fIhandle\fR ?\fIdirectory\fR? -\fBftp::NList\fR \fIhandle\fR ?\fIdirectory\fR? -\fBftp::FileSize\fR \fIhandle\fR \fIfile\fR -\fBftp::ModTime\fR \fIhandle\fR \fIfile\fR -\fBftp::Delete\fR \fIhandle\fR \fIfile\fR -\fBftp::Rename\fR \fIhandle\fR \fIfrom\fR \fIto\fR -\fBftp::Put\fR \fIhandle\fR (\fIlocal\fR | -data \fIdata\fR | -channel \fIchan\fR) ?\fIremote\fR? -\fBftp::Append\fR \fIhandle\fR (\fIlocal\fR | -data \fIdata\fR | -channel \fIchan\fR) ?\fIremote\fR? -\fBftp::Get\fR \fIhandle\fR \fIremote\fR ?(\fIlocal\fR | -variable \fIvarname\fR | -channel \fIchan\fR)? -\fBftp::Reget\fR \fIhandle\fR \fIremote\fR ?\fIlocal\fR? ?\fIfrom\fR? ?\fIto\fR? -\fBftp::Newer\fR \fIhandle\fR \fIremote\fR ?\fIlocal\fR? -\fBftp::MkDir\fR \fIhandle\fR \fIdirectory\fR -\fBftp::RmDir\fR \fIhandle\fR \fIdirectory\fR -\fBftp::Quote\fR \fIhandle\fR \fIarg1\fR \fIarg2\fR \fI...\fR -\fBftp::DisplayMsg\fR \fIhandle\fR \fImsg\fR ?\fIstate\fR? -.sp -\fBftp::geturl\fR \fIurl\fR -.sp -.BE -.SH "DESCRIPTION" -.PP -The ftp library package provides the client side of the ftp protocol. -The package implements both active (default) and passive ftp sessions. -.PP -A new ftp session is started with the \fBOpen\fR command. To shutdown -an existing ftp session use \fBClose\fR. All other commands are -restricted to usage in an an open ftp session. They will generate -errors if they are used out of context. The ftp package includes file -and directory manipulating commands for remote sites. To perform the -same operations on the local site use commands built into the core, -like \fBcd\fR or \fBfile\fR. -.PP -The output of the package is controlled by two state variables, -\fIftp::VERBOSE\fR and \fIftp::DEBUG\fR. Setting \fIftp::VERBOSE\fR -to \fI1\fR forces the package to show all responses from a remote -server. The default value is \fI0\fR. Setting \fIftp::DEBUG\fR to -\fI1\fR enables debugging and forces the package to show all return -codes, states, state changes and "real" ftp commands. The default -value is \fI0\fR. -.PP -The procedure \fBDisplayMsg\fR is used to show the different messages -from the ftp session. The setting of \fIVERBOSE\fR determines if this -command is called or not. The current implementation of the command -uses the \fBlog\fR module of tcllib to write the messages to their -final destination. This means that the behaviour of \fBDisplayMsg\fR -can be customized without changing its implementation. For more -radical changes overwriting its implementation by the application is -of course still possible. Note that the default implementation honors -the -output option to \fBftp::Open\fR for a session specific log -command. -.PP -\fBCaution\fR: The default implementation logs error messages like all -other messages. If this behaviour is changed to throwing an error -instead all commands in the API will change their behaviour too. In -such a case they will not return a failure code as described below but -pass the thrown error to their caller. -.SH "API" -.TP -\fBftp::geturl \fIurl\fR -This command lives in its own package, \fBftp::geturl\fR, and can be -used by the generic \fBuri::geturl\fR command to retrieve the contents -of ftp urls. Internally it uses the ftp commands described below to -fulfill the request. -.sp -The contents of an ftp url are defined as follows: -.RS -.TP -\fBfile\fR -The contents of the specified file itself. -.TP -\fBdirectory\fR -A listing of the contents of the directory in key value notation where -the file name is the key and its attributes the associated value. -.TP -\fBlink\fR -The attributes of the link, including the path it refers to. -.RE -.TP -\fBftp::Open\fR \fIserver\fR \fIuser\fR \fIpasswd\fR ?\fIoptions\fR? -This command is used to start a FTP session by establishing a control -connection to the FTP server. The defaults are used for any option not -specified by the caller. -.sp -The command takes a host name \fIserver\fR, a user name \fIuser\fR and -a password \fIpassword\fR as its parameters and returns a session -handle that is an integer number greater than or equal to \fI0\fR, if -the connection is successfully established. Otherwise it returns -\fI-1\fR. The \fIserver\fR parameter must be the name or internet -address (in dotted decimal notation) of the ftp server to connect -to. The \fIuser\fR and \fIpasswd\fR parameters must contain a valid -user name and password to complete the login process. -.sp -The options overwrite some default values or set special abilities: -.RS -.TP --blocksize \fIsize\fP -The blocksize is used during data transfer. At most \fIsize\fR bytes -are transfered at once. The default value for this option is 4096. -The package will evaluate the \fB-progress callback\fR for the -session after the transfer of each block. -.TP --timeout \fIseconds\fP -If \fIseconds\fR is non-zero, then \fBftp::Open\fR sets up a timeout -which will occur after the specified number of seconds. The default -value is 600. -.TP --port \fInumber\fP -The port \fInumber\fR specifies an alternative remote port on the ftp -server on which the ftp service resides. Most ftp services listen for -connection requests on the default port 21. Sometimes, usually for -security reasons, port numbers other than 21 are used for ftp -connections. -.TP --mode \fImode\fP -The transfer \fImode\fR option determines if a file transfer occurs in -\fBactive\fR or \fBpassive\fR mode. In passive mode the client -will ask the ftp server to listen on a data port and wait for the -connection rather than to initiate the process by itself when a data -transfer request comes in. Passive mode is normally a requirement when -accessing sites via a firewall. The default mode is \fBactive\fR. -.TP --progress \fIcallback\fP -This \fIcallback\fR is evaluated whenever a block of data was -transfered. See the option \fB-blocksize\fR for how to specify the -size of the transfered blocks. -.sp -When evaluating the \fIcallback\fR one argument is appended to the -callback script, the current accumulated number of bytes transferred -so far. -.TP --command \fIcallback\fP -Specifying this option places the connection into asynchronous -mode. The \fIcallback\fR is evaluated after the completion of any -operation. When an operation is running no further operations must be -started until a callback has been received for the currently executing -operation. -.sp -When evaluating the \fIcallback\fR several arguments are appended to -the callback script, namely the keyword of the operation that has -completed and any additional arguments specific to the operation. If -an error occured during the execution of the operation the callback is -given the keyword \fBerror\fR. -.TP --output \fIcallback\fP -This option has no default. If it is set the default implementation of -\fBDisplayMsg\fR will use its value as command prefix to log all -internal messages. The callback will have three arguments appended to -it before evaluation, the id of the session, the message itself, and -the connection state, in this order. -.RE -.TP -\fBftp::Close\fR \fIhandle\fR -This command terminates the specified ftp session. If no file transfer -is in progress, the server will close the control connection -immediately. If a file transfer is in progress however, the control -connection will remain open until the transfers completes. When that -happens the server will write the result response for the transfer to -it and close the conenction afterward. -.TP -\fBftp::Cd\fR \fIhandle\fR \fIdirectory\fR -This command changes the current working directory on the ftp server -to a specified target \fIdirectory\fR. The command returns 1 if the -current working directory was successfully changed to the specified -directory or 0 if it fails. The target directory can be -.RS -.IP * -a subdirectory of the current directory, -.IP * -.B .. -(as an indicator for the parent directory of the current directory) -.IP * -or a fully qualified path to a new working directory. -.RE -.TP -\fBftp::Pwd\fR \fIhandle\fR -This command returns the complete path of the current working -directory on the ftp server, or an empty string in case of an error. -.TP -\fBftp::Type\fR \fIhandle\fR ?\fIascii|binary|tenex\fR? -This command sets the ftp file transfer type to either \fBascii\fR, -\fBbinary\fR, or \fBtenex\fR. The command always returns the -currently set type. If called without type no change is made. -.sp -Currently only \fBascii\fR and \fBbinary\fR types are -supported. There is some early (alpha) support for Tenex mode. The -type \fBascii\fR is normally used to convert text files into a -format suitable for text editors on the platform of the destination -machine. This mainly affects end-of-line markers. The type -\fBbinary\fR on the other hand allows the undisturbed transfer of -non-text files, such as compressed files, images and executables. -.TP -\fBftp::List\fR \fIhandle\fR ?\fIpattern\fR? -This command returns a human-readable list of files. -Wildcard expressions such as \fI*.tcl\fR are allowed. -If \fIpattern\fR refers to a specific directory, -then the contents of that directory are returned. -If the \fIpattern\fR is not a fully-qualified path name, -the command lists entries relative to the current remote directory. -If no \fIpattern\fR is specified, the contents of the current remote -directory is returned. -.sp -The listing includes any system-dependent information that the server -chooses to include. For example most UNIX systems produce output from -the command \fBls -l\fR. The command returns the retrieved -information as a tcl list with one item per entry. Empty lines and -UNIX's "total" lines are ignored and not included in the result as -reported by this command. -.sp -If the command fails an empty list is returned. -.TP -\fBftp::NList\fR \fIhandle\fR ?\fIdirectory\fR? -This command has the same behavior as the \fBftp::List\fR command, -except that it only retrieves an abbreviated listing. This means only -file names are returned in a sorted list. -.TP -\fBftp::FileSize\fR \fIhandle\fR \fIfile\fR -This command returns the size of the specified \fIfile\fR on the ftp -server. If the command fails an empty string is returned. -.sp -\fBATTENTION!\fR It will not work properly when in ascii mode and -is not supported by all ftp server implementations. -.TP -\fBftp::ModTime\fR \fIhandle\fR \fIfile\fR -This command retrieves the time of the last modification of the -\fIfile\fR on the ftp server as a system dependent integer value in -seconds or an empty string if an error occured. Use the built-in -command \fBclock\fR to convert the retrieves value into other formats. -.TP -\fBftp::Delete\fR \fIhandle\fR \fIfile\fR -This command deletes the specified \fIfile\fR on the ftp server. The -command returns 1 if the specified file was successfully deleted or 0 -if it failed. -.TP -\fBftp::Rename\fR \fIhandle\fR \fIfrom\fR \fIto\fR -This command renames the file \fIfrom\fR in the current directory of -the ftp server to the specified new file name \fIto\fR. This new file -name must not be the same as any existing subdirectory or file name. -The command returns 1 if the specified file was successfully renamed -or 0 if it failed. -.TP -\fBftp::Put\fR \fIhandle\fR (\fIlocal\fR | -data \fIdata\fR | -channel \fIchan\fR) ?\fIremote\fR? -This command transfers a local file \fIlocal\fR to a remote file -\fIremote\fR on the ftp server. If the file parameters passed to the -command do not fully qualified path names the command will use the -current directory on local and remote host. If the remote file name is -unspecified, the server will use the name of the local file as the -name of the remote file. The command returns 1 to indicate a sucessful -transfer and 0 in the case of a failure. -.sp -If \fB-data \fIdata\fR is specified instead of a local file, -the system will not transfer a file, but the \fIdata\fR passed into -it. In this case the name of the remote file has to be specified. -.sp -If \fB-channel \fIchan\fR is specified instead of a local file, the -system will not transfer a file, but read the contents of the channel -\fIchan\fR and write this to the remote file. In this case the name of -the remote file has to be specified. After the transfer \fIchan\fR -will be closed. -.TP -\fBftp::Append\fR \fIhandle\fR (\fIlocal\fR | -data \fIdata\fR | -channel \fIchan\fR) ?\fIremote\fR? -This command behaves like \fBftp::Puts\fR, but appends the transfered -information to the remote file. If the file did not exist on the -server it will be created. -.TP -\fBftp::Get\fR \fIhandle\fR \fIremote\fR ?(\fIlocal\fR | -variable \fIvarname\fR | -channel \fIchan\fR)? -This command retrieves a remote file \fIremote\fR on the ftp server -and stores its contents into the local file \fIlocal\fR. If the file -parameters passed to the command are not fully qualified path names the -command will use the current directory on local and remote host. If -the local file name is unspecified, the server will use the name of -the remote file as the name of the local file. The command returns 1 -to indicate a sucessful transfer and 0 in the case of a failure. The -command will throw an error if the directory the file \fIlocal\fR is -to be placed in does not exist. -.sp -If \fB-variable \fIvarname\fR is specified, the system will -store the retrieved data into the variable \fIvarname\fR instead of a -file. -.sp -If \fB-channel \fIchan\fR is specified, the system will write the -retrieved data into the channel \fIchan\fR instead of a file. The -system will \fBnot\fR close \fIchan\fR after the transfer, this is the -responsibility of the caller to \fBGet\fR. -.TP -\fBftp::Reget\fR \fIhandle\fR \fIremote\fR ?\fIlocal\fR? ?\fIfrom\fR? ?\fIto\fR? -This command behaves like \fBftp::Get\fR, except that if local file -\fIlocal\fR exists and is smaller than remote file \fIremote\fR, the -local file is presumed to be a partially transferred copy of the -remote file and the transfer is continued from the apparent point of -failure. The command will throw an error if the directory the file -\fIlocal\fR is to be placed in does not exist. This command is useful -when transferring very large files over networks that tend to drop -connections. -.sp -Specifying the additional byte offsets \fIfrom\fR and \fIto\fR will -cause the command to change its behaviour and to download exactly the -specified slice of the remote file. This mode is possible only if a -local destination is explicitly provided. Omission of \fIto\fR leads -to downloading till the end of the file. -.TP -\fBftp::Newer\fR \fIhandle\fR \fIremote\fR ?\fIlocal\fR? -This command behaves like \fBftp::Get\fR, except that it retrieves the -remote file only if the modification time of the remote file is more -recent than the file on the local system. If the file does not exist -on the local system, the remote file is considered newer. The command -will throw an error if the directory the file \fIlocal\fR is to be -placed in does not exist. -.TP -\fBftp::MkDir\fR \fIhandle\fR \fIdirectory\fR -This command creates the specified \fIdirectory\fR on the ftp -server. If the specified path is relative the new directory will be -created as a subdirectory of the current working directory. Else the -created directory will have the specified path name. The command -returns 1 to indicate a sucessful creation of the directory and 0 in -the case of a failure. -.TP -\fBftp::RmDir\fR \fIhandle\fR \fIdirectory\fR -This command removes the specified directory on the ftp server. The -remote directory has to be empty or the command will fail. The command -returns 1 to indicate a sucessful removal of the directory and 0 in -the case of a failure. -.TP -\fBftp::Quote\fR \fIhandle\fR \fIarg1\fR \fIarg2\fR \fI...\fR -This command is used to send an arbitrary ftp command to the -server. It cannot be used to obtain a directory listing or for -transferring files. It is included to allow an application to execute -commands on the ftp server which are not provided by this package. -The arguments are sent verbatim, i.e. as is, with no changes. -.sp -In constrast to the other commands in this package this command will -not parse the response it got from the ftp server but return it -verbatim to the caller. -.TP -\fBftp::DisplayMsg\fR \fIhandle\fR \fImsg\fR ?\fIstate\fR? -This command is used by the package itself to show the different -messages from the ftp sessions. The package itself declares this -command very simple, writing the messages to \fIstdout\fR (if -\fIVERBOSE\fR was set, see below) and throwing tcl errors for error -messages. It is the responsibility of the application to overwrite it -as needed. A state variable for different states assigned to different -colors is recommended by the author. The \fBlog\fR package can be -useful for this. -.TP -\fBftp::VERBOSE\fR -A state variable controlling the output of the package. Setting -\fIftp::VERBOSE\fR to \fI1\fR forces the package to show all -responses from a remote server. The default value is \fI0\fR. -.TP -\fBftp::DEBUG\fR -A state variable controlling the output of ftp. Setting -\fIftp::DEBUG\fR to \fI1\fR enables debugging and forces the package -to show all return codes, states, state changes and "real" ftp -commands. The default value is \fI0\fR. -.SH "BUGS" -.PP -The correct execution of many commands depends upon the proper -behavior by the remote server, network and router configuration. -.PP -An update command placed in the procedure \fBDisplayMsg\fR may run -into persistent errors or infinite loops. The solution to this problem -is to use \fBupdate idletasks\fR instead of \fBupdate\fR. -.SH "SEE ALSO" -ftpd, smtp, pop3, mime -.SH "KEYWORDS" -ftp, rfc959, internet, net - DELETED modules/ftp/ftp.tcl Index: modules/ftp/ftp.tcl ================================================================== --- modules/ftp/ftp.tcl +++ /dev/null @@ -1,2978 +0,0 @@ -# ftp.tcl -- -# -# FTP library package for Tcl 8.2+. Originally written by Steffen -# Traeger (Steffen.Traeger@t-online.de); modified by Peter MacDonald -# (peter@pdqi.com) to support multiple simultaneous FTP sessions; -# Modified by Steve Ball (Steve.Ball@zveno.com) to support -# asynchronous operation. -# -# Copyright (c) 1996-1999 by Steffen Traeger -# Copyright (c) 2000 by Ajuba Solutions -# Copyright (c) 2000 by Zveno Pty Ltd -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: ftp.tcl,v 1.30 2003/04/11 18:39:17 andreas_kupries Exp $ -# -# core ftp support: ftp::Open -# ftp::Close -# ftp::Cd -# ftp::Pwd -# ftp::Type -# ftp::List -# ftp::NList -# ftp::FileSize -# ftp::ModTime -# ftp::Delete -# ftp::Rename -# ftp::Put <(local | -data "data" -channel chan)> -# ftp::Append <(local | -data "data" | -channel chan)> -# ftp::Get -# ftp::Reget -# ftp::Newer -# ftp::MkDir -# ftp::RmDir -# ftp::Quote ... -# -# Internal documentation. Contents of a session state array. -# -# --------------------------------------------- -# key value -# --------------------------------------------- -# State Current state of the session and the currently executing command. -# RemoteFileName Name of the remote file, for put/get -# LocalFileName Name of local file, for put/get -# inline 1 - Put/Get is inline (from data, to variable) -# filebuffer -# PutData Data to move when inline -# SourceCI Channel to read from, "Put" -# --------------------------------------------- -# - -package require Tcl 8.2 -package require log ; # tcllib/log, general logging facility. - -namespace eval ::ftp { - namespace export DisplayMsg Open Close Cd Pwd Type List NList \ - FileSize ModTime Delete Rename Put Append Get Reget \ - Newer Quote MkDir RmDir - - set serial 0 - set VERBOSE 0 - set DEBUG 0 -} - -############################################################################# -# -# DisplayMsg -- -# -# This is a simple procedure to display any messages on screen. -# Can be intercepted by the -output option to Open -# -# namespace ftp { -# proc DisplayMsg {msg} { -# ...... -# } -# } -# -# Arguments: -# msg - message string -# state - different states {normal, data, control, error} -# -proc ::ftp::DisplayMsg {s msg {state ""}} { - - upvar ::ftp::ftp$s ftp - - if { ([info exists ftp(Output)]) && ($ftp(Output) != "") } { - eval [concat $ftp(Output) {$s $msg $state}] - return - } - - # FIX #476729. Instead of changing the documentation this - # procedure is changed to enforce the documented - # behaviour. IOW, this procedure will not throw - # errors anymore. At the same time printing to stdout - # is exchanged against calls into the 'log' module - # tcllib, which is much easier to customize for the - # needs of any application using the ftp module. The - # variable VERBOSE is still relevant as it controls - # whether this procedure is called or not. - - switch -exact -- $state { - data {log::log debug "$state | $msg"} - control {log::log debug "$state | $msg"} - error {log::log error "$state | E: $msg"} - default {log::log debug "$state | $msg"} - } - return -} - -############################################################################# -# -# Timeout -- -# -# Handle timeouts -# -# Arguments: -# - -# -proc ::ftp::Timeout {s} { - upvar ::ftp::ftp$s ftp - - after cancel $ftp(Wait) - set ftp(state.control) 1 - - DisplayMsg "" "Timeout of control connection after $ftp(Timeout) sec.!" error - Command $ftp(Command) timeout - return -} - -############################################################################# -# -# WaitOrTimeout -- -# -# Blocks the running procedure and waits for a variable of the transaction -# to complete. It continues processing procedure until a procedure or -# StateHandler sets the value of variable "finished". -# If a connection hangs the variable is setting instead of by this procedure after -# specified seconds in $ftp(Timeout). -# -# -# Arguments: -# - -# - -proc ::ftp::WaitOrTimeout {s} { - upvar ::ftp::ftp$s ftp - - set retvar 1 - - if { ![string length $ftp(Command)] && [info exists ftp(state.control)] } { - - set ftp(Wait) [after [expr {$ftp(Timeout) * 1000}] [list [namespace current]::Timeout $s]] - - vwait ::ftp::ftp${s}(state.control) - set retvar $ftp(state.control) - } - - if {$ftp(Error) != ""} { - set errmsg $ftp(Error) - set ftp(Error) "" - DisplayMsg $s $errmsg error - } - - return $retvar -} - -############################################################################# -# -# WaitComplete -- -# -# Transaction completed. -# Cancel execution of the delayed command declared in procedure WaitOrTimeout. -# -# Arguments: -# value - result of the transaction -# 0 ... Error -# 1 ... OK -# - -proc ::ftp::WaitComplete {s value} { - upvar ::ftp::ftp$s ftp - - if {![info exists ftp(Command)]} { - set ftp(state.control) $value - return $value - } - if { ![string length $ftp(Command)] && [info exists ftp(state.data)] } { - vwait ::ftp::ftp${s}(state.data) - } - - catch {after cancel $ftp(Wait)} - set ftp(state.control) $value - return $ftp(state.control) -} - -############################################################################# -# -# PutsCtrlSocket -- -# -# Puts then specified command to control socket, -# if DEBUG is set than it logs via DisplayMsg -# -# Arguments: -# command - ftp command -# - -proc ::ftp::PutsCtrlSock {s {command ""}} { - upvar ::ftp::ftp$s ftp - variable DEBUG - - if { $DEBUG } { - DisplayMsg $s "---> $command" - } - - puts $ftp(CtrlSock) $command - flush $ftp(CtrlSock) - return -} - -############################################################################# -# -# StateHandler -- -# -# Implements a finite state handler and a fileevent handler -# for the control channel -# -# Arguments: -# sock - socket name -# If called from a procedure than this argument is empty. -# If called from a fileevent than this argument contains -# the socket channel identifier. - -proc ::ftp::StateHandler {s {sock ""}} { - upvar ::ftp::ftp$s ftp - variable DEBUG - variable VERBOSE - - # disable fileevent on control socket, enable it at the and of the state machine - # fileevent $ftp(CtrlSock) readable {} - - # there is no socket (and no channel to get) if called from a procedure - - set rc " " - set msgtext {} - - if { $sock != "" } { - - set number [gets $sock bufline] - - if { $number > 0 } { - - # get return code, check for multi-line text - - regexp -- "(^\[0-9\]+)( |-)?(.*)$" $bufline all rc multi_line msgtext - set buffer $bufline - - # multi-line format detected ("-"), get all the lines - # until the real return code - - while { [string equal $multi_line "-"] } { - set number [gets $sock bufline] - if { $number > 0 } { - append buffer \n "$bufline" - regexp -- "(^\[0-9\]+)( |-)?(.*)$" $bufline all rc multi_line - } - } - } elseif { [eof $ftp(CtrlSock)] } { - # remote server has closed control connection - # kill control socket, unset State to disable all following command - - set rc 421 - if { $VERBOSE } { - DisplayMsg $s "C: 421 Service not available, closing control connection." control - } - set ftp(Error) "Service not available!" - CloseDataConn $s - WaitComplete $s 0 - Command $ftp(Command) terminated - catch {unset ftp(State)} - catch {close $ftp(CtrlSock); unset ftp(CtrlSock)} - return - } else { - # Fix SF bug #466746: Incomplete line, do nothing. - return - } - } - - if { $DEBUG } { - DisplayMsg $s "-> rc=\"$rc\"\n-> msgtext=\"$msgtext\"\n-> state=\"$ftp(State)\"" - } - - # In asynchronous mode, should we move on to the next state? - set nextState 0 - - # system status replay - if { [string equal $rc "211"] } { - return - } - - # use only the first digit - regexp -- "^\[0-9\]?" $rc rc - - switch -exact -- $ftp(State) { - user { - switch -exact -- $rc { - 2 { - PutsCtrlSock $s "USER $ftp(User)" - set ftp(State) passwd - Command $ftp(Command) user - } - default { - set errmsg "Error connecting! $msgtext" - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - passwd { - switch -exact -- $rc { - 2 { - set complete_with 1 - Command $ftp(Command) password - } - 3 { - PutsCtrlSock $s "PASS $ftp(Passwd)" - set ftp(State) connect - Command $ftp(Command) password - } - default { - set errmsg "Error connecting! $msgtext" - set complete_with 0 - Command $ftp(Command) error $msgtext - } - } - } - connect { - switch -exact -- $rc { - 2 { - # The type is set after this, and we want to report - # that the connection is complete once the type is done - set nextState 1 - if {[info exists ftp(NextState)] && ![llength $ftp(NextState)]} { - Command $ftp(Command) connect $s - } else { - set complete_with 1 - } - } - default { - set errmsg "Error connecting! $msgtext" - set complete_with 0 - Command $ftp(Command) error $msgtext - } - } - } - connect_last { - Command $ftp(Command) connect $s - set complete_with 1 - } - quit { - PutsCtrlSock $s "QUIT" - set ftp(State) quit_sent - } - quit_sent { - switch -exact -- $rc { - 2 { - set complete_with 1 - set nextState 1 - Command $ftp(Command) quit - } - default { - set errmsg "Error disconnecting! $msgtext" - set complete_with 0 - Command $ftp(Command) error $msgtext - } - } - } - quote { - PutsCtrlSock $s $ftp(Cmd) - set ftp(State) quote_sent - } - quote_sent { - set complete_with 1 - set ftp(Quote) $buffer - set nextState 1 - Command $ftp(Command) quote $buffer - } - type { - if { [string equal $ftp(Type) "ascii"] } { - PutsCtrlSock $s "TYPE A" - } elseif { [string equal $ftp(Type) "binary"] } { - PutsCtrlSock $s "TYPE I" - } else { - PutsCtrlSock $s "TYPE L" - } - set ftp(State) type_sent - } - type_sent { - switch -exact -- $rc { - 2 { - set complete_with 1 - set nextState 1 - Command $ftp(Command) type $ftp(Type) - } - default { - set errmsg "Error setting type \"$ftp(Type)\"!" - set complete_with 0 - Command $ftp(Command) error "error setting type \"$ftp(Type)\"" - } - } - } - type_change { - set ftp(Type) $ftp(type:changeto) - set ftp(State) type - StateHandler $s - } - nlist_active { - if { [OpenActiveConn $s] } { - PutsCtrlSock $s "PORT $ftp(LocalAddr),$ftp(DataPort)" - set ftp(State) nlist_open - } else { - set errmsg "Error setting port!" - } - } - nlist_passive { - PutsCtrlSock $s "PASV" - set ftp(State) nlist_open - } - nlist_open { - switch -exact -- $rc { - 1 {} - 2 { - if { [string equal $ftp(Mode) "passive"] } { - if { ![OpenPassiveConn $s $buffer] } { - set errmsg "Error setting PASSIVE mode!" - set complete_with 0 - Command $ftp(Command) error "error setting passive mode" - } - } - PutsCtrlSock $s "NLST$ftp(Dir)" - set ftp(State) list_sent - } - default { - if { [string equal $ftp(Mode) "passive"] } { - set errmsg "Error setting PASSIVE mode!" - } else { - set errmsg "Error setting port!" - } - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - list_active { - if { [OpenActiveConn $s] } { - PutsCtrlSock $s "PORT $ftp(LocalAddr),$ftp(DataPort)" - set ftp(State) list_open - } else { - set errmsg "Error setting port!" - Command $ftp(Command) error $errmsg - } - } - list_passive { - PutsCtrlSock $s "PASV" - set ftp(State) list_open - } - list_open { - switch -exact -- $rc { - 1 {} - 2 { - if { [string equal $ftp(Mode) "passive"] } { - if { ![OpenPassiveConn $s $buffer] } { - set errmsg "Error setting PASSIVE mode!" - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - PutsCtrlSock $s "LIST$ftp(Dir)" - set ftp(State) list_sent - } - default { - if { [string equal $ftp(Mode) "passive"] } { - set errmsg "Error setting PASSIVE mode!" - } else { - set errmsg "Error setting port!" - } - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - list_sent { - switch -exact -- $rc { - 1 - - 2 { - set ftp(State) list_close - } - default { - if { [string equal $ftp(Mode) "passive"] } { - unset ftp(state.data) - } - set errmsg "Error getting directory listing!" - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - list_close { - switch -exact -- $rc { - 1 {} - 2 { - set nextState 1 - if {[info exists ftp(NextState)] && ![llength $ftp(NextState)]} { - Command $ftp(Command) list [ListPostProcess $ftp(List)] - } else { - set complete_with 1 - } - } - default { - set errmsg "Error receiving list!" - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - list_last { - Command $ftp(Command) list [ListPostProcess $ftp(List)] - set complete_with 1 - } - size { - PutsCtrlSock $s "SIZE $ftp(File)" - set ftp(State) size_sent - } - size_sent { - switch -exact -- $rc { - 2 { - regexp -- "^\[0-9\]+ (.*)$" $buffer all ftp(FileSize) - set complete_with 1 - set nextState 1 - Command $ftp(Command) size $ftp(File) $ftp(FileSize) - } - default { - set errmsg "Error getting file size!" - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - modtime { - if {$ftp(DateTime) != ""} { - PutsCtrlSock $s "MDTM $ftp(DateTime) $ftp(File)" - } else { ;# No DateTime Specified - PutsCtrlSock $s "MDTM $ftp(File)" - } - set ftp(State) modtime_sent - } - modtime_sent { - switch -exact -- $rc { - 2 { - regexp -- "^\[0-9\]+ (.*)$" $buffer all ftp(DateTime) - set complete_with 1 - set nextState 1 - Command $ftp(Command) modtime $ftp(File) [ModTimePostProcess $ftp(DateTime)] - } - default { - if {$ftp(DateTime) != ""} { - set errmsg "Error setting modification time! No server MDTM support?" - } else { - set errmsg "Error getting modification time!" - } - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - pwd { - PutsCtrlSock $s "PWD" - set ftp(State) pwd_sent - } - pwd_sent { - switch -exact -- $rc { - 2 { - regexp -- "^.*\"(.*)\"" $buffer temp ftp(Dir) - set complete_with 1 - set nextState 1 - Command $ftp(Command) pwd $ftp(Dir) - } - default { - set errmsg "Error getting working dir!" - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - cd { - PutsCtrlSock $s "CWD$ftp(Dir)" - set ftp(State) cd_sent - } - cd_sent { - switch -exact -- $rc { - 1 {} - 2 { - set complete_with 1 - set nextState 1 - Command $ftp(Command) cd $ftp(Dir) - } - default { - set errmsg "Error changing directory to \"$ftp(Dir)\"" - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - mkdir { - PutsCtrlSock $s "MKD $ftp(Dir)" - set ftp(State) mkdir_sent - } - mkdir_sent { - switch -exact -- $rc { - 2 { - set complete_with 1 - set nextState 1 - Command $ftp(Command) mkdir $ftp(Dir) - } - default { - set errmsg "Error making dir \"$ftp(Dir)\"!" - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - rmdir { - PutsCtrlSock $s "RMD $ftp(Dir)" - set ftp(State) rmdir_sent - } - rmdir_sent { - switch -exact -- $rc { - 2 { - set complete_with 1 - set nextState 1 - Command $ftp(Command) rmdir $ftp(Dir) - } - default { - set errmsg "Error removing directory!" - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - delete { - PutsCtrlSock $s "DELE $ftp(File)" - set ftp(State) delete_sent - } - delete_sent { - switch -exact -- $rc { - 2 { - set complete_with 1 - set nextState 1 - Command $ftp(Command) delete $ftp(File) - } - default { - set errmsg "Error deleting file \"$ftp(File)\"!" - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - rename { - PutsCtrlSock $s "RNFR $ftp(RenameFrom)" - set ftp(State) rename_to - } - rename_to { - switch -exact -- $rc { - 3 { - PutsCtrlSock $s "RNTO $ftp(RenameTo)" - set ftp(State) rename_sent - } - default { - set errmsg "Error renaming file \"$ftp(RenameFrom)\"!" - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - rename_sent { - switch -exact -- $rc { - 2 { - set complete_with 1 - set nextState 1 - Command $ftp(Command) rename $ftp(RenameFrom) $ftp(RenameTo) - } - default { - set errmsg "Error renaming file \"$ftp(RenameFrom)\"!" - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - put_active { - if { [OpenActiveConn $s] } { - PutsCtrlSock $s "PORT $ftp(LocalAddr),$ftp(DataPort)" - set ftp(State) put_open - } else { - set errmsg "Error setting port!" - Command $ftp(Command) error $errmsg - } - } - put_passive { - PutsCtrlSock $s "PASV" - set ftp(State) put_open - } - put_open { - switch -exact -- $rc { - 1 - - 2 { - if { [string equal $ftp(Mode) "passive"] } { - if { ![OpenPassiveConn $s $buffer] } { - set errmsg "Error setting PASSIVE mode!" - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - PutsCtrlSock $s "STOR $ftp(RemoteFilename)" - set ftp(State) put_sent - } - default { - if { [string equal $ftp(Mode) "passive"] } { - set errmsg "Error setting PASSIVE mode!" - } else { - set errmsg "Error setting port!" - } - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - put_sent { - switch -exact -- $rc { - 1 - - 2 { - set ftp(State) put_close - } - default { - if { [string equal $ftp(Mode) "passive"] } { - # close already opened DataConnection - unset ftp(state.data) - } - set errmsg "Error opening connection!" - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - put_close { - switch -exact -- $rc { - 1 { - # Keep going - return - } - 2 { - set complete_with 1 - set nextState 1 - Command $ftp(Command) put $ftp(RemoteFilename) - } - default { - DisplayMsg $s "rc = $rc msgtext = \"$msgtext\"" - set errmsg "Error storing file \"$ftp(RemoteFilename)\" due to \"$msgtext\"" - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - append_active { - if { [OpenActiveConn $s] } { - PutsCtrlSock $s "PORT $ftp(LocalAddr),$ftp(DataPort)" - set ftp(State) append_open - } else { - set errmsg "Error setting port!" - Command $ftp(Command) error $errmsg - } - } - append_passive { - PutsCtrlSock $s "PASV" - set ftp(State) append_open - } - append_open { - switch -exact -- $rc { - 1 - - 2 { - if { [string equal $ftp(Mode) "passive"] } { - if { ![OpenPassiveConn $s $buffer] } { - set errmsg "Error setting PASSIVE mode!" - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - PutsCtrlSock $s "APPE $ftp(RemoteFilename)" - set ftp(State) append_sent - } - default { - if { [string equal $ftp(Mode) "passive"] } { - set errmsg "Error setting PASSIVE mode!" - } else { - set errmsg "Error setting port!" - } - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - append_sent { - switch -exact -- $rc { - 1 { - set ftp(State) append_close - } - default { - if { [string equal $ftp(Mode) "passive"] } { - # close already opened DataConnection - unset ftp(state.data) - } - set errmsg "Error opening connection!" - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - append_close { - switch -exact -- $rc { - 2 { - set complete_with 1 - set nextState 1 - Command $ftp(Command) append $ftp(RemoteFilename) - } - default { - set errmsg "Error storing file \"$ftp(RemoteFilename)\"!" - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - reget_active { - if { [OpenActiveConn $s] } { - PutsCtrlSock $s "PORT $ftp(LocalAddr),$ftp(DataPort)" - set ftp(State) reget_restart - } else { - set errmsg "Error setting port!" - Command $ftp(Command) error $errmsg - } - } - reget_passive { - PutsCtrlSock $s "PASV" - set ftp(State) reget_restart - } - reget_restart { - switch -exact -- $rc { - 2 { - if { [string equal $ftp(Mode) "passive"] } { - if { ![OpenPassiveConn $s $buffer] } { - set errmsg "Error setting PASSIVE mode!" - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - if { $ftp(FileSize) != 0 } { - PutsCtrlSock $s "REST $ftp(FileSize)" - set ftp(State) reget_open - } else { - PutsCtrlSock $s "RETR $ftp(RemoteFilename)" - set ftp(State) reget_sent - } - } - default { - set errmsg "Error restarting filetransfer of \"$ftp(RemoteFilename)\"!" - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - reget_open { - switch -exact -- $rc { - 2 - - 3 { - PutsCtrlSock $s "RETR $ftp(RemoteFilename)" - set ftp(State) reget_sent - } - default { - if { [string equal $ftp(Mode) "passive"] } { - set errmsg "Error setting PASSIVE mode!" - } else { - set errmsg "Error setting port!" - } - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - reget_sent { - switch -exact -- $rc { - 1 { - set ftp(State) reget_close - } - default { - if { [string equal $ftp(Mode) "passive"] } { - # close already opened DataConnection - unset ftp(state.data) - } - set errmsg "Error retrieving file \"$ftp(RemoteFilename)\"!" - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - reget_close { - switch -exact -- $rc { - 2 { - set complete_with 1 - set nextState 1 - Command $ftp(Command) get $ftp(RemoteFilename):$ftp(From):$ftp(To) - unset ftp(From) ftp(To) - } - default { - set errmsg "Error retrieving file \"$ftp(RemoteFilename)\"!" - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - get_active { - if { [OpenActiveConn $s] } { - PutsCtrlSock $s "PORT $ftp(LocalAddr),$ftp(DataPort)" - set ftp(State) get_open - } else { - set errmsg "Error setting port!" - Command $ftp(Command) error $errmsg - } - } - get_passive { - PutsCtrlSock $s "PASV" - set ftp(State) get_open - } - get_open { - switch -exact -- $rc { - 1 - - 2 - - 3 { - if { [string equal $ftp(Mode) "passive"] } { - if { ![OpenPassiveConn $s $buffer] } { - set errmsg "Error setting PASSIVE mode!" - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - PutsCtrlSock $s "RETR $ftp(RemoteFilename)" - set ftp(State) get_sent - } - default { - if { [string equal $ftp(Mode) "passive"] } { - set errmsg "Error setting PASSIVE mode!" - } else { - set errmsg "Error setting port!" - } - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - get_sent { - switch -exact -- $rc { - 1 { - set ftp(State) get_close - } - default { - if { [string equal $ftp(Mode) "passive"] } { - # close already opened DataConnection - unset ftp(state.data) - } - set errmsg "Error retrieving file \"$ftp(RemoteFilename)\"!" - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - get_close { - switch -exact -- $rc { - 2 { - set complete_with 1 - set nextState 1 - if {$ftp(inline)} { - upvar #0 $ftp(get:varname) returnData - set returnData $ftp(GetData) - Command $ftp(Command) get $ftp(GetData) - } else { - Command $ftp(Command) get $ftp(RemoteFilename) - } - } - default { - set errmsg "Error retrieving file \"$ftp(RemoteFilename)\"!" - set complete_with 0 - Command $ftp(Command) error $errmsg - } - } - } - default { - error "Unknown state \"$ftp(State)\"" - } - } - - # finish waiting - if { [info exists complete_with] } { - WaitComplete $s $complete_with - } - - # display control channel message - if { [info exists buffer] } { - if { $VERBOSE } { - foreach line [split $buffer \n] { - DisplayMsg $s "C: $line" control - } - } - } - - # Rather than throwing an error in the event loop, set the ftp(Error) - # variable to hold the message so that it can later be thrown after the - # the StateHandler has completed. - - if { [info exists errmsg] } { - set ftp(Error) $errmsg - } - - # If operating asynchronously, commence next state - if {$nextState && [info exists ftp(NextState)] && [llength $ftp(NextState)]} { - # Pop the head of the NextState queue - set ftp(State) [lindex $ftp(NextState) 0] - set ftp(NextState) [lreplace $ftp(NextState) 0 0] - StateHandler $s - } - - # enable fileevent on control socket again - #fileevent $ftp(CtrlSock) readable [list ::ftp::StateHandler $ftp(CtrlSock)] - -} - -############################################################################# -# -# Type -- -# -# REPRESENTATION TYPE - Sets the file transfer type to ascii or binary. -# (exported) -# -# Arguments: -# type - specifies the representation type (ascii|binary) -# -# Returns: -# type - returns the current type or {} if an error occurs - -proc ::ftp::Type {s {type ""}} { - upvar ::ftp::ftp$s ftp - - if { ![info exists ftp(State)] } { - if { ![string is digit -strict $s] } { - DisplayMsg $s "Bad connection name \"$s\"" error - } else { - DisplayMsg $s "Not connected!" error - } - return {} - } - - # return current type - if { $type == "" } { - return $ftp(Type) - } - - # save current type - set old_type $ftp(Type) - - set ftp(Type) $type - set ftp(State) type - StateHandler $s - - # wait for synchronization - set rc [WaitOrTimeout $s] - if { $rc } { - return $ftp(Type) - } else { - # restore old type - set ftp(Type) $old_type - return {} - } -} - -############################################################################# -# -# NList -- -# -# NAME LIST - This command causes a directory listing to be sent from -# server to user site. -# (exported) -# -# Arguments: -# dir - The $dir should specify a directory or other system -# specific file group descriptor; a null argument -# implies the current directory. -# -# Arguments: -# dir - directory to list -# -# Returns: -# sorted list of files or {} if listing fails - -proc ::ftp::NList {s { dir ""}} { - upvar ::ftp::ftp$s ftp - - if { ![info exists ftp(State)] } { - if { ![string is digit -strict $s] } { - DisplayMsg $s "Bad connection name \"$s\"" error - } else { - DisplayMsg $s "Not connected!" error - } - return {} - } - - set ftp(List) {} - if { $dir == "" } { - set ftp(Dir) "" - } else { - set ftp(Dir) " $dir" - } - - # save current type and force ascii mode - set old_type $ftp(Type) - if { $ftp(Type) != "ascii" } { - if {[string length $ftp(Command)]} { - set ftp(NextState) [list nlist_$ftp(Mode) type_change list_last] - set ftp(type:changeto) $old_type - Type $s ascii - return {} - } - Type $s ascii - } - - set ftp(State) nlist_$ftp(Mode) - StateHandler $s - - # wait for synchronization - set rc [WaitOrTimeout $s] - - # restore old type - if { [Type $s] != $old_type } { - Type $s $old_type - } - - unset ftp(Dir) - if { $rc } { - return [lsort $ftp(List)] - } else { - CloseDataConn $s - return {} - } -} - -############################################################################# -# -# List -- -# -# LIST - This command causes a list to be sent from the server -# to user site. -# (exported) -# -# Arguments: -# dir - If the $dir specifies a directory or other group of -# files, the server should transfer a list of files in -# the specified directory. If the $dir specifies a file -# then the server should send current information on the -# file. A null argument implies the user's current -# working or default directory. -# -# Returns: -# list of files or {} if listing fails - -proc ::ftp::List {s {dir ""}} { - - upvar ::ftp::ftp$s ftp - - if { ![info exists ftp(State)] } { - if { ![string is digit -strict $s] } { - DisplayMsg $s "Bad connection name \"$s\"" error - } else { - DisplayMsg $s "Not connected!" error - } - return {} - } - - set ftp(List) {} - if { $dir == "" } { - set ftp(Dir) "" - } else { - set ftp(Dir) " $dir" - } - - # save current type and force ascii mode - - set old_type $ftp(Type) - if { ![string equal "$ftp(Type)" "ascii"] } { - if {[string length $ftp(Command)]} { - set ftp(NextState) [list list_$ftp(Mode) type_change list_last] - set ftp(type:changeto) $old_type - Type $s ascii - return {} - } - Type $s ascii - } - - set ftp(State) list_$ftp(Mode) - StateHandler $s - - # wait for synchronization - - set rc [WaitOrTimeout $s] - - # restore old type - - if { ![string equal "[Type $s]" "$old_type"] } { - Type $s $old_type - } - - unset ftp(Dir) - if { $rc } { - return [ListPostProcess $ftp(List)] - } else { - CloseDataConn $s - return {} - } -} - -proc ::ftp::ListPostProcess l { - - # clear "total"-line - - set l [split $l "\n"] - set index [lsearch -regexp $l "^total"] - if { $index != "-1" } { - set l [lreplace $l $index $index] - } - - # clear blank line - - set index [lsearch -regexp $l "^$"] - if { $index != "-1" } { - set l [lreplace $l $index $index] - } - - return $l -} - -############################################################################# -# -# FileSize -- -# -# REMOTE FILE SIZE - This command gets the file size of the -# file on the remote machine. -# ATTENTION! Doesn't work properly in ascii mode! -# (exported) -# -# Arguments: -# filename - specifies the remote file name -# -# Returns: -# size - files size in bytes or {} in error cases - -proc ::ftp::FileSize {s {filename ""}} { - upvar ::ftp::ftp$s ftp - - if { ![info exists ftp(State)] } { - if { ![string is digit -strict $s] } { - DisplayMsg $s "Bad connection name \"$s\"" error - } else { - DisplayMsg $s "Not connected!" error - } - return {} - } - - if { $filename == "" } { - return {} - } - - set ftp(File) $filename - set ftp(FileSize) 0 - - set ftp(State) size - StateHandler $s - - # wait for synchronization - set rc [WaitOrTimeout $s] - - if {![string length $ftp(Command)]} { - unset ftp(File) - } - - if { $rc } { - return $ftp(FileSize) - } else { - return {} - } -} - - -############################################################################# -# -# ModTime -- -# -# MODIFICATION TIME - This command gets the last modification time of the -# file on the remote machine. -# (exported) -# -# Arguments: -# filename - specifies the remote file name -# datetime - optional new timestamp for file -# -# Returns: -# clock - files date and time as a system-depentend integer -# value in seconds (see tcls clock command) or {} in -# error cases -# if MDTM not supported on server, returns original timestamp - -proc ::ftp::ModTime {s {filename ""} {datetime ""}} { - upvar ::ftp::ftp$s ftp - - if { ![info exists ftp(State)] } { - if { ![string is digit -strict $s] } { - DisplayMsg $s "Bad connection name \"$s\"" error - } else { - DisplayMsg $s "Not connected!" error - } - return {} - } - - if { $filename == "" } { - return {} - } - - set ftp(File) $filename - - if {$datetime != ""} { - set datetime [clock format $datetime -format "%Y%m%d%H%M%S"] - } - set ftp(DateTime) $datetime - - set ftp(State) modtime - StateHandler $s - - # wait for synchronization - set rc [WaitOrTimeout $s] - - if {![string length $ftp(Command)]} { - unset ftp(File) - } - if { ![string length $ftp(Command)] && $rc } { - return [ModTimePostProcess $ftp(DateTime)] - } else { - return {} - } -} - -proc ::ftp::ModTimePostProcess {clock} { - foreach {year month day hour min sec} {1 1 1 1 1 1} break - - # Bug #478478. Special code to detect ftp servers with a Y2K patch - # gone bad and delivering, hmmm, non-standard date information. - - if {[string length $clock] == 15} { - scan $clock "%2s%3s%2s%2s%2s%2s%2s" cent year month day hour min sec - set year [expr {($cent * 100) + $year}] - log::log warning "data | W: server with non-standard time, bad Y2K patch." - } else { - scan $clock "%4s%2s%2s%2s%2s%2s" year month day hour min sec - } - - set clock [clock scan "$month/$day/$year $hour:$min:$sec" -gmt 1] - return $clock -} - -############################################################################# -# -# Pwd -- -# -# PRINT WORKING DIRECTORY - Causes the name of the current working directory. -# (exported) -# -# Arguments: -# None. -# -# Returns: -# current directory name - -proc ::ftp::Pwd {s } { - upvar ::ftp::ftp$s ftp - - if { ![info exists ftp(State)] } { - if { ![string is digit -strict $s] } { - DisplayMsg $s "Bad connection name \"$s\"" error - } else { - DisplayMsg $s "Not connected!" error - } - return {} - } - - set ftp(Dir) {} - - set ftp(State) pwd - StateHandler $s - - # wait for synchronization - set rc [WaitOrTimeout $s] - - if { $rc } { - return $ftp(Dir) - } else { - return {} - } -} - -############################################################################# -# -# Cd -- -# -# CHANGE DIRECTORY - Sets the working directory on the server host. -# (exported) -# -# Arguments: -# dir - pathname specifying a directory -# -# Returns: -# 0 - ERROR -# 1 - OK - -proc ::ftp::Cd {s {dir ""}} { - upvar ::ftp::ftp$s ftp - - if { ![info exists ftp(State)] } { - if { ![string is digit -strict $s] } { - DisplayMsg $s "Bad connection name \"$s\"" error - } else { - DisplayMsg $s "Not connected!" error - } - return 0 - } - - if { $dir == "" } { - set ftp(Dir) "" - } else { - set ftp(Dir) " $dir" - } - - set ftp(State) cd - StateHandler $s - - # wait for synchronization - set rc [WaitOrTimeout $s] - - if {![string length $ftp(Command)]} { - unset ftp(Dir) - } - - if { $rc } { - return 1 - } else { - return 0 - } -} - -############################################################################# -# -# MkDir -- -# -# MAKE DIRECTORY - This command causes the directory specified in the $dir -# to be created as a directory (if the $dir is absolute) or as a subdirectory -# of the current working directory (if the $dir is relative). -# (exported) -# -# Arguments: -# dir - new directory name -# -# Returns: -# 0 - ERROR -# 1 - OK - -proc ::ftp::MkDir {s dir} { - upvar ::ftp::ftp$s ftp - - if { ![info exists ftp(State)] } { - DisplayMsg $s "Not connected!" error - return 0 - } - - set ftp(Dir) $dir - - set ftp(State) mkdir - StateHandler $s - - # wait for synchronization - set rc [WaitOrTimeout $s] - - if {![string length $ftp(Command)]} { - unset ftp(Dir) - } - - if { $rc } { - return 1 - } else { - return 0 - } -} - -############################################################################# -# -# RmDir -- -# -# REMOVE DIRECTORY - This command causes the directory specified in $dir to -# be removed as a directory (if the $dir is absolute) or as a -# subdirectory of the current working directory (if the $dir is relative). -# (exported) -# -# Arguments: -# dir - directory name -# -# Returns: -# 0 - ERROR -# 1 - OK - -proc ::ftp::RmDir {s dir} { - upvar ::ftp::ftp$s ftp - - if { ![info exists ftp(State)] } { - DisplayMsg $s "Not connected!" error - return 0 - } - - set ftp(Dir) $dir - - set ftp(State) rmdir - StateHandler $s - - # wait for synchronization - set rc [WaitOrTimeout $s] - - if {![string length $ftp(Command)]} { - unset ftp(Dir) - } - - if { $rc } { - return 1 - } else { - return 0 - } -} - -############################################################################# -# -# Delete -- -# -# DELETE - This command causes the file specified in $file to be deleted at -# the server site. -# (exported) -# -# Arguments: -# file - file name -# -# Returns: -# 0 - ERROR -# 1 - OK - -proc ::ftp::Delete {s file} { - upvar ::ftp::ftp$s ftp - - if { ![info exists ftp(State)] } { - DisplayMsg $s "Not connected!" error - return 0 - } - - set ftp(File) $file - - set ftp(State) delete - StateHandler $s - - # wait for synchronization - set rc [WaitOrTimeout $s] - - if {![string length $ftp(Command)]} { - unset ftp(File) - } - - if { $rc } { - return 1 - } else { - return 0 - } -} - -############################################################################# -# -# Rename -- -# -# RENAME FROM TO - This command causes the file specified in $from to be -# renamed at the server site. -# (exported) -# -# Arguments: -# from - specifies the old file name of the file which -# is to be renamed -# to - specifies the new file name of the file -# specified in the $from agument -# Returns: -# 0 - ERROR -# 1 - OK - -proc ::ftp::Rename {s from to} { - upvar ::ftp::ftp$s ftp - - if { ![info exists ftp(State)] } { - DisplayMsg $s "Not connected!" error - return 0 - } - - set ftp(RenameFrom) $from - set ftp(RenameTo) $to - - set ftp(State) rename - - StateHandler $s - - # wait for synchronization - set rc [WaitOrTimeout $s] - - if {![string length $ftp(Command)]} { - unset ftp(RenameFrom) - unset ftp(RenameTo) - } - - if { $rc } { - return 1 - } else { - return 0 - } -} - -############################################################################# -# -# ElapsedTime -- -# -# Gets the elapsed time for file transfer -# -# Arguments: -# stop_time - ending time - -proc ::ftp::ElapsedTime {s stop_time} { - upvar ::ftp::ftp$s ftp - - set elapsed [expr {$stop_time - $ftp(Start_Time)}] - if { $elapsed == 0 } { - set elapsed 1 - } - set persec [expr {$ftp(Total) / $elapsed}] - DisplayMsg $s "$ftp(Total) bytes sent in $elapsed seconds ($persec Bytes/s)" - return -} - -############################################################################# -# -# PUT -- -# -# STORE DATA - Causes the server to accept the data transferred via the data -# connection and to store the data as a file at the server site. If the file -# exists at the server site, then its contents shall be replaced by the data -# being transferred. A new file is created at the server site if the file -# does not already exist. -# (exported) -# -# Arguments: -# source - local file name -# dest - remote file name, if unspecified, ftp assigns -# the local file name. -# Returns: -# 0 - file not stored -# 1 - OK - -proc ::ftp::Put {s args} { - upvar ::ftp::ftp$s ftp - - if { ![info exists ftp(State)] } { - DisplayMsg $s "Not connected!" error - return 0 - } - if {([llength $args] < 1) || ([llength $args] > 4)} { - DisplayMsg $s \ - "wrong # args: should be \"ftp::Put handle (-data \"data\" | -channel chan | localFilename) remoteFilename\"" error - return 0 - } - - set ftp(inline) 0 - set flags 1 - set source "" - set dest "" - foreach arg $args { - if {[string equal $arg "--"]} { - set flags 0 - } elseif {($flags) && ([string equal $arg "-data"])} { - set ftp(inline) 1 - set ftp(filebuffer) "" - } elseif {($flags) && ([string equal $arg "-channel"])} { - set ftp(inline) 2 - } elseif {$source == ""} { - set source $arg - } elseif {$dest == ""} { - set dest $arg - } else { - DisplayMsg $s "wrong # args: should be \"ftp::Put handle (-data \"data\" | -channel chan | localFilename) remoteFilename\"" error - return 0 - } - } - - if {($source == "")} { - DisplayMsg $s "Must specify a valid data source to Put" error - return 0 - } - - set ftp(RemoteFilename) $dest - - if {$ftp(inline) == 1} { - set ftp(PutData) $source - if { $dest == "" } { - set dest ftp.tmp - } - set ftp(RemoteFilename) $dest - } else { - if {$ftp(inline) == 0} { - # File transfer - - set ftp(PutData) "" - if { ![file exists $source] } { - DisplayMsg $s "File \"$source\" not exist" error - return 0 - } - if { $dest == "" } { - set dest [file tail $source] - } - set ftp(LocalFilename) $source - set ftp(SourceCI) [open $ftp(LocalFilename) r] - } else { - # Channel transfer. We fake the rest of the system into - # believing that a file transfer is happening. This makes - # the handling easier. - - set ftp(SourceCI) $source - set ftp(inline) 0 - } - set ftp(RemoteFilename) $dest - - # TODO: read from source file asynchronously - if { [string equal $ftp(Type) "ascii"] } { - fconfigure $ftp(SourceCI) -buffering line -blocking 1 - } else { - fconfigure $ftp(SourceCI) -buffering line -translation binary -blocking 1 - } - } - - set ftp(State) put_$ftp(Mode) - StateHandler $s - - # wait for synchronization - set rc [WaitOrTimeout $s] - if { $rc } { - if {![string length $ftp(Command)]} { - ElapsedTime $s [clock seconds] - } - return 1 - } else { - CloseDataConn $s - return 0 - } -} - -############################################################################# -# -# APPEND -- -# -# APPEND DATA - Causes the server to accept the data transferred via the data -# connection and to store the data as a file at the server site. If the file -# exists at the server site, then the data shall be appended to that file; -# otherwise the file specified in the pathname shall be created at the -# server site. -# (exported) -# -# Arguments: -# source - local file name -# dest - remote file name, if unspecified, ftp assigns -# the local file name. -# Returns: -# 0 - file not stored -# 1 - OK - -proc ::ftp::Append {s args} { - upvar ::ftp::ftp$s ftp - - if { ![info exists ftp(State)] } { - DisplayMsg $s "Not connected!" error - return 0 - } - - if {([llength $args] < 1) || ([llength $args] > 4)} { - DisplayMsg $s "wrong # args: should be \"ftp::Append handle (-data \"data\" | -channel chan | localFilename) remoteFilename\"" error - return 0 - } - - set ftp(inline) 0 - set flags 1 - set source "" - set dest "" - foreach arg $args { - if {[string equal $arg "--"]} { - set flags 0 - } elseif {($flags) && ([string equal $arg "-data"])} { - set ftp(inline) 1 - set ftp(filebuffer) "" - } elseif {($flags) && ([string equal $arg "-channel"])} { - set ftp(inline) 2 - } elseif {$source == ""} { - set source $arg - } elseif {$dest == ""} { - set dest $arg - } else { - DisplayMsg $s "wrong # args: should be \"ftp::Append handle (-data \"data\" | -channel chan | localFilename) remoteFilename\"" error - return 0 - } - } - - if {($source == "")} { - DisplayMsg $s "Must specify a valid data source to Append" error - return 0 - } - - set ftp(RemoteFilename) $dest - - if {$ftp(inline) == 1} { - set ftp(PutData) $source - if { $dest == "" } { - set dest ftp.tmp - } - set ftp(RemoteFilename) $dest - } else { - if {$ftp(inline) == 0} { - # File transfer - - set ftp(PutData) "" - if { ![file exists $source] } { - DisplayMsg $s "File \"$source\" not exist" error - return 0 - } - - if { $dest == "" } { - set dest [file tail $source] - } - - set ftp(LocalFilename) $source - set ftp(SourceCI) [open $ftp(LocalFilename) r] - } else { - # Channel transfer. We fake the rest of the system into - # believing that a file transfer is happening. This makes - # the handling easier. - - set ftp(SourceCI) $source - set ftp(inline) 0 - } - set ftp(RemoteFilename) $dest - - if { [string equal $ftp(Type) "ascii"] } { - fconfigure $ftp(SourceCI) -buffering line -blocking 1 - } else { - fconfigure $ftp(SourceCI) -buffering line -translation binary \ - -blocking 1 - } - } - - set ftp(State) append_$ftp(Mode) - StateHandler $s - - # wait for synchronization - set rc [WaitOrTimeout $s] - if { $rc } { - if {![string length $ftp(Command)]} { - ElapsedTime $s [clock seconds] - } - return 1 - } else { - CloseDataConn $s - return 0 - } -} - - -############################################################################# -# -# Get -- -# -# RETRIEVE DATA - Causes the server to transfer a copy of the specified file -# to the local site at the other end of the data connection. -# (exported) -# -# Arguments: -# source - remote file name -# dest - local file name, if unspecified, ftp assigns -# the remote file name. -# Returns: -# 0 - file not retrieved -# 1 - OK - -proc ::ftp::Get {s args} { - upvar ::ftp::ftp$s ftp - - if { ![info exists ftp(State)] } { - DisplayMsg $s "Not connected!" error - return 0 - } - - if {([llength $args] < 1) || ([llength $args] > 4)} { - DisplayMsg $s "wrong # args: should be \"ftp::Get handle remoteFile ?(-variable varName | -channel chan | localFilename)?\"" error - return 0 - } - - set ftp(inline) 0 - set flags 1 - set source "" - set dest "" - set varname "**NONE**" - foreach arg $args { - if {[string equal $arg "--"]} { - set flags 0 - } elseif {($flags) && ([string equal $arg "-variable"])} { - set ftp(inline) 1 - set ftp(filebuffer) "" - } elseif {($flags) && ([string equal $arg "-channel"])} { - set ftp(inline) 2 - } elseif {($ftp(inline) == 1) && ([string equal $varname "**NONE**"])} { - set varname $arg - set ftp(get:varname) $varname - } elseif {($ftp(inline) == 2) && ([string equal $varname "**NONE**"])} { - set ftp(get:channel) $arg - } elseif {$source == ""} { - set source $arg - } elseif {$dest == ""} { - set dest $arg - } else { - DisplayMsg $s "wrong # args: should be \"ftp::Get handle remoteFile -?(-variable varName | -channel chan | localFilename)?\"" error - return 0 - } - } - - if {($ftp(inline) != 0) && ($dest != "")} { - DisplayMsg $s "Cannot return data in a variable or channel, and place it in destination file." error - return 0 - } - - if {$source == ""} { - DisplayMsg $s "Must specify a valid data source to Get" error - return 0 - } - - if {$ftp(inline) == 0} { - if { $dest == "" } { - set dest $source - } else { - if {[file isdirectory $dest]} { - set dest [file join $dest [file tail $source]] - } - } - if {![file exists [file dirname $dest]]} { - return -code error "ftp::Get, directory \"[file dirname $dest]\" for destination \"$dest\" does not exist" - } - set ftp(LocalFilename) $dest - } - - set ftp(RemoteFilename) $source - - if {$ftp(inline) == 2} { - set ftp(inline) 0 - } - set ftp(State) get_$ftp(Mode) - StateHandler $s - - # wait for synchronization - set rc [WaitOrTimeout $s] - - # It is important to unset 'get:channel' in all cases or it will - # interfere with any following ftp command (as its existence - # suppresses the closing of the destination channel identifier - # (DestCI). We cannot do it earlier than just before the 'return' - # or code depending on it for the current command may not execute - # correctly. - - if { $rc } { - if {![string length $ftp(Command)]} { - ElapsedTime $s [clock seconds] - if {$ftp(inline)} { - catch {unset ftp(get:channel)} - upvar $varname returnData - set returnData $ftp(GetData) - } - } - catch {unset ftp(get:channel)} - return 1 - } else { - if {$ftp(inline)} { - catch {unset ftp(get:channel)} - return "" - } - CloseDataConn $s - catch {unset ftp(get:channel)} - return 0 - } -} - -############################################################################# -# -# Reget -- -# -# RESTART RETRIEVING DATA - Causes the server to transfer a copy of the specified file -# to the local site at the other end of the data connection like get but skips over -# the file to the specified data checkpoint. -# (exported) -# -# Arguments: -# source - remote file name -# dest - local file name, if unspecified, ftp assigns -# the remote file name. -# Returns: -# 0 - file not retrieved -# 1 - OK - -proc ::ftp::Reget {s source {dest ""} {from_bytes 0} {till_bytes -1}} { - upvar ::ftp::ftp$s ftp - - if { ![info exists ftp(State)] } { - DisplayMsg $s "Not connected!" error - return 0 - } - - if { $dest == "" } { - set dest $source - } - if {![file exists [file dirname $dest]]} { - return -code error \ - "ftp::Reget, directory \"[file dirname $dest]\" for destination \"$dest\" does not exist" - } - - set ftp(RemoteFilename) $source - set ftp(LocalFilename) $dest - set ftp(From) $from_bytes - - - # Assumes that the local file has a starting offset of $from_bytes - # The following calculation ensures that the download starts from the - # correct offset - - if { [file exists $ftp(LocalFilename)] } { - set ftp(FileSize) [ expr {[file size $ftp(LocalFilename)] + $from_bytes }] - - if { $till_bytes != -1 } { - set ftp(To) $till_bytes - set ftp(Bytes_to_go) [ expr {$till_bytes - $ftp(FileSize)} ] - - if { $ftp(Bytes_to_go) <= 0 } {return 0} - - } else { - # till_bytes not set - set ftp(To) end - } - - } else { - # local file does not exist - set ftp(FileSize) $from_bytes - - if { $till_bytes != -1 } { - set ftp(Bytes_to_go) [ expr {$till_bytes - $from_bytes }] - set ftp(To) $till_bytes - } else { - #till_bytes not set - set ftp(To) end - } - } - - set ftp(State) reget_$ftp(Mode) - StateHandler $s - - # wait for synchronization - set rc [WaitOrTimeout $s] - if { $rc } { - if {![string length $ftp(Command)]} { - ElapsedTime $s [clock seconds] - } - return 1 - } else { - CloseDataConn $s - return 0 - } -} - -############################################################################# -# -# Newer -- -# -# GET NEWER DATA - Get the file only if the modification time of the remote -# file is more recent that the file on the current system. If the file does -# not exist on the current system, the remote file is considered newer. -# Otherwise, this command is identical to get. -# (exported) -# -# Arguments: -# source - remote file name -# dest - local file name, if unspecified, ftp assigns -# the remote file name. -# -# Returns: -# 0 - file not retrieved -# 1 - OK - -proc ::ftp::Newer {s source {dest ""}} { - upvar ::ftp::ftp$s ftp - - if { ![info exists ftp(State)] } { - DisplayMsg $s "Not connected!" error - return 0 - } - - if {[string length $ftp(Command)]} { - return -code error "unable to retrieve file asynchronously (not implemented yet)" - } - - if { $dest == "" } { - set dest $source - } - if {![file exists [file dirname $dest]]} { - return -code error "ftp::Newer, directory \"[file dirname $dest]\" for destination \"$dest\" does not exist" - } - - set ftp(RemoteFilename) $source - set ftp(LocalFilename) $dest - - # get remote modification time - set rmt [ModTime $s $ftp(RemoteFilename)] - if { $rmt == "-1" } { - return 0 - } - - # get local modification time - if { [file exists $ftp(LocalFilename)] } { - set lmt [file mtime $ftp(LocalFilename)] - } else { - set lmt 0 - } - - # remote file is older than local file - if { $rmt < $lmt } { - return 0 - } - - # remote file is newer than local file or local file doesn't exist - # get it - set rc [Get $s $ftp(RemoteFilename) $ftp(LocalFilename)] - return $rc - -} - -############################################################################# -# -# Quote -- -# -# The arguments specified are sent, verbatim, to the remote ftp server. -# -# Arguments: -# arg1 arg2 ... -# -# Returns: -# string sent back by the remote ftp server or null string if any error -# - -proc ::ftp::Quote {s args} { - upvar ::ftp::ftp$s ftp - - if { ![info exists ftp(State)] } { - DisplayMsg $s "Not connected!" error - return 0 - } - - set ftp(Cmd) $args - set ftp(Quote) {} - - set ftp(State) quote - StateHandler $s - - # wait for synchronization - set rc [WaitOrTimeout $s] - - unset ftp(Cmd) - - if { $rc } { - return $ftp(Quote) - } else { - return {} - } -} - - -############################################################################# -# -# Abort -- -# -# ABORT - Tells the server to abort the previous ftp service command and -# any associated transfer of data. The control connection is not to be -# closed by the server, but the data connection must be closed. -# -# NOTE: This procedure doesn't work properly. Thus the ftp::Abort command -# is no longer available! -# -# Arguments: -# None. -# -# Returns: -# 0 - ERROR -# 1 - OK -# -# proc Abort {} { -# -# } - -############################################################################# -# -# Close -- -# -# Terminates a ftp session and if file transfer is not in progress, the server -# closes the control connection. If file transfer is in progress, the -# connection will remain open for result response and the server will then -# close it. -# (exported) -# -# Arguments: -# None. -# -# Returns: -# 0 - ERROR -# 1 - OK - -proc ::ftp::Close {s } { - variable connections - upvar ::ftp::ftp$s ftp - - if { ![info exists ftp(State)] } { - DisplayMsg $s "Not connected!" error - return 0 - } - - if {[info exists \ - connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost),afterid)]} { - unset connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost),afterid) - unset connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost)) - } - - set ftp(State) quit - StateHandler $s - - # wait for synchronization - WaitOrTimeout $s - - catch {close $ftp(CtrlSock)} - catch {unset ftp} - return 1 -} - -proc ::ftp::LazyClose {s } { - variable connections - upvar ::ftp::ftp$s ftp - - if { ![info exists ftp(State)] } { - DisplayMsg $s "Not connected!" error - return 0 - } - - if {[info exists connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost))]} { - set connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost),afterid) \ - [after 5000 [list ftp::Close $s]] - } - return 1 -} - -############################################################################# -# -# Open -- -# -# Starts the ftp session and sets up a ftp control connection. -# (exported) -# -# Arguments: -# server - The ftp server hostname. -# user - A string identifying the user. The user identification -# is that which is required by the server for access to -# its file system. -# passwd - A string specifying the user's password. -# options - -blocksize size writes "size" bytes at once -# (default 4096) -# -timeout seconds if non-zero, sets up timeout to -# occur after specified number of -# seconds (default 120) -# -progress proc procedure name that handles callbacks -# (no default) -# -output proc procedure name that handles output -# (no default) -# -mode mode switch active or passive file transfer -# (default active) -# -port number alternative port (default 21) -# -command proc callback for completion notification -# (no default) -# -# Returns: -# 0 - Not logged in -# 1 - User logged in - -proc ::ftp::Open {server user passwd args} { - variable DEBUG - variable VERBOSE - variable serial - variable connections - - set s $serial - incr serial - upvar ::ftp::ftp$s ftp -# if { [info exists ftp(State)] } { -# DisplayMsg $s "Mmh, another attempt to open a new connection? There is already a hot wire!" error -# return 0 -# } - - # default NO DEBUG - if { ![info exists DEBUG] } { - set DEBUG 0 - } - - # default NO VERBOSE - if { ![info exists VERBOSE] } { - set VERBOSE 0 - } - - if { $DEBUG } { - DisplayMsg $s "Starting new connection with: " - } - - set ftp(inline) 0 - set ftp(User) $user - set ftp(Passwd) $passwd - set ftp(RemoteHost) $server - set ftp(LocalHost) [info hostname] - set ftp(DataPort) 0 - set ftp(Type) {} - set ftp(Error) "" - set ftp(Progress) {} - set ftp(Command) {} - set ftp(Output) {} - set ftp(Blocksize) 4096 - set ftp(Timeout) 600 - set ftp(Mode) active - set ftp(Port) 21 - - set ftp(State) user - - # set state var - set ftp(state.control) "" - - # Get and set possible options - set options {-blocksize -timeout -mode -port -progress -output -command} - foreach {option value} $args { - if { [lsearch -exact $options $option] != "-1" } { - if { $DEBUG } { - DisplayMsg $s " $option = $value" - } - regexp -- {^-(.?)(.*)$} $option all first rest - set option "[string toupper $first]$rest" - set ftp($option) $value - } - } - if { $DEBUG && ([llength $args] == 0) } { - DisplayMsg $s " no option" - } - - if {[info exists \ - connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost),afterid)]} { - after cancel $connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost),afterid) - Command $ftp(Command) connect $connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost)) - return $connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost)) - } - - - # No call of StateHandler is required at this time. - # StateHandler at first time is called automatically - # by a fileevent for the control channel. - - # Try to open a control connection - if { ![OpenControlConn $s [expr {[string length $ftp(Command)] > 0}]] } { - return -1 - } - - # waits for synchronization - # 0 ... Not logged in - # 1 ... User logged in - if {[string length $ftp(Command)]} { - # Don't wait - asynchronous operation - set ftp(NextState) {type connect_last} - set connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost)) $s - return $s - } elseif { [WaitOrTimeout $s] } { - # default type is binary - Type $s binary - set connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost)) $s - Command $ftp(Command) connect $s - return $s - } else { - # close connection if not logged in - Close $s - return -1 - } -} - -############################################################################# -# -# CopyNext -- -# -# recursive background copy procedure for ascii/binary file I/O -# -# Arguments: -# bytes - indicates how many bytes were written on $ftp(DestCI) - -proc ::ftp::CopyNext {s bytes {error {}}} { - upvar ::ftp::ftp$s ftp - variable DEBUG - variable VERBOSE - - # summary bytes - - incr ftp(Total) $bytes - - # update bytes_to_go and blocksize - - if { [info exists ftp(Bytes_to_go)] } { - set ftp(Bytes_to_go) [expr {$ftp(Bytes_to_go) - $bytes}] - - if { $ftp(Blocksize) <= $ftp(Bytes_to_go) } { - set blocksize $ftp(Blocksize) - } else { - set blocksize $ftp(Bytes_to_go) - } - } else { - set blocksize $ftp(Blocksize) - } - - # callback for progress bar procedure - - if { ([info exists ftp(Progress)]) && \ - [string length $ftp(Progress)] && \ - ([info commands [lindex $ftp(Progress) 0]] != "") } { - eval $ftp(Progress) $ftp(Total) - } - - # setup new timeout handler - - catch {after cancel $ftp(Wait)} - set ftp(Wait) [after [expr {$ftp(Timeout) * 1000}] [namespace current]::Timeout $s] - - if { $DEBUG } { - DisplayMsg $s "-> $ftp(Total) bytes $ftp(SourceCI) -> $ftp(DestCI)" - } - - if { $error != "" } { - # Protect the destination channel from destruction if it came - # from the caller. Closing it is not our responsibility in that case. - - if {![info exists ftp(get:channel)]} { - catch {close $ftp(DestCI)} - } - catch {close $ftp(SourceCI)} - unset ftp(state.data) - DisplayMsg $s $error error - - } elseif { ([eof $ftp(SourceCI)] || ($blocksize <= 0)) } { - # Protect the destination channel from destruction if it came - # from the caller. Closing it is not our responsibility in that case. - - if {![info exists ftp(get:channel)]} { - close $ftp(DestCI) - } - close $ftp(SourceCI) - unset ftp(state.data) - if { $VERBOSE } { - DisplayMsg $s "D: Port closed" data - } - - } else { - fcopy $ftp(SourceCI) $ftp(DestCI) \ - -command [list [namespace current]::CopyNext $s] \ - -size $blocksize - } - return -} - -############################################################################# -# -# HandleData -- -# -# Handles ascii/binary data transfer for Put and Get -# -# Arguments: -# sock - socket name (data channel) - -proc ::ftp::HandleData {s sock} { - upvar ::ftp::ftp$s ftp - - # Turn off any fileevent handlers - - fileevent $sock writable {} - fileevent $sock readable {} - - # create local file for ftp::Get - - if { [string match "get*" $ftp(State)] && (!$ftp(inline))} { - - # A channel was specified by the caller. Use that instead of a - # file. - - if {[info exists ftp(get:channel)]} { - set ftp(DestCI) $ftp(get:channel) - set rc 0 - } else { - set rc [catch {set ftp(DestCI) [open $ftp(LocalFilename) w]} msg] - } - if { $rc != 0 } { - DisplayMsg $s "$msg" error - return 0 - } - # TODO: Use non-blocking I/O - if { [string equal $ftp(Type) "ascii"] } { - fconfigure $ftp(DestCI) -buffering line -blocking 1 - } else { - fconfigure $ftp(DestCI) -buffering line -translation binary -blocking 1 - } - } - - # append local file for ftp::Reget - - if { [string match "reget*" $ftp(State)] } { - set rc [catch {set ftp(DestCI) [open $ftp(LocalFilename) a]} msg] - if { $rc != 0 } { - DisplayMsg $s "$msg" error - return 0 - } - # TODO: Use non-blocking I/O - if { [string equal $ftp(Type) "ascii"] } { - fconfigure $ftp(DestCI) -buffering line -blocking 1 - } else { - fconfigure $ftp(DestCI) -buffering line -translation binary -blocking 1 - } - } - - - set ftp(Total) 0 - set ftp(Start_Time) [clock seconds] - - # calculate blocksize - - if { [ info exists ftp(Bytes_to_go) ] } { - - if { $ftp(Blocksize) <= $ftp(Bytes_to_go) } { - set Blocksize $ftp(Blocksize) - } else { - set Blocksize $ftp(Bytes_to_go) - } - - } else { - set Blocksize $ftp(Blocksize) - } - - # perform fcopy - fcopy $ftp(SourceCI) $ftp(DestCI) \ - -command [list [namespace current]::CopyNext $s ] \ - -size $Blocksize - return 1 -} - -############################################################################# -# -# HandleList -- -# -# Handles ascii data transfer for list commands -# -# Arguments: -# sock - socket name (data channel) - -proc ::ftp::HandleList {s sock} { - upvar ::ftp::ftp$s ftp - variable VERBOSE - - if { ![eof $sock] } { - set buffer [read $sock] - if { $buffer != "" } { - set ftp(List) [append ftp(List) $buffer] - } - } else { - close $sock - catch {unset ftp(state.data)} - if { $VERBOSE } { - DisplayMsg $s "D: Port closed" data - } - } - return -} - -############################################################################# -# -# HandleVar -- -# -# Handles data transfer for get/put commands that use buffers instead -# of files. -# -# Arguments: -# sock - socket name (data channel) - -proc ::ftp::HandleVar {s sock} { - upvar ::ftp::ftp$s ftp - variable VERBOSE - - if {$ftp(Start_Time) == -1} { - set ftp(Start_Time) [clock seconds] - } - - if { ![eof $sock] } { - set buffer [read $sock] - if { $buffer != "" } { - append ftp(GetData) $buffer - incr ftp(Total) [string length $buffer] - } - } else { - close $sock - catch {unset ftp(state.data)} - if { $VERBOSE } { - DisplayMsg $s "D: Port closed" data - } - } - return -} - -############################################################################# -# -# HandleOutput -- -# -# Handles data transfer for get/put commands that use buffers instead -# of files. -# -# Arguments: -# sock - socket name (data channel) - -proc ::ftp::HandleOutput {s sock} { - upvar ::ftp::ftp$s ftp - variable VERBOSE - - if {$ftp(Start_Time) == -1} { - set ftp(Start_Time) [clock seconds] - } - - if { $ftp(Total) < [string length $ftp(PutData)] } { - set substr [string range $ftp(PutData) $ftp(Total) \ - [expr {$ftp(Total) + $ftp(Blocksize)}]] - if {[catch {puts -nonewline $sock "$substr"} result]} { - close $sock - unset ftp(state.data) - if { $VERBOSE } { - DisplayMsg $s "D: Port closed" data - } - } else { - incr ftp(Total) [string length $substr] - } - } else { - fileevent $sock writable {} - close $sock - catch {unset ftp(state.data)} - if { $VERBOSE } { - DisplayMsg $s "D: Port closed" data - } - } - return -} - -############################################################################ -# -# CloseDataConn -- -# -# Closes all sockets and files used by the data conection -# -# Arguments: -# None. -# -# Returns: -# None. -# -proc ::ftp::CloseDataConn {s } { - upvar ::ftp::ftp$s ftp - - # Protect the destination channel from destruction if it came - # from the caller. Closing it is not our responsibility. - - if {[info exists ftp(get:channel)]} { - catch {unset ftp(get:channel)} - catch {unset ftp(DestCI)} - } - - catch {after cancel $ftp(Wait)} - catch {fileevent $ftp(DataSock) readable {}} - catch {close $ftp(DataSock); unset ftp(DataSock)} - catch {close $ftp(DestCI); unset ftp(DestCI)} - catch {close $ftp(SourceCI); unset ftp(SourceCI)} - catch {close $ftp(DummySock); unset ftp(DummySock)} - return -} - -############################################################################# -# -# InitDataConn -- -# -# Configures new data channel for connection to ftp server -# ATTENTION! The new data channel "sock" is not the same as the -# server channel, it's a dummy. -# -# Arguments: -# sock - the name of the new channel -# addr - the address, in network address notation, -# of the client's host, -# port - the client's port number - -proc ::ftp::InitDataConn {s sock addr port} { - upvar ::ftp::ftp$s ftp - variable VERBOSE - - # If the new channel is accepted, the dummy channel will be closed - - catch {close $ftp(DummySock); unset ftp(DummySock)} - - set ftp(state.data) 0 - - # Configure translation and blocking modes - - set blocking 1 - if {[string length $ftp(Command)]} { - set blocking 0 - } - - if { [string equal $ftp(Type) "ascii"] } { - fconfigure $sock -buffering line -blocking $blocking - } else { - fconfigure $sock -buffering line -translation binary -blocking $blocking - } - - # assign fileevent handlers, source and destination CI (Channel Identifier) - - # NB: this really does need to be -regexp [PT] 18Mar03 - switch -regexp -- $ftp(State) { - list { - fileevent $sock readable [list [namespace current]::HandleList $s $sock] - set ftp(SourceCI) $sock - } - get { - if {$ftp(inline)} { - set ftp(GetData) "" - set ftp(Start_Time) -1 - set ftp(Total) 0 - fileevent $sock readable [list [namespace current]::HandleVar $s $sock] - } else { - fileevent $sock readable [list [namespace current]::HandleData $s $sock] - set ftp(SourceCI) $sock - } - } - append - - put { - if {$ftp(inline)} { - set ftp(Start_Time) -1 - set ftp(Total) 0 - fileevent $sock writable [list [namespace current]::HandleOutput $s $sock] - } else { - fileevent $sock writable [list [namespace current]::HandleData $s $sock] - set ftp(DestCI) $sock - } - } - default { - error "Unknown state \"$ftp(State)\"" - } - } - - if { $VERBOSE } { - DisplayMsg $s "D: Connection from $addr:$port" data - } - return -} - -############################################################################# -# -# OpenActiveConn -- -# -# Opens a ftp data connection -# -# Arguments: -# None. -# -# Returns: -# 0 - no connection -# 1 - connection established - -proc ::ftp::OpenActiveConn {s } { - upvar ::ftp::ftp$s ftp - variable VERBOSE - - # Port address 0 is a dummy used to give the server the responsibility - # of getting free new port addresses for every data transfer. - - set rc [catch {set ftp(DummySock) [socket -server [list [namespace current]::InitDataConn $s] 0]} msg] - if { $rc != 0 } { - DisplayMsg $s "$msg" error - return 0 - } - - # get a new local port address for data transfer and convert it to a format - # which is useable by the PORT command - - set p [lindex [fconfigure $ftp(DummySock) -sockname] 2] - if { $VERBOSE } { - DisplayMsg $s "D: Port is $p" data - } - set ftp(DataPort) "[expr {$p / 256}],[expr {$p % 256}]" - - return 1 -} - -############################################################################# -# -# OpenPassiveConn -- -# -# Opens a ftp data connection -# -# Arguments: -# buffer - returned line from server control connection -# -# Returns: -# 0 - no connection -# 1 - connection established - -proc ::ftp::OpenPassiveConn {s buffer} { - upvar ::ftp::ftp$s ftp - - if { [regexp -- {([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)} $buffer all a1 a2 a3 a4 p1 p2] } { - set ftp(LocalAddr) "$a1.$a2.$a3.$a4" - set ftp(DataPort) "[expr {$p1 * 256 + $p2}]" - - # establish data connection for passive mode - - set rc [catch {set ftp(DataSock) [socket $ftp(LocalAddr) $ftp(DataPort)]} msg] - if { $rc != 0 } { - DisplayMsg $s "$msg" error - return 0 - } - - InitDataConn $s $ftp(DataSock) $ftp(LocalAddr) $ftp(DataPort) - return 1 - } else { - return 0 - } -} - -############################################################################# -# -# OpenControlConn -- -# -# Opens a ftp control connection -# -# Arguments: -# s connection id -# block blocking or non-blocking mode -# -# Returns: -# 0 - no connection -# 1 - connection established - -proc ::ftp::OpenControlConn {s {block 1}} { - upvar ::ftp::ftp$s ftp - variable DEBUG - variable VERBOSE - - # open a control channel - - set rc [catch {set ftp(CtrlSock) [socket $ftp(RemoteHost) $ftp(Port)]} msg] - if { $rc != 0 } { - if { $VERBOSE } { - DisplayMsg $s "C: No connection to server!" error - } - if { $DEBUG } { - DisplayMsg $s "[list $msg]" error - } - unset ftp(State) - return 0 - } - - # configure control channel - - fconfigure $ftp(CtrlSock) -buffering line -blocking $block -translation {auto crlf} - fileevent $ftp(CtrlSock) readable [list [namespace current]::StateHandler $s $ftp(CtrlSock)] - - # prepare local ip address for PORT command (convert pointed format - # to comma format) - - set ftp(LocalAddr) [lindex [fconfigure $ftp(CtrlSock) -sockname] 0] - set ftp(LocalAddr) [string map {. ,} $ftp(LocalAddr)] - - # report ready message - - set peer [fconfigure $ftp(CtrlSock) -peername] - if { $VERBOSE } { - DisplayMsg $s "C: Connection from [lindex $peer 0]:[lindex $peer 2]" control - } - - return 1 -} - -# ::ftp::Command -- -# -# Wrapper for evaluated user-supplied command callback -# -# Arguments: -# cb callback script -# msg what happened -# args additional info -# -# Results: -# Depends on callback script - -proc ::ftp::Command {cb msg args} { - if {[string length $cb]} { - uplevel #0 $cb [list $msg] $args - } -} - -# ================================================================== -# ?????? Hmm, how to do multithreaded for tkcon? -# added TkCon support -# TkCon is (c) 1995-2001 Jeffrey Hobbs, http://tkcon.sourceforge.net/ -# started with: tkcon -load ftp -if { [string equal [uplevel "#0" {info commands tkcon}] "tkcon"] } { - - # new ftp::List proc makes the output more readable - proc ::ftp::__ftp_ls {args} { - foreach i [eval ::ftp::List_org $args] { - puts $i - } - } - - # rename the original ftp::List procedure - rename ::ftp::List ::ftp::List_org - - alias ::ftp::List ::ftp::__ftp_ls - alias bye catch {::ftp::Close; exit} - - set ::ftp::VERBOSE 1 - set ::ftp::DEBUG 0 -} - -# ================================================================== -# At last, everything is fine, we can provide the package. - -package provide ftp [lindex {Revision: 2.4} 1] DELETED modules/ftp/ftp_geturl.tcl Index: modules/ftp/ftp_geturl.tcl ================================================================== --- modules/ftp/ftp_geturl.tcl +++ /dev/null @@ -1,131 +0,0 @@ -# ftp_geturl.tcl -- -# -# Copyright (c) 2001 by Andreas Kupries -# -# ftp::geturl url - -package require ftp -package require uri - -namespace eval ::ftp { - namespace export geturl -} - -# ::ftp::geturl -# -# Command useable by uri to retrieve the contents of an ftp url. -# Returns the contents of the requested url. - -proc ::ftp::geturl {url} { - # FUTURE: -validate to validate existence of url, but no download - # of contents. - - array set urlparts [uri::split $url] - - if {$urlparts(user) == {}} { - set urlparts(user) "anonymous" - } - if {$urlparts(pwd) == {}} { - set urlparts(pwd) "user@localhost.localdomain" - } - if {$urlparts(port) == {}} { - set urlparts(port) 21 - } - - set fdc [ftp::Open $urlparts(host) $urlparts(user) $urlparts(pwd) \ - -port $urlparts(port)] - if {$fdc < 0} { - return -code error "Cannot reach host for url \"$url\"" - } - - # We have reached the host, now get on to retrieve the item. - # We are very careful in accessing the item because we don't know - # if it is a file, directory or link. So we change into the - # directory containing the item, get a list of all entries and - # then determine if the item actually exists and what type it is, - # and what actions to perform. - - set ftp_dir [file dirname $urlparts(path)] - set ftp_file [file tail $urlparts(path)] - - set result [ftp::Cd $fdc $ftp_dir] - if { $result == 0 } { - ftp::Close $fdc - return -code error "Cannot reach directory of url \"$url\"" - } - - # Fix for the tkcon List enhancements in ftp.tcl - set List ::ftp::List_org - if {[info command $List] == {}} { - set List ::ftp::List - } - - # The result of List is a list of entries in the given directory. - # Note that it is in 'ls -l format. We parse that into a more - # readable array. - - #array set flist [ftp::ParseList [$List $fdc ""]] - #if {![info exists flist($ftp_file)]} {} - set flist [$List $fdc $ftp_file] - if {$flist == {}} { - ftp::Close $fdc - return -code error "Cannot reach item of url \"$url\"" - } - - # The item exists, what is it ? - # File : Download the contents. - # Directory: Download a listing, this is its contents. - # Link : For now we do not follow the link but return the - # meta information, i.e. the path it is pointing to. - - #switch -exact -- [lindex $flist($ftp_file) 0] {} - switch -exact -- [string index [lindex $flist 0] 0] { - - { - ftp::Get $fdc $ftp_file -variable contents - } - d { - set contents [ftp::NList $fdc $ftp_file] - } - l { - set contents $flist - } - default { - ftp::Close $fdc - return -code error "File information \"$flist\" not recognised" - } - } - - ftp::Close $fdc - return $contents -} - -# Internal helper to parse a directory listing into something which -# can be better handled by tcl than raw ls -l format. - -proc ::ftp::ParseList {flist} { - array set data {} - foreach item $flist { - foreach {mode dummy owner group size month day yrtime name} $item break - - if {[string first : $yrtime] >=0} { - set date "$month/$day/[clock format [clock seconds] -format %Y] $yrtime" - } else { - set date "$month/$day/$yrtime 00:00" - } - set info [list owner $owner group $group size $size date $date] - - switch -exact -- [string index $mode 0] { - - {set type file} - d {set type dir} - l {set type link ; lappend info link [lindex $item end]} - } - - set data($name) [list $type $info] - } - array get data -} - -# ================================================================== -# At last, everything is fine, we can provide the package. - -package provide ftp::geturl [lindex {Revision: 0.2} 1] DELETED modules/ftp/pkgIndex.tcl Index: modules/ftp/pkgIndex.tcl ================================================================== --- modules/ftp/pkgIndex.tcl +++ /dev/null @@ -1,14 +0,0 @@ -# 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. - -if {![package vsatisfies [package provide Tcl] 8.2]} {return} - -package ifneeded ftp 2.4 [list source [file join $dir ftp.tcl]] -package ifneeded ftp::geturl 0.2 [list source [file join $dir ftp_geturl.tcl]] DELETED modules/ftpd/ChangeLog Index: modules/ftpd/ChangeLog ================================================================== --- modules/ftpd/ChangeLog +++ /dev/null @@ -1,75 +0,0 @@ -2003-04-11 Andreas Kupries - - * ftpd.tcl: - * ftpd.man: - * pkgIndex.tcl: Fixed bug #614591. Set version of the package to - to 1.1.3. - -2003-01-16 Andreas Kupries - - * ftpd.man: More semantic markup, less visual one. - -2002-08-30 Andreas Kupries - - * ftpd.tcl: Updated 'info exist' to 'info exists'. - -2002-06-03 Andreas Kupries - - * pkgIndex.tcl: - * ftpd.tcl: - * ftpd.n: - * ftpd.man: Bumped to version 1.1.2. - -2002-03-20 Andreas Kupries - - * ftpd.man: New, doctools manpage. - -2002-03-19 Andreas Kupries - - * pkgIndex.tcl: - * ftpd.n: Changed to require tcl version 8.3. Code uses -unique - option of [lsort], introduced in that version. This fixes SF bug - #531799. - -2001-09-07 Andreas Kupries - - * ftpd.tcl: Applied patch [459197] from Hemang to fix more - 'namespace export *'. Patch modified before application as some - export command are actually private (Implementations of the ftp - commands). - -2001-09-05 Andreas Kupries - - * ftpd.tcl: Restricted export list to public API. - [456255]. Patch by Hemang Lavana - - -2001-06-21 Andreas Kupries - - * ftpd.tcl: Fixed dubious code reported by frink. - -2000-11-22 Eric Melski - - * Integrated patch from Mark O'Conner. Patch fixed file translation - mode bug (ie, binary vs. ascii) that prevented proper retrieval - of binary files. [SFBUG: 122664] - -2000-11-01 Dan Kuchler - - * Integrated patch from Keith Vetter - Patch fixed several bugs. Allowed users to log in as - both 'anonymous' and 'ftp' by default instead of just anonymous. - Fixed syntax error with the 'socket -server' line in ftpd::server when - 'myaddr' is specified. Fixed the argument specifications for - cmdline:getoptions in ftpd::config so that arguments are required for - the -logCmd and the -fsCmd. - -2000-10-30 Dan Kuchler - - * Made some fixes to better support windows. - -2000-10-27 Dan Kuchler - - * Initial revision of tcllib ftpd. Based off of the ftpd in - the stdtcl distribution. - DELETED modules/ftpd/ftpd.man Index: modules/ftpd/ftpd.man ================================================================== --- modules/ftpd/ftpd.man +++ /dev/null @@ -1,233 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[manpage_begin ftpd n 1.1.3] -[moddesc {Tcl FTP Server Package}] -[titledesc {Tcl FTP server implementation}] -[require Tcl 8.3] -[require ftpd [opt 1.1.3]] -[description] - -The [package ftpd] package provides a simple Tcl-only server library -for the FTP protocol. It works by listening on the standard FTP -socket. Most server errors are returned as error messages with the -appropriate code attached to them. Since the server code for the ftp -daemon is executed in the event loop, it is possible that a - -[cmd bgerror] will be thrown on the server if there are problems with -the code in the module. - -[section COMMANDS] - -[list_begin definitions] - -[call [cmd ::ftpd::server] [opt [arg myaddr]]] - -Open a listening socket to listen to and accept ftp connections. -myaddr is an optional argument. [arg myaddr] is the domain-style name -or numerical IP address of the client-side network interface to use -for the connection. - -[call [cmd ::ftpd::config] [opt [arg {option value}]] [opt [arg {option value ...}]]] - -The value is always the name of the command to call as the -callback. The option specifies which callback should be configured. -See section [sectref CALLBACKS] for descriptions of the arguments and -return values for each of the callbacks. - -[list_begin definitions] - -[lst_item "-authIpCmd [arg proc]"] - -Callback to authenticate new connections based on the ip-address of -the peer. - -[lst_item "-authUsrCmd [arg proc]"] - -Callback to authenticate new connections based on the user logging in -(and the users password). - -[lst_item "-authFileCmd [arg proc]"] - -Callback to accept or deny a users access to read and write to a -specific path or file. - -[lst_item "-logCmd [arg proc]"] - -Callback for log information generated by the FTP engine. - -[lst_item "-fsCmd [arg proc]"] - -Callback to connect the engine to the filesystem it operates on. - -[list_end] -[list_end] - -[section CALLBACKS] - -[list_begin definitions] - -[lst_item "[cmd authIpCmd] callback"]] - -The authIpCmd receives the ip-address of the peer attempting to -connect to the ftp server as its argument. It returns a 1 to allow -users from the specified IP to attempt to login and a 0 to reject the -login attempt from the specified IP. - -[lst_item "[cmd authUsrCmd] callback"]] - -The authUsrCmd receives the username and password as its two -arguments. It returns a 1 to accept the attempted login to the ftpd -and a 0 to reject the attempted login. - -[lst_item "[cmd authFileCmd] callback"]] - -The authFileCmd receives the user (that is currently logged in), the -path or filename that is about to be read or written, and - -[const read] or [const write] as its three arguments. It returns a -1 to allow the path or filename to be read or written, and a 0 to -reject the attempted read or write with a permissions error code. - -[lst_item "[cmd logCmd] callback"]] - -The logCmd receives a severity and a message as its two arguments. -The severities used within the ftpd package are [const note], - -[const debug], and [const error]. The logCmd doesn't return -anything. - -[lst_item "[cmd fsCmd] callback"]] - -The fsCmd receives a subcommand, a filename or path, and optional -additional arguments (depending on the subcommand). - -[nl] -The subcommands supported by the fsCmd are: - -[list_begin definitions] - -[call [arg fsCmd] [method append] [arg path]] - -The append subcommand receives the filename to append to as its -argument. It returns a writable tcl channel as its return value. - -[call [arg fsCmd] [method delete] [arg path] [arg channel]] - -The delete subcommand receives the filename to delete, and a channel -to write to as its two arguments. The file specified is deleted and -the appropriate ftp message is written to the channel that is passed -as the second argument. The delete subcommand returns nothing. - -[call [arg fsCmd] [method dlist] [arg path] [arg style] [arg channel]] - -The dlist subcommand receives the path that it should list the files -that are in, the style in which the files should be listed which is -either [const nlst] or [const list], and a channel to write to as -its three arguments. The files in the specified path are printed to -the specified channel one per line. If the style is [const nlst] -only the name of the file is printed to the channel. If the style is -[const list] then the file permissions, number of links to the file, -the name of the user that owns the file, the name of the group that -owns the file, the size (in bytes) of the file, the modify time of the -file, and the filename are printed out to the channel in a formatted -space separated format. The [method dlist] subcommand returns -nothing. - -[call [arg fsCmd] [method exists] [arg path]] - -The exists subcommand receives the name of a file to check the -existence of as its only argument. The exists subcommand returns a 1 -if the path specified exists and the path is not a directory. - -[call [arg fsCmd] [method mkdir] [arg path] [arg channel]] - -The mkdir subcommand receives the path of a directory to create and a -channel to write to as its two arguments. The mkdir subcommand -creates the specified directory if necessary and possible. The mkdir -subcommand then prints the appropriate success or failure message to -the channel. The mkdir subcommand returns nothing. - -[call [arg fsCmd] [method mtime] [arg path] [arg channel]] - -The mtime subcommand receives the path of a file to check the modify -time on and a channel as its two arguments. If the file exists the -mtime is printed to the channel in the proper FTP format, otherwise an -appropriate error message and code are printed to the channel. The -mtime subcommand returns nothing. - -[call [arg fsCmd] [method permissions] [arg path]] - -The permissions subcommand receives the path of a file to retrieve the -permissions of. The permissions subcommand returns the octal file -permissions of the specified file. The file is expected to exist. - -[call [arg fsCmd] [method rename] [arg path] [arg newpath] [arg channel]] - -The rename subcommand receives the path of the current file, the new -file path, and a channel to write to as its three arguments. The -rename subcommand renames the current file to the new file path if the -path to the new file exists, and then prints out the appropriate -message to the channel. If the new file path doesn't exist the -appropriate error message is printed to the channel. The rename -subcommand returns nothing. - -[call [arg fsCmd] [method retr] [arg path]] - -The retr subcommand receives the path of a file to read as its only -argument. The retr subcommand returns a readable channel that the -specified file can be read from. - -[call [arg fsCmd] [method rmdir] [arg path] [arg channel]] - -The rmdir subcommand receives the path of a directory to remove and a -channel to write to as its two arguments. The rmdir subcommand -removes the specified directory (if possible) and prints the -appropriate message to the channel (which may be an error if the -specified directory does not exist or is not empty). The rmdir -subcommand returns nothing. - -[call [arg fsCmd] [method size] [arg path] [arg channel]] - -The size subcommand receives the path of a file to get the size (in -bytes) of and a channel to write to as its two arguments. The size -subcommand prints the appropriate code and the size of the file if the -specified path is a file, otherwise an appropriate error code and -message are printed to the channel. The size subcommand returns -nothing. - -[call [arg fsCmd] [method store] [arg path]] - -The store subcommand receives the path of a file to write as its only -argument. The store subcommand returns a writable channel. - -[list_end] -[list_end] - -[section VARIABLES] - -[list_begin definitions] - -[lst_item [var ::ftpd::cwd]] - -The current working directory for a session when someone first -connects to the FTPD or when the [cmd REIN] ftp command is received. - -[lst_item [var ::ftpd::contact]] - -The e-mail address of the person that is the contact for the ftp -server. This address is printed out as part of the response to the -[cmd {FTP HELP}] command. - -[lst_item [var ::ftpd::port]] - -The port that the ftp server should listen on. - -[lst_item [var ::ftpd::welcome]] - -The message that is printed out when the user first connects to the -ftp server. - - -[list_end] - -[keywords ftpd ftp ftpserver services {rfc 959}] -[manpage_end] DELETED modules/ftpd/ftpd.n Index: modules/ftpd/ftpd.n ================================================================== --- modules/ftpd/ftpd.n +++ /dev/null @@ -1,197 +0,0 @@ -'\" -'\" Copyright (c) 2000 by Ajuba Solutions. -'\" All rights reserved. -'\" -'\" RCS: @(#) $Id: ftpd.n,v 1.5 2002/06/03 20:21:46 andreas_kupries Exp $ -'\" -.so man.macros -.TH ftpd n 1.1.2 ftpd "Tcl FTP Server Package" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -ftpd \- Tcl FTP server implementation -.SH SYNOPSIS -\fBpackage require Tcl 8.3\fR -.sp -\fBpackage require ftpd ?1.1.2?\fR -.sp -\fB::ftpd::server\fR \fR?\fImyaddr\fR?\fR -.sp -\fB::ftpd::config\fR \fR?\fIoption\fR \fIvalue\fR?\fR \fR?\fIoption\fR \fIvalue\fR \fI...\fR?\fR -.sp - -.BE -.SH DESCRIPTION -.PP -The \fBftpd\fR package provides a simple Tcl-only server library for -the FTP protocol. It works by listening on the standard FTP socket. -Most server errors are returned as error messages with the appropriate -code attached to them. Since the server code for the ftp daemon is -executed in the event loop, it is possible that a bgerror will be thrown -on the server if there are problems with the code in the module. - -.SH COMMANDS -.TP -\fB::ftpd::server\fR \fR?\fImyaddr\fR?\fR -Open a listening socket to listen to and accept ftp connections. -myaddr is an optional argument. \fBmyaddr\fR is the domain-style name or -numerical IP address of the client-side network interface to use for the -connection. -.TP -\fB::ftpd::config\fR \fR?\fIoption\fR \fIvalue\fR?\fR \fR?\fIoption\fR \fIvalue\fR \fI...\fR?\fR -The value is always the proc to call as the callback. The option specifies -which callback should be configured. See the CALLBACKS section for -descriptions of the arguments and return values for each of the callbacks. -.RS -.TP -\fB-authIpCmd proc\fR -Callback to authenticate new connections based on the ip-address of the -peer. -.TP -\fB-authUsrCmd proc\fR -Callback to authenticate new connections based on the user logging in (and -the users password). -.TP -\fB-authFileCmd proc\fR -Callback to accept or deny a users access to read and write to a specific -path or file. -.TP -\fB-logCmd proc\fR -Callback for log information generated by the FTP engine. -.TP -\fB-fsCmd proc\fR -Callback to connect the engine to the filesystem it operates on. -.RE -.TP -.SH CALLBACKS -.TP -\fBauthIpCmd callback\fR -The authIpCmd receives the ip-address of the peer attempting to connect to -the ftp server as its argument. It returns a 1 to allow users from the -specified IP to attempt to login and a 0 to reject the login attempt from -the specified IP. -.TP -\fBauthUsrCmd callback\fR -The authUsrCmd receives the username and password as its two arguments. It -returns a 1 to accept the attempted login to the ftpd and a 0 to reject the -attempted login. -.TP -\fBauthFileCmd callback\fR -The authFileCmd receives the user (that is currently logged in), the -path or filename that is about to be read or written, and \fBread\fR -or \fBwrite\fR as its three arguments. It returns a 1 to allow the path or -filename to be read or written, and a 0 to reject the attempted read or -write with a permissions error code. -.TP -\fBlogCmd callback\fR -The logCmd receives a severity and a message as its two arguments. The -severities used within the ftpd package are \fBnote\fR, \fBdebug\fR, and -\fBerror\fR. The logCmd doesn't return anything. -.TP -\fBfsCmd callback\fR -The fsCmd receives a subcommand, a filename or path, and optional -additional arguments (depending on the subcommand). -.SP -The subcommands supported by the fsCmd are: -.RS -.TP -\fBappend\fR -The append subcommand receives the filename to append to as its argument. It -returns a writable tcl channel as its return value. -.TP -\fBdelete\fR -The delete subcommand receives the filename to delete, and a channel to -write to as its two arguments. The file specified is deleted and the -appropriate ftp message is written to the channel that is passed as the -second argument. The delete subcommand returns nothing. -.TP -\fBdlist\fR - - -
 TOC 
-
- - - -
The README fileM.T. Rose
 Dover Beach Consulting, Inc.
 February 22, 2000
-

Tcl MIME
- - -

Abstract

- -

-Tcl MIME generates and parses MIME body parts. -

-
 -
 TOC 
-

Table of Contents

-
    -1.  -SYNOPSIS
     -1.1  -Requirements
     -1.2  -Copyrights
     -2.  -SYNTAX
     -3.  -SEMANTICS
     -3.1  -mime::initialize
     -3.2  -mime::finalize
     -3.3  -mime::getproperty
     -3.4  -mime::getheader
     -3.5  -mime::setheader
     -3.6  -mime::getbody
     -3.7  -mime::copymessage
     -3.7  -mime::buildmessage
     -3.8  -smtp::sendmessage
     -3.9  -mime::parseaddress
     -3.10  -mime::parsedatetime
     -3.10  -mime::mapencoding
     -3.10  -mime::reversemapencoding
     - -4.  -EXAMPLES
     -§  -References
     -§  -Author's Address
     -A.  -TODO List
     -B.  -Acknowledgements
     -
-
- -
 -
 TOC 
-

1. SYNOPSIS

-
-    package provide mime 1.2
-    package provide smtp 1.2
-
- -

-Tcl MIME is an implementation of a Tcl package that generates and -parses MIME[1] body parts. -

- -

-Each MIME part consists of a header -(zero or more key/value pairs), -an empty line, -and a structured body. -A MIME part is either a "leaf" or has (zero or more) subordinates. -

- -

-MIME defines four keys that may appear in the headers: - -

- -
Content-Type:
-
-describes the data contained in the body -("the content"); -
- -
Content-Transfer-Encoding:
-
-describes how the content is -encoded for transmission in an ASCII stream; -
- -
Content-Description:
-
-a textual description of the -content; and, -
- -
Content-ID:
-
-a globally-unique identifier for the -content. -
- -
- -

- -

-Consult [2] for a list of standard content types. -Further, -consult [3] for a list of several other header keys -(e.g., "To", "cc", etc.) -

- -

-A simple example might be: -

-
-    Date: Sun, 04 July 1999 10:38:25 -0600
-    From: Marshall Rose <mrose@dbc.mtview.ca.us>
-    To: Andreas Kupries <a.kupries@westend.com>
-    cc: dnew@messagemedia.com (Darren New)
-    MIME-Version: 1.0
-    Content-Type: text/plain; charset="us-ascii"
-    Content-Description: a simple example
-    Content-ID: <4294407315.931384918.1@dbc.mtview.ca.us>
-    
-    Here is the body. In this case, simply plain text.
-
- -

-In addition to an implementation of the mime package, -Tcl MIME includes an implementation of the smtp package. -

- -

1.1 Requirements

- -

-This package requires: - -

-

-

-In addition, this package requires one of the following: - -

-

-

-If it is available, Trf will be used to provide better performance; -if not, Tcl-only equivalent functions, based on the base64 package, are used. -

- -

1.2 Copyrights

- -

-(c) 1999-2000 Marshall T. Rose -

- -

-Hold harmless the author, and any lawful use is allowed. -

- -
 -
 TOC 
-

2. SYNTAX

- -

-mime::initialize -returns a token. -Parameters: -

-
    ?-canonical type/subtype
-        ?-param    {key value}?...
-        ?-encoding value?
-        ?-header   {key value}?... ?
-    (-file name | -string value | -parts {token1 ... tokenN})
-
- -

-mime::finalize returns -an empty string. -Parameters: -

-
    token ?-subordinates "all" | "dynamic" | "none"?
-
- -

-mime::getproperty -returns a string or a list of strings. -Parameters: -

-
    token ?property | -names?
-
- -

-mime::getheader returns -a list of strings. -Parameters: -

-
    token ?key | -names?
-
- -

-mime::setheader returns -a list of strings. -Parameters: -

-
    token key value ?-mode "write" | "append" | "delete"?
-
- -

-mime::getbody returns a string. -Parameters: -

-
    ?-command callback ?-blocksize octets? ?
-
- -

-mime::copymessage -returns an empty string. -Parameters: -

-
    token channel
-
- -

-mime::buildmessage -returns a string. -Parameters: -

-
    token
-
- -

-smtp::sendmessage -returns a list. -Parameters: -

-
    token ?-servers list? ?-ports list?
-          ?-queue boolean?     ?-atleastone boolean?
-          ?-originator string? ?-recipients string?
-          ?-header {key value}?...
-
- -

-mime::parseaddress -returns a list of serialized arrays. -Parameters: -

-
    string
-
- -

-mime::parsedatetime -returns a string. -Parameters: -

-
    [string | -now] property
-
- -

-mime::mapencoding -returns a string. -Parameters: -

-
    encoding_name
-
- -

-mime::reversemapencoding -returns a string. -Parameters: -

-
    mime_charset
-
- -
 -
 TOC 
-

3. SEMANTICS

- -

3.1 mime::initialize

- -

-mime::initialize creates a MIME part: - -

    - -
  • -If the -canonical option is present, -then the body is in canonical (raw) form and is found by consulting -either the -file, -string, or -part option. -
    -
    - -In addition, -both the -param and -header options may occur zero or more times to -specify "Content-Type" parameters (e.g., "charset") -and header keyword/values (e.g., "Content-Disposition"), -respectively. -
    -
    - -Also, -encoding, if present, -specifies the "Content-Transfer-Encoding" when copying the body. -
    • - -
  • -If the -canonical option is not present, -then the MIME part contained in either the -file or the -string option -is parsed, -dynamically generating subordinates as appropriate. -
    • - -
- -

- -

3.2 mime::finalize

- -

-mime::finalize destroys a MIME part. -

- -

-If the -subordinates option is present, -it specifies which subordinates should also be destroyed. -The default value is "dynamic". -

- -

3.3 mime::getproperty

- -

-mime::getproperty returns the properties of a MIME part. -

- -

-The properties are: -

-
-    property    value
-    ========    =====
-    content     the type/subtype describing the content
-    encoding    the "Content-Transfer-Encoding"
-    params      a list of "Content-Type" parameters
-    parts       a list of tokens for the part's subordinates
-    size        the approximate size of the content (unencoded)
-
- -

-The "parts" property is present only if the MIME part has -subordinates. -

- -

-If mime::getproperty is invoked with the name of a specific property, -then the corresponding value is returned; -instead, -if -names is specified, -a list of all properties is returned; -otherwise, -a serialized array of properties and values is returned. -

- -

3.4 mime::getheader

- -

-mime::getheader returns the header of a MIME part. -

- -

-A header consists of zero or more key/value pairs. -Each value is a list containing one or more strings. -

- -

-If mime::getheader is invoked with the name of a specific key, -then a list containing the corresponding value(s) is returned; -instead, -if -names is specified, -a list of all keys is returned; -otherwise, -a serialized array of keys and values is returned. -Note that when a key is specified (e.g., "Subject"), -the list returned usually contains exactly one string; -however, -some keys (e.g., "Received") often occur more than once in the header, -accordingly the list returned usually contains more than one string. -

- -

3.5 mime::setheader

- -

-mime::setheader writes, appends to, or deletes the value associated -with a key in the header. -

- -

-The value for -mode is one of: - -

- -
write:
-
- the key/value is either created or -overwritten (the default); -
- -
append:
-
- a new value is appended for the key -(creating it as necessary); or, -
- -
delete:
-
- all values associated with the key are removed -(the "value" parameter is ignored). -
- -
- -

- -

-Regardless, -mime::setheader returns the previous value associated with the key. -

- -

3.6 mime::getbody

- -

-mime::getbody returns the body of a leaf MIME part in canonical form. -

- -

-If the -command option is present, -then it is repeatedly invoked with a fragment of the body as this: -

-
-    uplevel #0 $callback [list "data" $fragment]
-
- -

-(The -blocksize option, -if present, -specifies the maximum size of each fragment passed to the -callback.) -

- -

-When the end of the body is reached, -the callback is invoked as: -

-
-    uplevel #0 $callback "end"
-
- -

-Alternatively, -if an error occurs, -the callback is invoked as: -

-
-    uplevel #0 $callback [list "error" reason]
-
- -

-Regardless, -the return value of the final invocation of the callback is propagated -upwards by mime::getbody. -

- -

-If the -command option is absent, -then the return value of mime::getbody is a string containing the MIME -part's entire body. -

- -

3.7 mime::copymessage

- -

-mime::copymessage copies the MIME part to the specified channel. -

- -

-mime::copymessage operates synchronously, -and uses fileevent to allow asynchronous operations to proceed -independently. -

- -

3.7 mime::buildmessage

- -

-mime::buildmessage returns the MIME part as a string. It is similar -to mime::copymessage, only it returns the data as a return string -instead of writing to a channel. -

- - -

3.8 smtp::sendmessage

- -

-smtp::sendmessage sends a MIME part to an SMTP server. -(Note that this procedure is in the "smtp" package, -not the "mime" package.) -

- -

-The options are: - -

- -
-servers:
-
-a list of SMTP servers -(the default is "localhost"); -
- -
-ports:
-
-a list of SMTP ports -(the default is 25); -
- -
-queue:
-
-indicates that the SMTP server should be -asked to queue the message for later processing; -
- -
-atleastone:
-
-indicates that the SMTP server must find -at least one recipient acceptable for the message to be sent; -
- -
-originator:
-
-a string containing an 822-style address -specification -(if present the header isn't examined for an originator address); -
- -
-recipients:
-
-a string containing one or more 822-style -address specifications -(if present the header isn't examined for recipient addresses); and, -
- -
-header:
-
-a keyword/value pairing -(may occur zero or more times). -
- -
- -

- -

-If the -originator option is not present, -the originator address is taken from "From" (or "Resent-From"); -similarly, -if the -recipients option is not present, -recipient addresses are taken from "To", "cc", and "Bcc" (or -"Resent-To", and so on). -Note that the header key/values supplied by the "-header" option -(not those present in the MIME part) -are consulted. -Regardless, -header key/values are added to the outgoing message as necessary to -ensure that a valid 822-style message is sent. -

- -

-smtp::sendmessage returns a list indicating which recipients were -unacceptable to the SMTP server. -Each element of the list is another list, -containing the address, an SMTP error code, and a textual diagnostic. -Depending on the -atleastone option and the intended recipients,, -a non-empty list may still indicate that the message was accepted by -the server. -

- -

3.9 mime::parseaddress

- -

-mime::parseaddr takes a string containing one or more 822-style -address specifications and returns a list of serialized arrays, -one element for each address specified in the argument. -

- -

-Each serialized array contains these properties: -

-
-    property    value
-    ========    =====
-    address     local@domain
-    comment     822-style comment
-    domain      the domain part (rhs)
-    error       non-empty on a parse error 
-    group       this address begins a group
-    friendly    user-friendly rendering
-    local       the local part (lhs)
-    memberP     this address belongs to a group
-    phrase      the phrase part
-    proper      822-style address specification
-    route       822-style route specification (obsolete)
-
- -

-Note that one or more of these properties may be empty. -

- -

3.10 mime::parsedatetime

- -

-mime::parsedatetime takes a string containing an 822-style -date-time specification and returns the specified property. -

- -

-The list of properties and their ranges are: -

-
-    property     range
-    ========     =====
-    hour         0 .. 23
-    lmonth       January, February, ..., December
-    lweekday     Sunday, Monday, ... Saturday
-    mday         1 .. 31
-    min          0 .. 59
-    mon          1 .. 12
-    month        Jan, Feb, ..., Dec
-    proper       822-style date-time specification
-    rclock       elapsed seconds between then and now
-    sec          0 .. 59
-    wday         0 .. 6 (Sun .. Mon)
-    weekday      Sun, Mon, ..., Sat
-    yday         1 .. 366
-    year         1900 ...
-    zone         -720 .. 720 (minutes east of GMT)
-
- -

3.10 mime::mapencoding

- -

-mime::mapencoding takes a string containing the name of a -tcl encoding (see [encoding names]) and returns the MIME -charset name for that encoding (or "" if the charset name -is unknown). -

- -

3.10 mime::reversemapencoding

- -

-mime::reversemapencoding takes a string containing the name of a -MIME charset tcl encoding (see [encoding names]) and returns the MIME -charset name for that encoding (or "" if no known tcl encoding maps to -the mime charset type). -

- -
 -
 TOC 
-

4. EXAMPLES

-
-package require mime 1.0
-package require smtp 1.0
-
-
-# create an image
-
-set imageT [mime::initialize -canonical image/gif \
-                             -file logo.gif]
-
-
-# parse a message
-
-set messageT [mime::initialize -file example.msg]
-
-
-# recursively traverse a message looking for primary recipients
-
-proc traverse {token} {
-    set result ""
-
-# depth-first search
-    if {![catch { mime::getproperty $token parts } parts]} {
-        foreach part $parts {
-            set result [concat $result [traverse $part]]
-        }
-    }
-
-# one value for each line occuring in the header
-    foreach value [mime::getheader $token To] {
-        foreach addr [mime::parseaddress $value] {
-            catch { unset aprops }
-            array set aprops $addr
-            lappend result $aprops(address)
-        }
-    }
-
-    return $result
-}
-
-
-# create a multipart containing both, and a timestamp
-
-set multiT [mime::initialize -canonical multipart/mixed
-                             -parts [list $imageT $messageT]]
-
-
-
-
-# send it to some friends
-
-smtp::sendmessage $multiT \
-      -header [list From "Marshall Rose <mrose@dbc.mtview.ca.us>"] \
-      -header [list To "Andreas Kupries <a.kupries@westend.com>"] \
-      -header [list cc "dnew@messagemedia.com (Darren New)"] \
-      -header [list Subject "test message..."]
-
-
-# clean everything up
-
-mime::finalize $multiT -subordinates all
-
-
 -
 TOC 
-

-References

- - - - - - - -
[1]Freed, N. and N.S. Borenstein, "Multipurpose Internet Mail Extensions (MIME) -Part One: Format of Internet Message Bodies", RFC 2045, November 1996.
[2]Freed, N. and N.S. Borenstein, "Multipurpose Internet Mail Extensions (MIME) -Part Two: Media Types", RFC 2046, November 1995.
[3]Crocker, D., "Standard for the format of ARPA Internet Text Messages", RFC 822, STD 11, August 1982.
- -
 -
 TOC 
-

Author's Address

- - - - - - - - - - - - - - - - - -
 Marshall T. Rose
 Dover Beach Consulting, Inc.
 POB 255268
 Sacramento, CA 95865-5268
 US
Phone: +1 916 483 8878
Fax: +1 916 483 8848
EMail: mrose@dbc.mtview.ca.us
- -
 -
 TOC 
-

Appendix A. TODO List

- -

- -

- -
mime::initialize
-
- -
    - -
  • -well-defined errorCode values -
    • - -
  • -catch nested errors when processing a multipart -
    • - -
- -
- -
- -

- -
 -
 TOC 
-

Appendix B. Acknowledgements

- -

-This package is influenced by the safe-tcl package -(Borenstein and Rose, circa 1993), -and also by Darren New's -unpublished package of 1999. -

- -

-This package makes use of -Andreas Kupries's -excellent Trf package. -

- DELETED modules/mime/README.txt Index: modules/mime/README.txt ================================================================== --- modules/mime/README.txt +++ /dev/null @@ -1,804 +0,0 @@ - - -The README file M.T. Rose - Dover Beach Consulting, Inc. - February 22, 2000 - - - Tcl MIME - - -Abstract - - Tcl MIME generates and parses MIME body parts. - -Table of Contents - - 1. SYNOPSIS . . . . . . . . . . . . . . . . . . . . . . . . . . 2 - 1.1 Requirements . . . . . . . . . . . . . . . . . . . . . . . . 3 - 1.2 Copyrights . . . . . . . . . . . . . . . . . . . . . . . . . 3 - 2. SYNTAX . . . . . . . . . . . . . . . . . . . . . . . . . . . 4 - 3. SEMANTICS . . . . . . . . . . . . . . . . . . . . . . . . . 5 - 3.1 mime::initialize . . . . . . . . . . . . . . . . . . . . . . 5 - 3.2 mime::finalize . . . . . . . . . . . . . . . . . . . . . . . 5 - 3.3 mime::getproperty . . . . . . . . . . . . . . . . . . . . . 5 - 3.4 mime::getheader . . . . . . . . . . . . . . . . . . . . . . 6 - 3.5 mime::setheader . . . . . . . . . . . . . . . . . . . . . . 6 - 3.6 mime::getbody . . . . . . . . . . . . . . . . . . . . . . . 6 - 3.7 mime::copymessage . . . . . . . . . . . . . . . . . . . . . 7 - 3.8 mime::buildmessage . . . . . . . . . . . . . . . . . . . . . 7 - 3.9 smtp::sendmessage . . . . . . . . . . . . . . . . . . . . . 7 - 3.10 mime::parseaddress . . . . . . . . . . . . . . . . . . . . . 8 - 3.11 mime::parsedatetime . . . . . . . . . . . . . . . . . . . . 9 - 3.12 mime::mapencoding . . . . . . . . . . . . . . . . . . . . . 9 - 3.13 mime::reversemapencoding . . . . . . . . . . . . . . . . . . 9 - - 4. EXAMPLES . . . . . . . . . . . . . . . . . . . . . . . . . . 10 - References . . . . . . . . . . . . . . . . . . . . . . . . . 12 - Author's Address . . . . . . . . . . . . . . . . . . . . . . 12 - A. TODO List . . . . . . . . . . . . . . . . . . . . . . . . . 13 - B. Acknowledgements . . . . . . . . . . . . . . . . . . . . . . 14 - - - - - - - - - - - - - - - - - - -Rose [Page 1] - -README Tcl MIME February 2000 - - -1. SYNOPSIS - - package provide mime 1.2 - package provide smtp 1.2 - - Tcl MIME is an implementation of a Tcl package that generates and - parses MIME[1] body parts. - - Each MIME part consists of a header (zero or more key/value pairs), - an empty line, and a structured body. A MIME part is either a "leaf" - or has (zero or more) subordinates. - - MIME defines four keys that may appear in the headers: - - Content-Type: describes the data contained in the body ("the - content"); - - Content-Transfer-Encoding: describes how the content is encoded - for transmission in an ASCII stream; - - Content-Description: a textual description of the content; and, - - Content-ID: a globally-unique identifier for the content. - - Consult [2] for a list of standard content types. Further, consult - [3] for a list of several other header keys (e.g., "To", "cc", etc.) - - A simple example might be: - - Date: Sun, 04 July 1999 10:38:25 -0600 - From: Marshall Rose - To: Andreas Kupries - cc: dnew@messagemedia.com (Darren New) - MIME-Version: 1.0 - Content-Type: text/plain; charset="us-ascii" - Content-Description: a simple example - Content-ID: <4294407315.931384918.1@dbc.mtview.ca.us> - - Here is the body. In this case, simply plain text. - - In addition to an implementation of the mime package, Tcl MIME - includes an implementation of the smtp package. - - - - - - - - - -Rose [Page 2] - -README Tcl MIME February 2000 - - -1.1 Requirements - - This package requires: - - o Tcl/Tk version 8.0.3[4] or later - - In addition, this package requires one of the following: - - o Trf version 2.0p5[5] or later - - o base64 version 2.0 or later (included with tcllib) - - If it is available, Trf will be used to provide better performance; - if not, Tcl-only equivalent functions, based on the base64 package, - are used. - -1.2 Copyrights - - (c) 1999-2000 Marshall T. Rose - - Hold harmless the author, and any lawful use is allowed. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Rose [Page 3] - -README Tcl MIME February 2000 - - -2. SYNTAX - - mime::initialize (Section 3.1) returns a token. Parameters: - ?-canonical type/subtype - ?-param {key value}?... - ?-encoding value? - ?-header {key value}?... ? - (-file name | -string value | -parts {token1 ... tokenN}) - - mime::finalize (Section 3.2) returns an empty string. Parameters: - token ?-subordinates "all" | "dynamic" | "none"? - - mime::getproperty (Section 3.3) returns a string or a list of - strings. Parameters: - token ?property | -names? - - mime::getheader (Section 3.4) returns a list of strings. Parameters: - token ?key | -names? - - mime::setheader (Section 3.5) returns a list of strings. Parameters: - token key value ?-mode "write" | "append" | "delete"? - - mime::getbody (Section 3.6) returns a string. Parameters: - ?-command callback ?-blocksize octets? ? - - mime::copymessage (Section 3.7) returns an empty string. Parameters: - token channel - - mime::buildmessage (Section 3.7) returns a string. Parameters: - token - - smtp::sendmessage (Section 3.8) returns a list. Parameters: - token ?-servers list? ?-ports list? - ?-queue boolean? ?-atleastone boolean? - ?-originator string? ?-recipients string? - ?-header {key value}?... - - mime::parseaddress (Section 3.9) returns a list of serialized - arrays. Parameters: - string - - mime::parsedatetime (Section 3.10) returns a string. Parameters: - [string | -now] property - - mime::mapencoding (Section 3.10) returns a string. Parameters: - encoding_name - - mime::reversemapencoding (Section 3.10) returns a string. Parameters: - charset_type - - - -Rose [Page 4] - -README Tcl MIME February 2000 - - -3. SEMANTICS - -3.1 mime::initialize - - mime::initialize creates a MIME part: - - o If the -canonical option is present, then the body is in - canonical (raw) form and is found by consulting either the -file, - -string, or -part option. - - In addition, both the -param and -header options may occur zero - or more times to specify "Content-Type" parameters (e.g., - "charset") and header keyword/values (e.g., - "Content-Disposition"), respectively. - - Also, -encoding, if present, specifies the - "Content-Transfer-Encoding" when copying the body. - - o If the -canonical option is not present, then the MIME part - contained in either the -file or the -string option is parsed, - dynamically generating subordinates as appropriate. - -3.2 mime::finalize - - mime::finalize destroys a MIME part. - - If the -subordinates option is present, it specifies which - subordinates should also be destroyed. The default value is - "dynamic". - -3.3 mime::getproperty - - mime::getproperty returns the properties of a MIME part. - - The properties are: - - property value - ======== ===== - content the type/subtype describing the content - encoding the "Content-Transfer-Encoding" - params a list of "Content-Type" parameters - parts a list of tokens for the part's subordinates - size the approximate size of the content (unencoded) - - The "parts" property is present only if the MIME part has - subordinates. - - If mime::getproperty is invoked with the name of a specific - property, then the corresponding value is returned; instead, if - - -Rose [Page 5] - -README Tcl MIME February 2000 - - - -names is specified, a list of all properties is returned; - otherwise, a serialized array of properties and values is returned. - -3.4 mime::getheader - - mime::getheader returns the header of a MIME part. - - A header consists of zero or more key/value pairs. Each value is a - list containing one or more strings. - - If mime::getheader is invoked with the name of a specific key, then - a list containing the corresponding value(s) is returned; instead, - if -names is specified, a list of all keys is returned; otherwise, a - serialized array of keys and values is returned. Note that when a - key is specified (e.g., "Subject"), the list returned usually - contains exactly one string; however, some keys (e.g., "Received") - often occur more than once in the header, accordingly the list - returned usually contains more than one string. - -3.5 mime::setheader - - mime::setheader writes, appends to, or deletes the value associated - with a key in the header. - - The value for -mode is one of: - - write: the key/value is either created or overwritten (the - default); - - append: a new value is appended for the key (creating it as - necessary); or, - - delete: all values associated with the key are removed (the - "value" parameter is ignored). - - Regardless, mime::setheader returns the previous value associated - with the key. - -3.6 mime::getbody - - mime::getbody returns the body of a leaf MIME part in canonical form. - - If the -command option is present, then it is repeatedly invoked - with a fragment of the body as this: - - uplevel #0 $callback [list "data" $fragment] - - (The -blocksize option, if present, specifies the maximum size of - each fragment passed to the callback.) - - -Rose [Page 6] - -README Tcl MIME February 2000 - - - When the end of the body is reached, the callback is invoked as: - - uplevel #0 $callback "end" - - Alternatively, if an error occurs, the callback is invoked as: - - uplevel #0 $callback [list "error" reason] - - Regardless, the return value of the final invocation of the callback - is propagated upwards by mime::getbody. - - If the -command option is absent, then the return value of - mime::getbody is a string containing the MIME part's entire body. - -3.7 mime::copymessage - - mime::copymessage copies the MIME part to the specified channel. - - mime::copymessage operates synchronously, and uses fileevent to - allow asynchronous operations to proceed independently. - -3.7 mime::buildmessage - - mime::buildmessage returns the MIME part as a string. It is similar - to mime::copymessage, only it returns the data as a return string - instead of writing to a channel. - -3.8 smtp::sendmessage - - smtp::sendmessage sends a MIME part to an SMTP server. (Note that - this procedure is in the "smtp" package, not the "mime" package.) - - The options are: - - -servers: a list of SMTP servers (the default is "localhost"); - - -ports: a list of SMTP ports (the default is 25) - - -queue: indicates that the SMTP server should be asked to queue - the message for later processing; - - -atleastone: indicates that the SMTP server must find at least - one recipient acceptable for the message to be sent; - - -originator: a string containing an 822-style address - specification (if present the header isn't examined for an - originator address); - - -recipients: a string containing one or more 822-style address - specifications (if present the header isn't examined for - recipient addresses); and, - - -header: a keyword/value pairing (may occur zero or more times). - - If the -originator option is not present, the originator address is - taken from "From" (or "Resent-From"); similarly, if the -recipients - option is not present, recipient addresses are taken from "To", - - -Rose [Page 7] - -README Tcl MIME February 2000 - - - "cc", and "Bcc" (or "Resent-To", and so on). Note that the header - key/values supplied by the "-header" option (not those present in - the MIME part) are consulted. Regardless, header key/values are - added to the outgoing message as necessary to ensure that a valid - 822-style message is sent. - - smtp::sendmessage returns a list indicating which recipients were - unacceptable to the SMTP server. Each element of the list is another - list, containing the address, an SMTP error code, and a textual - diagnostic. Depending on the -atleastone option and the intended - recipients,, a non-empty list may still indicate that the message - was accepted by the server. - -3.9 mime::parseaddress - - mime::parseaddr takes a string containing one or more 822-style - address specifications and returns a list of serialized arrays, one - element for each address specified in the argument. - - Each serialized array contains these properties: - - property value - ======== ===== - address local@domain - comment 822-style comment - domain the domain part (rhs) - error non-empty on a parse error - group this address begins a group - friendly user-friendly rendering - local the local part (lhs) - memberP this address belongs to a group - phrase the phrase part - proper 822-style address specification - route 822-style route specification (obsolete) - - Note that one or more of these properties may be empty. - - - - - - - - - - - - - - -Rose [Page 8] - -README Tcl MIME February 2000 - - -3.10 mime::parsedatetime - - mime::parsedatetime takes a string containing an 822-style date-time - specification and returns the specified property. - - The list of properties and their ranges are: - - property range - ======== ===== - hour 0 .. 23 - lmonth January, February, ..., December - lweekday Sunday, Monday, ... Saturday - mday 1 .. 31 - min 0 .. 59 - mon 1 .. 12 - month Jan, Feb, ..., Dec - proper 822-style date-time specification - rclock elapsed seconds between then and now - sec 0 .. 59 - wday 0 .. 6 (Sun .. Mon) - weekday Sun, Mon, ..., Sat - yday 1 .. 366 - year 1900 ... - zone -720 .. 720 (minutes east of GMT) - -3.10 mime::mapencoding - - mime::mapencodings maps tcl encodings onto the proper names for their - MIME charset type. This is only done for encodings whose charset types - were known. The remaining encodings return "" for now. - -3.10 mime::reversemapencoding - - mime::reversemapencoding maps MIME charset types onto tcl encoding names. - Those that are unknown return "". - - - - - - - - - - - - - - - - -Rose [Page 9] - -README Tcl MIME February 2000 - - -4. EXAMPLES - - package require mime 1.0 - package require smtp 1.0 - - - # create an image - - set imageT [mime::initialize -canonical image/gif \ - -file logo.gif] - - - # parse a message - - set messageT [mime::initialize -file example.msg] - - - # recursively traverse a message looking for primary recipients - - proc traverse {token} { - set result "" - - # depth-first search - if {![catch { mime::getproperty $token parts } parts]} { - foreach part $parts { - set result [concat $result [traverse $part]] - } - } - - # one value for each line occuring in the header - foreach value [mime::getheader $token To] { - foreach addr [mime::parseaddress $value] { - catch { unset aprops } - array set aprops $addr - lappend result $aprops(address) - } - } - - return $result - } - - - # create a multipart containing both, and a timestamp - - set multiT [mime::initialize -canonical multipart/mixed - -parts [list $imageT $messageT]] - - - - - -Rose [Page 10] - -README Tcl MIME February 2000 - - - # send it to some friends - - smtp::sendmessage $multiT \ - -header [list From "Marshall Rose "] \ - -header [list To "Andreas Kupries "] \ - -header [list cc "dnew@messagemedia.com (Darren New)"] \ - -header [list Subject "test message..."] - - - # clean everything up - - mime::finalize $multiT -subordinates all - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Rose [Page 11] - -README Tcl MIME February 2000 - - -References - - [1] Freed, N. and N.S. Borenstein, "Multipurpose Internet Mail - Extensions (MIME) Part One: Format of Internet Message Bodies", - RFC 2045, November 1996. - - [2] Freed, N. and N.S. Borenstein, "Multipurpose Internet Mail - Extensions (MIME) Part Two: Media Types", RFC 2046, November - 1995. - - [3] Crocker, D., "Standard for the format of ARPA Internet Text - Messages", RFC 822, STD 11, August 1982. - - [4] http://www.scriptics.com/software/8.1.html - - [5] http://www.oche.de/~akupries/soft/trf/ - - [6] mailto:dnew@messagemedia.com - - [7] mailto:a.kupries@westend.com - - -Author's Address - - Marshall T. Rose - Dover Beach Consulting, Inc. - POB 255268 - Sacramento, CA 95865-5268 - US - - Phone: +1 916 483 8878 - Fax: +1 916 483 8848 - EMail: mrose@dbc.mtview.ca.us - - - - - - - - - - - - - - - - - - -Rose [Page 12] - -README Tcl MIME February 2000 - - -Appendix A. TODO List - - mime::initialize - - * well-defined errorCode values - - * catch nested errors when processing a multipart - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Rose [Page 13] - -README Tcl MIME February 2000 - - -Appendix B. Acknowledgements - - This package is influenced by the safe-tcl package (Borenstein and - Rose, circa 1993), and also by Darren New[6]'s unpublished package - of 1999. - - This package makes use of Andreas Kupries[7]'s excellent Trf package. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Rose [Page 14] - DELETED modules/mime/README.xml Index: modules/mime/README.xml ================================================================== --- modules/mime/README.xml +++ /dev/null @@ -1,660 +0,0 @@ - - - - - - - - - - -Tcl MIME - - -Dover Beach Consulting, Inc. -
- -POB 255268 -Sacramento CA 95865-5268 -US - -+1 916 483 8878 -+1 916 483 8848 -mrose@dbc.mtview.ca.us -
- - - - -Tcl MIME generates and parses MIME body parts. - - - - -
-
- -Tcl MIME is an implementation of a Tcl package that generates and -parses MIME body parts. - -Each MIME part consists of a header -(zero or more key/value pairs), -an empty line, -and a structured body. -A MIME part is either a "leaf" or has (zero or more) subordinates. - -MIME defines four keys that may appear in the headers: - -describes the data contained in the body -("the content"); - -describes how the content is -encoded for transmission in an ASCII stream; - -a textual description of the -content; and, - -a globally-unique identifier for the -content. - - -Consult for a list of standard content types. -Further, -consult for a list of several other header keys -(e.g., "To", "cc", etc.) - -
-A simple example might be: - - To: Andreas Kupries - cc: dnew@messagemedia.com (Darren New) - MIME-Version: 1.0 - Content-Type: text/plain; charset="us-ascii" - Content-Description: a simple example - Content-ID: <4294407315.931384918.1@dbc.mtview.ca.us> - - Here is the body. In this case, simply plain text. -]]> -
- -In addition to an implementation of the mime package, -Tcl MIME includes an implementation of the smtp package. - - - -
-This package requires: - -Tcl/Tk version 8.0.3 - -or later -In addition, this package requires one of the following: - -Trf version 2.0p5 -or later -base 64 version 2.0 or later (included with tcllib) - -If it is available, Trf will be used to provide better performance; -if not, Tcl-only equivalent functions, based on the base64 package, -are used. -
- -
-(c) 1999-2000 Marshall T. Rose - -Hold harmless the author, and any lawful use is allowed. -
-
- -
-
-mime::initialize -returns a token. -Parameters: - -
- -
-mime::finalize returns -an empty string. -Parameters: - -
- -
-mime::getproperty -returns a string or a list of strings. -Parameters: - -
- -
-mime::getheader returns -a list of strings. -Parameters: - -
- -
-mime::setheader returns -a list of strings. -Parameters: - -
- -
-mime::getbody returns a string. -Parameters: - -
- -
-mime::copymessage -returns an empty string. -Parameters: - -
- -
-mime::buildmessage -returns an empty string. -Parameters: - -
- -
-smtp::sendmessage -returns a list. -Parameters: - -
- -
-mime::parseaddress -returns a list of serialized arrays. -Parameters: - -
- -
-mime::parsedatetime -returns a string. -Parameters: - -
- -
-mime::mapencoding -returns a string. -Parameters: - -
- -
-mime::reversemapencoding -returns a string. -Parameters: - -
- -
- -
- -
-mime::initialize creates a MIME part: - -If the -canonical option is present, -then the body is in canonical (raw) form and is found by consulting -either the -file, -string, or -part option. - -In addition, -both the -param and -header options may occur zero or more times to -specify "Content-Type" parameters (e.g., "charset") -and header keyword/values (e.g., "Content-Disposition"), -respectively. - -Also, -encoding, if present, -specifies the "Content-Transfer-Encoding" when copying the body. - -If the -canonical option is not present, -then the MIME part contained in either the -file or the -string option -is parsed, -dynamically generating subordinates as appropriate. - -
- -
-mime::finalize destroys a MIME part. - -If the -subordinates option is present, -it specifies which subordinates should also be destroyed. -The default value is "dynamic". -
- -
-mime::getproperty returns the properties of a MIME part. - -
-The properties are: - -The "parts" property is present only if the MIME part has -subordinates. -
- -If mime::getproperty is invoked with the name of a specific property, -then the corresponding value is returned; -instead, -if -names is specified, -a list of all properties is returned; -otherwise, -a serialized array of properties and values is returned. -
- -
-mime::getheader returns the header of a MIME part. - -A header consists of zero or more key/value pairs. -Each value is a list containing one or more strings. - -If mime::getheader is invoked with the name of a specific key, -then a list containing the corresponding value(s) is returned; -instead, -if -names is specified, -a list of all keys is returned; -otherwise, -a serialized array of keys and values is returned. -Note that when a key is specified (e.g., "Subject"), -the list returned usually contains exactly one string; -however, -some keys (e.g., "Received") often occur more than once in the header, -accordingly the list returned usually contains more than one string. -
- -
-mime::setheader writes, appends to, or deletes the value associated -with a key in the header. - -The value for -mode is one of: - - the key/value is either created or -overwritten (the default); - - a new value is appended for the key -(creating it as necessary); or, - - all values associated with the key are removed -(the "value" parameter is ignored). - - -Regardless, -mime::setheader returns the previous value associated with the key. -
- -
-mime::getbody returns the body of a leaf MIME part in canonical form. - -
-If the -command option is present, -then it is repeatedly invoked with a fragment of the body as this: - -(The -blocksize option, -if present, -specifies the maximum size of each fragment passed to the -callback.) -
- -
-When the end of the body is reached, -the callback is invoked as: - -
- -
-Alternatively, -if an error occurs, -the callback is invoked as: - -
- -Regardless, -the return value of the final invocation of the callback is propagated -upwards by mime::getbody. - -If the -command option is absent, -then the return value of mime::getbody is a string containing the MIME -part's entire body. -
- -
-mime::copymessage copies the MIME part to the specified channel. - -mime::copymessage operates synchronously, -and uses fileevent to allow asynchronous operations to proceed -independently. -
- -
-mime::buildmessage returns the MIME part as a string. It is similar -to mime::copymessage, only it returns the data as a return string -instead of writing to a channel. -
- -
-smtp::sendmessage sends a MIME part to an SMTP server. -(Note that this procedure is in the "smtp" package, -not the "mime" package.) - -The options are: - -a list of SMTP servers -(the default is "localhost"); - -a list of SMTP ports -(the default is 25); - -indicates that the SMTP server should be -asked to queue the message for later processing; - -indicates that the SMTP server must find -at least one recipient acceptable for the message to be sent; - -a string containing an 822-style address -specification -(if present the header isn't examined for an originator address); - -a string containing one or more 822-style -address specifications -(if present the header isn't examined for recipient addresses); and, - -a keyword/value pairing -(may occur zero or more times). - - -If the -originator option is not present, -the originator address is taken from "From" (or "Resent-From"); -similarly, -if the -recipients option is not present, -recipient addresses are taken from "To", "cc", and "Bcc" (or -"Resent-To", and so on). -Note that the header key/values supplied by the "-header" option -(not those present in the MIME part) -are consulted. -Regardless, -header key/values are added to the outgoing message as necessary to -ensure that a valid 822-style message is sent. - -smtp::sendmessage returns a list indicating which recipients were -unacceptable to the SMTP server. -Each element of the list is another list, -containing the address, an SMTP error code, and a textual diagnostic. -Depending on the -atleastone option and the intended recipients,, -a non-empty list may still indicate that the message was accepted by -the server. -
- -
-mime::parseaddr takes a string containing one or more 822-style -address specifications and returns a list of serialized arrays, -one element for each address specified in the argument. - -
-Each serialized array contains these properties: - -Note that one or more of these properties may be empty. -
-
- - - -
-mime::parsedatetime takes a string containing an 822-style -date-time specification and returns the specified property. - -
-The list of properties and their ranges are: - -
-
- -
-mime::mapencoding maps tcl encodings onto the proper names for their -MIME charset type. This is only done for encodings whose charset types -were known. The remaining encodings return "" for now. -
- -
-mime::reversemapencoding maps MIME charset types onto tcl encoding names. -Those that are unknown return "". -
- -
- -
-
-"] \ - -header [list To "Andreas Kupries "] \ - -header [list cc "dnew@messagemedia.com (Darren New)"] \ - -header [list Subject "test message..."] - - -# clean everything up - -mime::finalize $multiT -subordinates all -]]> -
-
- - - - - - - -Multipurpose Internet Mail Extensions (MIME) -Part One: Format of Internet Message Bodies - -Innosoft International, Inc. -
-ned@innosoft.com -
- - -First Virtual Holdings, Incorporated -
-nsb@messagemedia.com -
- - - - - - - - -Multipurpose Internet Mail Extensions (MIME) -Part Two: Media Types - -Innosoft International, Inc. -
-ned@innosoft.com -
- - -First Virtual Holdings, Incorporated -
-nsb@messagemedia.com -
- - - - - - - - -Standard for the format of ARPA Internet Text Messages - -University of Delaware -
-DCrocker@UDel-Relay -
- - - - - - - - - -
- - - -well-defined errorCode values - -catch nested errors when processing a multipart - - - -
- -
-This package is influenced by the safe-tcl package -(Borenstein and Rose, circa 1993), -and also by Darren New's -unpublished package of 1999. - -This package makes use of -Andreas Kupries's -excellent Trf package. -
- - - DELETED modules/mime/mime.man Index: modules/mime/mime.man ================================================================== --- modules/mime/mime.man +++ /dev/null @@ -1,373 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[manpage_begin mime n 1.3.3] -[copyright {1999-2000 Marshall T. Rose}] -[moddesc {Mime}] -[titledesc {Manipulation of MIME body parts}] -[require Tcl] -[require mime [opt 1.3.3]] -[description] -[para] - -The [package mime] library package provides the commands to create and -manipulate MIME body parts. - -[list_begin definitions] - - -[call [cmd ::mime::initialize] [opt "[option -canonical] [arg type/subtype] [opt "[option -param] \{[arg {key value}]\}..."] [opt "[option -encoding] [arg value]"] [opt "[option -header] \{[arg {key value}]\}..."]"] "([option -file] [arg name] | [option -string] [arg value] | [option -part] \{[arg token1] ... [arg tokenN]\})"] - -This command creates a MIME part and returns a token representing it. - -[list_begin bullet] - -[bullet] - -If the [option -canonical] option is present, then the body is in -canonical (raw) form and is found by consulting either the - -[option -file], [option -string], or [option -part] option. - -[nl] - -In addition, both the [option -param] and [option -header] options may -occur zero or more times to specify [const Content-Type] parameters -(e.g., [const charset]) and header keyword/values (e.g., - -[const Content-Disposition]), respectively. - -[nl] - -Also, [option -encoding], if present, specifies the - -[const Content-Transfer-Encoding] when copying the body. - -[bullet] - -If the [option -canonical] option is not present, then the MIME part -contained in either the [option -file] or the [option -string] option -is parsed, dynamically generating subordinates as appropriate. - -[list_end] - - -[call [cmd ::mime::finalize] [arg token] [opt "[option -subordinates] [const all] | [const dynamic] | [const none]"]] - -This command destroys the MIME part represented by [arg token]. It -returns an empty string. - -[nl] - -If the [option -subordinates] option is present, it specifies which -subordinates should also be destroyed. The default value is - -[const dynamic], destroying all subordinates which were created by -[cmd ::mime::initialize] together with the containing body part. - - -[call [cmd ::mime::getproperty] [arg token] [opt "[arg property] | [option -names]"]] - -This command returns a string or a list of strings containing the -properties of a MIME part. If the command is invoked with the name of -a specific property, then the corresponding value is returned; -instead, if [option -names] is specified, a list of all properties is -returned; otherwise, a serialized array of properties and values is -returned. - -[nl] -The possible properties are: - -[list_begin definitions] - - -[lst_item [const content]] - -The type/subtype describing the content - -[lst_item [const encoding]] - -The "Content-Transfer-Encoding" - -[lst_item [const params]] - -A list of "Content-Type" parameters - -[lst_item [const parts]] - -A list of tokens for the part's subordinates. This property is -present only if the MIME part has subordinates. - -[lst_item [const size]] - -The approximate size of the content (unencoded) - -[list_end] - - -[call [cmd ::mime::getheader] [arg token] [opt "[arg key] | [option -names]"]] - -This command returns the header of a MIME part, as a list of strings. - -[nl] - -A header consists of zero or more key/value pairs. Each value is a -list containing one or more strings. - -[nl] - -If this command is invoked with the name of a specific [arg key], then -a list containing the corresponding value(s) is returned; instead, if --names is specified, a list of all keys is returned; otherwise, a -serialized array of keys and values is returned. Note that when a key -is specified (e.g., "Subject"), the list returned usually contains -exactly one string; however, some keys (e.g., "Received") often occur -more than once in the header, accordingly the list returned usually -contains more than one string. - - -[call [cmd ::mime::setheader] [arg token] [arg {key value}] [opt "[option -mode] [const write] | [const append] | [const delete]"]] - -This command writes, appends to, or deletes the [arg value] associated -with a [arg key] in the header. It returns a list of strings -containing the previous value associated with the key. - -[nl] - -The value for [option -mode] is one of: - -[list_begin definitions] - - -[lst_item [const write]] - -The [arg key]/[arg value] is either created or overwritten (the default). - -[lst_item [const append]] - -A new [arg value] is appended for the [arg key] (creating it as necessary). - -[lst_item [const delete]] - -All values associated with the key are removed (the [arg value] -parameter is ignored). - -[list_end] - - -[call [cmd ::mime::getbody] [arg token] [opt "[option -command] [arg callback] [opt "[option -blocksize] [arg octets]"]"]] - -This command returns a string containing the body of the leaf MIME -part represented by [arg token] in canonical form. - -[nl] - -If the [option -command] option is present, then it is repeatedly -invoked with a fragment of the body as this: - -[example { - uplevel #0 $callback [list "data" $fragment] -}] - -[nl] - -(The [option -blocksize] option, if present, specifies the maximum -size of each fragment passed to the callback.) - -[nl] - -When the end of the body is reached, the callback is invoked as: - -[example { - uplevel #0 $callback "end" -}] - -[nl] - -Alternatively, if an error occurs, the callback is invoked as: - -[example { - uplevel #0 $callback [list "error" reason] -}] - -[nl] - -Regardless, the return value of the final invocation of the callback -is propagated upwards by mime::getbody. - -[nl] - -If the [option -command] option is absent, then the return value of -[cmd ::mime::getbody] is a string containing the MIME part's entire -body. - - -[call [cmd ::mime::copymessage] [arg token] [arg channel]] - -This command copies the MIME represented by [arg token] part to the -specified [arg channel]. The command operates synchronously, and uses -fileevent to allow asynchronous operations to proceed -independently. It returns an empty string. - - -[call [cmd ::mime::buildmessage] [arg token]] - -This command returns the MIME part represented by [arg token] as a -string. It is similar to [cmd ::mime::copymessage], only it returns -the data as a return string instead of writing to a channel. - - -[call [cmd ::mime::parseaddress] [arg string]] - -This command takes a string containing one or more 822-style address -specifications and returns a list of serialized arrays, one element -for each address specified in the argument. If the string contains -more than one address they will be separated by commas. - -[nl] - -Each serialized array contains the properties below. Note that one or -more of these properties may be empty. - -[list_begin definitions] - - -[lst_item [const address]] - -local@domain - -[lst_item [const comment]] - -822-style comment - -[lst_item [const domain]] - -the domain part (rhs) - -[lst_item [const error]] - -non-empty on a parse error - -[lst_item [const group]] - -this address begins a group - -[lst_item [const friendly]] - -user-friendly rendering - -[lst_item [const local]] - -the local part (lhs) - -[lst_item [const memberP]] - -this address belongs to a group - -[lst_item [const phrase]] - -the phrase part - -[lst_item [const proper]] - -822-style address specification - -[lst_item [const route]] - -822-style route specification (obsolete) - -[list_end] - - -[call [cmd ::mime::parsedatetime] ([arg string] | [option -now]) [arg property]] - -This command takes a string containing an 822-style date-time -specification and returns the specified property as a serialized -array. - -[nl] - -The list of properties and their ranges are: - -[list_begin definitions] - - -[lst_item [const hour]] - -0 .. 23 - -[lst_item [const lmonth]] - -January, February, ..., December - -[lst_item [const lweekday]] - -Sunday, Monday, ... Saturday - -[lst_item [const mday]] - -1 .. 31 - -[lst_item [const min]] - -0 .. 59 - -[lst_item [const mon]] - -1 .. 12 - -[lst_item [const month]] - -Jan, Feb, ..., Dec - -[lst_item [const proper]] - -822-style date-time specification - -[lst_item [const rclock]] - -elapsed seconds between then and now - -[lst_item [const sec]] - -0 .. 59 - -[lst_item [const wday]] - -0 .. 6 (Sun .. Mon) - -[lst_item [const weekday]] - -Sun, Mon, ..., Sat - -[lst_item [const yday]] - -1 .. 366 - -[lst_item [const year]] - -1900 ... - -[lst_item [const zone]] - --720 .. 720 (minutes east of GMT) - -[list_end] - - -[call [cmd ::mime::mapencoding] [arg encoding_name]] - -This commansd maps tcl encodings onto the proper names for their MIME -charset type. This is only done for encodings whose charset types -were known. The remaining encodings return "" for now. - - -[call [cmd ::mime::reversemapencoding] [arg charset_type]] - -This command maps MIME charset types onto tcl encoding names. Those -that are unknown return "". - - -[list_end] - -[see_also smtp pop3 ftp http] -[keywords mail email smtp mime rfc821 rfc822 internet net] -[manpage_end] DELETED modules/mime/mime.n Index: modules/mime/mime.n ================================================================== --- modules/mime/mime.n +++ /dev/null @@ -1,286 +0,0 @@ -'\" -'\" Copyright (c) 2000 Andreas Kupries -'\" All right reserved -'\" -'\" CVS: $Id: mime.n,v 1.5 2002/02/01 17:44:53 andreas_kupries Exp $ mime.n -'\" -.so man.macros -.TH "mime" n 1.3.2 tcllib "mime" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -mime \- Manipulation of MIME body parts -.SH "SYNOPSIS" -package require \fBTcl\fR -.sp -package require \fBmime ?1.3.2?\fR -.sp -\fBmime::initialize\fR ?-canonical \fItype/subtype\fR ?-param {\fIkey value\fR}...? ?-encoding \fIvalue\fR? ?-header {\fIkey value\fR}...?? (-file \fIname\fR | -string \fIvalue\fR | -parse {\fItoken1\fR ... \fItokenN\fR} )\fR -.sp -\fBmime::finalize\fR \fItoken\fR ?-subordinates \fBall\fR | \fBdynamic\fR | \fBnone\fR?\fR -.sp -\fBmime::getproperty\fR \fItoken\fR ?\fIproperty\fR | -names?\fR -.sp -\fBmime::getheader\fR \fItoken\fR ?\fIkey\fR | -names?\fR -.sp -\fBmime::setheader\fR \fItoken\fR \fIkey\fR \fIvalue\fR ?-mode \fBwrite\fR | \fBappend\fR | \fBdelete\fR?\fR -.sp -\fBmime::getbody\fR \fItoken\fR ?-command \fIcallback\fR ?-blocksize \fIoctets\fR??\fR -.sp -\fBmime::copymessage\fR \fItoken\fR \fIchannel\fR\fR -.sp -\fBmime::buildmessage\fR \fItoken\fR\fR -.sp -\fBmime::parseaddress\fR \fIstring\fR\fR -.sp -\fBmime::parsedatetime\fR (\fIstring\fR | -now) \fIproperty\fR\fR -.sp -\fBmime::mapencoding\fR \fIencoding_name\fR\fR -.sp -\fBmime::reversemapencoding\fR \fIcharset_type\fR\fR -.sp -.BE -.SH "DESCRIPTION" -.PP -The mime library package provides the commands to create and -manipulate MIME body parts. -.TP -\fBmime::initialize\fR ?-canonical \fItype/subtype\fR ?-param {\fIkey value\fR}...? ?-encoding \fIvalue\fR? ?-header {\fIkey value\fR}...?? (-file \fIname\fR | -string \fIvalue\fR | -parse {\fItoken1\fR ... \fItokenN\fR} )\fR -This command creates a MIME part and returns a token representing it. -.RS -.TP -* -If the \fI-canonical\fR option is present, then the body is in -canonical (raw) form and is found by consulting either the \fI-file\fR, -\fI-string\fR, or \fI-part\fR option. -.sp -In addition, both the \fI-param\fR and \fI-header\fR options may occur zero -or more times to specify \fBContent-Type\fR parameters (e.g., -\fIcharset\fR) and header keyword/values (e.g., -\fIContent-Disposition\fR), respectively. -.sp -Also, \fI-encoding\fR, if present, specifies the -\fBContent-Transfer-Encoding\fR when copying the body. -.TP -* -If the \fI-canonical\fR option is not present, then the MIME part -contained in either the \fI-file\fR or the \fI-string\fR option is parsed, -dynamically generating subordinates as appropriate. -.RE -.TP -\fBmime::finalize\fR \fItoken\fR ?-subordinates \fBall\fR | \fBdynamic\fR | \fBnone\fR?\fR -This command destroys the MIME part represented by \fItoken\fR. It -returns an empty string. -.sp -If the \fI-subordinates\fR option is present, it specifies which -subordinates should also be destroyed. The default value is -\fBdynamic\fR, destroying all subordinates which were created by -\fBmime::initialize\fR together with the containing body part. -.TP -\fBmime::getproperty\fR \fItoken\fR ?\fIproperty\fR | -names?\fR -This command returns a string or a list of strings containing the -properties of a MIME part. If the command is invoked with the name of -a specific property, then the corresponding value is returned; -instead, if \fI-names\fR is specified, a list of all properties is -returned; otherwise, a serialized array of properties and values is -returned. -.sp The possible properties are: -.RS -.TP -\fBcontent\fR -The type/subtype describing the content -.TP -\fBencoding\fR -The "Content-Transfer-Encoding" -.TP -\fBparams\fR -A list of "Content-Type" parameters -.TP -\fBparts\fR -A list of tokens for the part's subordinates. This property is -present only if the MIME part has subordinates. -.TP -\fBsize\fR -The approximate size of the content (unencoded) -.RE -.TP -\fBmime::getheader\fR \fItoken\fR ?\fIkey\fR | -names?\fR -This command returns the header of a MIME part, as a list of strings. -.sp -A header consists of zero or more key/value pairs. Each value is a -list containing one or more strings. -.sp -If this command is invoked with the name of a specific \fIkey\fR, then -a list containing the corresponding value(s) is returned; instead, -if -names is specified, a list of all keys is returned; otherwise, a -serialized array of keys and values is returned. Note that when a -key is specified (e.g., "Subject"), the list returned usually -contains exactly one string; however, some keys (e.g., "Received") -often occur more than once in the header, accordingly the list -returned usually contains more than one string. -.TP -\fBmime::setheader\fR \fItoken\fR \fIkey\fR \fIvalue\fR ?-mode \fBwrite\fR | \fBappend\fR | \fBdelete\fR?\fR -This command writes, appends to, or deletes the \fIvalue\fR associated -with a \fIkey\fR in the header. It returns a list of strings -containing the previous value associated with the key. -.sp -The value for \fI-mode\fR is one of: -.RS -.TP -\fBwrite\fR -The \fIkey\fR/\fIvalue\fR is either created or overwritten (the default). -.TP -\fBappend\fR -A new \fIvalue\fR is appended for the \fIkey\fR (creating it as necessary). -.TP -\fBdelete\fR -All values associated with the key are removed (the \fIvalue\fR -parameter is ignored). -.RE -.TP -\fBmime::getbody\fR \fItoken\fR ?-command \fIcallback\fR ?-blocksize \fIoctets\fR??\fR -This command returns a string containing the body of the leaf MIME -part represented by \fItoken\fR in canonical form. -.sp -If the \fI-command\fR option is present, then it is repeatedly -invoked with a fragment of the body as this: -\fBuplevel #0 $callback [list "data" $fragment] \fR -.sp -(The \fI-blocksize\fR option, if present, specifies the maximum size -of each fragment passed to the callback.) -.sp -When the end of the body is reached, the callback is invoked as: -\fBuplevel #0 $callback "end"\fR -.sp -Alternatively, if an error occurs, the callback is invoked as: -\fBuplevel #0 $callback [list "error" reason]\fR -.sp -Regardless, the return value of the final invocation of the callback -is propagated upwards by mime::getbody. -.sp -If the \fI-command\fR option is absent, then the return value of -\fBmime::getbody\fR is a string containing the MIME part's entire -body. -.TP -\fBmime::copymessage\fR \fItoken\fR \fIchannel\fR\fR -This command copies the MIME represented by \fItoken\fR part to the -specified \fIchannel\fR. The command operates synchronously, and uses -fileevent to allow asynchronous operations to proceed -independently. It returns an empty string. -.TP -\fBmime::buildmessage\fR \fItoken\fR\fR -This command returns the MIME part represented by \fItoken\fR as a -string. It is similar to \fBmime::copymessage\fR, only it returns the -data as a return string instead of writing to a channel. -.TP -\fBmime::parseaddress\fR \fIstring\fR\fR -This command takes a string containing one or more 822-style address -specifications and returns a list of serialized arrays, one element -for each address specified in the argument. If the string contains -more than one address they will be separated by commas. -.sp -Each serialized array contains the properties below. Note that one or -more of these properties may be empty. -.RS -.TP -\fBaddress\fR -local@domain -.TP -\fBcomment\fR -822-style comment -.TP -\fBdomain\fR -the domain part (rhs) -.TP -\fBerror\fR -non-empty on a parse error -.TP -\fBgroup\fR -this address begins a group -.TP -\fBfriendly\fR -user-friendly rendering -.TP -\fBlocal\fR -the local part (lhs) -.TP -\fBmemberP\fR -this address belongs to a group -.TP -\fBphrase\fR -the phrase part -.TP -\fBproper\fR -822-style address specification -.TP -\fBroute\fR -822-style route specification (obsolete) -.RE -.TP -\fBmime::parsedatetime\fR (\fIstring\fR | -now) \fIproperty\fR\fR -This command takes a string containing an 822-style date-time -specification and returns the specified property as a serialized array. -.sp -The list of properties and their ranges are: -.RS -.TP -\fBhour\fR -0 .. 23 -.TP -\fBlmonth\fR -January, February, ..., December -.TP -\fBlweekday\fR -Sunday, Monday, ... Saturday -.TP -\fBmday\fR -1 .. 31 -.TP -\fBmin\fR -0 .. 59 -.TP -\fBmon\fR -1 .. 12 -.TP -\fBmonth\fR -Jan, Feb, ..., Dec -.TP -\fBproper\fR -822-style date-time specification -.TP -\fBrclock\fR -elapsed seconds between then and now -.TP -\fBsec\fR -0 .. 59 -.TP -\fBwday\fR -0 .. 6 (Sun .. Mon) -.TP -\fBweekday\fR -Sun, Mon, ..., Sat -.TP -\fByday\fR -1 .. 366 -.TP -\fByear\fR -1900 ... -.TP -\fBzone\fR --720 .. 720 (minutes east of GMT) -.RE -.TP -\fBmime::mapencoding\fR \fIencoding_name\fR\fR -This commansd maps tcl encodings onto the proper names for their MIME -charset type. This is only done for encodings whose charset types -were known. The remaining encodings return "" for now. -.TP -\fBmime::reversemapencoding\fR \fIcharset_type\fR\fR -This command maps MIME charset types onto tcl encoding names. Those -that are unknown return "". -.SH "SEE ALSO" -smtp, pop3, ftp, http -.SH "KEYWORDS" -mail, email, smtp, mime, rfc821, rfc822, internet, net - - DELETED modules/mime/mime.tcl Index: modules/mime/mime.tcl ================================================================== --- modules/mime/mime.tcl +++ /dev/null @@ -1,3585 +0,0 @@ -# mime.tcl - MIME body parts -# -# (c) 1999-2000 Marshall T. Rose -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# Influenced by Borenstein's/Rose's safe-tcl (circa 1993) and Darren New's -# unpublished package of 1999. -# - -# new string features and inline scan are used, requiring 8.3. -package require Tcl 8.3 - -package provide mime 1.3.3 - -if {[catch {package require Trf 2.0}]} { - - # Fall-back to tcl-based procedures of base64 and quoted-printable encoders - # Warning! - # These are a fragile emulations of the more general calling sequence - # that appears to work with this code here. - - package require base64 2.0 - package require md5 1.0 - - # Create these commands in the mime namespace so that they - # won't collide with things at the global namespace level - - namespace eval ::mime { - proc base64 {-mode what -- chunk} { - return [base64::$what $chunk] - } - proc quoted-printable {-mode what -- chunk} { - return [mime::qp_$what $chunk] - } - proc md5 {-- string} { - return [md5::md5 $string] - } - proc unstack {channel} { - # do nothing - return - } - } -} - -# -# state variables: -# -# canonicalP: input is in its canonical form -# content: type/subtype -# params: seralized array of key/value pairs (keys are lower-case) -# encoding: transfer encoding -# version: MIME-version -# header: serialized array of key/value pairs (keys are lower-case) -# lowerL: list of header keys, lower-case -# mixedL: list of header keys, mixed-case -# value: either "file", "parts", or "string" -# -# file: input file -# fd: cached file-descriptor, typically for root -# root: token for top-level part, for (distant) subordinates -# offset: number of octets from beginning of file/string -# count: length in octets of (encoded) content -# -# parts: list of bodies (tokens) -# -# string: input string -# -# cid: last child-id assigned -# - - -namespace eval ::mime { - variable mime - array set mime { uid 0 cid 0 } - -# 822 lexemes - variable addrtokenL [list ";" "," \ - "<" ">" \ - ":" "." \ - "(" ")" \ - "@" "\"" \ - "\[" "\]" \ - "\\"] - variable addrlexemeL [list LX_SEMICOLON LX_COMMA \ - LX_LBRACKET LX_RBRACKET \ - LX_COLON LX_DOT \ - LX_LPAREN LX_RPAREN \ - LX_ATSIGN LX_QUOTE \ - LX_LSQUARE LX_RSQUARE \ - LX_QUOTE] - -# 2045 lexemes - variable typetokenL [list ";" "," \ - "<" ">" \ - ":" "?" \ - "(" ")" \ - "@" "\"" \ - "\[" "\]" \ - "=" "/" \ - "\\"] - variable typelexemeL [list LX_SEMICOLON LX_COMMA \ - LX_LBRACKET LX_RBRACKET \ - LX_COLON LX_QUESTION \ - LX_LPAREN LX_RPAREN \ - LX_ATSIGN LX_QUOTE \ - LX_LSQUARE LX_RSQUARE \ - LX_EQUALS LX_SOLIDUS \ - LX_QUOTE] - - set encList [list \ - ascii US-ASCII \ - big5 Big5 \ - cp1250 "" \ - cp1251 "" \ - cp1252 "" \ - cp1253 "" \ - cp1254 "" \ - cp1255 "" \ - cp1256 "" \ - cp1257 "" \ - cp1258 "" \ - cp437 "" \ - cp737 "" \ - cp775 "" \ - cp850 "" \ - cp852 "" \ - cp855 "" \ - cp857 "" \ - cp860 "" \ - cp861 "" \ - cp862 "" \ - cp863 "" \ - cp864 "" \ - cp865 "" \ - cp866 "" \ - cp869 "" \ - cp874 "" \ - cp932 "" \ - cp936 "" \ - cp949 "" \ - cp950 "" \ - dingbats "" \ - euc-cn EUC-CN \ - euc-jp EUC-JP \ - euc-kr EUC-KR \ - gb12345 GB12345 \ - gb1988 GB1988 \ - gb2312 GB2312 \ - iso2022 ISO-2022 \ - iso2022-jp ISO-2022-JP \ - iso2022-kr ISO-2022-KR \ - iso8859-1 ISO-8859-1 \ - iso8859-2 ISO-8859-2 \ - iso8859-3 ISO-8859-3 \ - iso8859-4 ISO-8859-4 \ - iso8859-5 ISO-8859-5 \ - iso8859-6 ISO-8859-6 \ - iso8859-7 ISO-8859-7 \ - iso8859-8 ISO-8859-8 \ - iso8859-9 ISO-8859-9 \ - iso8859-15 ISO-8859-15 \ - jis0201 "" \ - jis0208 "" \ - jis0212 "" \ - koi8-r KOI8-R \ - ksc5601 "" \ - macCentEuro "" \ - macCroatian "" \ - macCyrillic "" \ - macDingbats "" \ - macGreek "" \ - macIceland "" \ - macJapan "" \ - macRoman "" \ - macRomania "" \ - macThai "" \ - macTurkish "" \ - macUkraine "" \ - shiftjis Shift_JIS \ - symbol "" \ - unicode "" \ - utf-8 ""] - - variable encodings - array set encodings $encList - variable reversemap - foreach {enc mimeType} $encList { - if {$mimeType != ""} { - set reversemap([string tolower $mimeType]) $enc - } - } - - namespace export initialize finalize getproperty \ - getheader setheader \ - getbody \ - copymessage \ - mapencoding \ - reversemapencoding \ - parseaddress \ - parsedatetime \ - uniqueID -} - -# ::mime::initialize -- -# -# Creates a MIME part, and returnes the MIME token for that part. -# -# Arguments: -# args Args can be any one of the following: -# ?-canonical type/subtype -# ?-param {key value}?... -# ?-encoding value? -# ?-header {key value}?... ? -# (-file name | -string value | -parts {token1 ... tokenN}) -# -# If the -canonical option is present, then the body is in -# canonical (raw) form and is found by consulting either the -file, -# -string, or -part option. -# -# In addition, both the -param and -header options may occur zero -# or more times to specify "Content-Type" parameters (e.g., -# "charset") and header keyword/values (e.g., -# "Content-Disposition"), respectively. -# -# Also, -encoding, if present, specifies the -# "Content-Transfer-Encoding" when copying the body. -# -# If the -canonical option is not present, then the MIME part -# contained in either the -file or the -string option is parsed, -# dynamically generating subordinates as appropriate. -# -# Results: -# An initialized mime token. - -proc ::mime::initialize {args} { - global errorCode errorInfo - - variable mime - - set token [namespace current]::[incr mime(uid)] - # FRINK: nocheck - variable $token - upvar 0 $token state - - if {[set code [catch { eval [list mime::initializeaux $token] $args } \ - result]]} { - set ecode $errorCode - set einfo $errorInfo - - catch { mime::finalize $token -subordinates dynamic } - - return -code $code -errorinfo $einfo -errorcode $ecode $result - } - - return $token -} - -# ::mime::initializeaux -- -# -# Configures the MIME token created in mime::initialize based on -# the arguments that mime::initialize supports. -# -# Arguments: -# token The MIME token to configure. -# args Args can be any one of the following: -# ?-canonical type/subtype -# ?-param {key value}?... -# ?-encoding value? -# ?-header {key value}?... ? -# (-file name | -string value | -parts {token1 ... tokenN}) -# -# Results: -# Either configures the mime token, or throws an error. - -proc ::mime::initializeaux {token args} { - global errorCode errorInfo - # FRINK: nocheck - variable $token - upvar 0 $token state - - array set params [set state(params) ""] - set state(encoding) "" - set state(version) "1.0" - - set state(header) "" - set state(lowerL) "" - set state(mixedL) "" - - set state(cid) 0 - - set argc [llength $args] - for {set argx 0} {$argx < $argc} {incr argx} { - set option [lindex $args $argx] - if {[incr argx] >= $argc} { - error "missing argument to $option" - } - set value [lindex $args $argx] - - switch -- $option { - -canonical { - set state(content) [string tolower $value] - } - - -param { - if {[llength $value] != 2} { - error "-param expects a key and a value, not $value" - } - set lower [string tolower [set mixed [lindex $value 0]]] - if {[info exists params($lower)]} { - error "the $mixed parameter may be specified at most once" - } - - set params($lower) [lindex $value 1] - set state(params) [array get params] - } - - -encoding { - switch -- [set state(encoding) [string tolower $value]] { - 7bit - 8bit - binary - quoted-printable - base64 { - } - - default { - error "unknown value for -encoding $state(encoding)" - } - } - } - - -header { - if {[llength $value] != 2} { - error "-header expects a key and a value, not $value" - } - set lower [string tolower [set mixed [lindex $value 0]]] - if {![string compare $lower content-type]} { - error "use -canonical instead of -header $value" - } - if {![string compare $lower content-transfer-encoding]} { - error "use -encoding instead of -header $value" - } - if {(![string compare $lower content-md5]) \ - || (![string compare $lower mime-version])} { - error "don't go there..." - } - if {[lsearch -exact $state(lowerL) $lower] < 0} { - lappend state(lowerL) $lower - lappend state(mixedL) $mixed - } - - array set header $state(header) - lappend header($lower) [lindex $value 1] - set state(header) [array get header] - } - - -file { - set state(file) $value - } - - -parts { - set state(parts) $value - } - - -string { - set state(string) $value - - set state(lines) [split $value "\n"] - set state(lines.count) [llength $state(lines)] - set state(lines.current) 0 - } - - -root { - # the following are internal options - - set state(root) $value - } - - -offset { - set state(offset) $value - } - - -count { - set state(count) $value - } - - -lineslist { - set state(lines) $value - set state(lines.count) [llength $state(lines)] - set state(lines.current) 0 - #state(string) is needed, but will be built when required - set state(string) "" - } - - default { - error "unknown option $option" - } - } - } - - #We only want one of -file, -parts or -string: - set valueN 0 - foreach value [list file parts string] { - if {[info exists state($value)]} { - set state(value) $value - incr valueN - } - } - if {$valueN != 1 && ![info exists state(lines)]} { - error "specify exactly one of -file, -parts, or -string" - } - - if {[set state(canonicalP) [info exists state(content)]]} { - switch -- $state(value) { - file { - set state(offset) 0 - } - - parts { - switch -glob -- $state(content) { - text/* - - - image/* - - - audio/* - - - video/* { - error "-canonical $state(content) and -parts do not mix" - } - - default { - if {[string compare $state(encoding) ""]} { - error "-encoding and -parts do not mix" - } - } - } - } - default {# Go ahead} - } - - if {[lsearch -exact $state(lowerL) content-id] < 0} { - lappend state(lowerL) content-id - lappend state(mixedL) Content-ID - - array set header $state(header) - lappend header(content-id) [uniqueID] - set state(header) [array get header] - } - - set state(version) 1.0 - - return - } - - if {[string compare $state(params) ""]} { - error "-param requires -canonical" - } - if {[string compare $state(encoding) ""]} { - error "-encoding requires -canonical" - } - if {[string compare $state(header) ""]} { - error "-header requires -canonical" - } - if {[info exists state(parts)]} { - error "-parts requires -canonical" - } - - if {[set fileP [info exists state(file)]]} { - if {[set openP [info exists state(root)]]} { - # FRINK: nocheck - variable $state(root) - upvar 0 $state(root) root - - set state(fd) $root(fd) - } else { - set state(root) $token - set state(fd) [open $state(file) { RDONLY }] - set state(offset) 0 - seek $state(fd) 0 end - set state(count) [tell $state(fd)] - - fconfigure $state(fd) -translation binary - } - } - - set code [catch { mime::parsepart $token } result] - set ecode $errorCode - set einfo $errorInfo - - if {$fileP} { - if {!$openP} { - unset state(root) - catch { close $state(fd) } - } - unset state(fd) - } - - return -code $code -errorinfo $einfo -errorcode $ecode $result -} - -# ::mime::parsepart -- -# -# Parses the MIME headers and attempts to break up the message -# into its various parts, creating a MIME token for each part. -# -# Arguments: -# token The MIME token to parse. -# -# Results: -# Throws an error if it has problems parsing the MIME token, -# otherwise it just sets up the appropriate variables. - -proc ::mime::parsepart {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - if {[set fileP [info exists state(file)]]} { - seek $state(fd) [set pos $state(offset)] start - set last [expr {$state(offset)+$state(count)-1}] - } else { - set string $state(string) - } - - set vline "" - while {1} { - set blankP 0 - if {$fileP} { - if {($pos > $last) || ([set x [gets $state(fd) line]] <= 0)} { - set blankP 1 - } else { - incr pos [expr {$x+1}] - } - } else { - - if { $state(lines.current) >= $state(lines.count) } { - set blankP 1 - set line "" - } else { - set line [lindex $state(lines) $state(lines.current)] - incr state(lines.current) - set x [string length $line] - if { $x == 0 } { set blankP 1 } - } - - } - - if {(!$blankP) && ([string last "\r" $line] == [expr {$x-1}])} { - - set line [string range $line 0 [expr {$x-2}]] - if {$x == 1} { - set blankP 1 - } - } - - if {(!$blankP) \ - && (([string first " " $line] == 0) \ - || ([string first "\t" $line] == 0))} { - append vline "\n" $line - continue - } - - if {![string compare $vline ""]} { - if {$blankP} { - break - } - - set vline $line - continue - } - - if {([set x [string first ":" $vline]] <= 0) \ - || (![string compare \ - [set mixed \ - [string trimright \ - [string range \ - $vline 0 [expr {$x-1}]]]] \ - ""])} { - error "improper line in header: $vline" - } - set value [string trim [string range $vline [expr {$x+1}] end]] - switch -- [set lower [string tolower $mixed]] { - content-type { - if {[info exists state(content)]} { - error "multiple Content-Type fields starting with $vline" - } - - if {![catch { set x [parsetype $token $value] }]} { - set state(content) [lindex $x 0] - set state(params) [lindex $x 1] - } - } - - content-md5 { - } - - content-transfer-encoding { - if {([string compare $state(encoding) ""]) \ - && ([string compare $state(encoding) \ - [string tolower $value]])} { - error "multiple Content-Transfer-Encoding fields starting with $vline" - } - - set state(encoding) [string tolower $value] - } - - mime-version { - set state(version) $value - } - - default { - if {[lsearch -exact $state(lowerL) $lower] < 0} { - lappend state(lowerL) $lower - lappend state(mixedL) $mixed - } - - array set header $state(header) - lappend header($lower) $value - set state(header) [array get header] - } - } - - if {$blankP} { - break - } - set vline $line - } - - if {![info exists state(content)]} { - set state(content) text/plain - set state(params) [list charset us-ascii] - } - - if {![string match multipart/* $state(content)]} { - if {$fileP} { - set x [tell $state(fd)] - incr state(count) [expr {$state(offset)-$x}] - set state(offset) $x - } else { - # rebuild string, this is cheap and needed by other functions - set state(string) [join [lrange $state(lines) \ - $state(lines.current) end] "\n"] - } - - if {[string match message/* $state(content)]} { - # FRINK: nocheck - variable [set child $token-[incr state(cid)]] - - set state(value) parts - set state(parts) $child - if {$fileP} { - mime::initializeaux $child \ - -file $state(file) -root $state(root) \ - -offset $state(offset) -count $state(count) - } else { - mime::initializeaux $child \ - -lineslist [lrange $state(lines) \ - $state(lines.current) end] - } - } - - return - } - - set state(value) parts - - set boundary "" - foreach {k v} $state(params) { - if {![string compare $k boundary]} { - set boundary $v - break - } - } - if {![string compare $boundary ""]} { - error "boundary parameter is missing in $state(content)" - } - if {![string compare [string trim $boundary] ""]} { - error "boundary parameter is empty in $state(content)" - } - - if {$fileP} { - set pos [tell $state(fd)] - } - - set inP 0 - set moreP 1 - while {$moreP} { - if {$fileP} { - if {$pos > $last} { - # error "termination string missing in $state(content)" - set line "--$boundary--" - } else { - if {[set x [gets $state(fd) line]] < 0} { - error "end-of-file encountered while parsing $state(content)" - } - } - incr pos [expr {$x+1}] - } else { - - if { $state(lines.current) >= $state(lines.count) } { - error "end-of-string encountered while parsing $state(content)" - } else { - set line [lindex $state(lines) $state(lines.current)] - incr state(lines.current) - set x [string length $line] - } - - set x [string length $line] - } - if {[string last "\r" $line] == [expr {$x-1}]} { - set line [string range $line 0 [expr {$x-2}]] - } - - if {[string first "--$boundary" $line] != 0} { - if {$inP && !$fileP} { - lappend start $line - } - - continue - } - - if {!$inP} { - if {![string compare $line "--$boundary"]} { - set inP 1 - if {$fileP} { - set start $pos - } else { - set start [list] - } - } - - continue - } - - if {([set moreP [string compare $line "--$boundary--"]]) \ - && ([string compare $line "--$boundary"])} { - if {$inP && !$fileP} { - lappend start $line - } - continue - } - # FRINK: nocheck - variable [set child $token-[incr state(cid)]] - - lappend state(parts) $child - - if {$fileP} { - if {[set count [expr {$pos-($start+$x+3)}]] < 0} { - set count 0 - } - - mime::initializeaux $child \ - -file $state(file) -root $state(root) \ - -offset $start -count $count - - seek $state(fd) [set start $pos] start - } else { - mime::initializeaux $child -lineslist $start - set start "" - } - } -} - -# ::mime::parsetype -- -# -# Parses the string passed in and identifies the content-type and -# params strings. -# -# Arguments: -# token The MIME token to parse. -# string The content-type string that should be parsed. -# -# Results: -# Returns the content and params for the string as a two element -# tcl list. - -proc ::mime::parsetype {token string} { - global errorCode errorInfo - # FRINK: nocheck - variable $token - upvar 0 $token state - - variable typetokenL - variable typelexemeL - - set state(input) $string - set state(buffer) "" - set state(lastC) LX_END - set state(comment) "" - set state(tokenL) $typetokenL - set state(lexemeL) $typelexemeL - - set code [catch { mime::parsetypeaux $token $string } result] - set ecode $errorCode - set einfo $errorInfo - - unset state(input) \ - state(buffer) \ - state(lastC) \ - state(comment) \ - state(tokenL) \ - state(lexemeL) - - return -code $code -errorinfo $einfo -errorcode $ecode $result -} - -# ::mime::parsetypeaux -- -# -# A helper function for mime::parsetype. Parses the specified -# string looking for the content type and params. -# -# Arguments: -# token The MIME token to parse. -# string The content-type string that should be parsed. -# -# Results: -# Returns the content and params for the string as a two element -# tcl list. - -proc ::mime::parsetypeaux {token string} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - if {[string compare [parselexeme $token] LX_ATOM]} { - error [format "expecting type (found %s)" $state(buffer)] - } - set type [string tolower $state(buffer)] - - switch -- [parselexeme $token] { - LX_SOLIDUS { - } - - LX_END { - if {[string compare $type message]} { - error "expecting type/subtype (found $type)" - } - - return [list message/rfc822 ""] - } - - default { - error [format "expecting \"/\" (found %s)" $state(buffer)] - } - } - - if {[string compare [parselexeme $token] LX_ATOM]} { - error [format "expecting subtype (found %s)" $state(buffer)] - } - append type [string tolower /$state(buffer)] - - array set params "" - while {1} { - switch -- [parselexeme $token] { - LX_END { - return [list $type [array get params]] - } - - LX_SEMICOLON { - } - - default { - error [format "expecting \";\" (found %s)" $state(buffer)] - } - } - - switch -- [parselexeme $token] { - LX_END { - return [list $type [array get params]] - } - - LX_ATOM { - } - - default { - error [format "expecting attribute (found %s)" $state(buffer)] - } - } - - set attribute [string tolower $state(buffer)] - - if {[string compare [parselexeme $token] LX_EQUALS]} { - error [format "expecting \"=\" (found %s)" $state(buffer)] - } - - switch -- [parselexeme $token] { - LX_ATOM { - } - - LX_QSTRING { - set state(buffer) \ - [string range $state(buffer) 1 \ - [expr {[string length $state(buffer)]-2}]] - } - - default { - error [format "expecting value (found %s)" $state(buffer)] - } - } - set params($attribute) $state(buffer) - } -} - -# ::mime::finalize -- -# -# mime::finalize destroys a MIME part. -# -# If the -subordinates option is present, it specifies which -# subordinates should also be destroyed. The default value is -# "dynamic". -# -# Arguments: -# token The MIME token to parse. -# args Args can be optionally be of the following form: -# ?-subordinates "all" | "dynamic" | "none"? -# -# Results: -# Returns an empty string. - -proc ::mime::finalize {token args} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - array set options [list -subordinates dynamic] - array set options $args - - switch -- $options(-subordinates) { - all { - if {![string compare $state(value) parts]} { - foreach part $state(parts) { - eval [list mime::finalize $part] $args - } - } - } - - dynamic { - for {set cid $state(cid)} {$cid > 0} {incr cid -1} { - eval [list mime::finalize $token-$cid] $args - } - } - - none { - } - - default { - error "unknown value for -subordinates $options(-subordinates)" - } - } - - foreach name [array names state] { - unset state($name) - } - # FRINK: nocheck - unset $token -} - -# ::mime::getproperty -- -# -# mime::getproperty returns the properties of a MIME part. -# -# The properties are: -# -# property value -# ======== ===== -# content the type/subtype describing the content -# encoding the "Content-Transfer-Encoding" -# params a list of "Content-Type" parameters -# parts a list of tokens for the part's subordinates -# size the approximate size of the content (unencoded) -# -# The "parts" property is present only if the MIME part has -# subordinates. -# -# If mime::getproperty is invoked with the name of a specific -# property, then the corresponding value is returned; instead, if -# -names is specified, a list of all properties is returned; -# otherwise, a serialized array of properties and values is returned. -# -# Arguments: -# token The MIME token to parse. -# property One of 'content', 'encoding', 'params', 'parts', and -# 'size'. Defaults to returning a serialized array of -# properties and values. -# -# Results: -# Returns the properties of a MIME part - -proc ::mime::getproperty {token {property ""}} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - switch -- $property { - "" { - array set properties [list content $state(content) \ - encoding $state(encoding) \ - params $state(params) \ - size [getsize $token]] - if {[info exists state(parts)]} { - set properties(parts) $state(parts) - } - - return [array get properties] - } - - -names { - set names [list content encoding params] - if {[info exists state(parts)]} { - lappend names parts - } - - return $names - } - - content - - - encoding - - - params { - return $state($property) - } - - parts { - if {![info exists state(parts)]} { - error "MIME part is a leaf" - } - - return $state(parts) - } - - size { - return [getsize $token] - } - - default { - error "unknown property $property" - } - } -} - -# ::mime::getsize -- -# -# Determine the size (in bytes) of a MIME part/token -# -# Arguments: -# token The MIME token to parse. -# -# Results: -# Returns the size in bytes of the MIME token. - -proc ::mime::getsize {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - switch -- $state(value)/$state(canonicalP) { - file/0 { - set size $state(count) - } - - file/1 { - return [file size $state(file)] - } - - parts/0 - - - parts/1 { - set size 0 - foreach part $state(parts) { - incr size [getsize $part] - } - - return $size - } - - string/0 { - set size [string length $state(string)] - } - - string/1 { - return [string length $state(string)] - } - default { - error "Unknown combination \"$state(value)/$state(canonicalP)\"" - } - } - - if {![string compare $state(encoding) base64]} { - set size [expr {($size*3+2)/4}] - } - - return $size -} - -# ::mime::getheader -- -# -# mime::getheader returns the header of a MIME part. -# -# A header consists of zero or more key/value pairs. Each value is a -# list containing one or more strings. -# -# If mime::getheader is invoked with the name of a specific key, then -# a list containing the corresponding value(s) is returned; instead, -# if -names is specified, a list of all keys is returned; otherwise, a -# serialized array of keys and values is returned. Note that when a -# key is specified (e.g., "Subject"), the list returned usually -# contains exactly one string; however, some keys (e.g., "Received") -# often occur more than once in the header, accordingly the list -# returned usually contains more than one string. -# -# Arguments: -# token The MIME token to parse. -# key Either a key or '-names'. If it is '-names' a list -# of all keys is returned. -# -# Results: -# Returns the header of a MIME part. - -proc ::mime::getheader {token {key ""}} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - array set header $state(header) - switch -- $key { - "" { - set result "" - foreach lower $state(lowerL) mixed $state(mixedL) { - lappend result $mixed $header($lower) - } - return $result - } - - -names { - return $state(mixedL) - } - - default { - set lower [string tolower [set mixed $key]] - - if {![info exists header($lower)]} { - error "key $mixed not in header" - } - return $header($lower) - } - } -} - -# ::mime::setheader -- -# -# mime::setheader writes, appends to, or deletes the value associated -# with a key in the header. -# -# The value for -mode is one of: -# -# write: the key/value is either created or overwritten (the -# default); -# -# append: a new value is appended for the key (creating it as -# necessary); or, -# -# delete: all values associated with the key are removed (the -# "value" parameter is ignored). -# -# Regardless, mime::setheader returns the previous value associated -# with the key. -# -# Arguments: -# token The MIME token to parse. -# key The name of the key whose value should be set. -# value The value for the header key to be set to. -# args An optional argument of the form: -# ?-mode "write" | "append" | "delete"? -# -# Results: -# Returns previous value associated with the specified key. - -proc ::mime::setheader {token key value args} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - array set options [list -mode write] - array set options $args - - switch -- [set lower [string tolower $key]] { - content-md5 - - - content-type - - - content-transfer-encoding - - - mime-version { - error "key $key may not be set" - } - default {# Skip key} - } - - array set header $state(header) - if {[set x [lsearch -exact $state(lowerL) $lower]] < 0} { - if {![string compare $options(-mode) delete]} { - error "key $key not in header" - } - - lappend state(lowerL) $lower - lappend state(mixedL) $key - - set result "" - } else { - set result $header($lower) - } - switch -- $options(-mode) { - append { - lappend header($lower) $value - } - - delete { - unset header($lower) - set state(lowerL) [lreplace $state(lowerL) $x $x] - set state(mixedL) [lreplace $state(mixedL) $x $x] - } - - write { - set header($lower) [list $value] - } - - default { - error "unknown value for -mode $options(-mode)" - } - } - - set state(header) [array get header] - - return $result -} - -# ::mime::getbody -- -# -# mime::getbody returns the body of a leaf MIME part in canonical form. -# -# If the -command option is present, then it is repeatedly invoked -# with a fragment of the body as this: -# -# uplevel #0 $callback [list "data" $fragment] -# -# (The -blocksize option, if present, specifies the maximum size of -# each fragment passed to the callback.) -# When the end of the body is reached, the callback is invoked as: -# -# uplevel #0 $callback "end" -# -# Alternatively, if an error occurs, the callback is invoked as: -# -# uplevel #0 $callback [list "error" reason] -# -# Regardless, the return value of the final invocation of the callback -# is propagated upwards by mime::getbody. -# -# If the -command option is absent, then the return value of -# mime::getbody is a string containing the MIME part's entire body. -# -# Arguments: -# token The MIME token to parse. -# args Optional arguments of the form: -# ?-command callback ?-blocksize octets? ? -# -# Results: -# Returns a string containing the MIME part's entire body, or -# if '-command' is specified, the return value of the command -# is returned. - -proc ::mime::getbody {token args} { - global errorCode errorInfo - # FRINK: nocheck - variable $token - upvar 0 $token state - - array set options [list -command [list mime::getbodyaux $token] \ - -blocksize 4096] - array set options $args - if {$options(-blocksize) < 1} { - error "-blocksize expects a positive integer, not $options(-blocksize)" - } - - set code 0 - set ecode "" - set einfo "" - - switch -- $state(value)/$state(canonicalP) { - file/0 { - set fd [open $state(file) { RDONLY }] - - set code [catch { - fconfigure $fd -translation binary - seek $fd [set pos $state(offset)] start - set last [expr {$state(offset)+$state(count)-1}] - - set fragment "" - while {$pos <= $last} { - if {[set cc [expr {($last-$pos)+1}]] \ - > $options(-blocksize)} { - set cc $options(-blocksize) - } - incr pos [set len \ - [string length [set chunk [read $fd $cc]]]] - switch -exact -- $state(encoding) { - base64 - - - quoted-printable { - if {([set x [string last "\n" $chunk]] > 0) \ - && ($x+1 != $len)} { - set chunk [string range $chunk 0 $x] - seek $fd [incr pos [expr {($x+1)-$len}]] start - } - set chunk [$state(encoding) -mode decode \ - -- $chunk] - } - 7bit - 8bit - binary - "" { - # Bugfix for [#477088] - # Go ahead, leave chunk alone - } - default { - error "Can't handle content encoding \"$state(encoding)\"" - } - } - append fragment $chunk - - set cc [expr {$options(-blocksize)-1}] - while {[string length $fragment] > $options(-blocksize)} { - uplevel #0 $options(-command) \ - [list data \ - [string range $fragment 0 $cc]] - - set fragment [string range \ - $fragment $options(-blocksize) \ - end] - } - } - if {[string length $fragment] > 0} { - uplevel #0 $options(-command) [list data $fragment] - } - } result] - set ecode $errorCode - set einfo $errorInfo - - catch { close $fd } - } - - file/1 { - set fd [open $state(file) { RDONLY }] - - set code [catch { - fconfigure $fd -translation binary - - while {[string length \ - [set fragment \ - [read $fd $options(-blocksize)]]] > 0} { - uplevel #0 $options(-command) [list data $fragment] - } - } result] - set ecode $errorCode - set einfo $errorInfo - - catch { close $fd } - } - - parts/0 - - - parts/1 { - error "MIME part isn't a leaf" - } - - string/0 - - - string/1 { - switch -- $state(encoding)/$state(canonicalP) { - base64/0 - - - quoted-printable/0 { - set fragment [$state(encoding) -mode decode \ - -- $state(string)] - } - - default { - # Not a bugfix for [#477088], but clarification - # This handles no-encoding, 7bit, 8bit, and binary. - set fragment $state(string) - } - } - - set code [catch { - set cc [expr {$options(-blocksize)-1}] - while {[string length $fragment] > $options(-blocksize)} { - uplevel #0 $options(-command) \ - [list data [string range $fragment 0 $cc]] - - set fragment [string range $fragment \ - $options(-blocksize) end] - } - if {[string length $fragment] > 0} { - uplevel #0 $options(-command) [list data $fragment] - } - } result] - set ecode $errorCode - set einfo $errorInfo - } - default { - error "Unknown combination \"$state(value)/$state(canonicalP)\"" - } - } - - set code [catch { - if {$code} { - uplevel #0 $options(-command) [list error $result] - } else { - uplevel #0 $options(-command) [list end] - } - } result] - set ecode $errorCode - set einfo $errorInfo - - return -code $code -errorinfo $einfo -errorcode $ecode $result -} - -# ::mime::getbodyaux -- -# -# Builds up the body of the message, fragment by fragment. When -# the entire message has been retrieved, it is returned. -# -# Arguments: -# token The MIME token to parse. -# reason One of 'data', 'end', or 'error'. -# fragment The section of data data fragment to extract a -# string from. -# -# Results: -# Returns nothing, except when called with the 'end' argument -# in which case it returns a string that contains all of the -# data that 'getbodyaux' has been called with. Will throw an -# error if it is called with the reason of 'error'. - -proc ::mime::getbodyaux {token reason {fragment ""}} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - switch -- $reason { - data { - append state(getbody) $fragment - return "" - } - - end { - if {[info exists state(getbody)]} { - set result $state(getbody) - unset state(getbody) - } else { - set result "" - } - - return $result - } - - error { - catch { unset state(getbody) } - error $reason - } - - default { - error "Unknown reason \"$reason\"" - } - } -} - -# ::mime::copymessage -- -# -# mime::copymessage copies the MIME part to the specified channel. -# -# mime::copymessage operates synchronously, and uses fileevent to -# allow asynchronous operations to proceed independently. -# -# Arguments: -# token The MIME token to parse. -# channel The channel to copy the message to. -# -# Results: -# Returns nothing unless an error is thrown while the message -# is being written to the channel. - -proc ::mime::copymessage {token channel} { - global errorCode errorInfo - # FRINK: nocheck - variable $token - upvar 0 $token state - - set openP [info exists state(fd)] - - set code [catch { mime::copymessageaux $token $channel } result] - set ecode $errorCode - set einfo $errorInfo - - if {(!$openP) && ([info exists state(fd)])} { - if {![info exists state(root)]} { - catch { close $state(fd) } - } - unset state(fd) - } - - return -code $code -errorinfo $einfo -errorcode $ecode $result -} - -# ::mime::copymessageaux -- -# -# mime::copymessageaux copies the MIME part to the specified channel. -# -# Arguments: -# token The MIME token to parse. -# channel The channel to copy the message to. -# -# Results: -# Returns nothing unless an error is thrown while the message -# is being written to the channel. - -proc ::mime::copymessageaux {token channel} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - array set header $state(header) - - if {[string compare $state(version) ""]} { - puts $channel "MIME-Version: $state(version)" - } - foreach lower $state(lowerL) mixed $state(mixedL) { - foreach value $header($lower) { - puts $channel "$mixed: $value" - } - } - if {(!$state(canonicalP)) \ - && ([string compare [set encoding $state(encoding)] ""])} { - puts $channel "Content-Transfer-Encoding: $encoding" - } - - puts -nonewline $channel "Content-Type: $state(content)" - set boundary "" - foreach {k v} $state(params) { - if {![string compare $k boundary]} { - set boundary $v - } - - puts -nonewline $channel ";\n $k=\"$v\"" - } - - set converter "" - set encoding "" - if {[string compare $state(value) parts]} { - puts $channel "" - - if {$state(canonicalP)} { - if {![string compare [set encoding $state(encoding)] ""]} { - set encoding [encoding $token] - } - if {[string compare $encoding ""]} { - puts $channel "Content-Transfer-Encoding: $encoding" - } - switch -- $encoding { - base64 - - - quoted-printable { - set converter $encoding - } - 7bit - 8bit - binary - "" { - # Bugfix for [#477088], also [#539952] - # Go ahead - } - default { - error "Can't handle content encoding \"$encoding\"" - } - } - } - } elseif {([string match multipart/* $state(content)]) \ - && (![string compare $boundary ""])} { -# we're doing everything in one pass... - set key [clock seconds]$token[info hostname][array get state] - set seqno 8 - while {[incr seqno -1] >= 0} { - set key [md5 -- $key] - } - set boundary "----- =_[string trim [base64 -mode encode -- $key]]" - - puts $channel ";\n boundary=\"$boundary\"" - } else { - puts $channel "" - } - - if {[info exists state(error)]} { - unset state(error) - } - - switch -- $state(value) { - file { - set closeP 1 - if {[info exists state(root)]} { - # FRINK: nocheck - variable $state(root) - upvar 0 $state(root) root - - if {[info exists root(fd)]} { - set fd $root(fd) - set closeP 0 - } else { - set fd [set state(fd) \ - [open $state(file) { RDONLY }]] - } - set size $state(count) - } else { - set fd [set state(fd) [open $state(file) { RDONLY }]] - # read until eof - set size -1 - } - seek $fd $state(offset) start - if {$closeP} { - fconfigure $fd -translation binary - } - - puts $channel "" - - while {($size != 0) && (![eof $fd])} { - if {$size < 0 || $size > 32766} { - set X [read $fd 32766] - } else { - set X [read $fd $size] - } - if {$size > 0} { - set size [expr {$size - [string length $X]}] - } - if {[string compare $converter ""]} { - puts $channel [$converter -mode encode -- $X] - } else { - puts $channel $X - } - } - - if {$closeP} { - catch { close $state(fd) } - unset state(fd) - } - } - - parts { - if {(![info exists state(root)]) \ - && ([info exists state(file)])} { - set state(fd) [open $state(file) { RDONLY }] - fconfigure $state(fd) -translation binary - } - - switch -glob -- $state(content) { - message/* { - puts $channel "" - foreach part $state(parts) { - mime::copymessage $part $channel - break - } - } - - default { - foreach part $state(parts) { - puts $channel "\n--$boundary" - mime::copymessage $part $channel - } - puts $channel "\n--$boundary--" - } - } - - if {[info exists state(fd)]} { - catch { close $state(fd) } - unset state(fd) - } - } - - string { - if {[catch { fconfigure $channel -buffersize } blocksize]} { - set blocksize 4096 - } elseif {$blocksize < 512} { - set blocksize 512 - } - set blocksize [expr {($blocksize/4)*3}] - - puts $channel "" - - if {[string compare $converter ""]} { - puts $channel [$converter -mode encode -- $state(string)] - } else { - puts $channel $state(string) - } - } - default { - error "Unknown value \"$state(value)\"" - } - } - - flush $channel - - if {[string compare $converter ""]} { - unstack $channel - } - if {[info exists state(error)]} { - error $state(error) - } -} - -# ::mime::buildmessage -- -# -# The following is a clone of the copymessage code to build up the -# result in memory, and, unfortunately, without using a memory channel. -# I considered parameterizing the "puts" calls in copy message, but -# the need for this procedure may go away, so I'm living with it for -# the moment. -# -# Arguments: -# token The MIME token to parse. -# -# Results: -# Returns the message that has been built up in memory. - -proc ::mime::buildmessage {token} { - global errorCode errorInfo - # FRINK: nocheck - variable $token - upvar 0 $token state - - set openP [info exists state(fd)] - - set code [catch { mime::buildmessageaux $token } result] - set ecode $errorCode - set einfo $errorInfo - - if {(!$openP) && ([info exists state(fd)])} { - if {![info exists state(root)]} { - catch { close $state(fd) } - } - unset state(fd) - } - - return -code $code -errorinfo $einfo -errorcode $ecode $result -} - -# ::mime::buildmessageaux -- -# -# The following is a clone of the copymessageaux code to build up the -# result in memory, and, unfortunately, without using a memory channel. -# I considered parameterizing the "puts" calls in copy message, but -# the need for this procedure may go away, so I'm living with it for -# the moment. -# -# Arguments: -# token The MIME token to parse. -# -# Results: -# Returns the message that has been built up in memory. - -proc ::mime::buildmessageaux {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - array set header $state(header) - - set result "" - if {[string compare $state(version) ""]} { - append result "MIME-Version: $state(version)\n" - } - foreach lower $state(lowerL) mixed $state(mixedL) { - foreach value $header($lower) { - append result "$mixed: $value\n" - } - } - if {(!$state(canonicalP)) \ - && ([string compare [set encoding $state(encoding)] ""])} { - append result "Content-Transfer-Encoding: $encoding\n" - } - - append result "Content-Type: $state(content)" - set boundary "" - foreach {k v} $state(params) { - if {![string compare $k boundary]} { - set boundary $v - } - - append result ";\n $k=\"$v\"" - } - - set converter "" - set encoding "" - if {[string compare $state(value) parts]} { - append result \n - - if {$state(canonicalP)} { - if {![string compare [set encoding $state(encoding)] ""]} { - set encoding [encoding $token] - } - if {[string compare $encoding ""]} { - append result "Content-Transfer-Encoding: $encoding\n" - } - switch -- $encoding { - base64 - - - quoted-printable { - set converter $encoding - } - 7bit - 8bit - binary - "" { - # Bugfix for [#477088] - # Go ahead - } - default { - error "Can't handle content encoding \"$encoding\"" - } - } - } - } elseif {([string match multipart/* $state(content)]) \ - && (![string compare $boundary ""])} { -# we're doing everything in one pass... - set key [clock seconds]$token[info hostname][array get state] - set seqno 8 - while {[incr seqno -1] >= 0} { - set key [md5 -- $key] - } - set boundary "----- =_[string trim [base64 -mode encode -- $key]]" - - append result ";\n boundary=\"$boundary\"\n" - } else { - append result "\n" - } - - if {[info exists state(error)]} { - unset state(error) - } - - switch -- $state(value) { - file { - set closeP 1 - if {[info exists state(root)]} { - # FRINK: nocheck - variable $state(root) - upvar 0 $state(root) root - - if {[info exists root(fd)]} { - set fd $root(fd) - set closeP 0 - } else { - set fd [set state(fd) \ - [open $state(file) { RDONLY }]] - } - set size $state(count) - } else { - set fd [set state(fd) [open $state(file) { RDONLY }]] - set size -1 ;# Read until EOF - } - seek $fd $state(offset) start - if {$closeP} { - fconfigure $fd -translation binary - } - - append result "\n" - - while {($size != 0) && (![eof $fd])} { - if {$size < 0 || $size > 32766} { - set X [read $fd 32766] - } else { - set X [read $fd $size] - } - if {$size > 0} { - set size [expr {$size - [string length $X]}] - } - if {[string compare $converter ""]} { - append result "[$converter -mode encode -- $X]\n" - } else { - append result "$X\n" - } - } - - if {$closeP} { - catch { close $state(fd) } - unset state(fd) - } - } - - parts { - if {(![info exists state(root)]) \ - && ([info exists state(file)])} { - set state(fd) [open $state(file) { RDONLY }] - fconfigure $state(fd) -translation binary - } - - switch -glob -- $state(content) { - message/* { - append result "\n" - foreach part $state(parts) { - append result [buildmessage $part] - break - } - } - - default { - foreach part $state(parts) { - append result "\n--$boundary\n" - append result [buildmessage $part] - } - append result "\n--$boundary--\n" - } - } - - if {[info exists state(fd)]} { - catch { close $state(fd) } - unset state(fd) - } - } - - string { - - append result "\n" - - if {[string compare $converter ""]} { - append result "[$converter -mode encode -- $state(string)]\n" - } else { - append result "$state(string)\n" - } - } - default { - error "Unknown value \"$state(value)\"" - } - } - - if {[info exists state(error)]} { - error $state(error) - } - return $result -} - -# ::mime::encoding -- -# -# Determines how a token is encoded. -# -# Arguments: -# token The MIME token to parse. -# -# Results: -# Returns the encoding of the message (the null string, base64, -# or quoted-printable). - -proc ::mime::encoding {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - switch -glob -- $state(content) { - audio/* - - - image/* - - - video/* { - return base64 - } - - message/* - - - multipart/* { - return "" - } - default {# Skip} - } - - set asciiP 1 - set lineP 1 - switch -- $state(value) { - file { - set fd [open $state(file) { RDONLY }] - fconfigure $fd -translation binary - - while {[gets $fd line] >= 0} { - if {$asciiP} { - set asciiP [encodingasciiP $line] - } - if {$lineP} { - set lineP [encodinglineP $line] - } - if {(!$asciiP) && (!$lineP)} { - break - } - } - - catch { close $fd } - } - - parts { - return "" - } - - string { - foreach line [split $state(string) "\n"] { - if {$asciiP} { - set asciiP [encodingasciiP $line] - } - if {$lineP} { - set lineP [encodinglineP $line] - } - if {(!$asciiP) && (!$lineP)} { - break - } - } - } - default { - error "Unknown value \"$state(value)\"" - } - } - - switch -glob -- $state(content) { - text/* { - if {!$asciiP} { - foreach {k v} $state(params) { - if {![string compare $k charset]} { - set v [string tolower $v] - if {([string compare $v us-ascii]) \ - && (![string match {iso-8859-[1-8]} $v])} { - return base64 - } - - break - } - } - } - - if {!$lineP} { - return quoted-printable - } - } - - - default { - if {(!$asciiP) || (!$lineP)} { - return base64 - } - } - } - - return "" -} - -# ::mime::encodingasciiP -- -# -# Checks if a string is a pure ascii string, or if it has a non-standard -# form. -# -# Arguments: -# line The line to check. -# -# Results: -# Returns 1 if \r only occurs at the end of lines, and if all -# characters in the line are between the ASCII codes of 32 and 126. - -proc ::mime::encodingasciiP {line} { - foreach c [split $line ""] { - switch -- $c { - " " - "\t" - "\r" - "\n" { - } - - default { - binary scan $c c c - if {($c < 32) || ($c > 126)} { - return 0 - } - } - } - } - if {([set r [string first "\r" $line]] < 0) \ - || ($r == [expr {[string length $line]-1}])} { - return 1 - } - - return 0 -} - -# ::mime::encodinglineP -- -# -# Checks if a string is a line is valid to be processed. -# -# Arguments: -# line The line to check. -# -# Results: -# Returns 1 the line is less than 76 characters long, the line -# contains more characters than just whitespace, the line does -# not start with a '.', and the line does not start with 'From '. - -proc ::mime::encodinglineP {line} { - if {([string length $line] > 76) \ - || ([string compare $line [string trimright $line]]) \ - || ([string first . $line] == 0) \ - || ([string first "From " $line] == 0)} { - return 0 - } - - return 1 -} - -# ::mime::fcopy -- -# -# Appears to be unused. -# -# Arguments: -# -# Results: -# - -proc ::mime::fcopy {token count {error ""}} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - if {[string compare $error ""]} { - set state(error) $error - } - set state(doneP) 1 -} - -# ::mime::scopy -- -# -# Copy a portion of the contents of a mime token to a channel. -# -# Arguments: -# token The token containing the data to copy. -# channel The channel to write the data to. -# offset The location in the string to start copying -# from. -# len The amount of data to write. -# blocksize The block size for the write operation. -# -# Results: -# The specified portion of the string in the mime token is -# copied to the specified channel. - -proc ::mime::scopy {token channel offset len blocksize} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - if {$len <= 0} { - set state(doneP) 1 - fileevent $channel writable "" - return - } - - if {[set cc $len] > $blocksize} { - set cc $blocksize - } - - if {[catch { puts -nonewline $channel \ - [string range $state(string) $offset \ - [expr {$offset+$cc-1}]] - fileevent $channel writable \ - [list mime::scopy $token $channel \ - [incr offset $cc] \ - [incr len -$cc] \ - $blocksize] - } result]} { - set state(error) $result - set state(doneP) 1 - fileevent $channel writable "" - } - return -} - -# ::mime::qp_encode -- -# -# Tcl version of quote-printable encode -# -# Arguments: -# string The string to quote. -# encoded_word Boolean value to determine whether or not encoded words -# (RFC 2047) should be handled or not. (optional) -# -# Results: -# The properly quoted string is returned. - -proc ::mime::qp_encode {string {encoded_word 0} {no_softbreak 0}} { - # 8.1+ improved string manipulation routines used. - # Replace outlying characters, characters that would normally - # be munged by EBCDIC gateways, and special Tcl characters "[\]{} - # with =xx sequence - - regsub -all -- \ - {[\x00-\x08\x0B-\x1E\x21-\x24\x3D\x40\x5B-\x5E\x60\x7B-\xFF]} \ - $string {[format =%02X [scan "\\&" %c]]} string - - # Replace the format commands with their result - - set string [subst -novariable $string] - - # soft/hard newlines and other - # Funky cases for SMTP compatibility - set mapChars [list " \n" "=20\n" "\t\n" "=09\n" \ - "\n\.\n" "\n=2E\n" "\nFrom " "\n=46rom "] - if {$encoded_word} { - # Special processing for encoded words (RFC 2047) - lappend mapChars " " "_" - } - set string [string map $mapChars $string] - - # Break long lines - ugh - - # Implementation of FR #503336 - if {$no_softbreak} { - set result $string - } else { - set result "" - foreach line [split $string \n] { - while {[string length $line] > 72} { - set chunk [string range $line 0 72] - if {[regexp -- (=|=.)$ $chunk dummy end]} { - - # Don't break in the middle of a code - - set len [expr {72 - [string length $end]}] - set chunk [string range $line 0 $len] - incr len - set line [string range $line $len end] - } else { - set line [string range $line 73 end] - } - append result $chunk=\n - } - append result $line\n - } - } - - # Trim off last \n, since the above code has the side-effect - # of adding an extra \n to the encoded string and return the result. - - set result [string range $result 0 end-1] - - # If the string ends in space or tab, replace with =xx - - set lastChar [string index $result end] - if {$lastChar==" "} { - set result [string replace $result end end "=20"] - } elseif {$lastChar=="\t"} { - set result [string replace $result end end "=09"] - } - - return $result -} - -# ::mime::qp_decode -- -# -# Tcl version of quote-printable decode -# -# Arguments: -# string The quoted-prinatble string to decode. -# encoded_word Boolean value to determine whether or not encoded words -# (RFC 2047) should be handled or not. (optional) -# -# Results: -# The decoded string is returned. - -proc ::mime::qp_decode {string {encoded_word 0}} { - # 8.1+ improved string manipulation routines used. - # Special processing for encoded words (RFC 2047) - - if {$encoded_word} { - # _ == \x20, even if SPACE occupies a different code position - set string [string map [list _ \u0020] $string] - } - - # smash the white-space at the ends of lines since that must've been - # generated by an MUA. - - regsub -all -- {[ \t]+\n} $string "\n" string - set string [string trimright $string " \t"] - - # Protect the backslash for later subst and - # smash soft newlines, has to occur after white-space smash - # and any encoded word modification. - - set string [string map [list "\\" "\\\\" "=\n" ""] $string] - - # Decode specials - - regsub -all -nocase {=([a-f0-9][a-f0-9])} $string {\\u00\1} string - - # process \u unicode mapped chars - - return [subst -novar -nocommand $string] -} - -# ::mime::parseaddress -- -# -# This was originally written circa 1982 in C. we're still using it -# because it recognizes virtually every buggy address syntax ever -# generated! -# -# mime::parseaddress takes a string containing one or more 822-style -# address specifications and returns a list of serialized arrays, one -# element for each address specified in the argument. -# -# Each serialized array contains these properties: -# -# property value -# ======== ===== -# address local@domain -# comment 822-style comment -# domain the domain part (rhs) -# error non-empty on a parse error -# group this address begins a group -# friendly user-friendly rendering -# local the local part (lhs) -# memberP this address belongs to a group -# phrase the phrase part -# proper 822-style address specification -# route 822-style route specification (obsolete) -# -# Note that one or more of these properties may be empty. -# -# Arguments: -# string The address string to parse -# -# Results: -# Returns a list of serialized arrays, one element for each address -# specified in the argument. - -proc ::mime::parseaddress {string} { - global errorCode errorInfo - - variable mime - - set token [namespace current]::[incr mime(uid)] - # FRINK: nocheck - variable $token - upvar 0 $token state - - set code [catch { mime::parseaddressaux $token $string } result] - set ecode $errorCode - set einfo $errorInfo - - foreach name [array names state] { - unset state($name) - } - # FRINK: nocheck - catch { unset $token } - - return -code $code -errorinfo $einfo -errorcode $ecode $result -} - -# ::mime::parseaddressaux -- -# -# This was originally written circa 1982 in C. we're still using it -# because it recognizes virtually every buggy address syntax ever -# generated! -# -# mime::parseaddressaux does the actually parsing for mime::parseaddress -# -# Each serialized array contains these properties: -# -# property value -# ======== ===== -# address local@domain -# comment 822-style comment -# domain the domain part (rhs) -# error non-empty on a parse error -# group this address begins a group -# friendly user-friendly rendering -# local the local part (lhs) -# memberP this address belongs to a group -# phrase the phrase part -# proper 822-style address specification -# route 822-style route specification (obsolete) -# -# Note that one or more of these properties may be empty. -# -# Arguments: -# token The MIME token to work from. -# string The address string to parse -# -# Results: -# Returns a list of serialized arrays, one element for each address -# specified in the argument. - -proc ::mime::parseaddressaux {token string} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - variable addrtokenL - variable addrlexemeL - - set state(input) $string - set state(glevel) 0 - set state(buffer) "" - set state(lastC) LX_END - set state(tokenL) $addrtokenL - set state(lexemeL) $addrlexemeL - - set result "" - while {[addr_next $token]} { - if {[string compare [set tail $state(domain)] ""]} { - set tail @$state(domain) - } else { - set tail @[info hostname] - } - if {[string compare [set address $state(local)] ""]} { - append address $tail - } - - if {[string compare $state(phrase) ""]} { - set state(phrase) [string trim $state(phrase) "\""] - foreach t $state(tokenL) { - if {[string first $t $state(phrase)] >= 0} { - set state(phrase) \"$state(phrase)\" - break - } - } - - set proper "$state(phrase) <$address>" - } else { - set proper $address - } - - if {![string compare [set friendly $state(phrase)] ""]} { - if {[string compare [set note $state(comment)] ""]} { - if {[string first "(" $note] == 0} { - set note [string trimleft [string range $note 1 end]] - } - if {[string last ")" $note] \ - == [set len [expr {[string length $note]-1}]]} { - set note [string range $note 0 [expr {$len-1}]] - } - set friendly $note - } - - if {(![string compare $friendly ""]) \ - && ([string compare [set mbox $state(local)] ""])} { - set mbox [string trim $mbox "\""] - - if {[string first "/" $mbox] != 0} { - set friendly $mbox - } elseif {[string compare \ - [set friendly [addr_x400 $mbox PN]] \ - ""]} { - } elseif {([string compare \ - [set friendly [addr_x400 $mbox S]] \ - ""]) \ - && ([string compare \ - [set g [addr_x400 $mbox G]] \ - ""])} { - set friendly "$g $friendly" - } - - if {![string compare $friendly ""]} { - set friendly $mbox - } - } - } - set friendly [string trim $friendly "\""] - - lappend result [list address $address \ - comment $state(comment) \ - domain $state(domain) \ - error $state(error) \ - friendly $friendly \ - group $state(group) \ - local $state(local) \ - memberP $state(memberP) \ - phrase $state(phrase) \ - proper $proper \ - route $state(route)] - - } - - unset state(input) \ - state(glevel) \ - state(buffer) \ - state(lastC) \ - state(tokenL) \ - state(lexemeL) - - return $result -} - -# ::mime::addr_next -- -# -# Locate the next address in a mime token. -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns 1 if there is another address, and 0 if there is not. - -proc ::mime::addr_next {token} { - global errorCode errorInfo - # FRINK: nocheck - variable $token - upvar 0 $token state - - foreach prop {comment domain error group local memberP phrase route} { - catch { unset state($prop) } - } - - switch -- [set code [catch { mime::addr_specification $token } result]] { - 0 { - if {!$result} { - return 0 - } - - switch -- $state(lastC) { - LX_COMMA - - - LX_END { - } - default { - # catch trailing comments... - set lookahead $state(input) - mime::parselexeme $token - set state(input) $lookahead - } - } - } - - 7 { - set state(error) $result - - while {1} { - switch -- $state(lastC) { - LX_COMMA - - - LX_END { - break - } - - default { - mime::parselexeme $token - } - } - } - } - - default { - set ecode $errorCode - set einfo $errorInfo - - return -code $code -errorinfo $einfo -errorcode $ecode $result - } - } - - foreach prop {comment domain error group local memberP phrase route} { - if {![info exists state($prop)]} { - set state($prop) "" - } - } - - return 1 -} - -# ::mime::addr_specification -- -# -# Uses lookahead parsing to determine whether there is another -# valid e-mail address or not. Throws errors if unrecognized -# or invalid e-mail address syntax is used. -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns 1 if there is another address, and 0 if there is not. - -proc ::mime::addr_specification {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - set lookahead $state(input) - switch -- [parselexeme $token] { - LX_ATOM - - - LX_QSTRING { - set state(phrase) $state(buffer) - } - - LX_SEMICOLON { - if {[incr state(glevel) -1] < 0} { - return -code 7 "extraneous semi-colon" - } - - catch { unset state(comment) } - return [addr_specification $token] - } - - LX_COMMA { - catch { unset state(comment) } - return [addr_specification $token] - } - - LX_END { - return 0 - } - - LX_LBRACKET { - return [addr_routeaddr $token] - } - - LX_ATSIGN { - set state(input) $lookahead - return [addr_routeaddr $token 0] - } - - default { - return -code 7 \ - [format "unexpected character at beginning (found %s)" \ - $state(buffer)] - } - } - - switch -- [parselexeme $token] { - LX_ATOM - - - LX_QSTRING { - append state(phrase) " " $state(buffer) - - return [addr_phrase $token] - } - - LX_LBRACKET { - return [addr_routeaddr $token] - } - - LX_COLON { - return [addr_group $token] - } - - LX_DOT { - set state(local) "$state(phrase)$state(buffer)" - unset state(phrase) - mime::addr_routeaddr $token 0 - mime::addr_end $token - } - - LX_ATSIGN { - set state(memberP) $state(glevel) - set state(local) $state(phrase) - unset state(phrase) - mime::addr_domain $token - mime::addr_end $token - } - - LX_SEMICOLON - - - LX_COMMA - - - LX_END { - set state(memberP) $state(glevel) - if {(![string compare $state(lastC) LX_SEMICOLON]) \ - && ([incr state(glevel) -1] < 0)} { - return -code 7 "extraneous semi-colon" - } - - set state(local) $state(phrase) - unset state(phrase) - } - - default { - return -code 7 [format "expecting mailbox (found %s)" \ - $state(buffer)] - } - } - - return 1 -} - -# ::mime::addr_routeaddr -- -# -# Parses the domain portion of an e-mail address. Finds the '@' -# sign and then calls mime::addr_route to verify the domain. -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns 1 if there is another address, and 0 if there is not. - -proc ::mime::addr_routeaddr {token {checkP 1}} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - set lookahead $state(input) - if {![string compare [parselexeme $token] LX_ATSIGN]} { - mime::addr_route $token - } else { - set state(input) $lookahead - } - - mime::addr_local $token - - switch -- $state(lastC) { - LX_ATSIGN { - mime::addr_domain $token - } - - LX_SEMICOLON - - - LX_RBRACKET - - - LX_COMMA - - - LX_END { - } - - default { - return -code 7 \ - [format "expecting at-sign after local-part (found %s)" \ - $state(buffer)] - } - } - - if {($checkP) && ([string compare $state(lastC) LX_RBRACKET])} { - return -code 7 [format "expecting right-bracket (found %s)" \ - $state(buffer)] - } - - return 1 -} - -# ::mime::addr_route -- -# -# Attempts to parse the portion of the e-mail address after the @. -# Tries to verify that the domain definition has a valid form. -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns nothing if successful, and throws an error if invalid -# syntax is found. - -proc ::mime::addr_route {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - set state(route) @ - - while {1} { - switch -- [parselexeme $token] { - LX_ATOM - - - LX_DLITERAL { - append state(route) $state(buffer) - } - - default { - return -code 7 \ - [format "expecting sub-route in route-part (found %s)" \ - $state(buffer)] - } - } - - switch -- [parselexeme $token] { - LX_COMMA { - append state(route) $state(buffer) - while {1} { - switch -- [parselexeme $token] { - LX_COMMA { - } - - LX_ATSIGN { - append state(route) $state(buffer) - break - } - - default { - return -code 7 \ - [format "expecting at-sign in route (found %s)" \ - $state(buffer)] - } - } - } - } - - LX_ATSIGN - - - LX_DOT { - append state(route) $state(buffer) - } - - LX_COLON { - append state(route) $state(buffer) - return - } - - default { - return -code 7 \ - [format "expecting colon to terminate route (found %s)" \ - $state(buffer)] - } - } - } -} - -# ::mime::addr_domain -- -# -# Attempts to parse the portion of the e-mail address after the @. -# Tries to verify that the domain definition has a valid form. -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns nothing if successful, and throws an error if invalid -# syntax is found. - -proc ::mime::addr_domain {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - while {1} { - switch -- [parselexeme $token] { - LX_ATOM - - - LX_DLITERAL { - append state(domain) $state(buffer) - } - - default { - return -code 7 \ - [format "expecting sub-domain in domain-part (found %s)" \ - $state(buffer)] - } - } - - switch -- [parselexeme $token] { - LX_DOT { - append state(domain) $state(buffer) - } - - LX_ATSIGN { - append state(local) % $state(domain) - unset state(domain) - } - - default { - return - } - } - } -} - -# ::mime::addr_local -- -# -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns nothing if successful, and throws an error if invalid -# syntax is found. - -proc ::mime::addr_local {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - set state(memberP) $state(glevel) - - while {1} { - switch -- [parselexeme $token] { - LX_ATOM - - - LX_QSTRING { - append state(local) $state(buffer) - } - - default { - return -code 7 \ - [format "expecting mailbox in local-part (found %s)" \ - $state(buffer)] - } - } - - switch -- [parselexeme $token] { - LX_DOT { - append state(local) $state(buffer) - } - - default { - return - } - } - } -} - -# ::mime::addr_phrase -- -# -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns nothing if successful, and throws an error if invalid -# syntax is found. - - -proc ::mime::addr_phrase {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - while {1} { - switch -- [parselexeme $token] { - LX_ATOM - - - LX_QSTRING { - append state(phrase) " " $state(buffer) - } - - default { - break - } - } - } - - switch -- $state(lastC) { - LX_LBRACKET { - return [addr_routeaddr $token] - } - - LX_COLON { - return [addr_group $token] - } - - LX_DOT { - append state(phrase) $state(buffer) - return [addr_phrase $token] - } - - default { - return -code 7 \ - [format "found phrase instead of mailbox (%s%s)" \ - $state(phrase) $state(buffer)] - } - } -} - -# ::mime::addr_group -- -# -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns nothing if successful, and throws an error if invalid -# syntax is found. - -proc ::mime::addr_group {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - if {[incr state(glevel)] > 1} { - return -code 7 [format "nested groups not allowed (found %s)" \ - $state(phrase)] - } - - set state(group) $state(phrase) - unset state(phrase) - - set lookahead $state(input) - while {1} { - switch -- [parselexeme $token] { - LX_SEMICOLON - - - LX_END { - set state(glevel) 0 - return 1 - } - - LX_COMMA { - } - - default { - set state(input) $lookahead - return [addr_specification $token] - } - } - } -} - -# ::mime::addr_end -- -# -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns nothing if successful, and throws an error if invalid -# syntax is found. - -proc ::mime::addr_end {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - switch -- $state(lastC) { - LX_SEMICOLON { - if {[incr state(glevel) -1] < 0} { - return -code 7 "extraneous semi-colon" - } - } - - LX_COMMA - - - LX_END { - } - - default { - return -code 7 [format "junk after local@domain (found %s)" \ - $state(buffer)] - } - } -} - -# ::mime::addr_x400 -- -# -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns nothing if successful, and throws an error if invalid -# syntax is found. - -proc ::mime::addr_x400 {mbox key} { - if {[set x [string first "/$key=" [string toupper $mbox]]] < 0} { - return "" - } - set mbox [string range $mbox [expr {$x+[string length $key]+2}] end] - - if {[set x [string first "/" $mbox]] > 0} { - set mbox [string range $mbox 0 [expr {$x-1}]] - } - - return [string trim $mbox "\""] -} - -# ::mime::parsedatetime -- -# -# Fortunately the clock command in the Tcl 8.x core does all the heavy -# lifting for us (except for timezone calculations). -# -# mime::parsedatetime takes a string containing an 822-style date-time -# specification and returns the specified property. -# -# The list of properties and their ranges are: -# -# property range -# ======== ===== -# hour 0 .. 23 -# lmonth January, February, ..., December -# lweekday Sunday, Monday, ... Saturday -# mday 1 .. 31 -# min 0 .. 59 -# mon 1 .. 12 -# month Jan, Feb, ..., Dec -# proper 822-style date-time specification -# rclock elapsed seconds between then and now -# sec 0 .. 59 -# wday 0 .. 6 (Sun .. Mon) -# weekday Sun, Mon, ..., Sat -# yday 1 .. 366 -# year 1900 ... -# zone -720 .. 720 (minutes east of GMT) -# -# Arguments: -# value Either a 822-style date-time specification or '-now' -# if the current date/time should be used. -# property The property (from the list above) to return -# -# Results: -# Returns the string value of the 'property' for the date/time that was -# specified in 'value'. - -proc ::mime::parsedatetime {value property} { - if {![string compare $value -now]} { - set clock [clock seconds] - } else { - set clock [clock scan $value] - } - - switch -- $property { - hour { - set value [clock format $clock -format %H] - } - - lmonth { - return [clock format $clock -format %B] - } - - lweekday { - return [clock format $clock -format %A] - } - - mday { - set value [clock format $clock -format %d] - } - - min { - set value [clock format $clock -format %M] - } - - mon { - set value [clock format $clock -format %m] - } - - month { - return [clock format $clock -format %b] - } - - proper { - set gmt [clock format $clock -format "%d %b %Y %H:%M:%S" \ - -gmt true] - if {[set diff [expr {($clock-[clock scan $gmt])/60}]] < 0} { - set s - - set diff [expr {-($diff)}] - } else { - set s + - } - set zone [format %s%02d%02d $s [expr {$diff/60}] [expr {$diff%60}]] - - return [clock format $clock \ - -format "%a, %d %b %Y %H:%M:%S $zone"] - } - - rclock { - if {![string compare $value -now]} { - return 0 - } else { - return [expr {[clock seconds]-$clock}] - } - } - - sec { - set value [clock format $clock -format %S] - } - - wday { - return [clock format $clock -format %w] - } - - weekday { - return [clock format $clock -format %a] - } - - yday { - set value [clock format $clock -format %j] - } - - year { - set value [clock format $clock -format %Y] - } - - zone { - regsub -all -- "\t" $value " " value - set value [string trim $value] - if {[set x [string last " " $value]] < 0} { - return 0 - } - set value [string range $value [expr {$x+1}] end] - switch -- [set s [string index $value 0]] { - + - - { - if {![string compare $s +]} { - set s "" - } - set value [string trim [string range $value 1 end]] - if {([string length $value] != 4) \ - || ([scan $value %2d%2d h m] != 2) \ - || ($h > 12) \ - || ($m > 59) \ - || (($h == 12) && ($m > 0))} { - error "malformed timezone-specification: $value" - } - set value $s[expr {$h*60+$m}] - } - - default { - set value [string toupper $value] - set z1 [list UT GMT EST EDT CST CDT MST MDT PST PDT] - set z2 [list 0 0 -5 -4 -6 -5 -7 -6 -8 -7] - if {[set x [lsearch -exact $z1 $value]] < 0} { - error "unrecognized timezone-mnemonic: $value" - } - set value [expr {[lindex $z2 $x]*60}] - } - } - } - - date2gmt - - - date2local - - - dst - - - sday - - - szone - - - tzone - - - default { - error "unknown property $property" - } - } - - if {![string compare [set value [string trimleft $value 0]] ""]} { - set value 0 - } - return $value -} - -# ::mime::uniqueID -- -# -# Used to generate a 'globally unique identifier' for the content-id. -# The id is built from the pid, the current time, the hostname, and -# a counter that is incremented each time a message is sent. -# -# Arguments: -# -# Results: -# Returns the a string that contains the globally unique identifier -# that should be used for the Content-ID of an e-mail message. - -proc ::mime::uniqueID {} { - variable mime - - return "<[pid].[clock seconds].[incr mime(cid)]@[info hostname]>" -} - -# ::mime::parselexeme -- -# -# Used to implement a lookahead parser. -# -# Arguments: -# token The MIME token to operate on. -# -# Results: -# Returns the next token found by the parser. - -proc ::mime::parselexeme {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - set state(input) [string trimleft $state(input)] - - set state(buffer) "" - if {![string compare $state(input) ""]} { - set state(buffer) end-of-input - return [set state(lastC) LX_END] - } - - set c [string index $state(input) 0] - set state(input) [string range $state(input) 1 end] - - if {![string compare $c "("]} { - set noteP 0 - set quoteP 0 - - while {1} { - append state(buffer) $c - - switch -- $c/$quoteP { - "(/0" { - incr noteP - } - - "\\/0" { - set quoteP 1 - } - - ")/0" { - if {[incr noteP -1] < 1} { - if {[info exists state(comment)]} { - append state(comment) " " - } - append state(comment) $state(buffer) - - return [parselexeme $token] - } - } - - default { - set quoteP 0 - } - } - - if {![string compare [set c [string index $state(input) 0]] ""]} { - set state(buffer) "end-of-input during comment" - return [set state(lastC) LX_ERR] - } - set state(input) [string range $state(input) 1 end] - } - } - - if {![string compare $c "\""]} { - set firstP 1 - set quoteP 0 - - while {1} { - append state(buffer) $c - - switch -- $c/$quoteP { - "\\/0" { - set quoteP 1 - } - - "\"/0" { - if {!$firstP} { - return [set state(lastC) LX_QSTRING] - } - set firstP 0 - } - - default { - set quoteP 0 - } - } - - if {![string compare [set c [string index $state(input) 0]] ""]} { - set state(buffer) "end-of-input during quoted-string" - return [set state(lastC) LX_ERR] - } - set state(input) [string range $state(input) 1 end] - } - } - - if {![string compare $c "\["]} { - set quoteP 0 - - while {1} { - append state(buffer) $c - - switch -- $c/$quoteP { - "\\/0" { - set quoteP 1 - } - - "\]/0" { - return [set state(lastC) LX_DLITERAL] - } - - default { - set quoteP 0 - } - } - - if {![string compare [set c [string index $state(input) 0]] ""]} { - set state(buffer) "end-of-input during domain-literal" - return [set state(lastC) LX_ERR] - } - set state(input) [string range $state(input) 1 end] - } - } - - if {[set x [lsearch -exact $state(tokenL) $c]] >= 0} { - append state(buffer) $c - - return [set state(lastC) [lindex $state(lexemeL) $x]] - } - - while {1} { - append state(buffer) $c - - switch -- [set c [string index $state(input) 0]] { - "" - " " - "\t" - "\n" { - break - } - - default { - if {[lsearch -exact $state(tokenL) $c] >= 0} { - break - } - } - } - - set state(input) [string range $state(input) 1 end] - } - - return [set state(lastC) LX_ATOM] -} - -# ::mime::mapencoding -- -# -# mime::mapencodings maps tcl encodings onto the proper names for their -# MIME charset type. This is only done for encodings whose charset types -# were known. The remaining encodings return "" for now. -# -# Arguments: -# enc The tcl encoding to map. -# -# Results: -# Returns the MIME charset type for the specified tcl encoding, or "" -# if none is known. - -proc ::mime::mapencoding {enc} { - - variable encodings - - if {[info exists encodings($enc)]} { - return $encodings($enc) - } - return "" -} - -# ::mime::reversemapencoding -- -# -# mime::reversemapencodings maps MIME charset types onto tcl encoding names. -# Those that are unknown return "". -# -# Arguments: -# mimeType The MIME charset to convert into a tcl encoding type. -# -# Results: -# Returns the tcl encoding name for the specified mime charset, or "" -# if none is known. - -proc ::mime::reversemapencoding {mimeType} { - - variable reversemap - - set lmimeType [string tolower $mimeType] - if {[info exists reversemap($lmimeType)]} { - return $reversemap($lmimeType) - } - return "" -} - -# ::mime::word_encode -- -# -# Word encodes strings as per RFC 2047. -# -# Arguments: -# charset The character set to encode the message to. -# method The encoding method (base64 or quoted-printable). -# string The string to encode. -# -# Results: -# Returns a word encoded string. - -proc ::mime::word_encode {charset method string} { - - variable encodings - - if {![info exists encodings($charset)]} { - error "unknown charset '$charset'" - } - - if {$encodings($charset) == ""} { - error "invalid charset '$charset'" - } - - if {$method != "base64" && $method != "quoted-printable"} { - error "unknown method '$method', must be base64 or quoted-printable" - } - - set result "=?$encodings($charset)?" - switch -exact -- $method { - base64 { - append result "B?[string trimright [base64 -mode encode -- $string] \n]?=" - } - quoted-printable { - append result "Q?[qp_encode $string 1]?=" - } - "" { - # Go ahead - } - default { - error "Can't handle content encoding \"$method\"" - } - } - - return $result -} - -# ::mime::word_decode -- -# -# Word decodes strings that have been word encoded as per RFC 2047. -# -# Arguments: -# encoded The word encoded string to decode. -# -# Results: -# Returns the string that has been decoded from the encoded message. - -proc ::mime::word_decode {encoded} { - - variable reversemap - - if {[regexp -- {=\?([^?]+)\?(.)\?([^?]*)\?=} $encoded \ - - charset method string] != 1} { - error "malformed word-encoded expression '$encoded'" - } - - set enc [reversemapencoding $charset] - if {[string equal "" $enc]} { - error "unknown charset '$charset'" - } - - switch -exact -- $method { - B { - set method base64 - } - Q { - set method quoted-printable - } - default { - error "unknown method '$method', must be B or Q" - } - } - - switch -exact -- $method { - base64 { - set result [base64 -mode decode -- $string] - } - quoted-printable { - set result [qp_decode $string 1] - } - "" { - # Go ahead - } - default { - error "Can't handle content encoding \"$method\"" - } - } - - return [list $enc $method $result] -} - -# ::mime::field_decode -- -# -# Word decodes strings that have been word encoded as per RFC 2047 -# and converts the string from UTF to the original encoding/charset. -# -# Arguments: -# field The string to decode -# -# Results: -# Returns the decoded string in its original encoding/charset.. - -proc ::mime::field_decode {field} { - # ::mime::field_decode is broken. Here's a new version. - # This code is in the public domain. Don Libes - - # Step through a field for mime-encoded words, building a new - # version with unencoded equivalents. - - # Sorry about the grotesque regexp. Most of it is sensible. One - # notable fudge: the final $ is needed because of an apparent bug - # in the regexp engine where the preceding .* otherwise becomes - # non-greedy - perhaps because of the earlier ".*?", sigh. - - while {[regexp {(.*?)(=\?(?:[^?]+)\?(?:.)\?(?:[^?]*)\?=)(.*)$} $field ignore prefix encoded field]} { - # don't allow whitespace between encoded words per RFC 2047 - if {"" != $prefix} { - if {![string is space $prefix]} { - append result $prefix - } - } - - set decoded [word_decode $encoded] - foreach {charset - string} $decoded break - - append result [::encoding convertfrom $charset $string] - } - - append result $field - return $result -} - DELETED modules/mime/mime.test Index: modules/mime/mime.test ================================================================== --- modules/mime/mime.test +++ /dev/null @@ -1,251 +0,0 @@ -# mime.test - Test suite for TclMIME -# -*- tcl -*- -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 2000 by Ajuba Solutions -# All rights reserved. -# -# RCS: @(#) $Id: mime.test,v 1.5 2002/09/14 23:39:55 andreas_kupries Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -source [file join [file dirname [info script]] mime.tcl] -namespace import mime::* - -puts "mime [package present mime]" - - - -test mime-1.1 {initialize with no args} { - catch {initialize} res - subst $res -} {specify exactly one of -file, -parts, or -string} - -test mime-2.1 {Generate a MIME message} { - set tok [initialize -canonical "Text/plain" -string "jack and jill"] - set msg [mime::buildmessage $tok] - # The generated message is predictable except for the Content-ID - regexp {MIME-Version: 1.0 -Content-ID: [^\n]+ -Content-Type: text/plain - -jack and jill} $msg -} 1 - -test mime-2.2 {Generate a multi-part MIME message} { - set tok1 [initialize -canonical "Text/plain" -string "jack and jill"] - set tok2 [initialize -canonical "Text/plain" -string "james"] - set bigTok [mime::initialize -canonical Multipart/MyType \ - -param [list MyParam foo] \ - -param [list boundary bndry] \ - -header [list Content-Description "Test Multipart"] \ - -parts [list $tok1 $tok2]] - set msg [mime::buildmessage $bigTok] - # The generated message is predictable except for the Content-ID - regexp {MIME-Version: 1.0 -Content-Description: Test Multipart -Content-ID: [^\n]+ -Content-Type: multipart/mytype; - boundary="bndry"; - myparam="foo" - ---bndry -MIME-Version: 1.0 -Content-ID: [^\n]+ -Content-Type: text/plain - -jack and jill - ---bndry -MIME-Version: 1.0 -Content-ID: [^\n]+ -Content-Type: text/plain - -james - ---bndry-- -} $msg -} 1 - -test mime-3.1 {Parse a MIME message} { - set msg {MIME-Version: 1.0 -Content-Type: Text/plain - -I'm the message.} - set tok [mime::initialize -string $msg] - mime::getbody $tok -} "I'm the message." - -test mime-3.2 {Parse a multi-part MIME message} { - set msg {MIME-Version: 1.0 -Content-Type: Multipart/foo; boundary="bar" - ---bar -MIME-Version: 1.0 -Content-Type: Text/plain - -part1 ---bar -MIME-Version: 1.0 -Content-Type: Text/plain - -part2 ---bar -MIME-Version: 1.0 -Content-Type: Text/plain - -part3 ---bar-- -} - - set tok [mime::initialize -string $msg] - set partToks [mime::getproperty $tok parts] - - set res "" - foreach childTok $partToks { - lappend res [mime::getbody $childTok] - } - set res -} {part1 part2 part3} - -test mime-3.3 {Try to parse a totally invalid message} { - catch {mime::initialize -string "blah"} err0 - set err0 -} {improper line in header: blah} - -test mime-3.4 {Try to parse a MIME message with an invalid version} { - set msg1 {MIME-Version: 2.0 -Content-Type: text/plain - -msg1} - - set tok [mime::initialize -string $msg1] - catch {mime::getbody $tok} err1 - catch {mime::buildmessage $tok} err1a - list $err1 $err1a -} {msg1 {MIME-Version: 2.0 -Content-Type: text/plain - -msg1 -}} - -test mime-3.5 {Try to parse a MIME message with no newline between headers and data} { - set msg2 {MIME-Version: 1.0 -Content-Type: foobar -data without newline} - - catch {mime::initialize -string $msg2} err2 - set err2 -} {improper line in header: data without newline} - -test mime-3.6 {Try to parse a MIME message with no MIME version and generate a new message from it} { - - # No MIME version - set msg3 {Content-Type: text/plain - -foo} - - set tok [mime::initialize -string $msg3] - catch {mime::getbody $tok} err3 - catch {mime::buildmessage $tok} err3a - list $err3 $err3a -} {foo {MIME-Version: 1.0 -Content-Type: text/plain - -foo -}} - -test mime-4.1 {Test qp_encode with a > 76 character string containing special chars.} { - set str1 "foo!\"\t barbaz \$ ` \{ # jack and jill went up a hill to fetch a pail of water. Jack fell down and said !\"\#\$@\[\\\]^`\{\|\}\~ \nJill said, \"Oh my\"" - mime::qp_encode $str1 -} "foo=21=22\t barbaz =24 =60 =7B =23 jack and jill went up a hill to fetch a=\n pail of water. Jack fell down and said =21=22=23=24=40=5B=5C=5D=5E=60=7B=\n=7C=7D=7E =20\nJill said, =22Oh my=22" - -test mime-4.2 {Check that encode/decode yields original string} { - set str1 "foo!\"\t barbaz \$ ` \{ # jack and jill went up a hill to fetch a pail of water. Jack fell down and said !\"\#\$@\[\\\]^`\{\|\}\~ \nJill said, \"Oh my\" " - set enc [mime::qp_encode $str1] - set dec [mime::qp_decode $enc] - string equal $dec $str1 -} {1} - -test mime-4.3 {mime::decode data that might come from an MUA} { - set enc "I'm the =22 message =\nwith some new lines= \n but with some extra space, too. " - mime::qp_decode $enc -} "I'm the \" message with some new lines but with some extra space, too." - -test mime-4.4 {Test qp_encode with non-US_ASCCI characters.} { - set str1 "Test de caractères accentués : â î é ç et quelques contrôles \"\[|\]()\"" - mime::qp_encode $str1 -} "Test de caract=E8res accentu=E9s : =E2 =EE =E9 =E7 et quelques contr=F4le=\ns =22=5B=7C=5D()=22" - - - - - -test mime-5.1 {Test word_encode with quoted-printable method} { - mime::word_encode iso8859-1 quoted-printable "Test de contrôle effectué" -} "=?ISO-8859-1?Q?Test_de_contr=F4le_effectu=E9?=" - -test mime-5.2 {Test word_encode with base64 method} { - mime::word_encode iso8859-1 base64 "Test de contrôle effectué" -} "=?ISO-8859-1?B?VGVzdCBkZSBjb250cvRsZSBlZmZlY3R16Q==?=" - -test mime-5.3 {Test encode+decode with quoted-printable method} { - set enc [mime::word_encode iso8859-1 quoted-printable "Test de contrôle effectué"] - mime::word_decode $enc -} {iso8859-1 quoted-printable {Test de contrôle effectué}} - -test mime-5.4 {Test encode+decode with base64 method} { - set enc [mime::word_encode iso8859-1 base64 "Test de contrôle effectué"] - mime::word_decode $enc -} {iso8859-1 base64 {Test de contrôle effectué}} - - -test mime-6.1 {Test field_decode (from RFC 2047, part 8)} { - mime::field_decode {=?US-ASCII?Q?Keith_Moore?= } -} {Keith Moore } - -test mime-6.2 {Test field_decode (from RFC 2047, part 8)} { - mime::field_decode {=?ISO-8859-1?Q?Patrik_F=E4ltstr=F6m?= } -} {Patrik Fältström } - -test mime-6.3 {Test field_decode (from RFC 2047, part 8)} { - mime::field_decode {=?ISO-8859-1?B?SWYgeW91IGNhbiByZWFkIHRoaXMgeW8=?= - =?ISO-8859-2?B?dSB1bmRlcnN0YW5kIHRoZSBleGFtcGxlLg==?=} -} {If you can read this you understand the example.} - -foreach {n encoded expected} { - 4 "(=?ISO-8859-1?Q?a?=)" - "(a)" - 5 "(=?ISO-8859-1?Q?a?= b)" - "(a b)" - 6 "(=?ISO-8859-1?Q?a?= =?ISO-8859-1?Q?b?=)" - "(ab)" - 7 "(=?ISO-8859-1?Q?a?= =?ISO-8859-1?Q?b?=)" - "(ab)" - 8 "(=?ISO-8859-1?Q?a?= - =?ISO-8859-1?Q?b?=)" - "(ab)" - 9 "(=?ISO-8859-1?Q?a_b?=)" - "(a b)" - 10 "(=?ISO-8859-1?Q?a?= =?ISO-8859-2?Q?_b?=)" - "(a b)" - 11 "(=?ISO-8859-1?Q?a?=x=?ISO-8859-2?Q?_b?=)" - "(ax b)" - 12 "a b c" - "a b c" - 13 "" - "" -} { - test mime-6.$n {Test field_decode (from RFC 2047, part 8)} { - mime::field_decode $encoded - } $expected ; # {} -} - - -::tcltest::cleanupTests DELETED modules/mime/performance.tcl Index: modules/mime/performance.tcl ================================================================== --- modules/mime/performance.tcl +++ /dev/null @@ -1,139 +0,0 @@ -#!/usr/bin/tclsh - -#package require mime -source ./mime.tcl - -proc construct_item_with_attachment size { - set message_token [mime::initialize -canonical text/plain \ - -string "This is a first part."] - set attachment_body [string repeat abcd\n [expr $size / 5]] - set attachment_token [mime::initialize \ - -canonical application/octet-stream \ - -string $attachment_body] - set multi_token [mime::initialize -canonical multipart/mixed \ - -parts [list $message_token $attachment_token]] - - set packaged [mime::buildmessage $multi_token] - mime::finalize $multi_token - return $packaged -} - -proc small_test size { - set item [construct_item_with_attachment $size] - #puts $item - set length [string length $item] - set result [time {mime::finalize [mime::initialize \ - -string $item]} 1] - - puts "$size ($length): $result" -} - -small_test 800000 -small_test 1000000 -small_test 1500000 -small_test 2500000 -small_test 5000000 - - -small_test 1000 -small_test 10000 -small_test 50000 -small_test 100000 -small_test 200000 -small_test 400000 - - -exit -foreach func [profiler::sortFunctions totalRuntime] { - if { [lindex $func 1] > 0 } { - puts [profiler::print [lindex $func 0]] - } -} -exit - -set fp [open /tmp/msgdump r] -set message [read $fp] -close $fp - -set curpos 0 -set next_EOL -1 -set msg_EOF 0 -set msg_size [string length $message] - -proc doforeach {} { - global message - - set cnt 0 - foreach line [split $message "\n"] { - incr cnt - } - puts "doforeach $cnt lines" - -} - -proc dolindex {} { - global message - set cnt 0 - set lmsg [split $message "\n"] - set len [llength $lmsg] - for {set cnt 0} { $cnt < $len } {incr cnt} { - set line [lindex $lmsg $cnt] - } - - puts "dolindex $cnt lines" - -} - -proc getnextline {} { - global message - global curpos - global next_EOL - global msg_EOF - global msg_size - - if { $msg_EOF } { - error "End-Of-Message reached" - } - - set next_EOL [string first "\n" $message $curpos] - - if { $next_EOL == -1 } { - set next_EOL $msg_size - } - - set msg_EOF [expr $next_EOL == $msg_size] - - set line [string range $message $sp $next_EOL] - set curpos [incr next_EOL] - -} - -proc dogetnext {} { - global message - global curpos - global next_EOL - global msg_EOF - global msg_size - - set curpos 0 - set next_EOL -1 - set msg_EOF 0 - set msg_size [string length $message] - - set cnt 0 - while { !$msg_EOF } { - getnextline - incr cnt - } - - puts "dogetnext $cnt lines" -} - -set res [time doforeach 10] -puts $res -set time1 [lindex $res 0] - -set res [time dolindex 10] -puts $res -set time2 [lindex $res 0] -puts [expr $time2.0 / $time1.0 ] DELETED modules/mime/pkgIndex.tcl Index: modules/mime/pkgIndex.tcl ================================================================== --- modules/mime/pkgIndex.tcl +++ /dev/null @@ -1,3 +0,0 @@ -if {![package vsatisfies [package provide Tcl] 8.3]} {return} -package ifneeded mime 1.3.3 [list source [file join $dir mime.tcl]] -package ifneeded smtp 1.3.3 [list source [file join $dir smtp.tcl]] DELETED modules/mime/rfc2629.dtd Index: modules/mime/rfc2629.dtd ================================================================== --- modules/mime/rfc2629.dtd +++ /dev/null @@ -1,209 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DELETED modules/mime/smtp.man Index: modules/mime/smtp.man ================================================================== --- modules/mime/smtp.man +++ /dev/null @@ -1,104 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[manpage_begin smtp n 1.3.3] -[copyright {1999-2000 Marshall T. Rose}] -[moddesc {smtp client}] -[titledesc {Client-side tcl implementation of the smtp protocol}] -[require Tcl] -[require mime [opt 1.3.3]] -[require smtp [opt 1.3.3]] -[description] -[para] - -The [package smtp] library package provides the client side of the -smtp protocol. - -[list_begin definitions] - -[call [cmd ::smtp::sendmessage] [arg token] [arg option]...] - -This command sends the MIME part (see package [package mime]) -represented by [arg token] to an SMTP server. [arg options] is a list -of options and their associated values. The recognized options are: - -[list_begin definitions] - -[lst_item [option -servers]] - -A list of SMTP servers. The default is [const localhost]. - -[lst_item [option -ports]] - -A list of SMTP ports. The default is [const 25]. - -[lst_item [option -queue]] - -Indicates that the SMTP server should be asked to queue the message -for later processing. A boolean value. - -[lst_item [option -atleastone]] - -Indicates that the SMTP server must find at least one recipient -acceptable for the message to be sent. A boolean value. - -[lst_item [option -originator]] - -A string containing an 822-style address specification. If present the -header isn't examined for an originator address. - -[lst_item [option -recipients]] - -A string containing one or more 822-style address specifications. If -present the header isn't examined for recipient addresses). If the -string contains more than one address they will be separated by -commas. - -[lst_item [option -header]] - -A list of keywords and their values (may occur zero or more times). - -[list_end] -[nl] - -If the [option -originator] option is not present, the originator -address is taken from [const From] (or [const Resent-From]); -similarly, if the [option -recipients] option is not present, -recipient addresses are taken from [const To], [const cc], and -[const Bcc] (or [const Resent-To], and so on). Note that the header -key/values supplied by the [option -header] option (not those present -in the MIME part) are consulted. Regardless, header key/values are -added to the outgoing message as necessary to ensure that a valid -822-style message is sent. - -[nl] - -The command returns a list indicating which recipients were -unacceptable to the SMTP server. Each element of the list is another -list, containing the address, an SMTP error code, and a textual -diagnostic. Depending on the [option -atleastone] option and the -intended recipients, a non-empty list may still indicate that the -message was accepted by the server. - -[list_end] - -[section EXAMPLE] - -[example { -proc send_simple_message {recipient email_server subject body} { - package require smtp - package require mime - - set token [mime::initialize -canonical text/plain \\ - -string $body] - mime::setheader $token Subject $subject - smtp::sendmessage $token \\ - -recipients $recipient -servers $email_server - mime::finalize $token -} - -send_simple_message someone@somewhere.com localhost \\ - "This is the subject." "This is the message." -}] - -[see_also mime pop3 ftp http] -[keywords mail mail email smtp mime rfc821 rfc822 internet net] -[manpage_end] DELETED modules/mime/smtp.n Index: modules/mime/smtp.n ================================================================== --- modules/mime/smtp.n +++ /dev/null @@ -1,82 +0,0 @@ -'\" -'\" Copyright (c) 2000 Andreas Kupries -'\" All right reserved -'\" -'\" CVS: $Id: smtp.n,v 1.5 2002/02/01 17:44:53 andreas_kupries Exp $ smtp.n -'\" -.so man.macros -.TH "smtp" n 1.3.2 tcllib "smtp client" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -smtp \- Client-side tcl implementation of the smtp protocol -.SH "SYNOPSIS" -package require \fBTcl\fR -.sp -package require \fBmime ?1.3.2?\fR -.sp -package require \fBsmtp ?1.3.2?\fR -.sp -\fBsmtp::sendmessage\fR \fItoken\fR \fIoptions\fR\fR -.sp -.BE -.SH "DESCRIPTION" -.PP -The smtp library package provides the client side of the smtp protocol. -.TP -\fBsmtp::sendmessage\fR \fItoken\fR \fIoptions\fR\fR -This command sends the MIME part represented by \fItoken\fR to an SMTP -server. \fIoptions\fR is a list of options and their associated values. -The recognized options are: -.RS -.TP -\fB-servers\fR -A list of SMTP servers. The default is \fIlocalhost\fR. -.TP -\fB-ports\fR -A list of SMTP ports. The default is \fI25\fR. -.TP -\fB-queue\fR -Indicates that the SMTP server should be asked to queue the message -for later processing. A boolean value. -.TP -\fB-atleastone\fR -Indicates that the SMTP server must find at least one recipient -acceptable for the message to be sent. A boolean value. -.TP -\fB-originator\fR -A string containing an 822-style address specification. If present the -header isn't examined for an originator address. -.TP -\fB-recipients\fR -A string containing one or more 822-style address specifications. If -present the header isn't examined for recipient addresses). If the -string contains more than one address they will be separated by -commas. -.TP -\fB-header\fR -A list of keywords and their values (may occur zero or more times). -.RE -.sp -If the \fI-originator\fR option is not present, the originator -address is taken from \fBFrom\fR (or \fBResent-From\fR); -similarly, if the \fI-recipients\fR option is not present, recipient -addresses are taken from \fBTo\fR, \fBcc\fR, and \fBBcc\fR -(or \fBResent-To\fR, and so on). Note that the header key/values -supplied by the \fI-header\fR option (not those present in the MIME -part) are consulted. Regardless, header key/values are added to the -outgoing message as necessary to ensure that a valid 822-style message -is sent. -.sp -The command returns a list indicating which recipients were -unacceptable to the SMTP server. Each element of the list is another -list, containing the address, an SMTP error code, and a textual -diagnostic. Depending on the \fI-atleastone\fR option and the -intended recipients, a non-empty list may still indicate that the -message was accepted by the server. -.SH "SEE ALSO" -mime, pop3, ftp, http -.SH "KEYWORDS" -mail, email, smtp, mime, rfc821, rfc822, internet, net - - DELETED modules/mime/smtp.tcl Index: modules/mime/smtp.tcl ================================================================== --- modules/mime/smtp.tcl +++ /dev/null @@ -1,1254 +0,0 @@ -# smtp.tcl - SMTP client -# -# (c) 1999-2000 Marshall T. Rose -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# - -package require Tcl 8.3 -package require mime 1.3.3 -package provide smtp 1.3.3 - -# -# state variables: -# -# sd: socket to server -# afterID: afterID associated with ::smtp::timer -# options: array of user-supplied options -# readable: semaphore for vwait -# addrs: number of recipients negotiated -# error: error during read -# line: response read from server -# crP: just put a \r in the data -# nlP: just put a \n in the data -# size: number of octets sent in DATA -# - - -namespace eval ::smtp { - variable trf 1 - variable smtp - array set smtp { uid 0 } - - namespace export sendmessage -} - -if {[catch {package require Trf 2.0}]} { - # Trf is not available, but we can live without it as long as the - # transform and unstack procs are defined. - - # Warning! - # This is a fragile emulation of the more general calling sequence - # that appears to work with this code here. - - proc transform {args} { - upvar state mystate - set mystate(size) 1 - } - proc unstack {channel} { - # do nothing - return - } - set ::smtp::trf 0 -} - - -# ::smtp::sendmessage -- -# -# Sends a mime object (containing a message) to some recipients -# -# Arguments: -# part The MIME object containing the message to send -# args A list of arguments specifying various options for sending the -# message: -# -atleastone A boolean specifying whether or not to send the -# message at all if any of the recipients are -# invalid. A value of false (as defined by -# ::smtp::boolean) means that ALL recipients must be -# valid in order to send the message. A value of -# true means that as long as at least one recipient -# is valid, the message will be sent. -# -debug A boolean specifying whether or not debugging is -# on. If debugging is enabled, status messages are -# printed to stderr while trying to send mail. -# -queue A boolean specifying whether or not the message -# being sent should be queued for later delivery. -# -header A single RFC 822 header key and value (as a list), -# used to specify to whom to send the message -# (To, Cc, Bcc), the "From", etc. -# -originator The originator of the message (equivalent to -# specifying a From header). -# -recipients A string containing recipient e-mail addresses. -# NOTE: This option overrides any recipient addresses -# specified with -header. -# -servers A list of mail servers that could process the -# request. -# -ports A list of SMTP ports to use for each SMTP server -# specified -# -maxsecs Maximum number of seconds to allow the SMTP server -# to accept the message. If not specified, the default -# is 120 seconds. -# -# Results: -# Message is sent. On success, return "". On failure, throw an -# exception with an error code and error message. - -proc ::smtp::sendmessage {part args} { - global errorCode errorInfo - - # Here are the meanings of the following boolean variables: - # aloP -- value of -atleastone option above. - # debugP -- value of -debug option above. - # origP -- 1 if -originator option was specified, 0 otherwise. - # queueP -- value of -queue option above. - - set aloP 0 - set debugP 0 - set origP 0 - set queueP 0 - set maxsecs 120 - set originator "" - set recipients "" - set servers [list localhost] - set ports [list 25] - - array set header "" - - # lowerL will contain the list of header keys (converted to lower case) - # specified with various -header options. mixedL is the mixed-case version - # of the list. - set lowerL "" - set mixedL "" - - # Parse options (args). - - if {[expr {[llength $args]%2}]} { - # Some option didn't get a value. - error "Each option must have a value! Invalid option list: $args" - } - - foreach {option value} $args { - switch -- $option { - -atleastone {set aloP [boolean $value]} - -debug {set debugP [boolean $value]} - -queue {set queueP [boolean $value]} - -maxsecs {set maxsecs [expr {$value < 0 ? 0 : $value}]} - -header { - if {[llength $value] != 2} { - error "-header expects a key and a value, not $value" - } - set mixed [lindex $value 0] - set lower [string tolower $mixed] - set disallowedHdrList \ - [list content-type \ - content-transfer-encoding \ - content-md5 \ - mime-version] - if {[lsearch -exact $disallowedHdrList $lower] > -1} { - error "Content-Type, Content-Transfer-Encoding,\ - Content-MD5, and MIME-Version cannot be user-specified." - } - if {[lsearch -exact $lowerL $lower] < 0} { - lappend lowerL $lower - lappend mixedL $mixed - } - - lappend header($lower) [lindex $value 1] - } - - -originator { - set originator $value - if {$originator == ""} { - set origP 1 - } - } - - -recipients { - set recipients $value - } - - -servers { - set servers $value - } - - -ports { - set ports $value - } - - default { - error "unknown option $option" - } - } - } - - if {[lsearch -glob $lowerL resent-*] >= 0} { - set prefixL resent- - set prefixM Resent- - } else { - set prefixL "" - set prefixM "" - } - - # Set a bunch of variables whose value will be the real header to be used - # in the outbound message (with proper case and prefix). - - foreach mixed {From Sender To cc Dcc Bcc Date Message-ID} { - set lower [string tolower $mixed] - # FRINK: nocheck - set ${lower}L $prefixL$lower - # FRINK: nocheck - set ${lower}M $prefixM$mixed - } - - if {$origP} { - # -originator was specified with "", so SMTP sender should be marked "". - set sender "" - } else { - # -originator was specified with a value, OR -originator wasn't - # specified at all. - - # If no -originator was provided, get the originator from the "From" - # header. If there was no "From" header get it from the username - # executing the script. - - set who "-originator" - if {$originator == ""} { - if {![info exists header($fromL)]} { - set originator $::tcl_platform(user) - } else { - set originator [join $header($fromL) ,] - - # Indicate that we're using the From header for the originator. - - set who $fromM - } - } - - # If there's no "From" header, create a From header with the value - # of -originator as the value. - - if {[lsearch -exact $lowerL $fromL] < 0} { - lappend lowerL $fromL - lappend mixedL $fromM - lappend header($fromL) $originator - } - - # ::mime::parseaddress returns a list whose elements are huge key-value - # lists with info about the addresses. In this case, we only want one - # originator, so we want the length of the main list to be 1. - - set addrs [::mime::parseaddress $originator] - if {[llength $addrs] > 1} { - error "too many mailboxes in $who: $originator" - } - array set aprops [lindex $addrs 0] - if {$aprops(error) != ""} { - error "error in $who: $aprops(error)" - } - - # sender = validated originator or the value of the From header. - - set sender $aprops(address) - - # If no Sender header has been specified and From is different from - # originator, then set the sender header to the From. Otherwise, don't - # specify a Sender header. - set from [join $header($fromL) ,] - if {[lsearch -exact $lowerL $senderL] < 0 && \ - [string compare $originator $from]} { - if {[info exists aprops]} { - unset aprops - } - array set aprops [lindex [::mime::parseaddress $from] 0] - if {$aprops(error) != ""} { - error "error in $fromM: $aprops(error)" - } - if {[string compare $aprops(address) $sender]} { - lappend lowerL $senderL - lappend mixedL $senderM - lappend header($senderL) $aprops(address) - } - } - } - - # We're done parsing the arguments. - - if {$recipients != ""} { - set who -recipients - } elseif {![info exists header($toL)]} { - error "need -header \"$toM ...\"" - } else { - set recipients [join $header($toL) ,] - # Add Cc values to recipients list - set who $toM - if {[info exists header($ccL)]} { - append recipients ,[join $header($ccL) ,] - append who /$ccM - } - - set dccInd [lsearch -exact $lowerL $dccL] - if {$dccInd >= 0} { - # Add Dcc values to recipients list, and get rid of Dcc header - # since we don't want to output that. - append recipients ,[join $header($dccL) ,] - append who /$dccM - - unset header($dccL) - set lowerL [lreplace $lowerL $dccInd $dccInd] - set mixedL [lreplace $mixedL $dccInd $dccInd] - } - } - - set brecipients "" - set bccInd [lsearch -exact $lowerL $bccL] - if {$bccInd >= 0} { - set bccP 1 - - # Build valid bcc list and remove bcc element of header array (so that - # bcc info won't be sent with mail). - foreach addr [::mime::parseaddress [join $header($bccL) ,]] { - if {[info exists aprops]} { - unset aprops - } - array set aprops $addr - if {$aprops(error) != ""} { - error "error in $bccM: $aprops(error)" - } - lappend brecipients $aprops(address) - } - - unset header($bccL) - set lowerL [lreplace $lowerL $bccInd $bccInd] - set mixedL [lreplace $mixedL $bccInd $bccInd] - } else { - set bccP 0 - } - - # If there are no To headers, add "" to bcc list. WHY?? - if {[lsearch -exact $lowerL $toL] < 0} { - lappend lowerL $bccL - lappend mixedL $bccM - lappend header($bccL) "" - } - - # Construct valid recipients list from recipients list. - - set vrecipients "" - foreach addr [::mime::parseaddress $recipients] { - if {[info exists aprops]} { - unset aprops - } - array set aprops $addr - if {$aprops(error) != ""} { - error "error in $who: $aprops(error)" - } - lappend vrecipients $aprops(address) - } - - # If there's no date header, get the date from the mime message. Same for - # the message-id. - - if {([lsearch -exact $lowerL $dateL] < 0) \ - && ([catch { ::mime::getheader $part $dateL }])} { - lappend lowerL $dateL - lappend mixedL $dateM - lappend header($dateL) [::mime::parsedatetime -now proper] - } - - if {([lsearch -exact $lowerL ${message-idL}] < 0) \ - && ([catch { ::mime::getheader $part ${message-idL} }])} { - lappend lowerL ${message-idL} - lappend mixedL ${message-idM} - lappend header(${message-idL}) [::mime::uniqueID] - - } - - # Get all the headers from the MIME object and save them so that they can - # later be restored. - set savedH [::mime::getheader $part] - - # Take all the headers defined earlier and add them to the MIME message. - foreach lower $lowerL mixed $mixedL { - foreach value $header($lower) { - ::mime::setheader $part $mixed $value -mode append - } - } - - if {![string compare $servers localhost]} { - set client localhost - } else { - set client [info hostname] - } - - # Create smtp token, which essentially means begin talking to the SMTP - # server. - set token [initialize -debug $debugP -client $client \ - -maxsecs $maxsecs \ - -multiple $bccP -queue $queueP \ - -servers $servers -ports $ports] - - if {![string match "::smtp::*" $token]} { - # An error occurred and $token contains the error info - array set respArr $token - return -code error $respArr(diagnostic) - } - - set code [catch { sendmessageaux $token $part \ - $sender $vrecipients $aloP } \ - result] - set ecode $errorCode - set einfo $errorInfo - - # Send the message to bcc recipients as a MIME attachment. - - if {($code == 0) && ($bccP)} { - set inner [::mime::initialize -canonical message/rfc822 \ - -header [list Content-Description \ - "Original Message"] \ - -parts [list $part]] - - set subject "\[$bccM\]" - if {[info exists header(subject)]} { - append subject " " [lindex $header(subject) 0] - } - - set outer [::mime::initialize \ - -canonical multipart/digest \ - -header [list From $originator] \ - -header [list Bcc ""] \ - -header [list Date \ - [::mime::parsedatetime -now proper]] \ - -header [list Subject $subject] \ - -header [list Message-ID [::mime::uniqueID]] \ - -header [list Content-Description \ - "Blind Carbon Copy"] \ - -parts [list $inner]] - - - set code [catch { sendmessageaux $token $outer \ - $sender $brecipients \ - $aloP } result2] - set ecode $errorCode - set einfo $errorInfo - - if {$code == 0} { - set result [concat $result $result2] - } else { - set result $result2 - } - - catch { ::mime::finalize $inner -subordinates none } - catch { ::mime::finalize $outer -subordinates none } - } - - # Determine if there was any error in prior operations and set errorcodes - # and error messages appropriately. - - switch -- $code { - 0 { - set status orderly - } - - 7 { - set code 1 - array set response $result - set result "$response(code): $response(diagnostic)" - set status abort - } - - default { - set status abort - } - } - - # Destroy SMTP token 'cause we're done with it. - - catch { finalize $token -close $status } - - # Restore provided MIME object to original state (without the SMTP headers). - - foreach key [::mime::getheader $part -names] { - mime::setheader $part $key "" -mode delete - } - foreach {key values} $savedH { - foreach value $values { - ::mime::setheader $part $key $value -mode append - } - } - - return -code $code -errorinfo $einfo -errorcode $ecode $result -} - -# ::smtp::sendmessageaux -- -# -# Sends a mime object (containing a message) to some recipients using an -# existing SMTP token. -# -# Arguments: -# token SMTP token that has an open connection to the SMTP server. -# part The MIME object containing the message to send. -# originator The e-mail address of the entity sending the message, -# usually the From clause. -# recipients List of e-mail addresses to whom message will be sent. -# aloP Boolean "atleastone" setting; see the -atleastone option -# in ::smtp::sendmessage for details. -# -# Results: -# Message is sent. On success, return "". On failure, throw an -# exception with an error code and error message. - -proc ::smtp::sendmessageaux {token part originator recipients aloP} { - global errorCode errorInfo - - winit $token $originator - - set goodP 0 - set badP 0 - set oops "" - foreach recipient $recipients { - set code [catch { waddr $token $recipient } result] - set ecode $errorCode - set einfo $errorInfo - - switch -- $code { - 0 { - incr goodP - } - - 7 { - incr badP - - array set response $result - lappend oops [list $recipient $response(code) \ - $response(diagnostic)] - } - - default { - return -code $code -errorinfo $einfo -errorcode $ecode $result - } - } - } - - if {($goodP) && ((!$badP) || ($aloP))} { - wtext $token $part - } else { - catch { talk $token 300 RSET } - } - - return $oops -} - -# ::smtp::initialize -- -# -# Create an SMTP token and open a connection to the SMTP server. -# -# Arguments: -# args A list of arguments specifying various options for sending the -# message: -# -debug A boolean specifying whether or not debugging is -# on. If debugging is enabled, status messages are -# printed to stderr while trying to send mail. -# -client Either localhost or the name of the local host. -# -multiple Multiple messages will be sent using this token. -# -queue A boolean specifying whether or not the message -# being sent should be queued for later delivery. -# -servers A list of mail servers that could process the -# request. -# -ports A list of ports on mail servers that could process -# the request (one port per server-- defaults to 25). -# -# Results: -# On success, return an smtp token. On failure, throw -# an exception with an error code and error message. - -proc ::smtp::initialize {args} { - global errorCode errorInfo - - variable smtp - - set token [namespace current]::[incr smtp(uid)] - # FRINK: nocheck - variable $token - upvar 0 $token state - - array set state [list afterID "" options "" readable 0] - array set options [list -debug 0 -client localhost -multiple 1 \ - -maxsecs 120 -queue 0 -servers localhost -ports 25] - array set options $args - set state(options) [array get options] - - # Iterate through servers until one accepts a connection (and responds - # nicely). - - set index 0 - foreach server $options(-servers) { - set state(readable) 0 - if {[llength $options(-ports)] >= $index} { - set port [lindex $options(-ports) $index] - } else { - set port 25 - } - if {$options(-debug)} { - puts stderr "Trying $server..." - flush stderr - } - - if {[info exists state(sd)]} { - unset state(sd) - } - - if {[set code [catch { - set state(sd) [socket -async $server $port] - fconfigure $state(sd) -blocking off -translation binary - fileevent $state(sd) readable [list ::smtp::readable $token] - } result]]} { - set ecode $errorCode - set einfo $errorInfo - - catch { close $state(sd) } - continue - } - - if {[set code [catch { hear $token 600 } result]]} { - array set response [list code 400 diagnostic $result] - } else { - array set response $result - } - set ecode $errorCode - set einfo $errorInfo - switch -- $response(code) { - 220 { - } - - 421 - default { - # 421 - Temporary problem on server - catch {close $state(sd)} - continue - } - } - - # Try enhanced SMTP first. - - if {[set code [catch {smtp::talk $token 300 "EHLO $options(-client)"} \ - result]]} { - array set response [list code 400 diagnostic $result args ""] - } else { - array set response $result - } - set ecode $errorCode - set einfo $errorInfo - if {(500 <= $response(code)) && ($response(code) <= 599)} { - if {[set code [catch { talk $token 300 \ - "HELO $options(-client)" } \ - result]]} { - array set response [list code 400 diagnostic $result \ - args ""] - } else { - array set response $result - } - set ecode $errorCode - set einfo $errorInfo - } - - if {$response(code) == 250} { - # Successful response to HELO or EHLO command, so set up queuing - # and whatnot and return the token. - - if {(!$options(-multiple)) \ - && ([lsearch $response(args) ONEX] >= 0)} { - catch {smtp::talk $token 300 ONEX} - } - if {($options(-queue)) \ - && ([lsearch $response(args) XQUE] >= 0)} { - catch {smtp::talk $token 300 QUED} - } - - return $token - } else { - # Bad response; close the connection and hope the next server - # is happier. - catch {close $state(sd)} - } - incr index - } - - # None of the servers accepted our connection, so close everything up and - # return an error. - finalize $token -close drop - - return -code $code -errorinfo $einfo -errorcode $ecode $result -} - -# ::smtp::finalize -- -# -# Deletes an SMTP token by closing the connection to the SMTP server, -# cleanup up various state. -# -# Arguments: -# token SMTP token that has an open connection to the SMTP server. -# args Optional arguments, where the only useful option is -close, -# whose valid values are the following: -# orderly Normal successful completion. Close connection and -# clear state variables. -# abort A connection exists to the SMTP server, but it's in -# a weird state and needs to be reset before being -# closed. Then clear state variables. -# drop No connection exists, so we just need to clean up -# state variables. -# -# Results: -# SMTP connection is closed and state variables are cleared. If there's -# an error while attempting to close the connection to the SMTP server, -# throw an exception with the error code and error message. - -proc ::smtp::finalize {token args} { - global errorCode errorInfo - # FRINK: nocheck - variable $token - upvar 0 $token state - - array set options [list -close orderly] - array set options $args - - switch -- $options(-close) { - orderly { - set code [catch { talk $token 120 QUIT } result] - } - - abort { - set code [catch { - talk $token 0 RSET - talk $token 0 QUIT - } result] - } - - drop { - set code 0 - set result "" - } - - default { - error "unknown value for -close $options(-close)" - } - } - set ecode $errorCode - set einfo $errorInfo - - catch { close $state(sd) } - - if {$state(afterID) != ""} { - catch { after cancel $state(afterID) } - } - - foreach name [array names state] { - unset state($name) - } - # FRINK: nocheck - unset $token - - return -code $code -errorinfo $einfo -errorcode $ecode $result -} - -# ::smtp::winit -- -# -# Send originator info to SMTP server. This occurs after HELO/EHLO -# command has completed successfully (in ::smtp::initialize). This function -# is called by ::smtp::sendmessageaux. -# -# Arguments: -# token SMTP token that has an open connection to the SMTP server. -# originator The e-mail address of the entity sending the message, -# usually the From clause. -# mode SMTP command specifying the mode of communication. Default -# value is MAIL. -# -# Results: -# Originator info is sent and SMTP server's response is returned. If an -# error occurs, throw an exception. - -proc ::smtp::winit {token originator {mode MAIL}} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - if {[lsearch -exact [list MAIL SEND SOML SAML] $mode] < 0} { - error "unknown origination mode $mode" - } - - array set response \ - [set result [talk $token 600 \ - "$mode FROM:<$originator>"]] - if {$response(code) == 250} { - set state(addrs) 0 - return $result - } else { - return -code 7 $result - } -} - -# ::smtp::waddr -- -# -# Send recipient info to SMTP server. This occurs after originator info -# is sent (in ::smtp::winit). This function is called by -# ::smtp::sendmessageaux. -# -# Arguments: -# token SMTP token that has an open connection to the SMTP server. -# recipient One of the recipients to whom the message should be -# delivered. -# -# Results: -# Recipient info is sent and SMTP server's response is returned. If an -# error occurs, throw an exception. - -proc ::smtp::waddr {token recipient} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - set result [talk $token 3600 "RCPT TO:<$recipient>"] - array set response $result - - switch -- $response(code) { - 250 - 251 { - incr state(addrs) - return $result - } - - default { - return -code 7 $result - } - } -} - -# ::smtp::wtext -- -# -# Send message to SMTP server. This occurs after recipient info -# is sent (in ::smtp::winit). This function is called by -# ::smtp::sendmessageaux. -# -# Arguments: -# token SMTP token that has an open connection to the SMTP server. -# part The MIME object containing the message to send. -# -# Results: -# MIME message is sent and SMTP server's response is returned. If an -# error occurs, throw an exception. - -proc ::smtp::wtext {token part} { - # FRINK: nocheck - variable $token - upvar 0 $token state - array set options $state(options) - - set result [talk $token 300 DATA] - array set response $result - if {$response(code) != 354} { - return -code 7 $result - } - - if {[catch { wtextaux $token $part } result]} { - catch { puts -nonewline $state(sd) "\r\n.\r\n" ; flush $state(sd) } - return -code 7 [list code 400 diagnostic $result] - } - - set secs $options(-maxsecs) - - set result [talk $token $secs .] - array set response $result - switch -- $response(code) { - 250 - 251 { - return $result - } - - default { - return -code 7 $result - } - } -} - -# ::smtp::wtextaux -- -# -# Helper function that coordinates writing the MIME message to the socket. -# In particular, it stacks the channel leading to the SMTP server, sets up -# some file events, sends the message, unstacks the channel, resets the -# file events to their original state, and returns. -# -# Arguments: -# token SMTP token that has an open connection to the SMTP server. -# part The MIME object containing the message to send. -# -# Results: -# Message is sent. If anything goes wrong, throw an exception. - -proc ::smtp::wtextaux {token part} { - global errorCode errorInfo - variable trf - # FRINK: nocheck - variable $token - upvar 0 $token state - - flush $state(sd) - fileevent $state(sd) readable "" - transform -attach $state(sd) -command [list ::smtp::wdata $token] - fileevent $state(sd) readable [list ::smtp::readable $token] - - # If trf is not available, get the contents of the message, - # replace all '.'s that start their own line with '..'s, and - # then write the mime body out to the filehandle. Do not forget to - # deal with bare LF's here too (SF bug #499242). - - if {$trf} { - set code [catch { ::mime::copymessage $part $state(sd) } result] - } else { - set code [catch { ::mime::buildmessage $part } result] - if {$code == 0} { - # Detect and transform bare LF's into proper CR/LF - # sequences. - - while {[regsub -all -- {([^\r])\n} $result "\\1\r\n" result]} {} - regsub -all -- {\n\.} $result "\n.." result - - set state(size) [string length $result] - puts -nonewline $state(sd) $result - set result "" - } - } - set ecode $errorCode - set einfo $errorInfo - - flush $state(sd) - fileevent $state(sd) readable "" - unstack $state(sd) - fileevent $state(sd) readable [list ::smtp::readable $token] - - return -code $code -errorinfo $einfo -errorcode $ecode $result -} - -# ::smtp::wdata -- -# -# This is the custom transform using Trf to do CR/LF translation. If Trf -# is not installed on the system, then this function never gets called and -# no translation occurs. -# -# Arguments: -# token SMTP token that has an open connection to the SMTP server. -# command Trf provided command for manipulating socket data. -# buffer Data to be converted. -# -# Results: -# buffer is translated, and state(size) is set. If Trf is not installed -# on the system, the transform proc defined at the top of this file sets -# state(size) to 1. state(size) is used later to determine a timeout -# value. - -proc ::smtp::wdata {token command buffer} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - switch -- $command { - create/read - - - create/write - - - clear/write - - - delete/write { - set state(crP) 0 - set state(nlP) 1 - set state(size) 0 - } - - write { - set result "" - - foreach c [split $buffer ""] { - switch -- $c { - "." { - if {$state(nlP)} { - append result . - } - set state(crP) 0 - set state(nlP) 0 - } - - "\r" { - set state(crP) 1 - set state(nlP) 0 - } - - "\n" { - if {!$state(crP)} { - append result "\r" - } - set state(crP) 0 - set state(nlP) 1 - } - - default { - set state(crP) 0 - set state(nlP) 0 - } - } - - append result $c - } - - incr state(size) [string length $result] - return $result - } - - flush/write { - set result "" - - if {!$state(nlP)} { - if {!$state(crP)} { - append result "\r" - } - append result "\n" - } - - incr state(size) [string length $result] - return $result - } - - create/read - - delete/read { - # Bugfix for [#539952] - } - - default { - error "Unknown command \"$command\"" - } - } - - return "" -} - -# ::smtp::talk -- -# -# Sends an SMTP command to a server -# -# Arguments: -# token SMTP token that has an open connection to the SMTP server. -# secs Timeout after which command should be aborted. -# command Command to send to SMTP server. -# -# Results: -# command is sent and response is returned. If anything goes wrong, throw -# an exception. - -proc ::smtp::talk {token secs command} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - array set options $state(options) - - if {$options(-debug)} { - puts stderr "--> $command (wait upto $secs seconds)" - flush stderr - } - - if {[catch { puts -nonewline $state(sd) "$command\r\n" - flush $state(sd) } result]} { - return [list code 400 diagnostic $result] - } - - if {$secs == 0} { - return "" - } - - return [hear $token $secs] -} - -# ::smtp::hear -- -# -# Listens for SMTP server's response to some prior command. -# -# Arguments: -# token SMTP token that has an open connection to the SMTP server. -# secs Timeout after which we should stop waiting for a response. -# -# Results: -# Response is returned. - -proc ::smtp::hear {token secs} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - array set options $state(options) - - array set response [list args ""] - - set firstP 1 - while {1} { - if {$secs >= 0} { - set state(afterID) [after [expr {$secs*1000}] \ - [list ::smtp::timer $token]] - } - - if {!$state(readable)} { - vwait ${token}(readable) - } - - # Wait until socket is readable. - if {$state(readable) != -1} { - catch { after cancel $state(afterID) } - set state(afterID) "" - } - - if {$state(readable) < 0} { - array set response [list code 400 diagnostic $state(error)] - break - } - set state(readable) 0 - - if {$options(-debug)} { - puts stderr "<-- $state(line)" - flush stderr - } - - if {[string length $state(line)] < 3} { - array set response \ - [list code 500 \ - diagnostic "response too short: $state(line)"] - break - } - - if {$firstP} { - set firstP 0 - - if {[scan [string range $state(line) 0 2] %d response(code)] \ - != 1} { - array set response \ - [list code 500 \ - diagnostic "unrecognizable code: $state(line)"] - break - } - - set response(diagnostic) \ - [string trim [string range $state(line) 4 end]] - } else { - lappend response(args) \ - [string trim [string range $state(line) 4 end]] - } - - # When status message line ends in -, it means the message is complete. - - if {[string compare [string index $state(line) 3] -]} { - break - } - } - - return [array get response] -} - -# ::smtp::readable -- -# -# Reads a line of data from SMTP server when the socket is readable. This -# is the callback of "fileevent readable". -# -# Arguments: -# token SMTP token that has an open connection to the SMTP server. -# -# Results: -# state(line) contains the line of data and state(readable) is reset. -# state(readable) gets the following values: -# -3 if there's a premature eof, -# -2 if reading from socket fails. -# 1 if reading from socket was successful - -proc ::smtp::readable {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - if {[catch { array set options $state(options) }]} { - return - } - - set state(line) "" - if {[catch { gets $state(sd) state(line) } result]} { - set state(readable) -2 - set state(error) $result - } elseif {$result == -1} { - if {[eof $state(sd)]} { - set state(readable) -3 - set state(error) "premature end-of-file from server" - } - } else { - # If the line ends in \r, remove the \r. - if {![string compare [string index $state(line) end] "\r"]} { - set state(line) [string range $state(line) 0 end-1] - } - set state(readable) 1 - } - - if {$state(readable) < 0} { - if {$options(-debug)} { - puts stderr " ... $state(error) ..." - flush stderr - } - - catch { fileevent $state(sd) readable "" } - } -} - -# ::smtp::timer -- -# -# Handles timeout condition on any communication with the SMTP server. -# -# Arguments: -# token SMTP token that has an open connection to the SMTP server. -# -# Results: -# Sets state(readable) to -1 and state(error) to an error message. - -proc ::smtp::timer {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - array set options $state(options) - - set state(afterID) "" - set state(readable) -1 - set state(error) "read from server timed out" - - if {$options(-debug)} { - puts stderr " ... $state(error) ..." - flush stderr - } -} - -# ::smtp::boolean -- -# -# Helper function for unifying boolean values to 1 and 0. -# -# Arguments: -# value Some kind of value that represents true or false (i.e. 0, 1, -# false, true, no, yes, off, on). -# -# Results: -# Return 1 if the value is true, 0 if false. If the input value is not -# one of the above, throw an exception. - -proc ::smtp::boolean {value} { - switch -- [string tolower $value] { - 0 - false - no - off { - return 0 - } - - 1 - true - yes - on { - return 1 - } - - default { - error "unknown boolean value: $value" - } - } -} DELETED modules/ncgi/ChangeLog Index: modules/ncgi/ChangeLog ================================================================== --- modules/ncgi/ChangeLog +++ /dev/null @@ -1,155 +0,0 @@ -2003-04-10 Andreas Kupries - - * pkgIndex.tcl: - * ncgi.man: - * ncgi.tcl: Fixed bug #614591. Set version of the package to to - 1.2.2. Also fixed equivalnet of bug #648679. - -2003-02-05 David N. Welton - - * ncgi.tcl: Use string match instead of regexp. - -2002-08-30 Andreas Kupries - - * ncgi.tcl: Updated 'info exist' to 'info exists'. - -2002-08-15 David N. Welton - - * ncgi.tcl (ncgi::setValueList): Fix [ 593254 ] ncgi::SetValue bug - - SetValue now works correctly with multipart values with spaces - in them. - -2002-08-09 David N. Welton - - * ncgi.test: Added two new tests for setValue. - - * ncgi.tcl (ncgi::multipart): Fix [ 564279 ] ncgi::multipart bug - - commented out offending 'puts' statements. - -2002-04-12 Andreas Kupries - - * ncgi.man: Added doctools manpage. - -2002-01-15 Andreas Kupries - - * Bumped version to 1.2.1 - -2001-10-20 Andreas Kupries - - * ncgi.tcl (ncgi::redirect): Fixed bug #464560 reported by Ed - Rolfe . The proposed fix is not - used as it does not pass the testsuite. We check for the - existence of "env(REQUEST_URI)" instead, again, and use the - appropriate alternate information if it does not exist. - -2001-10-16 Andreas Kupries - - * ncgi.n: - * ncgi.test: - * ncgi.tcl: - * pkgIndex.tcl: Version up to 1.2 - -2001-09-05 Andreas Kupries - - * ncgi.tcl: Restricted export list to public API. - [456255]. Patch by Hemang Lavana - - -2001-09-05 Andreas Kupries - - * ncgi.tcl: Added missing [global env]. Bug [458023]. - -2001-08-01 Jeff Hobbs - - * ncgi.tcl: made require Tcl 8.1+, sped up encode and decode. - -2001-07-10 Andreas Kupries - - * ncgi.tcl: Frink 2.2 run, fixed dubious code. - -2001-06-21 Andreas Kupries - - * ncgi.tcl: Fixed dubious code reported by frink. - -2001-06-15 Melissa Chawla - - * ncgi.tcl: Applied George Wu's patch (gwu@acm.org) to the - multipart function. It failed to process binary data correctly - because it replaced all "\r\n" sequences with "\n". - -2000-07-31 Brent Welch - - * ncgi.tcl: Added ncgi::setValue, ncgi::setValueList, - ncgi::setDefaultValue, ncgi::setDefaultValueList to push values - back into the CGI environment. - -2000-05-26 Melissa Chawla - - * ncgi.tcl: fixed bug 5727 where Netscape prepends an extra \n to - post data sent via HTTPS. Urlencoded post does not include - preceding or trailing whitespace, so to be safe, we trim - whitespace off the post data before parsing the attributes. - -2000-05-15 Brent Welch - - * ncgi.tcl: Changed ncgi::redirect so it grabs the server name - from REQUEST_URI before using the SERVER_NAME value. This is so - the server name matches the previous page better. Otherwise a - transition from "www" to "www.scriptics.com" can trigger - Basic Authentication challenges. - -2000-05-02 Brent Welch - - * ncgi/ncgi.tcl: - Moved the '+' decoding from nvlist down into ncgi::decode. - Changed ncgi::value to strip out the structure associated with - multipart/form-data values. Use ncgi::valueList to get the - structured value. - -2000-05-02 Sandeep Tamhankar - - * ncgi.tcl: Changed ncgi::parseMimeValue such that a key-value - pair like name="" would turn into the list {name {}} instead of - {name {""}}. - -2000-04-26 Brent Welch - - * ncgi.tcl, ncgi.test: changed names to get capitalization - right: setCookie, valueList, importAll, urlStub - -2000-04-17 Brent Welch - - * ncgi.tcl: Fixed ncgi::reset with no query data. Fixed - ncgi::multipart because it usually gets \r\n data. - -2000-04-14 Brent Welch - - * ncgi.tcl: Changed ncgi::list to ncgi::nvlist (for "name value - list") becauase of the inevitable conflict with the global list - command. Added ncgi::importall to import a set of cgi variables. - Added multipart/form-data parsing. Added ncgi::cookie and - ncgi::setcookie. - -2000-03-20 Eric Melski - - * ncgi.test: Fixed tests that created files with "source ncgi.tcl" - in them to use full path for sourcing, so that tests could be run - from any directory. [Bug: 4393] - -2000-03-15 Brent Welch - - * ncgi.tcl: added ncgi::reset so the ncgi package can be used inside - TclHttpd - - * ncgi.test: added ncgi::reset tests, renumbered everything, and - switch most tests to use ncgi::reset - -2000-03-10 Eric Melski - - * pkgIndex.tcl: Added package index file. - - * ncgi.test: Added code to add source dir to auto_path, so that - tests could be run on uninstalled package. Added call to - tcltest::cleanupTests. - - DELETED modules/ncgi/formdata.txt Index: modules/ncgi/formdata.txt ================================================================== --- modules/ncgi/formdata.txt +++ /dev/null @@ -1,24 +0,0 @@ -Content-Type: multipart/form-data; boundary="---------------------------17661509020136" - ------------------------------17661509020136 -Content-Disposition: form-data; name="field1" - -value ------------------------------17661509020136 -Content-Disposition: form-data; name="field2" - -another value ------------------------------17661509020136 -Content-Disposition: form-data; name="the_file_naame"; filename="C:\Program Files\Netscape\Communicator\Program\nareadme.htm" -Content-Type: text/html - - -

- Netscape Address Book Sync for Palm Pilot - User Guide -

- - - ------------------------------17661509020136-- - DELETED modules/ncgi/ncgi.man Index: modules/ncgi/ncgi.man ================================================================== --- modules/ncgi/ncgi.man +++ /dev/null @@ -1,259 +0,0 @@ -[manpage_begin ncgi n 1.2.2] -[comment {-*- tcl -*- doctools manpage}] -[moddesc {CGI Support}] -[titledesc {Procedures to manipulate CGI values.}] -[require Tcl 8.2] -[require ncgi [opt 1.2.2]] -[description] -[para] - -The [package ncgi] package provides commands that manipulate CGI -values. These are values that come from Web forms and are processed -either by CGI scripts or web pages with embedded Tcl code. Use the -[package ncgi] package to query these values, set and get cookies, and -encode and decode www-url-encoded values. - -[para] - -In the simplest case, a CGI script first calls [cmd ::ncgi::parse] and -then calls [cmd ::ncgi::value] to get different form values. If a CGI -value is repeated, you should use [cmd ::ncgi::valueList] to get back -the complete list of values. - -[para] - -An alternative to [cmd ::ncgi::parse] is [cmd ::ncgi::input], which -has semantics similar to Don Libes' [cmd cgi_input] procedure. - -[cmd ::ncgi::input] restricts repeated CGI values to have names that -end with "List". In this case, [cmd ::ncgi::value] will return the -complete list of values, and [cmd ::ncgi::input] will raise errors if -it find repeated form elements without the right name. - -[para] - -The [cmd ::ncgi::reset] procedure can be used in test suites and Web -servers to initialize the source of the CGI values. Otherwise the -values are read in from the CGI environment. - -[para] - -The complete set of procedures is described below. - - -[list_begin definitions] - -[call [cmd ::ncgi::cookie] [arg cookie]] - -Return a list of values for [arg cookie], if any. It is possible that -more than one cookie with the same name can be present, so this -procedure returns a list. - - -[call [cmd ::ncgi::decode] [arg str]] - -Decode strings in www-url-encoding, which represents special -characters with a %xx sequence, where xx is the character code in hex. - - -[call [cmd ::ncgi::empty] [arg name]] - -Returns 1 if the CGI variable [arg name] is not present or has the -empty string as its value. - - -[call [cmd ::ncgi::encode] [arg string]] - -Encode [arg string] into www-url-encoded format. - - -[call [cmd ::ncgi::header] [opt [arg type]] [arg args]] - -Output the CGI header to standard output. This emits a Content-Type: -header and additional headers based on [arg args], which is a list of -header names and header values. The [arg type] defaults to -"text/html". - - -[call [cmd ::ncgi::import] [arg cginame] [opt [arg tclname]]] - -This creates a variable in the current scope with the value of the CGI -variable [arg cginame]. The name of the variable is [arg tclname], or -[arg cginame] if [arg tclname] is empty (default). - - -[call [cmd ::ncgi::importAll] [arg args]] - -This imports several CGI variables as Tcl variables. If [arg args] is -empty, then every CGI vale is imported. Otherwise each CGI variable -listed in [arg args] is imported. - - -[call [cmd ::ncgi::input] [opt [arg fakeinput]] [opt [arg fakecookie]]] - -This reads and decodes the CGI values from the environment. It -restricts repeated form values to have a trailing "List" in their -name. The CGI values are obtained later with the [cmd ::ncgi::value] -procedure. - - -[call [cmd ::ncgi::multipart] [arg {type query}]] - -This procedure parses a multipart/form-data [arg query]. This is used -by [cmd ::ncgi::nvlist] and not normally called directly. It returns -an alternating list of names and structured values. Each structure -value is in turn a list of two elements. The first element is -meta-data from the multipart/form-data structure. The second element -is the form value. If you use [cmd ::ncgi::value] you just get the -form value. If you use [cmd ::ncgi::valueList] you get the structured -value with meta data and the value. - -[nl] - -The [arg type] is the whole Content-Type, including the parameters -like [arg boundary]. This returns a list of names and values that -describe the multipart data. The values are a nested list structure -that has some descriptive information first, and the actual form value -second. The descriptive information is list of header names and -values that describe the content. - - -[call [cmd ::ncgi::nvlist]] - -This returns all the query data as a name, value list. In the case of -multipart/form-data, the values are structured as described in - -[cmd ::ncgi::multipart]. - - -[call [cmd ::ncgi::parse]] - -This reads and decodes the CGI values from the environment. The CGI -values are obtained later with the [cmd ::ncgi::value] procedure. IF -a CGI value is repeated, then you should use [cmd ::ncgi::valueList] -to get the complete list of values. - - -[call [cmd ::ncgi::parseMimeValue] [arg value]] - -This decodes the Content-Type and other MIME headers that have the -form of "primary value; param=val; p2=v2" It returns a list, where the -first element is the primary value, and the second element is a list -of parameter names and values. - - -[call [cmd ::ncgi::query]] - -This returns the raw query data. - - -[call [cmd ::ncgi::redirect] [arg url]] - -Generate a response that causes a 302 redirect by the Web server. The -[arg url] is the new URL that is the target of the redirect. The URL -will be qualified with the current server and current directory, if -necessary, to convert it into a full URL. - - -[call [cmd ::ncgi::reset] [arg {query type}]] - -Set the query data and Content-Type for the current CGI session. This -is used by the test suite and by Web servers to initialize the ncgi -module so it does not try to read standard input or use environment -variables to get its data. If neither [arg query] or [arg type] are -specified, then the [package ncgi] module will look in the standard -CGI environment for its data. - - -[call [cmd ::ncgi::setCookie] [arg args]] - -Set a cookie value that will be returned as part of the reply. This -must be done before [cmd ::ncgi::header] or [cmd ::ncgi::redirect] is -called in order for the cookie to be returned properly. The - -[arg args] are a set of flags and values: - -[list_begin definitions] - -[lst_item "[option -name] [arg name]"] -[lst_item "[option -value] [arg value]"] -[lst_item "[option -expires] [arg date]"] -[lst_item "[option -path] [arg {path restriction}]"] -[lst_item "[option -domain] [arg {domain restriction}]"] -[list_end] - - -[call [cmd ::ncgi::setDefaultValue] [arg {key defvalue}]] - -Set a CGI value if it does not already exists. This affects future -calls to [cmd ::ncgi::value] (but not future calls to - -[cmd ::ncgi::nvlist]). If the CGI value already is present, then this -procedure has no side effects. - - -[call [cmd ::ncgi::setDefaultValueList] [arg {key defvaluelist}]] - -Like [cmd ::ncgi::setDefaultValue] except that the value already has -list structure to represent multiple checkboxes or a multi-selection. - - -[call [cmd ::ncgi::setValue] [arg {key value}]] - -Set a CGI value, overriding whatever was present in the CGI -environment already. This affects future calls to [cmd ::ncgi::value] -(but not future calls to [cmd ::ncgi::nvlist]). - -[call [cmd ::ncgi::setValueList] [arg {key valuelist}]] - -Like [cmd ::ncgi::setValue] except that the value already has list -structure to represent multiple checkboxes or a multi-selection. - - -[call [cmd ::ncgi::type]] - -Returns the Content-Type of the current CGI values. - - -[call [cmd ::ncgi::urlStub] [opt [arg url]]] - -Returns the current URL, but without the protocol, server, and port. -If [arg url] is specified, then it defines the URL for the current -session. That value will be returned by future calls to - -[cmd ::ncgi::urlStub] - - -[call [cmd ::ncgi::value] [arg key] [opt [arg default]]] - -Return the CGI value identified by [arg key]. If the CGI value is not -present, then the [arg default] value is returned instead. This value -defaults to the empty string. - -[nl] - -If the form value [arg key] is repeated, then there are two cases: if -[cmd ::ncgi::parse] was called, then [cmd ::ncgi::value] only returns -the first value associated with [arg key]. If [cmd ::ncgi::input] was -called, then [cmd ::ncgi::value] returns a Tcl list value and - -[arg key] must end in "List" (e.g., "skuList"). In the case of -multipart/form-data, this procedure just returns the value of the form -element. If you want the meta-data associated with each form value, -then use [cmd ::ncgi::valueList]. - - -[call [cmd ::ncgi::valueList] [arg key] [opt [arg default]]] - -Like [cmd ::ncgi::value], but this always returns a list of values -(even if there is only one value). In the case of -multipart/form-data, this procedure returns a list of two elements. -The first element is meta-data in the form of a parameter, value list. -The second element is the form value. - -[list_end] - - -[see_also html] -[keywords CGI form html cookie] -[manpage_end] DELETED modules/ncgi/ncgi.n Index: modules/ncgi/ncgi.n ================================================================== --- modules/ncgi/ncgi.n +++ /dev/null @@ -1,283 +0,0 @@ -'\" -'\" Copyright (c) 1998-2000 by Ajuba Solutions. -'\" All rights reserved. -'\" -'\" RCS: @(#) $Id: ncgi.n,v 1.9 2002/01/18 20:51:16 andreas_kupries Exp $ -'\" -.so man.macros -.TH ncgi n 1.2.1 Ncgi "CGI Support" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -::ncgi \- Procedures to manipulate CGI values. -.SH SYNOPSIS -.BS -.sp -\fBpackage require Tcl 8.2\fR -.sp -\fBpackage require ncgi ?1.2.1?\fR -.sp -\fBncgi::cookie\fR \fIcookie\fR -.sp -\fBncgi::decode\fR \fIstr\fR -.sp -\fBncgi::empty\fR \fIname\fR -.sp -\fBncgi::encode\fR \fIstring\fR -.sp -\fBncgi::header\fR \fI{type text/html} args\fR -.sp -\fBncgi::import\fR \fIcginame {tclname {}}\fR -.sp -\fBncgi::importAll\fR \fIargs\fR -.sp -\fBncgi::input\fR \fI{fakeinput {}} {fakecookie {}}\fR -.sp -\fBncgi::multipart\fR \fItype query\fR -.sp -\fBncgi::nvlist\fR \fI\fR -.sp -\fBncgi::parse\fR \fI\fR -.sp -\fBncgi::parseMimeValue\fR \fIvalue\fR -.sp -\fBncgi::query\fR \fI\fR -.sp -\fBncgi::redirect\fR \fIurl\fR -.sp -\fBncgi::reset\fR \fIargs\fR -.sp -\fBncgi::setCookie\fR \fIargs\fR -.sp -\fBncgi::setDefaultValue\fR \fIkey defvalue\fR -.sp -\fBncgi::setDefaultValueList\fR \fIkey defvaluelist\fR -.sp -\fBncgi::setValue\fR \fIkey value\fR -.sp -\fBncgi::setValueList\fR \fIkey valuelist\fR -.sp -\fBncgi::type\fR \fI\fR -.sp -\fBncgi::urlStub\fR \fI{url {}}\fR -.sp -\fBncgi::value\fR \fIkey {default {}}\fR -.sp -\fBncgi::valueList\fR \fIkey {default {}}\fR -.BE -.SH DESCRIPTION -.PP -The \fB::ncgi\fR package provides commands that manipulate CGI -values. These are values that come from Web forms and are -processed either by CGI scripts or web pages with embedded Tcl -code. Use the \fB::ncgi\fP package to query these values, -set and get cookies, and encode and decode www-url-encoded values. - -.PP -In the simplest case, a CGI script first calls -\fBncgi::parse\fP and then calls \fBncgi::value\fP to get different -form values. If a CGI value is repeated, you should use -\fBncgi::valueList\fP to get back the complete list of values. - -.PP -An alternative to \fBncgi::parse\fP is \fBncgi::input\fP, -which has semantics similar to Don Libes' \fBcgi_input\fP procedure. -\fBncgi::input\fP restricts repeated CGI values to have names -that end with "List". In this case, \fBncgi::value\fP will return -the complete list of values, and \fBncgi::input\fP will raise -errors if it find repeated form elements without the right name. - -.PP -The \fBncgi::reset\fP procedure can be used in test suites and -Web servers to initialize the source of the CGI values. -Otherwise the values are read in from the CGI environment. - -.PP -The complete set of procedures is described below. - -.TP -\fBncgi::cookie\fR \fIcookie\fR -Return a list of values for \fIcookie\fP, if any. -It is possible that more than one cookie with the same name can -be present, so this procedure returns a list. - -.TP -\fBncgi::decode\fR \fIstr\fR -Decode strings in www-url-encoding, which represents special -characters with a %xx sequence, where xx is the character code in hex. - -.TP -\fBncgi::empty\fR \fIname\fR -Returns 1 if the CGI variable \fIname\fP is not present or has -the empty string as its value. - -.TP -\fBncgi::encode\fR \fIstring\fR -Encode \fBstring\fR into www-url-encoded format. - -.TP -\fBncgi::header\fR \fI{type text/html} args\fR -Output the CGI header to standard output. -This emits a Content-Type: header and additional headers based -on \fIargs\fP, which is a list of -header names and header values. - -.TP -\fBncgi::import\fR \fIcginame {tclname {}}\fR -This creates a variable in the current scope with the -value of the CGI variable \fIcginame\fP. -The name of the variable is \fItclname\fP, or -\fIcginame\fP if \fItclname\fP is empty. - -.TP -\fBncgi::importAll\fR \fIargs\fR -This imports several CGI variables as Tcl variables. -If \fIargs\fP is empty, then every CGI vale is imported. -Otherwise each CGI variable listed in \fIargs\fP is imported. - -.TP -\fBncgi::input\fR \fI{fakeinput {}} {fakecookie {}}\fR -This reads and decodes the CGI values from the environment. -It restricts repeated form values to have a trailing -"List" in their name. The CGI values are obtained later with -the \fBncgi::value\fP procedure. - -.TP -\fBncgi::multipart\fR \fItype query\fR -This procedure parses a multipart/form-data \fIquery\fP. -This is used by \fBncgi::nvlist\fP and not normally called directly. -It returns an alternating list of names and structured values. -Each structure value is in turn a list of two elements. -The first element is meta-data from the multipart/form-data structure. -The second element is the form value. If you use -\fBncgi::value\fP you just get the form value. -If you use \fBncgi::valueList\fP you get the structured value -with meta data and the value. - -The \fItype\fP is the whole Content-Type, including the -parameters like \fBboundary\fP. This returns a list -of names and values -that describe the multipart data. -The values are a nested list structure that has some -descriptive information first, and the actual form value second. -The descriptive information is list of header names and -values that describe the content. - -.TP -\fBncgi::nvlist\fR \fI\fR -This returns all the query data as a name, value list. -In the case of multipart/form-data, the values are structured as -described in \fBncgi::multipart\fP. - -.TP -\fBncgi::parse\fR \fI\fR -This reads and decodes the CGI values from the environment. -The CGI values are obtained later with -the \fBncgi::value\fP procedure. -IF a CGI value is repeated, then you should use -\fBncgi::valueList\fP to get the complete list of values. - -.TP -\fBncgi::parseMimeValue\fR \fIvalue\fR -This decodes the Content-Type and other MIME headers that have -the form of "primary value; param=val; p2=v2" -It returns a list, where the first element is the primary value, -and the second element is a list of parameter names and values. - -.TP -\fBncgi::query\fR \fI\fR -This returns the raw query data. - -.TP -\fBncgi::redirect\fR \fIurl\fR -Generate a response that causes a 302 redirect by the Web server. -The \fIurl\fP is the new URL that is the target of the redirect. -The URL will be qualified with the current server and current -directory, if necessary, to convert it into a full URL. - -.TP -\fBncgi::reset\fR \fIquery type\fR -Set the query data and Content-Type for the current CGI session. -This is used by the test suite and by Web servers to initialize -the ncgi module so it does not try to read standard input or -use environment variables to get its data. -If neither \fIquery\fP or \fItype\fP are specified, then -the \fBncgi\fP module will look -in the standard CGI environment for its data. - -.TP -\fBncgi::setCookie\fR \fIargs\fR -Set a cookie value that will be returned as part of the reply. -This must be done before \fBncgi::header\fP or -\fBncgi::redirect\fP is called in order for the cookie to -be returned properly. -The \fIargs\fP are a set of flags and values: - -.DS --name \fIname\fP --value \fIvalue\fP --expires \fIdate\fP --path \fIpath restriction\fP --domain \fIdomain restriction\fP -.DE - -.TP -\fBncgi::setDefaultValue\fR \fIkey defvalue\fR -Set a CGI value if it does not already exists. -This affects future calls to \fBncgi::value\fR (but not future -calls to \fBncgi::nvlist\fR). -If the CGI value already is present, then this procedure has -no side effects. -.TP -\fBncgi::setDefaultValueList\fR \fIkey defvaluelist\fR -Like \fBncgi::setDefaultValue\fR except that the value already -has list structure to represent multiple checkboxes or a multi-selection. -.TP -\fBncgi::setValue\fR \fIkey value\fR -Set a CGI value, overriding whatever was present in the CGI environment already. -This affects future calls to \fBncgi::value\fR (but not future -calls to \fBncgi::nvlist\fR). -.TP -\fBncgi::setValueList\fR \fIkey valuelist\fR -Like \fBncgi::setValue\fR except that the value already -has list structure to represent multiple checkboxes or a multi-selection. - -.TP -\fBncgi::type\fR \fI\fR -Returns the Content-Type of the current CGI values. - -.TP -\fBncgi::urlStub\fR \fI{url {}}\fR -Returns the current URL, but without the protocol, server, and port. -If \fIurl\fP is specified, then it defines the URL for the -current session. That value will be returned by future calls to -\fBncgi::urlStub\fR - -.TP -\fBncgi::value\fR \fIkey {default {}}\fR -Return the CGI value identified by \fIkey\fP. -If the CGI value is not present, then the \fIdefault\fP value -is returned instead. -If the form value \fIkey\fP is repeated, then there are -two cases: if \fBncgi::parse\fP was called, then -\fBncgi::value\fR only returns the first value associated with \fIkey\fP. -If \fBncgi::input\fP was called, then \fBncgi::value\fR returns a -Tcl list value and \fIkey\fP must end in "List" (e.g., "skuList"). -In the case of multipart/form-data, this procedure just returns the value -of the form element. If you want the meta-data associated with -each form value, then use \fBncgi::valueList\fP. - -.TP -\fBncgi::valueList\fR \fIkey {default {}}\fR -Like \fBncgi::value\fP, but this always returns a list of values -(even if there is only one value). -In the case of multipart/form-data, this procedure returns a list of -two elements. The first element is meta-data in the form of a parameter, value -list. The second element is the form value. - - -.SH SEE ALSO -html - -.SH KEYWORDS -CGI, form, html, cookie DELETED modules/ncgi/ncgi.tcl Index: modules/ncgi/ncgi.tcl ================================================================== --- modules/ncgi/ncgi.tcl +++ /dev/null @@ -1,960 +0,0 @@ -# ncgi.tcl -# -# Basic support for CGI programs -# -# Copyright (c) 2000 Ajuba Solutions. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. - - -# Please note that Don Libes' has a "cgi.tcl" that implements version 1.0 -# of the cgi package. That implementation provides a bunch of cgi_ procedures -# (it doesn't use the ::cgi:: namespace) and has a wealth of procedures for -# generating HTML. In contract, the package provided here is primarly -# concerned with processing input to CGI programs. I have tried to mirror his -# API's where possible. So, ncgi::input is equivalent to cgi_input, and so -# on. There are also some different APIs for accessing values (ncgi::list, -# ncgi::parse and ncgi::value come to mind) - -# Note, I use the term "query data" to refer to the data that is passed in -# to a CGI program. Typically this comes from a Form in an HTML browser. -# The query data is composed of names and values, and the names can be -# repeated. The names and values are encoded, and this module takes care -# of decoding them. - -# We use newer string routines -package require Tcl 8.2 - -package provide ncgi 1.2.2 - -namespace eval ::ncgi { - - # "query" holds the raw query (i.e., form) data - # This is treated as a cache, too, so you can call ncgi::query more than - # once - - variable query - - # This is the content-type which affects how the query is parsed - - variable contenttype - - # value is an array of parsed query data. Each array element is a list - # of values, and the array index is the form element name. - # See the differences among ncgi::parse, ncgi::input, ncgi::value - # and ncgi::valuelist for the various approaches to handling these values. - - variable value - - # This lists the names that appear in the query data - - variable varlist - - # This holds the URL coresponding to the current request - # This does not include the server name. - - variable urlStub - - # This flags compatibility with Don Libes cgi.tcl when dealing with - # form values that appear more than once. This bit gets flipped when - # you use the ncgi::input procedure to parse inputs. - - variable listRestrict 0 - - # This is the set of cookies that are pending for output - - variable cookieOutput - - # Support for x-www-urlencoded character mapping - # The spec says: "non-alphanumeric characters are replaced by '%HH'" - - variable i - variable c - variable map - - for {set i 1} {$i <= 256} {incr i} { - set c [format %c $i] - if {![string match \[a-zA-Z0-9\] $c]} { - set map($c) %[format %.2X $i] - } - } - - # These are handled specially - array set map { - " " + \n %0D%0A - } - - # I don't like importing, but this makes everything show up in - # pkgIndex.tcl - - namespace export reset urlStub query type decode encode - namespace export nvlist parse input value valueList - namespace export setValue setValueList setDefaultValue setDefaultValueList - namespace export empty import importAll redirect header - namespace export parseMimeValue multipart cookie setCookie -} - -# ::ncgi::reset -# -# This resets the state of the CGI input processor. This is primarily -# used for tests, although it is also designed so that TclHttpd can -# call this with the current query data -# so the ncgi package can be shared among TclHttpd and CGI scripts. -# -# DO NOT CALL this in a standard cgi environment if you have not -# yet processed the query data, which will not be used after a -# call to ncgi::reset is made. Instead, just call ncgi::parse -# -# Arguments: -# newquery The query data to be used instead of external CGI. -# newtype The raw content type. -# -# Side Effects: -# Resets the cached query data and wipes any environment variables -# associated with CGI inputs (like QUERY_STRING) - -proc ::ncgi::reset {args} { - global env - variable query - variable contenttype - variable cookieOutput - - set cookieOutput {} - if {[llength $args] == 0} { - - # We use and test args here so we can detect the - # difference between empty query data and a full reset. - - if {[info exists query]} { - unset query - } - if {[info exists contenttype]} { - unset contenttype - } - } else { - set query [lindex $args 0] - set contenttype [lindex $args 1] - } -} - -# ::ncgi::urlStub -# -# Set or return the URL associated with the current page. -# This is for use by TclHttpd to override the default value -# that otherwise comes from the CGI environment -# -# Arguments: -# url (option) The url of the page, not counting the server name. -# If not specified, the current urlStub is returned -# -# Side Effects: -# May affects future calls to ncgi::urlStub - -proc ::ncgi::urlStub {{url {}}} { - global env - variable urlStub - if {[string length $url]} { - set urlStub $url - return "" - } elseif {[info exists urlStub]} { - return $urlStub - } elseif {[info exists env(SCRIPT_NAME)]} { - set urlStub $env(SCRIPT_NAME) - return $urlStub - } else { - return "" - } -} - -# ::ncgi::query -# -# This reads the query data from the appropriate location, which depends -# on if it is a POST or GET request. -# -# Arguments: -# none -# -# Results: -# The raw query data. - -proc ::ncgi::query {} { - global env - variable query - - if {[info exists query]} { - # This ensures you can call ncgi::query more than once, - # and that you can use it with ncgi::reset - return $query - } - - set query "" - if {[info exists env(REQUEST_METHOD)]} { - if {$env(REQUEST_METHOD) == "GET"} { - if {[info exists env(QUERY_STRING)]} { - set query $env(QUERY_STRING) - } - } elseif {$env(REQUEST_METHOD) == "POST"} { - if {[info exists env(CONTENT_LENGTH)] && - [string length $env(CONTENT_LENGTH)] != 0} { - set query [read stdin $env(CONTENT_LENGTH)] - } - } - } - return $query -} - -# ::ncgi::type -# -# This returns the content type of the query data. -# -# Arguments: -# none -# -# Results: -# The content type of the query data. - -proc ::ncgi::type {} { - global env - variable contenttype - - if {![info exists contenttype]} { - if {[info exists env(CONTENT_TYPE)]} { - set contenttype $env(CONTENT_TYPE) - } else { - return "" - } - } - return $contenttype -} - -# ::ncgi::decode -# -# This decodes data in www-url-encoded format. -# -# Arguments: -# An encoded value -# -# Results: -# The decoded value - -proc ::ncgi::decode {str} { - # rewrite "+" back to space - # protect \ from quoting another '\' - set str [string map [list + { } "\\" "\\\\"] $str] - - # prepare to process all %-escapes - regsub -all -- {%([A-Fa-f0-9][A-Fa-f0-9])} $str {\\u00\1} str - - # process \u unicode mapped chars - return [subst -novar -nocommand $str] -} - -# ::ncgi::encode -# -# This encodes data in www-url-encoded format. -# -# Arguments: -# A string -# -# Results: -# The encoded value - -proc ::ncgi::encode {string} { - variable map - - # 1 leave alphanumerics characters alone - # 2 Convert every other character to an array lookup - # 3 Escape constructs that are "special" to the tcl parser - # 4 "subst" the result, doing all the array substitutions - - regsub -all -- \[^a-zA-Z0-9\] $string {$map(&)} string - # This quotes cases like $map([) or $map($) => $map(\[) ... - regsub -all -- {[][{})\\]\)} $string {\\&} string - return [subst -nocommand $string] -} - - -# ::ncgi::nvlist -# -# This parses the query data and returns it as a name, value list -# -# Note: If you use ncgi::setValue or ncgi::setDefaultValue, this -# nvlist procedure doesn't see the effect of that. -# -# Arguments: -# none -# -# Results: -# An alternating list of names and values - -proc ::ncgi::nvlist {} { - set query [query] - set type [type] - switch -glob -- $type { - "" - - application/x-www-form-urlencoded - - application/x-www-urlencoded { - set result {} - - # Any whitespace at the beginning or end of urlencoded data is not - # considered to be part of that data, so we trim it off. One special - # case in which post data is preceded by a \n occurs when posting - # with HTTPS in Netscape. - - foreach {x} [split [string trim $query] &] { - # Turns out you might not get an = sign, - # especially with forms. - if {![regexp -- (.*)=(.*) $x dummy varname val]} { - set varname anonymous - set val $x - } - lappend result [decode $varname] [decode $val] - } - return $result - } - multipart/* { - return [multipart $type $query] - } - default { - return -code error "Unknown Content-Type: $type" - } - } -} - -# ::ncgi::parse -# -# The parses the query data and stores it into an array for later retrieval. -# You should use the ncgi::value or ncgi::valueList procedures to get those -# values, or you are allowed to access the ncgi::value array directly. -# -# Note - all values have a level of list structure associated with them -# to allow for multiple values for a given form element (e.g., a checkbox) -# -# Arguments: -# none -# -# Results: -# A list of names of the query values - -proc ::ncgi::parse {} { - variable value - variable listRestrict 0 - variable varlist {} - if {[info exists value]} { - unset value - } - foreach {name val} [nvlist] { - if {![info exists value($name)]} { - lappend varlist $name - } - lappend value($name) $val - } - return $varlist -} - -# ::ncgi::input -# -# Like ncgi::parse, but with Don Libes cgi.tcl semantics. -# Form elements must have a trailing "List" in their name to be -# listified, otherwise this raises errors if an element appears twice. -# -# Arguments: -# fakeinput See ncgi::reset -# fakecookie The raw cookie string to use when testing. -# -# Results: -# The list of element names in the form - -proc ::ncgi::input {{fakeinput {}} {fakecookie {}}} { - variable value - variable varlist {} - variable listRestrict 1 - if {[info exists value]} { - unset value - } - if {[string length $fakeinput]} { - ncgi::reset $fakeinput - } - foreach {name val} [nvlist] { - set exists [info exists value($name)] - if {!$exists} { - lappend varlist $name - } - if {[string match "*List" $name]} { - # Accumulate a list of values for this name - lappend value($name) $val - } elseif {$exists} { - error "Multiple definitions of $name encountered in input.\ - If you're trying to do this intentionally (such as with select),\ - the variable must have a \"List\" suffix." - } else { - # Capture value with no list structure - set value($name) $val - } - } - return $varlist -} - -# ::ncgi::value -# -# Return the value of a named query element, or the empty string if -# it was not not specified. This only returns the first value of -# associated with the name. If you want them all (like all values -# of a checkbox), use ncgi::valueList -# -# Arguments: -# key The name of the query element -# default The value to return if the value is not present -# -# Results: -# The first value of the named element, or the default - -proc ::ncgi::value {key {default {}}} { - variable value - variable listRestrict - variable contenttype - if {[info exists value($key)]} { - if {$listRestrict} { - - # ::ncgi::input was called, and it already figured out if the - # user wants list structure or not. - - set val $value($key) - } else { - - # Undo the level of list structure done by ncgi::parse - - set val [lindex $value($key) 0] - } - if {[string match multipart/* [type]]} { - - # Drop the meta-data information associated with each part - - set val [lindex $val 1] - } - return $val - } else { - return $default - } -} - -# ::ncgi::valueList -# -# Return all the values of a named query element as a list, or -# the empty list if it was not not specified. This always returns -# lists - if you do not want the extra level of listification, use -# ncgi::value instead. -# -# Arguments: -# key The name of the query element -# -# Results: -# The first value of the named element, or "" - -proc ::ncgi::valueList {key {default {}}} { - variable value - if {[info exists value($key)]} { - return $value($key) - } else { - return $default - } -} - -# ::ncgi::setValue -# -# Jam a new value into the CGI environment. This is handy for preliminary -# processing that does data validation and cleanup. -# -# Arguments: -# key The name of the query element -# value This is a single value, and this procedure wraps it up in a list -# for compatibility with the ncgi::value array usage. If you -# want a list of values, use ngci::setValueList -# -# -# Side Effects: -# Alters the ncgi::value and possibly the ncgi::valueList variables - -proc ::ncgi::setValue {key value} { - variable listRestrict - if {$listRestrict} { - ncgi::setValueList $key $value - } else { - ncgi::setValueList $key [list $value] - } -} - -# ::ncgi::setValueList -# -# Jam a list of new values into the CGI environment. -# -# Arguments: -# key The name of the query element -# valuelist This is a list of values, e.g., for checkbox or multiple -# selections sets. -# -# Side Effects: -# Alters the ncgi::value and possibly the ncgi::valueList variables - -proc ::ncgi::setValueList {key valuelist} { - variable value - variable varlist - if {![info exists value($key)]} { - lappend varlist $key - } - - # This if statement is a workaround for another hack in - # ::ncgi::value that treats multipart form data - # differently. - if {[string match multipart/* [type]]} { - set value($key) [list [list {} [join $valuelist]]] - } else { - set value($key) $valuelist - } - return "" -} - -# ::ncgi::setDefaultValue -# -# Set a new value into the CGI environment if there is not already one there. -# -# Arguments: -# key The name of the query element -# value This is a single value, and this procedure wraps it up in a list -# for compatibility with the ncgi::value array usage. -# -# -# Side Effects: -# Alters the ncgi::value and possibly the ncgi::valueList variables - -proc ::ncgi::setDefaultValue {key value} { - ncgi::setDefaultValueList $key [list $value] -} - -# ::ncgi::setDefaultValueList -# -# Jam a list of new values into the CGI environment if the CGI value -# is not already defined. -# -# Arguments: -# key The name of the query element -# valuelist This is a list of values, e.g., for checkbox or multiple -# selections sets. -# -# Side Effects: -# Alters the ncgi::value and possibly the ncgi::valueList variables - -proc ::ncgi::setDefaultValueList {key valuelist} { - variable value - if {![info exists value($key)]} { - ncgi::setValueList $key $valuelist - return "" - } else { - return "" - } -} - -# ::ncgi::empty -- -# -# Return true if the CGI variable doesn't exist or is an empty string -# -# Arguments: -# name Name of the CGI variable -# -# Results: -# 1 if the variable doesn't exist or has the empty value - -proc ::ncgi::empty {name} { - return [expr {[string length [string trim [value $name]]] == 0}] -} - -# ::ncgi::import -# -# Map a CGI input into a Tcl variable. This creates a Tcl variable in -# the callers scope that has the value of the CGI input. An alternate -# name for the Tcl variable can be specified. -# -# Arguments: -# cginame The name of the form element -# tclname If present, an alternate name for the Tcl variable, -# otherwise it is the same as the form element name - -proc ::ncgi::import {cginame {tclname {}}} { - if {[string length $tclname]} { - upvar 1 $tclname var - } else { - upvar 1 $cginame var - } - set var [value $cginame] -} - -# ::ncgi::importAll -# -# Map a CGI input into a Tcl variable. This creates a Tcl variable in -# the callers scope for every CGI value, or just for those named values. -# -# Arguments: -# args A list of form element names. If this is empty, -# then all form value are imported. - -proc ::ncgi::importAll {args} { - variable varlist - if {[llength $args] == 0} { - set args $varlist - } - foreach cginame $args { - upvar 1 $cginame var - set var [value $cginame] - } -} - -# ::ncgi::redirect -# -# Generate a redirect by returning a header that has a Location: field. -# If the URL is not absolute, this automatically qualifies it to -# the current server -# -# Arguments: -# url The url to which to redirect -# -# Side Effects: -# Outputs a redirect header - -proc ::ncgi::redirect {url} { - global env - - if {![regexp -- {^[^:]+://} $url]} { - - # The url is relative (no protocol/server spec in it), so - # here we create a canonical URL. - - # request_uri The current URL used when dealing with relative URLs. - # proto http or https - # server The server, which we are careful to match with the - # current one in base Basic Authentication is being used. - # port This is set if it is not the default port. - - if {[info exists env(REQUEST_URI)]} { - # Not all servers have the leading protocol spec - regsub -- {^https?://[^/]*/} $env(REQUEST_URI) / request_uri - } elseif {[info exists env(SCRIPT_NAME)]} { - set request_uri $env(SCRIPT_NAME) - } else { - set request_uri / - } - - set port "" - if {[info exists env(HTTPS)] && $env(HTTPS) == "on"} { - set proto https - if {$env(SERVER_PORT) != 443} { - set port :$env(SERVER_PORT) - } - } else { - set proto http - if {$env(SERVER_PORT) != 80} { - set port :$env(SERVER_PORT) - } - } - # Pick the server from REQUEST_URI so it matches the current - # URL. Otherwise use SERVER_NAME. These could be different, e.g., - # "pop.scriptics.com" vs. "pop" - - if {[info exists env(REQUEST_URI)]} { - # Not all servers have the leading protocol spec - if {![regexp -- {^https?://([^/:]*)} $env(REQUEST_URI) x server]} { - set server $env(SERVER_NAME) - } - } else { - set server $env(SERVER_NAME) - } - if {[string match /* $url]} { - set url $proto://$server$port$url - } else { - regexp -- {^(.*/)[^/]*$} $request_uri match dirname - set url $proto://$server$port$dirname$url - } - } - ncgi::header text/html Location $url - puts "Please go to $url" -} - -# ncgi:header -# -# Output the Content-Type header. -# -# Arguments: -# type The MIME content type -# args Additional name, value pairs to specifiy output headers -# -# Side Effects: -# Outputs a normal header - -proc ::ncgi::header {{type text/html} args} { - variable cookieOutput - puts "Content-Type: $type" - foreach {n v} $args { - puts "$n: $v" - } - if {[info exists cookieOutput]} { - foreach line $cookieOutput { - puts "Set-Cookie: $line" - } - } - puts "" - flush stdout -} - -# ::ncgi::parseMimeValue -# -# Parse a MIME header value, which has the form -# value; param=value; param2="value2"; param3='value3' -# -# Arguments: -# value The mime header value. This does not include the mime -# header field name, but everything after it. -# -# Results: -# A two-element list, the first is the primary value, -# the second is in turn a name-value list corresponding to the -# parameters. Given the above example, the return value is -# { -# value -# {param value param2 value param3 value3} -# } - -proc ::ncgi::parseMimeValue {value} { - set parts [split $value \;] - set results [list [string trim [lindex $parts 0]]] - set paramList [list] - foreach sub [lrange $parts 1 end] { - if {[regexp -- {([^=]+)=(.+)} $sub match key val]} { - set key [string trim [string tolower $key]] - set val [string trim $val] - # Allow single as well as double quotes - if {[regexp -- {^["']} $val quote]} { ;# need a " for balance - if {[regexp -- ^${quote}(\[^$quote\]*)$quote $val x val2]} { - # Trim quotes and any extra crap after close quote - set val $val2 - } - } - lappend paramList $key $val - } - } - if {[llength $paramList]} { - lappend results $paramList - } - return $results -} - -# ::ncgi::multipart -# -# This parses multipart form data. -# Based on work by Steve Ball for TclHttpd, but re-written to use -# string first with an offset to iterate through the data instead -# of using a regsub/subst combo. -# -# Arguments: -# type The Content-Type, because we need boundary options -# query The raw multipart query data -# -# Results: -# An alternating list of names and values -# In this case, the value is a two element list: -# headers, which in turn is a list names and values -# content, which is the main value of the element -# The header name/value pairs come primarily from the MIME headers -# like Content-Type that appear in each part. However, the -# Content-Disposition header is handled specially. It has several -# parameters like "name" and "filename" that are important, so they -# are promoted to to the same level as Content-Type. Otherwise, -# if a header like Content-Type has parameters, they appear as a list -# after the primary value of the header. For example, if the -# part has these two headers: -# -# Content-Disposition: form-data; name="Foo"; filename="/a/b/C.txt" -# Content-Type: text/html; charset="iso-8859-1"; mumble='extra' -# -# Then the header list will have this structure: -# { -# content-disposition form-data -# name Foo -# filename /a/b/C.txt -# content-type {text/html {charset iso-8859-1 mumble extra}} -# } -# Note that the header names are mapped to all lowercase. You can -# use "array set" on the header list to easily find things like the -# filename or content-type. You should always use [lindex $value 0] -# to account for values that have parameters, like the content-type -# example above. Finally, not that if the value has a second element, -# which are the parameters, you can "array set" that as well. -# -proc ::ncgi::multipart {type query} { - - set parsedType [parseMimeValue $type] - if {![string match multipart/* [lindex $parsedType 0]]} { - return -code error "Not a multipart Content-Type: [lindex $parsedType 0]" - } - array set options [lindex $parsedType 1] - if {![info exists options(boundary)]} { - return -code error "No boundary given for multipart document" - } - set boundary $options(boundary) - - # The query data is typically read in binary mode, which preserves - # the \r\n sequence from a Windows-based browser. - # Also, binary data may contain \r\n sequences. - - if {[string match "*$boundary\r\n*" $query]} { - set lineDelim "\r\n" - # puts "DELIM" - } else { - set lineDelim "\n" - # puts "NO" - } - - # Iterate over the boundary string and chop into parts - - set len [string length $query] - # [string length $lineDelim]+2 is for "$lineDelim--" - set blen [expr {[string length $lineDelim] + 2 + \ - [string length $boundary]}] - set first 1 - set results [list] - set offset 0 - - # Ensuring the query data starts - # with a newline makes the string first test simpler - if {[string first $lineDelim $query 0]!=0} { - set query $lineDelim$query - } - while {[set offset [string first $lineDelim--$boundary $query $offset]] \ - >= 0} { - if {!$first} { - lappend results $formName [list $headers \ - [string range $query $off2 [expr {$offset -1}]]] - } else { - set first 0 - } - incr offset $blen - - # Check for the ending boundary, which is signaled by --$boundary-- - - if {[string equal "--" \ - [string range $query $offset [expr {$offset + 1}]]]} { - break - } - - # Split headers out from content - # The headers become a nested list structure: - # {header-name { - # value { - # paramname paramvalue ... } - # } - # } - - set off2 [string first "$lineDelim$lineDelim" $query $offset] - set headers [list] - set formName "" - foreach line [split [string range $query $offset $off2] $lineDelim] { - if {[regexp -- {([^: ]+):(.*)$} $line x hdrname value]} { - set hdrname [string tolower $hdrname] - set valueList [parseMimeValue $value] - if {[string equal $hdrname "content-disposition"]} { - - # Promote Conent-Disposition parameters up to headers, - # and look for the "name" that identifies the form element - - lappend headers $hdrname [lindex $valueList 0] - foreach {n v} [lindex $valueList 1] { - lappend headers $n $v - if {[string equal $n "name"]} { - set formName $v - } - } - } else { - lappend headers $hdrname $valueList - } - } - } - - if {$off2 > 0} { - # +[string length "$lineDelim$lineDelim"] for the - # $lineDelim$lineDelim - incr off2 [string length "$lineDelim$lineDelim"] - set offset $off2 - } else { - break - } - } - return $results -} - -# ::ncgi::cookie -# -# Return a *list* of cookie values, if present, else "" -# It is possible for multiple cookies with the same key -# to be present, so we return a list. -# -# Arguments: -# cookie The name of the cookie (the key) -# -# Results: -# A list of values for the cookie - -proc ::ncgi::cookie {cookie} { - global env - set result "" - if {[info exists env(HTTP_COOKIE)]} { - foreach pair [split $env(HTTP_COOKIE) \;] { - foreach {key value} [split [string trim $pair] =] { break ;# lassign } - if {[string compare $cookie $key] == 0} { - lappend result $value - } - } - } - return $result -} - -# ::ncgi::setCookie -# -# Set a return cookie. You must call this before you call -# ncgi::header or ncgi::redirect -# -# Arguments: -# args Name value pairs, where the names are: -# -name Cookie name -# -value Cookie value -# -path Path restriction -# -domain domain restriction -# -expires Time restriction -# -# Side Effects: -# Formats and stores the Set-Cookie header for the reply. - -proc ::ncgi::setCookie {args} { - variable cookieOutput - array set opt $args - set line "$opt(-name)=$opt(-value) ;" - foreach extra {path domain} { - if {[info exists opt(-$extra)]} { - append line " $extra=$opt(-$extra) ;" - } - } - if {[info exists opt(-expires)]} { - switch -glob -- $opt(-expires) { - *GMT { - set expires $opt(-expires) - } - default { - set expires [clock format [clock scan $opt(-expires)] \ - -format "%A, %d-%b-%Y %H:%M:%S GMT" -gmt 1] - } - } - append line " expires=$expires ;" - } - if {[info exists opt(-secure)]} { - append line " secure " - } - lappend cookieOutput $line -} DELETED modules/ncgi/ncgi.test Index: modules/ncgi/ncgi.test ================================================================== --- modules/ncgi/ncgi.test +++ /dev/null @@ -1,567 +0,0 @@ -# Tests for the cgi module. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 1998-2000 by Ajuba Solutions -# -# RCS: @(#) $Id: ncgi.test,v 1.14 2002/08/15 18:23:39 davidw Exp $ - -package require tcltest -namespace import -force ::tcltest::* - -set ncgiFile [file join [file dirname [info script]] ncgi.tcl] -source $ncgiFile -package require ncgi 1.2.1 - -test ncgi-1.1 {ncgi::reset} { - ncgi::reset - list [info exist ncgi::query] [info exist ncgi::contenttype] -} {0 0} - -test ncgi-1.2 {ncgi::reset} { - ncgi::reset query=reset - list $ncgi::query $ncgi::contenttype -} {query=reset {}} - -test ncgi-1.3 {ncgi::reset} { - ncgi::reset query=reset text/plain - list $ncgi::query $ncgi::contenttype -} {query=reset text/plain} - -test ncgi-2.1 {ncgi::query fake query data} { - ncgi::reset "fake=query" - ncgi::query - set ncgi::query -} "fake=query" - -test ncgi-2.2 {ncgi::query GET} { - ncgi::reset - set env(REQUEST_METHOD) GET - set env(QUERY_STRING) name=value - ncgi::query - set ncgi::query -} "name=value" - -test ncgi-2.3 {ncgi::query HEAD} { - ncgi::reset - set env(REQUEST_METHOD) HEAD - catch {unset env(QUERY_STRING)} - ncgi::query - set ncgi::query -} "" - -test ncgi-2.4 {ncgi::query POST} { - ncgi::reset - catch {unset env(QUERY_STRING)} - set env(REQUEST_METHOD) POST - set env(CONTENT_LENGTH) 10 - makeFile [format { - source %s - ncgi::query - puts $ncgi::query - } $ncgiFile] test1 - set f [open "|[list $::tcltest::tcltest test1]" r+] - puts $f "name=value" - flush $f - gets $f line - set line -} "name=value" - -test ncgi-2.5 {ncgi::test} { - ncgi::reset - set env(CONTENT_TYPE) text/html - ncgi::type -} text/html - -test ncgi-2.6 {ncgi::test} { - ncgi::reset foo=bar text/plain - set env(CONTENT_TYPE) text/html - ncgi::type -} text/plain - -test ncgi-3.1 {ncgi::decode} { - ncgi::decode abcdef0123 -} abcdef0123 - -test ncgi-3.2 {ncgi::decode} { - ncgi::decode {[abc]def$0123\x} -} {[abc]def$0123\x} - -test ncgi-3.3 {ncgi::decode} { - ncgi::decode {[a%25c]def$01%7E3\x%3D} -} {[a%c]def$01~3\x=} - -test ncgi-3.4 {ncgi::decode} { - ncgi::decode {hello+world} -} {hello world} - -test ncgi-4.1 {ncgi::encode} { - ncgi::encode abcdef0123 -} abcdef0123 - -test ncgi-4.2 {ncgi::encode} { - ncgi::encode "\[abc\]def\$0123\\x" -} {%5Babc%5Ddef%240123%5Cx} - -test ncgi-4.3 {ncgi::encode} { - ncgi::encode {hello world} -} {hello+world} - -test ncgi-4.4 {ncgi::encode} { - ncgi::encode "hello\nworld\r\tbar" -} {hello%0D%0Aworld%0D%09bar} - -test ncgi-5.1 {ncgi::nvlist} { - ncgi::reset "name=hello+world&name2=%7ewelch" - ncgi::nvlist -} {name {hello world} name2 ~welch} - -test ncgi-5.2 {ncgi::nvlist} { - ncgi::reset "name=&name2" application/x-www-urlencoded - ncgi::nvlist -} {name {} anonymous name2} - -test ncgi-5.3 {ncgi::nvlist} { - ncgi::reset "name=&name2" application/x-www-form-urlencoded - ncgi::nvlist -} {name {} anonymous name2} - -test ncgi-5.4 {ncgi::nvlist} { - ncgi::reset "name=&name2" application/xyzzy - set code [catch ncgi::nvlist err] - list $code $err -} {1 {Unknown Content-Type: application/xyzzy}} - -# multipart tests at the end because I'm too lazy to renumber the tests - -test ncgi-6.1 {ncgi::parse, anonymous values} { - ncgi::reset "name=&name2" - ncgi::parse -} {name anonymous} - -test ncgi-6.2 {ncgi::parse, no list restrictions} { - ncgi::reset "name=value&name=value2" - ncgi::parse -} {name} - -test ncgi-7.1 {ncgi::input} { - ncgi::reset - catch {unset env(REQUEST_METHOD)} - ncgi::input "name=value&name2=value2" -} {name name2} - -test ncgi-7.2 {ncgi::input} { - ncgi::reset "nameList=value1+stuff&nameList=value2+more" - ncgi::input - set ncgi::value(nameList) -} {{value1 stuff} {value2 more}} - -test ncgi-7.3 {ncgi::input} { - ncgi::reset "name=value&name=value2" - catch {ncgi::input} err - set err -} {Multiple definitions of name encountered in input. If you're trying to do this intentionally (such as with select), the variable must have a "List" suffix.} - -test ncgi-8.1 {ncgi::value} { - ncgi::reset "nameList=val+ue&nameList=value2" - ncgi::input - ncgi::value nameList -} {{val ue} value2} - -test ncgi-8.2 {ncgi::value} { - ncgi::reset "name=val+ue&name=value2" - ncgi::parse - ncgi::value name -} {val ue} - -test ncgi-8.3 {ncgi::value} { - ncgi::reset "name=val+ue&name=value2" - ncgi::parse - ncgi::value noname -} {} - -test ncgi-9.1 {ncgi::valueList} { - ncgi::reset "name=val+ue&name=value2" - ncgi::parse - ncgi::valueList name -} {{val ue} value2} - -test ncgi-9.2 {ncgi::valueList} { - ncgi::reset "name=val+ue&name=value2" - ncgi::parse - ncgi::valueList noname -} {} - -test ncgi-10.1 {ncgi::import} { - ncgi::reset "nameList=val+ue&nameList=value2" - ncgi::input - ncgi::import nameList - set nameList -} {{val ue} value2} - -test ncgi-10.2 {ncgi::import} { - ncgi::reset "nameList=val+ue&nameList=value2" - ncgi::input - ncgi::import nameList myx - set myx -} {{val ue} value2} - -test ncgi-10.3 {ncgi::import} { - ncgi::reset "nameList=val+ue&nameList=value2" - ncgi::input - ncgi::import noname - set noname -} {} - -test ncgi-10.4 {ncgi::importAll} { - ncgi::reset "name1=val+ue&name2=value2" - catch {unset name1} - catch {unset name2} - ncgi::parse - ncgi::importAll - list $name1 $name2 -} {{val ue} value2} - -test ncgi-10.4 {ncgi::importAll} { - ncgi::reset "name1=val+ue&name2=value2" - catch {unset name1} - catch {unset name2} - catch {unset name3} - ncgi::parse - ncgi::importAll name2 name3 - list [info exist name1] $name2 $name3 -} {0 value2 {}} - -set URL http://www.tcltk.com/index.html -test ncgi-11.1 {ncgi::redirect} { - set env(REQUEST_URI) http://www.scriptics.com/cgi-bin/test.cgi - set env(REQUEST_METHOD) GET - set env(QUERY_STRING) {} - set env(SERVER_NAME) www.scriptics.com - set env(SERVER_PORT) 80 - makeFile [format { - if {[catch { - source %s - ncgi::redirect %s - } err]} { - puts $err - } - } $ncgiFile $URL] test1 - set f [open "|[list $::tcltest::tcltest test1]" r+] - read $f -} "Content-Type: text/html\nLocation: $URL\n\nPlease go to $URL\n" - -set URL /elsewhere/foo.html -set URL2 http://www/elsewhere/foo.html -test ncgi-11.2 {ncgi::redirect} { - set env(REQUEST_URI) http://www/cgi-bin/test.cgi - set env(REQUEST_METHOD) GET - set env(QUERY_STRING) {} - set env(SERVER_NAME) www.scriptics.com - set env(SERVER_PORT) 80 - makeFile [format { - if {[catch { - source %s - ncgi::setCookie -name CookieName -value 12345 - ncgi::redirect %s - } err]} { - puts $err - } - } $ncgiFile $URL] test1 - set f [open "|[list $::tcltest::tcltest test1]" r+] - read $f -} "Content-Type: text/html\nLocation: $URL2\nSet-Cookie: CookieName=12345 ;\n\nPlease go to $URL2\n" - -set URL foo.html -set URL2 http://www.scriptics.com/cgi-bin/foo.html -test ncgi-11.3 {ncgi::redirect} { - set env(REQUEST_URI) http://www.scriptics.com/cgi-bin/test.cgi - set env(REQUEST_METHOD) GET - set env(QUERY_STRING) {} - set env(SERVER_NAME) www.scriptics.com - set env(SERVER_PORT) 80 - makeFile [format { - if {[catch { - source %s - ncgi::redirect %s - } err]} { - puts $err - } - } $ncgiFile $URL] test1 - set f [open "|[list $::tcltest::tcltest test1]" r+] - read $f -} "Content-Type: text/html\nLocation: $URL2\n\nPlease go to $URL2\n" - -set URL foo.html -set URL2 http://www.scriptics.com/cgi-bin/foo.html -test ncgi-11.4 {ncgi::redirect} { - set env(REQUEST_URI) /cgi-bin/test.cgi - set env(REQUEST_METHOD) GET - set env(QUERY_STRING) {} - set env(SERVER_NAME) www.scriptics.com - set env(SERVER_PORT) 80 - makeFile [format { - if {[catch { - source %s - ncgi::redirect %s - } err]} { - puts $err - } - } $ncgiFile $URL] test1 - set f [open "|[list $::tcltest::tcltest test1]" r+] - read $f -} "Content-Type: text/html\nLocation: $URL2\n\nPlease go to $URL2\n" - -set URL foo.html -set URL2 http://www.scriptics.com:8000/cgi-bin/foo.html -test ncgi-11.5 {ncgi::redirect} { - set env(REQUEST_URI) /cgi-bin/test.cgi - set env(REQUEST_METHOD) GET - set env(QUERY_STRING) {} - set env(SERVER_NAME) www.scriptics.com - set env(SERVER_PORT) 8000 - makeFile [format { - if {[catch { - source %s - ncgi::redirect %s - } err]} { - puts $err - } - } $ncgiFile $URL] test1 - set f [open "|[list $::tcltest::tcltest test1]" r+] - read $f -} "Content-Type: text/html\nLocation: $URL2\n\nPlease go to $URL2\n" - -set URL foo.html -set URL2 https://www.scriptics.com/cgi-bin/foo.html -test ncgi-11.6 {ncgi::redirect} { - set env(REQUEST_URI) /cgi-bin/test.cgi - set env(REQUEST_METHOD) GET - set env(QUERY_STRING) {} - set env(SERVER_NAME) www.scriptics.com - set env(SERVER_PORT) 443 - set env(HTTPS) "on" - makeFile [format { - if {[catch { - source %s - ncgi::redirect %s - } err]} { - puts $err - } - } $ncgiFile $URL] test1 - set f [open "|[list $::tcltest::tcltest test1]" r+] - read $f -} "Content-Type: text/html\nLocation: $URL2\n\nPlease go to $URL2\n" - -test ncgi-12.1 {ncgi::header} { - makeFile [format { - if {[catch { - source %s - ncgi::header - } err]} { - puts $err - } - } $ncgiFile] test1 - set f [open "|[list $::tcltest::tcltest test1]" r+] - read $f -} "Content-Type: text/html\n\n" - -test ncgi-12.2 {ncgi::header} { - makeFile [format { - if {[catch { - source %s - ncgi::header text/plain - } err]} { - puts $err - } - } $ncgiFile] test1 - set f [open "|[list $::tcltest::tcltest test1]" r+] - read $f -} "Content-Type: text/plain\n\n" - -test ncgi-12.3 {ncgi::header} { - makeFile [format { - if {[catch { - source %s - ncgi::header text/html X-Comment "This is a test" - } err]} { - puts $err - } - } $ncgiFile] test1 - set f [open "|[list $::tcltest::tcltest test1]" r+] - read $f -} "Content-Type: text/html\nX-Comment: This is a test\n\n" - -test ncgi-12.4 {ncgi::header} { - makeFile [format { - if {[catch { - source %s - ncgi::setCookie -name Name -value {The+Value} - ncgi::header - } err]} { - puts $err - } - } $ncgiFile] test1 - set f [open "|[list $::tcltest::tcltest test1]" r+] - read $f -} "Content-Type: text/html\nSet-Cookie: Name=The+Value ;\n\n" - -test ncgi-13.1 {ncgi::parseMimeValue} { - ncgi::parseMimeValue text/html -} text/html - -test ncgi-13.2 {ncgi::parseMimeValue} { - ncgi::parseMimeValue "text/html; charset=iso-8859-1" -} {text/html {charset iso-8859-1}} - -test ncgi-13.3 {ncgi::parseMimeValue} { - ncgi::parseMimeValue "text/html; charset='iso-8859-1'" -} {text/html {charset iso-8859-1}} - -test ncgi-13.4 {ncgi::parseMimeValue} { - ncgi::parseMimeValue "text/html; charset=\"iso-8859-1\"" -} {text/html {charset iso-8859-1}} - -test ncgi-13.5 {ncgi::parseMimeValue} { - ncgi::parseMimeValue "text/html; charset=\"iso-8859-1\"; ignored" -} {text/html {charset iso-8859-1}} - -test ncgi-13.6 {ncgi::parseMimeValue} { - ncgi::parseMimeValue "text/html; charset=\"iso-8859-1\"morecrap" -} {text/html {charset iso-8859-1}} - - -test ncgi-14.1 {ncgi::multipart} { - catch {ncgi::multipart "application/x-www-urlencoded" name=val+ue} err - set err -} {Not a multipart Content-Type: application/x-www-urlencoded} - -test ncgi-14.2 {ncgi::multipart} { - catch {ncgi::multipart "multipart/form-data" {}} err - set err -} {No boundary given for multipart document} - -test ncgi-14.3 {ncgi::multipart} { - set in [open [file join [file dirname [info script]] formdata.txt]] - set X [read $in] - close $in - - foreach line [split $X \n] { - if {[string length $line] == 0} { - break - } - if {[regexp {^Content-Type: (.*)$} $line x type]} { - break - } - } - regsub ".*?\n\n" $X {} X - - ncgi::reset $X $type - ncgi::multipart $type $X -} {field1 {{content-disposition form-data name field1} value} field2 {{content-disposition form-data name field2} {another value}} the_file_naame {{content-disposition form-data name the_file_naame filename {C:\Program Files\Netscape\Communicator\Program\nareadme.htm} content-type text/html} { -

- Netscape Address Book Sync for Palm Pilot - User Guide -

- - -}}} - -test ncgi-14.4 {ncgi::multipart} { - set in [open [file join [file dirname [info script]] formdata.txt]] - set X [read $in] - close $in - - foreach line [split $X \n] { - if {[string length $line] == 0} { - break - } - if {[regexp {^Content-Type: (.*)$} $line x type]} { - break - } - } - regsub ".*?\n\n" $X {} X - - ncgi::reset $X $type - ncgi::parse - list [ncgi::value field1] [ncgi::value field2] [ncgi::value the_file_naame] -} {value {another value} { -

- Netscape Address Book Sync for Palm Pilot - User Guide -

- - -}} - -test ncgi-14.5 {ncgi::multipart--check binary file} { - set in [open [file join [file dirname [info script]] formdata.txt]] - - # Read the file in as though it were binary. - fconfigure $in -translation binary - set X [read $in] - close $in - - foreach line [split $X \n] { - if {[string length $line] == 0} { - break - } - if {[regexp {^Content-Type: (.*)$} $line x type]} { - break - } - } - regsub ".*?\n\n" $X {} X - - ncgi::reset $X $type - ncgi::parse - set content [ncgi::value the_file_naame] - list [ncgi::value field1] [ncgi::value field2] $content -} "value {another value} {\r -

\r - Netscape Address Book Sync for Palm Pilot\r - User Guide\r -

\r -\r -\r -}" - -test ncgi-14.6 {ncgi::multipart setValue} { - set in [open [file join [file dirname [info script]] formdata.txt]] - set X [read $in] - close $in - - foreach line [split $X \n] { - if {[string length $line] == 0} { - break - } - if {[regexp {^Content-Type: (.*)$} $line x type]} { - break - } - } - regsub ".*?\n\n" $X {} X - - ncgi::reset $X $type - ncgi::parse - ncgi::setValue userval1 foo - ncgi::setValue userval2 "a b" - list [ncgi::value field1] [ncgi::value field2] [ncgi::value userval1] [ncgi::value userval2] [ncgi::value the_file_naame] -} {value {another value} foo {a b} { -

- Netscape Address Book Sync for Palm Pilot - User Guide -

- - -}} - -test ncgi-15.1 {ncgi::setValue} { - ncgi::reset "nameList=val+ue&nameList=value2" - ncgi::input - ncgi::setValue foo 1 - ncgi::setValue bar "a b" - list [ncgi::value nameList] [ncgi::value foo] [ncgi::value bar] -} {{{val ue} value2} 1 {a b}} - -::tcltest::cleanupTests DELETED modules/ncgi/pkgIndex.tcl Index: modules/ncgi/pkgIndex.tcl ================================================================== --- modules/ncgi/pkgIndex.tcl +++ /dev/null @@ -1,12 +0,0 @@ -# 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. - -if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded ncgi 1.2.2 [list source [file join $dir ncgi.tcl]] DELETED modules/nntp/ChangeLog Index: modules/nntp/ChangeLog ================================================================== --- modules/nntp/ChangeLog +++ /dev/null @@ -1,67 +0,0 @@ -2003-04-11 Andreas Kupries - - * nntp.man: - * nntp.tcl: - * pkgIndex.tcl: Set version of the package to to 0.2.1 - -2003-02-24 David N. Welton - - * nntp.tcl (::nntp::squirt): Use if, string match instead of - regsub. - -2003-02-06 David N. Welton - - * nntp.tcl (::nntp::fetch): Use 'string match' instead of regexp. - Use if string match ... string range instead of regsub (it's - about twice as fast in a small test I ran). - -2003-01-16 Andreas Kupries - - * nntp.man: More semantic markup, less visual one. - -2002-08-19 Andreas Kupries - - * nntp.man: Added example, updated reference from rfc 850 to rfc - 1036. See Tcllib SF #597102, by Jussi Kuosa - . - * nntp.n: Out of date. Deprecated. - -2002-03-25 Andreas Kupries - - * nntp.man: New file, doctools manpage. - -2002-01-16 Andreas Kupries - - * Bumped version to 0.2 - -2002-01-16 Andreas Kupries - - * nntp.tcl: Fixed bug #502250 reported by Andreas Otto - which caused the package to wrap each - message into braces, causing nntp servers to reject the data. - -2001-07-10 Andreas Kupries - - * nntp.tcl: Frink 2.2 run, fixed dubious code. - -2001-06-21 Andreas Kupries - - * nntp.tcl: Fixed dubious code reported by frink. - -2000-06-20 Dan Kuchler - - * Code cleanup and bug fixes - -2000-06-18 Dan Kuchler - - * Fixed documentation bug in man page for xpat - -2000-06-16 Dan Kuchler - - * rfc977.txt: RFC for NNTP - - * pkgIndex.tcl - * nntp.tcl: Initial implementation of a nntp client package. - - * nntp.n: Initial documentation for the package. - DELETED modules/nntp/nntp.man Index: modules/nntp/nntp.man ================================================================== --- modules/nntp/nntp.man +++ /dev/null @@ -1,313 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[manpage_begin nntp n 1.5.1] -[moddesc {Tcl NNTP Client Library}] -[titledesc {Tcl client for the NNTP protocol}] -[require Tcl 8.2] -[require nntp [opt 0.2.1]] -[description] - -The package [package nntp] provides a simple Tcl-only client library -for the NNTP protocol. It works by opening the standard NNTP socket -on the server, and then providing a Tcl API to access the NNTP -protocol commands. All server errors are returned as Tcl errors -(thrown) which must be caught with the Tcl [cmd catch] command. - -[section COMMANDS] - -[list_begin definitions] - -[call [cmd ::nntp::nntp] [opt [arg host]] [opt [arg port]] [opt [arg nntpName]]] - -The command opens a socket connection to the specified NNTP server and -creates a new nntp object with an associated global Tcl command whose -name is [arg nntpName]. This command may be used to access the various -NNTP protocol commands for the new connection. The default [arg port] -number is "119" and the default [arg host] is "news". These defaults -can be overridden with the environment variables [var NNTPPORT] and -[var NNTPHOST] respectively. - -[nl] - -Some of the commands supported by this package are not part of the -nntp rfc (rfc 977) and will not be available (or implemented) on all -nntp servers. - -[nl] - -The access command [arg nntpName] has the following general form: - -[list_begin definitions] - -[call [arg nntpName] [method method] [opt [arg "arg arg ..."]]] - -[arg Option] and the [arg arg]s determine the exact behavior of the -command. - -[list_end] - -[call [arg nntpName] [method article] [opt [arg msgid]]] - -Query the server for article [arg msgid] from the current group. The article -is returned as a valid tcl list which contains the headers, followed by -a blank line, and then followed by the body of the article. Each element -in the list is one line of the article. - -[call [arg nntpName] [method authinfo] [opt [arg user]] [opt [arg pass]]] - -Send authentication information (username and password) to the server. - -[call [arg nntpName] [method body] [opt [arg msgid]]] - -Query the server for the body of the article [arg msgid] from the current -group. The body of the article is returned as a valid tcl list. Each element -in the list is one line of the body of the article. - -[call [arg nntpName] [method date]] - -Query the server for the servers current date. The date is returned in the -format [emph YYYYMMDDHHMMSS]. - -[call [arg nntpName] [method group] [opt [arg group]]] - -Optionally set the current group, and retrieve information about the -currently selected group. Returns the estimated number of articles in -the group followed by the number of the first article in the group, followed -by the last article in the group, followed by the name of the group. - -[call [arg nntpName] [method head] [opt [arg msgid]]] - -Query the server for the headers of the article [arg msgid] from the current -group. The headers of the article are returned as a valid tcl list. Each element -in the list is one line of the headers of the article. - -[call [arg nntpName] [method help]] - -Retrieves a list of the commands that are supported by the news server that -is currently attached to. - -[call [arg nntpName] [method last]] - -Sets the current article pointer to point to the previous message (if there is -one) and returns the msgid of that message. - -[call [arg nntpName] [method list]] - -Returns a tcl list of valid newsgroups and associated information. Each -newsgroup is returned as an element in the tcl list with the following format: -[example { - group last first p -}] -where is the name of the newsgroup, is the number of -the last known article currently in that newsgroup, is the -number of the first article currently in the newsgroup, and

is -either 'y' or 'n' indicating whether posting to this newsgroup is -allowed ('y') or prohibited ('n'). -[nl] -The and fields will always be numeric. They may have -leading zeros. If the field evaluates to less than the - field, there are no articles currently on file in the -newsgroup. - -[call [arg nntpName] [method listgroup] [opt [arg group]]] - -Query the server for a list of all the messages (message numbers) in the -group specified by the argument [arg group] or by the current group if -the [arg group] argument was not passed. - -[call [arg nntpName] [method mode_reader]] - -Query the server for its nntp 'MODE READER' response string. - -[call [arg nntpName] [method newgroups] [arg since]] - -Query the server for a list of all the new newsgroups created since the time -specified by the argument [arg since]. The argument [arg since] can be any -time string that is understood by [cmd {clock scan}]. The tcl list of newsgroups -is returned in a similar form to the list of groups returned by the -[cmd {nntpName list}] command. Each element of the list has the form: - -[example { - group last first p -}] -where is the name of the newsgroup, is the number of -the last known article currently in that newsgroup, is the -number of the first article currently in the newsgroup, and

is -either 'y' or 'n' indicating whether posting to this newsgroup is -allowed ('y') or prohibited ('n'). - -[call [arg nntpName] [method newnews]] - -Query the server for a list of new articles posted to the current group in the -last day. - -[call [arg nntpName] [method newnews] [arg since]] - -Query the server for a list of new articles posted to the current group since -the time specified by the argument [arg since]. The argument [arg since] can -be any time string that is understood by [cmd {clock scan}]. - -[call [arg nntpName] [method newnews] [arg group] [opt [arg since]]] - -Query the server for a list of new articles posted to the group specified by -the argument [arg group] since the time specified by the argument [arg since] -(or in the past day if no [arg since] argument is passed. The argument -[arg since] can be any time string that is understood by [cmd {clock scan}]. - -[call [arg nntpName] [method next]] - -Sets the current article pointer to point to the next message (if there is -one) and returns the msgid of that message. - -[call [arg nntpName] [method post] [arg article]] - -Posts an article of the form specified in RFC 1036 (successor to RFC -850) to the current news group. - -[call [arg nntpName] [method slave]] - -Identifies a connection as being made from a slave nntp server. This might -be used to indicate that the connection is serving multiple people and should -be given priority. Actual use is entirely implementation dependent and may -vary from server to server. - -[call [arg nntpName] [method stat] [opt [arg msgid]]] - -The stat command is similar to the article command except that no -text is returned. When selecting by message number within a group, -the stat command serves to set the current article pointer without -sending text. The returned acknowledgment response will contain the -message-id, which may be of some value. Using the stat command to -select by message-id is valid but of questionable value, since a -selection by message-id does NOT alter the "current article pointer" - -[call [arg nntpName] [method quit]] - -Gracefully close the connection after sending a NNTP QUIT command down -the socket. - -[call [arg nntpName] [method xgtitle] [opt [arg group_pattern]]] - -Returns a tcl list where each element is of the form: -[example { -newsgroup description -}] -If a [arg group_pattern] is specified then only newsgroups that match -the pattern will have their name and description returned. - -[call [arg nntpName] [method xhdr] [arg field] [opt [arg range]]] - -Returns the specified header field value for the current message or for a -list of messages from the current group. [arg field] is the title of a -field in the header such as from, subject, date, etc. If [arg range] is -not specified or is "" then the current message is queried. The command -returns a list of elements where each element has the form of: -[example { - msgid value -}] -Where msgid is the number of the message and value is the value set for the -queried field. The [arg range] argument can be in any of the following forms: - -[list_begin definitions] - -[lst_item [const {""}]] - -The current message is queried. - -[lst_item [arg msgid1]-[arg msgid2]] - -All messages between [arg msgid1] and [arg msgid2] -(including [arg msgid1] and [arg msgid2]) are queried. - -[lst_item "[arg msgid1] [arg msgid2]"] - -All messages between [arg msgid1] and [arg msgid2] -(including [arg msgid1] and [arg msgid2]) are queried. - -[list_end] - - -[call [arg nntpName] [method xover] [opt [arg range]]] - -Returns header information for the current message or for a range of messages -from the current group. The information is returned in a tcl list -where each element is of the form: -[example { - msgid subject from date idstring bodysize headersize xref -}] -If [arg range] is not specified or is "" then the current message is queried. -The [arg range] argument can be in any of the following forms: - -[list_begin definitions] - - -[lst_item [const {""}]] - -The current message is queried. - -[lst_item [arg msgid1]-[arg msgid2]] - -All messages between [arg msgid1] and [arg msgid2] -(including [arg msgid1] and [arg msgid2]) are queried. - -[lst_item "[arg msgid1] [arg msgid2]"] - -All messages between [arg msgid1] and [arg msgid2] -(including [arg msgid1] and [arg msgid2]) are queried. - -[list_end] - - -[call [arg nntpName] [method xpat] [arg field] [arg range] [opt [arg pattern_list]]] - -Returns the specified header field value for a specified message or for a -list of messages from the current group where the messages match the -pattern(s) given in the pattern_list. [arg field] is the title of a -field in the header such as from, subject, date, etc. The information is -returned in a tcl list where each element is of the form: -[example { - msgid value -}] -Where msgid is the number of the message and value is the value set for the -queried field. The [arg range] argument can be in any of the following forms: - -[list_begin definitions] - -[lst_item [arg msgid]] - -The message specified by [arg msgid] is queried. - -[lst_item [arg msgid1]-[arg msgid2]] - -All messages between [arg msgid1] and [arg msgid2] -(including [arg msgid1] and [arg msgid2]) are queried. - -[lst_item "[arg msgid1] [arg msgid2]"] - -All messages between [arg msgid1] and [arg msgid2] -(including [arg msgid1] and [arg msgid2]) are queried. - -[list_end] -[list_end] - -[section EXAMPLE] - -A bigger example for posting a single article. - -[para] -[example { - package require nntp - set n [nntp::nntp NNTP_SERVER] - $n post "From: USER@DOMAIN.EXT (USER_FULL) - Path: COMPUTERNAME!USERNAME - Newsgroups: alt.test - Subject: Tcl test post -ignore - Message-ID: <[pid][clock seconds] - @COMPUTERNAME> - Date: [clock format [clock seconds] -format "%a, %d % - b %y %H:%M:%S GMT" -gmt true] - - Test message body" -}] - -[keywords news nntp nntpclient rfc1030 rfc977] -[manpage_end] DELETED modules/nntp/nntp.n Index: modules/nntp/nntp.n ================================================================== --- modules/nntp/nntp.n +++ /dev/null @@ -1,247 +0,0 @@ -'\" -'\" Copyright (c) 2000 by Ajuba Solutions. -'\" All rights reserved. -'\" -'\" RCS: @(#) $Id: nntp.n,v 1.6 2002/01/18 20:51:16 andreas_kupries Exp $ -'\" -.so man.macros -.TH nntp n 0.2 nntp "Tcl NNTP Client Library" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -nntp \- Tcl client for the NNTP protocol -.SH SYNOPSIS -\fBpackage require Tcl 8.2\fR -.sp -\fBpackage require nntp ?0.2?\fR -.sp -\fB::nntp::nntp\fR \fR?\fIhost\fR? \fR?\fIport\fR? \fR?\fInntpName\fR? -.sp - -.BE -.SH DESCRIPTION -.PP -The \fBnntp\fR package provides a simple Tcl-only client library for -the NNTP protocol. It works by opening the standard NNTP socket -on the server, and then providing a Tcl API to access the NNTP protocol -commands. All server errors are returned as Tcl errors (thrown) which -must be caught with the Tcl \fBcatch\fR command. The \fB::nntp::nntp\fR -command creates a new nntp object with an associated Tcl command whose name -is returned by the \fB::nntp::nntp\fR command (\fBnntpName\fR). This command -may be used to access the various NNTP protocol commands. Some of the -commands supported by this package are not part of the nntp rfc (rfc 977) -and will not be available (or implemented) on all nntp servers. The commands -have the following general form: -.CS -\fBnntpName\fR \fIoption \fR?\fIarg arg ...\fR? -.CE -\fIOption\fR and the \fIarg\fRs -determine the exact behavior of the command. - -.SH COMMANDS -.TP -\fB::nntp::nntp\fR \fR?\fIhost\fR? \fR?\fIport\fR? \fR?\fInntpName\fR? -Open a socket connection to a NNTP server. The command returns the name -of the global command that can be used to access the nntp connection -subsequently. The default port number is \fB119\fR and the default server is -\fBnews\fR which can be overridden with the environment variables NNTPPORT and -NNTPHOST respectively. -.TP -\fBnntpName article\fR \fR?\fImsgid\fR?\fR -Query the server for article \fImsgid\fR from the current group. The article -is returned as a valid tcl list which contains the headers, followed by -a blank line, and then followed by the body of the article. Each element -in the list is one line of the article. -.TP -\fBnntpName authinfo\fR \fR?\fIuser\fR?\fR \fR?\fIpass\fR?\fR -Send authentication information (username and password) to the server. -.TP -\fBnntpName body\fR \fR?\fImsgid\fR?\fR -Query the server for the body of the article \fImsgid\fR from the current -group. The body of the article is returned as a valid tcl list. Each element -in the list is one line of the body of the article. -.TP -\fBnntpName date\fR -Query the server for the servers current date. The date is returned in the -format YYYYMMDDHHMMSS -.TP -\fBnntpName group\fR \fR?\fIgroup\fR?\fR -Optionally set the current group, and retrieve information about the -currently selected group. Returns the estimated number of articles in -the group followed by the number of the first article in the group, followed -by the last article in the group, followed by the name of the group. -.TP -\fBnntpName head\fR \fR?\fImsgid\fR?\fR -Query the server for the headers of the article \fImsgid\fR from the current -group. The headers of the article are returned as a valid tcl list. Each element -in the list is one line of the headers of the article. -.TP -\fBnntpName help\fR -Retrieves a list of the commands that are supported by the news server that -is currently attached to. -.TP -\fBnntpName last\fR -Sets the current article pointer to point to the previous message (if there is -one) and returns the msgid of that message. -.TP -\fBnntpName list\fR -Returns a tcl list of valid newsgroups and associated information. Each -newsgroup is returned as an element in the tcl list with the following format: -.sp - group last first p -.sp -where is the name of the newsgroup, is the number of -the last known article currently in that newsgroup, is the -number of the first article currently in the newsgroup, and

is -either 'y' or 'n' indicating whether posting to this newsgroup is -allowed ('y') or prohibited ('n'). -.sp -The and fields will always be numeric. They may have -leading zeros. If the field evaluates to less than the - field, there are no articles currently on file in the -newsgroup. -.TP -\fBnntpName listgroup\fR \fI?\fIgroup\fR?\fR -Query the server for a list of all the messages (message numbers) in the -group specified by the argument \fIgroup\fR or by the current group if -the \fIgroup\fR argument was not passed. -.TP -\fBnntpName mode_reader\fR -Query the server for its nntp 'MODE READER' response string. -.TP -\fBnntpName newgroups\fR \fIsince\fR -Query the server for a list of all the new newsgroups created since the time -specified by the argument \fIsince\fR. The argument \fIsince\fR can be any -time string that is understood by \fBclock scan\fR. The tcl list of newsgroups -is returned in a similar form to the list of groups returned by the \fBnntpName list\fR command. Each element of the list has the form: -.sp - group last first p -.sp -where is the name of the newsgroup, is the number of -the last known article currently in that newsgroup, is the -number of the first article currently in the newsgroup, and

is -either 'y' or 'n' indicating whether posting to this newsgroup is -allowed ('y') or prohibited ('n'). -.TP -\fBnntpName newnews\fR -Query the server for a list of new articles posted to the current group in the -last day. -.TP -\fBnntpName newnews\fR \fIsince\fR -Query the server for a list of new articles posted to the current group since -the time specified by the argument \fIsince\fR. The argument \fIsince\fR can -be any time string that is understood by \fBclock scan\fR. -.TP -\fBnntpName newnews\fR \fIgroup\fR \fR?\fIsince\fR?\fR -Query the server for a list of new articles posted to the group specified by -the argument \fIgroup\fR since the time specified by the argument \fIsince\fR -(or in the past day if no \fIsince\fR argument is passed. The argument -\fIsince\fR can be any time string that is understood by \fBclock scan\fR. -.TP -\fBnntpName next\fR -Sets the current article pointer to point to the next message (if there is -one) and returns the msgid of that message. -.TP -\fBnntpName post\fR \fIarticle\fR -Posts an article of the form specified in RFC 850 to the current news group. -.TP -\fBnntpName slave\fR -Identifies a connection as being made from a slave nntp server. This might -be used to indicate that the connection is serving multiple people and should -be given priority. Actual use is entirely implementation dependent and may -vary from server to server. -.TP -\fBnntpName stat\fR \fI?\fImsgid\fR?\fR -The stat command is similar to the article command except that no -text is returned. When selecting by message number within a group, -the stat command serves to set the current article pointer without -sending text. The returned acknowledgment response will contain the -message-id, which may be of some value. Using the stat command to -select by message-id is valid but of questionable value, since a -selection by message-id does NOT alter the "current article pointer" -.TP -\fBnntpName quit\fR -Gracefully close the connection after sending a NNTP QUIT command down -the socket. -.TP -\fBnntpName xgtitle\fR \fI?\fIgroup_pattern\fR?\fR -Returns a tcl list where each element is of the form: -.sp -newsgroup description -.sp -If a \fIgroup_pattern\fR is specified then only newsgroups that match -the pattern will have their name and description returned. -.TP -\fBnntpName xhdr\fR \fIfield\fR \fI?\fIrange\fR?\fR -Returns the specified header field value for the current message or for a -list of messages from the current group. \fIfield\fR is the title of a -field in the header such as from, subject, date, etc. If \fIrange\fR is -not specified or is "" then the current message is queried. The command -returns a list of elements where each element has the form of: -.sp -msgid value -.sp -Where msgid is the number of the message and value is the value set for the -queried field. The \fIrange\fR argument can be in any of the following forms: -.RS -.TP -\fB""\fR -The current message is queried. -.TP -\fBmsgid1-msgid2\fR -All messages between msgid1 and msgid2 (including msgid1 and msgid2) are queried. -.TP -\fBmsgid1 msgid2\fR -All messages between msgid1 and msgid2 (including msgid1 and msgid2) are queried. -.RE -.TP -\fBnntpName xover\fR \fI?\fIrange\fR?\fR -Returns header information for the current message or for a range of messages -from the current group. The information is returned in a tcl list -where each element is of the form: -.sp -msgid subject from date idstring bodysize headersize xref -.sp -If \fIrange\fR is not specified or is "" then the current message is queried. -The \fIrange\fR argument can be in any of the following forms: -.RS -.TP -\fB""\fR -The current message is queried. -.TP -\fBmsgid1-msgid2\fR -All messages between msgid1 and msgid2 (including msgid1 and msgid2) are queried. -.TP -\fBmsgid1 msgid2\fR -All messages between msgid1 and msgid2 (including msgid1 and msgid2) are queried. -.RE -.TP -\fBnntpName xpat\fR \fIfield\fR \fIrange\fR \fI?\fIpattern_list\fR?\fR -Returns the specified header field value for a specified message or for a -list of messages from the current group where the messages match the -pattern(s) given in the pattern_list. \fIfield\fR is the title of a -field in the header such as from, subject, date, etc. The information is -returned in a tcl list where each element is of the form: -.sp -msgid value -.sp -Where msgid is the number of the message and value is the value set for the -queried field. The \fIrange\fR argument can be in any of the following forms: -.RS -.TP -\fBmsgid\fR -The message specified by msgid is queried. -.TP -\fBmsgid1-msgid2\fR -All messages between msgid1 and msgid2 (including msgid1 and msgid2) are queried. -.TP -\fBmsgid1 msgid2\fR -All messages between msgid1 and msgid2 (including msgid1 and msgid2) are queried. -.RE -.TP -.SH KEYWORDS -news, nntp, nntpclient - - - - DELETED modules/nntp/nntp.tcl Index: modules/nntp/nntp.tcl ================================================================== --- modules/nntp/nntp.tcl +++ /dev/null @@ -1,928 +0,0 @@ -# nntp.tcl -- -# -# nntp implementation for Tcl. -# -# Copyright (c) 1998-2000 by Ajuba Solutions. -# All rights reserved. -# -# RCS: @(#) $Id: nntp.tcl,v 1.10 2003/04/11 20:04:39 andreas_kupries Exp $ - -package require Tcl 8.2 -package provide nntp 0.2.1 - -namespace eval ::nntp { - # The socks variable holds the handle to the server connections - variable socks - - # The counter is used to help create unique connection names - variable counter 0 - - # commands is the list of subcommands recognized by nntp - variable commands [list \ - "article" \ - "authinfo" \ - "body" \ - "date" \ - "group" \ - "head" \ - "help" \ - "last" \ - "list" \ - "listgroup" \ - "mode_reader" \ - "newgroups" \ - "newnews" \ - "next" \ - "post" \ - "stat" \ - "quit" \ - "xgtitle" \ - "xhdr" \ - "xover" \ - "xpat" \ - ] - - set ::nntp::eol "\n" - - # only export one command, the one used to instantiate a new - # nntp connection - namespace export nntp - -} - -# ::nntp::nntp -- -# -# Create a new nntp connection. -# -# Arguments: -# server - The name of the nntp server to connect to (optional). -# port - The port number to connect to (optional). -# name - The name of the nntp connection to create (optional). -# -# Results: -# Creates a connection to the a nntp server. By default the -# connection is established with the machine 'news' at port '119' -# These defaults can be overridden with the environment variables -# NNTPPORT and NNTPHOST, or can be passed as optional arguments - -proc ::nntp::nntp {{server ""} {port ""} {name ""}} { - global env - variable connections - variable counter - variable socks - - # If a name wasn't specified for the connection, create a new 'unique' - # name for the connection - - if { [llength [info level 0]] < 4 } { - set counter 0 - set name "nntp${counter}" - while {[lsearch -exact [info commands] $name] >= 0} { - incr counter - set name "nntp${counter}" - } - } - - if { ![string equal [info commands ::$name] ""] } { - error "command \"$name\" already exists, unable to create nntp connection" - } - - upvar 0 ::nntp::${name}data data - - set socks($name) [list ] - - # Initialize instance specific variables - - set data(debug) 0 - set data(eol) "\n" - - # Logic to determine whether to use the specified nntp server, or to use - # the default - - if {$server == ""} { - if {[info exists env(NNTPSERVER)]} { - set data(host) "$env(NNTPSERVER)" - } else { - set data(host) "news" - } - } else { - set data(host) $server - } - - # Logic to determine whether to use the specified nntp port, or to use the - # default. - - if {$port == ""} { - if {[info exists env(NNTPPORT)]} { - set data(port) $env(NNTPPORT) - } else { - set data(port) 119 - } - } else { - set data(port) $port - } - - set data(code) 0 - set data(mesg) "" - set data(addr) "" - - set sock [socket $data(host) $data(port)] - - set data(sock) $sock - - # Create the command to manipulate the nntp connection - - interp alias {} ::$name {} ::nntp::NntpProc $name - - ::nntp::response $name - - return $name -} - -# ::nntp::NntpProc -- -# -# Command that processes all nntp object commands. -# -# Arguments: -# name name of the nntp object to manipulate. -# args command name and args for the command. -# -# Results: -# Calls the appropriate nntp procedure for the command specified in -# 'args' and passes 'args' to the command/procedure. - -proc ::nntp::NntpProc {name {cmd ""} args} { - - # Do minimal args checks here - - if { [llength [info level 0]] < 3 } { - error "wrong # args: should be \"$name option ?arg arg ...?\"" - } - - # Split the args into command and args components - - if { [llength [info commands ::nntp::_$cmd]] == 0 } { - variable commands - set optlist [join $commands ", "] - set optlist [linsert $optlist "end-1" "or"] - error "bad option \"$cmd\": must be $optlist" - } - - # Call the appropriate command with its arguments - - return [eval [list ::nntp::_$cmd $name] $args] -} - -# ::nntp::okprint -- -# -# Used to test the return code stored in data(code) to -# make sure that it is alright to right to the socket. -# -# Arguments: -# name name of the nntp object. -# -# Results: -# Either throws an error describing the failure, or -# 'args' and passes 'args' to the command/procedure or -# returns 1 for 'OK' and 0 for error states. - -proc ::nntp::okprint {name} { - upvar 0 ::nntp::${name}data data - - if {$data(code) >=400} { - set val [expr {(0 < $data(code)) && ($data(code) < 400)}] - error "NNTPERROR: $data(code) $data(mesg)" - } - - # Codes less than 400 are good - - return [expr {(0 < $data(code)) && ($data(code) < 400)}] -} - -# ::nntp::message -- -# -# Used to format data(mesg) for printing to the socket -# by appending the appropriate end of line character which -# is stored in data(eol). -# -# Arguments: -# name name of the nntp object. -# -# Results: -# Returns a string containing the message from data(mesg) followed -# by the eol character(s) stored in data(eol) - -proc ::nntp::message {name} { - upvar 0 ::nntp::${name}data data - - return "$data(mesg)$data(eol)" -} - -################################################# -# -# NNTP Methods -# - -# ::nntp::_article -- -# -# Internal article proc. Called by the 'nntpName article' command. -# Retrieves the article specified by msgid, in the group specified by -# the 'nntpName group' command. If no msgid is specified the current -# (or first) article in the group is retrieved -# -# Arguments: -# name name of the nntp object. -# msgid The article number to retrieve -# -# Results: -# Returns the message (if there is one) from the specified group as -# a valid tcl list where each element is a line of the message. -# If no article is found, the "" string is returned. -# -# According to RFC 977 the responses are: -# -# 220 n article retrieved - head and body follow -# (n = article number, = message-id) -# 221 n article retrieved - head follows -# 222 n article retrieved - body follows -# 223 n article retrieved - request text separately -# 412 no newsgroup has been selected -# 420 no current article has been selected -# 423 no such article number in this group -# 430 no such article found -# - -proc ::nntp::_article {name {msgid ""}} { - upvar 0 ::nntp::${name}data data - - set data(cmnd) "fetch" - return [::nntp::command $name "ARTICLE $msgid"] -} - -# ::nntp::_authinfo -- -# -# Internal authinfo proc. Called by the 'nntpName authinfo' command. -# Passes the username and password for a nntp server to the nntp server. -# -# Arguments: -# name Name of the nntp object. -# user The username for the nntp server. -# pass The password for 'username' on the nntp server. -# -# Results: -# Returns the result of the attempts to set the username and password -# on the nntp server ( 1 if successful, 0 if failed). - -proc ::nntp::_authinfo {name {user "guest"} {pass "foobar"}} { - upvar 0 ::nntp::${name}data data - - set data(cmnd) "" - set res [::nntp::command $name "AUTHINFO USER $user"] - if {$res} { - set res [expr {$res && [::nntp::command $name "AUTHINFO PASS $pass"]}] - } - return $res -} - -# ::nntp::_body -- -# -# Internal body proc. Called by the 'nntpName body' command. -# Retrieves the body of the article specified by msgid from the group -# specified by the 'nntpName group' command. If no msgid is specified -# the current (or first) message body is returned -# -# Arguments: -# name Name of the nntp object. -# msgid The number of the body of the article to retrieve -# -# Results: -# Returns the body of article 'msgid' from the group specified through -# 'nntpName group'. If msgid is not specified or is "" then the body of -# the current (or the first) article in the newsgroup will be returned -# as a valid tcl list. The "" string will be returned if there is no -# article 'msgid' or if no group has been specified. - -proc ::nntp::_body {name {msgid ""}} { - upvar 0 ::nntp::${name}data data - - set data(cmnd) "fetch" - return [::nntp::command $name "BODY $msgid"] -} - -# ::nntp::_group -- -# -# Internal group proc. Called by the 'nntpName group' command. -# Sets the current group on the nntp server to the group passed in. -# -# Arguments: -# name Name of the nntp object. -# group The name of the group to set as the default group. -# -# Results: -# Sets the default group to the group specified. If no group is specified -# or if an invalid group is specified an error is thrown. -# -# According to RFC 977 the responses are: -# -# 211 n f l s group selected -# (n = estimated number of articles in group, -# f = first article number in the group, -# l = last article number in the group, -# s = name of the group.) -# 411 no such news group - -proc ::nntp::_group {name {group ""}} { - upvar 0 ::nntp::${name}data data - - set data(cmnd) "groupinfo" - if {$group == ""} { - set group $data(group) - } - return [::nntp::command $name "GROUP $group"] -} - -# ::nntp::_head -- -# -# Internal head proc. Called by the 'nntpName head' command. -# Retrieves the header of the article specified by msgid from the group -# specified by the 'nntpName group' command. If no msgid is specified -# the current (or first) message header is returned -# -# Arguments: -# name Name of the nntp object. -# msgid The number of the header of the article to retrieve -# -# Results: -# Returns the header of article 'msgid' from the group specified through -# 'nntpName group'. If msgid is not specified or is "" then the header of -# the current (or the first) article in the newsgroup will be returned -# as a valid tcl list. The "" string will be returned if there is no -# article 'msgid' or if no group has been specified. - -proc ::nntp::_head {name {msgid ""}} { - upvar 0 ::nntp::${name}data data - - set data(cmnd) "fetch" - return [::nntp::command $name "HEAD $msgid"] -} - -# ::nntp::_help -- -# -# Internal help proc. Called by the 'nntpName help' command. -# Retrieves a list of the valid nntp commands accepted by the server. -# -# Arguments: -# name Name of the nntp object. -# -# Results: -# Returns the NNTP commands expected by the NNTP server. - -proc ::nntp::_help {name} { - upvar 0 ::nntp::${name}data data - - set data(cmnd) "fetch" - return [::nntp::command $name "HELP"] -} - -proc ::nntp::_ihave {name {msgid ""} args} { - upvar 0 ::nntp::${name}data data - - set data(cmnd) "fetch" - if {![::nntp::command $name "IHAVE $msgid"]} { - return "" - } - return [::nntp::squirt $name "$args"] -} - -# ::nntp::_last -- -# -# Internal last proc. Called by the 'nntpName last' command. -# Sets the current message to the message before the current message. -# -# Arguments: -# name Name of the nntp object. -# -# Results: -# None. - -proc ::nntp::_last {name} { - upvar 0 ::nntp::${name}data data - - set data(cmnd) "msgid" - return [::nntp::command $name "LAST"] -} - -# ::nntp::_list -- -# -# Internal list proc. Called by the 'nntpName list' command. -# Lists all groups or (optionally) all groups of a specified type. -# -# Arguments: -# name Name of the nntp object. -# Type The type of groups to return (active active.times newsgroups -# distributions distrib.pats moderators overview.fmt -# subscriptions) - optional. -# -# Results: -# Returns a tcl list of all groups or the groups that match 'type' if -# a type is specified. - -proc ::nntp::_list {name {type ""}} { - upvar 0 ::nntp::${name}data data - - set data(cmnd) "fetch" - return [::nntp::command $name "LIST $type"] -} - -# ::nntp::_newgroups -- -# -# Internal newgroups proc. Called by the 'nntpName newgroups' command. -# Lists all new groups since a specified time. -# -# Arguments: -# name Name of the nntp object. -# since The time to find new groups since. The time can be in any -# format that is accepted by 'clock scan' in tcl. -# -# Results: -# Returns a tcl list of all new groups added since the time specified. - -proc ::nntp::_newgroups {name since args} { - upvar 0 ::nntp::${name}data data - - set since [clock format [clock scan "$since"] -format "%y%m%d %H%M%S"] - set dist "" - set data(cmnd) "fetch" - return [::nntp::command $name "NEWGROUPS $since $dist"] -} - -# ::nntp::_newnews -- -# -# Internal newnews proc. Called by the 'nntpName newnews' command. -# Lists all new news in the specified group since a specified time. -# -# Arguments: -# name Name of the nntp object. -# group Name of the newsgroup to query. -# since The time to find new groups since. The time can be in any -# format that is accepted by 'clock scan' in tcl. Defaults to -# "1 day ago" -# -# Results: -# Returns a tcl list of all new messages since the time specified. - -proc ::nntp::_newnews {name {group ""} {since ""}} { - upvar 0 ::nntp::${name}data data - - if {$group != ""} { - if {[regexp -- {^[\w\.\-]+$} $group] == 0} { - set since $group - set group "" - } - } - if {![info exists group] || ($group == "")} { - if {[info exists data(group)] && ($data(group) != "")} { - set group $data(group) - } else { - set group "*" - } - } - if {"$since" == ""} { - set since [clock format [clock scan "now - 1 day"]] - } - set since [clock format [clock scan $since] -format "%y%m%d %H%M%S"] - set dist "" - set data(cmnd) "fetch" - return [::nntp::command $name "NEWNEWS $group $since $dist"] -} - -# ::nntp::_next -- -# -# Internal next proc. Called by the 'nntpName next' command. -# Sets the current message to the next message after the current message. -# -# Arguments: -# name Name of the nntp object. -# -# Results: -# None. - -proc ::nntp::_next {name} { - upvar 0 ::nntp::${name}data data - - set data(cmnd) "msgid" - return [::nntp::command $name "NEXT"] -} - -# ::nntp::_post -- -# -# Internal post proc. Called by the 'nntpName post' command. -# Posts a message to a newsgroup. -# -# Responses (according to RFC 977) to a post request: -# 240 article posted ok -# 340 send article to be posted. End with . -# 440 posting not allowed -# 441 posting failed -# -# Arguments: -# name Name of the nntp object. -# article A message of the form specified in RFC 850 -# -# Results: -# None. - -proc ::nntp::_post {name article} { - - if {![::nntp::command $name "POST"]} { - return "" - } - return [::nntp::squirt $name "$article"] -} - -# ::nntp::_slave -- -# -# Internal slave proc. Called by the 'nntpName slave' command. -# Identifies a connection as being made from a slave nntp server. -# This might be used to indicate that the connection is serving -# multiple people and should be given priority. Actual use is -# entirely implementation dependant and may vary from server to -# server. -# -# Arguments: -# name Name of the nntp object. -# -# Results: -# None. -# -# According to RFC 977 the only response is: -# -# 202 slave status noted - -proc ::nntp::_slave {name} { - return [::nntp::command $name "SLAVE"] -} - -# ::nntp::_stat -- -# -# Internal stat proc. Called by the 'nntpName stat' command. -# The stat command is similar to the article command except that no -# text is returned. When selecting by message number within a group, -# the stat command serves to set the current article pointer without -# sending text. The returned acknowledgement response will contain the -# message-id, which may be of some value. Using the stat command to -# select by message-id is valid but of questionable value, since a -# selection by message-id does NOT alter the "current article pointer" -# -# Arguments: -# name Name of the nntp object. -# msgid The number of the message to stat (optional) default is to -# stat the current article -# -# Results: -# Returns the statistics for the article. - -proc ::nntp::_stat {name {msgid ""}} { - upvar 0 ::nntp::${name}data data - - set data(cmnd) "status" - return [::nntp::command $name "STAT $msgid"] -} - -# ::nntp::_quit -- -# -# Internal quit proc. Called by the 'nntpName quit' command. -# Quits the nntp session and closes the socket. Deletes the command -# that was created for the connection. -# -# Arguments: -# name Name of the nntp object. -# -# Results: -# Returns the return value from the quit command. - -proc ::nntp::_quit {name} { - upvar 0 ::nntp::${name}data data - - set ret [::nntp::command $name "QUIT"] - close $data(sock) - rename ${name} {} - return $ret -} - -############################################################# -# -# Extended methods (not available on all NNTP servers -# - -proc ::nntp::_date {name} { - upvar 0 ::nntp::${name}data data - - set data(cmnd) "msg" - return [::nntp::command $name "DATE"] -} - -proc ::nntp::_listgroup {name {group ""}} { - upvar 0 ::nntp::${name}data data - - set data(cmnd) "fetch" - return [::nntp::command $name "LISTGROUP $group"] -} - -proc ::nntp::_mode_reader {name} { - upvar 0 ::nntp::${name}data data - - set data(cmnd) "msg" - return [::nntp::command $name "MODE READER"] -} - -proc ::nntp::_xgtitle {name {group_pattern ""}} { - upvar 0 ::nntp::${name}data data - - set data(cmnd) "fetch" - return [::nntp::command $name "XGTITLE $group_pattern"] -} - -proc ::nntp::_xhdr {name {header "message-id"} {list ""} {last ""}} { - upvar 0 ::nntp::${name}data data - - if {![regexp -- {\d+-\d+} $list]} { - if {"$last" != ""} { - set list "$list-$last" - } else { - set list "" - } - } - set data(cmnd) "fetch" - return [::nntp::command $name "XHDR $header $list"] -} - -proc ::nntp::_xindex {name {group ""}} { - upvar 0 ::nntp::${name}data data - - if {("$group" == "") && [info exists data(group)]} { - set group $data(group) - } - set data(cmnd) "fetch" - return [::nntp::command $name "XINDEX $group"] -} - -proc ::nntp::_xmotd {name {since ""}} { - upvar 0 ::nntp::${name}data data - - if {"$since" != ""} { - set since [clock seconds] - } - set since [clock format [clock scan $since] -format "%y%m%d %H%M%S"] - set data(cmnd) "fetch" - return [::nntp::command $name "XMOTD $since"] -} - -proc ::nntp::_xover {name {list ""} {last ""}} { - upvar 0 ::nntp::${name}data data - if {![regexp -- {\d+-\d+} $list]} { - if {"$last" != ""} { - set list "$list-$last" - } else { - set list "" - } - } - set data(cmnd) "fetch" - return [::nntp::command $name "XOVER $list"] -} - -proc ::nntp::_xpat {name {header "subject"} {list 1} {last ""} args} { - upvar 0 ::nntp::${name}data data - - set patterns "" - - if {![regexp -- {\d+-\d+} $list]} { - if {("$last" != "") && ([string is digit $last])} { - set list "$list-$last" - } - } elseif {"$last" != ""} { - set patterns "$last" - } - - if {[llength $args] > 0} { - set patterns "$patterns $args" - } - - if {"$patterns" == ""} { - set patterns "*" - } - - set data(cmnd) "fetch" - return [::nntp::command $name "XPAT $header $list $patterns"] -} - -proc ::nntp::_xpath {name {msgid ""}} { - upvar 0 ::nntp::${name}data data - - set data(cmnd) "msg" - return [::nntp::command $name "XPATH $msgid"] -} - -proc ::nntp::_xsearch {name args} { - set res [::nntp::command $name "XSEARCH"] - if {!$res} { - return "" - } - return [::nntp::squirt $name "$args"] -} - -proc ::nntp::_xthread {name args} { - upvar 0 ::nntp::${name}data data - - if {[llength $args] > 0} { - set filename "dbinit" - } else { - set filename "thread" - } - set data(cmnd) "fetchbinary" - return [::nntp::command $name "XTHREAD $filename"] -} - -###################################################### -# -# Helper methods -# - -proc ::nntp::cmd {name cmd} { - upvar 0 ::nntp::${name}data data - - set eol "\015\012" - set sock $data(sock) - if {$data(debug)} { - puts stderr "$sock command $cmd" - } - puts $sock "$cmd" - flush $sock - return -} - -proc ::nntp::command {name args} { - set res [eval [list ::nntp::cmd $name] $args] - - return [::nntp::response $name] -} - -proc ::nntp::msg {name} { - upvar 0 ::nntp::${name}data data - - set res [::nntp::okprint $name] - if {!$res} { - return "" - } - return $data(mesg) -} - -proc ::nntp::groupinfo {name} { - upvar 0 ::nntp::${name}data data - - set data(group) "" - - if {[::nntp::okprint $name] && [regexp -- {(\d+)\s+(\d+)\s+(\d+)\s+([\w\.]+)} \ - $data(mesg) match count first last data(group)]} { - return [list $count $first $last $data(group)] - } - return "" -} - -proc ::nntp::msgid {name} { - upvar 0 ::nntp::${name}data data - - set result "" - if {[::nntp::okprint $name] && \ - [regsub -- {\s+<[^>]+>} $data(mesg) {} result]} { - return $result - } else { - return "" - } -} - -proc ::nntp::status {name} { - upvar 0 ::nntp::${name}data data - - set result "" - if {[::nntp::okprint $name] && \ - [regexp -- {\d+\s+<[^>]+>} $data(mesg) result]} { - return $result - } else { - return "" - } -} - -proc ::nntp::fetch {name} { - upvar 0 ::nntp::${name}data data - - set eol "\012" - - if {![::nntp::okprint $name]} { - return "" - } - set sock $data(sock) - - set result [list ] - while {![eof $sock]} { - gets $sock line - regsub -- {\015?\012$} $line $data(eol) line - - if {[string match "." $line]} { - break - } - if { [string match "..*" $line] } { - lappend result [string range $line 1 end] - } else { - lappend result $line - } - } - return $result -} - -proc ::nntp::response {name} { - upvar 0 ::nntp::${name}data data - - set eol "\012" - - set sock $data(sock) - - gets $sock line - set data(code) 0 - set data(mesg) "" - - if {$line == ""} { - error "nntp: unexpected EOF on $sock\n" - } - - regsub -- {\015?\012$} $line "" line - - set result [regexp -- {^((\d\d)(\d))\s*(.*)} $line match \ - data(code) val1 val2 data(mesg)] - - if {$result == 0} { - puts stderr "nntp garbled response: $line\n"; - return "" - } - - if {$val1 == 20} { - set data(post) [expr {!$val2}] - } - - if {$data(debug)} { - puts stderr "val1 $val1 val2 $val2" - puts stderr "code '$data(code)'" - puts stderr "mesg '$data(mesg)'" - if {[info exists data(post)]} { - puts stderr "post '$data(post)'" - } - } - - return [::nntp::returnval $name] -} - -proc ::nntp::returnval {name} { - upvar 0 ::nntp::${name}data data - - if {([info exists data(cmnd)]) \ - && ($data(cmnd) != "")} { - set command $data(cmnd) - } else { - set command okprint - } - - if {$data(debug)} { - puts stderr "returnval command '$command'" - } - - set data(cmnd) "" - return [::nntp::$command $name] -} - -proc ::nntp::squirt {name {body ""}} { - upvar 0 ::nntp::${name}data data - - set body [split $body \n] - - if {$data(debug)} { - puts stderr "$data(sock) sending [llength $body] lines\n"; - } - - foreach line $body { - # Print each line, possibly prepending a dot for lines - # starting with a dot and trimming any trailing \n. - if { [string match ".*" $line] } { - set line ".$line" - } - puts $data(sock) $line - } - puts $data(sock) "." - flush $data(sock) - - if {$data(debug)} { - puts stderr "$data(sock) is finished sending" - } - return [::nntp::response $name] -} -#eof - DELETED modules/nntp/pkgIndex.tcl Index: modules/nntp/pkgIndex.tcl ================================================================== --- modules/nntp/pkgIndex.tcl +++ /dev/null @@ -1,12 +0,0 @@ -# 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. - -if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded nntp 0.2.1 [list source [file join $dir nntp.tcl]] DELETED modules/nntp/rfc977.txt Index: modules/nntp/rfc977.txt ================================================================== --- modules/nntp/rfc977.txt +++ /dev/null @@ -1,1539 +0,0 @@ - - -Network Working Group Brian Kantor (U.C. San Diego) -Request for Comments: 977 Phil Lapsley (U.C. Berkeley) - February 1986 - - Network News Transfer Protocol - - A Proposed Standard for the Stream-Based - Transmission of News - -Status of This Memo - - NNTP specifies a protocol for the distribution, inquiry, retrieval, - and posting of news articles using a reliable stream-based - transmission of news among the ARPA-Internet community. NNTP is - designed so that news articles are stored in a central database - allowing a subscriber to select only those items he wishes to read. - Indexing, cross-referencing, and expiration of aged messages are also - provided. This RFC suggests a proposed protocol for the ARPA-Internet - community, and requests discussion and suggestions for improvements. - Distribution of this memo is unlimited. - -1. Introduction - - For many years, the ARPA-Internet community has supported the - distribution of bulletins, information, and data in a timely fashion - to thousands of participants. We collectively refer to such items of - information as "news". Such news provides for the rapid - dissemination of items of interest such as software bug fixes, new - product reviews, technical tips, and programming pointers, as well as - rapid-fire discussions of matters of concern to the working computer - professional. News is very popular among its readers. - - There are popularly two methods of distributing such news: the - Internet method of direct mailing, and the USENET news system. - -1.1. Internet Mailing Lists - - The Internet community distributes news by the use of mailing lists. - These are lists of subscriber's mailbox addresses and remailing - sublists of all intended recipients. These mailing lists operate by - remailing a copy of the information to be distributed to each - subscriber on the mailing list. Such remailing is inefficient when a - mailing list grows beyond a dozen or so people, since sending a - separate copy to each of the subscribers occupies large quantities of - network bandwidth, CPU resources, and significant amounts of disk - storage at the destination host. There is also a significant problem - in maintenance of the list itself: as subscribers move from one job - to another; as new subscribers join and old ones leave; and as hosts - come in and out of service. - - - - -Kantor & Lapsley [Page 1] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - -1.2. The USENET News System - - Clearly, a worthwhile reduction of the amount of these resources used - can be achieved if articles are stored in a central database on the - receiving host instead of in each subscriber's mailbox. The USENET - news system provides a method of doing just this. There is a central - repository of the news articles in one place (customarily a spool - directory of some sort), and a set of programs that allow a - subscriber to select those items he wishes to read. Indexing, - cross-referencing, and expiration of aged messages are also provided. - -1.3. Central Storage of News - - For clusters of hosts connected together by fast local area networks - (such as Ethernet), it makes even more sense to consolidate news - distribution onto one (or a very few) hosts, and to allow access to - these news articles using a server and client model. Subscribers may - then request only the articles they wish to see, without having to - wastefully duplicate the storage of a copy of each item on each host. - -1.4. A Central News Server - - A way to achieve these economies is to have a central computer system - that can provide news service to the other systems on the local area - network. Such a server would manage the collection of news articles - and index files, with each person who desires to read news bulletins - doing so over the LAN. For a large cluster of computer systems, the - savings in total disk space is clearly worthwhile. Also, this allows - workstations with limited disk storage space to participate in the - news without incoming items consuming oppressive amounts of the - workstation's disk storage. - - We have heard rumors of somewhat successful attempts to provide - centralized news service using IBIS and other shared or distributed - file systems. While it is possible that such a distributed file - system implementation might work well with a group of similar - computers running nearly identical operating systems, such a scheme - is not general enough to offer service to a wide range of client - systems, especially when many diverse operating systems may be in use - among a group of clients. There are few (if any) shared or networked - file systems that can offer the generality of service that stream - connections using Internet TCP provide, particularly when a wide - range of host hardware and operating systems are considered. - - NNTP specifies a protocol for the distribution, inquiry, retrieval, - and posting of news articles using a reliable stream (such as TCP) - server-client model. NNTP is designed so that news articles need only - - -Kantor & Lapsley [Page 2] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - - be stored on one (presumably central) host, and subscribers on other - hosts attached to the LAN may read news articles using stream - connections to the news host. - - NNTP is modelled upon the news article specifications in RFC 850, - which describes the USENET news system. However, NNTP makes few - demands upon the structure, content, or storage of news articles, and - thus we believe it easily can be adapted to other non-USENET news - systems. - - Typically, the NNTP server runs as a background process on one host, - and would accept connections from other hosts on the LAN. This works - well when there are a number of small computer systems (such as - workstations, with only one or at most a few users each), and a large - central server. - -1.5. Intermediate News Servers - - For clusters of machines with many users (as might be the case in a - university or large industrial environment), an intermediate server - might be used. This intermediate or "slave" server runs on each - computer system, and is responsible for mediating news reading - requests and performing local caching of recently-retrieved news - articles. - - Typically, a client attempting to obtain news service would first - attempt to connect to the news service port on the local machine. If - this attempt were unsuccessful, indicating a failed server, an - installation might choose to either deny news access, or to permit - connection to the central "master" news server. - - For workstations or other small systems, direct connection to the - master server would probably be the normal manner of operation. - - This specification does not cover the operation of slave NNTP - servers. We merely suggest that slave servers are a logical addition - to NNTP server usage which would enhance operation on large local - area networks. - -1.6. News Distribution - - NNTP has commands which provide a straightforward method of - exchanging articles between cooperating hosts. Hosts which are well - connected on a local area or other fast network and who wish to - actually obtain copies of news articles for local storage might well - find NNTP to be a more efficient way to distribute news than more - traditional transfer methods (such as UUCP). - - -Kantor & Lapsley [Page 3] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - - In the traditional method of distributing news articles, news is - propagated from host to host by flooding - that is, each host will - send all its new news articles on to each host that it feeds. These - hosts will then in turn send these new articles on to other hosts - that they feed. Clearly, sending articles that a host already has - obtained a copy of from another feed (many hosts that receive news - are redundantly fed) again is a waste of time and communications - resources, but for transport mechanisms that are single-transaction - based rather than interactive (such as UUCP in the UNIX-world <1>), - distribution time is diminished by sending all articles and having - the receiving host simply discard the duplicates. This is an - especially true when communications sessions are limited to once a - day. - - Using NNTP, hosts exchanging news articles have an interactive - mechanism for deciding which articles are to be transmitted. A host - desiring new news, or which has new news to send, will typically - contact one or more of its neighbors using NNTP. First it will - inquire if any new news groups have been created on the serving host - by means of the NEWGROUPS command. If so, and those are appropriate - or desired (as established by local site-dependent rules), those new - newsgroups can be created. - - The client host will then inquire as to which new articles have - arrived in all or some of the newsgroups that it desires to receive, - using the NEWNEWS command. It will receive a list of new articles - from the server, and can request transmission of those articles that - it desires and does not already have. - - Finally, the client can advise the server of those new articles which - the client has recently received. The server will indicate those - articles that it has already obtained copies of, and which articles - should be sent to add to its collection. - - In this manner, only those articles which are not duplicates and - which are desired are transferred. - - - - - - - - - - - - - -Kantor & Lapsley [Page 4] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - -2. The NNTP Specification - -2.1. Overview - - The news server specified by this document uses a stream connection - (such as TCP) and SMTP-like commands and responses. It is designed - to accept connections from hosts, and to provide a simple interface - to the news database. - - This server is only an interface between programs and the news - databases. It does not perform any user interaction or presentation- - level functions. These "user-friendly" functions are better left to - the client programs, which have a better understanding of the - environment in which they are operating. - - When used via Internet TCP, the contact port assigned for this - service is 119. - -2.2. Character Codes - - Commands and replies are composed of characters from the ASCII - character set. When the transport service provides an 8-bit byte - (octet) transmission channel, each 7-bit character is transmitted - right justified in an octet with the high order bit cleared to zero. - -2.3. Commands - - Commands consist of a command word, which in some cases may be - followed by a parameter. Commands with parameters must separate the - parameters from each other and from the command by one or more space - or tab characters. Command lines must be complete with all required - parameters, and may not contain more than one command. - - Commands and command parameters are not case sensitive. That is, a - command or parameter word may be upper case, lower case, or any - mixture of upper and lower case. - - Each command line must be terminated by a CR-LF (Carriage Return - - Line Feed) pair. - - Command lines shall not exceed 512 characters in length, counting all - characters including spaces, separators, punctuation, and the - trailing CR-LF (thus there are 510 characters maximum allowed for the - command and its parameters). There is no provision for continuation - command lines. - - - - -Kantor & Lapsley [Page 5] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - -2.4. Responses - - Responses are of two kinds, textual and status. - -2.4.1. Text Responses - - Text is sent only after a numeric status response line has been sent - that indicates that text will follow. Text is sent as a series of - successive lines of textual matter, each terminated with CR-LF pair. - A single line containing only a period (.) is sent to indicate the - end of the text (i.e., the server will send a CR-LF pair at the end - of the last line of text, a period, and another CR-LF pair). - - If the text contained a period as the first character of the text - line in the original, that first period is doubled. Therefore, the - client must examine the first character of each line received, and - for those beginning with a period, determine either that this is the - end of the text or whether to collapse the doubled period to a single - one. - - The intention is that text messages will usually be displayed on the - user's terminal whereas command/status responses will be interpreted - by the client program before any possible display is done. - -2.4.2. Status Responses - - These are status reports from the server and indicate the response to - the last command received from the client. - - Status response lines begin with a 3 digit numeric code which is - sufficient to distinguish all responses. Some of these may herald - the subsequent transmission of text. - - The first digit of the response broadly indicates the success, - failure, or progress of the previous command. - - 1xx - Informative message - 2xx - Command ok - 3xx - Command ok so far, send the rest of it. - 4xx - Command was correct, but couldn't be performed for - some reason. - 5xx - Command unimplemented, or incorrect, or a serious - program error occurred. - - - - - - -Kantor & Lapsley [Page 6] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - - The next digit in the code indicates the function response category. - - x0x - Connection, setup, and miscellaneous messages - x1x - Newsgroup selection - x2x - Article selection - x3x - Distribution functions - x4x - Posting - x8x - Nonstandard (private implementation) extensions - x9x - Debugging output - - The exact response codes that should be expected from each command - are detailed in the description of that command. In addition, below - is listed a general set of response codes that may be received at any - time. - - Certain status responses contain parameters such as numbers and - names. The number and type of such parameters is fixed for each - response code to simplify interpretation of the response. - - Parameters are separated from the numeric response code and from each - other by a single space. All numeric parameters are decimal, and may - have leading zeros. All string parameters begin after the separating - space, and end before the following separating space or the CR-LF - pair at the end of the line. (String parameters may not, therefore, - contain spaces.) All text, if any, in the response which is not a - parameter of the response must follow and be separated from the last - parameter by a space. Also, note that the text following a response - number may vary in different implementations of the server. The - 3-digit numeric code should be used to determine what response was - sent. - - Response codes not specified in this standard may be used for any - installation-specific additional commands also not specified. These - should be chosen to fit the pattern of x8x specified above. (Note - that debugging is provided for explicitly in the x9x response codes.) - The use of unspecified response codes for standard commands is - prohibited. - - We have provided a response pattern x9x for debugging. Since much - debugging output may be classed as "informative messages", we would - expect, therefore, that responses 190 through 199 would be used for - various debugging outputs. There is no requirement in this - specification for debugging output, but if such is provided over the - connected stream, it must use these response codes. If appropriate - to a specific implementation, other x9x codes may be used for - debugging. (An example might be to use e.g., 290 to acknowledge a - remote debugging request.) - - -Kantor & Lapsley [Page 7] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - -2.4.3. General Responses - - The following is a list of general response codes that may be sent by - the NNTP server. These are not specific to any one command, but may - be returned as the result of a connection, a failure, or some unusual - condition. - - In general, 1xx codes may be ignored or displayed as desired; code - 200 or 201 is sent upon initial connection to the NNTP server - depending upon posting permission; code 400 will be sent when the - NNTP server discontinues service (by operator request, for example); - and 5xx codes indicate that the command could not be performed for - some unusual reason. - - 100 help text - 190 - through - 199 debug output - - 200 server ready - posting allowed - 201 server ready - no posting allowed - - 400 service discontinued - - 500 command not recognized - 501 command syntax error - 502 access restriction or permission denied - 503 program fault - command not performed - -3. Command and Response Details - - On the following pages are descriptions of each command recognized by - the NNTP server and the responses which will be returned by those - commands. - - Each command is shown in upper case for clarity, although case is - ignored in the interpretation of commands by the NNTP server. Any - parameters are shown in lower case. A parameter shown in [square - brackets] is optional. For example, [GMT] indicates that the - triglyph GMT may present or omitted. - - Every command described in this section must be implemented by all - NNTP servers. - - - - - - -Kantor & Lapsley [Page 8] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - - There is no prohibition against additional commands being added; - however, it is recommended that any such unspecified command begin - with the letter "X" to avoid conflict with later revisions of this - specification. - - Implementors are reminded that such additional commands may not - redefine specified status response codes. Using additional - unspecified responses for standard commands is also prohibited. - -3.1. The ARTICLE, BODY, HEAD, and STAT commands - - There are two forms to the ARTICLE command (and the related BODY, - HEAD, and STAT commands), each using a different method of specifying - which article is to be retrieved. When the ARTICLE command is - followed by a message-id in angle brackets ("<" and ">"), the first - form of the command is used; when a numeric parameter or no parameter - is supplied, the second form is invoked. - - The text of the article is returned as a textual response, as - described earlier in this document. - - The HEAD and BODY commands are identical to the ARTICLE command - except that they respectively return only the header lines or text - body of the article. - - The STAT command is similar to the ARTICLE command except that no - text is returned. When selecting by message number within a group, - the STAT command serves to set the current article pointer without - sending text. The returned acknowledgement response will contain the - message-id, which may be of some value. Using the STAT command to - select by message-id is valid but of questionable value, since a - selection by message-id does NOT alter the "current article pointer". - -3.1.1. ARTICLE (selection by message-id) - - ARTICLE - - Display the header, a blank line, then the body (text) of the - specified article. Message-id is the message id of an article as - shown in that article's header. It is anticipated that the client - will obtain the message-id from a list provided by the NEWNEWS - command, from references contained within another article, or from - the message-id provided in the response to some other commands. - - Please note that the internally-maintained "current article pointer" - is NOT ALTERED by this command. This is both to facilitate the - presentation of articles that may be referenced within an article - - -Kantor & Lapsley [Page 9] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - - being read, and because of the semantic difficulties of determining - the proper sequence and membership of an article which may have been - posted to more than one newsgroup. - -3.1.2. ARTICLE (selection by number) - - ARTICLE [nnn] - - Displays the header, a blank line, then the body (text) of the - current or specified article. The optional parameter nnn is the - - numeric id of an article in the current newsgroup and must be chosen - from the range of articles provided when the newsgroup was selected. - If it is omitted, the current article is assumed. - - The internally-maintained "current article pointer" is set by this - command if a valid article number is specified. - - [the following applies to both forms of the article command.] A - response indicating the current article number, a message-id string, - and that text is to follow will be returned. - - The message-id string returned is an identification string contained - within angle brackets ("<" and ">"), which is derived from the header - of the article itself. The Message-ID header line (required by - RFC850) from the article must be used to supply this information. If - the message-id header line is missing from the article, a single - digit "0" (zero) should be supplied within the angle brackets. - - Since the message-id field is unique with each article, it may be - used by a news reading program to skip duplicate displays of articles - that have been posted more than once, or to more than one newsgroup. - -3.1.3. Responses - - 220 n article retrieved - head and body follow - (n = article number, = message-id) - 221 n article retrieved - head follows - 222 n article retrieved - body follows - 223 n article retrieved - request text separately - 412 no newsgroup has been selected - 420 no current article has been selected - 423 no such article number in this group - 430 no such article found - - - - - -Kantor & Lapsley [Page 10] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - -3.2. The GROUP command - -3.2.1. GROUP - - GROUP ggg - - The required parameter ggg is the name of the newsgroup to be - selected (e.g. "net.news"). A list of valid newsgroups may be - obtained from the LIST command. - - The successful selection response will return the article numbers of - the first and last articles in the group, and an estimate of the - number of articles on file in the group. It is not necessary that - the estimate be correct, although that is helpful; it must only be - equal to or larger than the actual number of articles on file. (Some - implementations will actually count the number of articles on file. - Others will just subtract first article number from last to get an - estimate.) - - When a valid group is selected by means of this command, the - internally maintained "current article pointer" is set to the first - article in the group. If an invalid group is specified, the - previously selected group and article remain selected. If an empty - newsgroup is selected, the "current article pointer" is in an - indeterminate state and should not be used. - - Note that the name of the newsgroup is not case-dependent. It must - otherwise match a newsgroup obtained from the LIST command or an - error will result. - -3.2.2. Responses - - 211 n f l s group selected - (n = estimated number of articles in group, - f = first article number in the group, - l = last article number in the group, - s = name of the group.) - 411 no such news group - - - - - - - - - - - -Kantor & Lapsley [Page 11] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - -3.3. The HELP command - -3.3.1. HELP - - HELP - - Provides a short summary of commands that are understood by this - implementation of the server. The help text will be presented as a - textual response, terminated by a single period on a line by itself. - - 3.3.2. Responses - - 100 help text follows - -3.4. The IHAVE command - -3.4.1. IHAVE - - IHAVE - - The IHAVE command informs the server that the client has an article - whose id is . If the server desires a copy of that - article, it will return a response instructing the client to send the - entire article. If the server does not want the article (if, for - example, the server already has a copy of it), a response indicating - that the article is not wanted will be returned. - - If transmission of the article is requested, the client should send - the entire article, including header and body, in the manner - specified for text transmission from the server. A response code - indicating success or failure of the transferral of the article will - be returned. - - This function differs from the POST command in that it is intended - for use in transferring already-posted articles between hosts. - Normally it will not be used when the client is a personal - newsreading program. In particular, this function will invoke the - server's news posting program with the appropriate settings (flags, - options, etc) to indicate that the forthcoming article is being - forwarded from another host. - - The server may, however, elect not to post or forward the article if - after further examination of the article it deems it inappropriate to - do so. The 436 or 437 error codes may be returned as appropriate to - the situation. - - Reasons for such subsequent rejection of an article may include such - - -Kantor & Lapsley [Page 12] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - - problems as inappropriate newsgroups or distributions, disk space - limitations, article lengths, garbled headers, and the like. These - are typically restrictions enforced by the server host's news - software and not necessarily the NNTP server itself. - -3.4.2. Responses - - 235 article transferred ok - 335 send article to be transferred. End with . - 435 article not wanted - do not send it - 436 transfer failed - try again later - 437 article rejected - do not try again - - An implementation note: - - Because some host news posting software may not be able to decide - immediately that an article is inappropriate for posting or - forwarding, it is acceptable to acknowledge the successful transfer - of the article and to later silently discard it. Thus it is - permitted to return the 235 acknowledgement code and later discard - the received article. This is not a fully satisfactory solution to - the problem. Perhaps some implementations will wish to send mail to - the author of the article in certain of these cases. - -3.5. The LAST command - -3.5.1. LAST - - LAST - - The internally maintained "current article pointer" is set to the - previous article in the current newsgroup. If already positioned at - the first article of the newsgroup, an error message is returned and - the current article remains selected. - - The internally-maintained "current article pointer" is set by this - command. - - A response indicating the current article number, and a message-id - string will be returned. No text is sent in response to this - command. - -3.5.2. Responses - - 223 n a article retrieved - request text separately - (n = article number, a = unique article id) - - - -Kantor & Lapsley [Page 13] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - - 412 no newsgroup selected - 420 no current article has been selected - 422 no previous article in this group - -3.6. The LIST command - -3.6.1. LIST - - LIST - - Returns a list of valid newsgroups and associated information. Each - newsgroup is sent as a line of text in the following format: - - group last first p - - where is the name of the newsgroup, is the number of - the last known article currently in that newsgroup, is the - number of the first article currently in the newsgroup, and

is - either 'y' or 'n' indicating whether posting to this newsgroup is - allowed ('y') or prohibited ('n'). - - The and fields will always be numeric. They may have - leading zeros. If the field evaluates to less than the - field, there are no articles currently on file in the - newsgroup. - - Note that posting may still be prohibited to a client even though the - LIST command indicates that posting is permitted to a particular - newsgroup. See the POST command for an explanation of client - prohibitions. The posting flag exists for each newsgroup because - some newsgroups are moderated or are digests, and therefore cannot be - posted to; that is, articles posted to them must be mailed to a - moderator who will post them for the submitter. This is independent - of the posting permission granted to a client by the NNTP server. - - Please note that an empty list (i.e., the text body returned by this - command consists only of the terminating period) is a possible valid - response, and indicates that there are currently no valid newsgroups. - -3.6.2. Responses - - 215 list of newsgroups follows - - - - - - - -Kantor & Lapsley [Page 14] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - -3.7. The NEWGROUPS command - -3.7.1. NEWGROUPS - - NEWGROUPS date time [GMT] [] - - A list of newsgroups created since will be listed in - the same format as the LIST command. - - The date is sent as 6 digits in the format YYMMDD, where YY is the - last two digits of the year, MM is the two digits of the month (with - leading zero, if appropriate), and DD is the day of the month (with - leading zero, if appropriate). The closest century is assumed as - part of the year (i.e., 86 specifies 1986, 30 specifies 2030, 99 is - 1999, 00 is 2000). - - Time must also be specified. It must be as 6 digits HHMMSS with HH - being hours on the 24-hour clock, MM minutes 00-59, and SS seconds - 00-59. The time is assumed to be in the server's timezone unless the - token "GMT" appears, in which case both time and date are evaluated - at the 0 meridian. - - The optional parameter "distributions" is a list of distribution - groups, enclosed in angle brackets. If specified, the distribution - portion of a new newsgroup (e.g, 'net' in 'net.wombat') will be - examined for a match with the distribution categories listed, and - only those new newsgroups which match will be listed. If more than - one distribution group is to be listed, they must be separated by - commas within the angle brackets. - - Please note that an empty list (i.e., the text body returned by this - command consists only of the terminating period) is a possible valid - response, and indicates that there are currently no new newsgroups. - -3.7.2. Responses - - 231 list of new newsgroups follows - - - - - - - - - - - - -Kantor & Lapsley [Page 15] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - -3.8. The NEWNEWS command - -3.8.1. NEWNEWS - - NEWNEWS newsgroups date time [GMT] [] - - A list of message-ids of articles posted or received to the specified - newsgroup since "date" will be listed. The format of the listing will - be one message-id per line, as though text were being sent. A single - line consisting solely of one period followed by CR-LF will terminate - the list. - - Date and time are in the same format as the NEWGROUPS command. - - A newsgroup name containing a "*" (an asterisk) may be specified to - broaden the article search to some or all newsgroups. The asterisk - will be extended to match any part of a newsgroup name (e.g., - net.micro* will match net.micro.wombat, net.micro.apple, etc). Thus - if only an asterisk is given as the newsgroup name, all newsgroups - will be searched for new news. - - (Please note that the asterisk "*" expansion is a general - replacement; in particular, the specification of e.g., net.*.unix - should be correctly expanded to embrace names such as net.wombat.unix - and net.whocares.unix.) - - Conversely, if no asterisk appears in a given newsgroup name, only - the specified newsgroup will be searched for new articles. Newsgroup - names must be chosen from those returned in the listing of available - groups. Multiple newsgroup names (including a "*") may be specified - in this command, separated by a comma. No comma shall appear after - the last newsgroup in the list. [Implementors are cautioned to keep - the 512 character command length limit in mind.] - - The exclamation point ("!") may be used to negate a match. This can - be used to selectively omit certain newsgroups from an otherwise - larger list. For example, a newsgroups specification of - "net.*,mod.*,!mod.map.*" would specify that all net. and - all mod. EXCEPT mod.map. newsgroup names would be - matched. If used, the exclamation point must appear as the first - character of the given newsgroup name or pattern. - - The optional parameter "distributions" is a list of distribution - groups, enclosed in angle brackets. If specified, the distribution - portion of an article's newsgroup (e.g, 'net' in 'net.wombat') will - be examined for a match with the distribution categories listed, and - only those articles which have at least one newsgroup belonging to - - -Kantor & Lapsley [Page 16] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - - the list of distributions will be listed. If more than one - distribution group is to be supplied, they must be separated by - commas within the angle brackets. - - The use of the IHAVE, NEWNEWS, and NEWGROUPS commands to distribute - news is discussed in an earlier part of this document. - - Please note that an empty list (i.e., the text body returned by this - command consists only of the terminating period) is a possible valid - response, and indicates that there is currently no new news. - -3.8.2. Responses - - 230 list of new articles by message-id follows - -3.9. The NEXT command - -3.9.1. NEXT - - NEXT - - The internally maintained "current article pointer" is advanced to - the next article in the current newsgroup. If no more articles - remain in the current group, an error message is returned and the - current article remains selected. - - The internally-maintained "current article pointer" is set by this - command. - - A response indicating the current article number, and the message-id - string will be returned. No text is sent in response to this - command. - -3.9.2. Responses - - 223 n a article retrieved - request text separately - (n = article number, a = unique article id) - 412 no newsgroup selected - 420 no current article has been selected - 421 no next article in this group - - - - - - - - - -Kantor & Lapsley [Page 17] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - -3.10. The POST command - -3.10.1. POST - - POST - - If posting is allowed, response code 340 is returned to indicate that - the article to be posted should be sent. Response code 440 indicates - that posting is prohibited for some installation-dependent reason. - - If posting is permitted, the article should be presented in the - format specified by RFC850, and should include all required header - lines. After the article's header and body have been completely sent - by the client to the server, a further response code will be returned - to indicate success or failure of the posting attempt. - - The text forming the header and body of the message to be posted - should be sent by the client using the conventions for text received - from the news server: A single period (".") on a line indicates the - end of the text, with lines starting with a period in the original - text having that period doubled during transmission. - - No attempt shall be made by the server to filter characters, fold or - limit lines, or otherwise process incoming text. It is our intent - that the server just pass the incoming message to be posted to the - server installation's news posting software, which is separate from - this specification. See RFC850 for more details. - - Since most installations will want the client news program to allow - the user to prepare his message using some sort of text editor, and - transmit it to the server for posting only after it is composed, the - client program should take note of the herald message that greeted it - when the connection was first established. This message indicates - whether postings from that client are permitted or not, and can be - used to caution the user that his access is read-only if that is the - case. This will prevent the user from wasting a good deal of time - composing a message only to find posting of the message was denied. - The method and determination of which clients and hosts may post is - installation dependent and is not covered by this specification. - -3.10.2. Responses - - 240 article posted ok - 340 send article to be posted. End with . - 440 posting not allowed - 441 posting failed - - - -Kantor & Lapsley [Page 18] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - - (for reference, one of the following codes will be sent upon initial - connection; the client program should determine whether posting is - generally permitted from these:) 200 server ready - posting allowed - 201 server ready - no posting allowed - -3.11. The QUIT command - -3.11.1. QUIT - - QUIT - - The server process acknowledges the QUIT command and then closes the - connection to the client. This is the preferred method for a client - to indicate that it has finished all its transactions with the NNTP - server. - - If a client simply disconnects (or the connection times out, or some - other fault occurs), the server should gracefully cease its attempts - to service the client. - -3.11.2. Responses - - 205 closing connection - goodbye! - -3.12. The SLAVE command - -3.12.1. SLAVE - - SLAVE - - Indicates to the server that this client connection is to a slave - server, rather than a user. - - This command is intended for use in separating connections to single - users from those to subsidiary ("slave") servers. It may be used to - indicate that priority should therefore be given to requests from - this client, as it is presumably serving more than one person. It - might also be used to determine which connections to close when - system load levels are exceeded, perhaps giving preference to slave - servers. The actual use this command is put to is entirely - implementation dependent, and may vary from one host to another. In - NNTP servers which do not give priority to slave servers, this - command must nonetheless be recognized and acknowledged. - -3.12.2. Responses - - 202 slave status noted - - -Kantor & Lapsley [Page 19] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - -4. Sample Conversations - - These are samples of the conversations that might be expected with - the news server in hypothetical sessions. The notation C: indicates - commands sent to the news server from the client program; S: indicate - responses received from the server by the client. - -4.1. Example 1 - relative access with NEXT - - S: (listens at TCP port 119) - - C: (requests connection on TCP port 119) - S: 200 wombatvax news server ready - posting ok - - (client asks for a current newsgroup list) - C: LIST - S: 215 list of newsgroups follows - S: net.wombats 00543 00501 y - S: net.unix-wizards 10125 10011 y - (more information here) - S: net.idiots 00100 00001 n - S: . - - (client selects a newsgroup) - C: GROUP net.unix-wizards - S: 211 104 10011 10125 net.unix-wizards group selected - (there are 104 articles on file, from 10011 to 10125) - - (client selects an article to read) - C: STAT 10110 - S: 223 10110 <23445@sdcsvax.ARPA> article retrieved - statistics - only (article 10110 selected, its message-id is - <23445@sdcsvax.ARPA>) - - (client examines the header) - C: HEAD - S: 221 10110 <23445@sdcsvax.ARPA> article retrieved - head - follows (text of the header appears here) - S: . - - (client wants to see the text body of the article) - C: BODY - S: 222 10110 <23445@sdcsvax.ARPA> article retrieved - body - follows (body text here) - S: . - - (client selects next article in group) - - -Kantor & Lapsley [Page 20] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - - C: NEXT - S: 223 10113 <21495@nudebch.uucp> article retrieved - statistics - only (article 10113 was next in group) - - (client finishes session) - C: QUIT - S: 205 goodbye. - -4.2. Example 2 - absolute article access with ARTICLE - - S: (listens at TCP port 119) - - C: (requests connection on TCP port 119) - S: 201 UCB-VAX netnews server ready -- no posting allowed - - C: GROUP msgs - S: 211 103 402 504 msgs Your new group is msgs - (there are 103 articles, from 402 to 504) - - C: ARTICLE 401 - S: 423 No such article in this newsgroup - - C: ARTICLE 402 - S: 220 402 <4105@ucbvax.ARPA> Article retrieved, text follows - S: (article header and body follow) - S: . - - C: HEAD 403 - S: 221 403 <3108@mcvax.UUCP> Article retrieved, header follows - S: (article header follows) - S: . - - C: QUIT - S: 205 UCB-VAX news server closing connection. Goodbye. - -4.3. Example 3 - NEWGROUPS command - - S: (listens at TCP port 119) - - C: (requests connection on TCP port 119) - S: 200 Imaginary Institute News Server ready (posting ok) - - (client asks for new newsgroups since April 3, 1985) - C: NEWGROUPS 850403 020000 - - S: 231 New newsgroups since 03/04/85 02:00:00 follow - - - -Kantor & Lapsley [Page 21] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - - S: net.music.gdead - S: net.games.sources - S: . - - C: GROUP net.music.gdead - S: 211 0 1 1 net.music.gdead Newsgroup selected - (there are no articles in that newsgroup, and - the first and last article numbers should be ignored) - - C: QUIT - S: 205 Imaginary Institute news server ceasing service. Bye! - -4.4. Example 4 - posting a news article - - S: (listens at TCP port 119) - - C: (requests connection on TCP port 119) - S: 200 BANZAIVAX news server ready, posting allowed. - - C: POST - S: 340 Continue posting; Period on a line by itself to end - C: (transmits news article in RFC850 format) - C: . - S: 240 Article posted successfully. - - C: QUIT - S: 205 BANZAIVAX closing connection. Goodbye. - -4.5. Example 5 - interruption due to operator request - - S: (listens at TCP port 119) - - C: (requests connection on TCP port 119) - S: 201 genericvax news server ready, no posting allowed. - - (assume normal conversation for some time, and - that a newsgroup has been selected) - - C: NEXT - S: 223 1013 <5734@mcvax.UUCP> Article retrieved; text separate. - - C: HEAD - C: 221 1013 <5734@mcvax.UUCP> Article retrieved; head follows. - - S: (sends head of article, but halfway through is - interrupted by an operator request. The following - then occurs, without client intervention.) - - -Kantor & Lapsley [Page 22] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - - S: (ends current line with a CR-LF pair) - S: . - S: 400 Connection closed by operator. Goodbye. - S: (closes connection) - -4.6. Example 6 - Using the news server to distribute news between - systems. - - S: (listens at TCP port 119) - - C: (requests connection on TCP port 119) - S: 201 Foobar NNTP server ready (no posting) - - (client asks for new newsgroups since 2 am, May 15, 1985) - C: NEWGROUPS 850515 020000 - S: 235 New newsgroups since 850515 follow - S: net.fluff - S: net.lint - S: . - - (client asks for new news articles since 2 am, May 15, 1985) - C: NEWNEWS * 850515 020000 - S: 230 New news since 850515 020000 follows - S: <1772@foo.UUCP> - S: <87623@baz.UUCP> - S: <17872@GOLD.CSNET> - S: . - - (client asks for article <1772@foo.UUCP>) - C: ARTICLE <1772@foo.UUCP> - S: 220 <1772@foo.UUCP> All of article follows - S: (sends entire message) - S: . - - (client asks for article <87623@baz.UUCP> - C: ARTICLE <87623@baz.UUCP> - S: 220 <87623@baz.UUCP> All of article follows - S: (sends entire message) - S: . - - (client asks for article <17872@GOLD.CSNET> - C: ARTICLE <17872@GOLD.CSNET> - S: 220 <17872@GOLD.CSNET> All of article follows - S: (sends entire message) - S: . - - - - -Kantor & Lapsley [Page 23] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - - (client offers an article it has received recently) - C: IHAVE <4105@ucbvax.ARPA> - S: 435 Already seen that one, where you been? - - (client offers another article) - C: IHAVE <4106@ucbvax.ARPA> - S: 335 News to me! to end. - C: (sends article) - C: . - S: 235 Article transferred successfully. Thanks. - - (or) - - S: 436 Transfer failed. - - (client is all through with the session) - C: QUIT - S: 205 Foobar NNTP server bids you farewell. - -4.7. Summary of commands and responses. - - The following are the commands recognized and responses returned by - the NNTP server. - -4.7.1. Commands - - ARTICLE - BODY - GROUP - HEAD - HELP - IHAVE - LAST - LIST - NEWGROUPS - NEWNEWS - NEXT - POST - QUIT - SLAVE - STAT - -4.7.2. Responses - - 100 help text follows - 199 debug output - - - -Kantor & Lapsley [Page 24] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - - 200 server ready - posting allowed - 201 server ready - no posting allowed - 202 slave status noted - 205 closing connection - goodbye! - 211 n f l s group selected - 215 list of newsgroups follows - 220 n article retrieved - head and body follow 221 n article - retrieved - head follows - 222 n article retrieved - body follows - 223 n article retrieved - request text separately 230 list of new - articles by message-id follows - 231 list of new newsgroups follows - 235 article transferred ok - 240 article posted ok - - 335 send article to be transferred. End with . - 340 send article to be posted. End with . - - 400 service discontinued - 411 no such news group - 412 no newsgroup has been selected - 420 no current article has been selected - 421 no next article in this group - 422 no previous article in this group - 423 no such article number in this group - 430 no such article found - 435 article not wanted - do not send it - 436 transfer failed - try again later - 437 article rejected - do not try again. - 440 posting not allowed - 441 posting failed - - 500 command not recognized - 501 command syntax error - 502 access restriction or permission denied - 503 program fault - command not performed - -4.8. A Brief Word about the USENET News System - - In the UNIX world, which traditionally has been linked by 1200 baud - dial-up telephone lines, the USENET News system has evolved to handle - central storage, indexing, retrieval, and distribution of news. With - the exception of its underlying transport mechanism (UUCP), USENET - News is an efficient means of providing news and bulletin service to - subscribers on UNIX and other hosts worldwide. The USENET News - - - - -Kantor & Lapsley [Page 25] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - - system is discussed in detail in RFC 850. It runs on most versions - of UNIX and on many other operating systems, and is customarily - distributed without charge. - - USENET uses a spooling area on the UNIX host to store news articles, - one per file. Each article consists of a series of heading text, - which contain the sender's identification and organizational - affiliation, timestamps, electronic mail reply paths, subject, - newsgroup (subject category), and the like. A complete news article - is reproduced in its entirety below. Please consult RFC 850 for more - details. - - Relay-Version: version B 2.10.3 4.3bsd-beta 6/6/85; site - sdcsvax.UUCP - Posting-Version: version B 2.10.1 6/24/83 SMI; site unitek.uucp - Path:sdcsvax!sdcrdcf!hplabs!qantel!ihnp4!alberta!ubc-vision!unitek - !honman - From: honman@unitek.uucp (Man Wong) - Newsgroups: net.unix-wizards - Subject: foreground -> background ? - Message-ID: <167@unitek.uucp> - Date: 25 Sep 85 23:51:52 GMT - Date-Received: 29 Sep 85 09:54:48 GMT - Reply-To: honman@unitek.UUCP (Hon-Man Wong) - Distribution: net.all - Organization: Unitek Technologies Corporation - Lines: 12 - - I have a process (C program) which generates a child and waits for - it to return. What I would like to do is to be able to run the - child process interactively for a while before kicking itself into - the background so I can return to the parent process (while the - child process is RUNNING in the background). Can it be done? And - if it can, how? - - Please reply by E-mail. Thanks in advance. - - Hon-Man Wong - - - - - - - - - - - -Kantor & Lapsley [Page 26] - - - -RFC 977 February 1986 -Network News Transfer Protocol - - -5. References - - [1] Crocker, D., "Standard for the Format of ARPA Internet Text - Messages", RFC-822, Department of Electrical Engineering, - University of Delaware, August, 1982. - - [2] Horton, M., "Standard for Interchange of USENET Messages", - RFC-850, USENET Project, June, 1983. - - [3] Postel, J., "Transmission Control Protocol- DARPA Internet - Program Protocol Specification", RFC-793, USC/Information - Sciences Institute, September, 1981. - - [4] Postel, J., "Simple Mail Transfer Protocol", RFC-821, - USC/Information Sciences Institute, August, 1982. - -6. Acknowledgements - - The authors wish to express their heartfelt thanks to those many - people who contributed to this specification, and especially to Erik - Fair and Chuq von Rospach, without whose inspiration this whole thing - would not have been necessary. - -7. Notes - - <1> UNIX is a trademark of Bell Laboratories. - - - - - - - - - - - - - - - - - - - - - - - -Kantor & Lapsley [Page 27] - DELETED modules/ntp/ChangeLog Index: modules/ntp/ChangeLog ================================================================== --- modules/ntp/ChangeLog +++ /dev/null @@ -1,17 +0,0 @@ -2003-04-16 Pat Thoyts - - * time.man: Renamed the man page to avoid clashing with - * ntp_time.man: the tcl time.n manual page. - -2003-03-20 Pat Thoyts - - * time.test: Added a test package. - * pkgIndex.tcl: Added a package index file. - -2003-03-17 Pat Thoyts - - * time.tcl: - * time.man: Initial checkin of an RFC 868 client. - * examples/ntp/rdate.tcl: A demo using the time package to request - the current time from a remote host via tcp or udp. - DELETED modules/ntp/ntp_time.man Index: modules/ntp/ntp_time.man ================================================================== --- modules/ntp/ntp_time.man +++ /dev/null @@ -1,89 +0,0 @@ -[manpage_begin ntp_time n 1.0.0] -[copyright {2002, Pat Thoyts }] -[moddesc {ntp}] -[titledesc {Tcl Time Service Client}] -[require Tcl 8.2] -[require time [opt 1.0.0]] -[description] -[para] - -This package implements a client for the RFC 868 TIME protocol. This -simple protocol returns the time in seconds since 1 January 1900 to -either tcp or udp clients. - -[section COMMANDS] - -[list_begin definitions] - -[call [cmd ::time::gettime] [opt [arg "options"]] [arg timeserver] [opt [arg "port"]]] - -Get the time from [arg timeserver]. You may specify any of the options -listed for the [cmd configure] command here. This command returns a -token which must then be used with the remaining commands in this -package. Once you have finished, you should use [cmd cleanup] to -release all resources. - -[call [cmd ::time::configure] [opt [arg "options"]]] - -Called with no arguments this command returns all the current -configuration options and values. Otherwise it should be called with -pairs of option name and value. - -[list_begin definitions] -[lst_item "[cmd -protocol] [arg number]"] - Set the default network protocol. This defaults to udp if the tcludp - package is available. Otherwise it will use tcp. -[lst_item "[cmd -port] [arg number]"] - Set the default port to use. RFC868 uses port 37. -[lst_item "[cmd -timeout] [arg number]"] - Set the default timeout value in milliseconds. The default is 10 seconds. -[lst_item "[cmd -command] [arg number]"] - Set a command procedure to be run when a reply is received. The - procedure is called with the time token appended to the argument list. -[lst_item "[cmd -loglevel] [arg number]"] - Set the logging level. The default is 'warning'. -[list_end] - -[call [cmd ::time::cget] [arg name]] - -Get the current value for the named configuration option. - -[call [cmd ::time::unixtime] [arg token]] - Format the returned time for the unix epoch. RFC868 time defines - time 0 as 1 Jan 1900, while unix time defines time 0 as 1 Jan - 1970. This command converts the reply to unix time. - -[call [cmd ::time::status] [arg token]] - Returns the status flag. For a successfully completed query this will be - [emph ok]. May be [emph error] or [emph timeout] or [emph eof]. - See also [cmd ::time::error] - -[call [cmd ::time::error] [arg token]] - Returns the error message provided for requests whose status is [emph error]. - If there is no error message then an empty string is returned. - -[call [cmd ::time::reset] [arg token] [arg [opt reason]]] - Reset or cancel the query optionally specfying the reason to record - for the [cmd error] command. - -[call [cmd ::time::wait] [arg token]] - Wait for a query to complete and return the status upon completion. - -[call [cmd ::time::cleanup] [arg token]] - Remove all state variables associated with the request. - -[list_end] - - -[example { -% set tok [::time::gettime ntp2a.mcc.ac.uk] -% set t [::time::unixtime $tok] -% ::time::cleanup $tok -}] - -[see_also ntp] -[section AUTHORS] -Pat Thoyts - -[keywords time NTP RFC868] -[manpage_end] DELETED modules/ntp/pkgIndex.tcl Index: modules/ntp/pkgIndex.tcl ================================================================== --- modules/ntp/pkgIndex.tcl +++ /dev/null @@ -1,11 +0,0 @@ -# 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 time 1.0.0 [list source [file join $dir time.tcl]] DELETED modules/ntp/time.tcl Index: modules/ntp/time.tcl ================================================================== --- modules/ntp/time.tcl +++ /dev/null @@ -1,314 +0,0 @@ -# time.tcl - Copyright (C) 2003 Pat Thoyts -# -# Client for the Time protocol. See RFC868 -# -# ------------------------------------------------------------------------- -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# ------------------------------------------------------------------------- -# -# $Id: time.tcl,v 1.3 2003/03/26 22:58:59 patthoyts Exp $ - -package require Tcl 8.0; # tcl minimum version -package require log; # tcllib 1.3 - -namespace eval ::time { - variable version 1.0.0 - variable rcsid {$Id: time.tcl,v 1.3 2003/03/26 22:58:59 patthoyts Exp $} - - namespace export configure gettime server cleanup - - variable options - if {![info exists options]} { - array set options { - -timeserver {} - -port 37 - -protocol tcp - -timeout 10000 - -command {} - -loglevel warning - } - if {![catch {package require udp}]} { - set options(-protocol) udp - } - log::lvSuppressLE emergency 0 - log::lvSuppressLE $options(-loglevel) 1 - log::lvSuppress $options(-loglevel) 0 - } - - # Store conversions for other epochs. Currently only unix - but maybe - # there are some others out there. - variable epoch - if {![info exists epoch]} { - array set epoch { - unix 2208988800 - } - } - - # The id for the next token. - variable uid - if {![info exists uid]} { - set uid 0 - } -} - -# ------------------------------------------------------------------------- - -# Description: -# Retrieve configuration settings for the time package. -# -proc ::time::cget {optionname} { - return [configure $optionname] -} - -# Description: -# Configure the package. -# With no options, returns a list of all current settings. -# -proc ::time::configure {args} { - variable options - set r {} - set cget 0 - - if {[llength $args] < 1} { - foreach opt [lsort [array names options]] { - lappend r $opt $options($opt) - } - return $r - } - - if {[llength $args] == 1} { - set cget 1 - } - - while {[string match -* [set option [lindex $args 0]]]} { - switch -glob -- $option { - -port { set r [SetOrGet -port $cget] } - -timeout { set r [SetOrGet -timeout $cget] } - -protocol { set r [SetOrGet -protocol $cget] } - -command { set r [SetOrGet -command $cget] } - -loglevel { - if {$cget} { - return $options(-loglevel) - } else { - set options(-loglevel) [Pop args 1] - log::lvSuppressLE emergency 0 - log::lvSuppressLE $options(-loglevel) 1 - log::lvSuppress $options(-loglevel) 0 - } - } - -- { Pop args ; break } - default { - set err [join [lsort [array names State -*]] ", "] - return -code error "bad option $option: must be $err" - } - } - Pop args - } - - return $r -} - -# Set/get package options. -proc ::time::SetOrGet {option {cget 0}} { - upvar options options - upvar args args - if {$cget} { - return $options($option) - } else { - set options($option) [Pop args 1] - } - return {} -} - -# ------------------------------------------------------------------------- - -proc ::time::gettime {args} { - variable options - variable uid - set token [namespace current]::[incr uid] - variable $token - upvar 0 $token State - - array set State [array get options] - set State(status) unconnected - set State(data) {} - - while {[string match -* [set option [lindex $args 0]]]} { - switch -glob -- $option { - -port { set State(-port) [Pop args 1] } - -timeout { set State(-timeout) [Pop args 1] } - -protocol { set State(-protocol) [Pop args 1] } - -command { set State(-command) [Pop args 1] } - -- { Pop args ; break } - default { - set err [join [lsort [array names State -*]] ", "] - return -code error "bad option $option: must be $err" - } - } - Pop args - } - - set len [llength $args] - if {$len < 1 || $len > 2} { - return -code error "wrong # args: - \"gettime ?options? timeserver ?port?\"" - } - set State(-timeserver) [lindex $args 0] - if {$len == 2} { - set State(-port) [lindex $args 1] - } - - return [QueryTime $token] -} - -proc ::time::QueryTime {token} { - variable $token - upvar 0 $token State - - if {$State(-protocol) == "udp"} { - set State(sock) [udp_open] - udp_conf $State(sock) $State(-timeserver) $State(-port) - } else { - set State(sock) [socket $State(-timeserver) $State(-port)] - } - - # setup the timeout - if {$State(-timeout) > 0} { - set State(after) [after $State(-timeout) \ - [list [namespace origin reset] $token timeout]] - } - - set State(status) connect - fconfigure $State(sock) -translation binary -buffering none - - puts -nonewline $State(sock) "abcd" - - fileevent $State(sock) readable \ - [list [namespace origin ClientReadEvent] $token] - - if {$State(-command) == {}} { - wait $token - } - - return $token -} - -proc ::time::unixtime {{token {}}} { - variable $token - variable epoch - upvar 0 $token State - if {$State(status) != "ok"} { - return -code error $State(error) - } - binary scan $State(data) I r - return [expr {$r - $epoch(unix)}] -} - -proc ::time::status {token} { - variable $token - upvar 0 $token State - return $State(status) -} - -proc ::time::error {token} { - variable $token - upvar 0 $token State - set r {} - if {[info exists State(error)]} { - set r $State(error) - } - return $r -} - -proc ::time::wait {token} { - variable $token - upvar 0 $token State - - if {$State(status) == "connect"} { - vwait [subst $token](status) - } - - return $State(status) -} - -proc ::time::reset {token {why reset}} { - variable $token - upvar 0 $token State - set reason {} - set State(status) $why - catch {fileevent $State(sock) readable {}} - if {$why == "timeout"} { - set reason "timeout ocurred" - } - Finish $token $reason -} - -# Description: -# Remove any state associated with this token. -# -proc ::time::cleanup {token} { - variable $token - upvar 0 $token State - if {[info exists State]} { - unset State - } -} - -# ------------------------------------------------------------------------- - -proc ::time::ClientReadEvent {token} { - variable $token - upvar 0 $token State - - set State(data) [read $State(sock)] - #FIX ME: acquire peer data? - set State(status) ok - Finish $token - return -} - -proc ::time::Finish {token {errormsg {}}} { - variable $token - upvar 0 $token State - global errorInfo errorCode - - if {[string length $errormsg] > 0} { - set State(error) $errormsg - set State(status) error - } - catch {close $State(sock)} - catch {after cancel $State(after)} - if {[info exists State(-command)] && $State(-command) != {}} { - if {[catch {eval $State(-command) {$token}} err]} { - if {[string length $errormsg] == 0} { - set State(error) [list $err $errorInfo $errorCode] - set State(status) error - } - } - if {[info exists State(-command)]} { - unset State(-command) - } - } -} - -# ------------------------------------------------------------------------- -# Description: -# Pop the nth element off a list. Used in options processing. -# -proc ::time::Pop {varname {nth 0}} { - upvar $varname args - set r [lindex $args $nth] - set args [lreplace $args $nth $nth] - return $r -} - -# ------------------------------------------------------------------------- - -package provide time $::time::version - -# ------------------------------------------------------------------------- -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: DELETED modules/ntp/time.test Index: modules/ntp/time.test ================================================================== --- modules/ntp/time.test +++ /dev/null @@ -1,106 +0,0 @@ -# time.test = Copyright (C) 2003 Pat Thoyts -# -# Exercise the tcllib time package. -# -# $Id: time.test,v 1.2 2003/03/20 00:41:04 patthoyts Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} - -if {[catch {package require time}]} { - puts "ERROR: failed to load time package. Skipping tests." - ::tcltest::cleanupTests - return -} - -# ------------------------------------------------------------------------- - -set testScript tstsrv.tmp - -proc createServerProcess {} { - file delete -force $::testScript - set f [open $::testScript w+] - puts $f { - proc ::srv {chan args} { - if {[catch { - set r [binary format I [expr {[clock seconds] + 2208988800}]] - puts "connect on $chan from [fconfigure $chan -peername]" - puts -nonewline $chan $r - close $chan - } msg]} { - puts stderr "error: $msg" - } - set ::done 1 - } - - set s [socket -server ::srv 0] - fconfigure $s -translation binary -buffering none -eofchar {} - set port [lindex [fconfigure $s -sockname] 2] - - puts $port - flush stdout - vwait ::done - update - exit - } - close $f - - set f [open |[list [::tcltest::interpreter] $::testScript] r] - fconfigure $f -buffering line -blocking 1 - #after 500 {set _init 1} ; vwait _init - return $f -} - -# ------------------------------------------------------------------------- - -set token {} - -test time-1.1 {time::gettime} { - global token - list [catch { - set f [createServerProcess] - gets $f port - set token [::time::gettime -protocol tcp localhost $port] - set r {} - } msg] $msg -} {0 {}} - -test time-1.2 {time::status} { - global token - list [catch {time::status $token} m] $m -} {0 ok} - -test time-1.2 {time::unixtime} { - global token - list [catch { - set t [time::unixtime $token] - string is integer -strict $t - } m] $m -} {0 1} - -test time-1.3 {time::cget} { - global token - list [catch { - time::cget -port - } m] $m -} {0 37} - -test time-1.4 {time::cleanup} { - global token - list [catch { - time::cleanup $token - } m] $m -} {0 {}} - -# ------------------------------------------------------------------------- -file delete -force $::testScript -::tcltest::cleanupTests -return - -# -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: DELETED modules/pop3/ChangeLog Index: modules/pop3/ChangeLog ================================================================== --- modules/pop3/ChangeLog +++ /dev/null @@ -1,198 +0,0 @@ -2003-04-21 Andreas Kupries - - * pop3.test (0.6): Fixed test 0.6, removed dependency on service - running on port 25 (smtp), using fake service on some free port - instead. - -2003-04-11 Andreas Kupries - - * pop3.tcl: - * pop3.man: - * pkgIndex.tcl: Set version of the package to to 1.6 - -2003-04-09 Andreas Kupries - - * pop3.man: Documented new API. - - * pop3.tcl: More logging of internal activity. Final nail into the - bug #528928 (Additional border cases were not handled yet, - incorrect handling detected through the new testsuite). - - New API 'pop3::config'. - - * pop3.test: Testsuite rewritten. Uses the sub-process and server - support provided by the new module 'devtools'. Avoids the stdin - lockup on windows. Uses a micro server for fixed responses to - the client instead of a true pop3 server, simplifies the - testing, less external dependencies, also better control over - the data sent to the client = easier to create intentionally - (semi-)bogus information to stress border cases. - -2003-04-03 Andreas Kupries - - * pop3.tcl: Fixed bug in the new code which wasn't found because - that case was untestable when using a full-blown pop3 demon (Was - unable to construct a message which caused the boundary - condition to ocur in the client). Found using the microserver - code. - - * pop3.test: Removed test case planned to test the above mentioned - boundary case. Added code for a microserver based testcase which - does exercize the condition. Deactivated as microserver is not - yet part of tcllib. - - * pop3.test: - * srv.tcl: Corrected leftover changes from yesterday which should - not have been in the commit. I.e. reactivated reporting and - correct cleanup. - -2003-04-02 Andreas Kupries - - * srv.tcl: - * pop3.test: Added tests and messages for bug #528928. - - * pop3.tcl (pop3::open): Bug fix, close channel to server when - talking to it fails (no greeting, login failure). This cleans up - a leak of open sockets. - - (pop3::RetrFast): Fixed bug #528928 where a .-stuffed line was - misinterpreted as mail terminator. - -2003-01-16 Andreas Kupries - - * pop3.man: More semantic markup, less visual one. - -2002-10-14 Andreas Kupries - - * pop3.test: Updated to expect 10 messages in pop3-6.0. - * srv.tcl: Initialize server with 10 messages. Divert log output - to server log. Prevents hangs in pop3-6.0. - - * pop3.tcl (pop3::retrieve): Changed conditionals around [scan] to - check for the actual number of conversions required to make the - code work, instead of < 0. This fixes bug 620062. - -2002-09-04 Andreas Kupries - - * srv.tcl: Extended to cleanup the fake maildrop directories when - exiting the server. - - * pop3.test: Updated to handle differences between 8.3 and 8.4 - (different error messages). Added code to suppress logging under - normal circumstances. Extended to clean up the log file created - by the test pop3 server. - -2002-09-03 Andreas Kupries - - * pop3.test: Added testcase 6.0, a nano-client to retrieve and - delete all messages on a pop server in one go. Directly derived - from the script for Tcllib bug #501577. Unable to reproduce that - bug :( - - * pop3.test: - * clnt.tcl: - * srv.tcl: Added testsuite. Incomplete. No test of 'delete' - command yet. The problems found by the testsuite so far were all - in the used pop3 server (pop3d module of tcllib). - -2002-03-25 Andreas Kupries - - * pop3.man: New file, doctools manpage. - -2002-01-15 Andreas Kupries - - * Bumped version to 1.5.1 - -2001-12-11 Andreas Kupries - - * pop3.tcl (retrieve): Forgot several 'RETR $index' - commands. Fixed now. This is tcllib bug item #490151 reported by - an unknown person. - -2001-10-16 Andreas Kupries - - * pop3.n: - * pop3.tcl: - * pkgIndex.tcl: Version up to 1.5 - -2001-08-20 Andreas Kupries - - * pop3.tcl: Added UIDL command, patch [448634] by Mark G. Saye - . Code was added manually as - the patch was not applicable anymore after the recent changes - (see below). Updated implementation of UIDL to use the new - command [RetrSlow] instead of performing the retrieval by - itself. Also updated the implementations of the TOP and LIST - commands to do the same. - -2001-08-02 Andreas Kupries - - * pop3.n: Updated to new package version, see [447013] too. - - * pop3.tcl: Lots of changes with regard to items [443613] and - [443645]. Switched auto back to binary (or else the counting of - octects is not right and we will hang trying to read more than - is coming from the server). This means we have to perform EOL - translation on the message on our own, this was effectively an - unreported bug. also unreported was that the faster code did not - do .-unstuffing, which the slower line-by-line code did. This is - now fixed too. My thanks to Ashwin Hirschi - for his help in testing the code. - -2001-07-31 Andreas Kupries - - * pkgIndex.tcl: Updated to reflect pkg version in the code. After - the fact comment: This also fixes SF bug [447013] - - * pop3.tcl: Added 'state' variable to remember state information - about the active (= open) pop3 connections. This state includes - information about the retrieval mode to use and whether we are - talking to an MS Exchange server or not. MS Exchange can't be - set automatically for now, but the retrieval mode is - auto-detected. Because of the former, pop3::open now accepts the - options -msex and -retr-mode. This should allay and fix the SF - bugs [443613] and [443645]. - - (pop3::list): Fixed bug [443619]. - -2001-06-21 Andreas Kupries - - * pop3.tcl: Fixed dubious code reported by frink. - -2001-01-24 Scott Redman - - * pop3.tcl: Fixed a bug when getting the "." back - with extra \r by adding a [string trimright $line]. - Reported by Joe English, [bug: 124477]. - -2000-09-14 Scott Redman - - * pop3.tcl: Based on feedback from Cameron Laird, I did some - digging into the RFC and figured out that using the number of - octets given by RETR at the beginning of the retrieval to grab - that number of bytes was far more efficient. Thanks to Cameron - for pointing that out. Speed for retrieval should be greatly - improved. Changed version to 1.1. - -2000-05-18 Scott Redman - - * pop3.tcl: - * pop3.n: Applied patch from Petteri Kettunen to add the LIST and - TOP implementations. See RFC1939. Also removed a spurious puts - command. [bug: 5426] - -2000-05-17 Scott Redman - - * pop3.tcl: Remove extra '.'s added by the POP3 server. If a - line begins with a '.', the server will add a '.' to the line to - prevent confusion with the end-of-message character (which is also - '.'). [bug: 5522] - -2000-03-06 Scott Redman - - * ChangeLog: - * man.macros: - * pkgIndex.tcl: - * pop3.n: - * pop3.tcl: New POP3 email client API, inspired by Scott - Beasley's "frenchie" email client program. DELETED modules/pop3/clnt.tcl Index: modules/pop3/clnt.tcl ================================================================== --- modules/pop3/clnt.tcl +++ /dev/null @@ -1,89 +0,0 @@ -#!/bin/sh -# -*- tcl -*- \ -exec tclsh "$0" ${1+"$@"} - -# pop3 client, loaded with sequence of operations -# to perform. - -set modules [file dirname $testdir] -set pop [file join $modules pop3] - -# Read client functionality - -source [file join $testdir pop3.tcl] - -proc log {code {payload {}}} { - puts stdout [list $code $payload] - flush stdout - return -} - -proc res {fail msg} {log res [list $fail $msg]} -proc wait {} {while {[gets stdin line] < 0} {}} - -# Run the provided operations ... -# Mini CPU ... - -set chan {} -set fail 0 - -foreach op $ops { - foreach {cmd ca} $op break - switch -exact -- $cmd { - wait {wait} - poke { - res 0 $::pop3::state($chan) - } - open { - foreach {user passwd} $ca break - set fail [catch {set chan [::pop3::open localhost $user $passwd $port]} msg] - res $fail $msg - } - close { - set fail [catch {::pop3::close $chan} msg] - res $fail $msg - } - status { - set fail [catch {::pop3::status $chan} msg] - res $fail $msg - } - top { - foreach {msg n} $ca break - set fail [catch {::pop3::top $chan $msg $n} msg] - res $fail $msg - } - retrieve { - foreach {start end} $ca break - if {$end == {}} {set end -1} - set fail [catch {::pop3::retrieve $chan $start $end} msg] - res $fail $msg - } - delete { - foreach {start end} $ca break - if {$end == {}} {set end -1} - set fail [catch {::pop3::delete $chan $start $end} msg] - res $fail $msg - } - list { - foreach {msg} $ca break - set fail [catch {::pop3::list $chan $msg} msg] - res $fail $msg - } - uidl { - foreach {msg} $ca break - set fail [catch {::pop3::uidl $chan $msg} msg] - res $fail $msg - } - last { - set fail [catch {::pop3::last $chan} msg] - res $fail $msg - } - } - if {$fail} break -} - -# Wait for last call from control and then exit. - -log done -wait -exit DELETED modules/pop3/pkgIndex.tcl Index: modules/pop3/pkgIndex.tcl ================================================================== --- modules/pop3/pkgIndex.tcl +++ /dev/null @@ -1,12 +0,0 @@ -# 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. - -if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded pop3 1.6 [list source [file join $dir pop3.tcl]] DELETED modules/pop3/pop3.man Index: modules/pop3/pop3.man ================================================================== --- modules/pop3/pop3.man +++ /dev/null @@ -1,181 +0,0 @@ -[manpage_begin pop3 n 1.6] -[comment {-*- tcl -*- doctools manpage}] -[moddesc {Tcl POP3 Client Library}] -[titledesc {Tcl client for POP3 email protocol}] -[require Tcl 8.2] -[require pop3 [opt 1.6]] -[description] - -The [package pop3] package provides a simple Tcl-only client library -for the POP3 email protocol (RFC1939). It works by opening the -standard POP3 socket on the server, transmitting the username and -password, then providing a Tcl API to access the POP3 protocol -commands. All server errors are returned as Tcl errors (thrown) which -must be caught with the Tcl [cmd catch] command. - -[section COMMANDS] - -[list_begin definitions] - -[call [cmd ::pop3::open] [opt "[option -msex] 0|1"] [opt "[option -retr-mode] retr|list|slow"] [arg {host username password}] [opt [arg port]]] - -Open a socket connection to the server specified by [arg host], -transmit the [arg username] and [arg password] as login information to -the server. The default port number is 110, which can be overridden -using the optional [arg port] argument. The return value is a channel -used by all of the other ::pop3 functions. - -[nl] - -The command recognizes the options [option -msex] and - -[option -retr-mode]. The first of them can be used to notify the -package of the fact that the server to talk to is an MS Exchange -server (which has some oddities we have to work around). The default -is 0. - -[nl] - -The retrieval mode determines how exactly messages are read from the -server. The allowed values are [const retr], [const list] and -[const slow]. The default is [const retr]. See - -[cmd ::pop3::retrieve] for more information. - - -[call [cmd ::pop3::config] [arg chan]] - -Returns the configuration of the pop3 connection identified by the -channel handle [arg chan] as a serialized array. - - -[call [cmd ::pop3::status] [arg chan]] - -Query the server for the status of the mail spool. The status is -returned as a list containing two elements, the first is the number of -email messages on the server and the second is the size (in octets, 8 -byte blocks) of the entire mail spool. - -[call [cmd ::pop3::last] [arg chan]] - -Query the server for the last email message read from the spool. This -value includes all messages read from all clients connecting to the -login account. This command may not be supported by the email server, -in which case the server may return 0 or an error. - -[call [cmd ::pop3::retrieve] [arg {chan startIndex}] [opt [arg endIndex]]] - -Retrieve a range of messages from the server. If the [arg endIndex] -is not specified, only one message will be retrieved. The return -value is a list containing each message as a separate element. See -the [arg startIndex] and [arg endIndex] descriptions below. - -[nl] - -The retrieval mode determines how exactly messages are read from the -server. The mode [const retr] assumes that the RETR command delivers -the size of the message as part of the command status and uses this to -read the message efficiently. In mode [const list] RETR does not -deliver the size, but the LIST command does and we use this to -retrieve the message size before the actual retrieval, which can then -be done efficiently. In the last mode, [const slow], the system is -unable to obtain the size of the message to retrieve in any manner and -falls back to reading the message from the server line by line. - -[nl] - -It should also be noted that the system checks upon the configured -mode and falls back to the slower modes if the above assumptions are -not true. - - -[call [cmd ::pop3::delete] [arg {chan startIndex}] [opt [arg endIndex]]] - -Delete a range of messages from the server. If the [arg endIndex] is -not specified, only one message will be deleted. Note, the indices -are not reordered on the server, so if you delete message 1, then the -first message in the queue is message 2 (message index 1 is no longer -valid). See the [arg startIndex] and [arg endIndex] descriptions -below. - -[list_begin definitions] - -[lst_item [arg startIndex]] - -The [arg startIndex] may be an index of a specific message starting -with the index 1, or it have any of the following values: - -[list_begin definitions] - -[lst_item [const start]] - -This is a logical value for the first message in the spool, equivalent -to the value 1. - -[lst_item [const next]] - -The message immediately following the last message read, see -[cmd ::pop3::last]. - -[lst_item [const end]] - -The most recent message in the spool (the end of the spool). This is -useful to retrieve only the most recent message. - -[list_end] - -[lst_item [arg endIndex]] - -The [arg endIndex] is an optional parameter and defaults to the value -"-1", which indicates to only retrieve the one message specified by - -[arg startIndex]. If specified, it may be an index of a specific -message starting with the index "1", or it may have any of the -following values: - -[list_begin definitions] - -[lst_item [const last]] - -The message is the last message read by a POP3 client, see -[cmd ::pop3::last]. - -[lst_item [const end]] - -The most recent message in the spool (the end of the spool). - -[list_end] -[list_end] - -[call [cmd ::pop3::list] [arg chan] [opt [arg msg]]] - -Returns the scan listing of the mailbox. If parameter [arg msg] is -given, then the listing only for that message is returned. - - -[call [cmd ::pop3::top] [arg chan] [arg msg] [arg n] ] - - -Optional POP3 command, not all servers may support this. - -[cmd ::pop3::top] retrieves headers of a message, specified by -parameter [arg msg], and number of [arg n] lines from the message -body. - -[call [cmd ::pop3::uidl] [arg chan] [opt [arg msg]]] - -Optional POP3 command, not all servers may support this. - -[cmd ::pop3::uidl] returns the uid listing of the mailbox. If the -parameter [arg msg] is specified, then the listing only for that -message is returned. - -[call [cmd ::pop3::close] [arg chan]] - -Gracefully close the connect after sending a POP3 QUIT command down -the socket. - -[list_end] - -[keywords mail email pop pop3 RFC1939] -[manpage_end] DELETED modules/pop3/pop3.n Index: modules/pop3/pop3.n ================================================================== --- modules/pop3/pop3.n +++ /dev/null @@ -1,156 +0,0 @@ -'\" -'\" Copyright (c) 2000 by Ajuba Solutions. -'\" All rights reserved. -'\" -'\" RCS: @(#) $Id: pop3.n,v 1.9 2002/01/18 20:51:16 andreas_kupries Exp $ -'\" -.so man.macros -.TH pop3 n 1.5.1 pop3 "Tcl POP3 Client Library" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -pop3 \- Tcl client for POP3 email protocol -.SH SYNOPSIS -\fBpackage require Tcl 8.2\fR -.sp -\fBpackage require pop3 ?1.5.1?\fR -.sp -\fB::pop3::open\fR ?-msex \fB0|1\fR? ?-retr-mode \fBretr|list|slow\fR? \fIhost user Ipassword \fR?\fIport\fR? -.sp -\fB::pop3::status\fR \fIchan\fR -.sp -\fB::pop3::last\fR \fIchan\fR -.sp -\fB::pop3::retrieve\fR \fIchan startIndex \fR?\fIendIndex\fR? -.sp -\fB::pop3::delete\fR \fIchan startIndex \fR?\fIendIndex\fR? -.sp -\fB::pop3::list\fR \fIchan\fR \fR?\fImsg\fR? -.sp -\fB::pop3::top\fR \fIchan\fR \fImsg\fR \fIn\fR -.sp -\fB::pop3::uidl\fR \fIchan\fR \fR?\fImsg\fR? -.sp -\fB::pop3::close\fR \fIchan\fR -.sp -.BE -.SH DESCRIPTION -.PP -The \fBpop3\fR package provides a simple Tcl-only client library for -the POP3 email protocol (RFC1939). It works by opening the standard POP3 socket -on the server, transmitting the username and password, then providing -a Tcl API to access the POP3 protocol commands. All server errors -are returned as Tcl errors (thrown) which must be caught with the Tcl -\fBcatch\fR command. -.SH COMMANDS -.TP -\fB::pop3::open\fR ?-msex \fB0|1\fR? ?-retr-mode \fBretr|list|slow\fR? \fIhost username password \fR?\fIport\fR? -Open a socket connection to the server specified by \fIhost\fR, -transmit the \fIusername\fR and \fIpassword\fR as login information to -the server. The default port number is 110, which can be overridden -using the optional \fIport\fR argument. The return value is a channel -used by all of the other ::pop3 functions. - -The command recognizes the options \fI-msex\fR and -\fI-retr-mode\fR. The first of them can be used to notify the package -of the fact that the server to talk to is an MS Exchange server (which -has some oddities we have to work around). The default is 0. - -The retrieval mode determines how exactly messages are read from the -server. The allowed values are \fBretr\fR, \fBlist\fR and -\fBslow\fR. The default is \fBretr\fR. See \fB::pop3::retrieve\fR for -more information. -.TP -\fB::pop3::status\fR \fIchan\fR -Query the server for the status of the mail spool. The status is -returned as a list containing two elements, the first is the number of -email messages on the server and the second is the size (in octets, 8 -byte blocks) of the entire mail spool. -.TP -\fB::pop3::last\fR \fIchan\fR -Query the server for the last email message read from the spool. This -value includes all messages read from all clients connecting to the -login account. This command may not be supported by the email -server, in which case the server may return 0 or an error. -.TP -\fB::pop3::retrieve\fR \fIchan startIndex \fR?\fIendIndex\fR? -Retrieve a range of messages from the server. If the \fIendIndex\fR -is not specified, only one message will be retrieved. The return -value is a list containing each message as a separate element. See -the \fIstartIndex\fR and \fIendIndex\fR descriptions below. - -The retrieval mode determines how exactly messages are read from the -server. The mode \fBretr\fR assumes that the RETR command delivers the -size of the message as part of the command status and uses this to -read the message efficiently. In mode \fBlist\fR RETR does not deliver -the size, but the LIST command does and we use this to retrieve the -message size before the actual retrieval, which can then be done -efficiently. In the last mode, \fBslow\fR, the system is unable to -obtain the size of the message to retrieve in any manner and falls -back to reading the message from the server line by line. - -It should also be noted that the system checks upon the configured -mode and falls back to the slower modes if the above assumptions are -not true. -.TP -\fB::pop3::delete\fR \fIchan startIndex \fR?\fIendIndex\fR? -Delete a range of messages from the server. If the \fIendIndex\fR is -not specified, only one message will be deleted. Note, the indices -are not reordered on the server, so if you delete message 1, then the -first message in the queue is message 2 (message index 1 is no longer -valid). See the \fIstartIndex\fR and \fIendIndex\fR descriptions below. -.TP -\fIstartIndex\fR -The \fIstartIndex\fR may be an index of a specific message starting -with the index 1, or it have any of the following values: -.RS -.TP -\fBstart\fR -This is a logical value for the first message in the spool, equivalent -to the value 1. -.TP -\fBnext\fR -The message immediately following the last message read, see -\fB::pop3::last\fR. -.TP -\fBend\fR -The most recent message in the spool (the end of the spool). This is -useful to retrieve only the most recent message. -.RE -.TP -\fIendIndex\fR -The \fIendIndex\fR is an optional parameter and defaults to the value -1, -which indicates to only retrieve the one message specified by -\fIstartIndex\fR. If specified, it may be an index of a specific -message starting with the index 1, or it have any of the following -values: -.RS -.TP -\fBlast\fR -The message is the last message read by a POP3 client, see -\fB::pop3::last\fR. -.TP -\fBend\fR -The most recent message in the spool (the end of the spool). -.RE -.TP -\fB::pop3::list\fR \fIchan\fR \fR?\fImsg\fR? -Returns the scan listing of the mailbox. If parameter \fImsg\fR -is given, then the listing only for that message is returned. -.TP -\fB::pop3::top\fR \fIchan\fR \fImsg\fR \fIn\fR -Optional POP3 command, not all servers may support this. -\fB::pop3::top\fR retrieves headers of a message, specified by parameter -\fImsg\fR, and number of \fIn\fR lines from the message body. -.TP -\fB::pop3::uidl\fR \fIchan\fR \fR?\fImsg\fR? -Optional POP3 command, not all servers may support this. -\fB::pop3::uidl\fR returns the uid listing of the mailbox. If the -parameter \fImsg\fR is specified, then the listing only for that -message is returned. -.TP -\fB::pop3::close\fR \fIchan\fR -Gracefully close the connect after sending a POP3 QUIT command down -the socket. -.SH KEYWORDS -mail, email, pop, pop3, RFC1939 DELETED modules/pop3/pop3.tcl Index: modules/pop3/pop3.tcl ================================================================== --- modules/pop3/pop3.tcl +++ /dev/null @@ -1,685 +0,0 @@ -# pop3.tcl -- -# -# POP3 mail client package, written in pure Tcl. -# Some concepts borrowed from "frenchie", a POP3 -# mail client utility written by Scott Beasley. -# -# Copyright (c) 2000 by Ajuba Solutions. -# portions Copyright (c) 2000 by Scott Beasley -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: pop3.tcl,v 1.25 2003/04/11 20:07:24 andreas_kupries Exp $ - -package require Tcl 8.2 -package require cmdline -package require log -package provide pop3 1.6 - -namespace eval ::pop3 { - - # The state variable remembers information about the open pop3 - # connection. It is indexed by channel id. The information is - # a keyed list, with keys "msex" and "retr_mode". The value - # associated with "msex" is boolean, a true value signals that the - # server at the other end is MS Exchange. The value associated - # with "retr_mode" is one of {retr, list, slow}. - - # The value of "msex" influences how the translation for the - # channel is set and is determined by the contents of the received - # greeting. The value of "retr_mode" is initially "retr" and - # completely determined by the first call to [retrieve]. For "list" - # the system will use LIST before RETR to retrieve the message size. - - # The state can be influenced by options given to "open". - - variable state - array set state {} - -} - -# ::pop3::config -- -# -# Retrieve configuration of pop3 connection -# -# Arguments: -# chan The channel, returned by ::pop3::open -# -# Results: -# A serialized array. - -proc ::pop3::config {chan} { - variable state - return $state($chan) -} - -# ::pop3::close -- -# -# Close the connection to the POP3 server. -# -# Arguments: -# chan The channel, returned by ::pop3::open -# -# Results: -# None. - -proc ::pop3::close {chan} { - variable state - catch {::pop3::send $chan "QUIT"} - unset state($chan) - ::close $chan -} - -# ::pop3::delete -- -# -# Delete messages on the POP3 server. -# -# Arguments: -# chan The channel, returned by ::pop3::open -# start The first message to delete in the range. -# May be "next" (the next message after the last -# one seen, see ::pop3::last), "start" (aka 1), -# "end" (the last message in the spool, for -# deleting only the last message). -# end (optional, defaults to -1) The last message -# to delete in the range. May be "last" -# (the last message viewed), "end" (the last -# message in the spool), or "-1" (the default, -# any negative number means delete only -# one message). -# -# Results: -# None. -# May throw errors from the server. - -proc ::pop3::delete {chan start {end -1}} { - - set count [lindex [::pop3::status $chan] 0] - set last 0 - catch {set last [::pop3::last $chan]} - - if {![string is integer $start]} { - if {[string match $start "next"]} { - set start $last - incr start - } elseif {$start == "start"} { - set start 1 - } elseif {$start == "end"} { - set start $count - } else { - error "POP3 Deletion error: Bad start index $start" - } - } - if {$start == 0} { - set start 1 - } - - if {![string is integer $end]} { - if {$end == "end"} { - set end $count - } elseif {$end == "last"} { - set end $last - } else { - error "POP3 Deletion error: Bad end index $end" - } - } elseif {$end < 0} { - set end $start - } - - if {$end > $count} { - set end $count - } - - for {set index $start} {$index <= $end} {incr index} { - if {[catch {::pop3::send $chan "DELE $index"} errorStr]} { - error "POP3 DELETE ERROR: $errorStr" - } - } - return {} -} - -# ::pop3::last -- -# -# Gets the index of the last email read from the server. -# Note, some POP3 servers do not support this feature, -# in which case the value returned may always be zero, -# or an error may be thrown. -# -# Arguments: -# chan The channel, returned by ::pop3::open -# -# Results: -# The index of the last email message read, which may -# be zero if none have been read or if the server does -# not support this feature. -# Server errors may be thrown, including some cases -# when the LAST command is not supported. - -proc ::pop3::last {chan} { - - if {[catch { - set resultStr [::pop3::send $chan "LAST"] - } errorStr]} { - error "POP3 LAST ERROR: $errorStr" - } - - return [string trim $resultStr] -} - -# ::pop3::list -- -# -# Returns "scan listing" of the mailbox. If parameter msg -# is defined, then the listing only for the given message -# is returned. -# -# Arguments: -# chan The channel open to the POP3 server. -# msg The message number (optional). -# -# Results: -# If msg parameter is not given, Tcl list of scan listings in -# the maildrop is returned. In case msg parameter is given, -# a list of length one containing the specified message listing -# is returned. - -proc ::pop3::list {chan {msg ""}} { - global PopErrorNm PopErrorStr debug - - if {$msg == ""} { - if {[catch {::pop3::send $chan "LIST"} errorStr]} { - error "POP3 LIST ERROR: $errorStr" - } - set msgBuffer [RetrSlow $chan] - } else { - # argument msg given, single-line response expected - - if {[catch {expr {0 + $msg}}]} { - error "POP3 LIST ERROR: malformed message number '$msg'" - } else { - set msgBuffer [string trim [::pop3::send $chan "LIST $msg"]] - } - } - return $msgBuffer -} - -# pop3::open -- -# -# Opens a connection to a POP3 mail server. -# -# Arguments: -# args A list of options and values, possibly empty, -# followed by the regular arguments, i.e. host, user, -# passwd and port. The latter is optional. -# -# host The name or IP address of the POP3 server host. -# user The username to use when logging into the server. -# passwd The password to use when logging into the server. -# port (optional) The socket port to connect to, defaults -# to port 110, the POP standard port address. -# -# Results: -# The connection channel (a socket). -# May throw errors from the server. - -proc ::pop3::open {args} { - variable state - array set cstate {msex 0 retr_mode retr} - - log::log debug "pop3::open | [join $args]" - - while {[set err [cmdline::getopt args {msex.arg retr-mode.arg} opt arg]]} { - if {$err < 0} { - return -code error "::pop3::open : $arg" - } - switch -exact -- $opt { - msex { - if {![string is boolean $arg]} { - return -code error \ - ":pop3::open : Argument to -msex has to be boolean" - } - set cstate(msex) $arg - } - retr-mode { - switch -exact -- $arg { - retr - list - slow { - set cstate(retr_mode) $arg - } - default { - return -code error \ - ":pop3::open : Argument to -retr-mode has to be one of retr, list or slow" - } - } - } - default {# Can't happen} - } - } - - if {[llength $args] > 4} { - return -code error "To many arguments to ::pop3::open" - } - if {[llength $args] < 3} { - return -code error "Not enough arguments to ::pop3::open" - } - foreach {host user password port} $args break - if {$port == {}} { - set port 110 - } - - log::log debug "pop3::open | protocol, connect to $host $port" - - # Argument processing is finally complete, now open the channel - - set chan [socket $host $port] - fconfigure $chan -buffering none - - log::log debug "pop3::open | connect on $chan" - - if {$cstate(msex)} { - # We are talking to MS Exchange. Work around its quirks. - fconfigure $chan -translation binary - } else { - fconfigure $chan -translation {binary crlf} - } - - log::log debug "pop3::open | wait for greeting" - - if {[catch {::pop3::send $chan {}} errorStr]} { - ::close $chan - error "POP3 CONNECT ERROR: $errorStr" - } - - if {0} { - # -FUTURE- Identify MS Exchange servers - set cstate(msex) 1 - - # We are talking to MS Exchange. Work around its quirks. - fconfigure $chan -translation binary - } - - log::log debug "pop3::open | authenticate $user (*password not shown*)" - - if {[catch { - ::pop3::send $chan "user $user" - ::pop3::send $chan "pass $password" - } errorStr]} { - ::close $chan - error "POP3 LOGIN ERROR: $errorStr" - } - - # Remember the state. - - set state($chan) [array get cstate] - - log::log debug "pop3::open | ok ($chan)" - return $chan -} - -# ::pop3::retrieve -- -# -# Retrieve email message(s) from the server. -# -# Arguments: -# chan The channel, returned by ::pop3::open -# start The first message to retrieve in the range. -# May be "next" (the next message after the last -# one seen, see ::pop3::last), "start" (aka 1), -# "end" (the last message in the spool, for -# retrieving only the last message). -# end (optional, defaults to -1) The last message -# to retrieve in the range. May be "last" -# (the last message viewed), "end" (the last -# message in the spool), or "-1" (the default, -# any negative number means retrieve only -# one message). -# -# Results: -# A list containing all of the messages retrieved. -# May throw errors from the server. - -proc ::pop3::retrieve {chan start {end -1}} { - variable state - array set cstate $state($chan) - - set count [lindex [::pop3::status $chan] 0] - set last 0 - catch {set last [::pop3::last $chan]} - - if {![string is integer $start]} { - if {[string match $start "next"]} { - set start $last - incr start - } elseif {$start == "start"} { - set start 1 - } elseif {$start == "end"} { - set start $count - } else { - error "POP3 Retrieval error: Bad start index $start" - } - } - if {$start == 0} { - set start 1 - } - - if {![string is integer $end]} { - if {$end == "end"} { - set end $count - } elseif {$end == "last"} { - set end $last - } else { - error "POP3 Retrieval error: Bad end index $end" - } - } elseif {$end < 0} { - set end $start - } - - if {$end > $count} { - set end $count - } - - set result {} - - ::log::log debug "pop3 $chan retrieve $start -- $end" - - for {set index $start} {$index <= $end} {incr index} { - switch -exact -- $cstate(retr_mode) { - retr { - set sizeStr [::pop3::send $chan "RETR $index"] - - ::log::log debug "pop3 $chan retrieve ($sizeStr)" - - if {[scan $sizeStr {%d %s} size dummy] < 1} { - # The server did not deliver the size information. - # Switch our mode to "list" and use the slow - # method this time. The next call will use LIST before - # RETR to get the size information. If even that fails - # the system will fall back to slow mode all the time. - - ::log::log debug "pop3 $chan retrieve - no size information, go slow" - - set cstate(retr_mode) list - set state($chan) [array get cstate] - - # Retrieve in slow motion. - set msgBuffer [RetrSlow $chan] - } else { - ::log::log debug "pop3 $chan retrieve - size information present, use fast mode" - - set msgBuffer [RetrFast $chan $size] - } - } - list { - set sizeStr [::pop3::send $chan "LIST $index"] - - if {[scan $sizeStr {%d %d %s} dummy size dummy] < 2} { - # Not even LIST generates the necessary size information. - # Switch to full slow mode and don't bother anymore. - - set cstate(retr_mode) slow - set state($chan) [array get cstate] - - ::pop3::send $chan "RETR $index" - - # Retrieve in slow motion. - set msgBuffer [RetrSlow $chan] - } else { - # Ignore response of RETR, already know the size - # through LIST - - ::pop3::send $chan "RETR $index" - set msgBuffer [RetrFast $chan $size] - } - } - slow { - # Retrieve in slow motion. - - ::pop3::send $chan "RETR $index" - set msgBuffer [RetrSlow $chan] - } - } - lappend result $msgBuffer - } - return $result -} - -# ::pop3::RetrFast -- -# -# Fast retrieval of a message from the pop3 server. -# Internal helper to prevent code bloat in "pop3::retrieve" -# -# Arguments: -# chan The channel to read the message from. -# -# Results: -# The text of the retrieved message. - -proc ::pop3::RetrFast {chan size} { - set msgBuffer [read $chan $size] - - foreach line [split $msgBuffer \n] { - ::log::log debug "pop3 $chan fast <$line>" - } - - # There is a small discrepance in counting octets we have to be - # aware of. 'size' is #octets before transmission, i.e. can be - # with one eol character, CR or LF. The channel system in binary - # mode counts every character, and the protocol specified CRLF as - # eol, so for every line in the message we read that many - # characters _less_. Another factor which can cause a miscount is - # the ".-stuffing performed by the sender. I.e. what we got now is - # not necessarily the complete message. We have to perform slow - # reads to get the remainder of the message. This has another - # complication. We cannot simply check for a line containing the - # terminating signature, simply because the point where the - # message was broken in two might jsut be in between the dots of a - # "\r\n..\r\n" sequence. We have to make sure that we do not - # misinterpret the second part of this sequence as terminator. - # Another possibility: "\r\n.\r\n" is broken just after the dot. - # Then we have to ensure to not to miss the terminator entirely. - - # Sometimes the gets returns nothing, need to get the real - # terminating "." / " - - if {[string range $msgBuffer end-3 end] == "\n.\r\n"} { - # Complete terminator found. Remove it from the message buffer. - - ::log::log debug "pop3 $chan /5__" - set msgBuffer [string range $msgBuffer 0 end-3] - - } elseif {[string range $msgBuffer end-2 end] == "\n.\r"} { - # Complete terminator found. Remove it from the message buffer. - # Also perform an empty read to remove the missing '\n' from - # the channel. If we don't do this all following commands will - # run into off-by-one (character) problems. - - ::log::log debug "pop3 $chan /4__" - set msgBuffer [string range $msgBuffer 0 end-2] - while {[read $chan 1] != "\n"} {} - - } elseif {[string range $msgBuffer end-1 end] == "\n."} { - # \n. at the end of the fast buffer. - # Can be \n.\r\n = Terminator - # or \n..\r\n = dot-stuffed single . - - log::log debug "pop3 $chan /check for cut .. or terminator sequence" - - # Idle until non-empty line encountered. - while {[set line [gets $chan]] == ""} {} - if {"$line" == "\r"} { - # Terminator already found. Note that we have to - # remove the partial terminator sequence from the - # message buffer. - ::log::log debug "pop3 $chan /3__ <$line>" - set msgBuffer [string range $msgBuffer 0 end-1] - } else { - # Append line and look for the real terminator - append msgBuffer $line - ::log::log debug "pop3 $chan ____ <$line>" - while {[set line [gets $chan]] != ".\r"} { - ::log::log debug "pop3 $chan ____ <$line>" - append msgBuffer $line - } - ::log::log debug "pop3 $chan /2__ <$line>" - } - } else { - while {[set line [gets $chan]] != ".\r"} { - ::log::log debug "pop3 $chan ____ <$line>" - append msgBuffer $line - } - ::log::log debug "pop3 $chan /1__ <$line>" - } - - ::log::log debug "pop3 $chan done" - - # Map both cr+lf and cr to lf to simulate auto EOL translation, then - # unstuff .-stuffed lines. - - return [string map [::list \n.. \n.] [string map [::list \r \n] [string map [::list \r\n \n] $msgBuffer]]] -} - -# ::pop3::RetrSlow -- -# -# Slow retrieval of a message from the pop3 server. -# Internal helper to prevent code bloat in "pop3::retrieve" -# -# Arguments: -# chan The channel to read the message from. -# -# Results: -# The text of the retrieved message. - -proc ::pop3::RetrSlow {chan} { - - set msgBuffer "" - - while {1} { - set line [string trimright [gets $chan] \r] - ::log::log debug "pop3 $chan slow $line" - - # End of the message is a line with just "." - if {$line == "."} { - break - } elseif {[string index $line 0] == "."} { - set line [string range $line 1 end] - } - - append msgBuffer $line "\n" - } - - return $msgBuffer -} - -# ::pop3::send -- -# -# Send a command string to the POP3 server. This is an -# internal function, but may be used in rare cases. -# -# Arguments: -# chan The channel open to the POP3 server. -# cmdstring POP3 command string -# -# Results: -# Result string from the POP3 server, except for the +OK tag. -# Errors from the POP3 server are thrown. - -proc ::pop3::send {chan cmdstring} { - global PopErrorNm PopErrorStr debug - - if {$cmdstring != {}} { - ::log::log debug "pop3 $chan >>> $cmdstring" - puts $chan $cmdstring - } - - set popRet [string trim [gets $chan]] - ::log::log debug "pop3 $chan <<< $popRet" - - if {[string first "+OK" $popRet] == -1} { - error [string range $popRet 4 end] - } - - return [string range $popRet 3 end] -} - -# ::pop3::status -- -# -# Get the status of the mail spool on the POP3 server. -# -# Arguments: -# chan The channel, returned by ::pop3::open -# -# Results: -# A list containing two elements, {msgCount octetSize}, -# where msgCount is the number of messages in the spool -# and octetSize is the size (in octets, or 8 bytes) of -# the entire spool. - -proc ::pop3::status {chan} { - - if {[catch {set statusStr [::pop3::send $chan "STAT"]} errorStr]} { - error "POP3 STAT ERROR: $errorStr" - } - - # Dig the sent size and count info out. - set rawStatus [split [string trim $statusStr]] - - return [::list [lindex $rawStatus 0] [lindex $rawStatus 1]] -} - -# ::pop3::top -- -# -# Optional POP3 command (see RFC1939). Retrieves message header -# and given number of lines from the message body. -# -# Arguments: -# chan The channel open to the POP3 server. -# msg The message number to be retrieved. -# n Number of lines returned from the message body. -# -# Results: -# Text (with newlines) from the server. -# Errors from the POP3 server are thrown. - -proc ::pop3::top {chan msg n} { - global PopErrorNm PopErrorStr debug - - if {[catch {::pop3::send $chan "TOP $msg $n"} errorStr]} { - error "POP3 TOP ERROR: $errorStr" - } - - return [RetrSlow $chan] -} - -# ::pop3::uidl -- -# -# Returns "uid listing" of the mailbox. If parameter msg -# is defined, then the listing only for the given message -# is returned. -# -# Arguments: -# chan The channel open to the POP3 server. -# msg The message number (optional). -# -# Results: -# If msg parameter is not given, Tcl list of uid listings in -# the maildrop is returned. In case msg parameter is given, -# a list of length one containing the uid of the specified -# message listing is returned. - -proc ::pop3::uidl {chan {msg ""}} { - if {$msg == ""} { - if {[catch {::pop3::send $chan "UIDL"} errorStr]} { - error "POP3 UIDL ERROR: $errorStr" - } - set msgBuffer [RetrSlow $chan] - } else { - # argument msg given, single-line response expected - - if {[catch {expr {0 + $msg}}]} { - error "POP3 UIDL ERROR: malformed message number '$msg'" - } else { - set msgBuffer [string trim [::pop3::send $chan "UIDL $msg"]] - } - } - - return $msgBuffer -} DELETED modules/pop3/pop3.test Index: modules/pop3/pop3.test ================================================================== --- modules/pop3/pop3.test +++ /dev/null @@ -1,525 +0,0 @@ -# -*- tcl -*- -# pop3.test: tests for the pop3 client. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 2002-2003 by Andreas Kupries -# All rights reserved. -# -# RCS: @(#) $Id: pop3.test,v 1.8 2003/04/21 19:56:27 andreas_kupries Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -source [file join $::tcltest::testsDirectory pop3.tcl] -source [file join [file dirname $::tcltest::testsDirectory] devtools subserv.tcl] - -if 0 { - rename test test__ - proc test {args} { - puts "[lindex $args 0] ____________________________________________" - return [uplevel test__ $args] - } -} - - -package require pop3 -puts "tcltest [package present tcltest]" -puts "pop3 [package present pop3]" - -# ---------------------------------------------------------------------- -# Dialog scripts for the various servers we start ... - -set __Init [list \ - CrLf \ - {Send {+OK localhost muserv ready <534358773_pop3d1_12380@localhost>}} \ - ] - -set __InitBad [list \ - CrLf \ - {Send {Grumble}} \ - ] - -set __loginOk $__Init -lappend __loginOk \ - {Respond {+OK please send PASS command}} \ - {Respond {+OK congratulations}} - -set __loginFailed $__Init -lappend __loginFailed \ - {Respond {+OK please send PASS command}} \ - {Respond {-ERR authentication failed, sorry}} - -set __loginFailedLock $__Init -lappend __loginFailedLock \ - {Respond {+OK please send PASS command}} \ - {Respond {-ERR could not aquire lock for maildrop ak}} - - -set __statusOk $__loginOk -lappend __statusOk \ - {Respond {+OK 11 176}} - -set __statusOkQuit $__statusOk -lappend __statusOkQuit \ - {Respond {+OK localhost muserv shutting down}} - -set __lastFailed $__loginOk -lappend __lastFailed \ - {Respond {-ERR unknown command 'LAST'}} - -set __uidlFailed $__loginOk -lappend __uidlFailed \ - {Respond {-ERR unknown command 'UIDL'}} - -set __retrFail $__statusOk -lappend __retrFail \ - {Respond {-ERR unknown command 'LAST'}} \ - {Respond {+OK localhost muserv shutting down}} - -set __topFail $__loginOk -lappend __topFail \ - {Respond {-ERR no such message}} \ - {Respond {+OK localhost muserv shutting down}} - -set __message {MIME-Version: 1.0 -Content-Type: text/plain; - charset="us-ascii" - -Test ______ - -. - --- -Done -} - -proc message {msg {n {}}} { - if {$n == {}} {set n [string length $msg]} - set res [list] - foreach l [split $msg \n] { - if {[string match .* $l]} {set l .$l} - lappend res [list Send $l] - } - if {[lindex $res end] == {Send {}}} { - set res [lrange $res 0 end-1] - } - lappend res {Send .} - return [join $res \n] -} - - -proc retrMessage {list msg {n {}}} { - if {$n == {}} {set n [string length $msg]} - global __loginOk - set res $__loginOk - lappend res \ - "Respond {+OK 1 $n}" \ - {Respond {-ERR unknown command 'LAST'}} - if {$list} {lappend res "Respond {+OK 1 $n}"} - lappend res \ - "Respond {+OK $n octets}" \ - [message $msg $n] \ - {Respond {+OK localhost muserv shutting down}} \ - ] - return $res -} - -proc topMessage {msg} { - global __loginOk - set res $__loginOk - lappend res \ - {Respond +OK} \ - [message $msg] \ - {Respond {+OK localhost muserv shutting down}} \ - ] - return $res -} - -proc deleDialog {} { - global __loginOk - set res $__loginOk - lappend res \ - {RespondLog {+OK 11 176}} - - foreach n {1 2 3 4 5 6 7 8 9 10 11} { - lappend res \ - {RespondLog {+OK 11 176}} \ - {RespondLog {-ERR unknown command 'LAST'}} \ - {RespondLog {+OK 6 octets}} \ - {Send {Content-Type: text/plain;}} \ - {Send { charset="us-ascii"}} \ - {Send {}} \ - {Send { }} \ - {Send {.}} \ - {RespondLog {+OK 11 176}} \ - {RespondLog {-ERR unknown command 'LAST'}} \ - "RespondLog {+OK message $n deleted}" - } - lappend res \ - {RespondLog {+OK localhost muserv shutting down}} - return $res -} - - -proc setupServer {responses} { - return [::subserv::muservSpawn [makeFile {} __pop3d] 0 [join $responses \n]] -} - - -proc bgerror {message} { - global errorCode errorInfo - puts $errorCode - puts $errorInfo - return -} - -proc peek {chan} { - set res {} - array set _ [::pop3::config $chan] - foreach k [lsort [array names _]] { - lappend res $k $_($k) - } - return $res -} - -# Reduce output generated by the client. -::log::lvSuppress info -::log::lvSuppress notice -::log::lvSuppress debug -::log::lvSuppress warning - -proc blot {txt sock} { - string map [list $sock SOCK] $txt -} - -# ---------------------------------------------------------------------- -# Tests. Operations -# -# open, status, delete, cut, open, status | -# open, status, delete, close | -# -# ---------------------------------------------------------------------- - -# ---------------------------------------------------------------------- -# ---------------------------------------------------------------------- -# Handling of 'open' alone. -# ---------------------------------------------------------------------- -# ---------------------------------------------------------------------- - -test pop3-0.0 {bogus options} { - catch {pop3::open -foo bar localhost ak smash 7664} msg - set msg -} {::pop3::open : Illegal option "foo"} - -test pop3-0.1 {bogus options} { - catch {pop3::open -msex bar localhost ak smash 2534} msg - set msg -} {:pop3::open : Argument to -msex has to be boolean} - -test pop3-0.2 {bogus options} { - catch {pop3::open -retr-mode bar localhost ak smash 54345} msg - set msg -} {:pop3::open : Argument to -retr-mode has to be one of retr, list or slow} - -test pop3-0.3 {not enough arguments} { - catch {pop3::open localhost ak} msg - set msg -} {Not enough arguments to ::pop3::open} - -test pop3-0.4 {too many arguments} { - catch {pop3::open localhost ak smash 432490 dribble} msg - set msg -} {To many arguments to ::pop3::open} - -test pop3-0.5 {connect to missing server} { - catch {pop3::open localhost foo foo 1111} msg - set msg -} {couldn't open socket: connection refused} - -test pop3-0.6 {wrong type of server (fake)} { - set port [setupServer $__InitBad] - catch {pop3::open localhost foo foo $port} msg - ::subserv::muservStop - regsub {^([^:]*:).*$} $msg {\1} msg - set msg -} {POP3 CONNECT ERROR:} - -test pop3-0.7 {unknown user} { - set port [setupServer $__loginFailed] - catch {pop3::open localhost usrX *** $port} msg - ::subserv::muservStop - set msg -} {POP3 LOGIN ERROR: authentication failed, sorry} - -test pop3-0.8 {open pop3 channel} { - set port [setupServer $__loginOk] - set psock [pop3::open localhost ak smash $port] - close $psock - ::subserv::muservStop - regsub -all {[0-9]} $psock {} msg - # status data is retained if the connection is not closed through - # the prescribed api command. - lappend msg [peek $psock] - set msg -} {sock {msex 0 retr_mode retr}} - -test pop3-0.9 {outside close} { - set port [setupServer $__loginOk] - set psock [pop3::open localhost ak smash $port] - close $psock - catch {pop3::close $psock} msg - ::subserv::muservStop - blot $msg $psock -} {can not find channel named "SOCK"} - -test pop3-0.10 {multiple open pop3 channel to same maildrop} { - set port [setupServer $__loginFailedLock] - catch {pop3::open localhost ak smash $port} msg - ::subserv::muservStop - set msg -} {POP3 LOGIN ERROR: could not aquire lock for maildrop ak} - - -# ---------------------------------------------------------------------- -# ---------------------------------------------------------------------- -# Handling of 'status'. -# ---------------------------------------------------------------------- -# ---------------------------------------------------------------------- - -test pop3-1.0 {status after cut} { - set port [setupServer $__loginOk] - set psock [pop3::open localhost ak smash $port] - close $psock - catch {pop3::status $psock} msg - ::subserv::muservStop - blot $msg $psock -} {POP3 STAT ERROR: can not find channel named "SOCK"} - -test pop3-1.1 {status after close} { - set port [setupServer $__loginOk] - set psock [pop3::open localhost ak smash $port] - pop3::close $psock - catch {pop3::status $psock} msg - ::subserv::muservStop - blot $msg $psock -} {POP3 STAT ERROR: can not find channel named "SOCK"} - -test pop3-1.2 {status ok} { - set port [setupServer $__statusOkQuit] - set psock [pop3::open localhost ak smash $port] - set status [pop3::status $psock] - lappend status [peek $psock] - pop3::close $psock - ::subserv::muservStop - set status -} {11 176 {msex 0 retr_mode retr}} - -# ---------------------------------------------------------------------- -# ---------------------------------------------------------------------- -# Handling of 'retrieve'. -# ---------------------------------------------------------------------- -# ---------------------------------------------------------------------- - -test pop3-2.0 {retrieve, no arguments} { - catch {pop3::retrieve} msg - set msg -} [tcltest::getErrorMessage "pop3::retrieve" "chan start ?end?" 0] - -test pop3-2.1 {retrieve, not enough arguments} { - catch {pop3::retrieve sock5} msg - set msg -} [tcltest::getErrorMessage "pop3::retrieve" "chan start ?end?" 1] - -test pop3-2.2 {retrieve, too many arguments} { - catch {pop3::retrieve sock5 foo bar fox} msg - set msg -} [tcltest::tooManyMessage "pop3::retrieve" "chan start ?end?"] - -test pop3-2.3 {retrieve without valid channel} { - catch {pop3::retrieve sock5 foo bar} msg - set msg -} {can't read "state(sock5)": no such element in array} - -test pop3-2.4 {retrieve, invalid start} { - set port [setupServer $__retrFail] - set psock [pop3::open localhost ak smash $port] - catch {pop3::retrieve $psock foo bar} msg - pop3::close $psock - ::subserv::muservStop - set msg -} {POP3 Retrieval error: Bad start index foo} - -test pop3-2.5 {retrieve, invalid end} { - set port [setupServer $__retrFail] - set psock [pop3::open localhost ak smash $port] - catch {pop3::retrieve $psock 0 bar} msg - pop3::close $psock - ::subserv::muservStop - set msg -} {POP3 Retrieval error: Bad end index bar} - -set msg {MIME-Version: 1.0 -Content-Type: text/plain; - charset="us-ascii" - - -} - -foreach {n mode len listflag} { - 0 retr {} 0 - 1 list {} 1 - 2 slow {} 0 - 3 retr 98 0 - 4 retr 114 0 - 5 retr 0 0 - 6 retr 1 0 - 7 retr 97 0 - 8 retr 113 0 - 9 retr 99 0 - 10 retr 115 0 - 11 retr 116 0 -} { - test pop3-2.6.$n "retrieval, $mode $len" { - set port [setupServer [retrMessage $listflag $__message $len]] - set psock [pop3::open -retr-mode $mode localhost ak smash $port] - set res [pop3::retrieve $psock 1] - pop3::close $psock - ::subserv::muservStop - set res - } [list $__message] ; # {} -} - -# Note: 2.7 == 2.6.3 | Separate test cases to make clear that they -# Note: 2.8 == 2.6.4 | there created to check for a bug report. - -test pop3-2.7 {fast retrieval, .-stuff border break, #528928} { - set port [setupServer [retrMessage 0 $__message 98]] - set psock [pop3::open -retr-mode retr localhost ak smash $port] - set res [pop3::retrieve $psock 1] - pop3::close $psock - ::subserv::muservStop - set res -} [list $__message] - - -test pop3-2.8 {fast retrieval, .-stuff border break, #528928} { - set port [setupServer [retrMessage 0 $__message 114]] - set psock [pop3::open -retr-mode retr localhost ak smash $port] - set res [pop3::retrieve $psock 1] - pop3::close $psock - ::subserv::muservStop - set res -} [list $__message] - -# ---------------------------------------------------------------------- -# ---------------------------------------------------------------------- -# Handling of 'top'. -# ---------------------------------------------------------------------- -# ---------------------------------------------------------------------- - -test pop3-3.0 {top, no arguments} { - catch {pop3::top} msg - set msg -} [tcltest::getErrorMessage "pop3::top" "chan msg n" 0] - -test pop3-3.1 {top, not enough arguments} { - catch {pop3::top sock5} msg - set msg -} [tcltest::getErrorMessage "pop3::top" "chan msg n" 1] - -test pop3-3.2 {top, too many arguments} { - catch {pop3::top sock5 foo bar fox} msg - set msg -} [tcltest::tooManyMessage "pop3::top" "chan msg n"] - -test pop3-3.3 {top without valid channel} { - catch {pop3::top sockXXX foo bar} msg - set msg -} {POP3 TOP ERROR: can not find channel named "sockXXX"} - -test pop3-3.4 {top, invalid message id} { - set port [setupServer $__topFail] - set psock [pop3::open localhost ak smash $port] - catch {pop3::top $psock foo bar} msg - pop3::close $psock - ::subserv::muservStop - set msg -} {POP3 TOP ERROR: no such message} - -set msg {MIME-Version: 1.0 -Content-Type: text/plain; - charset="us-ascii" - -} - -test pop3-3.5 {top} { - set port [setupServer [topMessage $__message]] - set psock [pop3::open localhost ak smash $port] - set res [pop3::top $psock 1 1] - pop3::close $psock - ::subserv::muservStop - set res -} $__message - -# ---------------------------------------------------------------------- -# ---------------------------------------------------------------------- -# Handling of 'delete' -# ---------------------------------------------------------------------- -# ---------------------------------------------------------------------- - - -test pop3-5.0 {get and delete all message, nano-client} { - set res "" - set port [setupServer [deleDialog]] - - set psock [pop3::open -retr-mode slow localhost ak smash $port] - set x [lindex [pop3::status $psock] 0] - lappend res $x - for {set i 0 } {$i < $x} {incr i} { - set j [expr {$i + 1}] - set msg [pop3::retrieve $psock $j] - lappend res [string length $msg] - pop3::delete $psock $j - } - pop3::close $psock - lappend res [::subserv::muservLog] - ::subserv::muservStop - set res -} {11 67 67 67 67 67 67 67 67 67 67 67 {STAT STAT LAST {RETR 1} STAT LAST {DELE 1} STAT LAST {RETR 2} STAT LAST {DELE 2} STAT LAST {RETR 3} STAT LAST {DELE 3} STAT LAST {RETR 4} STAT LAST {DELE 4} STAT LAST {RETR 5} STAT LAST {DELE 5} STAT LAST {RETR 6} STAT LAST {DELE 6} STAT LAST {RETR 7} STAT LAST {DELE 7} STAT LAST {RETR 8} STAT LAST {DELE 8} STAT LAST {RETR 9} STAT LAST {DELE 9} STAT LAST {RETR 10} STAT LAST {DELE 10} STAT LAST {RETR 11} STAT LAST {DELE 11} QUIT}} - -# ---------------------------------------------------------------------- -# ---------------------------------------------------------------------- -# Handling of 'last', 'uidl'. -# ---------------------------------------------------------------------- -# ---------------------------------------------------------------------- - -## None. The server used here (tcllib/pop3d) -## does not support the 'LAST' command, nor 'UIDL'. - -test pop3-6.0 {last} { - set port [setupServer $__lastFailed] - set psock [pop3::open localhost ak smash $port] - catch {pop3::last $psock} msg - pop3::close $psock - ::subserv::muservStop - set msg -} {POP3 LAST ERROR: unknown command 'LAST'} - -test pop3-6.1 {uidl} { - set port [setupServer $__uidlFailed] - set psock [pop3::open localhost ak smash $port] - catch {pop3::uidl $psock} msg - pop3::close $psock - ::subserv::muservStop - set msg -} {POP3 UIDL ERROR: unknown command 'UIDL'} - - -# ---------------------------------------------------------------------- -# ---------------------------------------------------------------------- -::tcltest::cleanupTests DELETED modules/pop3/srv.tcl Index: modules/pop3/srv.tcl ================================================================== --- modules/pop3/srv.tcl +++ /dev/null @@ -1,119 +0,0 @@ -#!/bin/sh -# -*- tcl -*- \ -exec tclsh "$0" ${1+"$@"} - -# pop3 server for testing the client. -# Spawn this via pipe. Writes the port -# it is listening on to stdout. Takes -# the directory for its file system parts -# from the command line. Exits if stdin is -# closed. - -# tmpdir | set by caller -# testdir | -# logfile | - -set modules [file dirname $testdir] -set popd [file join $modules pop3d] -##set logfile [file join $tmpdir $logfile] -set log [open $logfile w] - -fconfigure $log -buffering none -proc log {txt} {global log ; puts $log $txt} -proc log__ {l t} {log "$l $t"} - -fileevent stdin readable done -fconfigure stdin -blocking 0 -proc done {} { - gets stdin - if {[eof stdin]} { - global dboxdir - log "shutdown through caller" - catch {file delete -force $dboxdir} - exit - } -} - - -# Read server functionality - -source [file join $popd pop3d.tcl] -source [file join $popd pop3d_dbox.tcl] -source [file join $popd pop3d_udb.tcl] - -# Prevent log messages for now, or log into server log. - -::log::lvCmdForall log__ -#::log::lvSuppress info -#::log::lvSuppress notice -#::log::lvSuppress debug -#::log::lvSuppress warning - - -# Setup basic server - -set srv [::pop3d::new] - -$srv configure -port 0 -$srv configure -auth [set udb [::pop3d::udb::new]] -$srv configure -storage [set dbox [::pop3d::dbox::new]] - -# Configure the mail storage ... -# Directory, folders and mails . - -set dboxdir [file join $tmpdir __dbox__] -if {[file exists $dboxdir]} { - file delete -force $dboxdir -} -file mkdir $dboxdir -$dbox base $dboxdir -$dbox add usr0 -$dbox add usr1 - -foreach m {10 20 30 40 50 60 70 80 90 100} { - set f [open [file join $dboxdir usr0 $m] w] - puts $f { - } - close $f - - set f [open [file join $dboxdir usr1 $m] w] - puts $f { - } - close $f -} - -set f [open [file join $dboxdir usr0 15] w] -puts $f {MIME-Version: 1.0 -Content-Type: text/plain; - charset="us-ascii" - -Test1 -Test2 -Test3 -Test4 -x - -. - --- -Done} -close $f - -# Configure the authentication ... - -$udb add ak smash usr0 -$udb add jh wooof usr1 - -# Start server ... - -$srv up -set port [$srv cget -port] -puts stdout $port -flush stdout - -log "server up at $port" - -vwait forever -log "reached infinity" -catch {file delete -force $dboxdir} -exit DELETED modules/pop3d/ChangeLog Index: modules/pop3d/ChangeLog ================================================================== --- modules/pop3d/ChangeLog +++ /dev/null @@ -1,109 +0,0 @@ -2003-04-13 Andreas Kupries - - * pop3d.test: Updated to new version number. - -2003-04-11 Andreas Kupries - - * pop3d.tcl: - * pop3d.man: - * pop3d_dbox.tcl: - * pop3d_dbox.man: - * pop3d_udb.tcl: - * pop3d_udbx.man: - * pkgIndex.tcl: Set version of the package 'pop3d' to to - 1.0.1. 'dbox' is now at version 1.1. 'udb' is now at version - 1.0.1. - -2003-04-09 Andreas Kupries - - * pop3d.tcl: A bit more logging of internals. - -2003-04-02 Andreas Kupries - - * pop3d_dbox.tcl: Started to add log output. - - * pop3d.tcl: Added "."-stuffing. Not done by mime, out of scope, - has to be done by the transport, i.e. the pop3 demon. Also - removed the transmission of superfluous newline at end of the - message. - -2003-01-16 Andreas Kupries - - * pop3d.man: More semantic markup, less visual one. - * pop3d_dbox.man: - * pop3d_udb.man: - -2002-09-03 Andreas Kupries - - * pop3d.tcl (Transfer): Use a single dot to write the - terminator. Not \n.\n. Puts does the terminating \n, and - buildmessage/copymessage the other. Brought the client out of - sync after a retrieval because of an empty line after the - terminator line of the multi-line response. - -2002-08-31 Andreas Kupries - - * Note aside: The pop3 server may understate the size of a message - and of the maildrop. This happens as the package 'mime' we use - to transfer a message may add additional headers not present in - the original message (For example Mime-Version and/or - Content-Type). - - * pop3d.tcl (::pop3d::Transfer): Fixed oversight in my usage of - 'mime::copymessage'. This command copies a mime message to a - channel, but does not know about the framing protocol. In other - words, it does not write the singular dot closing a pop3 data - transfer. We have to do this in the calling routine. Added such - a piece of code. Fixed problem with distinguishing RETR and TOP - modes, wrong conditional. - - * pop3d.test: - * pop3d.tcl (CheckLogin): Now additionally retrieves size of - maildrop after querying the number of waiting messages. - (H_stat): Returns size of maildrop as second result of - STAT. Bugfix, pop3d was not rfc 1939 compliant with respect to - STAT, and now is. This problem was found while working on the - testsuite for the pop3 package (Result of pop3::stat was - bogus). Updated the testsuite. - - * pop3d_dbox.tcl: - * pop3d_dbox.man: method 'size' no accepts a call without message - id and returns the total size of the mail drop for that - case. Reason for the change: see above. - -2002-06-17 Andreas Kupries - - * pop3d.test: Modified testsuite courtesy Gerald Lester - for better execution of the - subshells under windows. - -2002-05-15 Andreas Kupries - - * pop3d.test: - * pop3d.man: - * pop3d_dbox.tcl: Split port into configured port and true - port. This allows the usage of port "0" to force auto-selection - of a free port. Documented the special behaviour of - -port. Created testsuite for pop3 server. Tcllib #532216. - -2002-05-14 Andreas Kupries - - * pop3d_dbox.man: - * pop3d_dbox.tcl: - * pop3d_dbox.test: New method [destroy]. Extended - documentation. Clarified interaction lock/remove and interaction - lock/stat/(size/get/dele). Added checks of message ids in size, - get, dele. Added general check of define base directory to all - methods. Added testsuite. Bugfixes. Tcllib #532216. - - * pop3d_udb.man: - * pop3d_udb.tcl: - * pop3d_udb.test: Documented [destroy]. Fixed documentation of - [lookup], refered to non-existing method [do]. Added [destroy] - method. Added test suite. Tcllib #532216. - -2002-03-19 Andreas Kupries - - * New module. Pop3 server, and associated objects for simple user - and mailbox management. No testsuite yet. Testsuite will be - written in conjunction with testsuite for pop3 module. DELETED modules/pop3d/pkgIndex.tcl Index: modules/pop3d/pkgIndex.tcl ================================================================== --- modules/pop3d/pkgIndex.tcl +++ /dev/null @@ -1,15 +0,0 @@ -# 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. - -if {![package vsatisfies [package provide Tcl] 8.2]} {return} - -package ifneeded pop3d 1.0.1 [list source [file join $dir pop3d.tcl]] -package ifneeded pop3d::udb 1.1 [list source [file join $dir pop3d_udb.tcl]] -package ifneeded pop3d::dbox 1.0.1 [list source [file join $dir pop3d_dbox.tcl]] DELETED modules/pop3d/pop3d.man Index: modules/pop3d/pop3d.man ================================================================== --- modules/pop3d/pop3d.man +++ /dev/null @@ -1,226 +0,0 @@ -[comment {-*- tcl -*-}] -[manpage_begin pop3d n 1.0.1] -[copyright {2002 Andreas Kupries }] -[moddesc {Tcl POP3 Server Package}] -[titledesc {Tcl POP3 server implementation}] -[require Tcl 8.2] -[require pop3d [opt 1.0.1]] -[description] -[para] - -[list_begin definitions] - -[call [cmd ::pop3d::new] [opt [arg serverName]]] - -This command creates a new server object with an associated global Tcl -command whose name is [arg serverName]. - -[list_end] - -The command [cmd serverName] may be used to invoke various operations -on the server. It has the following general form: - -[list_begin definitions] -[call [cmd serverName] [arg option] [opt [arg "arg arg ..."]]] - -[arg Option] and the [arg arg]s determine the exact behavior of the -command. - -[list_end] - -[para] - -A pop3 server can be started on any port the caller has permission for -from the operating system. The default port will be 110, which is the -port defined by the standard (RFC 1939). - -After creating, configuring and starting a the server object will -listen for and accept connections on that port and handle them -according to the POP3 protocol. - -[para] - -[emph Note:] The server provided by this module will handle only the -basic protocol by itself. For the higher levels of user authentication -and handling of the actual mailbox contents callbacks will be invoked. - -[para] - -The following commands are possible for server objects: - -[list_begin definitions] - -[call [arg serverName] [method up]] - -After this call the server will listen for connections on its configured port. - -[call [arg serverName] [method down]] - -After this call the server will stop listening for connections. This -does not affect existing connections. - -[call [arg serverName] [method destroy] [opt [arg mode]]] - -Destroys the server object. Currently open connections are handled -depending on the chosen mode. - -The provided [arg mode]s are: - -[list_begin definitions] - -[lst_item [const kill]] - -Destroys the server immediately, and forcefully closes all currently -open connections. This is the default mode. - -[lst_item [const defer]] - -Stops the server from accepting new connections and will actually -destroy it only after the last of the currently open connections for -the server is closed. - -[list_end] - -[call [arg serverName] [method configure]] - -Returns a list containing all options and their current values in a -format suitable for use by the command [cmd {array set}]. The options -themselves are described in section [sectref OPTIONS]. - -[call [arg serverName] [method configure] [arg -option]] - -Returns the current value of the specified option. This is an alias -for the method [method cget]. The options themselves are described in -section [sectref OPTIONS]. - -[call [arg serverName] [method configure] [arg {-option value}]...] - -Sets the specified option to the provided value. The options -themselves are described in section [sectref OPTIONS]. - -[call [arg serverName] [method cget] [arg -option]] - -Returns the current value of the specified option. The options -themselves are described in section [sectref OPTIONS]. - -[call [arg serverName] [method conn] list] - -Returns a list containing the ids of all connections currently open. - -[call [arg serverName] [method conn] state [arg id]] - -Returns a list suitable for [lb][cmd {array set}][rb] containing the -state of the connection referenced by [arg id]. - -[list_end] - -[section OPTIONS] - -The following options are available to pop3 server objects. - -[list_begin definitions] - -[lst_item "[option -port] [arg port]"] - -Defines the [arg port] to listen on for new connections. Default is -110. This option is a bit special. If [arg port] is set to "0" the -server, or rather the operating system, will select a free port on its -own. When querying [option -port] the id of this chosen port will be -returned. Changing the port while the server is up will neither change -the returned value, nor will it change on which port the server is -listening on. Only after resetting the server via a call to - -[method down] followed by a call to [method up] will the new port take -effect. It is at that time that the value returned when querying -[option -port] will change too. - -[lst_item "[option -auth] [arg command]"] - -Defines a [arg command] prefix to call whenever the authentication of -a user is required. If no such command is specified the server will -reject all users. The interface which has to be provided by the -command prefix is described in section [sectref AUTHENTICATION]. - -[lst_item "[option -storage] [arg command]"] - -Defines a [arg command] prefix to call whenever the handling of -mailbox contents is required. If no such command is specified the -server will claim that all mailboxes are empty. The interface which -has to be provided by the command prefix is described in section -[sectref MAILBOXES]. - -[list_end] - -[section AUTHENTICATION] - -Here we describe the interface which has to be provided by the -authentication callback so that pop3 servers following the interface -of this module are able to use it. - -[list_begin definitions] - -[call [arg authCmd] [method lookup] [arg name]] - -This method is given a user[arg name] and has to return a two-element -list containing the password for this user and a storage reference, in -this order. - -[nl] - -The storage reference is passed unchanged to the storage callback, see -sections [sectref OPTIONS] and [sectref MAILBOXES] for either the -option defining it and or the interface to provide, respectively. - -[list_end] - -[section MAILBOXES] - -Here we describe the interface which has to be provided by the storage -callback so that pop3 servers following the interface of this module -are able to use it. The [arg mbox] argument is the storage reference -as returned by the [method lookup] method of the authentication -command, see section [sectref AUTHENTICATION]. - -[list_begin definitions] - -[call [arg storageCmd] [method dele] [arg mbox] [arg msgList]]] - -Deletes the messages whose numeric ids are contained in the -[arg msgList] from the mailbox specified via [arg mbox]. - -[call [arg storageCmd] [method lock] [arg mbox]] - -This method locks the specified mailbox for use by a single connection -to the server. This is necessary to prevent havoc if several -connections to the same mailbox are open. The complementary method is -[method unlock]. The command will return true if the lock could be set -successfully or false if not. - -[call [arg storageCmd] [method unlock] [arg mbox]] - -This is the complementary method to [method lock], it revokes the lock -on the specified mailbox. - -[call [arg storageCmd] [method size] [arg mbox] [opt [arg msgId]]] - -Determines the size of the message specified through its id in -[arg msgId], in bytes, and returns this number. The command will -return the size of the whole maildrop if no message id was specified. - -[call [arg storageCmd] [method stat] [arg mbox]] - -Determines the number of messages in the specified mailbox and returns -this number. - -[call [arg storageCmd] [method get] [arg mbox] [arg msgId]] - -Returns a handle for the specified message. This handle is a mime -token following the interface described in the documentation of -package [package mime]. The pop3 server will use the functionality of -the mime token to send the mail to the requestor at the other end of a -pop3 connection. - -[list_end] - -[keywords pop3 internet network protocol rfc1939] -[manpage_end] DELETED modules/pop3d/pop3d.tcl Index: modules/pop3d/pop3d.tcl ================================================================== --- modules/pop3d/pop3d.tcl +++ /dev/null @@ -1,1090 +0,0 @@ -# pop3d.tcl -- -# -# Implementation of a pop3 server for Tcl. -# -# Copyright (c) 2002 by Andreas Kupries -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: pop3d.tcl,v 1.8 2003/04/11 20:11:26 andreas_kupries Exp $ - -package require md5 ; # tcllib | APOP -package require mime ; # tcllib | storage callback -package require log ; # tcllib | tracing - -namespace eval ::pop3d { - # Data storage in the pop3d module - # ------------------------------- - # - # There's a number of bits to keep track of for each server and - # connection managed by it. - # - # port - # callbacks - # connections - # connection state - # server state - # - # It would quickly become unwieldy to try to keep these in arrays or lists - # within the pop3d namespace itself. Instead, each pop3 server will - # get its own namespace. Each namespace contains: - # - # port - port to listen on - # sock - listening socket - # authCmd - authentication callback - # storCmd - storage callback - # state - state of the server (up, down, exiting) - # conn - map : sock -> state array - # counter - counter for state arrays - # - # Per connection in a server its own state array 'connXXX'. - # - # id - unique id for the connection (APOP) - # state - state of connection (auth, trans, update, fail) - # name - user for that connection - # storage - storage ref for that user - # logon - authentication method (empty, apop, user) - # deleted - list of deleted messages - # msg - number of messages in storage - # remotehost - name of remote host for connection - # remoteport - remote port for connection - - # counter is used to give a unique name for unnamed server - variable counter 0 - - # commands is the list of subcommands recognized by the server - variable commands [list \ - "cget" \ - "configure" \ - "destroy" \ - "down" \ - "up" \ - ] - - variable version ; set version 1.0.1 - variable server "tcllib/pop3d-$version" - - variable cmdMap ; array set cmdMap { - USER H_user - PASS H_pass - APOP H_apop - STAT H_stat - DELE H_dele - RETR H_retr - TOP H_top - QUIT H_quit - NOOP H_noop - RSET H_rset - LIST H_list - } - # -- UIDL -- not implemented -- - - # Only export one command, the one used to instantiate a new server - namespace export new -} - -# ::pop3d::new -- -# -# Create a new pop3 server with a given name; if no name is given, use -# pop3dX, where X is a number. -# -# Arguments: -# name name of the pop3 server; if null, generate one. -# -# Results: -# name name of the pop3 server created - -proc ::pop3d::new {{name ""}} { - variable counter - - if { [llength [info level 0]] == 1 } { - incr counter - set name "pop3d${counter}" - } - - if { ![string equal [info commands ::$name] ""] } { - return -code error "command \"$name\" already exists, unable to create pop3 server" - } - - # Set up the namespace - namespace eval ::pop3d::pop3d::$name { - variable port 110 - variable trueport 110 - variable sock {} - variable authCmd {} - variable storCmd {} - variable state down - variable conn ; array set conn {} - variable counter 0 - } - - # Create the command to manipulate the pop3 server - interp alias {} ::$name {} ::pop3d::Pop3dProc $name - - return $name -} - -########################## -# Private functions follow - -# ::pop3d::Pop3dProc -- -# -# Command that processes all pop3 server object commands. -# -# Arguments: -# name name of the pop3 server object to manipulate. -# args command name and args for the command -# -# Results: -# Varies based on command to perform - -proc ::pop3d::Pop3dProc {name {cmd ""} args} { - # Do minimal args checks here - if { [llength [info level 0]] == 2 } { - return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" - } - - # Split the args into command and args components - if { [llength [info commands ::pop3d::_$cmd]] == 0 } { - variable commands - set optlist [join $commands ", "] - set optlist [linsert $optlist "end-1" "or"] - return -code error "bad option \"$cmd\": must be $optlist" - } - eval [list ::pop3d::_$cmd $name] $args -} - -# ::pop3d::_up -- -# -# Start listening on the configured port. -# -# Arguments: -# name name of the pop3 server. -# -# Results: -# None. - -proc ::pop3d::_up {name} { - upvar ::pop3d::pop3d::${name}::port port - upvar ::pop3d::pop3d::${name}::trueport trueport - upvar ::pop3d::pop3d::${name}::state state - upvar ::pop3d::pop3d::${name}::sock sock - - log::log debug "pop3d $name up" - if {[string equal $state up]} {return} - - log::log debug "pop3d $name listening, requested port $port" - - set s [socket -server [list ::pop3d::HandleNewConnection $name] $port] - set trueport [lindex [fconfigure $s -sockname] 2] - - ::log::log debug "pop3d $name listening on $trueport, socket $s ([fconfigure $s -sockname])" - - set state up - set sock $s - return -} - -# ::pop3d::_down -- -# -# Stop listening on the configured port. -# -# Arguments: -# name name of the pop3 server. -# -# Results: -# None. - -proc ::pop3d::_down {name} { - upvar ::pop3d::pop3d::${name}::state state - upvar ::pop3d::pop3d::${name}::sock sock - upvar ::pop3d::pop3d::${name}::trueport trueport - upvar ::pop3d::pop3d::${name}::port port - - # Ignore if server is down or exiting - if {![string equal $state up]} {return} - - close $sock - set state down - set sock {} - - set trueport $port - return -} - -# ::pop3d::_destroy -- -# -# Destroy a pop3 server. -# -# Arguments: -# name name of the pop3 server. -# mode destruction mode -# -# Results: -# None. - -proc ::pop3d::_destroy {name {mode kill}} { - upvar ::pop3d::pop3d::${name}::conn conn - - switch -exact -- $mode { - kill { - _down $name - foreach c [array names conn] { - CloseConnection $name $c - } - - namespace delete ::pop3d::pop3d::$name - interp alias {} ::$name {} - } - defer { - if {[array size conn] > 0} { - upvar ::pop3d::pop3d::${name}::state state - - _down $name - set state exiting - return - } - _destroy $name kill - return - } - default { - return -code error \ - "Illegal destruction mode \"$mode\":\ - Expected \"kill\", or \"defer\"" - } - } - return -} - -# ::pop3d::_cget -- -# -# Query option value -# -# Arguments: -# name name of the pop3 server. -# -# Results: -# None. - -proc ::pop3d::_cget {name anoption} { - switch -exact -- $anoption { - -state { - upvar ::pop3d::pop3d::${name}::state state - return $state - } - -port { - upvar ::pop3d::pop3d::${name}::trueport trueport - return $trueport - } - -auth { - upvar ::pop3d::pop3d::${name}::authCmd authCmd - return $authCmd - } - -storage { - upvar ::pop3d::pop3d::${name}::storCmd storCmd - return $storCmd - } - default { - return -code error \ - "Unknown option \"$anoption\":\ - Expected \"-state\", \"-port\", \"-auth\", or \"-storage\"" - } - } - # return - in all branches -} - -# ::pop3d::_configure -- -# -# Query and set option values -# -# Arguments: -# name name of the pop3 server. -# args options and option values -# -# Results: -# None. - -proc ::pop3d::_configure {name args} { - set argc [llength $args] - if {($argc > 1) && (($argc % 2) == 1)} { - return -code error \ - "wrong # args, expected: -option | (-option value)..." - } - if {$argc == 1} { - return [_cget $name [lindex $args 0]] - } - - upvar ::pop3d::pop3d::${name}::trueport trueport - upvar ::pop3d::pop3d::${name}::port port - upvar ::pop3d::pop3d::${name}::authCmd authCmd - upvar ::pop3d::pop3d::${name}::storCmd storCmd - upvar ::pop3d::pop3d::${name}::state state - - if {$argc == 0} { - # Return the full configuration. - return [list \ - -port $trueport \ - -auth $authCmd \ - -storage $storCmd \ - -state $state - ] - } - - while {[llength $args] > 0} { - set option [lindex $args 0] - set value [lindex $args 1] - switch -exact -- $option { - -auth {set authCmd $value} - -storage {set storCmd $value} - -port { - set port $value - - # Propagate to the queried value if the server is down - # and thus has no real true port. - - if {[string equal $state down]} { - set trueport $value - } - } - -state { - return -code error "Option -state is read-only" - } - default { - return -code error \ - "Unknown option \"$option\":\ - Expected \"-port\", \"-auth\", or \"-storage\"" - } - } - set args [lrange $args 2 end] - } - return "" -} - - -# ::pop3d::_conn -- -# -# Query connection state. -# -# Arguments: -# name name of the pop3 server. -# cmd subcommand to perform -# args arguments for subcommand -# -# Results: -# Specific to subcommand - -proc ::pop3d::_conn {name cmd args} { - upvar ::pop3d::pop3d::${name}::conn conn - switch -exact -- $cmd { - list { - if {[llength $args] > 0} { - return -code error "wrong # args: should be \"$name conn list\"" - } - return [array names conn] - } - state { - if {[llength $args] != 1} { - return -code error "wrong # args: should be \"$name conn state connId\"" - } - set sock [lindex $args 0] - upvar $conn($sock) cstate - return [array get cstate] - } - default { - return -code error "bad option \"$cmd\": must be list, or state" - } - } -} - -########################## -########################## -# Server implementation. - -proc ::pop3d::HandleNewConnection {name sock rHost rPort} { - upvar ::pop3d::pop3d::${name}::conn conn - upvar ::pop3d::pop3d::${name}::counter counter - - set csa ::pop3d::pop3d::${name}::conn[incr counter] - set conn($sock) $csa - upvar $csa cstate - - set cstate(remotehost) $rHost - set cstate(remoteport) $rPort - set cstate(server) $name - set cstate(id) "<[string map {- {}} [clock clicks]]_${name}_[pid]@[::info hostname]>" - set cstate(state) "auth" - set cstate(name) "" - set cstate(logon) "" - set cstate(storage) "" - set cstate(deleted) "" - set cstate(msg) 0 - set cstate(size) 0 - - ::log::log notice "$name $sock state auth, waiting for logon" - - fconfigure $sock -buffering line -translation crlf -blocking 0 - - if {[catch {::pop3d::GreetPeer $name $sock} errmsg]} { - close $sock - log::log error "$name $sock greeting $errmsg" - unset cstate - unset conn($sock) - return - } - - fileevent $sock readable [list ::pop3d::HandleCommand $name $sock] - return -} - -proc ::pop3d::CloseConnection {name sock} { - upvar ::pop3d::pop3d::${name}::storCmd storCmd - upvar ::pop3d::pop3d::${name}::state state - upvar ::pop3d::pop3d::${name}::conn conn - - upvar $conn($sock) cstate - - ::log::log debug "$name $sock closing connection" - - if {[catch {close $sock} msg]} { - ::log::log error "$name $sock close: $msg" - } - if {$storCmd != {}} { - # remove possible lock set in storage facility. - if {[catch { - uplevel #0 [linsert $storCmd end unlock $cstate(storage)] - } msg]} { - ::log::log error "$name $sock storage unlock: $msg" - # -W- future ? kill all connections, execute clean up of storage - # -W- facility. - } - } - - unset cstate - unset conn($sock) - - ::log::log notice "$name $sock closed" - - if {[string equal $state existing] && ([array size conn] == 0)} { - _destroy $name - } - return -} - -proc ::pop3d::HandleCommand {name sock} { - # @c Called by the event system after arrival of a new command for - # @c connection. - - # @a sock: Direct access to the channel representing the connection. - - # Client closed connection, bye bye - if {[eof $sock]} { - CloseConnection $name $sock - return - } - - # line was incomplete, wait for more - if {[gets $sock line] < 0} { - return - } - - upvar ::pop3d::pop3d::${name}::conn conn - upvar $conn($sock) cstate - variable cmdMap - - ::log::log info "$name $sock < $line" - - set fail [catch { - set cmd [string toupper [lindex $line 0]] - - if {![::info exists cmdMap($cmd)]} { - # unknown command, use unknown handler - - HandleUnknownCmd $name $sock $cmd $line - } else { - $cmdMap($cmd) $name $sock $cmd $line - } - } errmsg] ;#{} - - if {$fail} { - # Had an error during handling of 'cmd'. - # Handled by closing the connection. - # (We do not know how to relay the internal error to the client) - - ::log::log error "$name $sock $cmd: $errmsg" - CloseConnection $name $sock - } - return -} - -proc ::pop3d::GreetPeer {name sock} { - # @c Called after the initialization of a new connection. Writes the - # @c greeting to the new client. Overides the baseclass definition - # @c (). - # - # @a conn: Descriptor of connection to write to. - - upvar cstate cstate - variable server - - log::log debug "pop3d $name $sock _ Greeting" - - Respond2Client $name $sock +OK \ - "[::info hostname] $server ready $cstate(id)" - return -} - -proc ::pop3d::HandleUnknownCmd {name sock cmd line} { - Respond2Client $name $sock -ERR "unknown command '$cmd'" - return -} - -proc ::pop3d::Respond2Client {name sock ok wtext} { - ::log::log info "$name $sock > $ok $wtext" - puts $sock "$ok $wtext" - return -} - -########################## -########################## -# Command implementations. - -proc ::pop3d::H_user {name sock cmd line} { - # @c Handle USER command. - # - # @a conn: Descriptor of connection to write to. - # @a cmd: The sent command - # @a line: The sent line, with as first word. - - # Called only in places where cstate is known! - upvar cstate cstate - - if {[string equal $cstate(logon) apop]} { - Respond2Client $name $sock -ERR "login mechanism APOP was chosen" - } elseif {[string equal $cstate(state) trans]} { - Respond2Client $name $sock -ERR "client already authenticated" - } else { - # The user name is the first argument to the command - - set cstate(name) [lindex [split $line] 1] - set cstate(logon) user - - Respond2Client $name $sock +OK "please send PASS command" - } - return -} - - -proc ::pop3d::H_pass {name sock cmd line} { - # @c Handle PASS command. - # - # @a conn: Descriptor of connection to write to. - # @a cmd: The sent command - # @a line: The sent line, with as first word. - - # Called only in places where cstate is known! - upvar cstate cstate - - if {[string equal $cstate(logon) apop]} { - Respond2Client $name $sock -ERR "login mechanism APOP was chosen" - } elseif {[string equal $cstate(state) trans]} { - Respond2Client $name $sock -ERR "client already authenticated" - } else { - upvar ::pop3d::pop3d::${name}::authCmd authCmd - - if {$authCmd == {}} { - # No authentication is possible. Reject all users. - CheckLogin $name $sock "" "" "" - return - } - - # The password is given as the first argument of the command - - set pwd [lindex [split $line] 1] - - if {![uplevel #0 [linsert $authCmd end exists $cstate(name)]]} { - ::log::log warning "$name $sock $authCmd lookup $cstate(name) : user does not exist" - CheckLogin $name $sock "" "" "" - return - } - if {[catch { - set info [uplevel #0 [linsert $authCmd end lookup $cstate(name)]] - } msg]} { - ::log::log error "$name $sock $authCmd lookup $cstate(name) : $msg" - CheckLogin $name $sock "" "" "" - return - } - CheckLogin $name $sock $pwd [lindex $info 0] [lindex $info 1] - } - return -} - - -proc ::pop3d::H_apop {name sock cmd line} { - # @c Handle APOP command. - # - # @a conn: Descriptor of connection to write to. - # @a cmd: The sent command - # @a line: The sent line, with as first word. - - # Called only in places where cstate is known! - upvar cstate cstate - - if {[string equal $cstate(logon) user]} { - Respond2Client $name $sock -ERR "login mechanism USER/PASS was chosen" - return - } elseif {[string equal $cstate(state) trans]} { - Respond2Client $name $sock -ERR "client already authenticated" - return - } - - # The first two arguments to the command are user name and its - # response to the challenge set by the server. - - set cstate(name) [lindex $line 1] - set cstate(logon) apop - - upvar ::pop3d::pop3d::${name}::authCmd authCmd - - #log::log debug "authCmd|$authCmd|" - - if {$authCmd == {}} { - # No authentication is possible. Reject all users. - CheckLogin $name $sock "" "" "" - return - } - - set digest [lindex $line 2] - - if {![uplevel #0 [linsert $authCmd end exists $cstate(name)]]} { - ::log::log warning "$name $sock $authCmd lookup $cstate(name) : user does not exist" - CheckLogin $name $sock "" "" "" - return - } - if {[catch { - set info [uplevel #0 [linsert $authCmd end lookup $cstate(name)]] - } msg]} { - ::log::log error "$name $sock $authCmd lookup $cstate(name) : $msg" - CheckLogin $name $sock "" "" "" - return - } - - set pwd [lindex $info 0] - set storage [lindex $info 1] - - ::log::log debug "$name $sock info = <$info>" - - if {$storage == {}} { - # user does not exist, skip over digest computation - CheckLogin $name $sock "" "" $storage - return - } - - # Do the same algorithm as the client to generate a digest, then - # compare our data with information sent by the client. As we are - # using tcl 8.x there is need to use channels, an immediate - # computation is possible. - - set ourDigest [md5::md5 "$cstate(id)$pwd"] - - ::log::log debug "$name $sock digest input <$cstate(id)$pwd>" - ::log::log debug "$name $sock digest outpt <$ourDigest>" - ::log::log debug "$name $sock digest given <$digest>" - - CheckLogin $name $sock $digest $ourDigest $storage - return -} - - -proc ::pop3d::H_stat {name sock cmd line} { - # @c Handle STAT command. - # - # @a conn: Descriptor of connection to write to. - # @a cmd: The sent command - # @a line: The sent line, with as first word. - - # Called only in places where cstate is known! - upvar cstate cstate - - if {[string equal $cstate(state) auth]} { - Respond2Client $name $sock -ERR "client not authenticated" - } else { - # Return number of messages waiting and size of the contents - # of the chosen maildrop in octects. - Respond2Client $name $sock +OK "$cstate(msg) $cstate(size)" - } - - return -} - - -proc ::pop3d::H_dele {name sock cmd line} { - # @c Handle DELE command. - # - # @a conn: Descriptor of connection to write to. - # @a cmd: The sent command - # @a line: The sent line, with as first word. - - # Called only in places where cstate is known! - upvar cstate cstate - - if {[string equal $cstate(state) auth]} { - Respond2Client $name $sock -ERR "client not authenticated" - return - } - - set msgid [lindex $line 1] - - if { - ($msgid < 1) || - ($msgid > $cstate(msg)) || - ([lsearch $msgid $cstate(deleted)] >= 0) - } { - Respond2Client $name $sock -ERR "no such message" - } else { - lappend cstate(deleted) $msgid - Respond2Client $name $sock +OK "message $msgid deleted" - } - return -} - - -proc ::pop3d::H_retr {name sock cmd line} { - # @c Handle RETR command. - # - # @a conn: Descriptor of connection to write to. - # @a cmd: The sent command - # @a line: The sent line, with as first word. - - # Called only in places where cstate is known! - upvar cstate cstate - - if {[string equal $cstate(state) auth]} { - Respond2Client $name $sock -ERR "client not authenticated" - return - } - - set msgid [lindex $line 1] - - if { - ($msgid > $cstate(msg)) || - ([lsearch $msgid $cstate(deleted)] >= 0) - } { - Respond2Client $name $sock -ERR "no such message" - } else { - Transfer $name $sock $msgid - } - return -} - - -proc ::pop3d::H_top {name sock cmd line} { - # @c Handle RETR command. - # - # @a conn: Descriptor of connection to write to. - # @a cmd: The sent command - # @a line: The sent line, with as first word. - - # Called only in places where cstate is known! - upvar cstate cstate - - if {[string equal $cstate(state) auth]} { - Respond2Client $name $sock -ERR "client not authenticated" - return - } - - set msgid [lindex $line 1] - set nlines [lindex $line 2] - - if { - ($msgid > $cstate(msg)) || - ([lsearch $msgid $cstate(deleted)] >= 0) - } { - Respond2Client $name $sock -ERR "no such message" - } elseif {$nlines == {}} { - Respond2Client $name $sock -ERR "missing argument: #lines to read" - } elseif {$nlines < 0} { - Respond2Client $name $sock -ERR \ - "number of lines has to be greater than or equal to zero." - } elseif {$nlines == 0} { - # nlines == 0, no limit, same as H_retr - Transfer $name $sock $msgid - } else { - # nlines > 0 - Transfer $name $sock $msgid $nlines - } - return -} - - -proc ::pop3d::H_quit {name sock cmd line} { - # @c Handle QUIT command. - # - # @a conn: Descriptor of connection to write to. - # @a cmd: The sent command - # @a line: The sent line, with as first word. - - # Called only in places where cstate is known! - upvar cstate cstate - variable server - - set cstate(state) update - - if {$cstate(deleted) != {}} { - upvar ::pop3d::pop3d::${name}::storCmd storCmd - if {$storCmd != {}} { - uplevel #0 [linsert $storCmd end \ - dele $cstate(storage) $cstate(deleted)] - } - } - - after idle [list ::pop3d::CloseConnection $name $sock] - - Respond2Client $name $sock +OK \ - "[::info hostname] $server shutting down" - return -} - - -proc ::pop3d::H_noop {name sock cmd line} { - # @c Handle NOOP command. - # - # @a conn: Descriptor of connection to write to. - # @a cmd: The sent command - # @a line: The sent line, with as first word. - - # Called only in places where cstate is known! - upvar cstate cstate - - if {[string equal $cstate(state) fail]} { - Respond2Client $name $sock -ERR "login failed, no actions possible" - } elseif {[string equal $cstate(state) auth]} { - Respond2Client $name $sock -ERR "client not authenticated" - } else { - Respond2Client $name $sock +OK "" - } - return -} - - -proc ::pop3d::H_rset {name sock cmd line} { - # @c Handle RSET command. - # - # @a conn: Descriptor of connection to write to. - # @a cmd: The sent command - # @a line: The sent line, with as first word. - - # Called only in places where cstate is known! - upvar cstate cstate - - if {[string equal $cstate(state) fail]} { - Respond2Client $name $sock -ERR "login failed, no actions possible" - } elseif {[string equal $cstate(state) auth]} { - Respond2Client $name $sock -ERR "client not authenticated" - } else { - set cstate(deleted) "" - - Respond2Client $name $sock +OK "$cstate(msg) messages waiting" - } - return -} - - -proc ::pop3d::H_list {name sock cmd line} { - # @c Handle LIST command. Generates scan listing - # - # @a conn: Descriptor of connection to write to. - # @a cmd: The sent command - # @a line: The sent line, with as first word. - - # Called only in places where cstate is known! - upvar cstate cstate - - if {[string equal $cstate(state) fail]} { - Respond2Client $name $sock -ERR "login failed, no actions possible" - return - } elseif {[string equal $cstate(state) auth]} { - Respond2Client $name $sock -ERR "client not authenticated" - return - } - - set msgid [lindex $line 1] - - upvar ::pop3d::pop3d::${name}::storCmd storCmd - - if {$msgid == {}} { - # full listing - Respond2Client $name $sock +OK "$cstate(msg) messages" - - set n $cstate(msg) - - for {set i 1} {$i <= $n} {incr i} { - Respond2Client $name $sock $i \ - [uplevel #0 [linsert $storCmd end \ - size $cstate(storage) $i]] - } - puts $sock "." - - } else { - # listing for specified message - - if { - ($msgid < 1) || - ($msgid > $cstate(msg)) || - ([lsearch $msgid $cstate(deleted)] >= 0) - } { - Respond2Client $name $sock -ERR "no such message" - return - } - - Respond2Client $name $sock +OK \ - "$msgid [uplevel #0 [linsert $storCmd end \ - size $cstate(storage) $msgid]]" - return - } -} - -########################## -########################## -# Command helper commands. - -proc ::pop3d::CheckLogin {name sock clientid serverid storage} { - # @c Internal procedure. General code used by USER/PASS and - # @c APOP login mechanisms to verify the given user-id. - # @c Locks the mailbox in case of a match. - # - # @a conn: Descriptor of connection to write to. - # @a clientid: Authentication code transmitted by client - # @a serverid: Authentication code calculated here. - # @a storage: Handle of mailbox requested by client. - - #log::log debug "CheckLogin|$name|$sock|$clientid|$serverid|$storage|" - - upvar cstate cstate - upvar ::pop3d::pop3d::${name}::storCmd storCmd - - set noStorage [expr {$storCmd == {}}] - - if {$storage == {}} { - # The user given by the client has no storage, therefore it does - # not exist. React as if wrong password was given. - - set cstate(state) auth - set cstate(logon) "" - - ::log::log notice "$name $sock state auth, no maildrop" - Respond2Client $name $sock -ERR "authentication failed, sorry" - - } elseif {[string compare $clientid $serverid] != 0} { - # password/digest given by client dos not match - - set cstate(state) auth - set cstate(logon) "" - - ::log::log notice "$name $sock state auth, secret does not match" - Respond2Client $name $sock -ERR "authentication failed, sorry" - - } elseif { - !$noStorage && - ! [uplevel #0 [linsert $storCmd end lock $storage]] - } { - # maildrop is locked already (by someone else). - - set cstate(state) auth - set cstate(logon) "" - - ::log::log notice "$name $sock state auth, maildrop already locked" - Respond2Client $name $sock -ERR \ - "could not aquire lock for maildrop $cstate(name)" - } else { - # everything went fine. allow to proceed in session. - - set cstate(storage) $storage - set cstate(state) trans - set cstate(logon) "" - - set cstate(msg) 0 - if {!$noStorage} { - set cstate(msg) [uplevel #0 [linsert $storCmd end \ - stat $cstate(storage)]] - set cstate(size) [uplevel #0 [linsert $storCmd end \ - size $cstate(storage)]] - } - - ::log::log notice \ - "$name $sock login $cstate(name) $storage $cstate(msg)" - ::log::log notice "$name $sock state trans" - - Respond2Client $name $sock +OK "congratulations" - } - return -} - -proc ::pop3d::Transfer {name sock msgid {limit -1}} { - # We ask the storage for the mime token of the mail and use - # that to generate and copy the mail to the requestor. - - upvar cstate cstate - upvar ::pop3d::pop3d::${name}::storCmd storCmd - - fileevent $sock readable {} - - if {$limit < 0} { - Respond2Client $name $sock +OK \ - "[uplevel #0 [linsert $storCmd end \ - size $cstate(storage) $msgid]] octets" - } else { - Respond2Client $name $sock +OK "" - } - - set token [uplevel #0 [linsert $storCmd end get $cstate(storage) $msgid]] - - ::log::log debug "$name $sock transfering data ($token)" - - if {$limit < 0} { - # Full transfer, we can use "copymessage" and avoid - # construction in memory (depending on source of token). - - log::log debug "$name Transfer $msgid /full" - - #::mime::copymessage $token $sock - - # We do "."-stuffing here. This is not in the scope of the - # MIME library we use, but a transport dependent thing. - -log::log debug "([string trimright [string map [list "\n." "\n.."] [mime::buildmessage $token]] \n])" - - puts $sock [string trimright [string map [list "\n." "\n.."] [mime::buildmessage $token]] \n] - puts $sock . - } else { - # As long as FR #531541 is not implemented we have to build - # the entire message in memory and then cut it down to the - # requested size. If limit was greater than the number of - # lines in the message we will get the terminating "." - # too. Using regsub we make sure that it is not present and - # reattach during the transfer. Otherwise we would have to use - # a regexp/if combo to decide wether to attach the terminator - # not. - - set msg [split [mime::buildmessage $token] \n] - set i 0 - incr limit -1 - while {[lindex $msg $i] != {}} { - incr i - incr limit - } - # i now refers to the line separating header and body - - regsub -- "\n\\.\n$" [string map [list "\n." "\n.."] [join [lrange $msg 0 $limit] \n]] {} data - puts $sock ${data}\n. - } - fileevent $sock readable [list ::pop3d::HandleCommand $name $sock] - ::log::log debug "$name $sock transfer complete, listening again" - # response already sent. - return -} - -########################## -# Module initialization - -package provide pop3d $::pop3d::version DELETED modules/pop3d/pop3d.test Index: modules/pop3d/pop3d.test ================================================================== --- modules/pop3d/pop3d.test +++ /dev/null @@ -1,845 +0,0 @@ -# -*- tcl -*- -# pop3.test: tests for the simple pop3 server. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 2002 by Andreas Kupries -# All rights reserved. -# -# RCS: @(#) $Id: pop3d.test,v 1.4 2003/04/14 04:59:43 andreas_kupries Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -package require pop3d -package require pop3d::udb -package require pop3d::dbox - -puts "pop3d [package present pop3d]" -puts "- udb [package present pop3d::udb]" -puts "- dbox [package present pop3d::dbox]" - -proc bgerror {message} { - global errorCode errorInfo - puts $errorCode - puts $errorInfo - return -} - -# Reduce output generated by the server objects -::log::lvSuppress info -::log::lvSuppress notice -::log::lvSuppress debug -::log::lvSuppress warning - -# ---------------------------------------------------------------------- -# Basic stuff - Create and destroy servers, -# (re)configure and query configuration. - -test pop3-srv-1.0 {anon create/destroy} { - set srv [::pop3d::new] - $srv destroy - set srv -} pop3d1 - -test pop3-srv-1.1 {named create/destroy} { - set srv [::pop3d::new foo] - $srv destroy - set srv -} foo - -test pop3-srv-1.2 {multiple create} { - ::pop3d::new foo - catch {::pop3d::new foo} msg - foo destroy - set msg -} {command "foo" already exists, unable to create pop3 server} - -test pop3-srv-1.3 {correct creation, destruction} { - ::pop3d::new foo - set res [list [info exists ::pop3d::pop3d::foo::port]] - foo destroy - lappend res [info exists ::pop3d::pop3d::foo::port] -} {1 0} - -test pop3-srv-1.4 {unknown method} { - set srv [::pop3d::new] - catch {$srv foo} res - $srv destroy - set res -} {bad option "foo": must be cget, configure, destroy, down, or up} - - -test pop3-srv-2.0 {base configuration} { - set srv [::pop3d::new] - set res [$srv configure] - $srv destroy - set res -} {-port 110 -auth {} -storage {} -state down} - -foreach {n opt val} { - 0 -port 110 - 1 -state down - 2 -auth {} - 3 -storage {} -} { - test pop3-srv-2.1.$n {cget} { - set srv [::pop3d::new] - set res [$srv cget $opt] - $srv destroy - set res - } $val ; # {} - test pop3-srv-2.2.$n {configure get} { - set srv [::pop3d::new] - set res [$srv configure $opt] - $srv destroy - set res - } $val ; # {} -} - -foreach {n opt val} { - 0 -port 2048 - 2 -auth p3udb54 - 3 -storage p3dbox128 -} { - test pop3-srv-2.3.$n {configure set/get} { - set srv [::pop3d::new] - $srv configure $opt $val - set res [$srv cget $opt] - $srv destroy - set res - } $val ; # {} -} - -test pop3-srv-2.3.1 {configure set/get} { - set srv [::pop3d::new] - catch {$srv configure -state exiting} res - $srv destroy - set res -} {Option -state is read-only} - -test pop3-srv-2.4 {configure set/get} { - set srv [::pop3d::new] - $srv configure -port 2048 -auth p3udb54 -storage p3dbox128 - set res [$srv configure] - $srv destroy - set res -} {-port 2048 -auth p3udb54 -storage p3dbox128 -state down} - -test pop3-srv-2.5 {configure} { - set srv [::pop3d::new] - catch {$srv configure -port 2048 -auth} res - $srv destroy - set res -} {wrong # args, expected: -option | (-option value)...} - -test pop3-srv-2.6 {connection introspection} { - set srv [::pop3d::new] - set res [$srv conn list] - $srv destroy - set res -} {} - -test pop3-srv-2.7 {connection introspection} { - set srv [::pop3d::new] - catch {$srv conn list foo} res - $srv destroy - regsub $srv $res @ res - set res -} {wrong # args: should be "@ conn list"} - -test pop3-srv-2.8 {connection introspection} { - set srv [::pop3d::new] - catch {$srv conn state} res - $srv destroy - regsub $srv $res @ res - set res -} {wrong # args: should be "@ conn state connId"} - -test pop3-srv-2.9 {connection introspection} { - set srv [::pop3d::new] - catch {$srv conn state foo bar} res - $srv destroy - regsub $srv $res @ res - set res -} {wrong # args: should be "@ conn state connId"} - -test pop3-srv-2.10 {connection introspection} { - set srv [::pop3d::new] - catch {$srv conn foo} res - $srv destroy - regsub $srv $res @ res - set res -} {bad option "foo": must be list, or state} - - -# ---------------------------------------------------------------------- -# Advanced I: Basic server up, down, check for true listening, -# check state, port information -# -# Helper functionality to create and destroy servers - -proc newsrv {} { - global srv - set srv [::pop3d::new] - $srv configure -port 0 - $srv up - ::log::log debug "$srv @ [$srv cget -port]" - return -} - -proc delsrv {} { - global srv - $srv destroy -} - -# ---------------------------------------------------------------------- - -test pop3-srv-3.0 {basic up} { - newsrv - set res [$srv cget -state] - delsrv - set res -} {up} - -test pop3-srv-3.1 {basic up & down} { - newsrv - set res [$srv cget -state] - $srv down - lappend res [$srv cget -state] - lappend res [$srv cget -port] - delsrv - set res -} {up down 0} - - - -# ---------------------------------------------------------------------- -# Advanced II. -# -# Full interaction with the server. -# -# First some helper commands to for the mgmt of a subprocess -# (Which will be the client), to create a server in a specific -# initial state, and to perform specific queries of the state. - -proc openpipe {} { - global tcl_platform - - switch -exact $tcl_platform(platform) { - windows { - return [open "|\"[info nameofexecutable]\" __script" r] - } - default { - return [open "|[info nameofexecutable] __script" r] - } - } -} - -proc subshell {script args} { - global pipe - removeFile __script - makeFile {} __script - set f [open __script w] - - foreach {k v} $args { - puts $f [list set $k $v] - } - puts $f $script - puts $f exit - close $f - - set ::result [list] - set pipe [openpipe] - fileevent $pipe readable [list subget $pipe] - vwait ::stop - if {[catch {close $pipe} msg]} { - return "$::stop % $msg" - } - return $::stop -} - -proc subshellpar {script myscript args} { - global pipe - removeFile __script - makeFile {} __script - set f [open __script w] - - foreach {k v} $args { - puts $f [list set $k $v] - } - puts $f "proc wait {} {gets stdin ; return}" - puts $f $script - puts $f exit - close $f - ## global srv ; file copy __script __script.$srv - - set ::result [list] - set pipe [openpipe] - fileevent $pipe readable [list subget $pipe] - uplevel 1 $myscript - vwait ::stop - if {[catch {close $pipe} msg]} { - return "$::stop % $msg" - } - return $::stop -} - -proc subgo {} {global pipe ; puts $pipe . ; return} -proc subwait {} {vwait ::result ; return} - -proc subget {pipe} { - if {[eof $pipe]} { - set ::stop [join $::result \n] - return - } - if {[gets $pipe line] < 0} {return} - - # Strip standard variant information out of all responses. - regsub -all [info hostname] $line {%%} line - lappend ::result $line - return -} - -proc asort {kv} { - set tmp [list] - foreach {k v} $kv {lappend tmp [list $k $v]} - set kv [list] - foreach item [lsort -index 0 $tmp] { - foreach {k v} $item break - lappend kv $k $v - } - return $kv -} - -proc ppcstate {state} { - if {$state == {}} {return $state} - global srv - array set tmp $state - - regsub -all [info hostname] $tmp(id) {%%} tmp(id) - regsub "\[0-9\]+_${srv}_\[0-9\]+@" $tmp(id) {==@} tmp(id) - - set tmp(server) [string equal $tmp(server) $srv] - set tmp(remoteport) "" - - return [asort [array get tmp]] -} - -makeDirectory __dbox__ -proc newfsrv {} { - global srv udb dbox - newsrv - $srv configure \ - -auth [set udb [::pop3d::udb::new]] \ - -storage [set dbox [::pop3d::dbox::new]] - - $dbox base __dbox__ - - $dbox add usr0 - $udb add ak smash usr0 - - makeFile {} [file join __dbox__ usr0 10] - makeFile {} [file join __dbox__ usr0 20] - makeFile {} [file join __dbox__ usr0 30] - - $dbox add usr1 - $udb add jh wooof usr1 - return -} - -proc delfsrv {} { - global udb dbox - delsrv - $udb destroy - foreach m [$dbox list] {$dbox remove $m} - $dbox destroy - return -} - - -# ---------------------------------------------------------------------- - -test pop3-srv-4.0 {connection introspection} { - newsrv - - subshellpar { - set c [socket localhost $port] - after 3000 - gets $c - close $c - } { - after 1000 {set res [$srv conn state [$srv conn list]]} - } port [$srv cget -port] ; # {} - - # Postprocess state to remove variable data from comparison - set res [ppcstate $res] - delsrv - set res -} {deleted {} id <==@%%> logon {} msg 0 name {} remotehost 127.0.0.1 remoteport {} server 1 size 0 state auth storage {}} - - -test pop3-srv-5.0 {initial contact, greeting} { - newsrv - - set res [subshell { - set c [socket localhost $port] - puts "greeting: [gets $c]" - close $c - } port [$srv cget -port]] ; # {} - - #regsub -all [info hostname] $res {%%} res - regsub "\[0-9\]+_${srv}_\[0-9\]+@" $res {==@} res - - delsrv - set res -} {greeting: +OK %% tcllib/pop3d-1.0.1 ready <==@%%>} - - -test pop3-srv-6.0 {unknown command} { - newsrv - - set res [subshell { - set c [socket localhost $port] - gets $c - puts $c "FOOBAR blub" ; flush $c - puts [gets $c] - after 3000 - close $c - } port [$srv cget -port]] ; # {} - - delsrv - set res -} {-ERR unknown command 'FOOBAR'} - - -# ---------------------------------------------------------------------- -# Database of possible responses and server states. - -array set cstate { - 0 {deleted {} id <==@%%> logon user msg 0 name foo remotehost 127.0.0.1 remoteport {} server 1 size 0 state auth storage {}} - 1 {deleted {} id <==@%%> logon {} msg 0 name {} remotehost 127.0.0.1 remoteport {} server 1 size 0 state auth storage {}} - 2 {} - 3 {deleted {} id <==@%%> logon {} msg 0 name foo remotehost 127.0.0.1 remoteport {} server 1 size 0 state auth storage {}} - 4 {deleted {} id <==@%%> logon {} msg 3 name ak remotehost 127.0.0.1 remoteport {} server 1 size 3 state trans storage usr0} - 5 {deleted {} id <==@%%> logon {} msg 0 name ak remotehost 127.0.0.1 remoteport {} server 1 size 0 state auth storage {}} - 6 {deleted 1 id <==@%%> logon {} msg 3 name ak remotehost 127.0.0.1 remoteport {} server 1 size 3 state trans storage usr0} -} -array set log { - 0 {+OK please send PASS command} - 1 {+OK %% tcllib/pop3d-1.0.1 shutting down} - 2 {-ERR client not authenticated} - 3 {-ERR authentication failed, sorry} - 4 {-ERR login mechanism USER/PASS was chosen} - 5 {+OK congratulations -ERR client already authenticated} - 6 {+OK congratulations} - 7 {-ERR client already authenticated} - 8 {+OK 3 3} - 9 {+OK message 1 deleted} - 10 {+OK 1 octets} - 11 {+OK } - 12 {+OK 3 messages waiting} - 13 {-ERR no such message} - 14 {+OK 1 1} - 15 {+OK 3 messages 1 1 2 1 3 1} - 16 {+OK 0 messages} -} - -# ====================================================================== -# ====================================================================== -# AUTHORIZATION state - Initial state, after the greeting. -# Allowed commands: USER, APOP, QUIT -# Not permitted: PASS, STAT, DELE, RETR, TOP, RSET, LIST, NOOP -# - -foreach {n cmd lidx cidx} { - 0 {USER foo} 0 0 - 1 {APOP foo bar} 3 3 - 2 {QUIT} 1 2 - 3 {STAT} 2 1 - 4 {DELE 1} 2 1 - 5 {RETR 1} 2 1 - 6 {TOP 1 10} 2 1 - 7 {RSET} 2 1 - 8 {LIST} 2 1 - 9 {NOOP} 2 1 - 10 {PASS xxx} 3 1 -} { - test pop3-srv-7.0.$n "auth, $cmd" { - newfsrv - set res "" - set trace [subshellpar { - set c [socket localhost $port] - gets $c line - puts $c "$cmd" ; flush $c ; gets $c line - after 3000 - close $c - puts $line - } { - after 2000 { - catch { - set res [$srv conn state [$srv conn list]] - } - } - } port [$srv cget -port] cmd $cmd] ; # {} - - # Postprocess state to remove variable data from comparison - set res [ppcstate $res] - delfsrv - list $trace $res - } [list $log($lidx) $cstate($cidx)] ; # {} -} - -# ---------------------------------------------------------------------- -# Mutual exclusion of the different authentication methods, -# block multiple authentication - -test pop3-srv-7.1 "auth, USER/APOP" { - newfsrv - set res "" - set trace [subshellpar { - set c [socket localhost $port] - gets $c - puts $c "USER foo" ; flush $c - gets $c - puts $c "APOP foo barr" ; flush $c - puts [gets $c] - after 3000 - close $c - } { - after 2000 { - set res [$srv conn state [$srv conn list]] - } - } port [$srv cget -port]] ; # {} - - # Postprocess state to remove variable data from comparison - set res [ppcstate $res] - delfsrv - list $trace $res -} [list $log(4) $cstate(0)] ; # {} - -test pop3-srv-7.2 "auth, APOP/USER" { - newfsrv - set res "" - set trace [subshellpar { - package require md5 - set c [socket localhost $port] - regexp {(<.*>)} [gets $c] -> id - set hash [md5::md5 ${id}smash] - puts $c "APOP ak $hash" ; flush $c - set line [gets $c] - puts $c "USER foo" ; flush $c - puts "$line [gets $c]" - after 5000 - close $c - } { - after 3000 { - set res [$srv conn state [$srv conn list]] - } - } port [$srv cget -port]] ; # {} - - # Postprocess state to remove variable data from comparison - set res [ppcstate $res] - delfsrv - list $trace $res -} [list $log(5) $cstate(4)] ; # {} - -# ---------------------------------------------------------------------- -# Checking authentication - -foreach {n user pass lidx cidx} { - 0 foo bar 3 3 - 1 ak bar 3 5 - 2 ak smash 6 4 -} { - test pop3-srv-7.3.$n {USER/PASS} { - newfsrv - set res "" - set trace [subshellpar { - set c [socket localhost $port] - gets $c line - puts $c "USER $user" ; flush $c ; gets $c line - puts $c "PASS $pass" ; flush $c ; gets $c line - after 3000 - close $c - puts $line - } { - after 2000 { - set res [$srv conn state [$srv conn list]] - } - } port [$srv cget -port] user $user pass $pass] ; # {} - - # Postprocess state to remove variable data from comparison - set res [ppcstate $res] - delfsrv - list $trace $res - } [list $log($lidx) $cstate($cidx)] ; # {} - - test pop3-srv-7.4.$n {APOP} { - newfsrv - set res "" - set trace [subshellpar { - package require md5 - set c [socket localhost $port] - gets $c line ; regexp {(<.*>)} $line -> id - set hash [md5::md5 ${id}$pass] - puts $c "APOP $user $hash" ; flush $c ; gets $c line - after 3000 - close $c - puts $line - } { - after 2000 { - set res [$srv conn state [$srv conn list]] - } - } port [$srv cget -port] user $user pass $pass] ; # {} - - # Postprocess state to remove variable data from comparison - set res [ppcstate $res] - delfsrv - list $trace $res - } [list $log($lidx) $cstate($cidx)] ; # {} -} - - -# ====================================================================== -# ====================================================================== -# TRANSACTION state - after successful authentication. -# Allowed commands: QUIT, STAT, DELE, RETR, TOP, RSET, LIST, NOOP -# Not permitted: USER, PASS, APOP -# - -foreach {n cmd lidx cidx} { - 0 {USER foo} 7 4 - 1 {APOP foo bar} 7 4 - 2 {QUIT} 1 2 - 3 {STAT} 8 4 - 4 {DELE 1} 9 6 - 5 {RETR 1} 10 4 - 6 {TOP 1 10} 11 4 - 7 {RSET} 12 4 - 9 {NOOP} 11 4 - 10 {PASS xxx} 7 4 -} { - test pop3-srv-7.5.$n "trans, $cmd" { - newfsrv - set res "" - set trace [subshellpar { - set c [socket localhost $port] - gets $c - puts $c "USER ak" ; flush $c ; gets $c - puts $c "PASS smash" ; flush $c ; gets $c - puts $c "$cmd" ; flush $c - puts [gets $c] - after 3000 - close $c - } { - after 2000 { - catch { - set res [$srv conn state [$srv conn list]] - } - } - } port [$srv cget -port] cmd $cmd] ; # {} - - # Postprocess state to remove variable data from comparison - set res [ppcstate $res] - delfsrv - list $trace $res - } [list $log($lidx) $cstate($cidx)] ; # {} -} - -# ====================================================================== -# ====================================================================== -# Test that deletion of messages is handled correctly (only after QUIT). -# (Out of range, actual deletion only after the QUIT ...) - -foreach {n id lidx cidx} { - 0 -1 13 4 - 1 0 13 4 - 2 1 9 6 - 3 4 13 4 -} { - test pop3-srv-7.6.$n "DELE, out of range" { - newfsrv - set res "" - set trace [subshellpar { - set c [socket localhost $port] - gets $c - puts $c "USER ak" ; flush $c ; gets $c - puts $c "PASS smash" ; flush $c ; gets $c - puts $c "DELE $mid" ; flush $c - puts [gets $c] - after 3000 - close $c - } { - after 2000 { - set res [$srv conn state [$srv conn list]] - } - } port [$srv cget -port] mid $id] ; # {} - - # Postprocess state to remove variable data from comparison - set res [ppcstate $res] - delfsrv - list $trace $res - } [list $log($lidx) $cstate($cidx)] ; # {} -} - -test pop3-srv-7.6.4 "DELE, out of range" { - newfsrv - set res "" - set trace [subshellpar { - set c [socket localhost $port] - gets $c - puts $c "USER ak" ; flush $c ; gets $c - puts $c "PASS smash" ; flush $c ; gets $c - puts $c "DELE 1" ; flush $c ; gets $c - puts $c "DELE 1" ; flush $c - puts [gets $c] - after 3000 - close $c - } { - after 2000 { - set res [$srv conn state [$srv conn list]] - } - } port [$srv cget -port] mid $id] ; # {} - - # Postprocess state to remove variable data from comparison - set res [ppcstate $res] - delfsrv - list $trace $res -} [list $log(13) $cstate(6)] ; # {} - - -test pop3-srv-7.7 "DELE, abort" { - newfsrv - set res "" - set trace [subshellpar { - set res [list] - - lappend res [file exists [file join __dbox__ usr0 10]] - - set c [socket localhost $port] - gets $c - puts $c "USER ak" ; flush $c ; gets $c - puts $c "PASS smash" ; flush $c ; gets $c - puts $c "DELE 1" ; flush $c ; gets $c line - lappend res [file exists [file join __dbox__ usr0 10]] - after 3000 - close $c - lappend res [file exists [file join __dbox__ usr0 10]] - lappend res $line - puts $res - } { - after 2000 { - set res [$srv conn state [$srv conn list]] - } - } port [$srv cget -port]] ; # {} - - # Postprocess state to remove variable data from comparison - set res [ppcstate $res] - delfsrv - list $trace $res -} [list [list 1 1 1 $log(9)] $cstate(6)] ; # {} - -test pop3-srv-7.8 "DELE, complete" { - newfsrv - set trace [subshell { - set res [list] - - lappend res [file exists [file join __dbox__ usr0 10]] - - set c [socket localhost $port] - gets $c - puts $c "USER ak" ; flush $c ; gets $c - puts $c "PASS smash" ; flush $c ; gets $c - puts $c "DELE 1" ; flush $c ; gets $c line - lappend res [file exists [file join __dbox__ usr0 10]] - puts $c "QUIT" ; flush $c ; gets $c - after 3000 - close $c - lappend res [file exists [file join __dbox__ usr0 10]] - lappend res $line - puts $res - } port [$srv cget -port]] ; # {} - - delfsrv - set trace -} [list 1 1 0 $log(9)] ; # {} - -foreach {n cmd lidx cidx} { - 0 {DELE 1} 13 6 - 1 {RETR 1} 13 6 - 2 {TOP 1 10} 13 6 -} { - test pop3-srv-7.10.$n "DELE, $cmd" { - newfsrv - set res "" - set trace [subshellpar { - set c [socket localhost $port] - gets $c - puts $c "USER ak" ; flush $c ; gets $c - puts $c "PASS smash" ; flush $c ; gets $c - puts $c "DELE 1" ; flush $c ; gets $c - puts $c "$cmd" ; flush $c - puts [gets $c] - after 3000 - close $c - } { - after 2000 { - set res [$srv conn state [$srv conn list]] - } - } port [$srv cget -port] cmd $cmd] ; # {} - - # Postprocess state to remove variable data from comparison - set res [ppcstate $res] - delfsrv - list $trace $res - } [list $log($lidx) $cstate($cidx)] ; # {} -} - -# ====================================================================== -# ====================================================================== -# LIST -# - -foreach {n user pass id lidx} { - 0 ak smash 0 13 - 1 ak smash -1 13 - 2 ak smash 1 14 - 3 ak smash 4 13 - 4 ak smash {} 15 - 5 jh wooof 0 13 - 6 jh wooof 1 13 - 7 jh wooof {} 16 -} { - test pop3-srv-7.11.$n "LIST $id" { - newfsrv - set trace [subshell { - set res [list] - set c [socket localhost $port] - gets $c - puts $c "USER $user" ; flush $c ; gets $c - puts $c "PASS $pass" ; flush $c ; gets $c - puts $c "LIST $id" ; flush $c ; gets $c line - lappend res $line - if {$id == {}} { - while {![eof $c]} { - gets $c line - if {[string equal $line .]} {break} - lappend res $line - } - } - close $c - puts [join $res] - } port [$srv cget -port] id $id user $user pass $pass] ; # {} - - delfsrv - set trace - } $log($lidx) ; # {} -} - -# ---------------------------------------------------------------------- -::tcltest::cleanupTests DELETED modules/pop3d/pop3d_dbox.man Index: modules/pop3d/pop3d_dbox.man ================================================================== --- modules/pop3d/pop3d_dbox.man +++ /dev/null @@ -1,159 +0,0 @@ -[comment {-*- tcl -*-}] -[manpage_begin pop3d::dbox n 1.1] -[copyright {2002 Andreas Kupries }] -[moddesc {Tcl POP3 Server Package}] -[titledesc {Simple mailbox database for pop3d}] -[require Tcl 8.2] -[require pop3d::dbox [opt 1.1]] -[description] -[para] - -The package [package pop3d::dbox] provides simple/basic mailbox -management facilities. Each mailbox object manages a single base -directory whose subdirectories represent the managed mailboxes. Mails -in a mailbox are represented by files in a mailbox directory, where -each of these files contains a single mail, both headers and body, in -RFC822 conformant format. - -[para] - -Any mailbox object following the interface described below can be used -in conjunction with the pop3 server core provided by the package -[package pop3d]. It is especially possible to directly use the objects -created by this package in the storage callback of pop3 servers -following the same interface as servers created by the package -[package pop3d]. - -[para] - -[list_begin definitions] - -[call [cmd ::pop3d::dbox::new] [opt [arg dbName]]] - -This command creates a new database object with an associated global -Tcl command whose name is [arg dbName]. - -[list_end] - -The command [cmd dbName] may be used to invoke various operations on -the database. It has the following general form: - -[list_begin definitions] -[call [cmd dbName] [arg option] [opt [arg "arg arg ..."]]] - -[arg Option] and the [arg arg]s determine the exact behavior of the -command. - -[list_end] - -[para] - -The following commands are possible for database objects: - -[list_begin definitions] - -[call [arg dbName] [method destroy]] - -Destroys the mailbox database and all transient data. The directory -associated with the object is not destroyed. - -[call [arg dbName] [method base] [arg base]] - -Defines the base directory containing the mailboxes to manage. If this -method is not called none of the following methods will work. - -[call [arg dbName] [method add] [arg mbox]] - -Adds a mailbox of name [arg mbox] to the database. The name must be a -valid path component. - -[call [arg dbName] [method remove] [arg mbox]] - -Removes the mailbox specified through [arg mbox], and the mails -contained therein, from the database. This method will fail if the -specified mailbox is locked. - -[call [arg dbName] [method move] [arg {old new}]] - -Changes the name of the mailbox [arg old] to [arg new]. - -[call [arg dbName] [method list]] - -Returns a list containing the names of all mailboxes in the directory -associated with the database. - -[call [arg dbName] [method exists] [arg mbox]] - -Returns true if the mailbox with name [arg mbox] exists in the -database, or false if not. - -[call [arg dbName] [method locked] [arg mbox]] - -Checks if the mailbox specified through [arg mbox] is currently locked. - -[call [arg dbName] [method lock] [arg mbox]] - -This method locks the specified mailbox for use by a single connection -to the server. This is necessary to prevent havoc if several -connections to the same mailbox are open. The complementary method is -[method unlock]. The command will return true if the lock could be set -successfully or false if not. - -[call [arg dbName] [method unlock] [arg mbox]] - -This is the complementary method to [method lock], it revokes the lock -on the specified mailbox. - -[call [arg dbName] [method stat] [arg mbox]] - -Determines the number of messages in the specified mailbox and returns -this number. This method fails if the mailbox [arg mbox] is not -locked. - -[call [arg dbName] [method size] [arg mbox] [opt [arg msgId]]] - -Determines the size of the message specified through its id in - -[arg msgId], in bytes, and returns this number. The command will -return the size of the whole maildrop if no message id was specified. - -If specified the [arg msgId] has to be in the range "1 ... [lb][arg dbName] [method stat][rb]" - -or this call will fail. If [method stat] was not called before this -call, [method size] will assume that there are zero messages in the -mailbox. - - -[call [arg dbName] [method dele] [arg {mbox msgList}]] - -Deletes the messages whose numeric ids are contained in the -[arg msgList] from the mailbox specified via [arg mbox]. - -The [arg msgList] must not be empty or this call will fail. - -The numeric ids in [arg msgList] have to be in the range "1 ... -[lb][arg dbName] [method stat][rb]" or this -call will fail. If [method stat] was not called -before this call, [method dele] will assume -that there are zero messages in the mailbox. - - -[call [arg storageCmd] [method get] [arg mbox] [arg msgId]] - -Returns a handle for the specified message. This handle is a mime -token following the interface described in the documentation of -package [package mime]. The token is [emph read-only]. In other -words, the caller is allowed to do anything with the token except to -modify it. - -The [arg msgId] has to be in the range "1 ... -[lb][arg dbName] [method stat][rb]" or this -call will fail. If [method stat] was not called -before this call, [method get] will assume -that there are zero messages in the mailbox. - - -[list_end] - -[keywords pop3 internet network protocol rfc1939] -[manpage_end] DELETED modules/pop3d/pop3d_dbox.tcl Index: modules/pop3d/pop3d_dbox.tcl ================================================================== --- modules/pop3d/pop3d_dbox.tcl +++ /dev/null @@ -1,489 +0,0 @@ -# -*- tcl -*- -# pop3d_dbox.tcl -- -# -# Implementation of a simple mailbox database for the pop3 server -# Each mailbox is a a directory in a base directory, with each mail -# a file in that directory. The mail file contains both headers and -# body of the mail. -# -# Copyright (c) 2002 by Andreas Kupries -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: pop3d_dbox.tcl,v 1.6 2003/04/11 20:11:26 andreas_kupries Exp $ - -package require mime ; # tcllib | mime token is result of "get". -package require log ; # tcllib | Logging package - -namespace eval ::pop3d::dbox { - # Data storage in the pop3d::dbox module - # ------------------------------------- - # One array per object containing the db contents. Keyed by user name. - # And the information about the last file data was read from. - - # counter is used to give a unique name for unnamed databases - variable counter 0 - - # commands is the list of subcommands recognized by the server - variable commands [list \ - "add" \ - "base" \ - "dele" \ - "destroy" \ - "exists" \ - "get" \ - "list" \ - "lock" \ - "locked" \ - "move" \ - "remove" \ - "size" \ - "stat" \ - "unlock" \ - ] - - variable version ; set version 1.1 -} - - -# ::pop3d::dbox::new -- -# -# Create a new mailbox database with a given name; -# if no name is given, use -# p3dboxX, where X is a number. -# -# Arguments: -# name name of the mailbox database; if null, generate one. -# -# Results: -# name name of the mailbox database created - -proc ::pop3d::dbox::new {{name ""}} { - variable counter - - if { [llength [info level 0]] == 1 } { - incr counter - set name "p3dbox${counter}" - } - - if { ![string equal [info commands ::$name] ""] } { - return -code error \ - "command \"$name\" already exists,\ - unable to create mailbox database" - } - - # Set up the namespace - namespace eval ::pop3d::dbox::dbox::$name { - variable dir "" - variable state ; array set state {} - variable locked ; array set locked {} - variable transfer ; array set transfer {} - } - - # Create the command to manipulate the mailbox database - interp alias {} ::$name {} ::pop3d::dbox::DboxProc $name - - return $name -} - -########################## -# Private functions follow - -# ::pop3d::dbox::DboxProc -- -# -# Command that processes all mailbox database object commands. -# -# Arguments: -# name name of the mailbox database object to manipulate. -# args command name and args for the command -# -# Results: -# Varies based on command to perform - -proc ::pop3d::dbox::DboxProc {name {cmd ""} args} { - - # Do minimal args checks here - if { [llength [info level 0]] == 2 } { - return -code error \ - "wrong # args: should be \"$name option ?arg arg ...?\"" - } - - # Split the args into command and args components - if { [llength [info commands ::pop3d::dbox::_$cmd]] == 0 } { - variable commands - set optlist [join $commands ", "] - set optlist [linsert $optlist "end-1" "or"] - return -code error "bad option \"$cmd\": must be $optlist" - } - eval [list ::pop3d::dbox::_$cmd $name] $args -} - - -proc ::pop3d::dbox::_base {name base} { - # @c Constructor. Does some more checks on the given base directory. - - # sanity checks - if {$base == {}} { - return -code error "directory not specified" - } - if {! [file exists $base]} { - return -code error "base: \"$base\" does not exist" - } - if {! [file isdirectory $base]} { - return -code error "base: \"$base\" not a directory" - } - if {! [file readable $base]} { - return -code error "base: \"$base\" not readable" - } - if {! [file writable $base]} { - return -code error "base: \"$base\" not writable" - } - - upvar ::pop3d::dbox::dbox::${name}::dir dir - set dir $base - return -} - - -# ::pop3d::dbox::_destroy -- -# -# Destroy a mail database, including its associated command and -# data storage. -# -# Arguments: -# name Name of the database to destroy. -# -# Results: -# None. - -proc ::pop3d::dbox::_destroy {name} { - namespace delete ::pop3d::dbox::dbox::$name - interp alias {} ::$name {} - return -} - -proc ::pop3d::dbox::_add {name mbox} { - # @c Create a mailbox with handle . The handle is used as the - # @c name of the directory to contain the mails too. - # - # @a mbox: Reference to the mailbox to be operated on. - - set dir [CheckDir $name] - set mboxpath [file join $dir $mbox] - - if {[file exists $mboxpath]} { - return -code error "cannot add \"$mbox\", mailbox already in existence" - } - - file mkdir $mboxpath - return -} - - -proc ::pop3d::dbox::_remove {name mbox} { - # @c Remove mailbox with handle . This will destroy all mails - # @c contained in it too. - # - # @a mbox: Reference to the mailbox to be operated on. - - set dir [CheckDir $name] - set mboxpath [file join $dir $mbox] - - if {![file exists $mboxpath]} { - return -code error "cannot remove \"$mbox\", mailbox does not exist" - } - - if {[_locked $name $mbox]} { - return -code error "cannot remove \"$mbox\", mailbox is locked" - } - - file delete -force $mboxpath - return -} - - -proc ::pop3d::dbox::_move {name old new} { - # @c Change the handle of mailbox to . - # - # @a old: Reference to the mailbox to be operated on. - # @a new: New reference to the mailbox - - set dir [CheckDir $name] - set oldpath [file join $dir $old] - set newpath [file join $dir $new] - - if {![file exists $oldpath]} { - return -code error "cannot move \"$old\", mailbox does not exist" - } - if {[file exists $newpath]} { - return -code error \ - "cannot move \"$old\", destination \"$new\" already exists" - } - - file rename -force $oldpath $newpath - return -} - - -proc ::pop3d::dbox::_list {name} { - # @c Lists known mailboxes in object. - # @r List of mailbox names. - - set dir [CheckDir $name] - set here [pwd] - cd $dir - set files [glob -nocomplain *] - cd $here - - set res [list] - foreach f $files { - set mboxpath [file join $dir $f] - if {! [file isdirectory $mboxpath]} {continue} - if {! [file readable $mboxpath]} {continue} - if {! [file writable $mboxpath]} {continue} - lappend res $f - } - return $res -} - - -proc ::pop3d::dbox::_exists {name mbox} { - # @c Determines existence of mailbox . - # @a mbox: Reference to the mailbox to check for. - # @r 1 if the mailbox exists, 0 else. - - set dir [CheckDir $name] - set mbox [file join $dir $mbox] - return [file exists $mbox] -} - - -proc ::pop3d::dbox::_locked {name mbox} { - # @c Checks wether the specified mailbox is locked or not. - # @a mbox: Reference to the mailbox to check. - # @r 1 if the mailbox is locked, 0 else. - - set dir [CheckDir $name] - set mbox [file join $dir $mbox] - - upvar ::pop3d::dbox::dbox::${name}::locked locked - - return [::info exists locked($mbox)] -} - - -# -- interface to the pop server (storage callback) -- - -proc ::pop3d::dbox::_lock {name mbox} { - # @c Locks the given mailbox, additionally stores a list of the - # @c available files in the manager state. All files (= messages) - # @c added to the mailbox after this operation will be ignored - # @c during the session. - # - # @a mbox: Reference to the mailbox to be locked. - # @r 1 if mailbox was locked sucessfully, 0 else. - - # locked already ? - if {[_locked $name $mbox]} { - return 0 - } - - set dir [Check $name $mbox] - - # Compute a list of message files residing in the mailbox directory - - upvar ::pop3d::dbox::dbox::${name}::state state - upvar ::pop3d::dbox::dbox::${name}::locked locked - - set state($dir) [lsort [glob -nocomplain [file join $dir *]]] - set locked($dir) 1 - return 1 -} - - -proc ::pop3d::dbox::_unlock {name mbox} { - # @c A locked mailbox is unlocked, thereby made available - # @c to other sessions. - # - # @a mbox: Reference to the mailbox to be locked. - - # not locked ? - if {![_locked $name $mbox]} {return} - set dir [Check $name $mbox] - - upvar ::pop3d::dbox::dbox::${name}::state state - upvar ::pop3d::dbox::dbox::${name}::locked locked - - unset state($dir) - unset locked($dir) - return -} - - -proc ::pop3d::dbox::_stat {name mbox} { - # @c Determines the number of messages picked up by . - # @c Will fail if the mailbox was not locked. - # - # @a mbox: Reference to the mailbox queried. - # @r The number of messages in the mailbox - - set dir [Check $name $mbox] - - if {![_locked $name $mbox]} { - return -code error "mailbox \"$mbox\" is not locked" - } - - upvar ::pop3d::dbox::dbox::${name}::state state - - return [llength $state($dir)] -} - - -proc ::pop3d::dbox::_size {name mbox {msgId {}}} { - # @c Determines the size of the specified message, in bytes. - # - # @a mbox: Reference to the mailbox to be operated on. - # @a msgId: Numerical index of the message to look at. - # @r size of the message in bytes. - - log::log debug "$name size $mbox ($msgId)" - - set dir [Check $name $mbox] - - log::log debug "$name mbox dir = $dir" - - upvar ::pop3d::dbox::dbox::${name}::state state - - if {$msgId == {}} { - log::log debug "$name size /full" - - # Full size of the maildrop requested. - if {![info exists state($dir)]} { - # No stat before size, assume that there are no messages - # in the maildrop, which implies that the maildrop is - # empty, i.e. of size 0. - return 0 - } - - set n 0 - set k [llength $state($dir)] - for {set id 0} {$id < $k} {incr id} { - incr n [file size [lindex $state($dir) $id]] - } - return $n - } - - if { - ($msgId < 1) || - (![info exists state($dir)]) || - ([llength $state($dir)] < $msgId) - } { - return -code error "id \"$msgId\" out of range" - } - incr msgId -1 - - ## log::log debug "$name msg mails = $state($dir)" - log::log debug "$name msg file = [lindex $state($dir) $msgId]" - - return [file size [lindex $state($dir) $msgId]] -} - - -proc ::pop3d::dbox::_dele {name mbox msgList} { - # @c Deletes the specified messages from the mailbox. This should - # @c be followed by a as the state is not updated - # @c accordingly. - # - # @a mbox: Reference to the mailbox to be operated on. - # @a msgList: List of message ids. - - set dir [Check $name $mbox] - if {[llength $msgList] == 0} { - return -code error "nothing to delete" - } - - # @d The code assumes that the id's in the list were already - # @d checked against the maximal number of messages. - - upvar ::pop3d::dbox::dbox::${name}::state state - - foreach msgId $msgList { - if { - ($msgId < 1) || - (![info exists state($dir)]) || - ([llength $state($dir)] < $msgId) - } { - return -code error "id \"$msgId\" out of range" - } - } - foreach msgId $msgList { - file delete [lindex $state($dir) [incr msgId -1]] - } - - # the mailbox state is unusable now. - return -} - -proc ::pop3d::dbox::_get {name mbox msgId} { - set dir [Check $name $mbox] - - upvar ::pop3d::dbox::dbox::${name}::state state - - if { - ($msgId < 1) || - (![info exists state($dir)]) || - ([llength $state($dir)] < $msgId) - } { - return -code error "id \"$msgId\" out of range" - } - incr msgId -1 - - set mailfile [lindex $state($dir) $msgId] - - set token [::mime::initialize -file $mailfile] - return $token -} - -########################### -########################### -# Internal helper commands. - -proc ::pop3d::dbox::Check {name mbox} { - # @c Internal procedure. Used to map a mailbox handle - # @c to the directory containing the messages. - # @a mbox: Reference to the mailbox to be operated on. - # @r Path of directory holding the message files of the - # @r specified mailbox. - - set dir [CheckDir $name] - set mboxpath [file join $dir $mbox] - - if {! [file exists $mboxpath]} { - return -code error "\"$mbox\" does not exist" - } - if {! [file isdirectory $mboxpath]} { - return -code error "\"$mbox\" is not a directory" - } - if {! [file readable $mboxpath]} { - return -code error "\"$mbox\" is not readable" - } - if {! [file writable $mboxpath]} { - return -code error "\"$mbox\" is not writable" - } - return $mboxpath -} - -proc ::pop3d::dbox::CheckDir {name} { - upvar ::pop3d::dbox::dbox::${name}::dir dir - - if {$dir == {}} { - return -code error "base directory not specified" - } - return $dir -} - -########################## -# Module initialization - -package provide pop3d::dbox $::pop3d::dbox::version DELETED modules/pop3d/pop3d_dbox.test Index: modules/pop3d/pop3d_dbox.test ================================================================== --- modules/pop3d/pop3d_dbox.test +++ /dev/null @@ -1,493 +0,0 @@ -# -*- tcl -*- -# pop3_dbox.test: tests for the simple pop3 mail database. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 2002 by Andreas Kupries -# All rights reserved. -# -# RCS: @(#) $Id: pop3d_dbox.test,v 1.1 2002/05/21 17:31:18 andreas_kupries Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -package require pop3d::dbox -puts "pop3d::dbox [package present pop3d::dbox]" - -# ---------------------------------------------------------------------- - -test pop3-dbox-1.0 {anon create/destroy} { - set dbox [::pop3d::dbox::new] - $dbox destroy - regsub {[0-9]+$} $dbox {} dbox - set dbox -} p3dbox - -test pop3-dbox-1.1 {named create/destroy} { - set dbox [::pop3d::dbox::new foo] - $dbox destroy - set dbox -} foo - -test pop3-dbox-1.2 {multiple create} { - ::pop3d::dbox::new foo - catch {::pop3d::dbox::new foo} msg - foo destroy - set msg -} {command "foo" already exists, unable to create mailbox database} - -test pop3-dbox-1.3 {correct creation, destruction} { - ::pop3d::dbox::new foo - set res [list [info exists ::pop3d::dbox::dbox::foo::dir]] - foo destroy - lappend res [info exists ::pop3d::dbox::dbox::foo::dir] -} {1 0} - -test pop3-dbox-1.4 {unknown method} { - set dbox [::pop3d::dbox::new] - catch {$dbox foo} res - $dbox destroy - set res -} {bad option "foo": must be add, base, dele, destroy, exists, get, list, lock, locked, move, remove, size, stat, or unlock} - - - -test pop3-dbox-2.0 {initialization} { - set dbox [::pop3d::dbox::new] - catch {$dbox base {}} res - $dbox destroy - set res -} {directory not specified} - -test pop3-dbox-2.1 {initialization} { - set dbox [::pop3d::dbox::new] - catch {$dbox base foo} res - $dbox destroy - set res -} {base: "foo" does not exist} - -makeFile {} __bar__ -test pop3-dbox-2.2 {initialization} { - set dbox [::pop3d::dbox::new] - catch {$dbox base __bar__} res - $dbox destroy - set res -} {base: "__bar__" not a directory} - -makeDirectory __dbox__ -test pop3-dbox-2.3 {initialization} { - set dbox [::pop3d::dbox::new] - set res [list [$dbox base __dbox__]] - lappend res [$dbox list] - $dbox destroy - set res -} {{} {}} - -makeDirectory [file join __dbox__ known] - -test pop3-dbox-3.0 {adding mailboxes} { - set dbox [::pop3d::dbox::new] - catch {$dbox add known} res - $dbox destroy - set res -} {base directory not specified} - -test pop3-dbox-3.1 {adding mailboxes} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - catch {$dbox add known} res - $dbox destroy - set res -} {cannot add "known", mailbox already in existence} - -test pop3-dbox-3.2 {adding mailboxes} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - set res [file exists [file join __dbox__ usr0]] - $dbox add usr0 - lappend res [file exists [file join __dbox__ usr0]] - lappend res [lsort [$dbox list]] - $dbox destroy - set res -} {0 1 {known usr0}} - -test pop3-dbox-4.0 {removing mailboxes} { - set dbox [::pop3d::dbox::new] - catch {$dbox remove known} res - $dbox destroy - set res -} {base directory not specified} - -test pop3-dbox-4.1 {removing mailboxes} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - catch {$dbox remove usr1} res - $dbox destroy - set res -} {cannot remove "usr1", mailbox does not exist} - -test pop3-dbox-4.2 {removing mailboxes} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - set res [file exists [file join __dbox__ usr0]] - $dbox remove usr0 - lappend res [file exists [file join __dbox__ usr0]] - $dbox destroy - set res -} {1 0} - - -test pop3-dbox-5.0 {renaming mailboxes} { - set dbox [::pop3d::dbox::new] - catch {$dbox move usr0 usr1} res - $dbox destroy - set res -} {base directory not specified} - -test pop3-dbox-5.1 {renaming mailboxes} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - catch {$dbox move usr0 usr1} res - $dbox destroy - set res -} {cannot move "usr0", mailbox does not exist} - -test pop3-dbox-5.2 {renaming mailboxes} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - $dbox add usr0 - catch {$dbox move usr0 known} res - $dbox remove usr0 - $dbox destroy - set res -} {cannot move "usr0", destination "known" already exists} - -test pop3-dbox-5.3 {renaming mailboxes} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - $dbox add usr0 - - set res {} - lappend res [file exists [file join __dbox__ usr0]] - - $dbox move usr0 usr1 - - lappend res [file exists [file join __dbox__ usr0]] - lappend res [file exists [file join __dbox__ usr1]] - - $dbox remove usr1 - $dbox destroy - set res -} {1 0 1} - - -test pop3-dbox-6.0 {existence of mailboxes} { - set dbox [::pop3d::dbox::new] - catch {$dbox exists foo} res - $dbox destroy - set res -} {base directory not specified} - -test pop3-dbox-6.1 {existence of mailboxes} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - set res [$dbox exists foo] - $dbox destroy - set res -} 0 - -test pop3-dbox-6.2 {existence of mailboxes} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - set res [$dbox exists known] - $dbox destroy - set res -} 1 - - -test pop3-dbox-7.0 {locking} { - set dbox [::pop3d::dbox::new] - catch {$dbox locked foo} res - $dbox destroy - set res -} {base directory not specified} -test pop3-dbox-7.1 {locking} { - set dbox [::pop3d::dbox::new] - catch {$dbox lock foo} res - $dbox destroy - set res -} {base directory not specified} -test pop3-dbox-7.2 {locking} { - set dbox [::pop3d::dbox::new] - catch {$dbox unlock foo} res - $dbox destroy - set res -} {base directory not specified} - -test pop3-dbox-7.3 {locking} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - set res [$dbox locked known] - $dbox destroy - set res -} 0 - -test pop3-dbox-7.4 {locking} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - set res [$dbox locked known] - lappend res [$dbox lock known] - lappend res [$dbox locked known] - $dbox unlock known - lappend res [$dbox locked known] - $dbox destroy - set res -} {0 1 1 0} - -test pop3-dbox-7.5 {locking} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - set res [$dbox lock known] - lappend res [$dbox lock known] - $dbox unlock known - lappend res [$dbox locked known] - $dbox destroy - set res -} {1 0 0} - -test pop3-dbox-7.6 {locking} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - $dbox add usr0 - $dbox lock usr0 - catch {$dbox remove usr0} res - $dbox unlock usr0 - $dbox remove usr0 - $dbox destroy - set res -} {cannot remove "usr0", mailbox is locked} - - -test pop3-dbox-8.0 {stat} { - set dbox [::pop3d::dbox::new] - catch {$dbox stat known} res - $dbox destroy - set res -} {base directory not specified} - -test pop3-dbox-8.1 {stat} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - catch {$dbox stat known} res - $dbox destroy - set res -} {mailbox "known" is not locked} - -test pop3-dbox-8.2 {stat} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - $dbox lock known - set res [$dbox stat known] - $dbox unlock known - $dbox destroy - set res -} 0 - -test pop3-dbox-8.3 {stat} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - $dbox add usr0 - makeFile {} [file join __dbox__ usr0 a] - makeFile {abc} [file join __dbox__ usr0 d] - makeFile {abcdef} [file join __dbox__ usr0 c] - $dbox lock usr0 - set res [$dbox stat usr0] - $dbox unlock usr0 - $dbox remove usr0 - $dbox destroy - set res -} 3 - - -test pop3-dbox-9.0 {size} { - set dbox [::pop3d::dbox::new] - catch {$dbox size known 0} res - $dbox destroy - set res -} {base directory not specified} - -test pop3-dbox-9.1 {size} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - catch {$dbox size known 0} res - $dbox destroy - set res -} {id "0" out of range} - -test pop3-dbox-9.2 {size} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - $dbox add usr0 - makeFile {} [file join __dbox__ usr0 a] - makeFile {abc} [file join __dbox__ usr0 d] - makeFile {abcdef} [file join __dbox__ usr0 c] - catch {$dbox size usr0 1} res - $dbox remove usr0 - $dbox destroy - set res -} {id "1" out of range} - -test pop3-dbox-9.3 {size} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - $dbox add usr0 - makeFile {} [file join __dbox__ usr0 a] - makeFile {abc} [file join __dbox__ usr0 b] - makeFile {abcdef} [file join __dbox__ usr0 c] - - $dbox lock usr0 - set res [$dbox stat usr0] - lappend res [$dbox size usr0 1] - lappend res [$dbox size usr0 2] - lappend res [$dbox size usr0 3] - - catch {$dbox size usr0 4} resb - lappend res $resb - - $dbox unlock usr0 - $dbox remove usr0 - $dbox destroy - set res -} {3 1 4 7 {id "4" out of range}} - - - -test pop3-dbox-10.0 {get} { - set dbox [::pop3d::dbox::new] - catch {$dbox get known 0} res - $dbox destroy - set res -} {base directory not specified} - -test pop3-dbox-10.1 {get} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - catch {$dbox get known 0} res - $dbox destroy - set res -} {id "0" out of range} - -test pop3-dbox-10.2 {get} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - $dbox add usr0 - makeFile {} [file join __dbox__ usr0 a] - makeFile {abc} [file join __dbox__ usr0 d] - makeFile {abcdef} [file join __dbox__ usr0 c] - catch {$dbox get usr0 1} res - $dbox remove usr0 - $dbox destroy - set res -} {id "1" out of range} - -test pop3-dbox-10.3 {get} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - $dbox add usr0 - makeFile {} [file join __dbox__ usr0 a] - makeFile {} [file join __dbox__ usr0 b] - makeFile {} [file join __dbox__ usr0 c] - - $dbox lock usr0 - set res [$dbox stat usr0] - lappend res [$dbox get usr0 1] - lappend res [$dbox get usr0 2] - lappend res [$dbox get usr0 3] - - catch {$dbox get usr0 4} resb - lappend res $resb - - $dbox unlock usr0 - $dbox remove usr0 - $dbox destroy - regsub -all {::mime::[0-9]+} $res {X} res - set res -} {3 X X X {id "4" out of range}} - - -test pop3-dbox-11.0 {dele} { - set dbox [::pop3d::dbox::new] - catch {$dbox dele known 0} res - $dbox destroy - set res -} {base directory not specified} - -test pop3-dbox-11.1 {dele} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - catch {$dbox dele known {}} res - $dbox destroy - set res -} {nothing to delete} - -test pop3-dbox-11.2 {dele} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - catch {$dbox dele known 0} res - $dbox destroy - set res -} {id "0" out of range} - -test pop3-dbox-11.3 {dele} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - $dbox add usr0 - makeFile {} [file join __dbox__ usr0 a] - makeFile {abc} [file join __dbox__ usr0 d] - makeFile {abcdef} [file join __dbox__ usr0 c] - catch {$dbox dele usr0 1} res - $dbox remove usr0 - $dbox destroy - set res -} {id "1" out of range} - -test pop3-dbox-11.4 {dele} { - set dbox [::pop3d::dbox::new] - $dbox base __dbox__ - $dbox add usr0 - makeFile {} [file join __dbox__ usr0 a] - makeFile {} [file join __dbox__ usr0 b] - makeFile {} [file join __dbox__ usr0 c] - - set res {} - foreach f {a b c} { - lappend res [file exists [file join __dbox__ usr0 $f]] - } - - $dbox lock usr0 - lappend res [$dbox stat usr0] - - $dbox dele usr0 {1 2 3} - - foreach f {a b c} { - lappend res [file exists [file join __dbox__ usr0 $f]] - } - # unusable state, wrong information - lappend res [$dbox stat usr0] - - catch {$dbox dele usr0 4} resb - lappend res $resb - - $dbox unlock usr0 - $dbox remove usr0 - $dbox destroy - set res -} {1 1 1 3 0 0 0 3 {id "4" out of range}} - - -# ---------------------------------------------------------------------- -::tcltest::cleanupTests DELETED modules/pop3d/pop3d_udb.man Index: modules/pop3d/pop3d_udb.man ================================================================== --- modules/pop3d/pop3d_udb.man +++ /dev/null @@ -1,108 +0,0 @@ -[comment {-*- tcl -*-}] -[manpage_begin pop3d::udb n 1.0.1] -[copyright {2002 Andreas Kupries }] -[moddesc {Tcl POP3 Server Package}] -[titledesc {Simple user database for pop3d}] -[require Tcl 8.2] -[require pop3d::udb [opt 1.0.1]] -[description] -[para] - -The package [package pop3d::udb] provides simple in memory databases -which can be used in conjunction with the pop3 server core provided by -the package [package pop3d]. The databases will use the names of users -as keys and associates passwords and storage references with them. - -[para] - -Objects created by this package can be directly used in the -authentication callback of pop3 servers following the same interface -as servers created by the package [package pop3d]. - -[para] - - -[list_begin definitions] - -[call [cmd ::pop3d::udb::new] [opt [arg dbName]]] - -This command creates a new database object with an associated global -Tcl command whose name is [arg dbName]. - -[list_end] - -The command [cmd dbName] may be used to invoke various operations on -the database. It has the following general form: - -[list_begin definitions] -[call [cmd dbName] [arg option] [opt [arg "arg arg ..."]]] - -[arg Option] and the [arg arg]s determine the exact behavior of the -command. - -[list_end] - -[para] - -The following commands are possible for database objects: - -[list_begin definitions] - -[call [arg dbName] [method destroy]] - -Destroys the database object. - -[call [arg dbName] [method add] [arg {user pwd storage}]] - -Add a new user or changes the data of an existing user. Stores -[arg password] and [arg storage] reference for the given [arg user]. - -[call [arg dbName] [method remove] [arg user]] - -Removes the specified [arg user] from the database. - -[call [arg dbName] [method rename] [arg {user newName}]] - -Changes the name of the specified [arg user] to [arg newName]. - -[call [arg dbName] [method lookup] [arg user]] - -Searches the database for the specified [arg user] and returns a -two-element list containing the associated password and storage -reference, in this order. Throws an error if the user could not be -found. This is the interface as expected by the authentication -callback of package [package pop3d]. - -[call [arg dbName] [method exists] [arg user]] - -Returns true if the specified [arg user] is known to the database, -else false. - -[call [arg dbName] [method who]] - -Returns a list of users known to the database. - -[call [arg dbName] [method save] [opt [arg file]]] - -Saves the contents of the database into the given [arg file]. If the -file is not specified the system will use the path last used in a call -to [arg dbName] [method read]. The generated file can be read by the -[method read] method. - -[call [arg dbName] [method read] [arg file]] - -Reads the specified [arg file] and adds the contained user definitions -to the database. As the file is actually [cmd source]'d a safe -interpreter is employed to safeguard against malicious code. This -interpreter knows the [cmd add] command for adding users and their -associated data to this database. This command has the same argument -signature as the method [method add]. The path of the [arg file] is -remembered internally so that it can be used in the next call of - -[arg dbName] [method save] without an argument. - - -[list_end] - -[keywords pop3 internet network protocol rfc1939] -[manpage_end] DELETED modules/pop3d/pop3d_udb.tcl Index: modules/pop3d/pop3d_udb.tcl ================================================================== --- modules/pop3d/pop3d_udb.tcl +++ /dev/null @@ -1,304 +0,0 @@ -# -*- tcl -*- -# pop3d_udb.tcl -- -# -# Implementation of a simple user database for the pop3 server -# -# Copyright (c) 2002 by Andreas Kupries -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: pop3d_udb.tcl,v 1.3 2003/04/11 20:11:26 andreas_kupries Exp $ - -namespace eval ::pop3d::udb { - # Data storage in the pop3d::udb module - # ------------------------------------- - # One array per object containing the db contents. Keyed by user name. - # And the information about the last file data was read from. - - # counter is used to give a unique name for unnamed databases - variable counter 0 - - # commands is the list of subcommands recognized by the server - variable commands [list \ - "add" \ - "destroy" \ - "exists" \ - "lookup" \ - "read" \ - "remove" \ - "rename" \ - "save" \ - "who" \ - ] - - variable version ; set version 1.1 -} - - -# ::pop3d::udb::new -- -# -# Create a new user database with a given name; if no name is given, use -# p3udbX, where X is a number. -# -# Arguments: -# name name of the user database; if null, generate one. -# -# Results: -# name name of the user database created - -proc ::pop3d::udb::new {{name ""}} { - variable counter - - if { [llength [info level 0]] == 1 } { - incr counter - set name "p3udb${counter}" - } - - if { ![string equal [info commands ::$name] ""] } { - return -code error \ - "command \"$name\" already exists,\ - unable to create user database" - } - - # Set up the namespace - namespace eval ::pop3d::udb::udb::$name { - variable user ; array set user {} - variable lastfile "" - } - - # Create the command to manipulate the user database - interp alias {} ::$name {} ::pop3d::udb::UdbProc $name - - return $name -} - -########################## -# Private functions follow - -# ::pop3d::udb::UdbProc -- -# -# Command that processes all user database object commands. -# -# Arguments: -# name name of the user database object to manipulate. -# args command name and args for the command -# -# Results: -# Varies based on command to perform - -proc ::pop3d::udb::UdbProc {name {cmd ""} args} { - - # Do minimal args checks here - if { [llength [info level 0]] == 2 } { - return -code error \ - "wrong # args: should be \"$name option ?arg arg ...?\"" - } - - # Split the args into command and args components - if { [llength [info commands ::pop3d::udb::_$cmd]] == 0 } { - variable commands - set optlist [join $commands ", "] - set optlist [linsert $optlist "end-1" "or"] - return -code error "bad option \"$cmd\": must be $optlist" - } - eval [list ::pop3d::udb::_$cmd $name] $args -} - - -# ::pop3d::udb::_destroy -- -# -# Destroy a user database, including its associated command and -# data storage. -# -# Arguments: -# name Name of the database to destroy. -# -# Results: -# None. - -proc ::pop3d::udb::_destroy {name} { - namespace delete ::pop3d::udb::udb::$name - interp alias {} ::$name {} - return -} - - -proc ::pop3d::udb::_add {name usrName password storage} { - # @c Add the user to the database, together with its - # @c password and a storage reference. The latter is stored and passed - # @c through this system without interpretation of the given value. - - # @a usrName: The name of the user defined here. - # @a password: Password given to the user. - # @a storage: symbolic reference to the maildrop of user . - # @a storage: Usable for a storage system only. - - if {$usrName == {}} {return -code error "user specification missing"} - if {$password == {}} {return -code error "password not specified"} - if {$storage == {}} {return -code error "storage location not defined"} - - upvar ::pop3d::udb::udb::${name}::user user - - set user($usrName) [list $password $storage] - return -} - - -proc ::pop3d::udb::_remove {name usrName} { - # @c Remove the user from the database. - # - # @a usrName: The name of the user to remove. - - if {$usrName == {}} {return -code error "user specification missing"} - - upvar ::pop3d::udb::udb::${name}::user user - - if {![::info exists user($usrName)]} { - return -code error "user \"$usrName\" not known" - } - - unset user($usrName) - return -} - - -proc ::pop3d::udb::_rename {name usrName newName} { - # @c Renames user to . - # @a usrName: The name of the user to rename. - # @a newName: The new name to give to the user - - if {$usrName == {}} {return -code error "user specification missing"} - if {$newName == {}} {return -code error "user specification missing"} - - upvar ::pop3d::udb::udb::${name}::user user - - if {![::info exists user($usrName)]} { - return -code error "user \"$usrName\" not known" - } - if {[::info exists user($newName)]} { - return -code error "user \"$newName\" is known" - } - - set data $user($usrName) - unset user($usrName) - - set user($newName) $data - return -} - - -proc ::pop3d::udb::_lookup {name usrName} { - # @c Query database for information about user . - # @c Overrides . - # @a usrName: Name of the user to query for. - # @r a 2-element list containing password and storage - # @r reference for user , in this order. - - upvar ::pop3d::udb::udb::${name}::user user - - if {![::info exists user($usrName)]} { - return -code error "user \"$usrName\" not known" - } - return $user($usrName) -} - - -proc ::pop3d::udb::_exists {name usrName} { - # @c Determines wether user is registered or not. - # @a usrName: The name of the user to check for. - - upvar ::pop3d::udb::udb::${name}::user user - - return [::info exists user($usrName)] -} - - -proc ::pop3d::udb::_who {name} { - # @c Determines the names of all registered users. - # @r A list containing the names of all registered users. - - upvar ::pop3d::udb::udb::${name}::user user - - return [array names user] -} - - -proc ::pop3d::udb::_save {name {file {}}} { - # @c Stores the current contents of the in-memory user database - # @c into the specified file. - - # @a file: The name of the file to write to. If it is not specified, or - # @a file: as empty, the value of the member variable - # @a file: is used instead. - - # save operation: do a backup of the file, write new contents, - # restore backup in case of problems. - - upvar ::pop3d::udb::udb::${name}::user user - upvar ::pop3d::udb::udb::${name}::lastfile lastfile - - if {$file == {}} { - set file $lastfile - } - if {$file == {}} { - return -code error "No file known to save data into" - } - - set tmp [file join [file dirname $file] [pid]] - - set f [open $tmp w] - puts $f "# -*- tcl -*-" - puts $f "# ----------- user authentication database -" - puts $f "" - - foreach name [array names user] { - set password [lindex $user($name) 0] - set storage [lindex $user($name) 1] - - puts $f "\tadd [list $name] [list $password] [list $storage]" - } - - puts $f "" - close $f - - if {[file exists $file]} { - file rename -force $file $file.old - } - file rename -force $tmp $file - return -} - - -proc ::pop3d::udb::_read {name path} { - # @c Reads the contents of the specified into the in-memory - # @c database of users, passwords and storage references. - - # @a path: The name of the file to read. - - # @n The name of the file is remembered internally, and used by - # @n (if called without or empty argument). - - upvar ::pop3d::udb::udb::${name}::user user - upvar ::pop3d::udb::udb::${name}::lastfile lastfile - - if {$path == {}} { - return -code error "No file known to read from" - } - - set lastfile $path - - foreach key [array names user] {unset user($key)} - - set ip [interp create -safe] - interp alias $ip add {} ::pop3d::udb::_add $name - $ip invokehidden -global source $path - interp delete $ip - - return -} - -########################## -# Module initialization - -package provide pop3d::udb $::pop3d::udb::version DELETED modules/pop3d/pop3d_udb.test Index: modules/pop3d/pop3d_udb.test ================================================================== --- modules/pop3d/pop3d_udb.test +++ /dev/null @@ -1,225 +0,0 @@ -# -*- tcl -*- -# pop3_udb.test: tests for the simple pop3 user database. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 2002 by Andreas Kupries -# All rights reserved. -# -# RCS: @(#) $Id: pop3d_udb.test,v 1.1 2002/05/21 17:31:18 andreas_kupries Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -package require pop3d::udb -puts "pop3d::udb [package present pop3d::udb]" - -# ---------------------------------------------------------------------- - -test pop3-udb-1.0 {anon create/destroy} { - set udb [::pop3d::udb::new] - $udb destroy - regsub {[0-9]+$} $udb {} udb - set udb -} p3udb - -test pop3-udb-1.1 {named create/destroy} { - set udb [::pop3d::udb::new foo] - $udb destroy - set udb -} foo - -test pop3-udb-1.2 {multiple create} { - ::pop3d::udb::new foo - catch {::pop3d::udb::new foo} msg - foo destroy - set msg -} {command "foo" already exists, unable to create user database} - -test pop3-udb-1.3 {correct creation, destruction} { - ::pop3d::udb::new foo - set res [list [info exists ::pop3d::udb::udb::foo::lastfile]] - foo destroy - lappend res [info exists ::pop3d::udb::udb::foo::lastfile] -} {1 0} - -test pop3-udb-1.4 {unknown method} { - set udb [::pop3d::udb::new] - catch {$udb foo} res - $udb destroy - set res -} {bad option "foo": must be add, destroy, exists, lookup, read, remove, rename, save, or who} - - -test pop3-udb-2.0 {adding entries, created empty} { - set udb [::pop3d::udb::new] - set res [$udb who] - $udb destroy - set res -} {} - -test pop3-udb-2.1 {adding entries} { - set udb [::pop3d::udb::new] - $udb add bar blurb **** - set res [$udb who] - $udb destroy - set res -} {bar} - -test pop3-udb-2.2 {adding entries, missing user} { - set udb [::pop3d::udb::new] - catch {$udb add {} blurb ****} res - $udb destroy - set res -} {user specification missing} - -test pop3-udb-2.3 {adding entries, missing passwd} { - set udb [::pop3d::udb::new] - catch {$udb add bar {} ****} res - $udb destroy - set res -} {password not specified} - -test pop3-udb-2.4 {adding entries, missing storage} { - set udb [::pop3d::udb::new] - catch {$udb add bar blurb {}} res - $udb destroy - set res -} {storage location not defined} - - -test pop3-udb-3.0 {removing entries} { - set udb [::pop3d::udb::new] - $udb add bar blurb **** - set res [list [$udb who]] - $udb remove bar - lappend res [$udb who] - $udb destroy - set res -} {bar {}} - -test pop3-udb-3.1 {removing entries} { - set udb [::pop3d::udb::new] - catch {$udb remove bar} res - $udb destroy - set res -} {user "bar" not known} - -test pop3-udb-3.2 {removing entries} { - set udb [::pop3d::udb::new] - catch {$udb remove {}} res - $udb destroy - set res -} {user specification missing} - - -test pop3-udb-3.0 {renaming entries} { - set udb [::pop3d::udb::new] - $udb add bar blurb **** - set res [list [$udb who]] - $udb rename bar booze - lappend res [$udb who] - $udb destroy - set res -} {bar booze} - -test pop3-udb-3.1 {renaming entries} { - set udb [::pop3d::udb::new] - catch {$udb rename {} {}} res - $udb destroy - set res -} {user specification missing} - -test pop3-udb-3.2 {renaming entries} { - set udb [::pop3d::udb::new] - catch {$udb rename bar {}} res - $udb destroy - set res -} {user specification missing} - -test pop3-udb-3.3 {renaming entries} { - set udb [::pop3d::udb::new] - catch {$udb rename bar floss} res - $udb destroy - set res -} {user "bar" not known} - -test pop3-udb-3.4 {renaming entries} { - set udb [::pop3d::udb::new] - $udb add bar blurb **** - $udb add booze blurb **** - catch {$udb rename bar booze} res - $udb destroy - set res -} {user "booze" is known} - - -test pop3-udb-4.0 {searching for entries} { - set udb [::pop3d::udb::new] - $udb add bar blurb **** - set res [$udb lookup bar] - $udb destroy - set res -} {blurb ****} - -test pop3-udb-4.1 {searching for entries} { - set udb [::pop3d::udb::new] - catch {$udb lookup bar} res - $udb destroy - set res -} {user "bar" not known} - - -test pop3-udb-5.0 {existence of entries} { - set udb [::pop3d::udb::new] - $udb add bar blurb **** - set res [$udb exists bar] - $udb destroy - set res -} 1 - -test pop3-udb-5.1 {existence of entries} { - set udb [::pop3d::udb::new] - set res [$udb exists bar] - $udb destroy - set res -} 0 - -# = who = already tested as part of add/remove - -makeFile {} __UDB__ -makeFile {} __UDB__.old - -test pop3-udb-6.0 {save database} { - set udb [::pop3d::udb::new] - $udb add bar blurb **** - $udb add booze Xblurb ***X - $udb save __UDB__ - $udb destroy - viewFile __UDB__ -} {# -*- tcl -*- -# ----------- user authentication database - - - add bar blurb **** - add booze Xblurb ***X -} - -test pop3-udb-6.1 {read database} { - set udb [::pop3d::udb::new] - $udb read __UDB__ - set res [list [lsort [$udb who]]] - foreach u [lsort [$udb who]] { - lappend res [$udb lookup $u] - } - $udb destroy - set res -} {{bar booze} {blurb ****} {Xblurb ***X}} - - - -# ---------------------------------------------------------------------- -::tcltest::cleanupTests DELETED modules/pop3d/rfc1939.txt Index: modules/pop3d/rfc1939.txt ================================================================== --- modules/pop3d/rfc1939.txt +++ /dev/null @@ -1,1291 +0,0 @@ - - - - -Network Working Group J. Myers -Request for Comments: 1939 Carnegie Mellon -STD: 53 M. Rose -Obsoletes: 1725 Dover Beach Consulting, Inc. -Category: Standards Track May 1996 - - - Post Office Protocol - Version 3 - -Status of this Memo - - This document specifies an Internet standards track protocol for the - Internet community, and requests discussion and suggestions for - improvements. Please refer to the current edition of the "Internet - Official Protocol Standards" (STD 1) for the standardization state - and status of this protocol. Distribution of this memo is unlimited. - -Table of Contents - - 1. Introduction ................................................ 2 - 2. A Short Digression .......................................... 2 - 3. Basic Operation ............................................. 3 - 4. The AUTHORIZATION State ..................................... 4 - QUIT Command ................................................ 5 - 5. The TRANSACTION State ....................................... 5 - STAT Command ................................................ 6 - LIST Command ................................................ 6 - RETR Command ................................................ 8 - DELE Command ................................................ 8 - NOOP Command ................................................ 9 - RSET Command ................................................ 9 - 6. The UPDATE State ............................................ 10 - QUIT Command ................................................ 10 - 7. Optional POP3 Commands ...................................... 11 - TOP Command ................................................. 11 - UIDL Command ................................................ 12 - USER Command ................................................ 13 - PASS Command ................................................ 14 - APOP Command ................................................ 15 - 8. Scaling and Operational Considerations ...................... 16 - 9. POP3 Command Summary ........................................ 18 - 10. Example POP3 Session ....................................... 19 - 11. Message Format ............................................. 19 - 12. References ................................................. 20 - 13. Security Considerations .................................... 20 - 14. Acknowledgements ........................................... 20 - 15. Authors' Addresses ......................................... 21 - Appendix A. Differences from RFC 1725 .......................... 22 - - - -Myers & Rose Standards Track [Page 1] - -RFC 1939 POP3 May 1996 - - - Appendix B. Command Index ...................................... 23 - -1. Introduction - - On certain types of smaller nodes in the Internet it is often - impractical to maintain a message transport system (MTS). For - example, a workstation may not have sufficient resources (cycles, - disk space) in order to permit a SMTP server [RFC821] and associated - local mail delivery system to be kept resident and continuously - running. Similarly, it may be expensive (or impossible) to keep a - personal computer interconnected to an IP-style network for long - amounts of time (the node is lacking the resource known as - "connectivity"). - - Despite this, it is often very useful to be able to manage mail on - these smaller nodes, and they often support a user agent (UA) to aid - the tasks of mail handling. To solve this problem, a node which can - support an MTS entity offers a maildrop service to these less endowed - nodes. The Post Office Protocol - Version 3 (POP3) is intended to - permit a workstation to dynamically access a maildrop on a server - host in a useful fashion. Usually, this means that the POP3 protocol - is used to allow a workstation to retrieve mail that the server is - holding for it. - - POP3 is not intended to provide extensive manipulation operations of - mail on the server; normally, mail is downloaded and then deleted. A - more advanced (and complex) protocol, IMAP4, is discussed in - [RFC1730]. - - For the remainder of this memo, the term "client host" refers to a - host making use of the POP3 service, while the term "server host" - refers to a host which offers the POP3 service. - -2. A Short Digression - - This memo does not specify how a client host enters mail into the - transport system, although a method consistent with the philosophy of - this memo is presented here: - - When the user agent on a client host wishes to enter a message - into the transport system, it establishes an SMTP connection to - its relay host and sends all mail to it. This relay host could - be, but need not be, the POP3 server host for the client host. Of - course, the relay host must accept mail for delivery to arbitrary - recipient addresses, that functionality is not required of all - SMTP servers. - - - - - -Myers & Rose Standards Track [Page 2] - -RFC 1939 POP3 May 1996 - - -3. Basic Operation - - Initially, the server host starts the POP3 service by listening on - TCP port 110. When a client host wishes to make use of the service, - it establishes a TCP connection with the server host. When the - connection is established, the POP3 server sends a greeting. The - client and POP3 server then exchange commands and responses - (respectively) until the connection is closed or aborted. - - Commands in the POP3 consist of a case-insensitive keyword, possibly - followed by one or more arguments. All commands are terminated by a - CRLF pair. Keywords and arguments consist of printable ASCII - characters. Keywords and arguments are each separated by a single - SPACE character. Keywords are three or four characters long. Each - argument may be up to 40 characters long. - - Responses in the POP3 consist of a status indicator and a keyword - possibly followed by additional information. All responses are - terminated by a CRLF pair. Responses may be up to 512 characters - long, including the terminating CRLF. There are currently two status - indicators: positive ("+OK") and negative ("-ERR"). Servers MUST - send the "+OK" and "-ERR" in upper case. - - Responses to certain commands are multi-line. In these cases, which - are clearly indicated below, after sending the first line of the - response and a CRLF, any additional lines are sent, each terminated - by a CRLF pair. When all lines of the response have been sent, a - final line is sent, consisting of a termination octet (decimal code - 046, ".") and a CRLF pair. If any line of the multi-line response - begins with the termination octet, the line is "byte-stuffed" by - pre-pending the termination octet to that line of the response. - Hence a multi-line response is terminated with the five octets - "CRLF.CRLF". When examining a multi-line response, the client checks - to see if the line begins with the termination octet. If so and if - octets other than CRLF follow, the first octet of the line (the - termination octet) is stripped away. If so and if CRLF immediately - follows the termination character, then the response from the POP - server is ended and the line containing ".CRLF" is not considered - part of the multi-line response. - - A POP3 session progresses through a number of states during its - lifetime. Once the TCP connection has been opened and the POP3 - server has sent the greeting, the session enters the AUTHORIZATION - state. In this state, the client must identify itself to the POP3 - server. Once the client has successfully done this, the server - acquires resources associated with the client's maildrop, and the - session enters the TRANSACTION state. In this state, the client - requests actions on the part of the POP3 server. When the client has - - - -Myers & Rose Standards Track [Page 3] - -RFC 1939 POP3 May 1996 - - - issued the QUIT command, the session enters the UPDATE state. In - this state, the POP3 server releases any resources acquired during - the TRANSACTION state and says goodbye. The TCP connection is then - closed. - - A server MUST respond to an unrecognized, unimplemented, or - syntactically invalid command by responding with a negative status - indicator. A server MUST respond to a command issued when the - session is in an incorrect state by responding with a negative status - indicator. There is no general method for a client to distinguish - between a server which does not implement an optional command and a - server which is unwilling or unable to process the command. - - A POP3 server MAY have an inactivity autologout timer. Such a timer - MUST be of at least 10 minutes' duration. The receipt of any command - from the client during that interval should suffice to reset the - autologout timer. When the timer expires, the session does NOT enter - the UPDATE state--the server should close the TCP connection without - removing any messages or sending any response to the client. - -4. The AUTHORIZATION State - - Once the TCP connection has been opened by a POP3 client, the POP3 - server issues a one line greeting. This can be any positive - response. An example might be: - - S: +OK POP3 server ready - - The POP3 session is now in the AUTHORIZATION state. The client must - now identify and authenticate itself to the POP3 server. Two - possible mechanisms for doing this are described in this document, - the USER and PASS command combination and the APOP command. Both - mechanisms are described later in this document. Additional - authentication mechanisms are described in [RFC1734]. While there is - no single authentication mechanism that is required of all POP3 - servers, a POP3 server must of course support at least one - authentication mechanism. - - Once the POP3 server has determined through the use of any - authentication command that the client should be given access to the - appropriate maildrop, the POP3 server then acquires an exclusive- - access lock on the maildrop, as necessary to prevent messages from - being modified or removed before the session enters the UPDATE state. - If the lock is successfully acquired, the POP3 server responds with a - positive status indicator. The POP3 session now enters the - TRANSACTION state, with no messages marked as deleted. If the - maildrop cannot be opened for some reason (for example, a lock can - not be acquired, the client is denied access to the appropriate - - - -Myers & Rose Standards Track [Page 4] - -RFC 1939 POP3 May 1996 - - - maildrop, or the maildrop cannot be parsed), the POP3 server responds - with a negative status indicator. (If a lock was acquired but the - POP3 server intends to respond with a negative status indicator, the - POP3 server must release the lock prior to rejecting the command.) - After returning a negative status indicator, the server may close the - connection. If the server does not close the connection, the client - may either issue a new authentication command and start again, or the - client may issue the QUIT command. - - After the POP3 server has opened the maildrop, it assigns a message- - number to each message, and notes the size of each message in octets. - The first message in the maildrop is assigned a message-number of - "1", the second is assigned "2", and so on, so that the nth message - in a maildrop is assigned a message-number of "n". In POP3 commands - and responses, all message-numbers and message sizes are expressed in - base-10 (i.e., decimal). - - Here is the summary for the QUIT command when used in the - AUTHORIZATION state: - - QUIT - - Arguments: none - - Restrictions: none - - Possible Responses: - +OK - - Examples: - C: QUIT - S: +OK dewey POP3 server signing off - -5. The TRANSACTION State - - Once the client has successfully identified itself to the POP3 server - and the POP3 server has locked and opened the appropriate maildrop, - the POP3 session is now in the TRANSACTION state. The client may now - issue any of the following POP3 commands repeatedly. After each - command, the POP3 server issues a response. Eventually, the client - issues the QUIT command and the POP3 session enters the UPDATE state. - - - - - - - - - - -Myers & Rose Standards Track [Page 5] - -RFC 1939 POP3 May 1996 - - - Here are the POP3 commands valid in the TRANSACTION state: - - STAT - - Arguments: none - - Restrictions: - may only be given in the TRANSACTION state - - Discussion: - The POP3 server issues a positive response with a line - containing information for the maildrop. This line is - called a "drop listing" for that maildrop. - - In order to simplify parsing, all POP3 servers are - required to use a certain format for drop listings. The - positive response consists of "+OK" followed by a single - space, the number of messages in the maildrop, a single - space, and the size of the maildrop in octets. This memo - makes no requirement on what follows the maildrop size. - Minimal implementations should just end that line of the - response with a CRLF pair. More advanced implementations - may include other information. - - NOTE: This memo STRONGLY discourages implementations - from supplying additional information in the drop - listing. Other, optional, facilities are discussed - later on which permit the client to parse the messages - in the maildrop. - - Note that messages marked as deleted are not counted in - either total. - - Possible Responses: - +OK nn mm - - Examples: - C: STAT - S: +OK 2 320 - - - LIST [msg] - - Arguments: - a message-number (optional), which, if present, may NOT - refer to a message marked as deleted - - - - - -Myers & Rose Standards Track [Page 6] - -RFC 1939 POP3 May 1996 - - - Restrictions: - may only be given in the TRANSACTION state - - Discussion: - If an argument was given and the POP3 server issues a - positive response with a line containing information for - that message. This line is called a "scan listing" for - that message. - - If no argument was given and the POP3 server issues a - positive response, then the response given is multi-line. - After the initial +OK, for each message in the maildrop, - the POP3 server responds with a line containing - information for that message. This line is also called a - "scan listing" for that message. If there are no - messages in the maildrop, then the POP3 server responds - with no scan listings--it issues a positive response - followed by a line containing a termination octet and a - CRLF pair. - - In order to simplify parsing, all POP3 servers are - required to use a certain format for scan listings. A - scan listing consists of the message-number of the - message, followed by a single space and the exact size of - the message in octets. Methods for calculating the exact - size of the message are described in the "Message Format" - section below. This memo makes no requirement on what - follows the message size in the scan listing. Minimal - implementations should just end that line of the response - with a CRLF pair. More advanced implementations may - include other information, as parsed from the message. - - NOTE: This memo STRONGLY discourages implementations - from supplying additional information in the scan - listing. Other, optional, facilities are discussed - later on which permit the client to parse the messages - in the maildrop. - - Note that messages marked as deleted are not listed. - - Possible Responses: - +OK scan listing follows - -ERR no such message - - Examples: - C: LIST - S: +OK 2 messages (320 octets) - S: 1 120 - - - -Myers & Rose Standards Track [Page 7] - -RFC 1939 POP3 May 1996 - - - S: 2 200 - S: . - ... - C: LIST 2 - S: +OK 2 200 - ... - C: LIST 3 - S: -ERR no such message, only 2 messages in maildrop - - - RETR msg - - Arguments: - a message-number (required) which may NOT refer to a - message marked as deleted - - Restrictions: - may only be given in the TRANSACTION state - - Discussion: - If the POP3 server issues a positive response, then the - response given is multi-line. After the initial +OK, the - POP3 server sends the message corresponding to the given - message-number, being careful to byte-stuff the termination - character (as with all multi-line responses). - - Possible Responses: - +OK message follows - -ERR no such message - - Examples: - C: RETR 1 - S: +OK 120 octets - S: - S: . - - - DELE msg - - Arguments: - a message-number (required) which may NOT refer to a - message marked as deleted - - Restrictions: - may only be given in the TRANSACTION state - - - - - - -Myers & Rose Standards Track [Page 8] - -RFC 1939 POP3 May 1996 - - - Discussion: - The POP3 server marks the message as deleted. Any future - reference to the message-number associated with the message - in a POP3 command generates an error. The POP3 server does - not actually delete the message until the POP3 session - enters the UPDATE state. - - Possible Responses: - +OK message deleted - -ERR no such message - - Examples: - C: DELE 1 - S: +OK message 1 deleted - ... - C: DELE 2 - S: -ERR message 2 already deleted - - - NOOP - - Arguments: none - - Restrictions: - may only be given in the TRANSACTION state - - Discussion: - The POP3 server does nothing, it merely replies with a - positive response. - - Possible Responses: - +OK - - Examples: - C: NOOP - S: +OK - - - RSET - - Arguments: none - - Restrictions: - may only be given in the TRANSACTION state - - Discussion: - If any messages have been marked as deleted by the POP3 - server, they are unmarked. The POP3 server then replies - - - -Myers & Rose Standards Track [Page 9] - -RFC 1939 POP3 May 1996 - - - with a positive response. - - Possible Responses: - +OK - - Examples: - C: RSET - S: +OK maildrop has 2 messages (320 octets) - -6. The UPDATE State - - When the client issues the QUIT command from the TRANSACTION state, - the POP3 session enters the UPDATE state. (Note that if the client - issues the QUIT command from the AUTHORIZATION state, the POP3 - session terminates but does NOT enter the UPDATE state.) - - If a session terminates for some reason other than a client-issued - QUIT command, the POP3 session does NOT enter the UPDATE state and - MUST not remove any messages from the maildrop. - - QUIT - - Arguments: none - - Restrictions: none - - Discussion: - The POP3 server removes all messages marked as deleted - from the maildrop and replies as to the status of this - operation. If there is an error, such as a resource - shortage, encountered while removing messages, the - maildrop may result in having some or none of the messages - marked as deleted be removed. In no case may the server - remove any messages not marked as deleted. - - Whether the removal was successful or not, the server - then releases any exclusive-access lock on the maildrop - and closes the TCP connection. - - Possible Responses: - +OK - -ERR some deleted messages not removed - - Examples: - C: QUIT - S: +OK dewey POP3 server signing off (maildrop empty) - ... - C: QUIT - - - -Myers & Rose Standards Track [Page 10] - -RFC 1939 POP3 May 1996 - - - S: +OK dewey POP3 server signing off (2 messages left) - ... - -7. Optional POP3 Commands - - The POP3 commands discussed above must be supported by all minimal - implementations of POP3 servers. - - The optional POP3 commands described below permit a POP3 client - greater freedom in message handling, while preserving a simple POP3 - server implementation. - - NOTE: This memo STRONGLY encourages implementations to support - these commands in lieu of developing augmented drop and scan - listings. In short, the philosophy of this memo is to put - intelligence in the part of the POP3 client and not the POP3 - server. - - TOP msg n - - Arguments: - a message-number (required) which may NOT refer to to a - message marked as deleted, and a non-negative number - of lines (required) - - Restrictions: - may only be given in the TRANSACTION state - - Discussion: - If the POP3 server issues a positive response, then the - response given is multi-line. After the initial +OK, the - POP3 server sends the headers of the message, the blank - line separating the headers from the body, and then the - number of lines of the indicated message's body, being - careful to byte-stuff the termination character (as with - all multi-line responses). - - Note that if the number of lines requested by the POP3 - client is greater than than the number of lines in the - body, then the POP3 server sends the entire message. - - Possible Responses: - +OK top of message follows - -ERR no such message - - Examples: - C: TOP 1 10 - S: +OK - - - -Myers & Rose Standards Track [Page 11] - -RFC 1939 POP3 May 1996 - - - S: - S: . - ... - C: TOP 100 3 - S: -ERR no such message - - - UIDL [msg] - - Arguments: - a message-number (optional), which, if present, may NOT - refer to a message marked as deleted - - Restrictions: - may only be given in the TRANSACTION state. - - Discussion: - If an argument was given and the POP3 server issues a positive - response with a line containing information for that message. - This line is called a "unique-id listing" for that message. - - If no argument was given and the POP3 server issues a positive - response, then the response given is multi-line. After the - initial +OK, for each message in the maildrop, the POP3 server - responds with a line containing information for that message. - This line is called a "unique-id listing" for that message. - - In order to simplify parsing, all POP3 servers are required to - use a certain format for unique-id listings. A unique-id - listing consists of the message-number of the message, - followed by a single space and the unique-id of the message. - No information follows the unique-id in the unique-id listing. - - The unique-id of a message is an arbitrary server-determined - string, consisting of one to 70 characters in the range 0x21 - to 0x7E, which uniquely identifies a message within a - maildrop and which persists across sessions. This - persistence is required even if a session ends without - entering the UPDATE state. The server should never reuse an - unique-id in a given maildrop, for as long as the entity - using the unique-id exists. - - Note that messages marked as deleted are not listed. - - While it is generally preferable for server implementations - to store arbitrarily assigned unique-ids in the maildrop, - - - -Myers & Rose Standards Track [Page 12] - -RFC 1939 POP3 May 1996 - - - this specification is intended to permit unique-ids to be - calculated as a hash of the message. Clients should be able - to handle a situation where two identical copies of a - message in a maildrop have the same unique-id. - - Possible Responses: - +OK unique-id listing follows - -ERR no such message - - Examples: - C: UIDL - S: +OK - S: 1 whqtswO00WBw418f9t5JxYwZ - S: 2 QhdPYR:00WBw1Ph7x7 - S: . - ... - C: UIDL 2 - S: +OK 2 QhdPYR:00WBw1Ph7x7 - ... - C: UIDL 3 - S: -ERR no such message, only 2 messages in maildrop - - - USER name - - Arguments: - a string identifying a mailbox (required), which is of - significance ONLY to the server - - Restrictions: - may only be given in the AUTHORIZATION state after the POP3 - greeting or after an unsuccessful USER or PASS command - - Discussion: - To authenticate using the USER and PASS command - combination, the client must first issue the USER - command. If the POP3 server responds with a positive - status indicator ("+OK"), then the client may issue - either the PASS command to complete the authentication, - or the QUIT command to terminate the POP3 session. If - the POP3 server responds with a negative status indicator - ("-ERR") to the USER command, then the client may either - issue a new authentication command or may issue the QUIT - command. - - The server may return a positive response even though no - such mailbox exists. The server may return a negative - response if mailbox exists, but does not permit plaintext - - - -Myers & Rose Standards Track [Page 13] - -RFC 1939 POP3 May 1996 - - - password authentication. - - Possible Responses: - +OK name is a valid mailbox - -ERR never heard of mailbox name - - Examples: - C: USER frated - S: -ERR sorry, no mailbox for frated here - ... - C: USER mrose - S: +OK mrose is a real hoopy frood - - - PASS string - - Arguments: - a server/mailbox-specific password (required) - - Restrictions: - may only be given in the AUTHORIZATION state immediately - after a successful USER command - - Discussion: - When the client issues the PASS command, the POP3 server - uses the argument pair from the USER and PASS commands to - determine if the client should be given access to the - appropriate maildrop. - - Since the PASS command has exactly one argument, a POP3 - server may treat spaces in the argument as part of the - password, instead of as argument separators. - - Possible Responses: - +OK maildrop locked and ready - -ERR invalid password - -ERR unable to lock maildrop - - Examples: - C: USER mrose - S: +OK mrose is a real hoopy frood - C: PASS secret - S: -ERR maildrop already locked - ... - C: USER mrose - S: +OK mrose is a real hoopy frood - C: PASS secret - S: +OK mrose's maildrop has 2 messages (320 octets) - - - -Myers & Rose Standards Track [Page 14] - -RFC 1939 POP3 May 1996 - - - APOP name digest - - Arguments: - a string identifying a mailbox and a MD5 digest string - (both required) - - Restrictions: - may only be given in the AUTHORIZATION state after the POP3 - greeting or after an unsuccessful USER or PASS command - - Discussion: - Normally, each POP3 session starts with a USER/PASS - exchange. This results in a server/user-id specific - password being sent in the clear on the network. For - intermittent use of POP3, this may not introduce a sizable - risk. However, many POP3 client implementations connect to - the POP3 server on a regular basis -- to check for new - mail. Further the interval of session initiation may be on - the order of five minutes. Hence, the risk of password - capture is greatly enhanced. - - An alternate method of authentication is required which - provides for both origin authentication and replay - protection, but which does not involve sending a password - in the clear over the network. The APOP command provides - this functionality. - - A POP3 server which implements the APOP command will - include a timestamp in its banner greeting. The syntax of - the timestamp corresponds to the `msg-id' in [RFC822], and - MUST be different each time the POP3 server issues a banner - greeting. For example, on a UNIX implementation in which a - separate UNIX process is used for each instance of a POP3 - server, the syntax of the timestamp might be: - - - - where `process-ID' is the decimal value of the process's - PID, clock is the decimal value of the system clock, and - hostname is the fully-qualified domain-name corresponding - to the host where the POP3 server is running. - - The POP3 client makes note of this timestamp, and then - issues the APOP command. The `name' parameter has - identical semantics to the `name' parameter of the USER - command. The `digest' parameter is calculated by applying - the MD5 algorithm [RFC1321] to a string consisting of the - timestamp (including angle-brackets) followed by a shared - - - -Myers & Rose Standards Track [Page 15] - -RFC 1939 POP3 May 1996 - - - secret. This shared secret is a string known only to the - POP3 client and server. Great care should be taken to - prevent unauthorized disclosure of the secret, as knowledge - of the secret will allow any entity to successfully - masquerade as the named user. The `digest' parameter - itself is a 16-octet value which is sent in hexadecimal - format, using lower-case ASCII characters. - - When the POP3 server receives the APOP command, it verifies - the digest provided. If the digest is correct, the POP3 - server issues a positive response, and the POP3 session - enters the TRANSACTION state. Otherwise, a negative - response is issued and the POP3 session remains in the - AUTHORIZATION state. - - Note that as the length of the shared secret increases, so - does the difficulty of deriving it. As such, shared - secrets should be long strings (considerably longer than - the 8-character example shown below). - - Possible Responses: - +OK maildrop locked and ready - -ERR permission denied - - Examples: - S: +OK POP3 server ready <1896.697170952@dbc.mtview.ca.us> - C: APOP mrose c4c9334bac560ecc979e58001b3e22fb - S: +OK maildrop has 1 message (369 octets) - - In this example, the shared secret is the string `tan- - staaf'. Hence, the MD5 algorithm is applied to the string - - <1896.697170952@dbc.mtview.ca.us>tanstaaf - - which produces a digest value of - - c4c9334bac560ecc979e58001b3e22fb - -8. Scaling and Operational Considerations - - Since some of the optional features described above were added to the - POP3 protocol, experience has accumulated in using them in large- - scale commercial post office operations where most of the users are - unrelated to each other. In these situations and others, users and - vendors of POP3 clients have discovered that the combination of using - the UIDL command and not issuing the DELE command can provide a weak - version of the "maildrop as semi-permanent repository" functionality - normally associated with IMAP. Of course the other capabilities of - - - -Myers & Rose Standards Track [Page 16] - -RFC 1939 POP3 May 1996 - - - IMAP, such as polling an existing connection for newly arrived - messages and supporting multiple folders on the server, are not - present in POP3. - - When these facilities are used in this way by casual users, there has - been a tendency for already-read messages to accumulate on the server - without bound. This is clearly an undesirable behavior pattern from - the standpoint of the server operator. This situation is aggravated - by the fact that the limited capabilities of the POP3 do not permit - efficient handling of maildrops which have hundreds or thousands of - messages. - - Consequently, it is recommended that operators of large-scale multi- - user servers, especially ones in which the user's only access to the - maildrop is via POP3, consider such options as: - - * Imposing a per-user maildrop storage quota or the like. - - A disadvantage to this option is that accumulation of messages may - result in the user's inability to receive new ones into the - maildrop. Sites which choose this option should be sure to inform - users of impending or current exhaustion of quota, perhaps by - inserting an appropriate message into the user's maildrop. - - * Enforce a site policy regarding mail retention on the server. - - Sites are free to establish local policy regarding the storage and - retention of messages on the server, both read and unread. For - example, a site might delete unread messages from the server after - 60 days and delete read messages after 7 days. Such message - deletions are outside the scope of the POP3 protocol and are not - considered a protocol violation. - - Server operators enforcing message deletion policies should take - care to make all users aware of the policies in force. - - Clients must not assume that a site policy will automate message - deletions, and should continue to explicitly delete messages using - the DELE command when appropriate. - - It should be noted that enforcing site message deletion policies - may be confusing to the user community, since their POP3 client - may contain configuration options to leave mail on the server - which will not in fact be supported by the server. - - One special case of a site policy is that messages may only be - downloaded once from the server, and are deleted after this has - been accomplished. This could be implemented in POP3 server - - - -Myers & Rose Standards Track [Page 17] - -RFC 1939 POP3 May 1996 - - - software by the following mechanism: "following a POP3 login by a - client which was ended by a QUIT, delete all messages downloaded - during the session with the RETR command". It is important not to - delete messages in the event of abnormal connection termination - (ie, if no QUIT was received from the client) because the client - may not have successfully received or stored the messages. - Servers implementing a download-and-delete policy may also wish to - disable or limit the optional TOP command, since it could be used - as an alternate mechanism to download entire messages. - -9. POP3 Command Summary - - Minimal POP3 Commands: - - USER name valid in the AUTHORIZATION state - PASS string - QUIT - - STAT valid in the TRANSACTION state - LIST [msg] - RETR msg - DELE msg - NOOP - RSET - QUIT - - Optional POP3 Commands: - - APOP name digest valid in the AUTHORIZATION state - - TOP msg n valid in the TRANSACTION state - UIDL [msg] - - POP3 Replies: - - +OK - -ERR - - Note that with the exception of the STAT, LIST, and UIDL commands, - the reply given by the POP3 server to any command is significant - only to "+OK" and "-ERR". Any text occurring after this reply - may be ignored by the client. - - - - - - - - - -Myers & Rose Standards Track [Page 18] - -RFC 1939 POP3 May 1996 - - -10. Example POP3 Session - - S: - C: - S: +OK POP3 server ready <1896.697170952@dbc.mtview.ca.us> - C: APOP mrose c4c9334bac560ecc979e58001b3e22fb - S: +OK mrose's maildrop has 2 messages (320 octets) - C: STAT - S: +OK 2 320 - C: LIST - S: +OK 2 messages (320 octets) - S: 1 120 - S: 2 200 - S: . - C: RETR 1 - S: +OK 120 octets - S: - S: . - C: DELE 1 - S: +OK message 1 deleted - C: RETR 2 - S: +OK 200 octets - S: - S: . - C: DELE 2 - S: +OK message 2 deleted - C: QUIT - S: +OK dewey POP3 server signing off (maildrop empty) - C: - S: - -11. Message Format - - All messages transmitted during a POP3 session are assumed to conform - to the standard for the format of Internet text messages [RFC822]. - - It is important to note that the octet count for a message on the - server host may differ from the octet count assigned to that message - due to local conventions for designating end-of-line. Usually, - during the AUTHORIZATION state of the POP3 session, the POP3 server - can calculate the size of each message in octets when it opens the - maildrop. For example, if the POP3 server host internally represents - end-of-line as a single character, then the POP3 server simply counts - each occurrence of this character in a message as two octets. Note - that lines in the message which start with the termination octet need - not (and must not) be counted twice, since the POP3 client will - remove all byte-stuffed termination characters when it receives a - multi-line response. - - - -Myers & Rose Standards Track [Page 19] - -RFC 1939 POP3 May 1996 - - -12. References - - [RFC821] Postel, J., "Simple Mail Transfer Protocol", STD 10, RFC - 821, USC/Information Sciences Institute, August 1982. - - [RFC822] Crocker, D., "Standard for the Format of ARPA-Internet Text - Messages", STD 11, RFC 822, University of Delaware, August 1982. - - [RFC1321] Rivest, R., "The MD5 Message-Digest Algorithm", RFC 1321, - MIT Laboratory for Computer Science, April 1992. - - [RFC1730] Crispin, M., "Internet Message Access Protocol - Version - 4", RFC 1730, University of Washington, December 1994. - - [RFC1734] Myers, J., "POP3 AUTHentication command", RFC 1734, - Carnegie Mellon, December 1994. - -13. Security Considerations - - It is conjectured that use of the APOP command provides origin - identification and replay protection for a POP3 session. - Accordingly, a POP3 server which implements both the PASS and APOP - commands should not allow both methods of access for a given user; - that is, for a given mailbox name, either the USER/PASS command - sequence or the APOP command is allowed, but not both. - - Further, note that as the length of the shared secret increases, so - does the difficulty of deriving it. - - Servers that answer -ERR to the USER command are giving potential - attackers clues about which names are valid. - - Use of the PASS command sends passwords in the clear over the - network. - - Use of the RETR and TOP commands sends mail in the clear over the - network. - - Otherwise, security issues are not discussed in this memo. - -14. Acknowledgements - - The POP family has a long and checkered history. Although primarily - a minor revision to RFC 1460, POP3 is based on the ideas presented in - RFCs 918, 937, and 1081. - - In addition, Alfred Grimstad, Keith McCloghrie, and Neil Ostroff - provided significant comments on the APOP command. - - - -Myers & Rose Standards Track [Page 20] - -RFC 1939 POP3 May 1996 - - -15. Authors' Addresses - - John G. Myers - Carnegie-Mellon University - 5000 Forbes Ave - Pittsburgh, PA 15213 - - EMail: jgm+@cmu.edu - - - Marshall T. Rose - Dover Beach Consulting, Inc. - 420 Whisman Court - Mountain View, CA 94043-2186 - - EMail: mrose@dbc.mtview.ca.us - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Myers & Rose Standards Track [Page 21] - -RFC 1939 POP3 May 1996 - - -Appendix A. Differences from RFC 1725 - - This memo is a revision to RFC 1725, a Draft Standard. It makes the - following changes from that document: - - - clarifies that command keywords are case insensitive. - - - specifies that servers must send "+OK" and "-ERR" in - upper case. - - - specifies that the initial greeting is a positive response, - instead of any string which should be a positive response. - - - clarifies behavior for unimplemented commands. - - - makes the USER and PASS commands optional. - - - clarified the set of possible responses to the USER command. - - - reverses the order of the examples in the USER and PASS - commands, to reduce confusion. - - - clarifies that the PASS command may only be given immediately - after a successful USER command. - - - clarified the persistence requirements of UIDs and added some - implementation notes. - - - specifies a UID length limitation of one to 70 octets. - - - specifies a status indicator length limitation - of 512 octets, including the CRLF. - - - clarifies that LIST with no arguments on an empty mailbox - returns success. - - - adds a reference from the LIST command to the Message Format - section - - - clarifies the behavior of QUIT upon failure - - - clarifies the security section to not imply the use of the - USER command with the APOP command. - - - adds references to RFCs 1730 and 1734 - - - clarifies the method by which a UA may enter mail into the - transport system. - - - -Myers & Rose Standards Track [Page 22] - -RFC 1939 POP3 May 1996 - - - - clarifies that the second argument to the TOP command is a - number of lines. - - - changes the suggestion in the Security Considerations section - for a server to not accept both PASS and APOP for a given user - from a "must" to a "should". - - - adds a section on scaling and operational considerations - -Appendix B. Command Index - - APOP ....................................................... 15 - DELE ....................................................... 8 - LIST ....................................................... 6 - NOOP ....................................................... 9 - PASS ....................................................... 14 - QUIT ....................................................... 5 - QUIT ....................................................... 10 - RETR ....................................................... 8 - RSET ....................................................... 9 - STAT ....................................................... 6 - TOP ........................................................ 11 - UIDL ....................................................... 12 - USER ....................................................... 13 - - - - - - - - - - - - - - - - - - - - - - - - - - - -Myers & Rose Standards Track [Page 23] - - - DELETED modules/profiler/ChangeLog Index: modules/profiler/ChangeLog ================================================================== --- modules/profiler/ChangeLog +++ /dev/null @@ -1,115 +0,0 @@ -2003-04-13 Andreas Kupries - - * profiler.test: - * profiler.tcl: Accepted patch #575376 by Hemang Lavana - reorganizing the internals - a bit and using the 8.4 specific trace support if possible. - -2003-04-11 Andreas Kupries - - * profiler.tcl: - * profiler.man: - * pkgIndex.tcl: Set version of the package to to 0.2.1. - -2003-02-24 David N. Welton - - * profiler.tcl (::profiler::tZero): Use string map instead of - regsub. - -2003-02-06 David N. Welton - - * profiler.tcl (::profiler::profProc): Use string match instead of - regexp. - -2003-01-16 Andreas Kupries - - * profiler.man: More semantic markup, less visual one. - -2002-10-14 Jeff Hobbs - - * profiler.tcl (dump): required result initialization. [Bug #564767] - -2002-04-15 Andreas Kupries - - * profiler.man: Added doctools manpage. - -2001-08-21 Andreas Kupries - - * pkgIndex.tcl: Moved version to 0.2. - - * profiler.test: Adapted testsuite. - - * profiler.n: Added documentation. Same patch as below. - - * profiler.tcl: Applied patch [446799] by Hemang Lavana - , adding support for - resume/suspend operations to the profiler. moved version to 0.2. - -2001-07-31 Andreas Kupries - - * profiler.tcl (Handler): Fixed [446562]. - -2001-07-10 Andreas Kupries - - * profiler.tcl: Frink 2.2 run, fixed dubious code. - -2001-06-21 Andreas Kupries - - * profiler.tcl: Fixed dubious code reported by frink. - -2000-09-20 Eric Melski - - * profiler.tcl: Corrected some non-Tcl-style-guide conforming - function headers. - -2000-06-15 Eric Melski - - * profiler.tcl: Added mods from Philip Ehrens - to changed formatting, add additional - statistics. [RFE: 5060] - -2000-03-27 Eric Melski - - * profiler.tcl: Added a check for [clock clicks] wrapping. - -2000-03-20 Eric Melski - - * profiler.test: - * profiler.tcl: Fixed issue with printing of descendants. - -2000-03-09 Eric Melski - - * profiler.test: Adapted tests to work inside and outside of - tcllib test framework. - -2000-03-08 Eric Melski - - * profiler.test: - * profiler.tcl: Added tracking of descendant time; changed - definition of total time to include compile time (which makes - determination of exclusive time (time in a function but not in its - descendants) easier). - -2000-03-03 Eric Melski - - * profiler.tcl: Added profiler::reset function and enhanced - profiler::sortFunctions - - * profiler.n: Updated documentation. - -2000-02-24 Eric Melski - - * profiler.tcl: Fixed dump command output to include - the name of the function being dumped. - -2000-02-17 Eric Melski - - * pkgIndex.tcl: package index for profiler. - - * man.macros: - * profiler.n: Doc for profiler. - - * profiler.test: Tests for profiler. - - * profiler.tcl: Simple Tcl function-level profiler. - DELETED modules/profiler/pkgIndex.tcl Index: modules/profiler/pkgIndex.tcl ================================================================== --- modules/profiler/pkgIndex.tcl +++ /dev/null @@ -1,12 +0,0 @@ -# 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. - -if {![package vsatisfies [package provide Tcl] 8.3]} {return} -package ifneeded profiler 0.2.1 [list source [file join $dir profiler.tcl]] DELETED modules/profiler/profiler.man Index: modules/profiler/profiler.man ================================================================== --- modules/profiler/profiler.man +++ /dev/null @@ -1,118 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[manpage_begin profiler n 0.2.1] -[moddesc {Tcl Profiler}] -[titledesc {Tcl source code profiler}] -[require Tcl 8.3] -[require profiler [opt 0.2.1]] -[description] -[para] - -The [package profiler] package provides a simple Tcl source code -profiler. It is a function-level profiler; that is, it collects only -function-level information, not the more detailed line-level -information. It operates by redefining the Tcl [cmd proc] command. -Profiling is initiated via the [cmd ::profiler::init] command. - -[section COMMANDS] - -[list_begin definitions] - - -[call [cmd ::profiler::init]] - -Initiate profiling. All procedures created after this command is -called will be profiled. To profile an entire application, this -command must be called before any other commands. - -[call [cmd ::profiler::dump] [arg pattern]] - -Dump profiling information for the all functions matching - -[arg pattern]. If no pattern is specified, information for all -functions will be returned. The result is a list of key/value pairs -that maps function names to information about that function. The -information about each function is in turn a list of key/value pairs. -The keys used and their values are: - -[list_begin definitions] - -[lst_item [const totalCalls]] - -The total number of times [arg functionName] was called. - -[lst_item [const callerDist]] - -A list of key/value pairs mapping each calling function that called -[arg functionName] to the number of times it called - -[arg functionName]. - -[lst_item [const compileTime]] - -The runtime, in clock clicks, of [arg functionName] the first time -that it was called. - -[lst_item [const totalRuntime]] - -The sum of the runtimes of all calls of [arg functionName]. - -[lst_item [const averageRuntime]] - -Average runtime of [arg functionName]. - -[lst_item [const descendantTime]] - -Sum of the time spent in descendants of [arg functionName]. - -[lst_item [const averageDescendantTime]] - -Average time spent in descendants of [arg functionName]. - -[list_end] - - -[call [cmd ::profiler::print] [opt [arg pattern]]] - -Print profiling information for all functions matching [arg pattern]. -If no pattern is specified, information about all functions will be -displayed. The return result is a human readable display of the -profiling information. - -[call [cmd ::profiler::reset]] - -Reset profiling information for all functions matching [arg pattern]. -If no pattern is specified, information will be reset for all -functions. - -[call [cmd ::profiler::suspend] [opt [arg pattern]]] - -Suspend profiling for all functions matching [arg pattern]. If no -pattern is specified, profiling will be suspended for all -functions. It stops gathering profiling information after this command -is issued. However, it does not erase any profiling information that -has been gathered previously. Use resume command to re-enable -profiling. - -[call [cmd ::profiler::resume] [opt [arg pattern]]] - -Resume profiling for all functions matching [arg pattern]. If no -pattern is specified, profiling will be resumed for all functions. -This command should be invoked after suspending the profiler in the -code. - -[call [cmd ::profiler::sortFunctions] [arg key]] - -Return a list of functions sorted by a particular profiling statistic. -Supported values for [arg key] are: [const calls], - -[const exclusiveTime], [const compileTime], [const nonCompileTime], -[const totalRuntime], [const avgExclusiveTime], and - -[const avgRuntime]. The return result is a list of lists, where each -sublist consists of a function name and the value of [arg key] for -that function. - -[list_end] - -[keywords profile performance speed] -[manpage_end] DELETED modules/profiler/profiler.n Index: modules/profiler/profiler.n ================================================================== --- modules/profiler/profiler.n +++ /dev/null @@ -1,112 +0,0 @@ -'\" -'\" Copyright (c) 1998-2000 by Ajuba Solutions. -'\" All rights reserved. -'\" -'\" RCS: @(#) $Id: profiler.n,v 1.6 2001/08/21 23:36:32 andreas_kupries Exp $ -'\" -.so man.macros -.TH profiler n 0.2 profiler "Tcl Profiler" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -profiler \- Tcl source code profiler -.SH SYNOPSIS -\fBpackage require Tcl 8.3\fR -.sp -\fBpackage require profiler ?0.2?\fR -.sp -\fB::profiler::suspend\fR ?\fIpattern\fR? -.sp -\fB::profiler::resume\fR ?\fIpattern\fR? -.sp -\fB::profiler::init\fR -.sp -\fB::profiler::dump\fR ?\fIpattern\fR? -.sp -\fB::profiler::print\fR ?\fIpattern\fR? -.sp -\fB::profiler::reset\fR ?\fIpattern\fR? -.sp -\fB::profiler::sortFunctions\fR \fIkey\fR -.sp -.BE -.SH DESCRIPTION -.PP -The \fBprofiler\fR package provides a simple Tcl source code -profiler. It is a function-level profiler; that is, it collects only -function-level information, not the more detailed line-level -information. It operates by redefining the Tcl \fBproc\fR command. -Profiling is initiated via the \fB::profiler::init\fR command. -.SH COMMANDS -.TP -\fB::profiler::init\fR -Initiate profiling. All procedures created after this command is -called will be profiled. To profile an entire application, this -command must be called before any other commands. -.TP -\fB::profiler::dump\fR \fIpattern\fR -Dump profiling information for the all functions matching -\fIpattern\fR. If no pattern is specified, information for all -functions will be returned. The result is a list of key/value pairs -that maps function names to information about that function. The -information about each function is in turn a list of key/value pairs. -The keys used and their values are: -.RS -.TP -\fBtotalCalls\fR -The total number of times \fIfunctionName\fR was called. -.TP -\fBcallerDist\fB -A list of key/value pairs mapping each calling function that called -\fIfunctionName\fR to the number of times it called \fIfunctionName\fR. -.TP -\fBcompileTime\fR -The runtime, in clock clicks, of \fIfunctionName\fR the first time -that it was called. -.TP -\fBtotalRuntime\fR -The sum of the runtimes of all calls of \fIfunctionName\fR. -.TP -\fBaverageRuntime\fR -Average runtime of \fIfunctionName\fR. -.TP -\fBdescendantTime\fR -Sum of the time spent in descendants of \fIfunctionName\fR. -.TP -\fBaverageDescendantTime\fR -Average time spent in descendants of \fIfunctionName\fR. -.RE -.TP -\fB::profiler::print\fR ?\fIpattern\fR? -Print profiling information for all functions matching \fIpattern\fR. -If no pattern is specified, information about all functions will be displayed. -The return result is a human readable display of the profiling -information. -.TP -\fB::profiler::reset\fR -Reset profiling information for all functions matching \fIpattern\fR. -If no pattern is specified, information will be reset for all functions. -.TP -\fB::profiler::suspend\fR ?\fIpattern\fR? -Suspend profiling for all functions matching \fIpattern\fR. -If no pattern is specified, profiling will be suspended for -all functions. It stops gathering profiling information after -this command is issued. However, it does not erase any profiling -information that has been gathered previously. -Use resume command to re-enable profiling. -.TP -\fB::profiler::resume\fR ?\fIpattern\fR? -Resume profiling for all functions matching \fIpattern\fR. -If no pattern is specified, profiling will be resumed for -all functions. This command should be invoked after suspending -the profiler in the code. -.TP -\fB::profiler::sortFunctions\fR \fIkey\fR -Return a list of functions sorted by a particular profiling -statistic. Supported values for \fIkey\fR are: \fBcalls\fR, -\fBexclusiveTime\fR, \fBcompileTime\fR, \fBnonCompileTime\fR, -\fBtotalRuntime\fR, \fBavgExclusiveTime\fR, and \fBavgRuntime\fR. The -return result is a list of lists, where each sublist consists of a -function name and the value of \fIkey\fR for that function. -.SH KEYWORDS -profile, performance, speed DELETED modules/profiler/profiler.tcl Index: modules/profiler/profiler.tcl ================================================================== --- modules/profiler/profiler.tcl +++ /dev/null @@ -1,580 +0,0 @@ -# profiler.tcl -- -# -# Tcl code profiler. -# -# Copyright (c) 1998-2000 by Ajuba Solutions. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: profiler.tcl,v 1.22 2003/04/14 07:08:36 andreas_kupries Exp $ - -package require Tcl 8.3 ;# uses [clock clicks -milliseconds] -package provide profiler 0.2.1 - -namespace eval ::profiler { -} - -# ::profiler::tZero -- -# -# Start a named timer instance -# -# Arguments: -# tag name for the timer instance; if none is given, defaults to "" -# -# Results: -# None. - -proc ::profiler::tZero { { tag "" } } { - set ms [ clock clicks -milliseconds ] - set us [ clock clicks ] - set tag [string map {: ""} $tag] - # FRINK: nocheck - set ::profiler::T$tag [ list $us $ms ] - return -} - -# ::profiler::tMark -- -# -# Return the delta time since the start of a named timer. -# -# Arguments: -# tag Tag for which to return a delta; if none is given, defaults to -# "" -# -# Results: -# dt Time difference between start of the timer and the current -# time, in microseconds. - -proc ::profiler::tMark { { tag "" } } { - set ut [ clock clicks ] - set mt [ clock clicks -milliseconds ] - set tag [string map {: ""} $tag] - - # Per tag a variable was created within the profiler - # namespace. But we should check if the tag does ecxist. - - if {![info exists ::profiler::T$tag]} { - error "Unknown tag \"$tag\"" - } - # FRINK: nocheck - set ust [ lindex [ set ::profiler::T$tag ] 0 ] - # FRINK: nocheck - set mst [ lindex [ set ::profiler::T$tag ] 1 ] - set udt [ expr { ($ut-$ust) } ] - set mdt [ expr { ($mt-$mst) } ]000 - set dt $udt - ;## handle wrapping of the microsecond clock - if { $dt < 0 || $dt > 1000000 } { set dt $mdt } - set dt -} - -# ::profiler::stats -- -# -# Compute statistical information for a set of values, including -# the mean, the standard deviation, and the covariance. -# -# Arguments: -# args Values for which to compute information. -# -# Results: -# A list with three elements: the mean, the standard deviation, and the -# covariance. - -proc ::profiler::stats {args} { - set sum 0 - set mean 0 - set sigma_sq 0 - set sigma 0 - set cov 0 - set N [ llength $args ] - if { $N > 1 } { - foreach val $args { - set sum [ expr { $sum+$val } ] - } - set mean [ expr { $sum/$N } ] - foreach val $args { - set sigma_sq [ expr { $sigma_sq+pow(($val-$mean),2) } ] - } - set sigma_sq [ expr { $sigma_sq/($N-1) } ] - set sigma [ expr { round(sqrt($sigma_sq)) } ] - set cov [ expr { (($sigma*1.0)/$mean)*100 } ] - set cov [ expr { round($cov*10)/10.0 } ] - } - return [ list $mean $sigma $cov ] -} - -# ::profiler::Handler -- -# -# Profile a function (tcl8.3). This function works together with -# profProc, which replaces the proc command. When a new procedure -# is defined, it creates and alias to this function; when that -# procedure is called, it calls this handler first, which gathers -# profiling information from the call. -# -# Arguments: -# name name of the function to profile. -# args arguments to pass to the original function. -# -# Results: -# res result from the original function. - -proc ::profiler::Handler {name args} { - variable enabled - - if { [info level] == 1 } { - set caller GLOBAL - } else { - # Get the name of the calling procedure - set caller [lindex [info level -1] 0] - # Remove the ORIG suffix - set caller [string range $caller 0 end-4] - } - - ::profiler::enterHandler $name $caller - set CODE [uplevel 1 [list ${name}ORIG] $args] - ::profiler::leaveHandler $name $caller - return $CODE -} - -# ::profiler::TraceHandler -- -# -# Profile a function (tcl8.4+). This function works together with -# profProc, which replaces the proc command. When a new procedure -# is defined, it creates an execution trace on the function; when -# that function is called, 'enter' and 'leave' traces invoke this -# handler first, which gathers profiling information from the call. -# -# Arguments: -# name name of the function to profile. -# cmd command name and its expanded arguments. -# args for 'enter' operation, value of args is "enter" -# for 'leave' operation, args is list of -# 3 elements: "leave" -# -# Results: -# None - -proc ::profiler::TraceHandler {name cmd args} { - - if { [info level] == 1 } { - set caller GLOBAL - } else { - # Get the name of the calling procedure - set caller [lindex [info level -1] 0] - } - - set type [lindex $args end] - ::profiler::${type}Handler $name $caller -} - -# ::profiler::enterHandler -- -# -# Profile a function. This function works together with Handler and -# TraceHandler to collect profiling information just before it invokes -# the function. -# -# Arguments: -# name name of the function to profile. -# caller name of the function that calls the profiled function. -# -# Results: -# None - -proc ::profiler::enterHandler {name caller} { - variable enabled - - if { !$enabled($name) } { - return - } - - if { [catch {incr ::profiler::callers($name,$caller)}] } { - set ::profiler::callers($name,$caller) 1 - } - ::profiler::tZero $name.$caller -} - -# ::profiler::leaveHandler -- -# -# Profile a function. This function works together with Handler and -# TraceHandler to collect profiling information just after it invokes -# the function. -# -# Arguments: -# name name of the function to profile. -# caller name of the function that calls the profiled function. -# -# Results: -# None - -proc ::profiler::leaveHandler {name caller} { - variable enabled - - if { !$enabled($name) } { - return - } - - set t [::profiler::tMark $name.$caller] - lappend ::profiler::statTime($name) $t - - if { [incr ::profiler::callCount($name)] == 1 } { - set ::profiler::compileTime($name) $t - } - incr ::profiler::totalRuntime($name) $t - if { [catch {incr ::profiler::descendantTime($caller) $t}] } { - set ::profiler::descendantTime($caller) $t - } - if { [catch {incr ::profiler::descendants($caller,$name)}] } { - set ::profiler::descendants($caller,$name) 1 - } -} - -# ::profiler::profProc -- -# -# Replacement for the proc command that adds rudimentary profiling -# capabilities to Tcl. -# -# Arguments: -# name name of the procedure -# arglist list of arguments -# body body of the procedure -# -# Results: -# None. - -proc ::profiler::profProc {name arglist body} { - variable callCount - variable compileTime - variable totalRuntime - variable descendantTime - variable statTime - variable enabled - variable paused - - # Get the fully qualified name of the proc - set ns [uplevel [list namespace current]] - # If the proc call did not happen at the global context and it did not - # have an absolute namespace qualifier, we have to prepend the current - # namespace to the command name - if { ![string equal $ns "::"] } { - if { ![string match "::*" $name] } { - set name "${ns}::${name}" - } - } - if { ![string match "::*" $name] } { - set name "::$name" - } - - # Set up accounting for this procedure - set callCount($name) 0 - set compileTime($name) 0 - set totalRuntime($name) 0 - set descendantTime($name) 0 - set statTime($name) {} - set enabled($name) [expr {!$paused}] - - if {[package vsatisfies [package provide Tcl] 8.4]} { - uplevel 1 [list ::_oldProc $name $arglist $body] - trace add execution $name {enter leave} \ - [list ::profiler::TraceHandler $name] - } else { - uplevel 1 [list ::_oldProc ${name}ORIG $arglist $body] - uplevel 1 [list interp alias {} $name {} ::profiler::Handler $name] - } - return -} - -# ::profiler::init -- -# -# Initialize the profiler. -# -# Arguments: -# None. -# -# Results: -# None. Renames proc to _oldProc and sets an alias for proc to -# profiler::profProc - -proc ::profiler::init {} { - # paused is set to 1 when the profiler is suspended. - variable paused 0 - - rename ::proc ::_oldProc - interp alias {} proc {} ::profiler::profProc - - return -} - -# ::profiler::print -- -# -# Print information about a proc. -# -# Arguments: -# pattern pattern of the proc's to get info for; default is *. -# -# Results: -# A human readable printout of info. - -proc ::profiler::print {{pattern *}} { - variable callCount - variable compileTime - variable totalRuntime - variable descendantTime - variable descendants - variable statTime - variable callers - - set result "" - foreach name [lsort [array names callCount $pattern]] { - set avgRuntime 0 - set sigmaRuntime 0 - set covRuntime 0 - set avgDesTime 0 - if { $callCount($name) > 0 } { - foreach {m s c} [eval ::profiler::stats $statTime($name)] { break } - set avgRuntime $m - set sigmaRuntime $s - set covRuntime $c - set avgDesTime \ - [expr {$descendantTime($name)/$callCount($name)}] - } - - append result "Profiling information for $name\n" - append result "[string repeat = 60]\n" - append result " Total calls: $callCount($name)\n" - if { !$callCount($name) } { - append result "\n" - continue - } - append result " Caller distribution:\n" - set i [expr {[string length $name] + 1}] - foreach index [lsort [array names callers $name,*]] { - append result " [string range $index $i end]: $callers($index)\n" - } - append result " Compile time: $compileTime($name)\n" - append result " Total runtime: $totalRuntime($name)\n" - append result " Average runtime: $avgRuntime\n" - append result " Runtime StDev: $sigmaRuntime\n" - append result " Runtime cov(%): $covRuntime\n" - append result " Total descendant time: $descendantTime($name)\n" - append result "Average descendant time: $avgDesTime\n" - append result "Descendants:\n" - if { !$descendantTime($name) } { - append result " none\n" - } - foreach index [lsort [array names descendants $name,*]] { - append result " [string range $index $i end]: \ - $descendants($index)\n" - } - append result "\n" - } - return $result -} - -# ::profiler::dump -- -# -# Dump out the information for a proc in a big blob. -# -# Arguments: -# pattern pattern of the proc's to lookup; default is *. -# -# Results: -# data data about the proc's. - -proc ::profiler::dump {{pattern *}} { - variable callCount - variable compileTime - variable totalRuntime - variable callers - variable descendantTime - variable descendants - variable statTime - - set result "" - foreach name [lsort [array names callCount $pattern]] { - set i [expr {[string length $name] + 1}] - catch {unset thisCallers} - foreach index [lsort [array names callers $name,*]] { - set thisCallers([string range $index $i end]) $callers($index) - } - set avgRuntime 0 - set sigmaRuntime 0 - set covRuntime 0 - set avgDesTime 0 - if { $callCount($name) > 0 } { - foreach {m s c} [eval ::profiler::stats $statTime($name)] { break } - set avgRuntime $m - set sigmaRuntime $s - set covRuntime $c - set avgDesTime \ - [expr {$descendantTime($name)/$callCount($name)}] - } - set descendantList [list ] - foreach index [lsort [array names descendants $name,*]] { - lappend descendantList [string range $index $i end] - } - lappend result $name [list callCount $callCount($name) \ - callerDist [array get thisCallers] \ - compileTime $compileTime($name) \ - totalRuntime $totalRuntime($name) \ - averageRuntime $avgRuntime \ - stddevRuntime $sigmaRuntime \ - covpercentRuntime $covRuntime \ - descendantTime $descendantTime($name) \ - averageDescendantTime $avgDesTime \ - descendants $descendantList] - } - return $result -} - -# ::profiler::sortFunctions -- -# -# Return a list of functions sorted by a particular field and the -# value of that field. -# -# Arguments: -# field field to sort by -# -# Results: -# slist sorted list of lists, sorted by the field in question. - -proc ::profiler::sortFunctions {{field ""}} { - switch -glob -- $field { - "calls" { - upvar ::profiler::callCount data - } - "compileTime" { - upvar ::profiler::compileTime data - } - "totalRuntime" { - upvar ::profiler::totalRuntime data - } - "avgRuntime" - - "averageRuntime" { - variable callCount - variable totalRuntime - foreach fxn [array names callCount] { - if { $callCount($fxn) > 1 } { - set data($fxn) \ - [expr {$totalRuntime($fxn)/($callCount($fxn) - 1)}] - } - } - } - "exclusiveRuntime" { - variable totalRuntime - variable descendantTime - foreach fxn [array names totalRuntime] { - set data($fxn) \ - [expr {$totalRuntime($fxn) - $descendantTime($fxn)}] - } - } - "avgExclusiveRuntime" { - variable totalRuntime - variable callCount - variable descendantTime - foreach fxn [array names totalRuntime] { - if { $callCount($fxn) } { - set data($fxn) \ - [expr {($totalRuntime($fxn) - \ - $descendantTime($fxn)) / $callCount($fxn)}] - } - } - } - "nonCompileTime" { - variable compileTime - variable totalRuntime - foreach fxn [array names totalRuntime] { - set data($fxn) [expr {$totalRuntime($fxn)-$compileTime($fxn)}] - } - } - default { - error "unknown statistic \"$field\": should be calls,\ - compileTime, exclusiveRuntime, nonCompileTime,\ - totalRuntime, avgExclusiveRuntime, or avgRuntime" - } - } - - set result [list ] - foreach fxn [array names data] { - lappend result [list $fxn $data($fxn)] - } - return [lsort -integer -index 1 $result] -} - -# ::profiler::reset -- -# -# Reset collected data for functions matching a given pattern. -# -# Arguments: -# pattern pattern of functions to reset; default is *. -# -# Results: -# None. - -proc ::profiler::reset {{pattern *}} { - variable callCount - variable compileTime - variable totalRuntime - variable callers - variable statTime - - foreach name [array names callCount $pattern] { - set callCount($name) 0 - set compileTime($name) 0 - set totalRuntime($name) 0 - set statTime($name) {} - foreach caller [array names callers $name,*] { - unset callers($caller) - } - } - return -} - -# ::profiler::suspend -- -# -# Suspend the profiler. -# -# Arguments: -# pattern pattern of functions to suspend; default is *. -# -# Results: -# None. Resets the `enabled($name)' variable to 0 -# to suspend profiling - -proc ::profiler::suspend {{pattern *}} { - variable callCount - variable enabled - variable paused - - set paused 1 - foreach name [array names callCount $pattern] { - set enabled($name) 0 - } - - return -} - -# ::profiler::resume -- -# -# Resume the profiler, after it has been suspended. -# -# Arguments: -# pattern pattern of functions to suspend; default is *. -# -# Results: -# None. Sets the `enabled($name)' variable to 1 -# so as to enable the profiler. - -proc ::profiler::resume {{pattern *}} { - variable callCount - variable enabled - variable paused - - set paused 0 - foreach name [array names callCount $pattern] { - set enabled($name) 1 - } - - return -} - DELETED modules/profiler/profiler.test Index: modules/profiler/profiler.test ================================================================== --- modules/profiler/profiler.test +++ /dev/null @@ -1,397 +0,0 @@ -# Profiler tests. -# -# Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 1998-2000 by Ajuba Solutions. -# All rights reserved. -# -# RCS: @(#) $Id: profiler.test,v 1.11 2003/04/14 07:08:36 andreas_kupries Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -# This constraint restricts certain tests to run on tcl8.3 version only -if {[package vsatisfies [package provide tcltest] 2.0]} { - # tcltest2.0+ has an API to specify a test constraint - ::tcltest::testConstraint tcl8.3only \ - [expr {![package vsatisfies [package provide Tcl] 8.4]}] -} else { - # In tcltest1.0, a global variable needs to be set directly. - set ::tcltest::testConstraints(tcl8.3only) \ - [expr {![package vsatisfies [package provide Tcl] 8.4]}] -} - -# Add the test script dir to the auto_path, so that we can package require -# profiler -set auto_path [linsert $auto_path 0 [file dirname [info script]]] - -test profiler-1.0 {profiler::init redirects the proc command} { - set c [interp create] - interp alias $c parentSet {} set - set result [$c eval { - set auto_path [parentSet auto_path] - package require profiler - profiler::init - list [interp alias {} proc] [info commands ::_oldProc] - }] - interp delete $c - set result -} [list ::profiler::profProc ::_oldProc] - -test profiler-2.0 {profiler creates two wrapper proc and real proc} {tcl8.3only} { - set c [interp create] - interp alias $c parentSet {} set - set result [$c eval { - set auto_path [parentSet auto_path] - package require profiler - profiler::init - proc foo {} { - puts "foo!" - } - list [info commands foo] [info commands fooORIG] - }] - interp delete $c - set result -} [list foo fooORIG] -test profiler-2.1 {profiler creates procs in correct scope} {tcl8.3only} { - set c [interp create] - interp alias $c parentSet {} set - set result [$c eval { - set auto_path [parentSet auto_path] - package require profiler - profiler::init - namespace eval foo {} - proc ::foo::foo {} { - puts "foo!" - } - list [info commands ::foo::foo] [info commands ::foo::fooORIG] - }] - interp delete $c - set result -} [list ::foo::foo ::foo::fooORIG] -test profiler-2.2 {profiler creates procs in correct scope} {tcl8.3only} { - set c [interp create] - interp alias $c parentSet {} set - set result [$c eval { - set auto_path [parentSet auto_path] - package require profiler - profiler::init - namespace eval foo { - proc foo {} { - puts "foo!" - } - } - list [info commands ::foo::foo] [info commands ::foo::fooORIG] - }] - interp delete $c - set result -} [list ::foo::foo ::foo::fooORIG] -test profiler-2.3 {profiler creates procs in correct scope} {tcl8.3only} { - set c [interp create] - interp alias $c parentSet {} set - set result [$c eval { - set auto_path [parentSet auto_path] - package require profiler - profiler::init - namespace eval foo { - namespace eval bar {} - proc bar::foo {} { - puts "foo!" - } - } - list [info commands ::foo::bar::foo] \ - [info commands ::foo::bar::fooORIG] - }] - interp delete $c - set result -} [list ::foo::bar::foo ::foo::bar::fooORIG] -test profiler-2.4 {profiler creates procs in correct scope} {tcl8.3only} { - set c [interp create] - interp alias $c parentSet {} set - set result [$c eval { - set auto_path [parentSet auto_path] - package require profiler - profiler::init - namespace eval foo { - proc ::foo {} { - puts "foo!" - } - } - list [info commands ::foo] \ - [info commands ::fooORIG] - }] - interp delete $c - set result -} [list ::foo ::fooORIG] - -test profiler-3.1 {profiler wrappers do profiling} { - set c [interp create] - interp alias $c parentSet {} set - set result [$c eval { - set auto_path [parentSet auto_path] - package require profiler - profiler::init - proc ::foo {} { - set foobar 0 - } - foo - foo - foo - foo - profiler::dump ::foo - }] - interp delete $c - array set bar $result - array set foo $bar(::foo) - list callCount $foo(callCount) callerDist $foo(callerDist) -} [list callCount 4 callerDist [list GLOBAL 4]] - -test profiler-4.1 {profiler::print produces nicer output than dump} { - set c [interp create] - interp alias $c parentSet {} set - set result [$c eval { - set auto_path [parentSet auto_path] - package require profiler - profiler::init - proc ::foo {} { - set foobar 0 - } - foo - foo - foo - foo - profiler::print ::foo - }] - interp delete $c - regsub {Compile time:.*} $result {} result - string trim $result -} "Profiling information for ::foo -============================================================ - Total calls: 4 - Caller distribution: - GLOBAL: 4" - -test profiler-5.1 {profiler respects suspend/resume} { - set c [interp create] - interp alias $c parentSet {} set - set result [$c eval { - set auto_path [parentSet auto_path] - package require profiler - profiler::init - proc ::foo {} { - set foobar 0 - } - foo - foo - foo - foo - profiler::suspend ::foo ; # note the qualification, has to match proc! - foo - foo - set res [profiler::print ::foo] - profiler::resume - set res - }] - interp delete $c - regsub {Compile time:.*} $result {} result - string trim $result -} "Profiling information for ::foo -============================================================ - Total calls: 4 - Caller distribution: - GLOBAL: 4" - -test profiler-6.1 {profiler handles functions with funny names} { - set c [interp create] - interp alias $c parentSet {} set - set result [$c eval { - set auto_path [parentSet auto_path] - package require profiler - profiler::init - proc ::foo(bar) {} { - set foobar 0 - } - foo(bar); foo(bar); foo(bar) - profiler::dump ::foo(bar) - }] - interp delete $c - array set bar $result - array set foo ${bar(::foo(bar))} - list callCount $foo(callCount) callerDist $foo(callerDist) -} [list callCount 3 callerDist [list GLOBAL 3]] - -test profiler-7.1 {sortFunctions} { - set c [interp create] - interp alias $c parentSet {} set - set result [$c eval { - set auto_path [parentSet auto_path] - package require profiler - profiler::init - catch {profiler::sortFunctions} res - set res - }] - interp delete $c - set result -} "unknown statistic \"\": should be calls, compileTime, exclusiveRuntime,\ -nonCompileTime, totalRuntime, avgExclusiveRuntime, or avgRuntime" -test profiler-7.2 {sortFunctions} { - set c [interp create] - interp alias $c parentSet {} set - set result [$c eval { - set auto_path [parentSet auto_path] - package require profiler - profiler::init - proc ::foo {} { - set foobar 0 - } - proc ::bar {} { - set foobar 1 - } - foo; foo; bar; - profiler::sortFunctions calls - }] - interp delete $c - set result -} [list [list ::bar 1] [list ::foo 2]] -test profiler-7.3 {sortFunctions} { - set c [interp create] - interp alias $c parentSet {} set - set result [$c eval { - set auto_path [parentSet auto_path] - package require profiler - profiler::init - proc ::foo {} { - set foobar 0 - } - proc ::bar {} { - set foobar 1 - } - foo; foo; bar; - catch {profiler::sortFunctions compileTime} - }] - interp delete $c - set result -} 0 -test profiler-7.4 {sortFunctions} { - set c [interp create] - interp alias $c parentSet {} set - set result [$c eval { - set auto_path [parentSet auto_path] - package require profiler - profiler::init - proc ::foo {} { - set foobar 0 - } - proc ::bar {} { - set foobar 1 - } - foo; foo; bar; - catch {profiler::sortFunctions totalRuntime} - }] - interp delete $c - set result -} 0 -test profiler-7.5 {sortFunctions} { - set c [interp create] - interp alias $c parentSet {} set - set result [$c eval { - set auto_path [parentSet auto_path] - package require profiler - profiler::init - proc ::foo {} { - set foobar 0 - } - proc ::bar {} { - set foobar 1 - } - foo; foo; bar; - catch {profiler::sortFunctions avgRuntime} - }] - interp delete $c - set result -} 0 - -test profiler-8.1 {reset} { - set c [interp create] - interp alias $c parentSet {} set - set result [$c eval { - set auto_path [parentSet auto_path] - package require profiler - profiler::init - proc ::foo {} { - set foobar 0 - } - proc ::bar {} { - set foobar 1 - } - foo; foo; bar; - profiler::reset - profiler::dump ::foo - }] - interp delete $c - array set bar $result - array set foo $bar(::foo) - list callCount $foo(callCount) callerDist $foo(callerDist) -} [list callCount 0 callerDist [list ]] -test profiler-8.2 {reset with a pattern} { - set c [interp create] - interp alias $c parentSet {} set - set result [$c eval { - set auto_path [parentSet auto_path] - package require profiler - profiler::init - proc ::foo {} { - set foobar 0 - } - proc ::bar {} { - set foobar 1 - } - foo; foo; bar; - profiler::reset ::foo - profiler::dump * - }] - interp delete $c - array set data $result - catch {unset foo} - catch {unset bar} - array set foo $data(::foo) - array set bar $data(::bar) - list [list callCount $foo(callCount) callerDist $foo(callerDist)] \ - [list callCount $bar(callCount) callerDist $bar(callerDist)] -} [list [list callCount 0 callerDist [list ]] \ - [list callCount 1 callerDist [list GLOBAL 1]]] - -test profiler-9.1 {dump for multiple functions} { - set c [interp create] - interp alias $c parentSet {} set - set result [$c eval { - set auto_path [parentSet auto_path] - package require profiler - profiler::init - proc ::foo {} { - set foobar 0 - } - proc ::bar {} { - set foobar 1 - } - foo; foo; bar; - profiler::dump * - }] - interp delete $c - array set data $result - catch {unset foo} - catch {unset bar} - array set foo $data(::foo) - array set bar $data(::bar) - list [list callCount $foo(callCount) callerDist $foo(callerDist)] \ - [list callCount $bar(callCount) callerDist $bar(callerDist)] -} [list [list callCount 2 callerDist [list GLOBAL 2]] \ - [list callCount 1 callerDist [list GLOBAL 1]]] - -catch {unset foo} -catch {unset bar} - -::tcltest::cleanupTests DELETED modules/report/ChangeLog Index: modules/report/ChangeLog ================================================================== --- modules/report/ChangeLog +++ /dev/null @@ -1,64 +0,0 @@ -2003-04-11 Andreas Kupries - - * report.tcl: - * report.man: - * pkgIndex.tcl: Set version of the package to to 0.3.1 - -2003-01-16 Andreas Kupries - - * report.man: More semantic markup, less visual one. - -2002-03-20 Andreas Kupries - - * report.n: - * report.man: Corrected example for "captionedtable". - -2002-03-15 Andreas Kupries - - * report.man: Added example of formatting a matrix using tabular - reports (See tcllib module "struct" too.). Fixes #530207. - -2002-02-28 Andreas Kupries - - * report.man: New file, manpage in doctools format. - -2002-02-01 Andreas Kupries - - * Version up to 0.3 to differentiate development from the - version in the tcllib 1.2 release. - - * report.tcl: - * report.test: Updated code and tests to cover all paths through the - code. - -2001-10-16 Andreas Kupries - - * report.n: - * report.tcl: - * pkgIndex.tcl: Version up to 0.2 - -2001-08-20 Andreas Kupries - - * report.test: Fixed broken error messages for 8.4. Using - [tcltest::getErrorMessage] now to get the correct message for - all versions of the core. Bug [440049] reported by Larry Virden. - -2001-07-10 Andreas Kupries - - * report.tcl: Frink 2.2 run, fixed dubious code. - -2001-06-21 Andreas Kupries - - * report.tcl: Fixed dubious code reported by frink. - -2001-06-19 Andreas Kupries - - * report.n: Fixed nroff trouble. - -2001-05-01 Andreas Kupries - - * Committed to CVS head at SF. - -2001-04-22 Andreas Kupries - - * New module for formatting matrices, reporting tabular data DELETED modules/report/pkgIndex.tcl Index: modules/report/pkgIndex.tcl ================================================================== --- modules/report/pkgIndex.tcl +++ /dev/null @@ -1,12 +0,0 @@ -# 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. - -if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded report 0.3.1 [list source [file join $dir report.tcl]] DELETED modules/report/report.man Index: modules/report/report.man ================================================================== --- modules/report/report.man +++ /dev/null @@ -1,472 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[manpage_begin report n 0.3.1] -[copyright {2002 Andreas Kupries }] -[moddesc {Matrix reports}] -[titledesc {Create and manipulate report objects}] -[require Tcl 8.2] -[require report [opt 0.3.1]] -[description] -[para] - -This package provides report objects which can be used by the -formatting methods of matrix objects to generate tabular reports of -the matrix in various forms. The report objects defined here break -each report down into three [sectref REGIONS] and ten classes of -[term lines] (various separator- and data-lines). See the following -section for more detailed explanations. - -[list_begin definitions] - -[call [cmd ::report::report] [arg reportName] [arg columns] [opt "[const style] [arg "style arg..."]"]] - -Creates a new report object for a report having [arg columns] columns -with an associated global Tcl command whose name is - -[arg reportName]. This command may be used to invoke various -configuration operations on the report. It has the following general -form: - -[list_begin definitions] - -[call [cmd reportName] [arg option] [opt [arg "arg arg ..."]]] - -[arg Option] and the [arg arg]s determine the exact behavior of the -command. See section [sectref {REPORT METHODS}] for more -explanations. If no [const style] is specified the report will use -the builtin style [const plain] as its default configuration. - -[list_end] - -[call [cmd ::report::defstyle] [arg "styleName arguments script"]] - -Defines the new style [arg styleName]. See section [sectref STYLES] -for more information. - -[call [cmd ::report::rmstyle] [arg styleName]] - -Deletes the style [arg styleName]. Trying to delete an unknown or -builtin style will result in an error. Beware, this command will not -check that there are no other styles depending on the deleted -one. Deleting a style which is still used by another style FOO will -result in a runtime error when FOO is applied to a newly instantiated -report. - -[call [cmd ::report::stylearguments] [arg styleName]] - -This introspection command returns the list of arguments associated -with the style [arg styleName]. - -[call [cmd ::report::stylebody] [arg styleName]] - -This introspection command returns the script associated with the -style [arg styleName]. - -[call [cmd ::report::styles]] - -This introspection command returns a list containing the names of all -styles known to the package at the time of the call. The order of the -names in the list reflects the order in which the styles were -created. In other words, the first item is the predefined style -[const plain], followed by the first style defined by the user, and -so on. - -[list_end] - -[section REGIONS] -[para] - -The three regions are the [term {top caption}], - -[term {data area}] and [term {bottom caption}]. These are, -roughly speaking, the title, the values to report and a title at the -bottom. The size of the caption regions can be specified by the user -as the number of rows they occupy in the matrix to format. The size of -the data area is specified implicitly. - -[section LINES] -[para] - -[sectref TEMPLATES] are associated with each of the ten line classes, -defining the formatting for this kind of line. The user is able to -enable and disable the separator lines at will, but not the data -lines. Their usage is solely determined by the number of rows -contained in the three regions. Data lines and all enabled separators -must have a template associated with them. - -[para] - -Note that the data-lines in a report and the rows in the matrix the -report was generated from are [emph not] in a 1:1 relationship if -any row in the matrix has a height greater than one. - -[para] - -The different kinds of lines and the codes used by the report methods -to address them are: - -[list_begin definitions] - - -[lst_item [const top]] - -The topmost line of a report. Separates the report from anything which -came before it. The user can enable the usage of this line at will. - -[lst_item [const topdatasep]] - -This line is used to separate the data rows in the top caption region, -if it contains more than one row and the user enabled its usage. - -[lst_item [const topcapsep]] - -This line is used to separate the top caption and data regions, if the -top caption is not empty and the user enabled its usage. - -[lst_item [const datasep]] - -This line is used to separate the data rows in the data region, if it -contains more than one row and the user enabled its usage. - -[lst_item [const botcapsep]] - -This line is used to separate the data and bottom caption regions, if -the bottom caption is not empty and the user enabled its usage. - -[lst_item [const botdatasep]] - -This line is used to separate the data rows in the bottom caption -region, if it contains more than one row and the user enabled its -usage. - -[lst_item [const bottom]] - -The bottommost line of a report. Separates the report from anything -which comes after it. The user can enable the usage of this line at -will. - -[lst_item [const topdata]] - -This line defines the format of data lines in the top caption region -of the report. - -[lst_item [const data]] - -This line defines the format of data lines in the data region of the -report. - -[lst_item [const botdata]] - -This line defines the format of data lines in the bottom caption -region of the report. - -[list_end] - -[section TEMPLATES] -[para] - -Each template is a list of strings used to format the line it is -associated with. For a report containing [var n] columns a template -for a data line has to contain "[var n]+1" items and a template for a -separator line "2*[var n]+1" items. - -[para] - -The items in a data template specify the strings used to separate the -column information. Together with the corresponding items in the -separator templates they form the vertical lines in the report. - -[para] - -[emph Note] that the corresponding items in all defined templates -have to be of equal length. This will be checked by the report -object. The first item defines the leftmost vertical line and the last -item defines the rightmost vertical line. The item at index [var k] -("1",...,"[var n]-2") separates the information in the columns - -"[var k]-1" and "[var k]". - -[para] - -The items in a separator template having an even-numbered index -("0","2",...) specify the column separators. The item at index -"2*[var k]" ("0","2",...,"2*[var n]") corresponds to the items at -index "[var k]" in the data templates. - -[para] - -The items in a separator template having an odd-numbered index -("1","3",...) specify the strings used to form the horizontal lines in -the separator lines. The item at index "2*[var k]+1" -("1","3",...,"2*[var n]+1") corresponds to column "[var k]". When -generating the horizontal lines the items are replicated to be at -least as long as the size of their column and then cut to the exact -size. - -[section STYLES] -[para] - -Styles are a way for the user of this package to define common -configurations for report objects and then use them later during the -actual instantiation of report objects. They are defined as tcl -scripts which when executed configure the report object into the -requested configuration. - -[para] - -The command to define styles is [cmd ::report::defstyle]. Its last -argument is the tcl [type script] performing the actual -reconfiguration of the report object to obtain the requested style. - -[para] - -In this script the names of all previously defined styles are -available as commands, as are all commands found in a safe interpreter -and the configuration methods of report objects. The latter implicitly -operate on the object currently executing the style script. The - -[var arguments] declared here are available in the [type script] as -variables. When calling the command of a previously declared style all -the arguments expected by it have to be defined in the call. - -[section {REPORT METHODS}] -[para] - -The following commands are possible for report objects: - -[list_begin definitions] - - -[call [arg reportName] [method destroy]] - -Destroys the report, including its storage space and associated -command. - -[call [arg reportName] [arg templatecode] [method disable]|[method enable]] - -Enables or disables the usage of the template addressed by the - -[arg templatecode]. Only the codes for separator lines are allowed -here. It is not possible to enable or disable data lines. - -[nl] - -Enabling a template causes the report to check all used templates for -inconsistencies in the definition of the vertical lines (See section -[sectref TEMPLATES]). - -[call [arg reportName] [arg templatecode] [method enabled]] - -Returns the whether the template addressed by the [arg templatecode] -is currently enabled or not. - -[call [arg reportName] [arg templatecode] [method get]] - -Returns the template currently associated with the kind of line -addressed by the [arg templatecode]. All known templatecodes are -allowed here. - -[call [arg reportName] [arg templatecode] [method set] [arg templatedata]] - -Sets the template associated with the kind of line addressed by the -[arg templatecode] to the new value in [arg templatedata]. See section -[sectref TEMPLATES] for constraints on the length of templates. - -[call [arg reportName] [method tcaption] [opt [arg size]]] - -Specifies the [arg size] of the top caption region as the number rows -it occupies in the matrix to be formatted. Only numbers greater than -or equal to zero are allowed. If no [arg size] is specified the -command will return the current size instead. - -[nl] - -Setting the size of the top caption to a value greater than zero -enables the corresponding data template and causes the report to check -all used templates for inconsistencies in the definition of the -vertical lines (See section [sectref TEMPLATES]). - -[call [arg reportName] [method bcaption] [arg size]] - -Specifies the [arg size] of the bottom caption region as the number -rows it occupies in the matrix to be formatted. Only numbers greater -than or equal to zero are allowed. If no [arg size] is specified the -command will return the current size instead. - -[nl] - -Setting the size of the bottom caption to a value greater than zero -enables the corresponding data template and causes the report to check -all used templates for inconsistencies in the definition of the -vertical lines (See section [sectref TEMPLATES]). - -[call [arg reportName] [cmd size] [arg column] [opt "[arg number]|[const dyn]"]] - -Specifies the size of the [arg column] in the output. The value -[const dyn] means that the columnwidth returned by the matrix to be -formatted for the specified column shall be used. The formatting of -the column is dynamic. If a fixed [arg number] is used instead of -[const dyn] it means that the column has a width of that many -characters (padding excluded). Only numbers greater than zero are -allowed here. - -[nl] - -If no size specification is given the command will return the current -size of the [arg column] instead. - -[call [arg reportName] [cmd sizes] [opt [arg size-list]]] - -This method allows the user to specify the sizes of all columns in one -call. Its argument is a list containing the sizes to associate with -the columns. The first item is associated with column 0, the next with -column 1, and so on. - -[nl] - -If no [arg size-list] is specified the command will return a list -containing the currently set sizes instead. - -[call [arg reportName] [cmd pad] [arg column] [opt "[const left]|[const right]|[const both] [opt [arg padstring]]"]] - -This method allows the user to specify padding on the left, right or -both sides of a [arg column]. If the [arg padstring] is not specified -it defaults to a single space character. [emph Note]: An alternative -way of specifying the padding is to use vertical separator strings -longer than one character in the templates (See section -[sectref TEMPLATES]). - -[nl] - -If no pad specification is given at all the command will return the -current state of padding for the column instead. This will be a list -containing two elements, the first element the left padding, the -second describing the right padding. - -[call [arg reportName] [cmd justify] [arg column] [opt [const left]|[const right]|[const center]]] - -Declares how the cell values for a [arg column] are filled into the -report given the specified size of a column in the report. - -[nl] - -For [const left] and [const right] justification a cell value -shorter than the width of the column is bound with its named edge to -the same edge of the column. The other side is filled with spaces. In -the case of [const center] the spaces are placed to both sides of the -value and the left number of spaces is at most one higher than the -right number of spaces. - -[nl] - -For a value longer than the width of the column the value is cut at -the named edge. This means for [const left] justification that the -[emph tail] (i.e. the [const right] part) of the value is made -visible in the output. For [const center] the value is cut at both -sides to fit into the column and the number of characters cut at the -left side of the value is at most one less than the number of -characters cut from the right side. - -[nl] - -If no justification was specified the command will return the current -justification for the column instead. - -[call [arg reportName] [cmd printmatrix] [arg matrix]] - -Formats the [arg matrix] according to the configuration of the report -and returns the resulting string. The matrix has to have the same -number of columns as the report. The matrix also has to have enough -rows so that the top and bottom caption regions do not overlap. The -data region is allowed to be empty. - -[call [arg reportName] [cmd printmatrix2channel] [arg "matrix chan"]] - -Formats the [arg matrix] according to the configuration of the report -and writes the result into the channel [arg chan]. The matrix has to -have the same number of columns as the report. The matrix also has to -have enough rows so that the top and bottom caption regions do not -overlap. The data region is allowed to be empty. - -[call [arg reportName] [cmd columns]] - -Returns the number of columns in the report. - -[list_end] - -[para] - -The methods [method size], [method pad] and [method justify] all take -a column index as their first argument. This index is allowed to use -all the forms of an index as accepted by the [cmd lindex] command. The -allowed range for indices is - - "0,...,[lb][var reportName] columns[rb]-1". - -[section EXAMPLES] -[para] - -Our examples define some generally useful report styles. - -[para] - -A simple table with lines surrounding all information and vertical -separators, but without internal horizontal separators. - -[para] - -[example { - ::report::defstyle simpletable {} { - data set [split "[string repeat "| " [columns]]|"] - top set [split "[string repeat "+ - " [columns]]+"] - bottom set [top get] - top enable - bottom enable - } -}] - -[para] - -An extension of a [cmd simpletable], see above, with a title area. - -[para] - -[example { - ::report::defstyle captionedtable {{n 1}} { - simpletable - topdata set [data get] - topcapsep set [top get] - topcapsep enable - tcaption $n - } -}] - -[para] - -Given the definitions above now an example which actually formats a -matrix into a tabular report. It assumes that the matrix actually -contains useful data. - -[para] - -[example { - % ::struct::matrix m - % # ... fill m with data, assume 5 columns - % ::report::report r 5 style captionedtable 1 - % r printmatrix m - +---+-------------------+-------+-------+--------+ - |000|VERSIONS: |2:8.4a3|1:8.4a3|1:8.4a3%| - +---+-------------------+-------+-------+--------+ - |001|CATCH return ok |7 |13 |53.85 | - |002|CATCH return error |68 |91 |74.73 | - |003|CATCH no catch used|7 |14 |50.00 | - |004|IF if true numeric |12 |33 |36.36 | - |005|IF elseif |15 |47 |31.91 | - | |true numeric | | | | - +---+-------------------+-------+-------+--------+ - % - % # alternate way of doing the above - % m format 2string r -}] - -[keywords matrix report table] -[manpage_end] DELETED modules/report/report.n Index: modules/report/report.n ================================================================== --- modules/report/report.n +++ /dev/null @@ -1,352 +0,0 @@ -'\" -'\" Copyright (c) 2001 by Andreas Kupries -'\" All rights reserved. -'\" -'\" RCS: @(#) $Id: report.n,v 1.7 2002/03/26 05:25:24 andreas_kupries Exp $ -'\" -.so man.macros -.TH report n 0.3 Report "Matrix reports" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -::report::report \- Create and manipulate report objects -.SH SYNOPSIS -\fBpackage require Tcl 8.2\fR -.sp -\fBpackage require report ?0.3?\fR -.sp -\fB::report::report\fR \fIreportName columns\fR ?\fBstyle\fR \fIstyle arg...\fR? -.sp -\fB::report::defstyle\fR \fIstyleName arguments script\fR -.sp -\fB::report::rmstyle\fR \fIstyleName\fR -.sp -\fB::report::stylearguments\fR \fIstyleName\fR -.sp -\fB::report::stylebody\fR \fIstyleName\fR -.sp -\fB::report::styles\fR -.sp -.BE -.SH DESCRIPTION -.PP -This package provides report objects which can be used by the -formatting methods of matrix objects to generate tabular reports of -the matrix in various forms. The report objects defined here break -each report down into three \fBregions\fR and ten classes of -\fBlines\fR (various separator- and data-lines). See the following -section for more detailed explanations. -.TP -\fB::report::report\fR \fIreportName columns\fR ?\fBstyle\fR \fIstyle -arg...\fR? Creates a new report object for a report having -\fIcolumns\fR columns with an associated global Tcl command whose name -is \fIreportName\fR. This command may be used to invoke various -configuration operations on the report. It has the following general -form: \fIreportName option \fR?\fIarg arg ...\fR? -.sp -\fIOption\fR and the \fIarg\fRs determine the exact behavior of the -command. See section \fBREPORT METHODS\fR for more explanations. If no -\fIstyle\fR is specified the report will use the builtin style -\fBplain\fR as its default configuration. -.TP -\fB::report::defstyle\fR \fIstyleName arguments script\fR -Defines the new style \fIstyleName\fR. See section \fBSTYLES\fR for -more information. -.TP -\fB::report::rmstyle\fR \fIstyleName\fR -Deletes the style \fIstyleName\fR. Trying to delete an unknown or -builtin style will result in an error. Beware, this command will not -check that there are no other styles depending on the deleted -one. Deleting a style which is still used by another style FOO will -result in a runtime error when FOO is applied to a newly instantiated -report. -.TP -\fB::report::stylearguments\fR \fIstyleName\fR -This introspection command returns the list of arguments associated with the -style \fIstyleName\fR. -.TP -\fB::report::stylebody\fR \fIstyleName\fR -This introspection command returns the script associated with the -style \fIstyleName\fR. -.TP -\fB::report::styles\fR -This introspection command returns a list containing the names of all -styles known to the package at the time of the call. The order of the -names in the list reflects the order in which the styles were -created. In other words, the first item is the predefined style -\fBplain\fR, followed by the first style defined by the user, and so -on. -.SH REGIONS -.PP -The three regions are the \fBtop caption\fR, \fBdata area\fR and -\fBbottom caption\fR. These are, roughly speaking, the title, the -values to report and a title at the bottom. The size of the caption -regions can be specified by the user as the number of rows they occupy -in the matrix to format. The size of the data area is specified -implicitly. -.SH LINES -.PP -Each of the ten line classes can have a \fBtemplate\fR (see section -below) associated with it defining the formatting for this kind of -line. The user is able to enable and disable the separator lines at -will, but not the data lines. Their usage is solely determined by the -number of rows contained in the three regions. Data lines and all -enabled separators must have a template associated with them. -.PP -Note that the data-lines in a report and the rows in the matrix the -report was generated from are \fBnot\fR in a 1:1 relationship if any -row in the matrix has a height greater than one. -.PP -The different kinds of lines and the codes used by the report methods -to address them are: -.TP -\fBtop\fR -The topmost line of a report. Separates the report from anything which -came before it. The user can enable the usage of this line at will. -.TP -\fBtopdatasep\fR -This line is used to separate the data rows in the top caption region, -if it contains more than one row and the user enabled its usage. -.TP -\fBtopcapsep\fR -This line is used to separate the top caption and data regions, if the -top caption is not empty and the user enabled its usage. -.TP -\fBdatasep\fR -This line is used to separate the data rows in the data region, if it -contains more than one row and the user enabled its usage. -.TP -\fBbotcapsep\fR -This line is used to separate the data and bottom caption regions, if -the bottom caption is not empty and the user enabled its usage. -.TP -\fBbotdatasep\fR -This line is used to separate the data rows in the bottom caption -region, if it contains more than one row and the user enabled its -usage. -.TP -\fBbottom\fR -The bottommost line of a report. Separates the report from anything -which comes after it. The user can enable the usage of this line at -will. -.TP -\fBtopdata\fR -This line defines the format of data lines in the top caption region -of the report. -.TP -\fBdata\fR -This line defines the format of data lines in the data region of the -report. -.TP -\fBbotdata\fR -This line defines the format of data lines in the bottom caption -region of the report. -.SH TEMPLATES -.PP -Each template is a list of strings used to format the line it is -associated with. For a report containing \fIn\fR columns a template -for a data line has to contain "\fIn\fR+1" items and a template for a -separator line "2*\fIn\fR+1" items. -.PP -The items in a data template specify the strings used to separate the -column information. Together with the corresponding items in the -separator templates they form the vertical lines in the -report. -.PP -\fBNote\fR that the corresponding items in all defined templates have -to be of equal length. This will be checked by the report object. The -first item defines the leftmost vertical line and the last item -defines the rightmost vertical line. The item at index \fIk\fR -("1",...,"\fIn\fR-2") separates the information in the columns -"\fIk\fR-1" and "\fIk\fR". -.PP -The items in a separator template having an even-numbered index -("0","2",...) specify the column separators. The item at index -"2*\fIk\fR" ("0","2",...,"2*\fIn\fR") corresponds to the items at -index "\fIk\fR" in the data templates. -.PP -The items in a separator template having an odd-numbered index -("1","3",...) specify the strings used to form the horizontal lines in -the separator lines. The item at index "2*\fIk\fR+1" -("1","3",...,"2*\fIn\fR+1") corresponds to column "\fIk\fR". When -generating the horizontal lines the items are replicated to be at -least as long as the size of their column and then cut to the exact -size. -.SH STYLES -.PP -Styles are a way for the user of this package to define common -configurations for report objects and then use them later during the -actual instantiation of report objects. They are defined as tcl -scripts which when executed configure the report object into the -requested configuration. -.PP -The command to define styles is \fB::report::defstyle\fR. Its last -argument is the tcl \fIscript\fR performing the actual reconfiguration -of the report object to obtain the requested style. -.PP -In this script the names of all previously defined styles are -available as commands, as are all commands found in a safe interpreter -and the configuration methods of report objects. The latter implicitly -operate on the object currently executing the style script. The -\fIarguments\fR declared here are available in the \fIscript\fR as -variables. When calling the command of a previously declared style all -the arguments expected by it have to be defined in the call. -.SH REPORT METHODS -.PP -The following commands are possible for report objects: -.TP -\fIreportName\fR \fBdestroy\fR -Destroys the report, including its storage space and associated -command. -.TP -\fIreportName\fR \fItemplatecode\fR \fBdisable\fR|\fBenable\fR -Enables or disables the usage of the template addressed by the -\fItemplatecode\fR. Only the codes for separator lines are allowed -here. It is not possible to enable or disable data lines. -.sp -Enabling a template causes the report to check all used templates for -inconsistencies in the definition of the vertical lines (See section -\fBTEMPLATES\fR). -.TP -\fIreportName\fR \fItemplatecode\fR \fBenabled\fR -Returns the whether the template addressed by the \fItemplatecode\fR is -currently enabled or not. -.TP -\fIreportName\fR \fItemplatecode\fR \fBget\fR -Returns the template currently associated with the kind of line -addressed by the \fItemplatecode\fR. All known templatecodes are -allowed here. -.TP -\fIreportName\fR \fItemplatecode\fR \fBset\fR \fItemplatedata\fR -Sets the template associated with the kind of line addressed by the -\fItemplatecode\fR to the new value in \fItemplatedata\fR. See section -\fBTEMPLATES\fR for constraints on the length of templates. -.TP -\fIreportName\fR \fBtcaption\fR ?\fIsize\fR? -Specifies the \fIsize\fR of the top caption region as the number rows -it occupies in the matrix to be formatted. Only numbers greater than -or equal to zero are allowed. If no \fIsize\fR is specified the -command will return the current size instead. -.sp -Setting the size of the top caption to a value greater than zero -enables the corresponding data template and causes the report to check -all used templates for inconsistencies in the definition of the -vertical lines (See section \fBTEMPLATES\fR). -.TP -\fIreportName\fR \fBbcaption\fR \fIsize\fR -Specifies the \fIsize\fR of the bottom caption region as the number -rows it occupies in the matrix to be formatted. Only numbers greater -than or equal to zero are allowed. If no \fIsize\fR is specified the -command will return the current size instead. -.sp -Setting the size of the bottom caption to a value greater than zero -enables the corresponding data template and causes the report to check -all used templates for inconsistencies in the definition of the -vertical lines (See section \fBTEMPLATES\fR). -.TP -\fIreportName\fR \fBsize\fR \fIcolumn\fR ?\fInumber\fR|\fBdyn\fR? -Specifies the size of the \fIcolumn\fR in the output. The value -\fBdyn\fR means that the columnwidth returned by the matrix to be -formatted for the specified column shall be used. The formatting of -the column is "dynamic". If a fixed \fInumber\fR is used instead of -\fBdyn\fR it means that the column has a width of that many characters -(padding excluded). Only numbers greater than zero are allowed here. -.sp -If no size specification is given the command will return the current -size of the \fIcolumn\fR instead. -.TP -\fIreportName\fR \fBsizes\fR ?\fIsize-list\fR? -This method allows the user to specify the sizes of all columns in one -call. Its argument is a list containing the sizes to associate with -the columns. The first item is associated with column 0, the next with -column 1, and so on. -.sp -If no \fIsize-list\fR is specified the command will return a list -containing the currently set sizes instead. -.TP -\fIreportName\fR \fBpad\fR \fIcolumn\fR ?\fBleft\fR|\fBright\fR|\fBboth\fR ?\fIpadstring\fR?? -This method allows the user to specify padding on the left, right or -both sides of a \fIcolumn\fR. If the \fIpadstring\fR is not specified -it defaults to a single space character. \fBNote\fR: An alternative -way of specifying the padding is to use vertical separator strings -longer than one character in the templates (See section -\fBTEMPLATES\fR). -.sp -If no pad specification is given at all the command will return the -current state of padding for the column instead. This will be a list -containing two elements, the first element the left padding, the -second describing the right padding. -.TP -\fIreportName\fR \fBjustify\fR \fIcolumn\fR ?\fBleft\fR|\fBright\fR|\fBcenter\fR? -Declares how the cell values for a \fIcolumn\fR are filled into the -report given the specified size of a column in the report. -.sp -For \fBleft\fR and \fBright\fR justification a cell value shorter than -the width of the column is bound with its named edge to the same edge -of the column. The other side is filled with spaces. In the case of -\fBcenter\fR the spaces are placed to both sides of the value and the -left number of spaces is at most one higher than the right number of -spaces. -.sp -For a value longer than the width of the column the value is cut at -the named edge. This means for \fBleft\fR justification that the -\fBtail\fR (i.e. the \fBright\fR part) of the value is made visible in -the output. For \fBcenter\fR the value is cut at both sides to fit -into the column and the number of characters cut at the left side of -the value is at most one less than the number of characters cut from -the right side. -.sp -If no justification was specified the command will return the -current justification for the column instead. -.TP -\fIreportName\fR \fBprintmatrix\fR \fImatrix\fR -Formats the \fImatrix\fR according to the configuration of the report -and returns the resulting string. The matrix has to have the same -number of columns as the report. The matrix also has to have enough -rows so that the top and bottom caption regions do not overlap. The -data region is allowed to be empty. -.TP -\fIreportName\fR \fBprintmatrix2channel\fR \fImatrix chan\fR -Formats the \fImatrix\fR according to the configuration of the report -and writes the result into the channel \fIchan\fR. The matrix has to -have the same number of columns as the report. The matrix also has to -have enough rows so that the top and bottom caption regions do not -overlap. The data region is allowed to be empty. -.TP -\fIreportName\fR \fBcolumns\fR -Returns the number of columns in the report. -.PP -The methods \fBsize\fR, \fBpad\fR and \fBjustify\fR all take a column -index as their first argument. This index is allowed to use all the -forms of an index as accepted by the \fBlindex\fR command. The allowed -range for indices is "0,...,[\fIreportName\fR columns]-1". -.SH EXAMPLES -.PP -Our examples define some generally useful report styles. -.PP -A simple table with lines surrounding all information and vertical -separators, but without internal horizontal separators. -.PP -.CS -::report::defstyle simpletable {} { - data set [split "[string repeat "| " [columns]]|"] - top set [split "[string repeat "+ - " [columns]]+"] - bottom set [top get] - top enable - bottom enable -} -.CE -.PP -An extension of a \fBsimpletable\fR, see above, with a title area. -.PP -.CS -::report::defstyle captionedtable {{n 1}} { - simpletable - topdata set [data get] - topcapsep set [top get] - topcapsep enable - tcaption $n -} -.CE -.SH KEYWORDS -matrix, report, table DELETED modules/report/report.tcl Index: modules/report/report.tcl ================================================================== --- modules/report/report.tcl +++ /dev/null @@ -1,1378 +0,0 @@ -# report.tcl -- -# -# Implementation of report objects for Tcl. -# -# Copyright (c) 2001 by Andreas Kupries -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: report.tcl,v 1.7 2003/04/11 20:15:11 andreas_kupries Exp $ - -package require Tcl 8.2 -package provide report 0.3.1 - -namespace eval ::report { - # Data storage in the report module - # ------------------------------- - # - # One namespace per object, containing - # 1) An array mapping from template codes to templates - # 2) An array mapping from template codes and columns to horizontal template items - # 3) An array mapping from template codes and columns to vertical template items - # 4) ... deleted, local to formatting - # 5) An array mapping from columns to left padding - # 6) An array mapping from columns to right padding - # 7) An array mapping from columns to column size - # 8) An array mapping from columns to justification - # 9) A scalar containing the number of columns in the report. - # 10) An array mapping from template codes to enabledness - # 11) A scalar containing the size of the top caption - # 12) A scalar containing the size of the bottom caption - # - # 1 - template 5 - lpad 9 - columns - # 2 - hTemplate 6 - rpad 10 - enabled - # 3 - vTemplate 7 - csize 11 - tcaption - # 4 - fullHTemplate 8 - cjust 12 - bcaption - - # commands is the list of subcommands recognized by the report - variable commands [list \ - "bcaption" \ - "botcapsep" \ - "botdata" \ - "botdatasep" \ - "bottom" \ - "columns" \ - "data" \ - "datasep" \ - "justify" \ - "pad" \ - "printmatrix" \ - "printmatrix2channel" \ - "size" \ - "sizes" \ - "tcaption" \ - "top" \ - "topcapsep" \ - "topdata" \ - "topdatasep" - ] - - # Only export the toplevel commands - namespace export report defstyle rmstyle stylearguments stylebody - - # Global data, style definitions - - variable styles [list plain] - variable styleargs - variable stylebody - - array set styleargs {plain {}} - array set stylebody {plain {}} - - # Global data, template codes, for easy checking - - variable tcode - array set tcode { - topdata 0 data 0 - botdata 0 top 1 - topdatasep 1 topcapsep 1 - datasep 1 botcapsep 1 - botdatasep 1 bottom 1 - } -} - -# ::report::report -- -# -# Create a new report with a given name -# -# Arguments: -# name Optional name of the report; if null or not given, generate one. -# -# Results: -# name Name of the report created - -proc ::report::report {name columns args} { - variable styleargs - - if { [llength [info commands ::$name]] } { - error "command \"$name\" already exists, unable to create report" - } - if {![string is integer $columns]} { - return -code error "columns: expected integer greater than zero, got \"$columns\"" - } elseif {$columns <= 0} { - return -code error "columns: expected integer greater than zero, got \"$columns\"" - } - - set styleName "" - switch -exact -- [llength $args] { - 0 {# No style was specied. This is OK} - 1 { - # We possibly got the "style" keyword, but everything behind is missing - return -code error "wrong # args: report name columns ?\"style\" styleName ?arg...??" - } - default { - # Break tail apart, check for correct keyword, ensure that style is known too. - # Don't forget to check the actual against the formal arguments. - - foreach {dummy styleName} $args break - set args [lrange $args 2 end] - - if {![string equal $dummy style]} { - return -code error "wrong # args: report name columns ?\"style\" styleName ?arg...??" - } - if {![info exists styleargs($styleName)]} { - return -code error "style \"$styleName\" is not known" - } - CheckStyleArguments $styleName $args - } - } - - # The arguments seem to be ok, setup the namespace for the object - # and configure it to style "plain". - - namespace eval ::report::report$name "variable columns $columns" - namespace eval ::report::report$name { - variable tcaption 0 - variable bcaption 0 - variable template - variable enabled - variable hTemplate - variable vTemplate - variable lpad - variable rpad - variable csize - variable cjust - - variable t - variable i - variable dt [list] - variable st [list] - for {set i 0} {$i < $columns} {incr i} { - set lpad($i) "" - set rpad($i) "" - set csize($i) dyn - set cjust($i) left - lappend dt {} - lappend st {} {} - } - lappend dt {} - lappend st {} - - foreach t { - topdata data botdata - } { - set enabled($t) 1 - set template($t) $dt - for {set i 0} {$i <= $columns} {incr i} { - set vTemplate($t,$i) {} - } - } - foreach t { - top topdatasep topcapsep - datasep - botcapsep botdatasep bottom - } { - set enabled($t) 0 - set template($t) $st - for {set i 0} {$i < $columns} {incr i} { - set hTemplate($t,$i) {} - } - for {set i 0} {$i <= $columns} {incr i} { - set vTemplate($t,$i) {} - } - } - - unset t i dt st - } - - # Create the command to manipulate the report - # $name -> ::report::ReportProc $name - interp alias {} ::$name {} ::report::ReportProc $name - - # If a style was specified execute it now, before the oobject is - # handed back to the user. - - if {$styleName != {}} { - ExecuteStyle $name $styleName $args - } - - return $name -} - -# ::report::defstyle -- -# -# Defines a new named style, with arguments and defining script. -# -# Arguments: -# styleName Name of the new style. -# arguments Formal arguments of the style, some format as for proc. -# body The script actually defining the style. -# -# Results: -# None. - -proc ::report::defstyle {styleName arguments body} { - variable styleargs - variable stylebody - variable styles - - if {[info exists styleargs($styleName)]} { - return -code error "Cannot create style \"$styleName\", already exists" - } - - # Check the formal arguments - # 1. Arguments without default may not follow an argument with a - # default. The special "args" is no exception! - # 2. Compute the minimal number of arguments required by the proc. - - set min 0 - set def 0 - set ca 0 - - foreach v $arguments { - switch -- [llength $v] { - 1 { - if {$def} { - return -code error \ - "Found argument without default after arguments having defaults" - } - incr min - } - 2 { - set def 1 - } - default { - error "Illegal length of value \"$v\"" - } - } - } - if {[string equal args [lindex $arguments end]]} { - # Correct requirements if we have a catch-all at the end. - incr min -1 - set ca 1 - } - - # Now we are allowed to extend the internal database - - set styleargs($styleName) [list $min $ca $arguments] - set stylebody($styleName) $body - lappend styles $styleName - return -} - -# ::report::rmstyle -- -# -# Deletes the specified style. -# -# Arguments: -# styleName Name of the style to destroy. -# -# Results: -# None. - -proc ::report::rmstyle {styleName} { - variable styleargs - variable stylebody - variable styles - - if {![info exists styleargs($styleName)]} { - return -code error "cannot delete unknown style \"$styleName\"" - } - if {[string equal $styleName plain]} { - return -code error {cannot delete builtin style "plain"} - } - - unset styleargs($styleName) - unset stylebody($styleName) - - set pos [lsearch -exact $styles $styleName] - set styles [lreplace $styles $pos $pos] - return -} - -# ::report::_stylearguments -- -# -# Introspection, returns the list of formal arguments of the -# specified style. -# -# Arguments: -# styleName Name of the style to query. -# -# Results: -# A list containing the formal argument of the style - -proc ::report::stylearguments {styleName} { - variable styleargs - if {![info exists styleargs($styleName)]} { - return -code error "style \"$styleName\" is not known" - } - return [lindex $styleargs($styleName) 2] -} - -# ::report::_stylebody -- -# -# Introspection, returns the body/script of the -# specified style. -# -# Arguments: -# styleName Name of the style to query. -# -# Results: -# A script, the body of the style. - -proc ::report::stylebody {styleName} { - variable stylebody - if {![info exists stylebody($styleName)]} { - return -code error "style \"$styleName\" is not known" - } - return $stylebody($styleName) -} - -# ::report::_styles -- -# -# Returns alist containing the names of all known styles. -# -# Arguments: -# None. -# -# Results: -# A list containing the names of all known styles - -proc ::report::styles {} { - variable styles - return $styles -} - -########################## -# Private functions follow - -# ::report::CheckStyleArguments -- -# -# Internal helper. Used to check actual arguments of a style against the formal ones. -# -# Arguments: -# styleName Name of the style in question -# arguments Actual arguments for the style. -# -# Results: -# None, or an error in case of problems. - -proc ::report::CheckStyleArguments {styleName arguments} { - variable styleargs - - # Match formal and actual arguments, error out in case of problems. - foreach {min catchall formal} $styleargs($styleName) break - - if {[llength $arguments] < $min} { - # Determine the name of the first formal parameter which did not get a value. - set firstmissing [lindex $formal [llength $arguments]] - return -code error "no value given for parameter \"$firstmissing\" to style \"$styleName\"" - } elseif {[llength $arguments] > $min} { - if {!$catchall && ([llength $arguments] > [llength $formal])} { - # More actual arguments than formals, without catch-all argument, error - return -code error "called style \"$styleName\" with too many arguments" - } - } -} - -# ::report::ExecuteStyle -- -# -# Internal helper. Applies a named style to the specified report object. -# -# Arguments: -# name Name of the report the style is applied to. -# styleName Name of the style to apply -# arguments Actual arguments for the style. -# -# Results: -# None. - -proc ::report::ExecuteStyle {name styleName arguments} { - variable styleargs - variable stylebody - variable styles - variable commands - - CheckStyleArguments $styleName $arguments - foreach {min catchall formal} $styleargs($styleName) break - - array set a {} - - if {([llength $arguments] > $min) && $catchall} { - # #min = number of formal arguments - 1 - set a(args) [lrange $arguments $min end] - set formal [lrange $formal 0 end-1] - incr min -1 - set arguments [lrange $arguments 0 $min] - - # arguments and formal are now of equal length and we also - # know that there are no arguments having a default value. - foreach v $formal aval $arguments { - set a($v) $aval - } - } - - # More arguments than minimally required, but no more than formal - # arguments! Proceed to standard matching: Go through the actual - # values and associate them with a formal argument. Then fill the - # remaining formal arguments with their default values. - - foreach aval $arguments { - set v [lindex $formal 0] - set formal [lrange $formal 1 end] - if {[llength $v] > 1} {set v [lindex $v 0]} - set a($v) $aval - } - - foreach vd $formal { - foreach {var default} $vd { - set a($var) $default - } - } - - # Create and initialize a safe interpreter, execute the style and - # then break everything down again. - - set ip [interp create -safe] - - # -- Report methods -- - - foreach m $commands { - # safe-ip method --> here report method - interp alias $ip $m {} $name $m - } - - # -- Styles defined before this one -- - - foreach s $styles { - if {[string equal $s $styleName]} {break} - interp alias $ip $s {} ::report::LinkExec $name $s - } - - # -- Arguments as variables -- - - foreach {var val} [array get a] { - $ip eval [list set $var $val] - } - - # Finally execute / apply the style. - - $ip eval $stylebody($styleName) - interp delete $ip - return -} - -# ::report::_LinkExec -- -# -# Internal helper. Used for application of styles from within -# another style script. Collects the formal arguments into the -# one list which is expected by "ExecuteStyle". -# -# Arguments: -# name Name of the report the style is applied to. -# styleName Name of the style to apply -# args Actual arguments for the style. -# -# Results: -# None. - -proc ::report::LinkExec {name styleName args} { - ExecuteStyle $name $styleName $args -} - -# ::report::ReportProc -- -# -# Command that processes all report object commands. -# -# Arguments: -# name Name of the report object to manipulate. -# cmd Subcommand to invoke. -# args Arguments for subcommand. -# -# Results: -# Varies based on command to perform - -proc ::report::ReportProc {name {cmd ""} args} { - variable tcode - - # Do minimal args checks here - if { [llength [info level 0]] == 2 } { - error "wrong # args: should be \"$name option ?arg arg ...?\"" - } - - # Split the args into command and args components - - if {[info exists tcode($cmd)]} { - # Template codes are a bit special - eval [list ::report::_tAction $name $cmd] $args - } else { - if { [llength [info commands ::report::_$cmd]] == 0 } { - variable commands - set optlist [join $commands ", "] - set optlist [linsert $optlist "end-1" "or"] - error "bad option \"$cmd\": must be $optlist" - } - eval [list ::report::_$cmd $name] $args - } -} - -# ::report::CheckColumn -- -# -# Helper to check and transform column indices. Returns the -# absolute index number belonging to the specified -# index. Rejects indices out of the valid range of columns. -# -# Arguments: -# columns Number of columns -# column The incoming index to check and transform -# -# Results: -# The absolute index to the column - -proc ::report::CheckColumn {columns column} { - switch -regex -- $column { - {end-[0-9]+} { - regsub -- {end-} $column {} column - set cc [expr {$columns - 1 - $column}] - if {($cc < 0) || ($cc >= $columns)} { - return -code error "column: index \"end-$column\" out of range" - } - return $cc - } - end { - if {$columns <= 0} { - return -code error "column: index \"$column\" out of range" - } - return [expr {$columns - 1}] - } - {[0-9]+} { - if {($column < 0) || ($column >= $columns)} { - return -code error "column: index \"$column\" out of range" - } - return $column - } - default { - return -code error "column: syntax error in index \"$column\"" - } - } -} - -# ::report::CheckVerticals -- -# -# Internal helper. Used to check the consistency of all active -# templates with respect to the generated vertical separators -# (Same length). -# -# Arguments: -# name Name of the report object to check. -# -# Results: -# None. - -proc ::report::CheckVerticals {name} { - upvar ::report::report${name}::vTemplate vTemplate - upvar ::report::report${name}::enabled enabled - upvar ::report::report${name}::columns columns - upvar ::report::report${name}::tcaption tcaption - upvar ::report::report${name}::bcaption bcaption - - for {set c 0} {$c <= $columns} {incr c} { - # Collect all lengths for a column in a list, sort that and - # compare first against last element. If they are not equal we - # have found an inconsistent definition. - - set res [list] - lappend res [string length $vTemplate(data,$c)] - - if {$tcaption > 0} { - lappend res [string length $vTemplate(topdata,$c)] - if {($tcaption > 1) && $enabled(topdatasep)} { - lappend res [string length $vTemplate(topdatasep,$c)] - } - if {$enabled(topcapsep)} { - lappend res [string length $vTemplate(topcapsep,$c)] - } - } - if {$bcaption > 0} { - lappend res [string length $vTemplate(botdata,$c)] - if {($bcaption > 1) && $enabled(botdatasep)} { - lappend res [string length $vTemplate(botdatasep,$c)] - } - if {$enabled(botcapsep)} { - lappend res [string length $vTemplate(botcapsep,$c)] - } - } - foreach t {top datasep bottom} { - if {$enabled($t)} { - lappend res [string length $vTemplate($t,$c)] - } - } - - set res [lsort $res] - - if {[lindex $res 0] != [lindex $res end]} { - return -code error "inconsistent verticals in report" - } - } -} - -# ::report::_tAction -- -# -# Implements the actions on templates (set, get, enable, disable, enabled) -# -# Arguments: -# name Name of the report object. -# template Name of the template to query or manipulate. -# cmd The action applied to the template -# args Additional arguments per action, see documentation. -# -# Results: -# None. - -proc ::report::_tAction {name template cmd args} { - # When coming in here we know that $template contains a legal - # template code. No need to check again. We need 'tcode' - # nevertheless to distinguish between separator (1) and data - # templates (0). - - variable tcode - - switch -exact -- $cmd { - set { - if {[llength $args] != 1} { - return -code error "Wrong # args: $name $template $cmd template" - } - set templval [lindex $args 0] - - upvar ::report::report${name}::columns columns - upvar ::report::report${name}::template tpl - upvar ::report::report${name}::hTemplate hTemplate - upvar ::report::report${name}::vTemplate vTemplate - upvar ::report::report${name}::enabled enabled - - if {$tcode($template)} { - # Separator template, expected size = 2*colums+1 - if {[llength $templval] > (2*$columns+1)} { - return -code error {template to long for number of columns in report} - } elseif {[llength $templval] < (2*$columns+1)} { - return -code error {template to short for number of columns in report} - } - - set tpl($template) $templval - - set even 1 - set c1 0 - set c2 0 - foreach item $templval { - if {$even} { - set vTemplate($template,$c1) $item - incr c1 - set even 0 - } else { - set hTemplate($template,$c2) $item - incr c2 - set even 1 - } - } - } else { - # Data template, expected size = columns+1 - if {[llength $templval] > ($columns+1)} { - return -code error {template to long for number of columns in report} - } elseif {[llength $templval] < ($columns+1)} { - return -code error {template to short for number of columns in report} - } - - set tpl($template) $templval - - set c 0 - foreach item $templval { - set vTemplate($template,$c) $item - incr c - } - } - if {$enabled($template)} { - # Perform checks for active separator templates and - # all data templates. - CheckVerticals $name - } - } - get - - enable - - disable - - enabled { - if {[llength $args] > 0} { - return -code error "Wrong # args: $name $template $cmd" - } - switch -exact -- $cmd { - get { - upvar ::report::report${name}::template tpl - return $tpl($template) - } - enable { - if {!$tcode($template)} { - # Data template, can't be enabled. - return -code error "Cannot enable data template \"$template\"" - } - - upvar ::report::report${name}::enabled enabled - - if {!$enabled($template)} { - set enabled($template) 1 - CheckVerticals $name - } - - } - disable { - if {!$tcode($template)} { - # Data template, can't be disabled. - return -code error "Cannot disable data template \"$template\"" - } - - upvar ::report::report${name}::enabled enabled - if {$enabled($template)} { - set enabled($template) 0 - } - } - enabled { - if {!$tcode($template)} { - # Data template, can't be disabled. - return -code error "Cannot query state of data template \"$template\"" - } - - upvar ::report::report${name}::enabled enabled - return $enabled($template) - } - default {error "Can't happen, panic, run, shout"} - } - } - default { - return -code error "Unknown template command \"$cmd\"" - } - } - return "" -} - -# ::report::_tcaption -- -# -# Sets or queries the size of the top caption region of the report. -# -# Arguments: -# name Name of the report object. -# size The new size, if not empty. Emptiness indicates that a -# query was requested -# -# Results: -# None, or the current size of the top caption region - -proc ::report::_tcaption {name {size {}}} { - upvar ::report::report${name}::tcaption tcaption - - if {$size == {}} { - return $tcaption - } - if {![string is integer $size]} { - return -code error "size: expected integer greater than or equal to zero, got \"$size\"" - } - if {$size < 0} { - return -code error "size: expected integer greater than or equal to zero, got \"$size\"" - } - if {$size == $tcaption} { - # No change, nothing to do - return "" - } - if {($size > 0) && ($tcaption == 0)} { - # Perform a consistency check after the assignment, the - # template might have been changed. - set tcaption $size - CheckVerticals $name - } else { - set tcaption $size - } - return "" -} - -# ::report::_bcaption -- -# -# Sets or queries the size of the bottom caption region of the report. -# -# Arguments: -# name Name of the report object. -# size The new size, if not empty. Emptiness indicates that a -# query was requested -# -# Results: -# None, or the current size of the bottom caption region - -proc ::report::_bcaption {name {size {}}} { - upvar ::report::report${name}::bcaption bcaption - - if {$size == {}} { - return $bcaption - } - if {![string is integer $size]} { - return -code error "size: expected integer greater than or equal to zero, got \"$size\"" - } - if {$size < 0} { - return -code error "size: expected integer greater than or equal to zero, got \"$size\"" - } - if {$size == $bcaption} { - # No change, nothing to do - return "" - } - if {($size > 0) && ($bcaption == 0)} { - # Perform a consistency check after the assignment, the - # template might have been changed. - set bcaption $size - CheckVerticals $name - } else { - set bcaption $size - } - return "" -} - -# ::report::_size -- -# -# Sets or queries the size of the specified column. -# -# Arguments: -# name Name of the report object. -# column Index of the column to manipulate or query -# size The new size, if not empty. Emptiness indicates that a -# query was requested -# -# Results: -# None, or the current size of the column - -proc ::report::_size {name column {size {}}} { - upvar ::report::report${name}::columns columns - upvar ::report::report${name}::csize csize - - set column [CheckColumn $columns $column] - - if {$size == {}} { - return $csize($column) - } - if {[string equal $size dyn]} { - set csize($column) $size - return "" - } - if {![string is integer $size]} { - return -code error "expected integer greater than zero, got \"$size\"" - } - if {$size <= 0} { - return -code error "expected integer greater than zero, got \"$size\"" - } - set csize($column) $size - return "" -} - -# ::report::_sizes -- -# -# Sets or queries the sizes of all columns. -# -# Arguments: -# name Name of the report object. -# sizes The new sizes, if not empty. Emptiness indicates that a -# query was requested -# -# Results: -# None, or a list containing the sizes of all columns. - -proc ::report::_sizes {name {sizes {}}} { - upvar ::report::report${name}::columns columns - upvar ::report::report${name}::csize csize - - if {$sizes == {}} { - set res [list] - foreach k [lsort -integer [array names csize]] { - lappend res $csize($k) - } - return $res - } - if {[llength $sizes] != $columns} { - return -code error "Wrong # number of column sizes" - } - foreach size $sizes { - if {[string equal $size dyn]} { - continue - } - if {![string is integer $size]} { - return -code error "expected integer greater than zero, got \"$size\"" - } - if {$size <= 0} { - return -code error "expected integer greater than zero, got \"$size\"" - } - } - - set i 0 - foreach s $sizes { - set csize($i) $s - incr i - } - return "" -} - -# ::report::_pad -- -# -# Sets or queries the padding for the specified column. -# -# Arguments: -# name Name of the report object. -# column Index of the column to manipulate or query -# where Where to place the padding. Emptiness indicates -# that a query was requested. -# -# Results: -# None, or the padding for the specified column. - -proc ::report::_pad {name column {where {}} {string { }}} { - upvar ::report::report${name}::columns columns - upvar ::report::report${name}::lpad lpad - upvar ::report::report${name}::rpad rpad - - set column [CheckColumn $columns $column] - - if {$where == {}} { - return [list $lpad($column) $rpad($column)] - } - - switch -exact -- $where { - left { - set lpad($column) $string - } - right { - set rpad($column) $string - } - both { - set lpad($column) $string - set rpad($column) $string - } - default { - return -code error "where: expected left, right, or both, got \"$where\"" - } - } - return "" -} - -# ::report::_justify -- -# -# Sets or queries the justification for the specified column. -# -# Arguments: -# name Name of the report object. -# column Index of the column to manipulate or query -# jvalue Justification to set. Emptiness indicates -# that a query was requested -# -# Results: -# None, or the current justication for the specified column - -proc ::report::_justify {name column {jvalue {}}} { - upvar ::report::report${name}::columns columns - upvar ::report::report${name}::cjust cjust - - set column [CheckColumn $columns $column] - - if {$jvalue == {}} { - return $cjust($column) - } - switch -exact -- $jvalue { - left - right - center { - set cjust($column) $jvalue - return "" - } - default { - return -code error "justification: expected, left, right, or center, got \"$jvalue\"" - } - } -} - -# ::report::_printmatrix -- -# -# Format the specified matrix according to the configuration of -# the report. -# -# Arguments: -# name Name of the report object. -# matrix Name of the matrix object to format. -# -# Results: -# A string containing the formatted matrix. - -proc ::report::_printmatrix {name matrix} { - CheckMatrix $name $matrix - ColumnSizes $name $matrix state - - upvar ::report::report${name}::tcaption tcaption - upvar ::report::report${name}::bcaption bcaption - - set row 0 - set out "" - append out [Separator top $name $matrix state] - if {$tcaption > 0} { - set n $tcaption - while {$n > 0} { - append out [FormatData topdata $name state [$matrix get row $row] [$matrix rowheight $row]] - if {$n > 1} { - append out [Separator topdatasep $name $matrix state] - } - incr n -1 - incr row - } - append out [Separator topcapsep $name $matrix state] - } - - set n [expr {[$matrix rows] - $bcaption}] - - while {$row < $n} { - append out [FormatData data $name state [$matrix get row $row] [$matrix rowheight $row]] - incr row - if {$row < $n} { - append out [Separator datasep $name $matrix state] - } - } - - if {$bcaption > 0} { - append out [Separator botcapsep $name $matrix state] - set n $bcaption - while {$n > 0} { - append out [FormatData botdata $name state [$matrix get row $row] [$matrix rowheight $row]] - if {$n > 1} { - append out [Separator botdatasep $name $matrix state] - } - incr n -1 - incr row - } - } - - append out [Separator bottom $name $matrix state] - - #parray state - return $out -} - -# ::report::_printmatrix2channel -- -# -# Format the specified matrix according to the configuration of -# the report. -# -# Arguments: -# name Name of the report. -# matrix Name of the matrix object to format. -# chan Handle of the channel to write the formatting result into. -# -# Results: -# None. - -proc ::report::_printmatrix2channel {name matrix chan} { - CheckMatrix $name $matrix - ColumnSizes $name $matrix state - - upvar ::report::report${name}::tcaption tcaption - upvar ::report::report${name}::bcaption bcaption - - set row 0 - puts -nonewline $chan [Separator top $name $matrix state] - if {$tcaption > 0} { - set n $tcaption - while {$n > 0} { - puts -nonewline $chan \ - [FormatData topdata $name state [$matrix get row $row] [$matrix rowheight $row]] - if {$n > 1} { - puts -nonewline $chan [Separator topdatasep $name $matrix state] - } - incr n -1 - incr row - } - puts -nonewline $chan [Separator topcapsep $name $matrix state] - } - - set n [expr {[$matrix rows] - $bcaption}] - - while {$row < $n} { - puts -nonewline $chan \ - [FormatData data $name state [$matrix get row $row] [$matrix rowheight $row]] - incr row - if {$row < $n} { - puts -nonewline $chan [Separator datasep $name $matrix state] - } - } - - if {$bcaption > 0} { - puts -nonewline $chan [Separator botcapsep $name $matrix state] - set n $bcaption - while {$n > 0} { - puts -nonewline $chan \ - [FormatData botdata $name state [$matrix get row $row] [$matrix rowheight $row]] - if {$n > 1} { - puts -nonewline $chan [Separator botdatasep $name $matrix state] - } - incr n -1 - incr row - } - } - - puts -nonewline $chan [Separator bottom $name $matrix state] - return -} - -# ::report::_columns -- -# -# Retrieves the number of columns in the report. -# -# Arguments: -# name Name of the report queried -# -# Results: -# A number - -proc ::report::_columns {name} { - upvar ::report::report${name}::columns columns - return $columns -} - -# ::report::_destroy -- -# -# Destroy a report, including its associated command and data storage. -# -# Arguments: -# name Name of the report to destroy. -# -# Results: -# None. - -proc ::report::_destroy {name} { - namespace delete ::report::report$name - interp alias {} ::$name {} - return -} - -# ::report::CheckMatrix -- -# -# Internal helper for the "print" methods. Checks that the -# supplied matrix can be formatted by the specified report. -# -# Arguments: -# name Name of the report to use for the formatting -# matrix Name of the matrix to format. -# -# Results: -# None, or an error in case of problems. - -proc ::report::CheckMatrix {name matrix} { - upvar ::report::report${name}::columns columns - upvar ::report::report${name}::tcaption tcaption - upvar ::report::report${name}::bcaption bcaption - - if {$columns != [$matrix columns]} { - return -code error "report/matrix mismatch in number of columns" - } - if {($tcaption + $bcaption) > [$matrix rows]} { - return -code error "matrix too small, top and bottom captions overlap" - } -} - -# ::report::ColumnSizes -- -# -# Internal helper for the "print" methods. Computes the final -# column sizes (with and without padding) and stores them in -# the print-state -# -# Arguments: -# name Name of the report used for the formatting -# matrix Name of the matrix to format. -# statevar Name of the array variable holding the state -# of the formatter. -# -# Results: -# None. - -proc ::report::ColumnSizes {name matrix statevar} { - # Calculate the final column sizes with and without padding and - # store them in the local state. - - upvar $statevar state - - upvar ::report::report${name}::columns columns - upvar ::report::report${name}::csize csize - upvar ::report::report${name}::lpad lpad - upvar ::report::report${name}::rpad rpad - - for {set c 0} {$c < $columns} {incr c} { - if {[string equal dyn $csize($c)]} { - set size [$matrix columnwidth $c] - } else { - set size $csize($c) - } - - set state(s,$c) $size - - incr size [string length $lpad($c)] - incr size [string length $rpad($c)] - - set state(s/pad,$c) $size - } - - return -} - -# ::report::Separator -- -# -# Internal helper for the "print" methods. Computes the final -# shape of the various separators using the column sizes with -# padding found in the print state. Uses also the print state as -# a cache to avoid costly recomputation for the separators which -# are used multiple times. -# -# Arguments: -# tcode Code of the separator to compute / template to use -# name Name of the report used for the formatting -# matrix Name of the matrix to format. -# statevar Name of the array variable holding the state -# of the formatter. -# -# Results: -# The final separator string. Empty for disabled separators. - -proc ::report::Separator {tcode name matrix statevar} { - upvar ::report::report${name}::enabled e - if {!$e($tcode)} {return ""} - upvar $statevar state - if {![info exists state($tcode)]} { - upvar ::report::report${name}::vTemplate vt - upvar ::report::report${name}::hTemplate ht - upvar ::report::report${name}::columns cs - set str "" - for {set c 0} {$c < $cs} {incr c} { - append str $vt($tcode,$c) - set fill $ht($tcode,$c) - set flen [string length $fill] - set rep [expr {($state(s/pad,$c)/$flen)+1}] - append str [string range [string repeat $fill $rep] 0 [expr {$state(s/pad,$c)-1}]] - } - append str $vt($tcode,$cs) - set state($tcode) $str - } - return $state($tcode)\n -} - -# ::report::FormatData -- -# -# Internal helper for the "print" methods. Computes the output -# for one row in the matrix, given its values, the rowheight, -# padding and justification. -# -# Arguments: -# tcode Code of the data template to use -# name Name of the report used for the formatting -# statevar Name of the array variable holding the state -# of the formatter. -# line List containing the values to format -# rh Height of the row (line) in lines. -# -# Results: -# The formatted string for the supplied row. - -proc ::report::FormatData {tcode name statevar line rh} { - upvar $statevar state - upvar ::report::report${name}::vTemplate vt - upvar ::report::report${name}::columns cs - upvar ::report::report${name}::lpad lpad - upvar ::report::report${name}::rpad rpad - upvar ::report::report${name}::cjust cjust - - if {$rh == 1} { - set str "" - set c 0 - foreach cell $line { - # prefix, cell (pad-l, value, pad-r) - append str $vt($tcode,$c)$lpad($c)[FormatCell $cell $state(s,$c) $cjust($c)]$rpad($c) - incr c - } - append str $vt($tcode,$cs)\n - return $str - } else { - array set str {} - for {set l 1} {$l <= $rh} {incr l} {set str($l) ""} - - # - Future - Vertical justification of cells less tall than rowheight - # - Future - Vertical cutff aftert n lines, auto-repeat of captions - # - Future - => Higher level, not here, use virtual matrices for this - # - Future - and count the generated lines - - set c 0 - foreach fcell $line { - set fcell [split $fcell \n] - for {set l 1; set lo 0} {$l <= $rh} {incr l; incr lo} { - append str($l) $vt($tcode,$c)$lpad($c)[FormatCell \ - [lindex $fcell $lo] $state(s,$c) $cjust($c)]$rpad($c) - } - incr c - } - set strout "" - for {set l 1} {$l <= $rh} {incr l} { - append strout $str($l)$vt($tcode,$cs)\n - } - return $strout - } -} - -# ::report::FormatCell -- -# -# Internal helper for the "print" methods. Formats the value of -# a single cell according to column size and justification. -# -# Arguments: -# value The value to format -# size The size of the column, without padding -# just The justification for the current cell/column -# -# Results: -# The formatted string for the supplied cell. - -proc ::report::FormatCell {value size just} { - set vlen [string length $value] - - if {$vlen == $size} { - # Value fits exactly, justification is irrelevant - return $value - } - - # - Future - Other fill characters ... - # - Future - Different fill characters per class of value => regex/glob pattern|functions - # - Future - Wraparound - interacts with rowheight! - - switch -exact -- $just { - left { - if {$vlen < $size} { - return $value[string repeat " " [expr {$size - $vlen}]] - } - return [string range $value [expr {$vlen - $size}] end] - } - right { - if {$vlen < $size} { - return [string repeat " " [expr {$size - $vlen}]]$value - } - incr size -1 - return [string range $value 0 $size] - } - center { - if {$vlen < $size} { - set fill [expr {$size - $vlen}] - set rfill [expr {$fill / 2}] - set lfill [expr {$fill - $rfill}] - return [string repeat " " $lfill]$value[string repeat " " $rfill] - } - - set cut [expr {$vlen - $size}] - set lcut [expr {$cut / 2}] - set rcut [expr {$cut - $lcut}] - - return [string range $value $lcut end-$rcut] - } - default { - error "Can't happen, panic, run, shout" - } - } -} DELETED modules/report/report.test Index: modules/report/report.test ================================================================== --- modules/report/report.test +++ /dev/null @@ -1,1349 +0,0 @@ -# -*- tcl -*- -# report.test: tests for the report structure. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 2001 by Andreas Kupries -# All rights reserved. -# -# RCS: @(#) $Id: report.test,v 1.3 2002/02/02 01:07:51 andreas_kupries Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -package require report -package require struct -puts "report [package present report]" -puts "- struct [package present struct]" - -namespace import ::report::report - -# styles ............................................................. - -test report-1.0 {styles introspection} { - ::report::styles -} {plain} - -test report-1.1 {styles introspection} { - set result [list] - lappend result [::report::styles] - ::report::defstyle foo {a b} {bla} - lappend result [::report::styles] - ::report::rmstyle foo - lappend result [::report::styles] - set result -} {plain {plain foo} plain} - - -test report-2.0 {style definition errors} { - catch {::report::defstyle} result - set result -} [tcltest::getErrorMessage "::report::defstyle" "styleName arguments body" 0] - -test report-2.1 {style definition error} { - catch {::report::defstyle foo} result - set result -} [tcltest::getErrorMessage "::report::defstyle" "styleName arguments body" 1] - -test report-2.2 {style definition errors} { - catch {::report::defstyle foo {}} result - set result -} [tcltest::getErrorMessage "::report::defstyle" "styleName arguments body" 2] - -test report-2.3 {style definition errors} { - catch {::report::defstyle foo {} {} bla} result - set result -} [if {[info tclversion] < 8.4} { - set msg {called "::report::defstyle" with too many arguments} -} else { - set msg {wrong # args: should be "::report::defstyle styleName arguments body"} -}] - -test report-2.4 {style definition errors} { - catch {::report::defstyle plain {} {}} result - set result -} {Cannot create style "plain", already exists} - -test report-2.5 {style definition error} { - catch {::report::defstyle foo {{a default} b} {}} result - set result -} {Found argument without default after arguments having defaults} - -test report-2.6 {style definition error} { - catch {::report::defstyle foo {a {a b c}} {}} result - set result -} {Illegal length of value "a b c"} - -test report-2.7 {style definition error} { - catch {::report::defstyle foo {a {}} {}} result - set result -} {Illegal length of value ""} - - -test report-3.0 {style deletion errors} { - catch {::report::rmstyle} result - set result -} [tcltest::getErrorMessage "::report::rmstyle" "styleName" 0] - -test report-3.1 {style deletion errors} { - catch {::report::rmstyle plain} result - set result -} {cannot delete builtin style "plain"} - -test report-3.2 {style deletion errors} { - catch {::report::rmstyle foo} result - set result -} {cannot delete unknown style "foo"} - - -test report-4.0 {style introspection error} { - catch {::report::stylearguments} result - set result -} [tcltest::getErrorMessage "::report::stylearguments" "styleName" 0] - -test report-4.1 {style introspection error} { - catch {::report::stylearguments foo} result - set result -} {style "foo" is not known} - -test report-4.2 {style introspection error} { - catch {::report::stylebody} result - set result -} [tcltest::getErrorMessage "::report::stylebody" "styleName" 0] - -test report-4.3 {style introspection error} { - catch {::report::stylebody foo} result - set result -} {style "foo" is not known} - -test report-4.4 {style introspection} { - ::report::defstyle foo {a b} {bar} - set result [list] - lappend result [::report::stylearguments foo] - lappend result [::report::stylebody foo] - ::report::rmstyle foo - set result -} {{a b} bar} - -test report-4.5 {style introspection} { - ::report::defstyle foo {a args} {bar} - set result [list] - lappend result [::report::stylearguments foo] - lappend result [::report::stylebody foo] - ::report::rmstyle foo - set result -} {{a args} bar} - -test report-4.6 {style introspection} { - set result [list] - lappend result [::report::stylearguments plain] - lappend result [::report::stylebody plain] - set result -} {{} {}} - -# Define now two generally useful styles. -# They are used in the following tests. -# --------------------------------------- - -::report::defstyle simpletable {} { - data set [split "[string repeat "| " [columns]]|"] - top set [split "[string repeat "+ - " [columns]]+"] - bottom set [top get] - top enable - bottom enable -} -::report::defstyle captionedtable {{n 1}} { - simpletable - topdata set [data get] - topcapsep set [top get] - topcapsep enable - tcaption $n -} -::report::defstyle bcaptionedtable {{n 1}} { - simpletable - topdata set [data get] - topcapsep set [top get] - topcapsep enable - tcaption $n - botdata set [data get] - botcapsep set [bottom get] - botcapsep enable - bcaption $n -} -::report::defstyle bdcaptionedtable {{n 1}} { - simpletable - topdata set [data get] - topcapsep set [top get] - topdatasep set [top get] - topcapsep enable - topdatasep enable - tcaption $n - botdata set [data get] - botcapsep set [bottom get] - botdatasep set [top get] - botcapsep enable - botdatasep enable - bcaption $n -} - -# --------------------------------------------------------------------- - -test report-5.0 {style application errors} { - catch {report myreport 3 style} result - set result -} {wrong # args: report name columns ?"style" styleName ?arg...??} - -test report-5.1 {style application errors} { - catch {report myreport 3 blarg foo ...} result - set result -} {wrong # args: report name columns ?"style" styleName ?arg...??} - -test report-5.2 {style application errors} { - catch {report myreport 3 style foo} result - set result -} {style "foo" is not known} - -test report-5.3 {style application errors} { - ::report::defstyle foo {a b} {} - catch {report myreport 3 style foo} result - ::report::rmstyle foo - set result -} {no value given for parameter "a" to style "foo"} - -# [tcltest::getErrorMessage "foo" "a b" 0] - -test report-5.4 {style application errors} { - ::report::defstyle foo {a b} {} - catch {report myreport 5 style foo a b c d e} result - ::report::rmstyle foo - set result -} {called style "foo" with too many arguments} - -test report-5.5 {style application} { - report myreport 3 style simpletable - - set result [list] - lappend result [myreport data get] - lappend result [myreport top get] - lappend result [myreport bottom get] - lappend result [myreport topcapsep get] - lappend result [myreport top enabled] - lappend result [myreport bottom enabled] - lappend result [myreport topcapsep enabled] - - myreport destroy - set result -} {{| | | |} {+ - + - + - +} {+ - + - + - +} {{} {} {} {} {} {} {}} 1 1 0} - -test report-5.6 {style application} { - - set result [list] - ::report::defstyle foo {a b args} { - # Hack to transfer information out of the safe interp to the - # test environment. - botcapsep set [list $a $b $args] - } - report mr 1 style foo A B ; lappend result [mr botcapsep get] - mr destroy - report mr 1 style foo A B C ; lappend result [mr botcapsep get] - mr destroy - report mr 1 style foo A B C D E ; lappend result [mr botcapsep get] - mr destroy - ::report::rmstyle foo - - set result -} {{A B {}} {A B C} {A B {C D E}}} - - -# reports ............................................................. - -test report-6.0 {report errors} { - catch {report myreport} msg - set msg -} [tcltest::getErrorMessage "report" "name columns args" 1] - -test report-6.1 {report errors} { - catch {report myreport -5} msg - set msg -} {columns: expected integer greater than zero, got "-5"} - -test report-6.2 {report errors} { - catch {report myreport 0} msg - set msg -} {columns: expected integer greater than zero, got "0"} - -test report-6.3 {report errors} { - catch {report myreport foo} msg - set msg -} {columns: expected integer greater than zero, got "foo"} - -test report-6.4 {report errors} { - catch {report set 4} msg - set msg -} "command \"set\" already exists, unable to create report" - -test report-6.5 {report errors} { - report myreport 3 - catch {report myreport 3} msg - myreport destroy - set msg -} "command \"myreport\" already exists, unable to create report" - -test report-6.6 {report errors} { - catch {report myreport 3 foo} msg - set msg -} {wrong # args: report name columns ?"style" styleName ?arg...??} - -# report methods ...................................................... - -test report-7.0 {report method errors} { - report myreport 3 - catch {myreport} msg - myreport destroy - set msg -} "wrong # args: should be \"myreport option ?arg arg ...?\"" - -test report-7.1 {report errors} { - report myreport 3 - catch {myreport foo} msg - myreport destroy - set msg -} "bad option \"foo\": must be bcaption, botcapsep, botdata, botdatasep, bottom, columns, data, datasep, justify, pad, printmatrix, printmatrix2channel, size, sizes, tcaption, top, topcapsep, topdata, or topdatasep" - -foreach {n m} { - 8 tcaption - 9 bcaption -} { - test report-$n.0 {captions} { - report myreport 3 - set result [myreport $m] - myreport $m 5 - lappend result [myreport $m] - myreport $m 0 - lappend result [myreport $m] - myreport $m 0 - lappend result [myreport $m] - myreport destroy - set result - } {0 5 0 0} - - test report-$n.1 {captions} { - report myreport 3 - catch [list myreport $m -1] result - myreport destroy - set result - } {size: expected integer greater than or equal to zero, got "-1"} - - test report-$n.2 {captions} { - report myreport 3 - catch [list myreport $m foo] result - myreport destroy - set result - } {size: expected integer greater than or equal to zero, got "foo"} -} - -test report-10.0 {column sizes} { - report myreport 3 - catch {myreport size} result - myreport destroy - set result -} [tcltest::getErrorMessage "::report::_size" "name column ?size?" 1] - -test report-10.1 {column sizes} { - report myreport 3 - catch {myreport size -1} result - myreport destroy - set result -} {column: index "-1" out of range} - -test report-10.2 {column sizes} { - report myreport 3 - catch {myreport size foo} result - myreport destroy - set result -} {column: syntax error in index "foo"} - -test report-10.3 {column sizes} { - report myreport 3 - catch {myreport size 4} result - myreport destroy - set result -} {column: index "4" out of range} - -test report-10.4 {column sizes} { - report myreport 3 - catch {myreport size end-5} result - myreport destroy - set result -} {column: index "end-5" out of range} - -test report-10.5 {column sizes} { - report myreport 3 - catch {myreport size 0 foo} result - myreport destroy - set result -} {expected integer greater than zero, got "foo"} - -test report-10.6 {column sizes} { - report myreport 3 - catch {myreport size 0 0} result - myreport destroy - set result -} {expected integer greater than zero, got "0"} - -test report-10.7 {column sizes} { - report myreport 3 - catch {myreport size 0 -4} result - myreport destroy - set result -} {expected integer greater than zero, got "-4"} - -test report-10.8 {column sizes} { - report myreport 3 - set result [myreport size 0] - myreport size 0 5 - lappend result [myreport size 0] - myreport destroy - set result -} {dyn 5} - -test report-10.9 {column sizes} { - report myreport 3 - set result [myreport size 0] - myreport size 0 5 - lappend result [myreport size 0] - myreport size 0 dyn - lappend result [myreport size 0] - myreport destroy - set result -} {dyn 5 dyn} - - -test report-11.0 {column sizes} { - report myreport 3 - catch {myreport sizes 1} result - myreport destroy - set result -} {Wrong # number of column sizes} - -test report-11.1 {column sizes} { - report myreport 3 - catch {myreport sizes {1 2 3 4}} result - myreport destroy - set result -} {Wrong # number of column sizes} - -test report-11.2 {column sizes} { - report myreport 3 - catch {myreport sizes {2 0 dyn}} result - myreport destroy - set result -} {expected integer greater than zero, got "0"} - -test report-11.3 {column sizes} { - report myreport 3 - catch {myreport sizes {2 foo dyn}} result - myreport destroy - set result -} {expected integer greater than zero, got "foo"} - -test report-11.4 {column sizes} { - report myreport 3 - catch {myreport sizes {2 -5 dyn}} result - myreport destroy - set result -} {expected integer greater than zero, got "-5"} - -test report-11.5 {column sizes} { - report myreport 3 - set result [list [myreport sizes]] - myreport sizes {2 dyn 5} - lappend result [myreport sizes] - myreport destroy - set result -} {{dyn dyn dyn} {2 dyn 5}} - - -test report-12.0 {padding} { - report myreport 3 - catch {myreport pad} result - myreport destroy - set result -} [tcltest::getErrorMessage "::report::_pad" "name column ?where? ?string?" 1] - -test report-12.1 {padding} { - report myreport 3 - catch {myreport pad -1} result - myreport destroy - set result -} {column: index "-1" out of range} - -test report-12.2 {padding} { - report myreport 3 - catch {myreport pad foo} result - myreport destroy - set result -} {column: syntax error in index "foo"} - -test report-12.3 {padding} { - report myreport 3 - catch {myreport pad 4} result - myreport destroy - set result -} {column: index "4" out of range} - -test report-12.4 {padding} { - report myreport 3 - catch {myreport pad end-5} result - myreport destroy - set result -} {column: index "end-5" out of range} - -test report-12.5 {padding} { - report myreport 3 - catch {myreport pad 0 foo} result - myreport destroy - set result -} {where: expected left, right, or both, got "foo"} - -test report-12.6 {padding} { - report myreport 3 - set result [list [myreport pad 0]] - myreport pad 0 left - myreport pad 0 right = - lappend result [myreport pad 0] - myreport pad 0 both _ - lappend result [myreport pad 0] - myreport destroy - set result -} {{{} {}} {{ } =} {_ _}} - - -test report-13.0 {justification} { - report myreport 3 - catch {myreport justify} result - myreport destroy - set result -} [tcltest::getErrorMessage "::report::_justify" "name column ?jvalue?" 1] - -test report-13.1 {justification} { - report myreport 3 - catch {myreport justify -1} result - myreport destroy - set result -} {column: index "-1" out of range} - -test report-13.2 {justification} { - report myreport 3 - catch {myreport justify foo} result - myreport destroy - set result -} {column: syntax error in index "foo"} - -test report-13.3 {justification} { - report myreport 3 - catch {myreport justify 4} result - myreport destroy - set result -} {column: index "4" out of range} - -test report-13.4 {justification} { - report myreport 3 - catch {myreport justify end-5} result - myreport destroy - set result -} {column: index "end-5" out of range} - -test report-13.5 {justification} { - report myreport 3 - catch {myreport justify 0 bla} result - myreport destroy - set result -} {justification: expected, left, right, or center, got "bla"} - -test report-13.6 {justification} { - report myreport 3 - set result [myreport justify 0] - myreport justify 0 right - lappend result [myreport justify 0] - myreport justify 0 center - lappend result [myreport justify 0] - myreport destroy - set result -} {left right center} - - -test report-14.0 {columns} { - report myreport 3 - set result [myreport columns] - myreport destroy - set result -} 3 - -foreach {n template} { - 15 top - 16 topdatasep - 17 topcapsep - 18 datasep - 19 botcapsep - 20 botdatasep - 21 bottom -} { - test report-$n.0 {separator templates} { - report myreport 1 - catch [list myreport $template] result - myreport destroy - set result - } [tcltest::getErrorMessage "::report::_tAction" "name template cmd args" 2] - - test report-$n.1 {separator templates} { - report myreport 1 - set result [myreport $template enabled] - myreport destroy - set result - } 0 - - test report-$n.2 {separator templates} { - report myreport 1 - myreport $template enable - set result [myreport $template enabled] - myreport $template disable - lappend result [myreport $template enabled] - myreport destroy - set result - } {1 0} - - test report-$n.3 {separator templates} { - report myreport 3 - set result [list [myreport $template get]] - myreport $template set {+ = + = + = +} - lappend result [myreport $template get] - myreport destroy - set result - } {{{} {} {} {} {} {} {}} {+ = + = + = +}} - - test report-$n.4 {consistency checking} { - report myreport 3 - catch [list myreport $template set {}] result - myreport destroy - set result - } {template to short for number of columns in report} - - test report-$n.5 {consistency checking} { - report myreport 3 - catch [list myreport $template set {+ - + - + - + - +}] result - myreport destroy - set result - } {template to long for number of columns in report} - - test report-$n.6 {templates} { - report myreport 3 - catch [list myreport $template set] result - myreport destroy - set result - } [list Wrong # args: myreport $template set template] - - test report-$n.7 {templates} { - report myreport 3 - catch [list myreport $template get foo] result - myreport destroy - set result - } [list Wrong # args: myreport $template get] - - test report-$n.8 {templates} { - report myreport 3 - catch [list myreport $template bla] result - myreport destroy - set result - } {Unknown template command "bla"} - - test report-$n.9 {consistency checking} { - report myreport 3 - myreport top set {+ - + - + - +} - catch {myreport top enable} result - myreport destroy - set result - } {inconsistent verticals in report} -} - -foreach {n template} { - 22 topdata - 23 data - 24 botdata -} { - test report-$n.0 {data templates} { - report myreport 1 - catch [list myreport $template] result - myreport destroy - set result - } [tcltest::getErrorMessage "::report::_tAction" "name template cmd args" 2] - - test report-$n.1 {data templates} { - report myreport 1 - catch [list myreport $template enabled] result - myreport destroy - set result - } "Cannot query state of data template \"$template\"" - - test report-$n.2 {data templates} { - report myreport 1 - catch [list myreport $template enable] result - myreport destroy - set result - } "Cannot enable data template \"$template\"" - - test report-$n.3 {data templates} { - report myreport 1 - catch [list myreport $template disable] result - myreport destroy - set result - } "Cannot disable data template \"$template\"" - - test report-$n.4 {data templates} { - report myreport 3 - set result [list [myreport $template get]] - myreport $template set {+ + + +} - lappend result [myreport $template get] - myreport destroy - set result - } {{{} {} {} {}} {+ + + +}} - - test report-$n.5 {consistency checking} { - report myreport 3 - catch [list myreport $template set {}] result - myreport destroy - set result - } {template to short for number of columns in report} - - test report-$n.6 {consistency checking} { - report myreport 3 - catch [list myreport data set {+ + + + +}] result - myreport destroy - set result - } {template to long for number of columns in report} - - test report-$n.7 {templates} { - report myreport 3 - catch [list myreport $template set] result - myreport destroy - set result - } [list Wrong # args: myreport $template set template] - - test report-$n.8 {templates} { - report myreport 3 - catch [list myreport $template get foo] result - myreport destroy - set result - } [list Wrong # args: myreport $template get] - - test report-$n.9 {templates} { - report myreport 3 - catch [list myreport $template bla] result - myreport destroy - set result - } {Unknown template command "bla"} - -} - -foreach {n template cap} { - 25 topdata tcaption - 26 botdata bcaption -} { - test report-$n.0 {consistency checking} { - report myreport 3 - myreport $template set {-+ + + +-} - catch [list myreport $cap 1] result - myreport destroy - set result - } {inconsistent verticals in report} -} - -# report execution, i.e. the actual formatting of a matrix ............ - -test report-27.0 {formatting errors} { - report myreport 5 - catch {myreport printmatrix} result - myreport destroy - set result -} [tcltest::getErrorMessage "::report::_printmatrix" "name matrix" 1] - -test report-27.1 {formatting errors} { - report myreport 5 - ::struct::matrix mymatrix - mymatrix add columns 3 - catch {myreport printmatrix mymatrix} result - mymatrix destroy - myreport destroy - set result -} {report/matrix mismatch in number of columns} - -test report-27.2 {formatting errors} { - report myreport 5 - ::struct::matrix mymatrix - mymatrix add columns 8 - catch {myreport printmatrix mymatrix} result - mymatrix destroy - myreport destroy - set result -} {report/matrix mismatch in number of columns} - -test report-27.3 {formatting errors} { - report myreport 5 - myreport tcaption 3 - myreport bcaption 4 - ::struct::matrix mymatrix - mymatrix add columns 5 - mymatrix add rows 6 - catch {myreport printmatrix mymatrix} result - mymatrix destroy - myreport destroy - set result -} {matrix too small, top and bottom captions overlap} - -test report-27.4 {formatting} { - ::struct::matrix mymatrix - mymatrix add columns 5 - mymatrix add row {000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} - mymatrix add row {001 {CATCH return ok} 7 13 53.85} - mymatrix add row {002 {CATCH return error} 68 91 74.73} - mymatrix add row {003 {CATCH no catch used} 7 14 50.00} - mymatrix add row {004 {IF if true numeric} 12 33 36.36} - mymatrix add row {005 {IF elseif true numeric} 15 47 31.91} - - report myreport 5 ; # style plain - set result [myreport printmatrix mymatrix] - myreport destroy - mymatrix destroy - - set result -} {000VERSIONS: 2:8.4a31:8.4a31:8.4a3% -001CATCH return ok 7 13 53.85 -002CATCH return error 68 91 74.73 -003CATCH no catch used 7 14 50.00 -004IF if true numeric 12 33 36.36 -005IF elseif true numeric15 47 31.91 -} - -test report-27.5 {formatting} { - - ::struct::matrix mymatrix - mymatrix add columns 5 - mymatrix add row {000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} - mymatrix add row {001 {CATCH return ok} 7 13 53.85} - mymatrix add row {002 {CATCH return error} 68 91 74.73} - mymatrix add row {003 {CATCH no catch used} 7 14 50.00} - mymatrix add row {004 {IF if true numeric} 12 33 36.36} - mymatrix add row {005 {IF elseif true numeric} 15 47 31.91} - - report myreport 5 style simpletable - set result [myreport printmatrix mymatrix] - myreport destroy - mymatrix destroy - - set result -} {+---+----------------------+-------+-------+--------+ -|000|VERSIONS: |2:8.4a3|1:8.4a3|1:8.4a3%| -|001|CATCH return ok |7 |13 |53.85 | -|002|CATCH return error |68 |91 |74.73 | -|003|CATCH no catch used |7 |14 |50.00 | -|004|IF if true numeric |12 |33 |36.36 | -|005|IF elseif true numeric|15 |47 |31.91 | -+---+----------------------+-------+-------+--------+ -} - -test report-27.6 {formatting} { - - ::struct::matrix mymatrix - mymatrix add columns 5 - mymatrix add row {000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} - mymatrix add row {001 {CATCH return ok} 7 13 53.85} - mymatrix add row {002 {CATCH return error} 68 91 74.73} - mymatrix add row {003 {CATCH no catch used} 7 14 50.00} - mymatrix add row {004 {IF if true numeric} 12 33 36.36} - mymatrix add row {005 {IF elseif true numeric} 15 47 31.91} - - report myreport 5 style captionedtable 1 - set result [myreport printmatrix mymatrix] - myreport destroy - mymatrix destroy - - - set result -} {+---+----------------------+-------+-------+--------+ -|000|VERSIONS: |2:8.4a3|1:8.4a3|1:8.4a3%| -+---+----------------------+-------+-------+--------+ -|001|CATCH return ok |7 |13 |53.85 | -|002|CATCH return error |68 |91 |74.73 | -|003|CATCH no catch used |7 |14 |50.00 | -|004|IF if true numeric |12 |33 |36.36 | -|005|IF elseif true numeric|15 |47 |31.91 | -+---+----------------------+-------+-------+--------+ -} - -test report-27.7 {formatting} { - ::struct::matrix mymatrix - mymatrix add columns 5 - mymatrix add row {000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} - mymatrix add row {001 {CATCH return ok} 7 13 53.85} - mymatrix add row {002 {CATCH return error} 68 91 74.73} - mymatrix add row {003 {CATCH no catch used} 7 14 50.00} - mymatrix add row {004 {IF if true numeric} 12 33 36.36} - mymatrix add row {005 {IF elseif true numeric} 15 47 31.91} - - report myreport 5 ; # plain - myreport top set {-+ -/ + -/ + -/ + -/ + -/ +-} - myreport topdata set {{ |} | | | | {| }} - myreport topcapsep set {=+ *= + *= + *= + *= + *= +=} - myreport data set {{ |} | | | | {| }} - myreport bottom set {-+ - + - + - + - + - +-} - myreport top enable - myreport topcapsep enable - myreport bottom enable - myreport tcaption 1 - myreport sizes {5 dyn 7 7 5} - myreport pad 0 right - myreport pad 1 both - myreport pad 2 both - myreport pad 3 both - myreport pad 4 both - myreport justify 0 center - myreport justify 1 right - myreport justify 2 right - myreport justify 3 right - myreport justify 3 right - - set result [myreport printmatrix mymatrix] - myreport destroy - mymatrix destroy - - set result -} {-+-/-/-/+-/-/-/-/-/-/-/-/-/-/-/-/+-/-/-/-/-+-/-/-/-/-+-/-/-/-+- - | 000 | VERSIONS: | 2:8.4a3 | 1:8.4a3 | .4a3% | -=+*=*=*=+*=*=*=*=*=*=*=*=*=*=*=*=+*=*=*=*=*+*=*=*=*=*+*=*=*=*+= - | 001 | CATCH return ok | 7 | 13 | 53.85 | - | 002 | CATCH return error | 68 | 91 | 74.73 | - | 003 | CATCH no catch used | 7 | 14 | 50.00 | - | 004 | IF if true numeric | 12 | 33 | 36.36 | - | 005 | IF elseif true numeric | 15 | 47 | 31.91 | --+------+------------------------+---------+---------+-------+- -} - -test report-27.7.1 {formatting} { - ::struct::matrix mymatrix - mymatrix add columns 5 - mymatrix add row {000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} - mymatrix add row {001 {CATCH return ok} 7 13 53.85} - mymatrix add row {002 {CATCH return error} 68 91 74.73} - mymatrix add row {003 {CATCH no catch used} 7 14 50.00} - mymatrix add row {004 {IF if true numeric} 12 33 36.36} - mymatrix add row {005 {IF elseif true numeric} 15 47 31.91} - - report myreport 5 ; # plain - myreport top set {-+ -/ + -/ + -/ + -/ + -/ +-} - myreport topdata set {{ |} | | | | {| }} - myreport topcapsep set {=+ *= + *= + *= + *= + *= +=} - myreport data set {{ |} | | | | {| }} - myreport bottom set {-+ - + - + - + - + - +-} - myreport top enable - myreport topcapsep enable - myreport bottom enable - myreport tcaption 1 - myreport sizes {2 5 7 7 5} - myreport pad 0 right - myreport pad 1 both - myreport pad 2 both - myreport pad 3 both - myreport pad 4 both - myreport justify 0 center - myreport justify 1 right - myreport justify 2 right - myreport justify 3 right - myreport justify 3 right - - set result [myreport printmatrix mymatrix] - myreport destroy - mymatrix destroy - - set result -} {-+-/-+-/-/-/-+-/-/-/-/-+-/-/-/-/-+-/-/-/-+- - |00 | VERSI | 2:8.4a3 | 1:8.4a3 | .4a3% | -=+*=*+*=*=*=*+*=*=*=*=*+*=*=*=*=*+*=*=*=*+= - |00 | CATCH | 7 | 13 | 53.85 | - |00 | CATCH | 68 | 91 | 74.73 | - |00 | CATCH | 7 | 14 | 50.00 | - |00 | IF if | 12 | 33 | 36.36 | - |00 | IF el | 15 | 47 | 31.91 | --+---+-------+---------+---------+-------+- -} - -test report-27.8 {formatting, rowheight > 1} { - ::struct::matrix mymatrix - mymatrix add columns 5 - mymatrix add row {000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} - mymatrix add row {001 {CATCH return ok} 7 13 53.85} - mymatrix add row {002 {CATCH return error} 68 91 74.73} - mymatrix add row {003 {CATCH no catch used} 7 14 50.00} - mymatrix add row {004 {IF if true numeric} 12 33 36.36} - mymatrix add row {005 {IF elseif -true numeric} 15 47 31.91} - - report myreport 5 style captionedtable 1 - set result [myreport printmatrix mymatrix] - myreport destroy - mymatrix destroy - - set result -} {+---+-------------------+-------+-------+--------+ -|000|VERSIONS: |2:8.4a3|1:8.4a3|1:8.4a3%| -+---+-------------------+-------+-------+--------+ -|001|CATCH return ok |7 |13 |53.85 | -|002|CATCH return error |68 |91 |74.73 | -|003|CATCH no catch used|7 |14 |50.00 | -|004|IF if true numeric |12 |33 |36.36 | -|005|IF elseif |15 |47 |31.91 | -| |true numeric | | | | -+---+-------------------+-------+-------+--------+ -} - -# And now all of above again, for printing into a channel. - -tcltest::makeFile {} dummy -tcltest::makeFile {} rep1 -tcltest::makeFile {} rep2 -tcltest::makeFile {} rep3 -tcltest::makeFile {} rep4 -tcltest::makeFile {} rep5 - -test report-28.0 {formatting errors} { - report myreport 5 - catch {myreport printmatrix2channel} result - myreport destroy - set result -} [tcltest::getErrorMessage "::report::_printmatrix2channel" "name matrix chan" 1] - -test report-28.1 {formatting errors} { - report myreport 5 - ::struct::matrix mymatrix - catch {myreport printmatrix2channel mymatrix} result - mymatrix destroy - myreport destroy - set result -} [tcltest::getErrorMessage "::report::_printmatrix2channel" "name matrix chan" 2] - -test report-28.2 {formatting errors} { - report myreport 5 - ::struct::matrix mymatrix - mymatrix add columns 3 - - set f [open dummy w] - catch {myreport printmatrix2channel mymatrix $f} result - mymatrix destroy - myreport destroy - close $f - set result -} {report/matrix mismatch in number of columns} - -test report-28.3 {formatting errors} { - report myreport 5 - ::struct::matrix mymatrix - mymatrix add columns 8 - set f [open dummy w] - catch {myreport printmatrix2channel mymatrix $f} result - mymatrix destroy - myreport destroy - close $f - set result -} {report/matrix mismatch in number of columns} - -test report-28.4 {formatting errors} { - report myreport 5 - myreport tcaption 3 - myreport bcaption 4 - ::struct::matrix mymatrix - mymatrix add columns 5 - mymatrix add rows 6 - set f [open dummy w] - catch {myreport printmatrix2channel mymatrix $f} result - mymatrix destroy - myreport destroy - close $f - set result -} {matrix too small, top and bottom captions overlap} - -test report-28.5 {formatting} { - ::struct::matrix mymatrix - mymatrix add columns 5 - mymatrix add row {000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} - mymatrix add row {001 {CATCH return ok} 7 13 53.85} - mymatrix add row {002 {CATCH return error} 68 91 74.73} - mymatrix add row {003 {CATCH no catch used} 7 14 50.00} - mymatrix add row {004 {IF if true numeric} 12 33 36.36} - mymatrix add row {005 {IF elseif true numeric} 15 47 31.91} - - set f [open rep1 w] - report myreport 5 ; # style plain - myreport printmatrix2channel mymatrix $f - myreport destroy - mymatrix destroy - close $f - - ::tcltest::viewFile rep1 -} {000VERSIONS: 2:8.4a31:8.4a31:8.4a3% -001CATCH return ok 7 13 53.85 -002CATCH return error 68 91 74.73 -003CATCH no catch used 7 14 50.00 -004IF if true numeric 12 33 36.36 -005IF elseif true numeric15 47 31.91 } - -test report-28.6 {formatting} { - - ::struct::matrix mymatrix - mymatrix add columns 5 - mymatrix add row {000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} - mymatrix add row {001 {CATCH return ok} 7 13 53.85} - mymatrix add row {002 {CATCH return error} 68 91 74.73} - mymatrix add row {003 {CATCH no catch used} 7 14 50.00} - mymatrix add row {004 {IF if true numeric} 12 33 36.36} - mymatrix add row {005 {IF elseif true numeric} 15 47 31.91} - - set f [open rep2 w] - report myreport 5 style simpletable - myreport printmatrix2channel mymatrix $f - myreport destroy - mymatrix destroy - close $f - - ::tcltest::viewFile rep2 -} {+---+----------------------+-------+-------+--------+ -|000|VERSIONS: |2:8.4a3|1:8.4a3|1:8.4a3%| -|001|CATCH return ok |7 |13 |53.85 | -|002|CATCH return error |68 |91 |74.73 | -|003|CATCH no catch used |7 |14 |50.00 | -|004|IF if true numeric |12 |33 |36.36 | -|005|IF elseif true numeric|15 |47 |31.91 | -+---+----------------------+-------+-------+--------+} - -test report-28.7 {formatting} { - - ::struct::matrix mymatrix - mymatrix add columns 5 - mymatrix add row {000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} - mymatrix add row {001 {CATCH return ok} 7 13 53.85} - mymatrix add row {002 {CATCH return error} 68 91 74.73} - mymatrix add row {003 {CATCH no catch used} 7 14 50.00} - mymatrix add row {004 {IF if true numeric} 12 33 36.36} - mymatrix add row {005 {IF elseif true numeric} 15 47 31.91} - - set f [open rep3 w] - report myreport 5 style captionedtable 1 - myreport printmatrix2channel mymatrix $f - myreport destroy - mymatrix destroy - close $f - - ::tcltest::viewFile rep3 -} {+---+----------------------+-------+-------+--------+ -|000|VERSIONS: |2:8.4a3|1:8.4a3|1:8.4a3%| -+---+----------------------+-------+-------+--------+ -|001|CATCH return ok |7 |13 |53.85 | -|002|CATCH return error |68 |91 |74.73 | -|003|CATCH no catch used |7 |14 |50.00 | -|004|IF if true numeric |12 |33 |36.36 | -|005|IF elseif true numeric|15 |47 |31.91 | -+---+----------------------+-------+-------+--------+} - -test report-28.8 {formatting} { - ::struct::matrix mymatrix - mymatrix add columns 5 - mymatrix add row {000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} - mymatrix add row {001 {CATCH return ok} 7 13 53.85} - mymatrix add row {002 {CATCH return error} 68 91 74.73} - mymatrix add row {003 {CATCH no catch used} 7 14 50.00} - mymatrix add row {004 {IF if true numeric} 12 33 36.36} - mymatrix add row {005 {IF elseif true numeric} 15 47 31.91} - - set f [open rep4 w] - report myreport 5 ; # plain - myreport top set {-+ -/ + -/ + -/ + -/ + -/ +-} - myreport topdata set {{ |} | | | | {| }} - myreport topcapsep set {=+ *= + *= + *= + *= + *= +=} - myreport data set {{ |} | | | | {| }} - myreport bottom set {-+ - + - + - + - + - +-} - myreport top enable - myreport topcapsep enable - myreport bottom enable - myreport tcaption 1 - myreport sizes {5 dyn 7 7 5} - myreport pad 0 right - myreport pad 1 both - myreport pad 2 both - myreport pad 3 both - myreport pad 4 both - myreport justify 0 center - myreport justify 1 right - myreport justify 2 right - myreport justify 3 right - myreport justify 3 right - - myreport printmatrix2channel mymatrix $f - myreport destroy - mymatrix destroy - close $f - - ::tcltest::viewFile rep4 -} {-+-/-/-/+-/-/-/-/-/-/-/-/-/-/-/-/+-/-/-/-/-+-/-/-/-/-+-/-/-/-+- - | 000 | VERSIONS: | 2:8.4a3 | 1:8.4a3 | .4a3% | -=+*=*=*=+*=*=*=*=*=*=*=*=*=*=*=*=+*=*=*=*=*+*=*=*=*=*+*=*=*=*+= - | 001 | CATCH return ok | 7 | 13 | 53.85 | - | 002 | CATCH return error | 68 | 91 | 74.73 | - | 003 | CATCH no catch used | 7 | 14 | 50.00 | - | 004 | IF if true numeric | 12 | 33 | 36.36 | - | 005 | IF elseif true numeric | 15 | 47 | 31.91 | --+------+------------------------+---------+---------+-------+-} - -test report-28.9 {formatting, rowheight > 1} { - ::struct::matrix mymatrix - mymatrix add columns 5 - mymatrix add row {000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} - mymatrix add row {001 {CATCH return ok} 7 13 53.85} - mymatrix add row {002 {CATCH return error} 68 91 74.73} - mymatrix add row {003 {CATCH no catch used} 7 14 50.00} - mymatrix add row {004 {IF if true numeric} 12 33 36.36} - mymatrix add row {005 {IF elseif -true numeric} 15 47 31.91} - - set f [open rep5 w] - report myreport 5 style captionedtable 1 - myreport printmatrix2channel mymatrix $f - myreport destroy - mymatrix destroy - close $f - - ::tcltest::viewFile rep5 -} {+---+-------------------+-------+-------+--------+ -|000|VERSIONS: |2:8.4a3|1:8.4a3|1:8.4a3%| -+---+-------------------+-------+-------+--------+ -|001|CATCH return ok |7 |13 |53.85 | -|002|CATCH return error |68 |91 |74.73 | -|003|CATCH no catch used|7 |14 |50.00 | -|004|IF if true numeric |12 |33 |36.36 | -|005|IF elseif |15 |47 |31.91 | -| |true numeric | | | | -+---+-------------------+-------+-------+--------+} - - - -test report-28.10 {formatting, rowheight > 1} { - ::struct::matrix mymatrix - mymatrix add columns 5 - mymatrix add row {000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} - mymatrix add row {000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} - mymatrix add row {001 {CATCH return ok} 7 13 53.85} - mymatrix add row {002 {CATCH return error} 68 91 74.73} - mymatrix add row {003 {CATCH no catch used} 7 14 50.00} - mymatrix add row {004 {IF if true numeric} 12 33 36.36} - mymatrix add row {005 {IF elseif -true numeric} 15 47 31.91} - - set f [open rep5 w] - report myreport 5 style captionedtable 2 - myreport printmatrix2channel mymatrix $f - myreport destroy - mymatrix destroy - close $f - - ::tcltest::viewFile rep5 -} {+---+-------------------+-------+-------+--------+ -|000|VERSIONS: |2:8.4a3|1:8.4a3|1:8.4a3%| -|000|VERSIONS: |2:8.4a3|1:8.4a3|1:8.4a3%| -+---+-------------------+-------+-------+--------+ -|001|CATCH return ok |7 |13 |53.85 | -|002|CATCH return error |68 |91 |74.73 | -|003|CATCH no catch used|7 |14 |50.00 | -|004|IF if true numeric |12 |33 |36.36 | -|005|IF elseif |15 |47 |31.91 | -| |true numeric | | | | -+---+-------------------+-------+-------+--------+} - -test report-28.11 {formatting, rowheight > 1} { - ::struct::matrix mymatrix - mymatrix add columns 5 - mymatrix add row {000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} - mymatrix add row {000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} - mymatrix add row {001 {CATCH return ok} 7 13 53.85} - mymatrix add row {002 {CATCH return error} 68 91 74.73} - mymatrix add row {003 {CATCH no catch used} 7 14 50.00} - mymatrix add row {004 {IF if true numeric} 12 33 36.36} - mymatrix add row {005 {IF elseif -true numeric} 15 47 31.91} - mymatrix add row {000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} - mymatrix add row {000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} - - set f [open rep5 w] - report myreport 5 style bdcaptionedtable 2 - myreport printmatrix2channel mymatrix $f - myreport destroy - mymatrix destroy - close $f - - ::tcltest::viewFile rep5 -} {+---+-------------------+-------+-------+--------+ -|000|VERSIONS: |2:8.4a3|1:8.4a3|1:8.4a3%| -+---+-------------------+-------+-------+--------+ -|000|VERSIONS: |2:8.4a3|1:8.4a3|1:8.4a3%| -+---+-------------------+-------+-------+--------+ -|001|CATCH return ok |7 |13 |53.85 | -|002|CATCH return error |68 |91 |74.73 | -|003|CATCH no catch used|7 |14 |50.00 | -|004|IF if true numeric |12 |33 |36.36 | -|005|IF elseif |15 |47 |31.91 | -| |true numeric | | | | -+---+-------------------+-------+-------+--------+ -|000|VERSIONS: |2:8.4a3|1:8.4a3|1:8.4a3%| -+---+-------------------+-------+-------+--------+ -|000|VERSIONS: |2:8.4a3|1:8.4a3|1:8.4a3%| -+---+-------------------+-------+-------+--------+} - -test report-28.12 {formatting, rowheight > 1} { - ::struct::matrix mymatrix - mymatrix add columns 5 - mymatrix add row {000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} - mymatrix add row {000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} - mymatrix add row {001 {CATCH return ok} 7 13 53.85} - mymatrix add row {002 {CATCH return error} 68 91 74.73} - mymatrix add row {003 {CATCH no catch used} 7 14 50.00} - mymatrix add row {004 {IF if true numeric} 12 33 36.36} - mymatrix add row {005 {IF elseif -true numeric} 15 47 31.91} - mymatrix add row {000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} - mymatrix add row {000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} - - report myreport 5 style bdcaptionedtable 2 - set result [myreport printmatrix mymatrix] - myreport destroy - mymatrix destroy - - set result -} {+---+-------------------+-------+-------+--------+ -|000|VERSIONS: |2:8.4a3|1:8.4a3|1:8.4a3%| -+---+-------------------+-------+-------+--------+ -|000|VERSIONS: |2:8.4a3|1:8.4a3|1:8.4a3%| -+---+-------------------+-------+-------+--------+ -|001|CATCH return ok |7 |13 |53.85 | -|002|CATCH return error |68 |91 |74.73 | -|003|CATCH no catch used|7 |14 |50.00 | -|004|IF if true numeric |12 |33 |36.36 | -|005|IF elseif |15 |47 |31.91 | -| |true numeric | | | | -+---+-------------------+-------+-------+--------+ -|000|VERSIONS: |2:8.4a3|1:8.4a3|1:8.4a3%| -+---+-------------------+-------+-------+--------+ -|000|VERSIONS: |2:8.4a3|1:8.4a3|1:8.4a3%| -+---+-------------------+-------+-------+--------+ -} - -::tcltest::cleanupTests DELETED modules/sha1/ChangeLog Index: modules/sha1/ChangeLog ================================================================== --- modules/sha1/ChangeLog +++ /dev/null @@ -1,63 +0,0 @@ -2003-04-10 Andreas Kupries - - * pkgIndex.tcl: - * sha1.man: - * sha1.tcl: Fixed bug #614591. Set version of the package to to - 1.0.3 - -2003-03-24 Andreas Kupries - - * sha1.tcl (sha1::sha1): Applied patch #637770 submitted by Donal - Fellows to fix problems on Mac OS X machines. This possibly - related to 64/32 bit arithmetic. See changes by Don Porter - below. - -2003-02-07 Pat Thoyts - - * sha1.tcl: Check that we have a _working_ C implementation. - -2003-02-06 David N. Welton - - * sha1.tcl (sha1::time): Use 'lindex' instead of regexp to fetch - number from 'time' results. - -2002-02-20 Don Porter - - * sha1.tcl (sha1): Force 32-bit register arithmetic so that - the right answers are computed even on 64-bit platforms. [446997] - -2002-02-20 Donal K. Fellows - - * sha1.tcl (initK,sha1): Force 32-bit interpretation of constants - larger than INT_MAX on 32-bit processors, due to TIP#72. - -2002-02-07 Andreas Kupries - - * Version up to 1.0.2 to differentiate development from the - version in the tcllib 1.2 release. - - * sha1.tcl: Adding -- to hex/sha1 commands to prevent - misinterpretation of data if starting with -. - -2001-10-16 Andreas Kupries - - * sha1.n: - * sha1.tcl: - * pkgIndex.tcl: Version up to 1.0.1 - -2001-08-20 Andreas Kupries - - * sha1.test: Fixed broken error messages for 8.4. Using - [tcltest::getErrorMessage] now to get the correct message for - all versions of the core. Bug [440051] reported by Larry Virden. - -2001-06-22 Andreas Kupries - - * sha1.tcl: Fixed dubious code reported by frink. - -2001-06-21 Andreas Kupries - - * New module, 'sha1'. The code is Don Libes's - sha1pure, with Donal K. Fellows's patches to speed it up, and - extended with a soft dependency on Trf to allow higher speed if - the environment is right. DELETED modules/sha1/pkgIndex.tcl Index: modules/sha1/pkgIndex.tcl ================================================================== --- modules/sha1/pkgIndex.tcl +++ /dev/null @@ -1,12 +0,0 @@ -# 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. - -if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded sha1 1.0.3 [list source [file join $dir sha1.tcl]] DELETED modules/sha1/sha1.man Index: modules/sha1/sha1.man ================================================================== --- modules/sha1/sha1.man +++ /dev/null @@ -1,40 +0,0 @@ -[manpage_begin sha1 n 1.0.3] -[moddesc {sha1 hash}] -[titledesc {Perform sha1 hashing}] -[require Tcl 8.2] -[require sha1 [opt 1.0.3]] -[description] -[para] - -This package provides commands to compute a SHA1 digests of arbitrary -messages. - -[section COMMANDS] -[list_begin definitions] -[call [cmd ::sha1::sha1] [arg msg]] - -The command takes a message and returns the SHA1 digest of this message -as a hexadecimal string. - -[call [cmd ::sha1::hmac] [arg key] [arg text]] - -The command takes a key string and a text and returns the hmac of the - -[list_end] - -[section EXAMPLES] - -[para] -[example { -% sha1::sha1 "hello world" -2aae6c35c94fcfb415dbe95f408b9ce91ee846ed -}] - -[para] -[example { -% sha1::hmac "our little secret" "hello world" -a7ed9d62819b9788e22171d9108a00c370104526 -}] - -[keywords sha1 hashing security] -[manpage_end] DELETED modules/sha1/sha1.n Index: modules/sha1/sha1.n ================================================================== --- modules/sha1/sha1.n +++ /dev/null @@ -1,48 +0,0 @@ -'\" -'\" Copyright (c) 2001 ActiveState Tool Corp. -'\" All rights reserved. -'\" -'\" RCS: @(#) $Id: sha1.n,v 1.5 2002/02/08 06:05:20 andreas_kupries Exp $ -'\" -.so man.macros -.TH sha1 n 1.0.2 Sha1 "sha1 hash" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -::sha1::sha1 \- Perform sha1 hashing -.SH SYNOPSIS -\fBpackage require Tcl 8.2\fR -.sp -\fBpackage require sha1 ?1.0.2?\fR -.sp -\fB::sha1::sha1\fR \fImsg\fR? -.sp -\fB::sha1::hmac\fR \fIkey text\fR -.sp -.BE -.SH DESCRIPTION -.PP -This package provides commands to compute a SHA1 digests of arbitrary -messages. -.SH COMMANDS -.TP -\fB::sha1::sha1\fR \fImsg\fR -The command takes a message and returns the SHA1 digest of this message -as a hexadecimal string. -.TP -\fB::sha1::hmac\fR \fIkey text\fR -The command takes a key string and a text and returns the hmac of the -text under the chosen key as a hexadecimal string. -.SH EXAMPLES -.PP -.CS -% sha1::sha1 "hello world" -2aae6c35c94fcfb415dbe95f408b9ce91ee846ed -.CE -.PP -.CS -% sha1::hmac "our little secret" "hello world" -a7ed9d62819b9788e22171d9108a00c370104526 -.CE -.SH KEYWORDS -sha1, hashing, security DELETED modules/sha1/sha1.tcl Index: modules/sha1/sha1.tcl ================================================================== --- modules/sha1/sha1.tcl +++ /dev/null @@ -1,331 +0,0 @@ -################################################## -# -# sha1.tcl - SHA1 in Tcl -# Author: Don Libes , May 2001 -# Version 1.0.3 -# -# SHA1 defined by FIPS 180-1, "The SHA1 Message-Digest Algorithm", -# http://www.itl.nist.gov/fipspubs/fip180-1.htm -# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication" -# -# Some of the comments below come right out of FIPS 180-1; That's why -# they have such peculiar numbers. In addition, I have retained -# original syntax, etc. from the FIPS. All remaining bugs are mine. -# -# HMAC implementation by D. J. Hagberg and -# is based on C code in FIPS 2104. -# -# For more info, see: http://expect.nist.gov/sha1pure -# -# - Don -################################################## - -### Code speedups by Donal Fellows who may well -### have added some extra bugs of his own... :^) - -### Changed the code to use Trf if this package is present on the -### system requiring the sha1 package. Analogous to md5. - -package require Tcl 8.2 -namespace eval ::sha1 { -} - -if {![catch {package require Trf 2.0}] && ![catch {::sha1 -- test}]} { - # Trf is available, so implement the functionality provided here - # in terms of calls to Trf for speed. - - proc ::sha1::sha1 {msg} { - string tolower [::hex -mode encode -- [::sha1 -- $msg]] - } - - # hmac: hash for message authentication - - # SHA1 of Trf and SHA1 as defined by this package have slightly - # different results. Trf returns the digest in binary, here we get - # it as hex-string. In the computation of the HMAC the latter - # requires back conversion into binary in some places. With Trf we - # can use omit these. (Not all, the first place must not the changed, - # see [x] - - proc ::sha1::hmac {key text} { - # if key is longer than 64 bytes, reset it to SHA1(key). If shorter, - # pad it out with null (\x00) chars. - set keyLen [string length $key] - if {$keyLen > 64} { - set key [binary format H32 [sha1 $key]] - # [x] set key [::sha1 -- $key] - set keyLen [string length $key] - } - - # ensure the key is padded out to 64 chars with nulls. - set padLen [expr {64 - $keyLen}] - append key [binary format "a$padLen" {}] - - # Split apart the key into a list of 16 little-endian words - binary scan $key i16 blocks - - # XOR key with ipad and opad values - set k_ipad {} - set k_opad {} - foreach i $blocks { - append k_ipad [binary format i [expr {$i ^ 0x36363636}]] - append k_opad [binary format i [expr {$i ^ 0x5c5c5c5c}]] - } - - # Perform inner sha1, appending its results to the outer key - append k_ipad $text - #append k_opad [binary format H* [sha1 $k_ipad]] - append k_opad [::sha1 -- $k_ipad] - - # Perform outer sha1 - #sha1 $k_opad - string tolower [::hex -mode encode -- [::sha1 -- $k_opad]] - } - -} else { - # Without Trf use the all-tcl implementation by Don Libes. - - namespace eval ::sha1 { - variable K - - proc initK {} { - variable K {} - foreach t { - 0x5A827999 - 0x6ED9EBA1 - 0x8F1BBCDC - 0xCA62C1D6 - } { - for {set i 0} {$i < 20} {incr i} { - lappend K [expr {int($t)}] - } - } - } - initK - } - - # test sha1 - # - # This proc is not necessary during runtime and may be omitted if you - # are simply inserting this file into a production program. - # - proc ::sha1::test {} { - foreach {msg expected} { - "abc" - "a9993e364706816aba3e25717850c26c9cd0d89d" - "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" - "84983e441c3bd26ebaae4aa1f95129e5e54670f1" - "[string repeat a 1000000]" - "34aa973cd4c4daa4f61eeb2bdbad27316534016f" - } { - puts "testing: sha1 \"$msg\"" - set msg [subst $msg] - set msgLen [string length $msg] - if {$msgLen > 10000} { - puts "warning: msg length = $msgLen; this may take a while . . ." - } - set computed [sha1 $msg] - puts "expected: $expected" - puts "computed: $computed" - if {0 != [string compare $computed $expected]} { - puts "FAILED" - } else { - puts "SUCCEEDED" - } - } - } - - # time sha1 - # - # This proc is not necessary during runtime and may be omitted if you - # are simply inserting this file into a production program. - # - proc ::sha1::time {} { - foreach len {10 50 100 500 1000 5000 10000} { - set time [::time {sha1 [format %$len.0s ""]} 10] - set msec [lindex $time 0] - puts "input length $len: [expr {$msec/1000}] milliseconds per interation" - } - } - - proc ::sha1::sha1 {msg} { - variable K - - # - # 4. MESSAGE PADDING - # - - # pad to 512 bits (512/8 = 64 bytes) - - set msgLen [string length $msg] - - # last 8 bytes are reserved for msgLen - # plus 1 for "1" - - set padLen [expr {56 - $msgLen%64}] - if {$msgLen % 64 >= 56} { - incr padLen 64 - } - - # 4a. and b. append single 1b followed by 0b's - append msg [binary format "a$padLen" \200] - - # 4c. append 64-bit length - # Our implementation obviously limits string length to 32bits. - append msg \0\0\0\0[binary format "I" [expr {8*$msgLen}]] - - # - # 7. COMPUTING THE MESSAGE DIGEST - # - - # initial H buffer - - set H0 [expr {int(0x67452301)}] - set H1 [expr {int(0xEFCDAB89)}] - set H2 [expr {int(0x98BADCFE)}] - set H3 [expr {int(0x10325476)}] - set H4 [expr {int(0xC3D2E1F0)}] - - # - # process message in 16-word blocks (64-byte blocks) - # - - # convert message to array of 32-bit integers - # each block of 16-words is stored in M($i,0-16) - - binary scan $msg I* words - set blockLen [llength $words] - - for {set i 0} {$i < $blockLen} {incr i 16} { - # 7a. Divide M[i] into 16 words W[0], W[1], ... - set W [lrange $words $i [expr {$i+15}]] - - # 7b. For t = 16 to 79 let W[t] = .... - set t 16 - set t3 12 - set t8 7 - set t14 1 - set t16 -1 - for {} {$t < 80} {incr t} { - set x [expr {[lindex $W [incr t3]] ^ [lindex $W [incr t8]] ^ \ - [lindex $W [incr t14]] ^ [lindex $W [incr t16]]}] - lappend W [expr {($x << 1) | (($x >> 31) & 1)}] - } - - # 7c. Let A = H[0] .... - set A $H0 - set B $H1 - set C $H2 - set D $H3 - set E $H4 - - # 7d. For t = 0 to 79 do - for {set t 0} {$t < 20} {incr t} { - set TEMP [expr {(($A << 5) | (($A >> 27) & 0x1f)) + \ - (($B & $C) | ((~$B) & $D)) \ - + $E + [lindex $W $t] + [lindex $K $t]}] - set E $D - set D $C - set C [expr {($B << 30) | (($B >> 2) & 0x3fffffff)}] - set B $A - set A $TEMP - } - for {} {$t<40} {incr t} { - set TEMP [expr {(($A << 5) | (($A >> 27) & 0x1f)) + \ - ($B ^ $C ^ $D) \ - + $E + [lindex $W $t] + [lindex $K $t]}] - set E $D - set D $C - set C [expr {($B << 30) | (($B >> 2) & 0x3fffffff)}] - set B $A - set A $TEMP - } - for {} {$t<60} {incr t} { - set TEMP [expr {(($A << 5) | (($A >> 27) & 0x1f)) + \ - (($B & $C) | ($B & $D) | ($C & $D)) \ - + $E + [lindex $W $t] + [lindex $K $t]}] - set E $D - set D $C - set C [expr {($B << 30) | (($B >> 2) & 0x3fffffff)}] - set B $A - set A $TEMP - } - for {} {$t<80} {incr t} { - set TEMP [expr {(($A << 5) | (($A >> 27) & 0x1f)) + \ - ($B ^ $C ^ $D) \ - + $E + [lindex $W $t] + [lindex $K $t]}] - set E $D - set D $C - set C [expr {($B << 30) | (($B >> 2) & 0x3fffffff)}] - set B $A - set A $TEMP - } - - set H0 [expr {int(($H0 + $A) & 0xffffffff)}] - set H1 [expr {int(($H1 + $B) & 0xffffffff)}] - set H2 [expr {int(($H2 + $C) & 0xffffffff)}] - set H3 [expr {int(($H3 + $D) & 0xffffffff)}] - set H4 [expr {int(($H4 + $E) & 0xffffffff)}] - } - - return [format %0.8x%0.8x%0.8x%0.8x%0.8x $H0 $H1 $H2 $H3 $H4] - } - - ### These procedures are either inlined or replaced with a normal [format]! - # - #proc ::sha1::f {t B C D} { - # switch [expr {$t/20}] { - # 0 { - # expr {($B & $C) | ((~$B) & $D)} - # } 1 - 3 { - # expr {$B ^ $C ^ $D} - # } 2 { - # expr {($B & $C) | ($B & $D) | ($C & $D)} - # } - # } - #} - # - #proc ::sha1::byte0 {i} {expr {0xff & $i}} - #proc ::sha1::byte1 {i} {expr {(0xff00 & $i) >> 8}} - #proc ::sha1::byte2 {i} {expr {(0xff0000 & $i) >> 16}} - #proc ::sha1::byte3 {i} {expr {((0xff000000 & $i) >> 24) & 0xff}} - # - #proc ::sha1::bytes {i} { - # format %0.2x%0.2x%0.2x%0.2x [byte3 $i] [byte2 $i] [byte1 $i] [byte0 $i] - #} - - # hmac: hash for message authentication - proc ::sha1::hmac {key text} { - # if key is longer than 64 bytes, reset it to SHA1(key). If shorter, - # pad it out with null (\x00) chars. - set keyLen [string length $key] - if {$keyLen > 64} { - set key [binary format H32 [sha1 $key]] - set keyLen [string length $key] - } - - # ensure the key is padded out to 64 chars with nulls. - set padLen [expr {64 - $keyLen}] - append key [binary format "a$padLen" {}] - - # Split apart the key into a list of 16 little-endian words - binary scan $key i16 blocks - - # XOR key with ipad and opad values - set k_ipad {} - set k_opad {} - foreach i $blocks { - append k_ipad [binary format i [expr {$i ^ 0x36363636}]] - append k_opad [binary format i [expr {$i ^ 0x5c5c5c5c}]] - } - - # Perform inner sha1, appending its results to the outer key - append k_ipad $text - append k_opad [binary format H* [sha1 $k_ipad]] - - # Perform outer sha1 - sha1 $k_opad - } -} - -package provide sha1 1.0.3 DELETED modules/sha1/sha1.test Index: modules/sha1/sha1.test ================================================================== --- modules/sha1/sha1.test +++ /dev/null @@ -1,70 +0,0 @@ -# -*- tcl -*- -# sha1.test: tests for the sha1 commands -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 2001 by ActiveState Tool Corp. -# All rights reserved. -# -# RCS: @(#) $Id: sha1.test,v 1.2 2001/08/20 20:35:12 andreas_kupries Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -package require sha1 -if {[catch {package present Trf}]} { - puts "sha1 [package present sha1] (pure Tcl)" -} else { - puts "sha1 [package present sha1] (Trf based)" -} - - -test sha1-1.0 {sha1} { - catch {::sha1::sha1} result - set result -} [tcltest::getErrorMessage "::sha1::sha1" "msg" 0] - -test sha1-1.1 {sha1} { - catch {::sha1::hmac} result - set result -} [tcltest::getErrorMessage "::sha1::hmac" "key text" 0] - -test sha1-1.2 {sha1} { - catch {::sha1::hmac key} result - set result -} [tcltest::getErrorMessage "::sha1::hmac" "key text" 1] - - -foreach {n msg expected} { - 1 "abc" - "a9993e364706816aba3e25717850c26c9cd0d89d" - 2 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" - "84983e441c3bd26ebaae4aa1f95129e5e54670f1" -} { - test sha1-2.$n {sha1} { - ::sha1::sha1 $msg - } $expected ; # {} -} - -foreach {n key text expected} { - 1 "" "" "fbdb1d1b18aa6c08324b7d64b71fb76370690e1d" - 2 "foo" "hello" "4c883e9bc42763641bba04185d492de00de7ce2c" - 3 "bar" "world" "a905e79f51faa446cb5a3888b577e34577ef7fce" - 4 "key" "text" "369e2959eb49450338b212748f77d8ded74847bb" - 5 "sha1" "hmac" "2660aeeccf432596e56f8f8260de971322e8935b" - 6 "hmac" "sha1" "170523fd610da92dd4b4fb948a01a8365d66511a" - 7 "sha1" "sha1" "5154473317173f66212fc59365233ffd9cbaab94" - 8 "hmac" "hmac" "9e08393f6ac829c4385930ea38567dad582d958f" - 9 "01234567abcdefgh01234567abcdefgh01234567abcdefgh01234567abcdefgh==" "hello world" - "6541c34492618a052c12cb9f88fb795d97595b34" -} { - test sha1-3.$n {hmac} { - ::sha1::hmac $key $text - } $expected ; # {} -} - -::tcltest::cleanupTests DELETED modules/smtpd/ChangeLog Index: modules/smtpd/ChangeLog ================================================================== --- modules/smtpd/ChangeLog +++ /dev/null @@ -1,68 +0,0 @@ -2003-04-10 Andreas Kupries - - * smtpd.tcl: Fixed bug #614591. - -2003-01-25 Pat Thoyts - - * smtpd.tcl: Fix bug #674333: require Tcl version 8.3+ - (the mime package requires 8.3 therefore so do we.) - -2003-01-16 Andreas Kupries - - * smtpd.man: More semantic markup, less visual one. - -2003-01-02 Pat Thoyts - - * smtpd.tcl: Added exception catching to all channel comms. - Added some ESMTP option handling (rudimentary). - Added SMTP Transparency handling. (RFC 2821: 4.5.2) - Improved error messages for DATA command. - -2002-10-25 Pat Thoyts - - * smtpd.tcl: Implemented request #627960 to propagate the network - interface name into the server messages. Added a catch around - the deliver call and permit the deliver code to return SMTP - failure codes via ::errorCode. - -2002-10-08 Pat Thoyts - - * smtpd.tcl: Implemented feature request #531531. Added - -deliverMIME option to provide mail as a MIME token. - * smtpd.man: Updated for the new delivery option. - * tk_smtpdMIME: New example using the -deliverMIME option. - -2002-09-25 David N. Welton - - * smtpd.man: Fixed documentation error in deliver example. - -2002-09-19 David N. Welton - - * smtpd.tcl (smtpd::service): Added Andreas' suggested changes to - avoid a bgerror caused by a broken pipe. - -2002-09-16 Pat Thoyts - - * smtpd.tcl: fixed bug #609835 to cope with multiple addresses in - MAIL and RCPT commands without raising exception. - -2002-04-10 Andreas Kupries - - * smtpd.man: Added doctools manpage. - -2001-12-10 Pat Thoyts - - * smtpd.tcl (smtpd::gmtoffset): Fixed for cases where the hour - offset is invalid. - -2001-11-19 Andreas Kupries - - * Moved example.tcl to the standard location in - 'tcllib/examples/smtpd'. Also renamed it to "tk_smtpd". - -2001-11-06 Pat Thoyts - - * smtpd.tcl: Tcl SMTP server package. - * smtpd.n: Manual page for the Tcl SMTP server. - * example.tcl: Simple demo of server use and authentication. - DELETED modules/smtpd/clients/README Index: modules/smtpd/clients/README ================================================================== --- modules/smtpd/clients/README +++ /dev/null @@ -1,13 +0,0 @@ -These files are mail sending test scripts written in various scripting -languages. The purpose of these is to check that our SMTPd -inter-operates successfully with everyone else's SMTP client software. - -Feel free to add a test script for your favourite other language - or to -improve the usage of any of the current languages. - -mail-test.pl - Perl test script -mail-test.py - Python test -mail-test.rb - Ruby test -mail-test.php - PHP test (requires some php.ini configuration) -php.ini - PHP ini file (default for Windows installations) -mail-test.tcl - and of course, a Tcl client! DELETED modules/smtpd/clients/mail-test.php Index: modules/smtpd/clients/mail-test.php ================================================================== --- modules/smtpd/clients/mail-test.php +++ /dev/null @@ -1,21 +0,0 @@ -"; - - $body = "This is a sample message send from PHP.\r\n"; - $body .= "As always, let us check the transparency function:\r\n"; - $body .= ". <-- there should be a dot there.\r\n"; - $body .= "Bye"; - - mail($rcpt, $subject, $body, $hdrs); - -?> DELETED modules/smtpd/clients/mail-test.pl Index: modules/smtpd/clients/mail-test.pl ================================================================== --- modules/smtpd/clients/mail-test.pl +++ /dev/null @@ -1,119 +0,0 @@ -# mail-test.pl - Copyright (C) 2003 Pat Thoyts -# -# Send some mail from Perl. -# -# This sends two messages, one valid and one without a recipient using the -# SMTP protocol. -# -# usage: ./mail-test.pl smtpd-host ?smtpd-port? -# -# ------------------------------------------------------------------------- - -use diagnostics; -use strict; - -use Net::SMTP; -use Sys::Hostname; - -my ($smtp_smart_host, $smtp_smart_port) = (shift, shift); - -$smtp_smart_host = 'localhost' if (!$smtp_smart_host); -$smtp_smart_port = 25 if (!$smtp_smart_port); - -my $smtp_default_from = 'postmaster@' . hostname(); -my $smtp_timeout = 120; -my $smtp_log_mail = 0; -my $smtp_debug = 1; - -my $sender_address = 'Perl Test Script '; -my $recipient_address = 'Tcl Server '; - -print "Sending valid message\n"; -test_ok(); -print "Sending invalid message\n"; -test_no_rcpt(); - -sub test_no_rcpt { - my $header = 'From: ' . $sender_address . "\n"; - $header .= 'Subject: perl test' . "\n"; - my $message = <new($smtp_smart_host, - Hello => hostname(), - Port => $smtp_smart_port, - Timeout => $smtp_timeout, - Debug => $smtp_debug) - || die "SMTP failed to connect: $!"; - - $smtp->mail($from, (Size=>length($msg), Bits=>'8')); - $smtp->to(@rcpts); - if ($smtp->data()) { # start sending data; - $smtp->datasend($msg); # send the message - $smtp->dataend(); # finished sending data - } else { - $smtp->reset(); - } - $smtp->quit; # end of session - - if ( $smtp_log_mail ) { - if ( open(MAILLOG, ">> data/maillog") ) { - print MAILLOG "From $from at ", localtime() . "\n"; - print MAILLOG "To: " . join(@rcpts, ',') . "\n"; - print MAILLOG $msg . "\n\n"; - close(MAILLOG); - } - } -} - -# ------------------------------------------------------------------------- DELETED modules/smtpd/clients/mail-test.py Index: modules/smtpd/clients/mail-test.py ================================================================== --- modules/smtpd/clients/mail-test.py +++ /dev/null @@ -1,53 +0,0 @@ -# Python mail sample - -import sys, smtplib - - -class SMTPTest: - def __init__(self, interface='localhost', port=25): - self.svr = smtplib.SMTP(interface, port) - self.svr.set_debuglevel(1) - - def sendmail(self, sender, recipient, message): - try: - self.svr.sendmail(sender, recipient, message) - except: - print "oops" - - def quit(self): - self.svr.quit() - -def test(): - sndr = "python-script-test@localhost" - rcpt = "tcllib-test@localhost" - mesg = """From: Python Mailer -To: Tcllib Tester -Date: Fri Dec 20 14:20:49 2002 -Subject: test from python - -This is a sample message from Python. -Hope it's OK -Check transparency: -. <- there should be one dot here. -Done -""" - # Connect - svr = SMTPTest('localhost') - - # Try normal message - svr.sendmail(sndr, rcpt, mesg) - - # should fail: invalid recipient. - svr.sendmail(sndr, "", mesg) - - # should fail: NULL recipient only valid for sender - svr.sendmail(sndr, "<>", mesg) - - # should be ok: null sender (permitted for daemon responses) - svr.sendmail("<>", rcpt, mesg) - - svr.quit() - - -if __name__ == '__main__': - test() DELETED modules/smtpd/clients/mail-test.rb Index: modules/smtpd/clients/mail-test.rb ================================================================== --- modules/smtpd/clients/mail-test.rb +++ /dev/null @@ -1,16 +0,0 @@ -require 'net/smtp' - -sndr = 'ruby-test-script@localhost' -rcpt = 'tcllib-test@localhost' -msg = 'From: Ruby -To: SMTPD -Subject: Testing from Ruby - -This is a sample message send from Ruby. -As always, let us check the transparency function: -. <-- there should be a dot there. -Bye' - -Net::SMTP.start('localhost', 25) do |smtp| - smtp.send_mail msg, sndr, rcpt -end DELETED modules/smtpd/clients/mail-test.tcl Index: modules/smtpd/clients/mail-test.tcl ================================================================== --- modules/smtpd/clients/mail-test.tcl +++ /dev/null @@ -1,15 +0,0 @@ -package require mime -package require smtp - -set sndr "tcl-test-script@localhost" -set rcpt "tcllib-test@localhost" -set msg "This is a sample message send from Tcl.\nAs\ -always, let us check the transparency function:\n. <-- there\ -should be a dot there.\nBye" - -set tok [mime::initialize -canonical text/plain -encoding 7bit -string $msg] -mime::setheader $tok Subject "Testing from Tcl" -smtp::sendmessage $tok -servers localhost \ - -header [list To $rcpt] \ - -header [list From $sndr] - DELETED modules/smtpd/clients/php.ini Index: modules/smtpd/clients/php.ini ================================================================== --- modules/smtpd/clients/php.ini +++ /dev/null @@ -1,56 +0,0 @@ -[PHP] -engine = On -short_open_tag = On -asp_tags = Off -precision = 14 -y2k_compliance = Off -output_buffering = 4096 -output_handler = -zlib.output_compression = Off -implicit_flush = Off -allow_call_time_pass_reference = Off -safe_mode = Off -safe_mode_gid = Off -safe_mode_include_dir = -safe_mode_exec_dir = -safe_mode_allowed_env_vars = PHP_ -safe_mode_protected_env_vars = LD_LIBRARY_PATH -disable_functions = -expose_php = On -max_execution_time = 30 ; Maximum execution time of each script, in seconds -memory_limit = 8M ; Maximum amount of memory a script may consume (8MB) -error_reporting = E_ALL -display_errors = Off -display_startup_errors = Off -log_errors = On -track_errors = Off -warn_plus_overloading = Off -variables_order = "GPCS" -register_globals = Off -register_argc_argv = Off -post_max_size = 8M -gpc_order = "GPC" -magic_quotes_gpc = Off -magic_quotes_runtime = Off -magic_quotes_sybase = Off -auto_prepend_file = -auto_append_file = -default_mimetype = "text/html" -doc_root = -user_dir = -extension_dir = ./ -enable_dl = On -file_uploads = On -upload_max_filesize = 2M -allow_url_fopen = On -[mail function] -; Win32 only -SMTP = localhost -sendmail_from = postmaster@localhost - -; For Unix only. You may supply arguments as well (default: "sendmail -t -i"). -;sendmail_path = - -; Local Variables: -; tab-width: 4 -; End: DELETED modules/smtpd/pkgIndex.tcl Index: modules/smtpd/pkgIndex.tcl ================================================================== --- modules/smtpd/pkgIndex.tcl +++ /dev/null @@ -1,12 +0,0 @@ -# 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. - -if {![package vsatisfies [package provide Tcl] 8.3]} {return} -package ifneeded smtpd 1.2.1 [list source [file join $dir smtpd.tcl]] DELETED modules/smtpd/smtpd.man Index: modules/smtpd/smtpd.man ================================================================== --- modules/smtpd/smtpd.man +++ /dev/null @@ -1,274 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[manpage_begin smtpd n 1.2.1] -[copyright {Pat Thoyts }] -[moddesc {Tcl SMTP Server Package}] -[titledesc {Tcl SMTP server implementation}] -[require Tcl 8.3] -[require smtpd [opt 1.2.1]] -[description] -[para] - -The [package smtpd] package provides a simple Tcl-only server library -for the Simple Mail Transfer Protocol as described in RFC 821 and RFC -2821. By default the server will bind to the default network address -and the standard SMTP port (25). - -[para] - -This package was designed to permit testing of Mail User Agent code -from a developers workstation. [emph "It does not attempt to deliver \ -mail to your mailbox." ] Instead users of this package are expected to -write a procedure that will be called when mail arrives. Once this -procedure returns, the server has nothing further to do with the mail. - -[section SECURITY] - -On Unix platforms binding to the SMTP port requires root privileges. I -would not recommend running any script-based server as root unless -there is some method for dropping root privileges immediately after -the socket is bound. Under Windows platforms, it is not necessary to -have root or administrator privileges to bind low numbered -sockets. However, security on these platforms is weak anyway. - -[para] - -In short, this code should probably not be used as a permanently -running Mail Transfer Agent on an Internet connected server, even -though we are careful not to evaluate remote user input. There are -many other well tested and security audited programs that can be used -as mail servers for internet connected hosts. - -[section COMMANDS] - -[list_begin definitions] - -[call [cmd ::smtpd::start] [opt [arg myaddr]] [opt [arg port]]] - -Start the service listening on [arg port] or the default port 25. If -[arg myaddr] is given as a domain-style name or numerical -dotted-quad IP address then the server socket will be bound to that -network interface. By default the server is bound to all network -interfaces. For example: - -[nl] - -[example { - set sock [::smtpd::start [info hostname] 0] -}] - -[nl] - -will bind to the hosts internet interface on the first available port. - -[nl] - -At present the package only supports a single instance of a SMTP -server. This could be changed if required at the cost of making the -package a little more complicated to read. If there is a good reason -for running multiple SMTP services then it will only be necessary to -fix the [var options] array and the [var ::smtpd::stopped] variable -usage. - -[nl] - -As the server code uses [cmd fileevent](n) handlers to process the -input on sockets you will need to run the event loop. This means -either you should be running from within [syscmd wish](1) or you -should [cmd vwait](n) on the [var ::smtpd::stopped] variable which is -set when the server is stopped. - -[call [cmd ::smtpd::stop]] - -Halt the server and release the listening socket. If the server has -not been started then this command does nothing. - -The [var ::smtpd::stopped] variable is set for use with - -[cmd vwait](n). - -[nl] - -It should be noted that stopping the server does not disconnect any -currently active sessions as these are operating over an independent -channel. Only explicitly tracking and closing these sessions, or -exiting the server process will close down all the running -sessions. This is similar to the usual unix daemon practice where the -server performs a [syscmd fork](2) and the client session continues on -the child process. - -[call [cmd ::smptd::configure] [opt "[arg option] [arg value]"] [opt "[arg option] [arg value] [arg ...]"]] - -Set configuration options for the SMTP server. Most values are the -name of a callback procedure to be called at various points in the -SMTP protocol. See the [sectref CALLBACKS] section for details of the -procedures. - -[list_begin definitions] - -[lst_item "[option -validate_host] [arg proc]"] - -Callback to authenticate new connections based on the ip-address of -the client. - -[lst_item "[option -validate_sender] [arg proc]"] - -Callback to authenticate new connections based on the senders email -address. - -[lst_item "[option -validate_recipient] [arg proc]"] - -Callback to validate and authorize a recipient email address - -[lst_item "[option -deliverMIME] [arg proc]"] - -Callback used to deliver mail as a mime token created by the tcllib -[package mime] package. - -[lst_item "[option -deliver] [arg proc]"] - -Callback used to deliver email. This option has no effect if -the [option -deliverMIME] option has been set. - -[list_end] - -[call [cmd ::smtpd::cget] [opt [arg option]]] - -If no [arg option] is specified the command will return a list of all -options and their current values. If an option is specified it will -return the value of that option. - -[list_end] - -[section CALLBACKS] - -[list_begin definitions] -[lst_item "[cmd validate_host] callback"]] - -This procedure is called with the clients ip address as soon as a -connection request has been accepted and before any protocol commands -are processed. If you wish to deny access to a specific host then an -error should be returned by this callback. For example: - -[nl] -[example { - proc validate_host {ipnum} { - if {[string match "192.168.1.*" $ipnum]} { - error "go away!" - } - } -}] -[nl] - -If access is denied the client will receive a standard message that -includes the text of your error, such as: - -[nl] -[example { - 550 Access denied: I hate you. -}] -[nl] - -As per the SMTP protocol, the connection is not closed but we wait for -the client to send a QUIT command. Any other commands cause a - -[const {503 Bad Sequence}] error. - -[lst_item "[cmd validate_sender] callback"]] - -The validate_sender callback is called with the senders mail address -during processing of a MAIL command to allow you to accept or reject -mail based upon the declared sender. To reject mail you should throw -an error. For example, to reject mail from user "denied": - -[nl] -[example { - proc validate_sender {address} { - eval array set addr \\ - [mime::parseaddress $address] - if {[string match "denied" $addr(local)]} { - error "mailbox $addr(local) denied" - } - return - } -}] - -[nl] - -The content of any error message will not be passed back to the client. - -[lst_item "[cmd validate_recipient] callback"]] - -The validate_recipient callback is similar to the validate_sender -callback and permits you to verify a local mailbox and accept mail for -a local user address during RCPT command handling. To reject mail, -throw an error as above. The error message is ignored. - -[lst_item "[cmd deliverMIME] callback"]] - -The deliverMIME callback is called once a mail message has been -successfully passed to the server. A mime token is constructed from -the sender, recipients and data and the users procedure it called with -this single argument. When the call returns, the mime token is cleaned -up so if the user wishes to preserve the data she must make a copy. - -[nl] -[example { - proc deliverMIME {token} { - set sender [lindex [mime::getheader $token From] 0] - set recipients [lindex [mime::getheader $token To] 0] - set mail "From $sender [clock format [clock seconds]]" - append mail "\n" [mime::buildmessage $token] - puts $mail - } -}] - -[lst_item "[cmd deliver] callback"]] - -The deliver callback is called once a mail message has been -successfully passed to the server and there is no -deliverMIME option -set. The procedure is called with the sender, a list of recipients and -the text of the mail as a list of lines. For example: - -[nl] -[example { - proc deliver {sender recipients data} { - set mail "From $sender \ - [clock format [clock seconds]]" - append mail "\n" [join $data "\n"] - puts "$mail" - } -}] -[nl] - -Note that the DATA command will return an error if no sender or -recipient has yet been defined. - -[list_end] - -[section VARIABLES] - -[list_begin definitions] - -[lst_item [var ::smtpd::stopped]] - -This variable is set to [const true] during the [cmd ::smtpd::stop] -command to permit the use of the [cmd vwait](n) command. - -[comment ::smtpd::postmaster] -[comment {The e-mail address of the person that is the contact for the server.}] - -[list_end] - -[section AUTHOR] - -Written by Pat Thoyts [uri mailto:patthoyts@users.sourceforge.net]. - -[section LICENSE] - -This software 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 file -[file license.terms] for more details. - -[keywords smtpd smtp services {RFC 821} {RFC 2821} vwait socket] -[manpage_end] DELETED modules/smtpd/smtpd.n Index: modules/smtpd/smtpd.n ================================================================== --- modules/smtpd/smtpd.n +++ /dev/null @@ -1,221 +0,0 @@ -'\" -'\" Generated from smtpd.man by mpexpand with fmt.nroff -'\" -.so man.macros -.TH "smtpd" n 1.2.1 smtpd "Tcl SMTP Server Package" -.BS -.SH NAME -smtpd \- Tcl SMTP server implementation -'\" -*- tcl -*- doctools manpage -.SH "SYNOPSIS" -package require \fBTcl 8.3\fR -.sp -package require \fBsmtpd ?1.2?\fR -.sp -\fB::smtpd::start\fR ?\fImyaddr\fR? ?\fIport\fR?\fR -.sp -\fB::smtpd::stop\fR \fR -.sp -\fB::smptd::configure\fR ?\fIoption\fR \fIvalue\fR? ?\fIoption\fR \fIvalue\fR \fI...\fR?\fR -.sp -\fB::smtpd::cget\fR ?\fIoption\fR?\fR -.sp -.BE -.SH "DESCRIPTION" -.PP -The \fBsmtpd\fR package provides a simple Tcl-only server library -for the Simple Mail Transfer Protocol as described in RFC 821 and RFC -2821. By default the server will bind to the default network address -and the standard SMTP port (25). -.PP -This package was designed to permit testing of Mail User Agent code -from a developers workstation. \fIIt does not attempt to deliver mail to your mailbox.\fR Instead users of this package are expected to -write a procedure that will be called when mail arrives. Once this -procedure returns, the server has nothing further to do with the mail. -.SH "SECURITY" -On Unix platforms binding to the SMTP port requires root privileges. I -would not recommend running any script-based server as root unless -there is some method for dropping root privileges immediately after -the socket is bound. Under Windows platforms, it is not necessary to -have root or administrator privileges to bind low numbered -sockets. However, security on these platforms is weak anyway. -.PP -In short, this code should probably not be used as a permanently -running Mail Transfer Agent on an Internet connected server, even -though we are careful not to evaluate remote user input. There are -many other well tested and security audited programs that can be used -as mail servers for internet connected hosts. -.SH "COMMANDS" -.TP -\fB::smtpd::start\fR ?\fImyaddr\fR? ?\fIport\fR?\fR -Start the service listening on \fIport\fR or the default port 25. If -\fImyaddr\fR is given as a domain-style name or numerical -dotted-quad IP address then the server socket will be bound to that -network interface. By default the server is bound to all network -interfaces. For example: -.sp -.nf - set sock [::smtpd::start [info hostname] 0] -.fi -.sp -will bind to the hosts internet interface on the first available port. -.sp -At present the package only supports a single instance of a SMTP -server. This could be changed if required at the cost of making the -package a little more complicated to read. If there is a good reason -for running multiple SMTP services then it will only be necessary to -fix the \fBoptions\fR array and the \fB::smtpd::stopped\fR variable -usage. -.sp -As the server code uses \fBfileevent\fR(n) handlers to process the -input on sockets you will need to run the event loop. This means -either you should be running from within \fBwish\fR(1) or you -should \fBvwait\fR(n) on the \fB::smtpd::stopped\fR variable which is -set when the server is stopped. -.TP -\fB::smtpd::stop\fR \fR -Halt the server and release the listening socket. If the server has -not been started then this command does nothing. -The \fB::smtpd::stopped\fR variable is set for use with -\fBvwait\fR(n). -.sp -It should be noted that stopping the server does not disconnect any -currently active sessions as these are operating over an independent -channel. Only explicitly tracking and closing these sessions, or -exiting the server process will close down all the running -sessions. This is similar to the usual unix daemon practice where the -server performs a \fBfork\fR(2) and the client session continues on -the child process. -.TP -\fB::smptd::configure\fR ?\fIoption\fR \fIvalue\fR? ?\fIoption\fR \fIvalue\fR \fI...\fR?\fR -Set configuration options for the SMTP server. Most values are the -name of a callback procedure to be called at various points in the -SMTP protocol. See the \fBCALLBACKS\fR section for details of the -procedures. -.RS -.TP -\fB-validate_host\fR \fIproc\fR -Callback to authenticate new connections based on the ip-address of -the client. -.TP -\fB-validate_sender\fR \fIproc\fR -Callback to authenticate new connections based on the senders email -address. -.TP -\fB-validate_recipient\fR \fIproc\fR -Callback to validate and authorize a recipient email address -.TP -\fB-deliverMIME\fR \fIproc\fR -Callback used to deliver mail as a mime token created by the tcllib -\fBmime\fR package. -.TP -\fB-deliver\fR \fIproc\fR -Callback used to deliver email. This option has no effect if -the \fB-deliverMIME\fR option has been set. -.RE -.TP -\fB::smtpd::cget\fR ?\fIoption\fR?\fR -If no \fIoption\fR is specified the command will return a list of all -options and their current values. If an option is specified it will -return the value of that option. -.SH "CALLBACKS" -.TP -\fBvalidate_host callback\fR -This procedure is called with the clients ip address as soon as a -connection request has been accepted and before any protocol commands -are processed. If you wish to deny access to a specific host then an -error should be returned by this callback. For example: -.sp -.nf - proc validate_host {ipnum} { - if {[string match "192.168.1.*" $ipnum]} { - error "go away!" - } - } -.fi -.sp -If access is denied the client will receive a standard message that -includes the text of your error, such as: -.sp -.nf - 550 Access denied: I hate you. -.fi -.sp -As per the SMTP protocol, the connection is not closed but we wait for -the client to send a QUIT command. Any other commands cause a -\fB503 Bad Sequence\fR error. -.TP -\fBvalidate_sender callback\fR -The validate_sender callback is called with the senders mail address -during processing of a MAIL command to allow you to accept or reject -mail based upon the declared sender. To reject mail you should throw -an error. For example, to reject mail from user "denied": -.sp -.nf - proc validate_sender {address} { - eval array set addr \\ - [mime::parseaddress $address] - if {[string match "denied" $addr(local)]} { - error "mailbox $addr(local) denied" - } - return - } -.fi -.sp -The content of any error message will not be passed back to the client. -.TP -\fBvalidate_recipient callback\fR -The validate_recipient callback is similar to the validate_sender -callback and permits you to verify a local mailbox and accept mail for -a local user address during RCPT command handling. To reject mail, -throw an error as above. The error message is ignored. -.TP -\fBdeliverMIME callback\fR -The deliverMIME callback is called once a mail message has been -successfully passed to the server. A mime token is constructed from -the sender, recipients and data and the users procedure it called with -this single argument. When the call returns, the mime token is cleaned -up so if the user wishes to preserve the data she must make a copy. -.sp -.nf - proc deliverMIME {token} { - set sender [lindex [mime::getheader $token From] 0] - set recipients [lindex [mime::getheader $token To] 0] - set mail "From $sender [clock format [clock seconds]]" - append mail "\n" [mime::buildmessage $token] - puts $mail - } -.fi -.TP -\fBdeliver callback\fR -The deliver callback is called once a mail message has been -successfully passed to the server and there is no -deliverMIME option -set. The procedure is called with the sender, a list of recipients and -the text of the mail as a list of lines. For example: -.sp -.nf - proc deliver {sender recipients data} { - set mail "From $sender [clock format [clock seconds]]" - append mail "\n" [join $data "\n"] - puts "$mail" - } -.fi -.sp -Note that the DATA command will return an error if no sender or -recipient has yet been defined. -.SH "VARIABLES" -.TP -\fB::smtpd::stopped\fR -This variable is set to \fBtrue\fR during the \fB::smtpd::stop\fR -command to permit the use of the \fBvwait\fR(n) command. -'\" ::smtpd::postmaster -'\" The e-mail address of the person that is the contact for the server. -.SH "AUTHOR" -Written by Pat Thoyts \fImailto:patthoyts@users.sourceforge.net\fR. -.SH "COPYRIGHT" -This software 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 file -"\fIlicense.terms\fR" for more details. -.SH "KEYWORDS" -smtpd, smtp, services, RFC 821, RFC 2821, vwait, socket DELETED modules/smtpd/smtpd.tcl Index: modules/smtpd/smtpd.tcl ================================================================== --- modules/smtpd/smtpd.tcl +++ /dev/null @@ -1,748 +0,0 @@ -# smtpd.tcl - Copyright (C) 2001 Pat Thoyts -# -# This provides a minimal implementation of the Simple Mail Tranfer Protocol -# as per RFC821 and RFC2821 (http://www.normos.org/ietf/rfc/rfc821.txt) and -# is designed for use during local testing of SMTP client software. -# -# ------------------------------------------------------------------------- -# This software 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 file 'license.terms' for -# more details. -# ------------------------------------------------------------------------- - -package require Tcl 8.3; # tcl minimum version -package require log; # tcllib -package require mime; # tcllib - -namespace eval ::smtpd { - variable rcsid {$Id: smtpd.tcl,v 1.9 2003/04/11 01:08:03 andreas_kupries Exp $} - variable version 1.2.1 - variable stopped - - namespace export start stop - - variable commands {EHLO HELO MAIL RCPT DATA RSET NOOP QUIT} - # non-minimal commands HELP VRFY EXPN VERB ETRN DSN - - variable options - if {! [info exists options]} { - array set options { - serveraddr {} - deliverMIME {} - deliver {} - validate_host {} - validate_sender {} - validate_recipient {} - } - } - - variable extensions - if {! [info exists extensions]} { - array set extensions { - 8BITMIME {} - SIZE 0 - } - } -} - -# ------------------------------------------------------------------------- -# Description: -# Obtain configuration options for the server. -# -proc ::smtpd::cget {option} { - variable options - set optname [string trimleft $option -] - if { [info exists options($optname)] } { - return $options($optname) - } else { - return -code error "unknown option: must be one of \ - \"[array names options]\"" - } -} - -# ------------------------------------------------------------------------- -# Description: -# Configure server options. These include validation of hosts or users -# and a procedure to handle delivery of incoming mail. The -deliver -# procedure must handle mail because the server may release all session -# resources once the deliver proc has completed. -# An example might be to exec procmail to deliver the mail to users. -# -proc ::smtpd::configure {args} { - variable options - - if {[llength $args] == 0} { - foreach {opt value} [array get options] { - lappend r -$opt $value - - } - return $r - } - - foreach {opt value} $args { - switch -- $opt { - -deliverMIME {set options(deliverMIME) $value} - -deliver {set options(deliver) $value} - -validate_host {set options(validate_host) $value} - -validate_sender {set options(validate_sender) $value} - -validate_recipient {set options(validate_recipient) $value} - default { - error "unknown option: \"$opt\": must be one of \ - -deliverMIME, -deliver,\ - -validate_host, -validate_recipient \ - or -validate_sender" - } - } - } - return {} -} - -# ------------------------------------------------------------------------- -# Description: -# Start the server on the given interface and port. -# -proc ::smtpd::start {{myaddr {}} {port 25}} { - variable options - variable stopped - - if {[info exists options(socket)]} { - error "smtpd service already running on socket $options(socket)" - } - - if {$myaddr != {}} { - set options(serveraddr) $myaddr - set myaddr "-myaddr $myaddr" - } else { - if {$options(serveraddr) == {}} { - set options(serveraddr) [info hostname] - } - } - - set options(socket) [eval socket \ - -server [namespace current]::accept $myaddr $port] - set stopped 0 - log::log notice "smtpd service started on $options(socket)" - return $options(socket) -} - -# ------------------------------------------------------------------------- -# Description: -# Stop a running server. Do nothing if the server isn't running. -# -proc ::smtpd::stop {} { - variable options - variable stopped - if {[info exists options(socket)]} { - close $options(socket) - set stopped 1 - log::log notice "smtpd service stopped" - unset options(socket) - } -} - -# ------------------------------------------------------------------------- -# Description: -# Accept a new connection and setup a fileevent handler to process the new -# session. Performs a host id validation step before allowing access. -# -proc ::smtpd::accept {channel client_addr client_port} { - variable options - variable version - upvar [namespace current]::state_$channel State - - # init state array - catch {unset State} - initializeState $channel - set State(access) allowed - set State(client_addr) $client_addr - set State(client_port) $client_port - set accepted true - - # configure the data channel - fconfigure $channel -buffering line -translation crlf -encoding ascii - fileevent $channel readable [list [namespace current]::service $channel] - - # check host access permissions - if {[cget -validate_host] != {}} { - if {[catch {eval [cget -validate_host] $client_addr} msg] } { - log::log notice "access denied for $client_addr:$client_port: $msg" - Puts $channel "550 Access denied: $msg" - set State(access) denied - set accepted false - } - } - - if {$accepted} { - # Accept the connection - log::log notice "connect from $client_addr:$client_port on $channel" - Puts $channel "220 $options(serveraddr) tcllib smtpd $version; [timestamp]" - } - - return -} - -# ------------------------------------------------------------------------- -# Description: -# Initialize the channel state array. Called by accept and RSET. -# -proc ::smtpd::initializeState {channel} { - upvar [namespace current]::state_$channel State - set State(indata) 0 - set State(to) {} - set State(from) {} - set State(data) {} - set State(options) {} -} - -# ------------------------------------------------------------------------- -# Description: -# Access the state of a connected session using the channel name as part -# of the state array name. Called with no value, it returns the current -# value of the item (or {} if not defined). -# -proc ::smtpd::state {channel args} { - if {[llength $args] == 0} { - return [array get [namespace current]::state_$channel] - } - - set arrname [namespace current]::[subst state_$channel] - - if {[llength $args] == 1} { - set r {} - if {[info exists [subst $arrname]($args)]} { - # FRINK: nocheck - set r [set [subst $arrname]($args)] - } - return $r - } - - foreach {name value} $args { - # FRINK: nocheck - set [namespace current]::[subst state_$channel]($name) $value - } - return {} -} - -# ------------------------------------------------------------------------- -# Description: -# Safe puts. -# If the client closes the channel, then puts will throw an error. Lets -# terminate the session if this occurs. -proc ::smtpd::Puts {channel args} { - if {[catch {uplevel puts $channel $args} msg]} { - log::log error $msg - catch { - close $channel - # FRINK: nocheck - unset -- [namespace current]::state_$channel - } - } - return $msg -} - -# ------------------------------------------------------------------------- -# Description: -# Perform the chat with a connected client. This procedure accepts input on -# the connected socket and executes commands according to the state of the -# session. -# -proc ::smtpd::service {channel} { - variable commands - variable options - upvar [namespace current]::state_$channel State - - if {[eof $channel]} { - close $channel - return - } - - if {[catch {gets $channel cmdline} msg]} { - close $channel - log::log error $msg - return - } - - if { $cmdline == "" && [eof $channel] } { - log::log warning "client has closed the channel" - return - } - - log::log debug "received: $cmdline" - - # If we are handling a DATA section, keep looking for the end of data. - if {$State(indata)} { - if {$cmdline == "."} { - set State(indata) 0 - fconfigure $channel -translation crlf - if {[catch {deliver $channel} err]} { - # permit delivery handler to return SMTP errors in errorCode - if {[regexp {\d{3}} $::errorCode]} { - Puts $channel "$::errorCode $err" - } else { - Puts $channel "554 Transaction failed: $err" - } - } else { - Puts $channel "250 [state $channel id]\ - Message accepted for delivery" - } - } else { - # RFC 2821 section 4.5.2: Transparency - if {[string match {..*} $cmdline]} { - set cmdline [string range $cmdline 1 end] - } - lappend State(data) $cmdline - } - return - } - - # Process SMTP commands (case insensitive) - set cmd [string toupper [lindex [split $cmdline] 0]] - if {[lsearch $commands $cmd] != -1} { - if {[info proc $cmd] == {}} { - Puts $channel "500 $cmd not implemented" - } else { - # If access denied then client can only issue QUIT. - if {$State(access) == "denied" && $cmd != "QUIT" } { - Puts $channel "503 bad sequence of commands" - } else { - set r [eval $cmd $channel [list $cmdline]] - } - } - } else { - Puts $channel "500 Invalid command" - } - - return -} - -# ------------------------------------------------------------------------- -# Description: -# Generate a random ASCII character for use in mail identifiers. -# -proc ::smtpd::uidchar {} { - set c . - while {! [string is alnum $c]} { - set n [expr {int(rand() * 74 + 48)}] - set c [format %c $n] - } - return $c -} - -# Description: -# Generate a unique random identifier using only ASCII alphanumeric chars. -# -proc ::smtpd::uid {} { - set r {} - for {set cn 0} {$cn < 12} {incr cn} { - append r [uidchar] - } - return $r -} - -# ------------------------------------------------------------------------- -# Description: -# Calculate the local offset from GMT in hours for use in the timestamp -# -proc ::smtpd::gmtoffset {} { - set now [clock seconds] - set lh [string trimleft [clock format $now -format "%H" -gmt false] 0] - set zh [string trimleft [clock format $now -format "%H" -gmt true] 0] - if {$lh == "" || $zh == ""} { - set off 0 - } else { - set off [expr {$zh - $lh}] - } - if {$off > 0} { - set off [format "+%02d00" $off] - } else { - set off [format "-%02d00" [expr {abs($off)}]] - } - return $off -} - -# ------------------------------------------------------------------------- -# Description: -# Generate a standard SMTP compliant timestamp. That is a local time but with -# the timezone represented as an offset. -# -proc ::smtpd::timestamp {} { - set ts [clock format [clock seconds] \ - -format "%a, %d %b %Y %H:%M:%S" -gmt false] - append ts " " [gmtoffset] - return $ts -} - -# ------------------------------------------------------------------------- -# Description: -# Get the servers ip address (from http://purl.org/mini/tcl/526.html) -# -proc ::smtpd::server_ip {} { - set me [socket -server xxx -myaddr [info hostname] 0] - set ip [lindex [fconfigure $me -sockname] 0] - close $me - return $ip -} - -# ------------------------------------------------------------------------- -# Description: -# deliver is called once a mail transaction is completed and there is -# no deliver procedure defined -# The configured -deliverMIME procedure is called with a MIME token. -# If no such callback is defined then try the -deliver option and use -# the old API. -# -proc ::smtpd::deliver {channel} { - set deliverMIME [cget deliverMIME] - if { $deliverMIME != {} \ - && [state $channel from] != {} \ - && [state $channel to] != {} \ - && [state $channel data] != {} } { - - # create a MIME token from the mail message. - set tok [mime::initialize -string \ - [join [state $channel data] "\n"]] -# mime::setheader $tok "From" [state $channel from] -# foreach recipient [state $channel to] { -# mime::setheader $tok "To" $recipient -mode append -# } - - # catch and rethrow any errors. - set err [catch {$deliverMIME $tok} msg] - mime::finalize $tok -subordinates all - if {$err} { - log::log debug "error in deliver: $msg" - return -code error -errorcode $::errorCode \ - -errorinfo $::errorInfo $msg - } - - } else { - # Try the old interface - deliver_old $channel - } -} - -# ------------------------------------------------------------------------- -# Description: -# Deliver is called once a mail transaction is completed (defined as the -# completion of a DATA command). The configured -deliver procedure is called -# with the sender, list of recipients and the text of the mail. -# -proc ::smtpd::deliver_old {channel} { - set deliver [cget deliver] - if { $deliver != {} \ - && [state $channel from] != {} \ - && [state $channel to] != {} \ - && [state $channel data] != {} } { - if {[catch {$deliver [state $channel from] \ - [state $channel to] \ - [state $channel data]} msg]} { - log::log debug "error in deliver: $msg" - return -code error -errorcode $::errorCode \ - -errorinfo $::errorInfo $msg - } - } -} - -# ------------------------------------------------------------------------- -proc ::smtpd::split_address {address} { - set start [string first < $address] - set end [string last > $address] - set addr [string range $address $start $end] - incr end - set opts [string trim [string range $address $end end]] - return [list $addr $opts] -} - -# ------------------------------------------------------------------------- -# The SMTP Commands -# ------------------------------------------------------------------------- -# Description: -# Initiate an SMTP session -# Reference: -# RFC2821 4.1.1.1 -# -proc ::smtpd::HELO {channel line} { - variable options - - if {[state $channel domain] != {}} { - Puts $channel "503 bad sequence of commands" - log::log debug "HELO received out of sequence." - return - } - - set r [regexp -nocase {^HELO\s+([-\w\.]+)\s*$} $line -> domain] - if {$r == 0} { - Puts $channel "501 Syntax error in parameters or arguments" - log::log debug "HELO received \"$line\"" - return - } - Puts $channel "250-$options(serveraddr) Hello $domain\ - \[[state $channel client_addr]\], pleased to meet you" - Puts $channel "250 Ready for mail." - state $channel domain $domain - log::log debug "HELO on $channel from $domain" - return -} - -# ------------------------------------------------------------------------- -# Description: -# Initiate an ESMTP session -# Reference: -# RFC2821 4.1.1.1 -proc ::smtpd::EHLO {channel line} { - variable options - variable extensions - - if {[state $channel domain] != {}} { - Puts $channel "503 bad sequence of commands" - log::log debug "EHLO received out of sequence." - return - } - - set r [regexp -nocase {^EHLO\s+([-\w\.]+)\s*$} $line -> domain] - if {$r == 0} { - Puts $channel "501 Syntax error in parameters or arguments" - log::log debug "EHLO received \"$line\"" - return - } - Puts $channel "250-$options(serveraddr) Hello $domain\ - \[[state $channel client_addr]\], pleased to meet you" - foreach {extn opts} [array get extensions] { - Puts $channel [string trimright "250-$extn $opts"] - } - Puts $channel "250 Ready for mail." - state $channel domain $domain - log::log debug "EHLO on $channel from $domain" - return -} - -# ------------------------------------------------------------------------- -# Description: -# Reference: -# RFC2821 4.1.1.2 -# -proc ::smtpd::MAIL {channel line} { - set r [regexp -nocase {^MAIL FROM:\s*(.*)} $line -> from] - if {$r == 0} { - Puts $channel "501 Syntax error in parameters or arguments" - log::log debug "MAIL received \"$line\"" - return - } - if {[catch { - set from [split_address $from] - set opts [lindex $from 1] - set from [lindex $from 0] - eval array set addr [mime::parseaddress $from] - } msg]} { - set addr(error) $msg - } - if {$addr(error) != {} } { - log::log debug "MAIL failed $addr(error)" - Puts $channel "501 Syntax error in parameters or arguments" - return - } - - if {[cget -validate_sender] != {}} { - if {[catch {eval [cget -validate_sender] $addr(address)}]} { - # this user has been denied - log::log info "MAIL denied user $addr(address)" - Puts $channel "553 Requested action not taken:\ - mailbox name not allowed" - return - } - } - - log::log debug "MAIL FROM: $addr(address)" - state $channel from $from - state $channel options $opts - Puts $channel "250 OK" - return -} - -# ------------------------------------------------------------------------- -# Description: -# Specify a recipient for this mail. This command may be executed multiple -# times to contruct a list of recipients. If a -validate_recipient -# procedure is configured then this is used. An error from the validation -# procedure indicates an invalid or unacceptable mailbox. -# Reference: -# RFC2821 4.1.1.3 -# Notes: -# The postmaster mailbox MUST be supported. (RFC2821: 4.5.1) -# -proc ::smtpd::RCPT {channel line} { - set r [regexp -nocase {^RCPT TO:\s*(.*)} $line -> to] - if {$r == 0} { - Puts $channel "501 Syntax error in parameters or arguments" - log::log debug "RCPT received \"$line\"" - return - } - if {[catch { - set to [split_address $to] - set opts [lindex $to 1] - set to [lindex $to 0] - eval array set addr [mime::parseaddress $to] - } msg]} { - set addr(error) $msg - } - - if {$addr(error) != {}} { - log::log debug "RCPT failed $addr(error)" - Puts $channel "501 Syntax error in parameters or arguments" - return - } - - if {[string match -nocase "postmaster" $addr(local)]} { - # we MUST support this recipient somehow as mail. - log::log notice "RCPT to postmaster" - } else { - if {[cget -validate_recipient] != {}} { - if {[catch {eval [cget -validate_recipient] $addr(address)}]} { - # this recipient has been denied - log::log info "RCPT denied mailbox $addr(address)" - Puts $channel "553 Requested action not taken:\ - mailbox name not allowed" - return - } - } - } - - log::log debug "RCPT TO: $addr(address)" - set recipients {} - catch {set recipients [state $channel to]} - lappend recipients $to - state $channel to $recipients - Puts $channel "250 OK" - return -} - -# ------------------------------------------------------------------------- -# Description: -# Begin accepting data for the mail payload. A line containing a single -# period marks the end of the data and the server will then deliver the -# mail. RCPT and MAIL commands must have been executed before the DATA -# command. -# Reference: -# RFC2821 4.1.1.4 -# Notes: -# The DATA section is the only part of the protocol permitted to use non- -# ASCII characters and non-CRLF line endings and some clients take -# advantage of this. Therefore we change the translation option on the -# channel and reset it once the DATA command is completed. See the -# 'service' procedure for the handling of DATA lines. -# We also insert trace information as per RFC2821:4.4 -# -proc ::smtpd::DATA {channel line} { - variable version - upvar [namespace current]::state_$channel State - log::log debug "DATA" - if { $State(from) == {}} { - Puts $channel "503 bad sequence: no sender specified" - } elseif { $State(to) == {}} { - Puts $channel "503 bad sequence: no recipient specified" - } else { - Puts $channel "354 Enter mail, end with \".\" on a line by itself" - set State(id) [uid] - set State(indata) 1 - - lappend trace "Return-Path: $State(from)" - lappend trace "Received: from [state $channel domain]\ - \[[state $channel client_addr]\]" - lappend trace "\tby [info hostname] with tcllib smtpd ($version)\ - id $State(id); [timestamp]" - set State(data) $trace - fconfigure $channel -translation auto ;# naughty: RFC2821:2.3.7 - } - return -} - -# ------------------------------------------------------------------------- -# Description: -# Reset the server state for this connection. -# Reference: -# RFC2821 4.1.1.5 -# -proc ::smtpd::RSET {channel line} { - upvar [namespace current]::state_$channel State - log::log debug "RSET on $channel" - if {[catch {initializeState $channel} msg]} { - log::log warning "RSET: $msg" - } - Puts $channel "250 OK" - return -} - -# ------------------------------------------------------------------------- -# Description: -# Verify the existence of a mailbox on the server -# Reference: -# RFC2821 4.1.1.6 -# -#proc ::smtpd::VRFY {channel line} { -# # VRFY SP String CRLF -#} - -# ------------------------------------------------------------------------- -# Description: -# Expand a mailing list. -# Reference: -# RFC2821 4.1.1.7 -# -#proc ::smtpd::EXPN {channel line} { -# # EXPN SP String CRLF -#} - -# ------------------------------------------------------------------------- -# Description: -# Return a help message. -# Reference: -# RFC2821 4.1.1.8 -# -#proc ::smtpd::HELP {channel line} { -# # HELP SP String CRLF -#} - -# ------------------------------------------------------------------------- -# Description: -# Perform no action. -# Reference: -# RFC2821 4.1.1.9 -# -proc ::smtpd::NOOP {channel line} { - set str {} - regexp -nocase {^NOOP (.*)$} -> str - log::log debug "NOOP: $str" - Puts $channel "250 OK" - return -} - -# ------------------------------------------------------------------------- -# Description: -# Terminate a session and close the transmission channel. -# Reference: -# RFC2821 4.1.1.10 -# Notes: -# The server is only permitted to close the channel once it has received -# a QUIT message. -# -proc ::smtpd::QUIT {channel line} { - variable options - upvar [namespace current]::state_$channel State - - log::log debug "QUIT on $channel" - Puts $channel "221 $options(serveraddr) Service closing transmission channel" - close $channel - - # cleanup the session state array. - unset State - return -} - -package provide smtpd $smtpd::version - -# ------------------------------------------------------------------------- -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: DELETED modules/soundex/ChangeLog Index: modules/soundex/ChangeLog ================================================================== --- modules/soundex/ChangeLog +++ /dev/null @@ -1,6 +0,0 @@ -2003-04-01 Andreas Kupries - - * soundex.tcl: New module for soundex algorithms. - * soundex.man: - * soundex.test: - * pkgIndex.tcl: DELETED modules/soundex/pkgIndex.tcl Index: modules/soundex/pkgIndex.tcl ================================================================== --- modules/soundex/pkgIndex.tcl +++ /dev/null @@ -1,12 +0,0 @@ -# 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. - -if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded soundex 1.0 [list source [file join $dir soundex.tcl]] DELETED modules/soundex/soundex.man Index: modules/soundex/soundex.man ================================================================== --- modules/soundex/soundex.man +++ /dev/null @@ -1,40 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[manpage_begin soundex n 1.0] -[copyright {????, Algorithm: Donald E. Knuth}] -[copyright {2003, Documentation: Andreas Kupries }] -[copyright {1998, Tcl port: Evan Rempel }] -[moddesc {Soundex}] -[titledesc {Soundex}] -[require Tcl 8.2] -[require soundex [opt 1.0]] -[description] -[para] - -This package provides soundex algorithms which allow the -comparison of words based on their phonetic likeness. - -[para] - -Currently only an algorithm by Knuth is provided, which -is tuned to english names and words. - -[list_begin definitions] - -[call [cmd ::soundex::knuth] [arg string]] - -Computes the soundex code of the input [arg string] using -Knuth's algorithm and returns it as the result of the -command. - -[list_end] - - -[section EXAMPLES] - -[example { - % ::soundex::knuth Knuth - K530 -}] - -[keywords soundex knuth {text comparison} {text likeness}] -[manpage_end] DELETED modules/soundex/soundex.tcl Index: modules/soundex/soundex.tcl ================================================================== --- modules/soundex/soundex.tcl +++ /dev/null @@ -1,96 +0,0 @@ -# soundex.tcl -- -# -# Implementation of soundex in Tcl -# -# Copyright (c) 2003 by Andreas Kupries -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: soundex.tcl,v 1.2 2003/04/11 19:21:16 andreas_kupries Exp $ - -package require Tcl 8.2 - -namespace eval ::soundex {} - -## ------------------------------------------------------------ -## -## I. Soundex by Knuth. - -# This implementation of the Soundex algorithm is released to the public -# domain: anyone may use it for any purpose. See if I care. - -# N. Dean Pentcheff 1/13/89 Dept. of Zoology University of California Berkeley, -# CA 94720 dean@violet.berkeley.edu -# TCL port by Evan Rempel 2/10/98 Dept Comp Services University of Victoria. -# erempel@uvic.ca - -# proc ::soundex::knuth ( string ) -# -# Given as argument: a character string. Returns: a static string, 4 characters long -# This string is the Soundex key for the argument string. -# Side effects and limitations: -# Does not clobber the string passed in as the argument. No limit on -# argument string length. Assumes a character set with continuously -# ascending and contiguous letters within each case and within the digits -# (e.g. this works for ASCII and bombs in EBCDIC. But then, most things -# do.). Reference: Adapted from Knuth, D.E. (1973) The art of computer -# programming; Volume 3: Sorting and searching. Addison-Wesley Publishing -# Company: Reading, Mass. Page 392. -# Special cases: Leading or embedded spaces, numerals, or punctuation are squeezed -# out before encoding begins. -# -# Null strings or those with no encodable letters return the code 'Z000'. -# -# Test data from Knuth (1973): -# Euler Gauss Hilbert Knuth Lloyd Lukasiewicz -# E460 G200 H416 K530 L300 L222 - -namespace eval ::soundex { - variable soundexKnuthCode - array set soundexKnuthCode { - a 0 b 1 c 2 d 3 e 0 f 1 g 2 h 0 i 0 j 2 k 2 l 4 m 5 - n 5 o 0 p 1 q 2 r 6 s 2 t 3 u 0 v 1 w 0 x 2 y 0 z 2 - } -} -proc ::soundex::knuth {in} { - variable soundexKnuthCode - set key "" - - # Remove the leading/trailing white space punctuation etc. - - set TempIn [string trim $in "\t\n\r .,'-"] - - # Only use alphabetic characters, so strip out all others - # also, soundex index uses only lower case chars, so force to lower - - regsub -all {[^a-z]} [string tolower $TempIn] {} TempIn - if {[string length $TempIn] == 0} { - return Z000 - } - set last [string index $TempIn 0] - set key [string toupper $last] - set last $soundexKnuthCode($last) - - # Scan rest of string, stop at end of string or when the key is - # full - - set count 1 - set MaxIndex [string length $TempIn] - - for {set index 1} {(($count < 4) && ($index < $MaxIndex))} {incr index } { - set chcode $soundexKnuthCode([string index $TempIn $index]) - # Fold together adjacent letters sharing the same code - if {![string equal $last $chcode]} { - set last $chcode - # Ignore code==0 letters except as separators - if {$last != 0} then { - set key $key$last - incr count - } - } - } - return [string range ${key}0000 0 3] -} - -package provide soundex 1.0 DELETED modules/soundex/soundex.test Index: modules/soundex/soundex.test ================================================================== --- modules/soundex/soundex.test +++ /dev/null @@ -1,35 +0,0 @@ -# -*- tcl -*- -# soundex.test: tests for the soundex commands. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 2003 by Andreas Kupries -# -# RCS: @(#) $Id: soundex.test,v 1.1 2003/04/01 21:24:21 andreas_kupries Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -package require soundex -puts "soundex [package present soundex]" - -namespace import ::soundex::knuth - -foreach {n in out} { - 1.0 Euler E460 - 1.1 Gauss G200 - 1.2 Hilbert H416 - 1.3 Knuth K530 - 1.4 Lloyd L300 - 1.5 Lukasiewicz L222 -} { - test soundex-$n {knuth soundex} { - ::soundex::knuth $in - } $out -} - -::tcltest::cleanupTests DELETED modules/stats/ChangeLog Index: modules/stats/ChangeLog ================================================================== --- modules/stats/ChangeLog +++ /dev/null @@ -1,58 +0,0 @@ -2002-04-16 Andreas Kupries - - * According to Brent Welch this module is DEPRECATED. Use - 'counter' instead. - -2001-09-05 Andreas Kupries - - * stats.tcl: Restricted export list to public API. - [456255]. Patch by Hemang Lavana - - -2001-07-10 Andreas Kupries - - * stats.tcl: Frink 2.2 run, fixed dubious code. - -2001-06-21 Andreas Kupries - - * stats.tcl: Fixed dubious code reported by frink. - -2000-10-02 Brent Welch - - * modules/stats/stats.tcl: Added stats::htmlHistDisplayRow - so that the calling page could define the overall table structure. - -2000-10-01 Brent Welch - - * modules/stats/stats.tcl: Fixed calculation of hourBase - and minuteBase when secsPerMinute was not 60. - -2000-09-23 Brent Welch - - * modules/stats/stats.tcl: Time-based histograms were - not displaying the 23rd hour nor the 59th minute. - -2000-09-22 Brent Welch - - * modules/stats/stats.tcl: Fixed initialization when the - server starts in the 59'th minute. The first after event - was an hour too long, so the first hour of data didn't - display correctly. - -2000-09-21 Brent Welch - - * modules/stats/stats.tcl: Added time labels and tick - marks to all the time-based histograms. - Fixed alignment of per-minute and per-hour histograms. - -2000-09-20 Brent Welch - - * modules/stats/stats.tcl: Refined the countGet routine to return things - needed by the TclHttpd status module. Refined the value-based histogram display. - * modules/stats/stats.tests: Added more tests. - * modules/stats/stats.n: Completed the man page. - -2000-09-15 Brent Welch - - * Created this module. - DELETED modules/stats/pkgIndex.tcl Index: modules/stats/pkgIndex.tcl ================================================================== --- modules/stats/pkgIndex.tcl +++ /dev/null @@ -1,12 +0,0 @@ -# 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 stats 1.0 [list error "The stats package is deprecated, use counter instead"] -## package ifneeded stats 1.0 [list source [file join $dir stats.tcl]] DELETED modules/stats/stats.n Index: modules/stats/stats.n ================================================================== --- modules/stats/stats.n +++ /dev/null @@ -1,230 +0,0 @@ -'\" -'\" Copyright (c) 1998-2000 by Ajuba Solutions. -'\" All rights reserved. -'\" -'\" RCS: @(#) $Id: stats.n,v 1.3 2001/07/06 18:30:52 andreas_kupries Exp $ -'\" -.so man.macros -.TH stats n 1.0 Stats "Statistics and Counters" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -::stats \- Procedures for counters, histograms, and statistics. -.SH SYNOPSIS -.BS -.sp -\fBstats::countInit\fR \fItag\fR \fIargs\fR -.sp -\fBstats::count\fR \fItag {delta 1} args\fR -.sp -\fBstats::countReset\fR \fItag\fR -.sp -\fBstats::countGet\fR \fItag args\fR -.sp -\fBstats::countStart\fR \fItag\fR -.sp -\fBstats::countStop\fR \fItag\fR -.sp -\fBstats::countExists\fR \fItag\fR -.sp -\fBstats::countNames\fR \fItag\fR -.sp -\fBstats::histHtmlDisplay\fR \fItag args\fR -.BE -.SH DESCRIPTION -.PP -The \fB::stats\fR package provides a counter facility and -can compute statistics and histograms over the collected data. - -.TP -\fBstats::countInit\fR \fItag args\fR -This defines a counter with the name \fItag\fP. -The \fIargs\fP determines the characteristics of the counter. -The \fIargs\fP are - -.TP -\fB-group\fR \fIname\fR -Keep a grouped counter where the name of the histogram bucket -is passed into \fBstats::count\fP. - -.TP -\fB-hist\fR \fIbucketsize\fR -Accumulate the counter into histogram buckets of size -\fIbucketsize\fP. For example, if the samples are millisecond -time values and \fIbucketsize\fP is 10, then each -histogram bucket represents time values of -0 to 10 msec, 10 to 20 msec, 20 to 30 msec, and so on. - -.TP -\fB-hist2x\fR \fIbucketsize\fR -Accumulate the statistic into histogram buckets. -The size of the first bucket is -\fIbucketsize\fP, each other bucket holds values -2 times the size of the previous bucket. -For example, if \fIbucketsize\fP is 10, then each -histogram bucket represents time values of -0 to 10 msec, 10 to 20 msec, 20 to 40 msec, 40 to 80 msec, and so on. - -.TP -\fB-hist10x\fR \fIbucketsize\fR -Accumulate the statistic into histogram buckets. -The size of the first bucket is -\fIbucketsize\fP, each other bucket holds values -10 times the size of the previous bucket. -For example, if \fIbucketsize\fP is 10, then each -histogram bucket represents time values of -0 to 10 msec, 10 to 100 msec, 100 to 1000 msec, and so on. - -.TP -\fB-lastn\fR \fIN\fR -Save the last \fIN\fP values of the counter to maintain -a "running average" over the last \fIN\fP values. - -.TP -\fB-timehist\fR \fIsecsPerMinute\fR -Keep a time-based histogram. -The counter is summed into a histogram bucket based on the current time. -There are 60 per-minute buckets that have a size determined by -\fIsecsPerMinute\fP, which -is normally 60, but for testing purposes can be less. -Every "hour" (i.e., 60 "minutes") the contents of the per-minute buckets are summed -into the next hourly bucket. -Every 24 "hours" the contents of the per-hour buckets are summed into -the next daily bucket. -The stats package keeps all time-based histograms in sync, so the first -\fIsecsPerMinute\fP value seen by the package is used for all subsequent -time-based histograms. - -.TP -\fBstats::count\fR \fItag {delta 1} {instance {}}\fR -Increment the counter identified by \fItag\fP. -The default increment is 1, although you can increment -by any value, integer or real, by specifying \fIdelta\fP. -You must declare each counter with \fBstats::countInit\fP to define -the characteristics of counter before you start to use it. -If the counter type is \fB-group\fP, then the counter -identified by \fIinstance\fP is incremented. - -.TP -\fBstats::countStart\fR \fItag instance\fR -Record the starting time of an interval. -The \fItag\fP is the name of the counter defined as -a \fB-hist\fP value-based histogram. -The \fIinstance\fP is used to distinguish this interval from -any other intervals that might be overlapping this one. - -.TP -\fBstats::countStop\fR \fItag instance\fR -Record the ending time of an interval. -The delta time since the corresponding \fBcountStart\fP call -for \fIinstance\fP is recorded in the histogram -identified by \fItag\fP. - -.TP -\fBstats::countGet\fR \fItag args\fR -Return statistics about a counter -identified by \fItag\fP. -The \fIargs\fP determine what value to return: -.TP -\fB-total\fP -Return the total value of the counter. This is the default -if \fIargs\fP is not specified. -.TP -\fB-totalVar\fP -Return the name of the total variable. Useful for -specifying with -textvariable in a Tk widget. -.TP -\fB-N\fP -Return the number of samples accumulated into the counter. -.TP -\fB-avg\fP -Return the average of samples accumulated into the counter. -.TP -\fB-avgn\fP -Return the average over the last \fIN\fP samples taken. -The \fIN\fP value is set in the \fBstats::countInit\fP call. -.TP -\fB-hist\fP \fIbucket\fP -If \fIbucket\fP is specified, then the value in that bucket -of the histogram is returned. -Otherwise the complete histogram is returned -in array get format sorted by bucket. -.TP -\fB-histVar\fP -Return the name of the histogram array variable. -.TP -\fB-histHour\fP -Return the complete hourly histogram -in array get format sorted by bucket. -.TP -\fB-histHourVar\fP -Return the name of the hourly histogram array variable. -.TP -\fB-histDay\fP -Return the complete daily histogram -in array get format sorted by bucket. -.TP -\fB-histDayVar\fP -Return the name of the daily histogram array variable. -.TP -\fB-resetDate\fP -Return the clock seconds value recorded when the -counter was last reset. -.TP -\fB-all\fP -Return an array get of the array used to store the counter. -This includes the total, the number of samples (N), and any -type-specific information. This does not include the -histogram array. - -.TP -\fBstats::countExists\fR \fItag\fR -Returns 1 if the counter is defined. - -.TP -\fBstats::countNames\fR -Returns a list of all counters defined. - -.TP -\fBstats::histHtmlDisplay\fR \fItag args\fR -Generate HTML to display a histogram for a counter. -The \fIargs\fP control the format of the display. -They are: - -.TP -\fB-title\fI string\fP -Label to display above bar chart -.TP -\fB-unit\fI unit\fP -Specify \fBminutes\fP, \fBhours\fP, or \fBdays\fP for the time-base histograms. -For value-based histograms, the \fIunit\fP is used in the title. -.TP -\fB-images\fI url\fP -URL of /images directory. -.TP -\fB-gif\fI filename\fP -Image for normal histogram bars. -The \fIfilename\fP is relative to the \fP-images\fP directory. -.TP -\fB-ongif\fI filename\fP -Image for the active histogram bar. -The \fIfilename\fP is relative to the \fP-images\fP directory. -.TP -\fB-max\fI N\fP -Maximum number of value-based buckets to display. -.TP -\fB-height\fI N\fP -Pixel height of the highest bar. -.TP -\fB-width\fI N\fP -Pixel width of each bar. -.TP -\fB-skip\fI N\fP -Buckets to skip when labeling value-based histograms. -.TP -\fB-format\fI string\fP -Format used to display labels of buckets. -.TP -\fB-text\fI boolean\fP -If 1, a text version of the histogram is dumped, -otherwise a graphical one is generated. DELETED modules/stats/stats.tcl Index: modules/stats/stats.tcl ================================================================== --- modules/stats/stats.tcl +++ /dev/null @@ -1,1249 +0,0 @@ -# stats.tcl -- -# -# Procedures to manage simple counters and histograms. -# -# Copyright (c) 1998-2000 by Ajuba Solutions. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: stats.tcl,v 1.18 2002/08/31 06:27:47 andreas_kupries Exp $ - -package provide stats 1.0 - -namespace eval stats:: { - - # Variables of name stats::T-$tagname - # are created as arrays to support each counter. - - # Time-based histograms are kept in sync with each other, - # so these variables are shared among them. - # These base times record the time corresponding to the first bucket - # of the per-minute, per-hour, and per-day time-based histograms. - - variable startTime - variable minuteBase - variable hourBase - variable hourEnd - variable dayBase - variable hourIndex - variable dayIndex - - # The time-based histogram uses an after event and a list - # of counters to do mergeing on. - - variable tagsToMerge - if {![info exists tagsToMerge]} { - set tagsToMerge {} - } - variable mergeInterval - - namespace export countInit countReset count countExists countGet countNames - namespace export histHtmlDisplay histHtmlDisplayRow histHtmlDisplayBarChart - namespace export countStart countStop -} - -# stats::countInit -- -# -# Set up a counter. -# -# Arguments: -# tag The identifier for the counter. Pass this to stats::count -# args option values pairs that define characteristics of the counter: -# See the man page for definitons. -# -# Results: -# None. -# -# Side Effects: -# Initializes state about a counter. - -proc stats::countInit {tag args} { - upvar #0 stats::T-$tag counter - if {[info exists counter]} { - unset counter - } - set counter(N) 0 ;# Number of samples - set counter(total) 0 - set counter(type) {} - - # With an empty type the counter is a simple accumulator - # for which we can compute an average. Here we loop through - # the args to determine what additional counter attributes - # we need to maintain in stats::count - - foreach {option value} $args { - switch -- $option { - -timehist { - variable tagsToMerge - variable secsPerMinute - variable startTime - variable minuteBase - variable hourBase - variable dayBase - variable hourIndex - variable dayIndex - - upvar #0 stats::H-$tag histogram - upvar #0 stats::Hour-$tag hourhist - upvar #0 stats::Day-$tag dayhist - - # Clear the histograms. - - for {set i 0} {$i < 60} {incr i} { - set histogram($i) 0 - } - for {set i 0} {$i < 24} {incr i} { - set hourhist($i) 0 - } - if {[info exists dayhist]} { - unset dayhist - } - set dayhist(0) 0 - - # Clear all-time high records - - set counter(maxPerMinute) 0 - set counter(maxPerHour) 0 - set counter(maxPerDay) 0 - - # The value associated with -timehist is the number of seconds - # in each bucket. Normally this is 60, but for - # testing, we compress minutes. The value is limited at - # 60 because the per-minute buckets are accumulated into - # per-hour buckets later. - - if {$value == "" || $value == 0 || $value > 60} { - set value 60 - } - - # Histogram state variables. - # All time-base histograms share the same bucket size - # and starting times to keep them all synchronized. - # So, we only initialize these parameters once. - - if {![info exists secsPerMinute]} { - set secsPerMinute $value - - set startTime [clock seconds] - set dayIndex 0 - - set dayStart [clock scan [clock format $startTime \ - -format 00:00]] - - # Figure out what "hour" we are - - set delta [expr {$startTime - $dayStart}] - set hourIndex [expr {$delta / ($secsPerMinute * 60)}] - set day [expr {$hourIndex / 24}] - set hourIndex [expr {$hourIndex % 24}] - - set hourBase [expr {$dayStart + $day * $secsPerMinute * 60 * 24}] - set minuteBase [expr {$hourBase + $hourIndex * 60 * $secsPerMinute}] - - set partialHour [expr {$startTime - - ($hourBase + $hourIndex * 60 * $secsPerMinute)}] - set secs [expr {(60 * $secsPerMinute) - $partialHour}] - if {$secs <= 0} { - set secs 1 - } - - # After the first timer, the event occurs once each "hour" - - set mergeInterval [expr {60 * $secsPerMinute * 1000}] - after [expr {$secs * 1000}] [list stats::MergeHour $mergeInterval] - } - if {[lsearch $tagsToMerge $tag] < 0} { - lappend tagsToMerge $tag - } - - # This records the last used slots in order to zero-out the - # buckets that are skipped during idle periods. - - set counter(lastMinute) -1 - - # The following is referenced when bugs cause histogram - # hits outside the expect range (overflow and underflow) - - set counter(bucketsize) 0 - } - -group { - # Cluster a set of counters with a single total - - upvar #0 stats::H-$tag histogram - if {[info exists histogram]} { - unset histogram - } - set counter(group) $value - } - -lastn { - # The lastN samples are kept if a vector to form a running average. - - upvar #0 stats::V-$tag vector - set counter(lastn) $value - set counter(index) 0 - if {[info exists vector]} { - unset vector - } - for {set i 0} {$i < $value} {incr i} { - set vector($i) 0 - } - } - -hist { - # A value-based histogram with buckets for different values. - - upvar #0 stats::H-$tag histogram - if {[info exists histogram]} { - unset histogram - } - set counter(bucketsize) $value - set counter(mult) 1 - } - -hist2x { - upvar #0 stats::H-$tag histogram - if {[info exists histogram]} { - unset histogram - } - set counter(bucketsize) $value - set counter(mult) 2 - } - -hist10x { - upvar #0 stats::H-$tag histogram - if {[info exists histogram]} { - unset histogram - } - set counter(bucketsize) $value - set counter(mult) 10 - } - -histlog { - upvar #0 stats::H-$tag histogram - if {[info exists histogram]} { - unset histogram - } - set counter(bucketsize) $value - } - -simple { - # Useful when disabling predefined -timehist or -group counter - } - default { - return -code error "Unsupported option $option.\ - Must be -timehist, -group, -lastn, -hist, -hist2x, -hist10x, -histlog, or -simple." - } - } - if {[string length $option]} { - # In case an option doesn't change the type, but - # this feature of the interface isn't used, etc. - - lappend counter(type) $option - } - } - - # Instead of supporting a counter that could have multiple attributes, - # we support a single type to make counting more efficient. - - if {[llength $counter(type)] > 1} { - return -code error "Multiple type attributes not supported. Use only one of\ - -timehist, -group, -lastn, -hist, -hist2x, -hist10x, -histlog, -disabled." - } - return "" -} - -# stats::countReset -- -# -# Reset a counter. -# -# Arguments: -# tag The identifier for the counter. -# -# Results: -# None. -# -# Side Effects: -# Deletes the counter and calls stats::countInit again for it. - -proc stats::countReset {tag args} { - upvar #0 stats::T-$tag counter - - # Layer reset on top of init. Here we figure out what - # we need to pass into the init procedure to recreate it. - - switch -- $counter(type) { - "" { - set args "" - } - -group { - upvar #0 stats::H-$tag histogram - if {[info exists histogram]} { - unset histogram - } - set args [list -group $counter(group)] - } - -lastn { - upvar #0 stats::V-$tag vector - if {[info exists vector]} { - unset vector - } - set args [list -lastn $counter(lastn)] - } - -hist - - -hist10x - - -histlog - - -hist2x { - upvar #0 stats::H-$tag histogram - if {[info exists histogram]} { - unset histogram - } - set args [list $counter(type) $counter(bucketsize)] - } - -timehist { - foreach h [list stats::H-$tag stats::Hour-$tag stats::Day-$tag] { - upvar #0 $h histogram - if {[info exists histogram]} { - unset histogram - } - } - set args [list -timehist $stats::secsPerMinute] - } - default { - error "Unknown counter type \"$counter(type)\"" - } - } - unset counter - eval {stats::countInit $tag} $args - set counter(resetDate) [clock seconds] - return "" -} - -# stats::count -- -# -# Accumulate statistics. -# -# Arguments: -# tag The counter identifier. -# delta The increment amount. Defaults to 1. -# arg For -group types, this is the histogram index. -# -# Results: -# None -# -# Side Effects: -# Accumlate statistics. - -proc stats::count {tag {delta 1} args} { - upvar #0 stats::T-$tag counter - set counter(total) [expr {$counter(total) + $delta}] - incr counter(N) - - # Instead of supporting a counter that could have multiple attributes, - # we support a single type to make counting a skosh more efficient. - -# foreach option $counter(type) { - switch -- $counter(type) { - "" { - # Simple counter - return - } - -group { - upvar #0 stats::H-$tag histogram - set subIndex [lindex $args 0] - if {![info exists histogram($subIndex)]} { - set histogram($subIndex) 0 - } - set histogram($subIndex) [expr {$histogram($subIndex) + $delta}] - } - -lastn { - upvar #0 stats::V-$tag vector - set vector($counter(index)) $delta - set counter(index) [expr {($counter(index) +1)%$counter(lastn)}] - } - -hist { - upvar #0 stats::H-$tag histogram - set bucket [expr {int($delta / $counter(bucketsize))}] - if {![info exists histogram($bucket)]} { - set histogram($bucket) 0 - } - incr histogram($bucket) - } - -hist10x - - -hist2x { - upvar #0 stats::H-$tag histogram - set bucket 0 - for {set max $counter(bucketsize)} {$delta > $max} \ - {set max [expr {$max * $counter(mult)}]} { - incr bucket - } - if {![info exists histogram($bucket)]} { - set histogram($bucket) 0 - } - incr histogram($bucket) - } - -histlog { - upvar #0 stats::H-$tag histogram - set bucket [expr {int(log($delta)*$counter(bucketsize))}] - if {![info exists histogram($bucket)]} { - set histogram($bucket) 0 - } - incr histogram($bucket) - } - -timehist { - upvar #0 stats::H-$tag histogram - variable minuteBase - variable secsPerMinute - - set minute [expr {([clock seconds] - $minuteBase) / $secsPerMinute}] - if {$minute > 59} { - # this occurs while debugging if the process is - # stopped at a breakpoint too long. - set minute 59 - } - - # Initialize the current bucket and - # clear any buckets we've skipped since the last sample. - - if {$minute != $counter(lastMinute)} { - set histogram($minute) 0 - for {set i [expr {$counter(lastMinute)+1}]} \ - {$i < $minute} \ - {incr i} { - set histogram($i) 0 - } - set counter(lastMinute) $minute - } - set histogram($minute) [expr {$histogram($minute) + $delta}] - } - default { - error "Unknown counter type \"$counter(type)\"" - } - } -# } - return -} - -# stats::countExists -- -# -# Return true if the counter exists. -# -# Arguments: -# tag The counter identifier. -# -# Results: -# 1 if it has been defined. -# -# Side Effects: -# None. - -proc stats::countExists {tag} { - upvar #0 stats::T-$tag counter - return [info exists counter] -} - -# stats::countGet -- -# -# Return statistics. -# -# Arguments: -# tag The counter identifier. -# option What statistic to get -# args Needed by some options. -# -# Results: -# With no args, just the counter value. -# -# Side Effects: -# None. - -proc stats::countGet {tag {option -total} args} { - upvar #0 stats::T-$tag counter - switch -- $option { - -total { - return $counter(total) - } - -totalVar { - return ::stats::T-$tag\(total) - } - -N { - return $counter(N) - } - -avg { - if {$counter(N) == 0} { - return 0 - } else { - return [expr {$counter(total) / double($counter(N))}] - } - } - -avgn { - upvar #0 stats::V-$tag vector - set sum 0 - for {set i 0} {($i < $counter(N)) && ($i < $counter(lastn))} {incr i} { - set sum [expr {$sum + $vector($i)}] - } - if {$i == 0} { - return 0 - } else { - return [expr {$sum / double($i)}] - } - } - -hist { - upvar #0 stats::H-$tag histogram - if {[llength $args]} { - # Return particular bucket - set bucket [lindex $args 0] - if {[info exists histogram($bucket)]} { - return $histogram($bucket) - } else { - return 0 - } - } else { - # Dump the whole histogram - - set result {} - if {$counter(type) == "-group"} { - set sort -dictionary - } else { - set sort -integer - } - foreach x [lsort $sort [array names histogram]] { - lappend result $x $histogram($x) - } - return $result - } - } - -histVar { - return ::stats::H-$tag - } - -histHour { - upvar #0 stats::Hour-$tag histogram - set result {} - foreach x [lsort -integer [array names histogram]] { - lappend result $x $histogram($x) - } - return $result - } - -histHourVar { - return ::stats::Hour-$tag - } - -histDay { - upvar #0 stats::Day-$tag histogram - set result {} - foreach x [lsort -integer [array names histogram]] { - lappend result $x $histogram($x) - } - return $result - } - -histDayVar { - return ::stats::Day-$tag - } - -maxPerMinute { - return $counter(maxPerMinute) - } - -maxPerHour { - return $counter(maxPerHour) - } - -maxPerDay { - return $counter(maxPerDay) - } - -resetDate { - if {[info exists counter(resetDate)]} { - return $counter(resetDate) - } else { - return "" - } - } - -all { - return [array get counter] - } - default { - return -code error "Invalid option $option.\ - Should be -all, -total, -N, -avg, -avgn, -hist, -histHour,\ - -histDay, -totalVar, -histVar, -histHourVar, -histDayVar -resetDate." - } - } -} - -# stats::countNames -- -# -# Return the list of defined counters. -# -# Arguments: -# none -# -# Results: -# A list of counter tags. -# -# Side Effects: -# None. - -proc stats::countNames {} { - set result {} - foreach v [info vars ::stats::T-*] { - if {[info exists $v]} { - # Declared arrays might not exist, yet - regsub -- ::stats::T- $v {} v - lappend result $v - } - } - return $result -} - -# stats::MergeHour -- -# -# Sum the per-minute histogram into the next hourly bucket. -# On 24-hour boundaries, sum the hourly buckets into the next day bucket. -# This operates on all time-based histograms. -# -# Arguments: -# none -# -# Results: -# none -# -# Side Effects: -# See description. - -proc stats::MergeHour {interval} { - variable hourIndex - variable minuteBase - variable hourBase - variable tagsToMerge - variable secsPerMinute - - after $interval [list stats::MergeHour $interval] - if {![info exists hourBase] || $hourIndex == 0} { - set hourBase $minuteBase - } - set minuteBase [clock seconds] - - foreach tag $tagsToMerge { - upvar #0 stats::T-$tag counter - upvar #0 stats::H-$tag histogram - upvar #0 stats::Hour-$tag hourhist - - # Clear any buckets we've skipped since the last sample. - - for {set i [expr {$counter(lastMinute)+1}]} {$i < 60} {incr i} { - set histogram($i) 0 - } - set counter(lastMinute) -1 - - # Accumulate into the next hour bucket. - - set hourhist($hourIndex) 0 - set max 0 - foreach i [array names histogram] { - set hourhist($hourIndex) [expr {$hourhist($hourIndex) + $histogram($i)}] - if {$histogram($i) > $max} { - set max $histogram($i) - } - } - set perSec [expr {$max / $secsPerMinute}] - if {$perSec > $counter(maxPerMinute)} { - set counter(maxPerMinute) $perSec - } - } - set hourIndex [expr {($hourIndex + 1) % 24}] - if {$hourIndex == 0} { - stats::MergeDay - } - -} -# stats::MergeDay -- -# -# Sum the per-minute histogram into the next hourly bucket. -# On 24-hour boundaries, sum the hourly buckets into the next day bucket. -# This operates on all time-based histograms. -# -# Arguments: -# none -# -# Results: -# none -# -# Side Effects: -# See description. - -proc stats::MergeDay {} { - variable dayIndex - variable dayBase - variable hourBase - variable tagsToMerge - - # Save the hours histogram into a bucket for the last day - # counter(day,$day) is the starting time for that day bucket - - if {![info exists dayBase]} { - set dayBase $hourBase - } - foreach tag $tagsToMerge { - upvar #0 stats::T-$tag counter - upvar #0 stats::Day-$tag dayhist - upvar #0 stats::Hour-$tag hourhist - set dayhist($dayIndex) 0 - set max 0 - for {set i 0} {$i < 24} {incr i} { - if {[info exists hourhist($i)]} { - set dayhist($dayIndex) [expr {$dayhist($dayIndex) + $hourhist($i)}] - if {$hourhist($i) > $max} { - set mx $hourhist($i) - } - } - } - set perSec [expr {double($max) / ($secsPerMinute * 60)}] - if {$perSec > $counter(maxPerHour)} { - set counter(maxPerHour) $perSec - } - } - set perSec [expr {double($dayhist($dayIndex)) / ($secsPerMinute * 60 * 24)}] - if {$perSec > $counter(maxPerDay)} { - set counter(maxPerDay) $perSec - } - incr dayIndex -} - -# stats::histHtmlDisplay -- -# -# Create an html display of the histogram. -# -# Arguments: -# tag The counter tag -# args option, value pairs that affect the display: -# -title Label to display above bar chart -# -unit minutes, hours, or days select time-base histograms. -# Specify anything else for value-based histograms. -# -images URL of /images directory. -# -gif Image for normal histogram bars -# -ongif Image for the active histogram bar -# -max Maximum number of value-based buckets to display -# -height Pixel height of the highest bar -# -width Pixel width of each bar -# -skip Buckets to skip when labeling value-based histograms -# -format Format used to display labels of buckets. -# -text If 1, a text version of the histogram is dumped, -# otherwise a graphical one is generated. -# -# Results: -# HTML for the display as a complete table. -# -# Side Effects: -# None. - -proc stats::histHtmlDisplay {tag args} { - append result "

\n\n" - append result [eval {stats::histHtmlDisplayRow $tag} $args] - append result
- return $result -} - -# stats::histHtmlDisplayRow -- -# -# Create an html display of the histogram. -# -# Arguments: -# See stats::histHtmlDisplay -# -# Results: -# HTML for the display. Ths is one row of a 2-column table, -# the calling page must define the tag. -# -# Side Effects: -# None. - -proc stats::histHtmlDisplayRow {tag args} { - upvar #0 stats::T-$tag counter - variable secsPerMinute - variable minuteBase - variable hourBase - variable dayBase - variable hourIndex - variable dayIndex - - array set options [list \ - -title $tag \ - -unit "" \ - -images /images \ - -gif Blue.gif \ - -ongif Red.gif \ - -max -1 \ - -height 100 \ - -width 4 \ - -skip 4 \ - -format %.2f \ - -text 0 - ] - array set options $args - - # Support for self-posting pages that can clear counters. - - append result "" - if {[ncgi::value resetCounter] == $tag} { - stats::countReset $tag - return "" - } - - switch -glob -- $options(-unit) { - min* { - upvar #0 stats::H-$tag histogram - set histname stats::H-$tag - if {![info exists minuteBase]} { - return "" - } - set time $minuteBase - set secsForMax $secsPerMinute - set periodMax $counter(maxPerMinute) - set curIndex [expr {([clock seconds] - $minuteBase) / $secsPerMinute}] - set options(-max) 60 - set options(-min) 0 - } - hour* { - upvar #0 stats::Hour-$tag histogram - set histname stats::Hour-$tag - if {![info exists hourBase]} { - return "" - } - set time $hourBase - set secsForMax [expr {$secsPerMinute * 60}] - set periodMax $counter(maxPerHour) - set curIndex [expr {$hourIndex - 1}] - if {$curIndex < 0} { - set curIndex 23 - } - set options(-max) 24 - set options(-min) 0 - } - day* { - upvar #0 stats::Day-$tag histogram - set histname stats::Day-$tag - if {![info exists dayBase]} { - return "" - } - set time $dayBase - set secsForMax [expr {$secsPerMinute * 60 * 24}] - set periodMax $counter(maxPerDay) - set curIndex dayIndex - set options(-max) $dayIndex - set options(-min) 0 - } - default { - # Value-based histogram with arbitrary units. - - upvar #0 stats::H-$tag histogram - set histname stats::H-$tag - - set unit $options(-unit) - set curIndex "" - set time "" - } - } - if {! [info exists histogram]} { - return "\n" - } - - set max 0 - set maxName 0 - foreach {name value} [array get histogram] { - if {$value > $max} { - set max $value - set maxName $name - } - } - - # Start 2-column HTML display. A summary table at the left, the histogram on the right. - - append result "\n - append result "\n - - return $result -} - -# stats::histHtmlDisplayBarChart -- -# -# Create an html display of the histogram. -# -# Arguments: -# tag The counter tag. -# histVar The name of the histogram array -# max The maximum counter value in a histogram bucket. -# curIndex The "current" histogram index, for time-base histograms. -# time The base, or starting time, for the time-based histograms. -# args The array get of the options passed into histHtmlDisplay -# -# Results: -# HTML for the bar chart. -# -# Side Effects: -# See description. - -proc stats::histHtmlDisplayBarChart {tag histVar max curIndex time args} { - upvar #0 ::stats::T-$tag counter - upvar 1 $histVar histogram - variable secsPerMinute - array set options $args - - append result "
\n" - - append result "\n" - append result "\n" - append result "" - append result "\n" - - if {[info exists secsForMax]} { - - # Time-base histogram - - set string {} - set t $secsForMax - set days [expr {$t / (60 * 60 * 24)}] - if {$days == 1} { - append string "1 Day " - } elseif {$days > 1} { - append string "$days Days " - } - set t [expr {$t - $days * (60 * 60 * 24)}] - set hours [expr {$t / (60 * 60)}] - if {$hours == 1} { - append string "1 Hour " - } elseif {$hours > 1} { - append string "$hours Hours " - } - set t [expr {$t - $hours * (60 * 60)}] - set mins [expr {$t / 60}] - if {$mins == 1} { - append string "1 Minute " - } elseif {$mins > 1} { - append string "$mins Minutes " - } - set t [expr {$t - $mins * 60}] - if {$t == 1} { - append string "1 Second " - } elseif {$t > 1} { - append string "$t Seconds " - } - append result "" - append result "\n" - - append result "" - append result "\n" - - if {$periodMax > 0} { - append result "" - append result "\n" - } - append result "" - switch -glob -- $options(-unit) { - min* { - append result "\n" - } - hour* { - append result "\n" - } - day* { - append result "\n" - } - default { - error "Unknown unit of time \"$options(-unit)\"" - } - } - - } else { - - # Value-base histogram - - set ix [lsort -integer [array names histogram]] - - set mode [expr {$counter(bucketsize) * $maxName}] - set first [expr {$counter(bucketsize) * [lindex $ix 0]}] - set last [expr {$counter(bucketsize) * [lindex $ix end]}] - - append result "" - append result "\n" - - append result "" - append result "\n" - - append result "" - append result "\n" - - append result "" - append result "\n" - - append result "" - append result "\n" - - append result "\n" - - if {$options(-max) < 0} { - set options(-max) [lindex $ix end] - } - if {![info exists options(-min)]} { - set options(-min) [lindex $ix 0] - } - } - - # End table nested inside left-hand column - - append result
[html::font]$options(-title)
[html::font]Total[html::font][format $options(-format) $counter(total)]
[html::font]Bucket Size[html::font]$string
[html::font]Max Per Sec[html::font][format %.2f [expr {$max/double($secsForMax)}]]
[html::font]Best Per Sec[html::font][format %.2f $periodMax]
[html::font]Starting Time[html::font][clock format $time \ - -format %k:%M:%S]
[html::font][clock format $time \ - -format %k:%M:%S]
[html::font][clock format $time \ - -format "%b %d %k:%M"]
[html::font]Average[html::font][format $options(-format) [countGet $tag -avg]]
[html::font]Mode[html::font]$mode
[html::font]Minimum[html::font]$first
[html::font]Maxmum[html::font]$last
[html::font]Unit[html::font]$unit
[html::font]" - append result "Reset
\n - append result 		\n" - - - # Display the histogram - - if {$options(-text)} { - } else { - append result [eval \ - {stats::histHtmlDisplayBarChart $tag histogram $max $curIndex $time} \ - [array get options]] - } - - # Close the right hand column, but leave our caller's table open. - - append result
\n" - - set ix [lsort -integer [array names histogram]] - - for {set t $options(-min)} {$t < $options(-max)} {incr t} { - if {![info exists histogram($t)]} { - set value 0 - } else { - set value $histogram($t) - } - if {$max == 0 || $value == 0} { - set height 1 - } else { - set percent [expr {round($value * 100.0 / $max)}] - set height [expr {$percent * $options(-height) / 100}] - } - if {$t == $curIndex} { - set img src=$options(-images)/$options(-ongif) - } else { - set img src=$options(-images)/$options(-gif) - } - append result "\n" - } - append result "" - - # Count buckets outside the range requested - - set overflow 0 - set underflow 0 - foreach t [lsort -integer [array names histogram]] { - if {($options(-max) > 0) && ($t > $options(-max))} { - incr overflow - } - if {($options(-min) >= 0) && ($t < $options(-min))} { - incr underflow - } - } - - # Append a row of labels at the bottom. - - if {$counter(type) != "-timehist"} { - - # Label each bucket with its value - # This is probably wrong for hist2x and hist10x - - append result "" - set skip $options(-skip) - if {![info exists counter(mult)]} { - set counter(mult) 1 - } - - # These are tick marks - - set img src=$options(-images)/$options(-gif) - append result "" - for {set i $options(-min)} {$i < $options(-max)} {incr i} { - if {(($i % $skip) == 0)} { - append result "\n" - } else { - append result "" - } - } - append result - - # These are the labels - - append result "" - for {set i $options(-min)} {$i < $options(-max)} {incr i} { - if {$counter(type) == "-histlog"} { - if {[catch {expr {int(log($i) * $counter(bucketsize))}} x]} { - # Out-of-bounds - break - } - } else { - set x [expr {$i * $counter(bucketsize) * $counter(mult)}] - } - set label [format $options(-format) $x] - if {(($i % $skip) == 0)} { - append result "" - } - } - append result - } else { - switch -glob -- $options(-unit) { - min* { - if {$secsPerMinute != 60} { - set format %k:%M:%S - set skip 12 - } else { - set format %k:%M - set skip 4 - } - set deltaT $secsPerMinute - set wrapDeltaT [expr {$secsPerMinute * -59}] - } - hour* { - if {$secsPerMinute != 60} { - set format %k:%M - set skip 4 - } else { - set format %k - set skip 2 - } - set deltaT [expr {$secsPerMinute * 60}] - set wrapDeltaT [expr {$secsPerMinute * 60 * -23}] - } - day* { - if {$secsPerMinute != 60} { - set format "%m/%d %k:%M" - set skip 10 - } else { - set format %k - set skip $options(-skip) - } - set deltaT [expr {$secsPerMinute * 60 * 24}] - set wrapDeltaT 0 - } - default { - error "Unknown unit of time \"$options(-unit)\"" - } - } - # These are tick marks - - set img src=$options(-images)/$options(-gif) - append result "" - foreach t [lsort -integer [array names histogram]] { - if {(($t % $skip) == 0)} { - append result "\n" - } else { - append result "" - } - } - append result - - set lastLabel "" - append result "" - foreach t [lsort -integer [array names histogram]] { - - # Label each bucket with its time - - set label [clock format $time -format $format] - if {(($t % $skip) == 0) && ($label != $lastLabel)} { - append result "" - set lastLabel $label - } - if {$t == $curIndex} { - incr time $wrapDeltaT - } else { - incr time $deltaT - } - } - append result \n - } - append result "
$value
$label
$label
" - if {$underflow > 0} { - append result "
Skipped $underflow samples <\ - [expr {$options(-min) * $counter(bucketsize)}]\n" - } - if {$overflow > 0} { - append result "
Skipped $overflow samples >\ - [expr {$options(-max) * $counter(bucketsize)}]\n" - } - return $result -} - -# stats::countStart -- -# -# Start an interval timer. This should be pre-declared with -# type either -hist, -hist2x, or -hist20x -# -# Arguments: -# tag The counter identifier. -# instance There may be multiple intervals outstanding -# at any time. This serves to distinquish them. -# -# Results: -# None -# -# Side Effects: -# Records the starting time for the instance of this interval. - -proc stats::countStart {tag instance} { - upvar #0 stats::Time-$tag time - set time($instance) [list [clock clicks] \ - [clock seconds]] -} - -# stats::countStop -- -# -# Record an interval timer. -# -# Arguments: -# tag The counter identifier. -# instance There may be multiple intervals outstanding -# at any time. This serves to distinquish them. -# func An optional function used to massage the time -# stamp before putting into the histogram. -# -# Results: -# None -# -# Side Effects: -# Computes the current interval and adds it to the histogram. - -proc stats::countStop {tag instance {func ::stats::countIdentity}} { - upvar #0 stats::Time-$tag time - - if {![info exists time($instance)]} { - # Extra call. Ignore so we can debug error cases. - return - } - set now [list [clock clicks] \ - [clock seconds]] - set delMicros [expr {[lindex $now 0] - [lindex $time($instance) 0]}] - set delSecond [expr {[lindex $now 1] - [lindex $time($instance) 1]}] - unset time($instance) - - if {$delMicros < 0} { - set delMicros [expr {1000000 + $delMicros}] - incr delSecond -1 - if {$delSecond < 0} { - set delSecond 0 - } - } - stats::count $tag [$func $delSecond.[format %06d $delMicros]] -} - -# stats::Identity -- -# -# Return its argument. This is used as the default function -# to apply to an interval timer. -# -# Arguments: -# x Some value. -# -# Results: -# $x -# -# Side Effects: -# None - - -proc stats::countIdentity {x} { - return $x -} DELETED modules/stats/stats.test Index: modules/stats/stats.test ================================================================== --- modules/stats/stats.test +++ /dev/null @@ -1,215 +0,0 @@ -# Tests for the stats module. -# -# This file contains a collection of tests for a module in the -# Standard Tcl Library. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 1998-2000 by Ajuba Solutions. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: stats.test,v 1.3 2000/10/02 07:40:59 welch Exp $ - -package require tcltest -namespace import -force ::tcltest::* - -catch {namespace delete stats} - -proc Stamp {tag} { - puts stderr "[clock format [clock seconds]] [clock clicks -milliseconds] $tag" -} - -set myFile [file join [file dirname [info script]] stats.tcl] -source $myFile -package require stats 1.0 - -test stats-1.1 {stats::countInit} { - catch {stats::countInit} err -} {1} - -set x 0 -puts "incr scaler [time {incr x} 100]" -set a(x) 0 -puts "incr array [time {incr a(x)} 100]" -set a(x) 0 -set a(n) 0 -puts "rawcount [time { - set a(x) [expr {$a(x) + 2.4}] - incr a(n) -} 100]" - -test stats-simple {stats::count} { - stats::countInit simple - stats::count simple - stats::count simple - stats::count simple - stats::countGet simple -} {3} -puts "simple [time {stats::count simple} 100]" - -test stats-avg {stats::count} { - stats::countInit avg - stats::count avg 2.2 - stats::count avg 3.3 - stats::count avg 9.8 - stats::countGet avg -avg -} {5.1} - -test stats-avg {stats::count} { - stats::countInit avg - stats::countGet avg -avg -} {0} - -test stats-lastn {averge over lastn} { - stats::countInit lastn -lastn 4 - stats::count lastn 2.2 - stats::count lastn 4.6 - stats::countGet lastn -avgn -} {3.4} - -test stats-lastn {averge over lastn} { - stats::countInit lastn -lastn 4 - stats::count lastn 2.2 - stats::count lastn 3.3 - stats::count lastn 8.6 - stats::count lastn 4.1 - stats::count lastn 6.9 - stats::count lastn 0.4 - stats::countGet lastn -avgn -} {5.0} -puts "lastn [time {stats::count lastn 2.4} 100]" - -test stats-lastn {lifetime average} { - stats::countInit lastn -lastn 4 - stats::count lastn 2.2 - stats::count lastn 3.3 - stats::count lastn 8.6 - stats::count lastn 4.1 - stats::count lastn 6.9 - stats::count lastn 0.4 - stats::countGet lastn -avg -} {4.25} -puts "lastn [time {stats::count lastn 2.4} 100]" - -test stats-hist {basic histogram} { - stats::countInit hist -hist 10 - stats::count hist 2.2 - stats::count hist 18.6 - stats::count hist 14.1 - stats::count hist 26.9 - stats::count hist 20.4 - stats::count hist 23.3 - stats::count hist 53.3 - stats::countGet hist -hist -} {0 1 1 2 2 3 5 1} -test stats-hist {histogram average} { - stats::countInit hist -hist 10 - stats::count hist 2.2 - stats::count hist 18.6 - stats::count hist 14.1 - stats::count hist 26.9 - stats::count hist 20.4 - stats::count hist 23.3 - stats::count hist 53.3 - stats::countGet hist -avg -} {22.6857142857} -puts "hist [time {stats::count hist 2.4} 100]" - -test stats-hist2x {stats::count} { - stats::countInit hist -hist2x 10 - stats::count hist 8 - stats::count hist 18 - stats::count hist 28 - stats::count hist 38 - stats::count hist 48 - stats::count hist 58 - stats::count hist 68 - stats::count hist 78 - stats::count hist 178 - stats::count hist 478 - stats::countGet hist -hist -} {0 1 1 1 2 2 3 4 5 1 6 1} -puts "hist2x [time {stats::count hist 50} 100]" - -test stats-hist10x {stats::count} { - stats::countInit hist -hist10x 10 - stats::count hist 8 - stats::count hist 18 - stats::count hist 28 - stats::count hist 38 - stats::count hist 48 - stats::count hist 58 - stats::count hist 68 - stats::count hist 78 - stats::count hist 178 - stats::count hist 478 - stats::count hist 1478 - stats::count hist 1478000 - stats::countGet hist -hist -} {0 1 1 7 2 2 3 1 6 1} - -test stats-histlog {stats::count} { - stats::countInit histlog -histlog 10 - stats::count histlog 0.1 - stats::count histlog 0.5 - stats::count histlog 0.9 - stats::count histlog 1.0 - stats::count histlog 2 - stats::count histlog 3 - stats::count histlog 5 - stats::count histlog 10 - stats::count histlog 30 - stats::count histlog 50 - stats::count histlog 100 - stats::count histlog 300 - stats::count histlog 500 - stats::count histlog 1000 - stats::countGet histlog -hist -} {0 1 1 7 2 2 3 1 6 1} - -test stats-timehist {stats::count} { - stats::countInit hits -timehist 4 - catch {puts stderr "Pausing during timehist tests"} - stats::count hits 2 - # We need to reach in and find out what bucket was used - array set info [stats::countGet hits -all] - set min0 $info(lastMinute) - after [expr 4000] - stats::count hits 4 - after [expr 4000] - stats::count hits 8 - foreach {n v} [stats::countGet hits -hist] { - if {$v > 0} { - lappend result [expr {$n - $min0}] $v - } - } - set result -} {0 2 1 4 2 8} - -puts "timehist [time {stats::count hits} 100]" - -test stats-countNames {stats::countNames} { - stats::countInit simple - stats::countInit avg - stats::countInit lastn -lastn 4 - stats::countInit hist -hist 10 - stats::countInit hits -timehist 4 - lsort [stats::countNames] -} {avg hist hits lastn simple} - -test stats-countExists {stats::countExist} { - stats::countInit simple - stats::countInit lastn -lastn 4 - unset stats::T-lastn - list [stats::countExists simple] [stats::countExists lastn] -} {1 0} - -test stats-countReset {stats::countReset} { - stats::countInit simple - stats::count simple 1 - stats::count simple 1 - stats::count simple 1 - stats::countReset simple - stats::countGet simple -} {0} DELETED modules/stooop/ChangeLog Index: modules/stooop/ChangeLog ================================================================== --- modules/stooop/ChangeLog +++ /dev/null @@ -1,21 +0,0 @@ -2003-04-11 Andreas Kupries - - * stooop.tcl: - * stooop.man: - * pkgIndex.tcl: Set version of the package to to 4.4.1 throughout. - -2003-04-01 Andreas Kupries - - * stooop.man: - * stooop.htm: Renamed to 'stoop_man.html'. Updated doctools - documentation to refer to manual under the new name. This - resolves the circular link reported in Tcllib SF bug #687923. - -2003-01-16 Andreas Kupries - - * stooop.man: More semantic markup, less visual one. - -2002-04-15 Andreas Kupries - - * stooop.man: Added doctools manpage. - DELETED modules/stooop/README Index: modules/stooop/README ================================================================== --- modules/stooop/README +++ /dev/null @@ -1,79 +0,0 @@ -This is stooop (a Simple Tcl Only Object Oriented Programming scheme) -version 4.2. Stooop is implemented in a single sourceable file and -uses simple techniques to provide object orientation to the great Tcl -language. - -If you know C++ or Java, stooop will be easy to use for you. Using the -familiar class, new, delete and virtual keywords and a few coding -conventions, you can start object oriented Tcl code right away, as the -following simple example shows: - - -source stooop.tcl -namespace import stooop::* - -class circle { - proc circle {this canvas diameter} { - set ($this,diameter) $diameter - set ($this,canvas) $canvas - set ($this,id) [$canvas create oval 0 0 $diameter $diameter] - } - proc ~circle {this} { - $($this,canvas) delete $($this,id) - } - proc move {this x y} { - $($this,canvas) move $($this,id) $x $y - } -} - -pack [canvas .canvas] -set c [new circle .canvas 50] -update; after 1000 -circle::move $c 10 10 -update; after 1000 -delete $c - - -Stooop supports single and multiple inheritance, data encapsulation -(all member data is public), dynamic binding, nested classes, object -copy, runtime type identification, optional runtime procedure and data -access checking as well as tracing. - -As stooop is entirely written in Tcl, it will run on all Tcl supported -platforms, including Windows and the Mac Intosh, if you have Tcl -version 8.3 or above. - -The class, new, delete, virtual and classof commands are implemented -as Tcl procedures. - -Stooop was implemented with a constant concern for performance. Member -data is stored in Tcl associative arrays, which are best for random -data access. Classes are implemented as namespaces to improve -encapsulation and reduce naming interferences. Object oriented helper -code is kept as small and as efficient as possible. Typically, only a -couple of Tcl lines are added to a member procedure definition. -Program startup time will be slightly increased due to some class and -member procedures preprocessing, but runtime overhead is kept to a -strict minimum. Use of object oriented techniques may actually improve -the performance of your code. - -A full HTML documentation, simple demonstration script, graphical -demonstration with composite pattern and test files are provided. You -may also run the test suite and look at the test scripts for -examples. There is also a utility for creating packages (in the Tcl -sense) from stooop compatible class files. - -There is a companion package to stooop: scwoop (a Simple Composite -Widget Object Oriented Package). Scwoop is implemented in a single -sourceable file and uses simple techniques to provide composite widget -(also known as mega widget) support to the great Tk widget library. -Moodss (a Modular Object Oriented Dynamic SpreadSheet) implemented -with stooop, scwoop, tkTable and BLT is also available on my website -(at http://jfontain.free.fr/). - -Whether you like it (or hate it), please let me know. I would like to -hear about bugs and improvements you would like to see. I will correct -the bugs quickly, especially if you send me a test script. - -Copyright (c) 2001 by Jean-Luc Fontaine . -This code may be distributed under the same terms as Tcl. DELETED modules/stooop/mkpkgidx.tcl Index: modules/stooop/mkpkgidx.tcl ================================================================== --- modules/stooop/mkpkgidx.tcl +++ /dev/null @@ -1,112 +0,0 @@ -# command line: -# $ interpreter mkpkgidx.tcl -p package1.n.n -p package2 -p package3.n ... -# packageName file1 file2 ... -# use wish as interpreter instead of tclsh in order to handle graphical packages - -# Copyright (c) 2001 by Jean-Luc Fontaine . -# This code may be distributed under the same terms as Tcl. -# -# $Id: mkpkgidx.tcl,v 1.2 2001/11/27 11:46:52 jfontain Exp $ - -# this utility must be used to create the package index file for a package that -# uses stooop. -# it differs from the tcl pkg_mkIndex procedure in the way it sources files. -# since base classes can usually be found in files separate from the derived -# class source file, sourcing each file in a different interpreter (as is done -# in the pkg_mkIndex procedure) results in an error for stooop that catches the -# fact that the base class is not defined. the solution is to use a single -# interpreter which will source the class files in order (base classes first at -# the user's responsibility). since stooop is loaded in that single interpreter, -# inheritance problems and others are automatically caught in the process. -# the generated package index file is fully compatible with the tcl generated -# ones. -# the stooop library makes sure that base classes source files are automatically -# sourced when a derived class is defined (see the stooop.tcl source file for -# more information). -# if your software requires one or more packages, you may force their loading -# by using the -p arguments. each package version number is optionally appended -# to the package name and follows the same rules as the Tcl package require -# command -# example: $ tclsh -p switched.1 -p scwoop foo bar.tcl barfoo.tcl foobar.tcl ... - -if {[catch {package require stooop 4}]} { - # in case stooop package is not installed - source stooop.tcl -} -namespace import stooop::* - -proc indexData {packageName files} { - global auto_index - - set index "# Package index file created with stooop version [package provide stooop] for stooop packages\n" - set data {} - - foreach command [info commands] { - set defined($command) {} - } - - foreach file $files { - # source at global level to avoid variable names collisions: - uplevel #0 source [list $file] - - catch {unset newCommands} ;# empty new commands array - foreach command [info commands] { - # check new commands at the global level - # filter out tk widget commands and ignore commands eventually - # loaded from a package required by the new commands - if { - [string match .* $command]||[info exists defined($command)]|| - [info exists auto_index($command)]||\ - [info exists auto_index(::$command)] - } continue - set newCommands($command) {} - set defined($command) {} - } - # check new classes, which actually are namespaces: - foreach class [array name stooop::declared] { - if {![info exists declared($class)]} { - # check new commands at the class namespace level: - foreach command [info commands ::${class}::*] { - # ignore commands eventually loaded from a package required - # by the new commands - if {\ - [info exists defined($command)]||\ - [info exists auto_index($command)]||\ - [info exists auto_index(::$command)]\ - } continue - set newCommands($command) {} - set defined($command) {} - } - set declared($class) {} - } - } - # so far only sourceable file, not shared libraries, are handled - lappend data [list $file source [lsort [array names newCommands]]] - } - set version [package provide $packageName] - append index "\npackage ifneeded $packageName $version \[list tclPkgSetup \$dir $packageName $version [list $data]\]" - return $index -} - -proc printUsage {exitCode} { - global argv0 - - puts stderr "usage: $argv0 \[\[-p package.n.n\] \[-p package.n.n\] ...\] moduleName tclFile tclFile ..." - exit $exitCode -} - -# first gather eventual packages: -for {set index 0} {$index<[llength $argv]} {incr index} { - if {[string compare [lindex $argv $index] -p]!=0} break - set version {} - scan [lindex $argv [incr index]] {%[^.].%s} name version - eval package require $name $version -} - -set argv [lrange $argv $index end] ;# keep remaining arguments -if {[llength $argv]<2} { - printUsage 1 -} - -puts [open pkgIndex.tcl w] [indexData [lindex $argv 0] [lrange $argv 1 end]] -exit ;# in case wish is used DELETED modules/stooop/pkgIndex.tcl Index: modules/stooop/pkgIndex.tcl ================================================================== --- modules/stooop/pkgIndex.tcl +++ /dev/null @@ -1,17 +0,0 @@ -# Copyright (c) 2001 by Jean-Luc Fontaine . -# This code may be distributed under the same terms as Tcl. -# -# $Id: pkgIndex.tcl,v 1.5 2003/04/11 20:18:45 andreas_kupries Exp $ - -# Since stooop redefines the proc command and the default package facility will -# only load the stooop package at the first unknown command, proc being -# obviously known by default, forcing the loading of stooop is mandatory prior -# to the first proc declaration. - -package ifneeded stooop 4.4.1 [list source [file join $dir stooop.tcl]] - -# the following package index instruction was generated using: -# "tclsh mkpkgidx.tcl switched switched.tcl" -# (comment out the following line if you do not want to use the switched class -# as a package) -package ifneeded switched 2.2 [list tclPkgSetup $dir switched 2.2 {{switched.tcl source {::switched::_copy ::switched::cget ::switched::complete ::switched::configure ::switched::description ::switched::descriptions ::switched::options ::switched::switched ::switched::~switched}}}] DELETED modules/stooop/stooop.man Index: modules/stooop/stooop.man ================================================================== --- modules/stooop/stooop.man +++ /dev/null @@ -1,221 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[manpage_begin stooop n 4.4.1] -[moddesc {Simple Tcl Only Object Oriented Programming}] -[titledesc {Object oriented extension.}] -[require Tcl 8.3] -[require stooop [opt 4.4.1]] -[description] -[para] - -This package provides commands to extend Tcl in an object oriented -manner, using a familiar C++ like syntax and behaviour. Stooop only -introduces a few new commands: [cmd class], [cmd new], [cmd delete], -[cmd virtual] and [cmd classof]. Along with a few coding conventions, -that is basically all you need to know to use stooop. Stooop is meant -to be as simple to use as possible. - -[para] - -This manual is very succinct and is to be used as a quick reminder for -the programmer, who should have read the thorough [uri stooop_man.html] -HTML documentation at this point. - -[list_begin definitions] - - -[call [cmd ::stooop::class] [arg {name body}]] - -This command creates a class. The body, similar in contents to a Tcl -namespace (which a class actually also is), contains member procedure -definitions. Member procedures can also be defined outside the class -body, by prefixing their name with [const class::], as you would -proceed with namespace procedures. - -[list_begin definitions] - -[lst_item "[cmd proc] [arg class] \{[const this] [opt [arg {arg arg ...}]]\} [opt "[arg base] \{[opt [arg {arg arg ...}]]\} ..."] [arg body]"] - -This is the constructor procedure for the class. It is invoked -following a [cmd new] invocation on the class. It must have the same -name as the class and a first argument named [const this]. Any number -of base classes specifications, including arguments to be passed to -their constructor, are allowed before the actual body of the -procedure. - -[lst_item "[cmd proc] ~[arg class] \{[const this]\} [arg body]"] - -This is the destructor procedure for the class. It is invoked -following a [cmd delete] invocation. Its name must be the -concatenation of a single [const ~] character followed by the class -name (as in C++). It must have a single argument named [const this]. - -[lst_item "[cmd proc] [arg name] \{[const this] [opt [arg {arg arg ...}]]\} [arg body]"] - -This is a member procedure of the class, as its first argument is -named [const this]. It allows a simple access of member data for the -object referenced by [const this] inside the procedure. For example: - -[example { - set ($this,data) 0 -}] - -[lst_item "[cmd proc] [arg name] \{[opt [arg {arg arg ...}]]\} [arg body]"] - -This is a static (as in C++) member procedure of the class, as its -first argument is not named [const this]. Static (global) class data -can be accessed as in: - -[example { - set (data) 0 -}] - -[lst_item "[cmd proc] [arg class] \{[const {this copy}]\} [arg body]"] - -This is the optional copy procedure for the class. It must have the -same name as the class and exactly 2 arguments named [const this] and -[const copy]. It is invoked following a [cmd new] invocation on an -existing object of the class. - -[list_end] - - -[call [cmd ::stooop::new] [arg class] [opt [arg {arg arg ...}]]] - -This command is used to create an object. The first argument is the -class name and is followed by the arguments needed by the -corresponding class constructor. A unique identifier for the object -just created is returned. - -[call [cmd ::stooop::delete] [arg object] [opt [arg {object ...}]]] - -This command is used to delete one or several objects. It takes one or -more object identifiers as argument(s). - -[call [cmd ::stooop::virtual] [const proc] [arg name] \{[const this] [opt [arg {arg arg ...}]]\} [opt [arg {body}]]] - -The [cmd virtual] specifier may be used on member procedures to -achieve dynamic binding. A procedure in a base class can then be -redefined (overloaded) in the derived class(es). If the base class -procedure is invoked on an object, it is actually the derived class -procedure which is invoked, if it exists. If the base class procedure -has no body, then it is considered to be a pure virtual and the -derived class procedure is always invoked. - -[call [cmd ::stooop::classof] [arg object]] - -This command returns the class of the existing object passed as single -parameter. - -[call [cmd ::stooop::new] [arg object]] - -This command is used to create an object by copying an existing -object. The copy constructor of the corresponding class is invoked if -it exists, otherwise a simple copy of the copied object data members -is performed. - -[list_end] - -[section DEBUGGING] - -[list_begin definitions] - -[lst_item {Environment variables}] - - -[list_begin definitions] - -[lst_item [var STOOOPCHECKDATA]] - -Setting this variable to any true value will cause stooop to check for -invalid member or class data access. - -[lst_item [var STOOOPCHECKPROCEDURES]] - -Setting this variable to any true value will cause stooop to check for -invalid member procedure arguments and pure interface classes -instanciation. - -[lst_item [var STOOOPCHECKALL]] - -Setting this variable to any true value will cause stooop to activate -both procedure and data member checking. - -[lst_item [var STOOOPCHECKOBJECTS]] - -Setting this variable to any true value will cause stooop to activate -object checking. The following stooop namespace procedures then become -available for debugging: [cmd printObjects], [cmd record] and -[cmd report]. - -[lst_item [var STOOOPTRACEPROCEDURES]] - -Setting this environment variable to either [const stdout], - -[const stderr] or a file name, activates procedure tracing. The -stooop library will then output to the specified channel 1 line of -informational text for each member procedure invocation. - -[lst_item [var STOOOPTRACEPROCEDURESFORMAT]] - -Defines the trace procedures output format. Defaults to -[const {"class: %C, procedure: %p, object: %O, arguments: %a"}]. - -[lst_item [var STOOOPTRACEDATA]] - -Setting this environment variable to either [const stdout], - -[const stderr] or a file name, activates data tracing. The stooop -library will then output to the specified channel 1 line of -informational text for each member data access. - -[lst_item [var STOOOPTRACEDATAFORMAT]] - -Defines the trace data output format. Defaults to -[const {"class: %C, procedure: %p, array: %A, object: %O, member: %m, operation: %o, value: %v"}]. - -[lst_item [var STOOOPTRACEDATAOPERATIONS]] - -When tracing data output, by default, all read, write and unsetting -accesses are reported, but the user can set this variable to any -combination of the letters [const r], [const w], and [const u] for -more specific tracing (please refer to the [cmd trace] Tcl manual page -for more information). - -[lst_item [var STOOOPTRACEALL]] - -Setting this environment variable to either [const stdout], - -[const stderr] or a file name, enables both procedure and data -tracing. - -[list_end] - - -[call [cmd ::stooop::printObjects] [opt [arg pattern]]] - -Prints an ordered list of existing objects, in creation order, oldest -first. Each output line contains the class name, object identifier and -the procedure within which the creation occurred. The optional pattern -argument (as in the Tcl [cmd {string match}] command) can be used to -limit the output to matching class names. - -[call [cmd ::stooop::record]] - -When invoked, a snapshot of all existing stooop objects is -taken. Reporting can then be used at a later time to see which objects -were created or deleted in the interval. - -[call [cmd ::stooop::report] [opt [arg pattern]]] - -Prints the created and deleted objects since the [cmd ::stooop::record] -procedure was invoked last. If present, the pattern argument limits -the output to matching class names. - -[list_end] - -[section EXAMPLES] - -Please see the full HTML documentation in [uri stooop_man.html]. - -[keywords class {object oriented} object C++] -[manpage_end] DELETED modules/stooop/stooop.n Index: modules/stooop/stooop.n ================================================================== --- modules/stooop/stooop.n +++ /dev/null @@ -1,118 +0,0 @@ -'\" -'\" Copyright (c) 2001 by Jean-Luc Fontaine . -'\" This code may be distributed under the same terms as Tcl. -'\" -'\" $Id: stooop.n,v 1.2 2001/12/10 09:07:31 jfontain Exp $ -.so man.macros -.TH stooop n 1.0 Stooop "Simple Tcl Only Object Oriented Programming" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -::stooop \- Object oriented extension. -.SH SYNOPSIS -\fBpackage require Tcl 8.3\fR -.sp -\fBpackage require stooop 4.2\fR -.br -\fBnamespace import stooop::*\fR -.sp -\fBclass\fR \fIname body\fR -.sp -\fBnew\fR \fIclass ?arg arg ...?\fR -.sp -\fBdelete\fR \fIobject ?object ...?\fR -.sp -\fBvirtual\fR \fIproc name {\fR\fBthis\fR \fI?arg arg ...?} ?body?\fR -.sp -\fBclassof\fR \fIobject\fR -.sp -\fBnew\fR \fIobject\fR -.BE -.SH DESCRIPTION -.PP -This package provides commands to extend Tcl in an object oriented manner, using a familiar C++ like syntax and behaviour. Stooop only introduces a few new commands: \fBclass\fR, \fBnew\fR, \fBdelete\fR, \fBvirtual\fR and \fBclassof\fR. Along with a few coding conventions, that is basically all you need to know to use stooop. Stooop is meant to be as simple to use as possible. -.sp -This manual is very succinct and is to be used as a quick reminder for the programmer, who should have read the thorough \fIstooop.html\fR HTML documentation at this point. -.TP -\fBclass\fR \fIname body\fR -This command creates a class. The body, similar in contents to a Tcl namespace (which a class actually also is), contains member procedure definitions. Member procedures can also be defined outside the class body, by prefixing their name with \fIclass::\fR, as you would proceed with namespace procedures. -.RS -.TP -\fIproc class {\fR\fBthis\fR \fI?arg arg ...?} ?base {?arg arg ...?} ...? body\fR -This is the constructor procedure for the class. It is invoked following a \fInew\fR invocation on the class. It must have the same name as the class and a first argument named \fIthis\fR. Any number of base classes specifications, including arguments to be passed to their constructor, are allowed before the actual body of the procedure. -.TP -\fIproc ~class {\fR\fBthis\fR\fI} body\fR -This is the destructor procedure for the class. It is invoked following a \fIdelete\fR invocation. Its name must be the concatenation of a single \fI~\fR character followed by the class name (as in C++). It must have a single argument named \fIthis\fR. -.TP -\fIproc name {\fR\fBthis\fR \fI?arg arg ...?} body\fR -This is a member procedure of the class, as its first argument is named \fIthis\fR. It allows a simple access of member data for the object referenced by \fIthis\fR inside the procedure. For example: \fIset ($this,data) 0\fR. -.TP -\fIproc name {?arg arg ...?} body\fR -This is a static (as in C++) member procedure of the class, as its first argument is not named \fIthis\fR. Static (global) class data can be accessed as in: \fIset (data) 0\fR. -.TP -\fIproc class {\fR\fBthis copy\fI} body\fR -This is the optional copy procedure for the class. It must have the same name as the class and exactly 2 arguments named \fIthis\fR and \fIcopy\fR. It is invoked following a \fInew\fR invocation on an existing object of the class. -.RE -.TP -\fBnew\fR \fIclass ?arg arg ...?\fR -This command is used to create an object. The first argument is the class name and is followed by the arguments needed by the corresponding class constructor. A unique identifier for the object just created is returned. -.TP -\fBdelete\fR \fIobject ?object ...?\fR -This command is used to delete one or several objects. It takes one or more object identifiers as argument(s). -.TP -\fBvirtual\fR \fIproc name {\fR\fBthis\fR \fI?arg arg ...?} ?body?\fR -The \fIvirtual\fR specifier may be used on member procedures to achieve dynamic binding. A procedure in a base class can then be redefined (overloaded) in the derived class(es). If the base class procedure is invoked on an object, it is actually the derived class procedure which is invoked, if it exists. If the base class procedure has no body, then it is considered to be a pure virtual and the derived class procedure is always invoked. -.TP -\fBclassof\fR \fIobject\fR -This command returns the class of the existing object passed as single parameter. -.TP -\fBnew\fR \fIobject\fR -This command is used to create an object by copying an existing object. The copy constructor of the corresponding class is invoked if it exists, otherwise a simple copy of the copied object data members is performed. -.SH DEBUGGING -.TP -Environment variables -.RS -.TP -STOOOPCHECKDATA -Setting this variable to any true value will cause stooop to check for invalid member or class data access. -.TP -STOOOPCHECKPROCEDURES -Setting this variable to any true value will cause stooop to check for invalid member procedure arguments and pure interface classes instanciation. -.TP -STOOOPCHECKALL -Setting this variable to any true value will cause stooop to activate both procedure and data member checking. -.TP -STOOOPCHECKOBJECTS -Setting this variable to any true value will cause stooop to activate object checking. The following stooop namespace procedures then become available for debugging: \fIprintObjects\fR, \fIrecord\fR and \fIreport\fR. -.TP -STOOOPTRACEPROCEDURES -Setting this environment variable to either \fIstdout\fR, \fIstderr\fR or a file name, activates procedure tracing. The stooop library will then output to the specified channel 1 line of informational text for each member procedure invocation. -.TP -STOOOPTRACEPROCEDURESFORMAT -Defines the trace procedures output format. Defaults to \fI"class: %C, procedure: %p, object: %O, arguments: %a"\fR. -.TP -STOOOPTRACEDATA -Setting this environment variable to either \fIstdout\fR, \fIstderr\fR or a file name, activates data tracing. The stooop library will then output to the specified channel 1 line of informational text for each member data access. -.TP -STOOOPTRACEDATAFORMAT -Defines the trace data output format. Defaults to \fI"class: %C, procedure: %p, array: %A, object: %O, member: %m, operation: %o, value: %v"\fR. -.TP -STOOOPTRACEDATAOPERATIONS -When tracing data output, by default, all read, write and unsetting accesses are reported, but the user can set this variable to any combination of the \fIr\fR, \fIw\fR and \fIu\fR letters for more specific tracing (please refer to the \fItrace\fR Tcl manual page for more information). -.TP -STOOOPTRACEALL -Setting this environment variable to either \fIstdout\fR, \fIstderr\fR or a file name, enables both procedure and data tracing. -.RE -.TP -\fB::stooop::printObjects\fR \fI?pattern?\fR -Prints an ordered list of existing objects, in creation order, oldest first. Each output line contains the class name, object identifier and the procedure within which the creation occured. The optional pattern argument (as in the Tcl \fIstring match\fR command) can be used to limit the output to matching class names. -.TP -\fB::stooop::record\fR -When invoked, a snapshot of all existing stooop objects is taken. Reporting can then be used at a later time to see which objects were created or deleted in the interval. -.TP -\fB::stooop::report\fR \fI?pattern?\fR -Prints the created and deleted objects since the \fIstooop::record\fR procedure was invoked last. If present, the pattern argument limits the output to matching class names. -.SH EXAMPLES -Please see the \fIstooop.html\fR HTML documentation. -.SH KEYWORDS -class object oriented C++ DELETED modules/stooop/stooop.tcl Index: modules/stooop/stooop.tcl ================================================================== --- modules/stooop/stooop.tcl +++ /dev/null @@ -1,938 +0,0 @@ -# stooop -# Simple Tcl Only Object Oriented Programming -# An object oriented extension to the Tcl programming language -# -# Copyright (c) 2002 by Jean-Luc Fontaine . -# This code may be distributed under the same terms as Tcl. -# -# $Id: stooop.tcl,v 1.7 2003/04/19 09:47:47 jfontain Exp $ - - -# check whether empty named arrays and array unset are supported: -package require Tcl 8.3 - -package provide stooop 4.4 - -# rename proc before it is overloaded, ignore error in case of multiple -# inclusion of this file: -catch {rename proc _proc} - -namespace eval ::stooop { - variable check - variable trace - - # no checking by default: use an empty instruction to avoid any performance - # hit: - set check(code) {} - if {[info exists ::env(STOOOPCHECKALL)]&&$::env(STOOOPCHECKALL)} { - array set ::env\ - {STOOOPCHECKPROCEDURES 1 STOOOPCHECKDATA 1 STOOOPCHECKOBJECTS 1} - } - set check(procedures) [expr {\ - [info exists ::env(STOOOPCHECKPROCEDURES)]&&\ - $::env(STOOOPCHECKPROCEDURES)\ - }] - set check(data) [expr {\ - [info exists ::env(STOOOPCHECKDATA)]&&$::env(STOOOPCHECKDATA)\ - }] - set check(objects) [expr {\ - [info exists ::env(STOOOPCHECKOBJECTS)]&&$::env(STOOOPCHECKOBJECTS)\ - }] - if {$check(procedures)} { - append check(code) {::stooop::checkProcedure;} - } - if {[info exists ::env(STOOOPTRACEALL)]} { - # use same channel for both traces - set ::env(STOOOPTRACEPROCEDURES) $::env(STOOOPTRACEALL) - set ::env(STOOOPTRACEDATA) $::env(STOOOPTRACEALL) - } - if {[info exists ::env(STOOOPTRACEPROCEDURES)]} { - set trace(procedureChannel) $::env(STOOOPTRACEPROCEDURES) - switch $trace(procedureChannel) { - stdout - stderr {} - default { - # eventually truncate output file if it exists: - set trace(procedureChannel) [open $::env(STOOOPTRACEPROCEDURES) w+] - } - } - # default format: - set trace(procedureFormat)\ - {class: %C, procedure: %p, object: %O, arguments: %a} - # eventually override with user defined format: - catch {set trace(procedureFormat) $::env(STOOOPTRACEPROCEDURESFORMAT)} - append check(code) {::stooop::traceProcedure;} - } - if {[info exists ::env(STOOOPTRACEDATA)]} { - set trace(dataChannel) $::env(STOOOPTRACEDATA) - switch $trace(dataChannel) { - stdout - stderr {} - default { - # eventually truncate output file if it exists - set trace(dataChannel) [open $::env(STOOOPTRACEDATA) w+] - } - } - # default format: - set trace(dataFormat) {class: %C, procedure: %p, array: %A, object: %O, member: %m, operation: %o, value: %v} - # eventually override with user defined format: - catch {set trace(dataFormat) $::env(STOOOPTRACEDATAFORMAT)} - # trace all operations by default: - set trace(dataOperations) rwu - # eventually override with user defined operations: - catch {set trace(dataOperations) $::env(STOOOPTRACEDATAOPERATIONS)} - } - - namespace export class virtual new delete classof ;# export public commands - - if {![info exists newId]} { - # initialize object id counter only once even if this file is sourced - # several times: - variable newId 0 - } - - # create an object of specified class or copy an existing object: - _proc new {classOrId args} { - variable newId - variable fullClass - - # use local variable for identifier because new can be invoked - # recursively: - if {[string is integer $classOrId]} { - # first argument is an object identifier (unsigned integer), copy - # source object to new object of identical class - if {[catch {\ - set fullClass([set id [incr newId]]) $fullClass($classOrId)\ - }]} { - error "invalid object identifier $classOrId" - } - # invoke the copy constructor for the class in caller's variable - # context so that object copy is transparent (see above): - uplevel 1 $fullClass($classOrId)::_copy $id $classOrId - } else { ;# first argument is a class - # generate constructor name: - set constructor ${classOrId}::[namespace tail $classOrId] - # we could detect here whether class was ever declared but that - # would prevent stooop packages to load properly, because - # constructor would not be invoked and thus class source file never - # sourced - # invoke the constructor for the class with optional arguments in - # caller's variable context so that object creation is transparent - # and that array names as constructor parameters work with a simple - # upvar - # note: if class is in a package, the class namespace code is loaded - # here, as the first object of the class is created - uplevel 1 $constructor [set id [incr newId]] $args - # generate fully qualified class namespace name now that we are sure - # that class namespace code has been invoked: - set fullClass($id) [namespace qualifiers\ - [uplevel 1 namespace which -command $constructor]\ - ] - } - return $id ;# return a unique object identifier - } - - _proc delete {args} { ;# delete one or more objects - variable fullClass - - foreach id $args { - # destruct in caller's variable context so that object deletion is - # transparent: - uplevel 1 ::stooop::deleteObject $fullClass($id) $id - unset fullClass($id) - } - } - - # delete object data starting at specified class layer and going up the base - # class hierarchy if any - # invoke the destructor for the object class and unset all the object data - # members for the class - # the destructor will in turn delete the base classes layers - _proc deleteObject {fullClass id} { - # invoke the destructor for the class in caller's variable context so - # that object deletion is transparent: - uplevel 1 ${fullClass}::~[namespace tail $fullClass] $id - # delete all this object data members if any (assume that they were - # stored as ${class}::($id,memberName)): - array unset ${fullClass}:: $id,* - # data member arrays deletion is left to the user - } - - _proc classof {id} { - variable fullClass - - return $fullClass($id) ;# return class of object - } - - # copy object data members from one object to another: - _proc copy {fullClass from to} { - set index [string length $from] - # copy regular data members: - foreach {name value} [array get ${fullClass}:: $from,*] { - set ${fullClass}::($to[string range $name $index end]) $value - } - # if any, array data members copy is left to the class programmer - # through the then mandatory copy constructor - } -} - -_proc ::stooop::class {args} { - variable declared - - set class [lindex $args 0] - # register class using its fully qualified name: - set declared([uplevel 1 namespace eval $class {namespace current}]) {} - # create the empty name array used to hold all class objects so that static - # members can be directly initialized within the class declaration but - # outside member procedures - uplevel 1 namespace eval $class [list "::variable {}\n[lindex $args end]"] -} - -# if procedure is a member of a known class, class and procedure names are set -# and true is returned, otherwise false is returned: -_proc ::stooop::parseProcedureName {\ - namespace name fullClassVariable procedureVariable messageVariable\ -} { - # namespace argument is the current namespace (fully qualified) in which the - # procedure is defined - variable declared - upvar 1 $fullClassVariable fullClass $procedureVariable procedure\ - $messageVariable message - - if {\ - [info exists declared($namespace)]&&\ - ([string length [namespace qualifiers $name]]==0)\ - } { - # a member procedure is being defined inside a class namespace - set fullClass $namespace - set procedure $name ;# member procedure name is full name - return 1 - } else { - # procedure is either a member of a known class or a regular procedure - if {![string match ::* $name]} { - # eventually fully qualify procedure name - if {[string equal $namespace ::]} { ;# global namespace special case - set name ::$name - } else { - set name ${namespace}::$name - } - } - # eventual class name is leading part: - set fullClass [namespace qualifiers $name] - if {[info exists declared($fullClass)]} { ;# if class is known - set procedure [namespace tail $name] ;# procedure always is the tail - return 1 - } else { ;# not a member procedure - if {[string length $fullClass]==0} { - set message "procedure $name class name is empty" - } else { - set message "procedure $name class $fullClass is unknown" - } - return 0 - } - } -} - -# virtual operator, to be placed before proc -# virtualize a member procedure, determine whether it is a pure virtual, check -# for procedures that cannot be virtualized -_proc ::stooop::virtual {keyword name arguments args} { - # set a flag so that proc knows it is acting upon a virtual procedure, also - # serves as a pure indicator: - variable pureVirtual - - if {![string equal [uplevel 1 namespace which -command $keyword] ::proc]} { - error "virtual operator works only on proc, not $keyword" - } - if {![parseProcedureName\ - [uplevel 1 namespace current] $name fullClass procedure message\ - ]} { - error $message ;# not in a member procedure definition - } - set class [namespace tail $fullClass] - if {[string equal $class $procedure]} { - error "cannot make class $fullClass constructor virtual" - } - if {[string equal ~$class $procedure]} { - error "cannot make class $fullClass destructor virtual" - } - if {![string equal [lindex $arguments 0] this]} { - error "cannot make static procedure $procedure of class $fullClass virtual" - } - # no procedure body means pure virtual: - set pureVirtual [expr {[llength $args]==0}] - # process procedure declaration, body being empty for pure virtual procedure - # make virtual transparent by using uplevel: - uplevel 1 ::proc [list $name $arguments [lindex $args 0]] - unset pureVirtual -} - -_proc proc {name arguments args} { - if {![::stooop::parseProcedureName\ - [uplevel 1 namespace current] $name fullClass procedure message\ - ]} { - # not in a member procedure definition, fall back to normal procedure - # declaration - # uplevel is required instead of eval here otherwise tcl seems to forget - # the procedure namespace if it exists - uplevel 1 _proc [list $name $arguments] $args - return - } - if {[llength $args]==0} { ;# check for procedure body presence - error "missing body for ${fullClass}::$procedure" - } - set class [namespace tail $fullClass] - if {[string equal $class $procedure]} { ;# class constructor definition - if {![string equal [lindex $arguments 0] this]} { - error "class $fullClass constructor first argument must be this" - } - if {[string equal [lindex $arguments 1] copy]} { - # user defined copy constructor definition - if {[llength $arguments]!=2} { - error "class $fullClass copy constructor must have 2 arguments exactly" - } - # make sure of proper declaration order: - if {[catch {info body ::${fullClass}::$class}]} { - error "class $fullClass copy constructor defined before constructor" - } - eval ::stooop::constructorDeclaration\ - $fullClass $class 1 \{$arguments\} $args - } else { ;# main constructor - eval ::stooop::constructorDeclaration\ - $fullClass $class 0 \{$arguments\} $args - # always generate default copy constructor: - ::stooop::generateDefaultCopyConstructor $fullClass - } - } elseif {[string equal ~$class $procedure]} { - # class destructor declaration - if {[llength $arguments]!=1} { - error "class $fullClass destructor must have 1 argument exactly" - } - if {![string equal [lindex $arguments 0] this]} { - error "class $fullClass destructor argument must be this" - } - # make sure of proper declaration order - # (use fastest method for testing procedure existence): - if {[catch {info body ::${fullClass}::$class}]} { - error "class $fullClass destructor defined before constructor" - } - ::stooop::destructorDeclaration\ - $fullClass $class $arguments [lindex $args 0] - } else { - # regular member procedure, may be static if there is no this first - # argument - # make sure of proper declaration order: - if {[catch {info body ::${fullClass}::$class}]} { - error "class $fullClass member procedure $procedure defined before constructor" - } - ::stooop::memberProcedureDeclaration\ - $fullClass $class $procedure $arguments [lindex $args 0] - } -} - -# copy flag is set for user defined copy constructor: -_proc ::stooop::constructorDeclaration {fullClass class copy arguments args} { - variable check - variable fullBases - variable variable - - set number [llength $args] - # check that each base class constructor has arguments: - if {($number%2)==0} { - error "bad class $fullClass constructor declaration, a base class, contructor arguments or body may be missing" - } - if {[string equal [lindex $arguments end] args]} { - # remember that there is a variable number of arguments in class - # constructor - set variable($fullClass) {} - } - if {!$copy} { - # do not initialize (or reinitialize in case of multiple class file - # source statements) base classes for copy constructor - set fullBases($fullClass) {} - } - # check base classes and their constructor arguments: - foreach {base baseArguments} [lrange $args 0 [expr {$number-2}]] { - # fully qualify base class namespace by looking up constructor, which - # must exist - set constructor ${base}::[namespace tail $base] - # in case base class is defined in a file that is part of a package, - # make sure that file is sourced through the tcl package auto-loading - # mechanism by directly invoking the base class constructor while - # ignoring the resulting error - catch {$constructor} - # determine fully qualified base class name in user invocation level - # (up 2 levels from here since this procedure is invoked exclusively by - # proc) - set fullBase [namespace qualifiers\ - [uplevel 2 namespace which -command $constructor]\ - ] - if {[string length $fullBase]==0} { ;# base constructor is not defined - if {[string match *$base $fullClass]} { - # if the specified base class name is included last in the fully - # qualified class name, assume that it was meant to be the same - error "class $fullClass cannot be derived from itself" - } else { - error "class $fullClass constructor defined before base class $base constructor" - } - } - # check and save base classes only for main constructor that defines - # them: - if {!$copy} { - if {[lsearch -exact $fullBases($fullClass) $fullBase]>=0} { - error "class $fullClass directly inherits from class $fullBase more than once" - } - lappend fullBases($fullClass) $fullBase - } - # replace new lines with blanks in base arguments part in case user has - # formatted long declarations with new lines - regsub -all {\n} $baseArguments { } constructorArguments($fullBase) - } - # setup access to class data (an empty named array) - # fully qualify tcl variable command for it may have been redefined within - # the class namespace - # since constructor is directly invoked by new, the object identifier must - # be valid, so debugging the procedure is pointless - set constructorBody \ -"::variable {} -$check(code) -" - # base class(es) derivation specified: - if {[llength $fullBases($fullClass)]>0} { - # invoke base class constructors before evaluating constructor body - # then set base part hidden derived member so that virtual procedures - # are invoked at base class level as in C++ - if {[info exists variable($fullClass)]} { - # variable number of arguments in derived class constructor - foreach fullBase $fullBases($fullClass) { - if {![info exists constructorArguments($fullBase)]} { - error "missing base class $fullBase constructor arguments from class $fullClass constructor" - } - set baseConstructor ${fullBase}::[namespace tail $fullBase] - if {\ - [info exists variable($fullBase)]&&\ - ([string first {$args} $constructorArguments($fullBase)]>=0)\ - } { - # variable number of arguments in base class constructor and - # in derived class base class constructor arguments - # use eval so that base class constructor sees arguments - # instead of a list - # only the last argument of the base class constructor - # arguments is considered as a variable list - # (it usually is $args but could be a procedure invocation, - # such as [filter $args]) - # fully qualify tcl commands such as set, for they may have - # been redefined within the class namespace - append constructorBody \ -"::set _list \[::list $constructorArguments($fullBase)\] -::eval $baseConstructor \$this \[::lrange \$_list 0 \[::expr {\[::llength \$_list\]-2}\]\] \[::lindex \$_list end\] -::unset _list -::set ${fullBase}::(\$this,_derived) $fullClass -" - } else { - # no special processing needed - # variable number of arguments in base class constructor or - # variable arguments list passed as is to base class - # constructor - append constructorBody \ -"$baseConstructor \$this $constructorArguments($fullBase) -::set ${fullBase}::(\$this,_derived) $fullClass -" - } - } - } else { ;# constant number of arguments - foreach fullBase $fullBases($fullClass) { - if {![info exists constructorArguments($fullBase)]} { - error "missing base class $fullBase constructor arguments from class $fullClass constructor" - } - set baseConstructor ${fullBase}::[namespace tail $fullBase] - append constructorBody \ -"$baseConstructor \$this $constructorArguments($fullBase) -::set ${fullBase}::(\$this,_derived) $fullClass -" - } - } - } ;# else no base class derivation specified - if {$copy} { - # for user defined copy constructor, copy derived class member if it - # exists - append constructorBody \ -"::catch {::set (\$this,_derived) \$(\$[::lindex $arguments 1],_derived)} -" - } - # finally append user defined procedure body: - append constructorBody [lindex $args end] - if {$copy} { - _proc ${fullClass}::_copy $arguments $constructorBody - } else { - _proc ${fullClass}::$class $arguments $constructorBody - } -} - -_proc ::stooop::destructorDeclaration {fullClass class arguments body} { - variable check - variable fullBases - - # setup access to class data - # since the object identifier is always valid at this point, debugging the - # procedure is pointless - set body \ -"::variable {} -$check(code) -$body -" - # if there are any, delete base classes parts in reverse order of - # construction - for {set index [expr {[llength $fullBases($fullClass)]-1}]} {$index>=0}\ - {incr index -1}\ - { - set fullBase [lindex $fullBases($fullClass) $index] - append body \ -"::stooop::deleteObject $fullBase \$this -" - } - _proc ${fullClass}::~$class $arguments $body -} - -_proc ::stooop::memberProcedureDeclaration {\ - fullClass class procedure arguments body\ -} { - variable check - variable pureVirtual - - if {[info exists pureVirtual]} { ;# virtual declaration - if {$pureVirtual} { ;# pure virtual declaration - # setup access to class data - # evaluate derived procedure which must exists. derived procedure - # return value is automatically returned - _proc ${fullClass}::$procedure $arguments \ -"::variable {} -$check(code) -::uplevel 1 \$(\$this,_derived)::$procedure \[::lrange \[::info level 0\] 1 end\] -" - } else { ;# regular virtual declaration - # setup access to class data - # evaluate derived procedure and return if it exists - # else evaluate the base class procedure which can be invoked from - # derived class procedure by prepending _ - _proc ${fullClass}::_$procedure $arguments \ -"::variable {} -$check(code) -$body -" - _proc ${fullClass}::$procedure $arguments \ -"::variable {} -$check(code) -if {!\[::catch {::info body \$(\$this,_derived)::$procedure}\]} { -::return \[::uplevel 1 \$(\$this,_derived)::$procedure \[::lrange \[::info level 0\] 1 end\]\] -} -::uplevel 1 ${fullClass}::_$procedure \[::lrange \[::info level 0\] 1 end\] -" - } - } else { ;# non virtual declaration - # setup access to class data: - _proc ${fullClass}::$procedure $arguments \ -"::variable {} -$check(code) -$body -" - } -} - -# generate default copy procedure which may be overriden by the user for any -# class layer: -_proc ::stooop::generateDefaultCopyConstructor {fullClass} { - variable fullBases - - # generate code for cloning base classes layers if there is at least one - # base class - foreach fullBase $fullBases($fullClass) { - append body \ -"${fullBase}::_copy \$this \$sibling -" - } - append body \ -"::stooop::copy $fullClass \$sibling \$this -" - _proc ${fullClass}::_copy {this sibling} $body -} - - -if {[llength [array names ::env STOOOP*]]>0} { - # if one or more environment variables are set, we are in debugging mode - - # gracefully handle multiple sourcing of this file: - catch {rename ::stooop::class ::stooop::_class} - # use a new class procedure instead of adding debugging code to existing one - _proc ::stooop::class {args} { - variable trace - variable check - - set class [lindex $args 0] - if {$check(data)} { - # check write and unset operations on empty named array holding - # class data - uplevel 1 namespace eval $class\ - [list {::trace variable {} wu ::stooop::checkData}] - } - if {[info exists ::env(STOOOPTRACEDATA)]} { - # trace write and unset operations on empty named array holding - # class data - uplevel 1 namespace eval $class [list\ - "::trace variable {} $trace(dataOperations) ::stooop::traceData"\ - ] - } - uplevel 1 ::stooop::_class $args - } - - if {$::stooop::check(procedures)} { - # prevent the creation of any object of a pure interface class - # use a new virtual procedure instead of adding debugging code to - # existing one - # gracefully handle multiple sourcing of this file: - catch {rename ::stooop::virtual ::stooop::_virtual} - # keep track of interface classes (which have at least 1 pure virtual - # procedure): - _proc ::stooop::virtual {keyword name arguments args} { - variable interface - - uplevel 1 ::stooop::_virtual [list $keyword $name $arguments] $args - parseProcedureName [uplevel 1 namespace current] $name\ - fullClass procedure message - if {[llength $args]==0} { ;# no procedure body means pure virtual - set interface($fullClass) {} - } - } - } - - if {$::stooop::check(objects)} { - _proc invokingProcedure {} { - if {[catch {set procedure [lindex [info level -2] 0]}]} { - # no invoking procedure - return {top level} - } elseif {\ - ([string length $procedure]==0)||\ - [string equal $procedure namespace]\ - } { ;# invoked from a namespace body - return "namespace [uplevel 2 namespace current]" - } else { - # store fully qualified name, visible from creator procedure - # invoking procedure - return [uplevel 3 namespace which -command $procedure] - } - } - } - - if {$::stooop::check(procedures)||$::stooop::check(objects)} { - # gracefully handle multiple sourcing of this file: - catch {rename ::stooop::new ::stooop::_new} - # use a new new procedure instead of adding debugging code to existing - # one: - _proc ::stooop::new {classOrId args} { - variable newId - variable check - - if {$check(procedures)} { - variable fullClass - variable interface - } - if {$check(objects)} { - variable creator - } - if {$check(procedures)} { - if {[string is integer $classOrId]} { - # first argument is an object identifier - # class code, if from a package, must already be loaded - set fullName $fullClass($classOrId) - } else { ;# first argument is a class - # generate constructor name: - set constructor ${classOrId}::[namespace tail $classOrId] - # force loading in case class is in a package so namespace - # commands work properly: - catch {$constructor} - set fullName [namespace qualifiers\ - [uplevel 1 namespace which -command $constructor]\ - ] - # anticipate full class name storage in original new{} in - # order to avoid invalid object identifier error in - # checkProcedure{} when member procedure is invoked from - # within contructor, in which case full class name would - # have yet to be stored. - set fullClass([expr {$newId+1}]) $fullName - # new identifier is really incremented in original new{} - } - if {[info exists interface($fullName)]} { - error "class $fullName with pure virtual procedures should not be instanciated" - } - } - if {$check(objects)} { - # keep track of procedure in which creation occured (new - # identifier is really incremented in original new{}) - set creator([expr {$newId+1}]) [invokingProcedure] - } - return [uplevel 1 ::stooop::_new $classOrId $args] - } - } - - if {$::stooop::check(objects)} { - _proc ::stooop::delete {args} { - variable fullClass - variable deleter - - # keep track of procedure in which deletion occured: - set procedure [invokingProcedure] - foreach id $args { - uplevel 1 ::stooop::deleteObject $fullClass($id) $id - unset fullClass($id) - set deleter($id) $procedure - } - } - } - - # return the unsorted list of ancestors in class hierarchy: - _proc ::stooop::ancestors {fullClass} { - variable ancestors ;# use a cache for efficiency - variable fullBases - - if {[info exists ancestors($fullClass)]} { - return $ancestors($fullClass) ;# found in the cache - } - set list {} - foreach class $fullBases($fullClass) { - set list [concat $list [list $class] [ancestors $class]] - } - set ancestors($fullClass) $list ;# save in cache - return $list - } - - # since this procedure is always invoked from a debug procedure, take the - # extra level in the stack frame into account - # parameters (passed as references) that cannot be determined are not set - _proc ::stooop::debugInformation {\ - className fullClassName procedureName fullProcedureName\ - thisParameterName\ - } { - upvar 1 $className class $fullClassName fullClass\ - $procedureName procedure $fullProcedureName fullProcedure\ - $thisParameterName thisParameter - variable declared - - set namespace [uplevel 2 namespace current] - # not in a class namespace: - if {[lsearch -exact [array names declared] $namespace]<0} return - # remove redundant global qualifier: - set fullClass [string trimleft $namespace :] - set class [namespace tail $fullClass] ;# class name - set list [info level -2] - set first [lindex $list 0] - if {([llength $list]==0)||[string equal $first namespace]}\ - return ;# not in a procedure, nothing else to do - set procedure $first - # procedure must be known at the invoker level: - set fullProcedure [uplevel 3 namespace which -command $procedure] - set procedure [namespace tail $procedure] ;# strip procedure name - if {[string equal $class $procedure]} { ;# constructor - set procedure constructor - } elseif {[string equal ~$class $procedure]} { ;# destructor - set procedure destructor - } - if {[string equal [lindex [info args $fullProcedure] 0] this]} { - # non static procedure - # object identifier is first argument: - set thisParameter [lindex $list 1] - } - } - - # check that member procedure is valid for object passed as parameter: - _proc ::stooop::checkProcedure {} { - variable fullClass - - debugInformation class qualifiedClass procedure qualifiedProcedure this - # static procedure, no checking possible: - if {![info exists this]} return - # in constructor, checking useless since object is not yet created: - if {[string equal $procedure constructor]} return - if {![info exists fullClass($this)]} { - error "$this is not a valid object identifier" - } - set fullName [string trimleft $fullClass($this) :] - # procedure and object classes match: - if {[string equal $fullName $qualifiedClass]} return - # restore global qualifiers to compare with internal full class array - # data - if {[lsearch -exact [ancestors ::$fullName] ::$qualifiedClass]<0} { - error "class $qualifiedClass of $qualifiedProcedure procedure not an ancestor of object $this class $fullName" - } - } - - # gather current procedure data, perform substitutions and output to trace - # channel: - _proc ::stooop::traceProcedure {} { - variable trace - - debugInformation class qualifiedClass procedure qualifiedProcedure this - # all debug data is available since we are for sure in a class procedure - set text $trace(procedureFormat) - regsub -all %C $text $qualifiedClass text ;# fully qualified class name - regsub -all %c $text $class text - # fully qualified procedure name: - regsub -all %P $text $qualifiedProcedure text - regsub -all %p $text $procedure text - if {[info exists this]} { ;# non static procedure - regsub -all %O $text $this text - # remaining arguments: - regsub -all %a $text [lrange [info level -1] 2 end] text - } else { ;# static procedure - regsub -all %O $text {} text - # remaining arguments: - regsub -all %a $text [lrange [info level -1] 1 end] text - } - puts $trace(procedureChannel) $text - } - - # check that class data member is accessed within procedure of identical - # class - # then if procedure is not static, check that only data belonging to the - # object passed as parameter is accessed - _proc ::stooop::checkData {array name operation} { - scan $name %u,%s identifier member - # ignore internally defined members: - if {[info exists member]&&[string equal $member _derived]} return - - debugInformation class qualifiedClass procedure qualifiedProcedure this - # no checking can be done outside of a class namespace: - if {![info exists class]} return - # determine array full name: - set array [uplevel 1 [list namespace which -variable $array]] - if {![info exists procedure]} { ;# inside a class namespace - # compare with empty named array fully qualified name: - if {![string equal $array ::${qualifiedClass}::]} { - # trace command error message is automatically prepended and - # indicates operation - error\ - "class access violation in class $qualifiedClass namespace" - } - return ;# done - } - # ignore internal copy procedure: - if {[string equal $qualifiedProcedure ::stooop::copy]} return - if {![string equal $array ::${qualifiedClass}::]} { - # compare with empty named array fully qualified name - # trace command error message is automatically prepended and - # indicates operation - error "class access violation in procedure $qualifiedProcedure" - } - # static procedure, all objects can be accessed: - if {![info exists this]} return - # static data members can be accessed: - if {![info exists identifier]} return - # check that accessed data belongs to this object: - if {$this!=$identifier} { - error "object $identifier access violation in procedure $qualifiedProcedure acting on object $this" - } - } - - # gather accessed data member information, perform substitutions and output - # to trace channel - _proc ::stooop::traceData {array name operation} { - variable trace - - scan $name %u,%s identifier member - # ignore internally defined members: - if {[info exists member]&&[string equal $member _derived]} return - - # ignore internal destruction: - if {\ - ![catch {lindex [info level -1] 0} procedure]&&\ - [string equal ::stooop::deleteObject $procedure]\ - } return - set class {} ;# in case we are outside a class - set qualifiedClass {} - set procedure {} ;# in case we are outside a class procedure - set qualifiedProcedure {} - - debugInformation class qualifiedClass procedure qualifiedProcedure this - set text $trace(dataFormat) - regsub -all %C $text $qualifiedClass text ;# fully qualified class name - regsub -all %c $text $class text - if {[info exists member]} { - regsub -all %m $text $member text - } else { - regsub -all %m $text $name text ;# static member - } - # fully qualified procedure name: - regsub -all %P $text $qualifiedProcedure text - regsub -all %p $text $procedure text - # fully qualified array name with global qualifiers stripped: - regsub -all %A $text [string trimleft\ - [uplevel 1 [list namespace which -variable $array]] :\ - ] text - if {[info exists this]} { ;# non static procedure - regsub -all %O $text $this text - } else { ;# static procedure - regsub -all %O $text {} text - } - array set string {r read w write u unset} - regsub -all %o $text $string($operation) text - if {[string equal $operation u]} { - regsub -all %v $text {} text ;# no value when unsetting - } else { - regsub -all %v $text [uplevel 1 set ${array}($name)] text - } - puts $trace(dataChannel) $text - } - - if {$::stooop::check(objects)} { - # print existing objects along with creation procedure, with optional - # class pattern (see the string Tcl command manual) - _proc ::stooop::printObjects {{pattern *}} { - variable fullClass - variable creator - - puts "stooop::printObjects invoked from [invokingProcedure]:" - foreach id [lsort -integer [array names fullClass]] { - if {[string match $pattern $fullClass($id)]} { - puts "$fullClass($id)\($id\) + $creator($id)" - } - } - } - - # record all existing objects for later report: - _proc ::stooop::record {} { - variable fullClass - variable checkpointFullClass - - puts "stooop::record invoked from [invokingProcedure]" - catch {unset checkpointFullClass} - array set checkpointFullClass [array get fullClass] - } - - # print all new or deleted object since last record, with optional class - # pattern: - _proc ::stooop::report {{pattern *}} { - variable fullClass - variable checkpointFullClass - variable creator - variable deleter - - puts "stooop::report invoked from [invokingProcedure]:" - set checkpointIds [lsort -integer [array names checkpointFullClass]] - set currentIds [lsort -integer [array names fullClass]] - foreach id $currentIds { - if {\ - [string match $pattern $fullClass($id)]&&\ - ([lsearch -exact $checkpointIds $id]<0)\ - } { - puts "+ $fullClass($id)\($id\) + $creator($id)" - } - } - foreach id $checkpointIds { - if {\ - [string match $pattern $checkpointFullClass($id)]&&\ - ([lsearch -exact $currentIds $id]<0)\ - } { - puts "- $checkpointFullClass($id)\($id\) - $deleter($id) + $creator($id)" - } - } - } - } - -} DELETED modules/stooop/stooop.test Index: modules/stooop/stooop.test ================================================================== --- modules/stooop/stooop.test +++ /dev/null @@ -1,9381 +0,0 @@ -# Copyright (c) 2001 by Jean-Luc Fontaine . -# This code may be distributed under the same terms as Tcl. -# -# $Id: stooop.test,v 1.4 2001/12/19 11:58:22 jfontain Exp $ - -if {[lsearch [namespace children] ::tcltest]<0} { - package require tcltest - namespace import ::tcltest::* -} - -set source [file join [file dirname [info script]] stooop.tcl] - -set dumpArraysCode { - proc dumpArrays {args} { - set list {} - foreach array $args { - upvar $array data - foreach name [lsort [array names data]] { - lappend list "$array\($name\) = $data($name)" - } - } - return $list - } -} - -test stooop-0 { - check that the empty named array feature works -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - set (0) 0 - lappend ::result $(0) - namespace eval n { - variable {} - set (1) 1 - lappend ::result $(1) - } - - set ::result - }] - interp delete $interpreter - set result -} [list\ - 0\ - 1\ -] - -test stooop-1 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - catch {new a} ::result - set ::result - }] - interp delete $interpreter - set result -} {invalid command name "a::a"} - -test stooop-2 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a {} - proc a::a {this} { - lappend ::result "a::a $this" - } - catch {delete [new a]} message - lappend ::result $message - - class A { - proc A {this} { - lappend ::result "A::A $this" - } - } - catch {delete [new A]} message - lappend ::result $message - - class b::c {} - proc b::c::c {this} { - lappend ::result "c::c $this" - } - catch {delete [new b::c]} message - lappend ::result $message - - class B { - class C { - proc C {this} { - lappend ::result "C::C $this" - } - } - catch {delete [new C]} message - lappend ::result $message - } - catch {delete [new B::C]} message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1}\ - {invalid command name "::a::~a"}\ - {A::A 2}\ - {invalid command name "::A::~A"}\ - {c::c 3}\ - {invalid command name "::b::c::~c"}\ - {C::C 4}\ - {invalid command name "::B::C::~C"}\ - {C::C 5}\ - {invalid command name "::B::C::~C"}\ -] - -test stooop-3 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a {} - catch {new a} message - lappend ::result $message - - class b::c {} - catch {new b::c} message - lappend ::result $message - - class A {} - catch {new A} message - lappend ::result $message - - class B { - class C {} - catch {new C} message - lappend ::result $message - } - catch {new B::C} message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {invalid command name "a::a"}\ - {invalid command name "b::c::c"}\ - {invalid command name "A::A"}\ - {invalid command name "C::C"}\ - {invalid command name "B::C::C"}\ -] - -test stooop-4 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this p q} { - lappend ::result "a::a $this" - set ($this,m) $p - set ($this,n) $q - } - proc a::~a {this} { - lappend ::result "a::~a $this" - } - set o [new a x {y z}] - eval lappend ::result [dumpArrays a::] - delete $o - eval lappend ::result [dumpArrays a::] - - class A { - proc A {this p q} { - lappend ::result "A::A $this" - set ($this,m) $p - set ($this,n) $q - } - proc ~A {this} { - lappend ::result "A::~A $this" - } - } - set o [new A x {y z}] - eval lappend ::result [dumpArrays A::] - delete $o - eval lappend ::result [dumpArrays A::] - - class c::d {} - proc c::d::d {this p q} { - lappend ::result "d::d $this" - set ($this,m) $p - set ($this,n) $q - } - proc c::d::~d {this} { - lappend ::result "d::~d $this" - } - set o [new c::d x {y z}] - eval lappend ::result [dumpArrays c::d::] - delete $o - eval lappend ::result [dumpArrays c::d::] - - class C { - class D { - proc D {this p q} { - lappend ::result "D::D $this" - set ($this,m) $p - set ($this,n) $q - } - proc ~D {this} { - lappend ::result "D::~D $this" - } - } - set o [new D x {y z}] - eval lappend ::result [dumpArrays D::] - delete $o - eval lappend ::result [dumpArrays D::] - } - set o [new C::D x {y z}] - eval lappend ::result [dumpArrays C::D::] - delete $o - eval lappend ::result [dumpArrays C::D::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1}\ - {a::(1,m) = x}\ - {a::(1,n) = y z}\ - {a::~a 1}\ - {A::A 2}\ - {A::(2,m) = x}\ - {A::(2,n) = y z}\ - {A::~A 2}\ - {d::d 3}\ - {c::d::(3,m) = x}\ - {c::d::(3,n) = y z}\ - {d::~d 3}\ - {D::D 4}\ - {D::(4,m) = x}\ - {D::(4,n) = y z}\ - {D::~D 4}\ - {D::D 5}\ - {C::D::(5,m) = x}\ - {C::D::(5,n) = y z}\ - {D::~D 5}\ -] - -test stooop-5 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class ::a {} - class b::b {} - set ::result {} - }] - interp delete $interpreter - set result -} {} - -test stooop-6 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this p} { - lappend ::result "a::a $this" - set ($this,m) $p - } - proc a::~a {this} { - lappend ::result "a::~a $this" - } - class b {} - proc b::b {this p q} a {$p} { - lappend ::result "b::b $this" - set ($this,n) $q - } - proc b::~b {this} { - lappend ::result "b::~b $this" - } - set o [new b {x y} z] - eval lappend ::result [dumpArrays a:: b::] - delete $o - eval lappend ::result [dumpArrays a:: b::] - - class A { - proc A {this p} { - lappend ::result "A::A $this" - set ($this,m) $p - } - proc ~A {this} { - lappend ::result "A::~A $this" - } - } - class B { - proc B {this p q} A {$p} { - lappend ::result "B::B $this" - set ($this,n) $q - } - proc ~B {this} { - lappend ::result "B::~B $this" - } - } - set o [new B {x y} z] - eval lappend ::result [dumpArrays A:: B::] - delete $o - eval lappend ::result [dumpArrays A:: B::] - - class c::d {} - proc c::d::d {this p} { - lappend ::result "d::d $this" - set ($this,m) $p - } - proc c::d::~d {this} { - lappend ::result "d::~d $this" - } - class c::e {} - proc c::e::e {this p q} c::d {$p} { - lappend ::result "e::e $this" - set ($this,n) $q - } - proc c::e::~e {this} { - lappend ::result "e::~e $this" - } - set o [new c::e {x y} z] - eval lappend ::result [dumpArrays c::d:: c::e::] - delete $o - eval lappend ::result [dumpArrays c::d:: c::e::] - - class C { - class D { - proc D {this p} { - lappend ::result "D::D $this" - set ($this,m) $p - } - proc ~D {this} { - lappend ::result "D::~D $this" - } - } - class E { - proc E {this p q} C::D {$p} { - lappend ::result "E::E $this" - set ($this,n) $q - } - proc ~E {this} { - lappend ::result "E::~E $this" - } - } - } - set o [new C::E {x y} z] - eval lappend ::result [dumpArrays C::D:: C::E::] - delete $o - eval lappend ::result [dumpArrays C::D:: C::E::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1}\ - {b::b 1}\ - {a::(1,_derived) = ::b}\ - {a::(1,m) = x y}\ - {b::(1,n) = z}\ - {b::~b 1}\ - {a::~a 1}\ - {A::A 2}\ - {B::B 2}\ - {A::(2,_derived) = ::B}\ - {A::(2,m) = x y}\ - {B::(2,n) = z}\ - {B::~B 2}\ - {A::~A 2}\ - {d::d 3}\ - {e::e 3}\ - {c::d::(3,_derived) = ::c::e}\ - {c::d::(3,m) = x y}\ - {c::e::(3,n) = z}\ - {e::~e 3}\ - {d::~d 3}\ - {D::D 4}\ - {E::E 4}\ - {C::D::(4,_derived) = ::C::E}\ - {C::D::(4,m) = x y}\ - {C::E::(4,n) = z}\ - {E::~E 4}\ - {D::~D 4}\ -] - -test stooop-7 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a {} - proc a::a {this} {} - class b {} - proc b::b {this} a {} {} - class c {} - proc c::c {this} b {} a {} {} - lappend ::result [classof [new a]] - lappend ::result [classof [new b]] - lappend ::result [classof [new c]] - - class A { - proc A {this} {} - } - class B { - proc B {this} A {} {} - } - class C { - proc C {this} B {} A {} {} - } - lappend ::result [classof [new A]] - lappend ::result [classof [new B]] - lappend ::result [classof [new C]] - - class d::e {} - proc d::e::e {this} {} - class d::f {} - proc d::f::f {this} d::e {} {} - class d::g {} - proc d::g::g {this} d::f {} d::e {} {} - lappend ::result [classof [new d::e]] - lappend ::result [classof [new d::f]] - lappend ::result [classof [new d::g]] - - class D { - class E { - proc E {this} {} - } - class F { - proc F {this} D::E {} {} - } - class G { - proc G {this} D::F {} D::E {} {} - } - lappend ::result [classof [new E]] - lappend ::result [classof [new F]] - lappend ::result [classof [new G]] - } - lappend ::result [classof [new D::E]] - lappend ::result [classof [new D::F]] - lappend ::result [classof [new D::G]] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - ::a\ - ::b\ - ::c\ - ::A\ - ::B\ - ::C\ - ::d::e\ - ::d::f\ - ::d::g\ - ::D::E\ - ::D::F\ - ::D::G\ - ::D::E\ - ::D::F\ - ::D::G\ -] - -test stooop-8 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a {} - proc a::a {this} { - lappend ::result "a::a $this" - } - proc a::~a {this} { - lappend ::result "a::~a $this" - } - class b {} - proc b::b {this} a {} { - lappend ::result "b::b $this" - } - proc b::~b {this} { - lappend ::result "b::~b $this" - } - class c {} - proc c::c {this} b {} { - lappend ::result "c::c $this" - } - proc c::~c {this} { - lappend ::result "c::~c $this" - } - delete [new a] - delete [new b] - delete [new c] - - class A { - proc A {this} { - lappend ::result "A::A $this" - } - proc ~A {this} { - lappend ::result "A::~A $this" - } - } - class B { - proc B {this} A {} { - lappend ::result "B::B $this" - } - proc ~B {this} { - lappend ::result "B::~B $this" - } - } - class C { - proc C {this} B {} { - lappend ::result "C::C $this" - } - proc ~C {this} { - lappend ::result "C::~C $this" - } - } - delete [new A] - delete [new B] - delete [new C] - - class d::e {} - proc d::e::e {this} { - lappend ::result "e::e $this" - } - proc d::e::~e {this} { - lappend ::result "e::~e $this" - } - class d::f {} - proc d::f::f {this} d::e {} { - lappend ::result "f::f $this" - } - proc d::f::~f {this} { - lappend ::result "f::~f $this" - } - class d::g {} - proc d::g::g {this} d::f {} { - lappend ::result "g::g $this" - } - proc d::g::~g {this} { - lappend ::result "g::~g $this" - } - delete [new d::e] - delete [new d::f] - delete [new d::g] - - class D { - class E { - proc E {this} { - lappend ::result "E::E $this" - } - proc ~E {this} { - lappend ::result "E::~E $this" - } - } - class F { - proc F {this} D::E {} { - lappend ::result "F::F $this" - } - proc ~F {this} { - lappend ::result "F::~F $this" - } - } - class G { - proc G {this} D::F {} { - lappend ::result "G::G $this" - } - proc ~G {this} { - lappend ::result "G::~G $this" - } - } - delete [new E] - delete [new F] - delete [new G] - } - delete [new D::E] - delete [new D::F] - delete [new D::G] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1}\ - {a::~a 1}\ - {a::a 2}\ - {b::b 2}\ - {b::~b 2}\ - {a::~a 2}\ - {a::a 3}\ - {b::b 3}\ - {c::c 3}\ - {c::~c 3}\ - {b::~b 3}\ - {a::~a 3}\ - {A::A 4}\ - {A::~A 4}\ - {A::A 5}\ - {B::B 5}\ - {B::~B 5}\ - {A::~A 5}\ - {A::A 6}\ - {B::B 6}\ - {C::C 6}\ - {C::~C 6}\ - {B::~B 6}\ - {A::~A 6}\ - {e::e 7}\ - {e::~e 7}\ - {e::e 8}\ - {f::f 8}\ - {f::~f 8}\ - {e::~e 8}\ - {e::e 9}\ - {f::f 9}\ - {g::g 9}\ - {g::~g 9}\ - {f::~f 9}\ - {e::~e 9}\ - {E::E 10}\ - {E::~E 10}\ - {E::E 11}\ - {F::F 11}\ - {F::~F 11}\ - {E::~E 11}\ - {E::E 12}\ - {F::F 12}\ - {G::G 12}\ - {G::~G 12}\ - {F::~F 12}\ - {E::~E 12}\ - {E::E 13}\ - {E::~E 13}\ - {E::E 14}\ - {F::F 14}\ - {F::~F 14}\ - {E::~E 14}\ - {E::E 15}\ - {F::F 15}\ - {G::G 15}\ - {G::~G 15}\ - {F::~F 15}\ - {E::~E 15}\ -] - -test stooop-9 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - catch { - class a {} - proc a::a {this} {} - proc a::~a {this p} {} - } message - lappend ::result $message - - catch { - class A { - proc A {this} {} - proc ~A {this p} {} - } - } message - lappend ::result $message - - catch { - class b::c {} - proc b::c::c {this} {} - proc b::c::~c {this p} {} - } message - lappend ::result $message - - catch { - class B { - class C { - proc C {this} {} - proc ~C {this p} {} - } - } - } message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {class ::a destructor must have 1 argument exactly}\ - {class ::A destructor must have 1 argument exactly}\ - {class ::b::c destructor must have 1 argument exactly}\ - {class ::B::C destructor must have 1 argument exactly}\ -] - -test stooop-10 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - catch { - class a {} - proc a::a {this} {} - virtual proc a::~a {this} {} - } message - lappend ::result $message - - catch { - class A { - proc A {this} {} - virtual proc ~A {this} {} - } - } message - lappend ::result $message - - catch { - class b::c {} - proc b::c::c {this} {} - virtual proc b::c::~c {this} {} - } message - lappend ::result $message - - catch { - class B { - class C { - proc C {this} {} - virtual proc ~C {this} {} - } - } - } message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {cannot make class ::a destructor virtual}\ - {cannot make class ::A destructor virtual}\ - {cannot make class ::b::c destructor virtual}\ - {cannot make class ::B::C destructor virtual}\ -] - -test stooop-11 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a {} - proc a::a {this} { - lappend ::result "a::a $this" - } - proc a::~a {this} { - lappend ::result "a::~a $this" - } - virtual proc a::f {this p q} {} - virtual proc a::g {this p q} - virtual proc a::h {this p q} { - lappend ::result "a::h $this $p $q" - } - virtual proc a::i {this p q} - class b {} - proc b::b {this} a {} { - lappend ::result "b::b $this" - } - proc b::~b {this} { - lappend ::result "b::~b $this" - } - virtual proc b::f {this p q} { - lappend ::result "b::f $this $p $q" - } - virtual proc b::g {this p q} { - lappend ::result "b::g $this $p $q" - } - set o [new b] - a::f $o x {y z} - a::g $o x {y z} - a::h $o x {y z} - catch {a::i $o x {y z}} message - lappend ::result $message - - class A { - proc A {this} { - lappend ::result "A::A $this" - } - proc ~A {this} { - lappend ::result "A::~A $this" - } - virtual proc f {this p q} {} - virtual proc g {this p q} - virtual proc h {this p q} { - lappend ::result "A::h $this $p $q" - } - virtual proc i {this p q} - } - class B { - proc B {this} A {} { - lappend ::result "B::B $this" - } - proc ~B {this} { - lappend ::result "B::~B $this" - } - virtual proc f {this p q} { - lappend ::result "B::f $this $p $q" - } - virtual proc g {this p q} { - lappend ::result "B::g $this $p $q" - } - } - set o [new B] - A::f $o x {y z} - A::g $o x {y z} - A::h $o x {y z} - catch {A::i $o x {y z}} message - lappend ::result $message - - class c::d {} - proc c::d::d {this} { - lappend ::result "d::d $this" - } - proc c::d::~d {this} { - lappend ::result "d::~d $this" - } - virtual proc c::d::f {this p q} {} - virtual proc c::d::g {this p q} - virtual proc c::d::h {this p q} { - lappend ::result "d::h $this $p $q" - } - virtual proc c::d::i {this p q} - class c::e {} - proc c::e::e {this} c::d {} { - lappend ::result "e::e $this" - } - proc c::e::~e {this} { - lappend ::result "e::~e $this" - } - virtual proc c::e::f {this p q} { - lappend ::result "e::f $this $p $q" - } - virtual proc c::e::g {this p q} { - lappend ::result "e::g $this $p $q" - } - set o [new c::e] - c::d::f $o x {y z} - c::d::g $o x {y z} - c::d::h $o x {y z} - catch {c::d::i $o x {y z}} message - lappend ::result $message - - class C { - class D { - proc D {this} { - lappend ::result "D::D $this" - } - proc ~D {this} { - lappend ::result "D::~D $this" - } - virtual proc f {this p q} {} - virtual proc g {this p q} - virtual proc h {this p q} { - lappend ::result "D::h $this $p $q" - } - virtual proc i {this p q} - } - class E { - proc E {this} C::D {} { - lappend ::result "E::E $this" - } - proc ~E {this} { - lappend ::result "E::~E $this" - } - virtual proc f {this p q} { - lappend ::result "E::f $this $p $q" - } - virtual proc g {this p q} { - lappend ::result "E::g $this $p $q" - } - } - set o [new E] - D::f $o x {y z} - D::g $o x {y z} - D::h $o x {y z} - catch {D::i $o x {y z}} message - lappend ::result $message - } - set o [new C::E] - C::D::f $o x {y z} - C::D::g $o x {y z} - C::D::h $o x {y z} - catch {C::D::i $o x {y z}} message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1}\ - {b::b 1}\ - {b::f 1 x y z}\ - {b::g 1 x y z}\ - {a::h 1 x y z}\ - {invalid command name "::b::i"}\ - {A::A 2}\ - {B::B 2}\ - {B::f 2 x y z}\ - {B::g 2 x y z}\ - {A::h 2 x y z}\ - {invalid command name "::B::i"}\ - {d::d 3}\ - {e::e 3}\ - {e::f 3 x y z}\ - {e::g 3 x y z}\ - {d::h 3 x y z}\ - {invalid command name "::c::e::i"}\ - {D::D 4}\ - {E::E 4}\ - {E::f 4 x y z}\ - {E::g 4 x y z}\ - {D::h 4 x y z}\ - {invalid command name "::C::E::i"}\ - {D::D 5}\ - {E::E 5}\ - {E::f 5 x y z}\ - {E::g 5 x y z}\ - {D::h 5 x y z}\ - {invalid command name "::C::E::i"}\ -] - -test stooop-12 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - catch { - class a {} - virtual proc a::a {this} {} - } message - lappend ::result $message - - catch { - class A { - virtual proc A {this} {} - } - } message - lappend ::result $message - - catch { - class b::c {} - virtual proc b::c::c {this} {} - } message - lappend ::result $message - - catch { - class B { - class C { - virtual proc C {this} {} - } - } - } message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {cannot make class ::a constructor virtual}\ - {cannot make class ::A constructor virtual}\ - {cannot make class ::b::c constructor virtual}\ - {cannot make class ::B::C constructor virtual}\ -] - -test stooop-13 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - catch { - class a {} - proc a::~a {this} {} - } message - lappend ::result $message - - catch { - class A { - proc ~A {this} {} - } - } message - lappend ::result $message - - catch { - class b::c {} - proc b::c::~c {this} {} - } message - lappend ::result $message - - catch { - class B { - class C { - proc ~C {this} {} - } - } - } message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {class ::a destructor defined before constructor}\ - {class ::A destructor defined before constructor}\ - {class ::b::c destructor defined before constructor}\ - {class ::B::C destructor defined before constructor}\ -] - -test stooop-14 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a {} - catch { - class b {} - proc b::b {this} a {} {} - } message - lappend ::result $message - - class A {} - catch { - class B { - proc B {this} A {} {} - } - } message - lappend ::result $message - - class b::c {} - catch { - class b::d {} - proc b::d::d {this} b::c {} {} - } message - lappend ::result $message - - catch { - class B { - class C {} - class D { - proc D {this} C {} {} - } - } - } message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {class ::b constructor defined before base class a constructor}\ - {class ::B constructor defined before base class A constructor}\ - {class ::b::d constructor defined before base class b::c constructor}\ - {class ::B::D constructor defined before base class C constructor}\ -] - -test stooop-15 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - catch { - class a {} - virtual a::f {this} {} - } message - lappend ::result $message - - catch { - class A { - virtual f {this} {} - } - } message - lappend ::result $message - - catch { - class b::c {} - virtual b::c::f {this} {} - } message - lappend ::result $message - - catch { - class B { - class C { - virtual f {this} {} - } - } - } message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {virtual operator works only on proc, not a::f}\ - {virtual operator works only on proc, not f}\ - {virtual operator works only on proc, not b::c::f}\ - {virtual operator works only on proc, not f}\ -] - -test stooop-16 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - catch { - virtual proc f {} {} - } message - lappend ::result $message - - catch { - virtual proc a::f {} {} - } message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {procedure ::f class name is empty}\ - {procedure ::a::f class ::a is unknown}\ -] - -test stooop-17 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - catch { - class a {} - proc a::f {this} - } message - lappend ::result $message - - catch { - class A { - proc f {this} - } - } message - lappend ::result $message - - catch { - class b::c {} - proc b::c::f {this} - } message - lappend ::result $message - - catch { - class B { - class C { - proc f {this} - } - } - } message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {missing body for ::a::f}\ - {missing body for ::A::f}\ - {missing body for ::b::c::f}\ - {missing body for ::B::C::f}\ -] - -test stooop-18 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - catch { - class b {} - proc b::b {this} a {} - } message - lappend ::result $message - - catch { - class B { - proc B {this} A {} - } - } message - lappend ::result $message - - catch { - class c::e {} - proc c::e::e {this} d {} - } message - lappend ::result $message - - catch { - class C { - class E { - proc E {this} D {} - } - } - } message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {bad class ::b constructor declaration, a base class, contructor arguments or body may be missing}\ - {bad class ::B constructor declaration, a base class, contructor arguments or body may be missing}\ - {bad class ::c::e constructor declaration, a base class, contructor arguments or body may be missing}\ - {bad class ::C::E constructor declaration, a base class, contructor arguments or body may be missing}\ -] - -test stooop-19 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - catch { - class b {} - proc b::b {this} b {} {} - } message - lappend ::result $message - - catch { - class B { - proc B {this} B {} {} - } - } message - lappend ::result $message - - catch { - class c::d {} - proc c::d::d {this} c::d {} {} - } message - lappend ::result $message - - catch { - class C { - class D { - proc D {this} D {} {} - } - } - } message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {class ::b cannot be derived from itself}\ - {class ::B cannot be derived from itself}\ - {class ::c::d cannot be derived from itself}\ - {class ::C::D cannot be derived from itself}\ -] - -test stooop-20 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - catch { - class a {} - proc a::~a {this} {} - } message - lappend ::result $message - - catch { - class A { - proc ~A {this} {} - } - } message - lappend ::result $message - - catch { - class a {} - proc a::a {this} {} - class a::b {} - proc a::b::~b {this} {} - } message - lappend ::result $message - - catch { - class A { - proc A {this} {} - class B { - proc ~B {this} {} - } - } - } message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {class ::a destructor defined before constructor}\ - {class ::A destructor defined before constructor}\ - {class ::a::b destructor defined before constructor}\ - {class ::A::B destructor defined before constructor}\ -] - -test stooop-21 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - catch { - class a {} - proc a::a {p} {} - } message - lappend ::result $message - - catch { - class A { - proc A {p} {} - } - } message - lappend ::result $message - - catch { - class a {} - proc a::a {this} {} - class a::b {} - proc a::b::b {p} {} - } message - lappend ::result $message - - catch { - class A { - proc A {this} {} - class B { - proc B {p} {} - } - } - } message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {class ::a constructor first argument must be this}\ - {class ::A constructor first argument must be this}\ - {class ::a::b constructor first argument must be this}\ - {class ::A::B constructor first argument must be this}\ -] - -test stooop-22 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - catch { - class a {} - proc a::~a {p} {} - } message - lappend ::result $message - - catch { - class A { - proc ~A {p} {} - } - } message - lappend ::result $message - - catch { - class a {} - proc a::a {this} {} - class a::b {} - proc a::b::~b {p} {} - } message - lappend ::result $message - - catch { - class A { - proc A {this} {} - class B { - proc ~B {p} {} - } - } - } message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {class ::a destructor argument must be this}\ - {class ::A destructor argument must be this}\ - {class ::a::b destructor argument must be this}\ - {class ::A::B destructor argument must be this}\ -] - -test stooop-23 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - catch { - class a {} - virtual proc a::f {p} {} - } message - lappend ::result $message - - catch { - class A { - virtual proc f {p} {} - } - } message - lappend ::result $message - - catch { - class a {} - proc a::a {this} {} - class a::b {} - virtual proc a::b::f {p} {} - } message - lappend ::result $message - - catch { - class A { - proc A {this} {} - class B { - virtual proc f {p} {} - } - } - } message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {cannot make static procedure f of class ::a virtual}\ - {cannot make static procedure f of class ::A virtual}\ - {cannot make static procedure f of class ::a::b virtual}\ - {cannot make static procedure f of class ::A::B virtual}\ -] - -test stooop-24 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this p args} { - lappend ::result "a::a $this $p $args" - set ($this,m) [lindex $args 0] - } - proc a::~a {this} { - lappend ::result "a::~a $this" - } - class b {} - proc b::b {this p args} a {$p $args} { - lappend ::result "b::b $this $p $args" - set ($this,n) [lindex $args 0] - } - proc b::~b {this} { - lappend ::result "b::~b $this" - } - new b {x y} {1 2} 3 - eval lappend ::result [dumpArrays a:: b::] - - class A { - proc A {this p args} { - lappend ::result "A::A $this $p $args" - set ($this,m) [lindex $args 0] - } - proc ~A {this} { - lappend ::result "A::~A $this" - } - } - class B { - proc B {this p args} A {$p $args} { - lappend ::result "B::B $this $p $args" - set ($this,n) [lindex $args 0] - } - proc ~B {this} { - lappend ::result "B::~B $this" - } - } - new B {x y} {1 2} 3 - eval lappend ::result [dumpArrays A:: B::] - - class c {} - class c::d {} - proc c::d::d {this p args} { - lappend ::result "d::d $this $p $args" - set ($this,m) [lindex $args 0] - } - proc c::d::~d {this} { - lappend ::result "d::~d $this" - } - class c::e {} - proc c::e::e {this p args} c::d {$p $args} { - lappend ::result "e::e $this $p $args" - set ($this,n) [lindex $args 0] - } - proc c::e::~e {this} { - lappend ::result "e::~e $this" - } - new c::e {x y} {1 2} 3 - eval lappend ::result [dumpArrays c::d:: c::e::] - - class C { - class D { - proc D {this p args} { - lappend ::result "D::D $this $p $args" - set ($this,m) [lindex $args 0] - } - proc ~D {this} { - lappend ::result "D::~D $this" - } - } - class E { - proc E {this p args} C::D {$p $args} { - lappend ::result "E::E $this $p $args" - set ($this,n) [lindex $args 0] - } - proc ~E {this} { - lappend ::result "E::~E $this" - } - } - new E {x y} {1 2} 3 - eval lappend ::result [dumpArrays D:: E::] - } - new C::E {x y} {1 2} 3 - eval lappend ::result [dumpArrays C::D:: C::E::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1 x y {1 2} 3}\ - {b::b 1 x y {1 2} 3}\ - {a::(1,_derived) = ::b}\ - {a::(1,m) = 1 2}\ - {b::(1,n) = 1 2}\ - {A::A 2 x y {1 2} 3}\ - {B::B 2 x y {1 2} 3}\ - {A::(2,_derived) = ::B}\ - {A::(2,m) = 1 2}\ - {B::(2,n) = 1 2}\ - {d::d 3 x y {1 2} 3}\ - {e::e 3 x y {1 2} 3}\ - {c::d::(3,_derived) = ::c::e}\ - {c::d::(3,m) = 1 2}\ - {c::e::(3,n) = 1 2}\ - {D::D 4 x y {1 2} 3}\ - {E::E 4 x y {1 2} 3}\ - {D::(4,_derived) = ::C::E}\ - {D::(4,m) = 1 2}\ - {E::(4,n) = 1 2}\ - {D::D 5 x y {1 2} 3}\ - {E::E 5 x y {1 2} 3}\ - {C::D::(4,_derived) = ::C::E}\ - {C::D::(4,m) = 1 2}\ - {C::D::(5,_derived) = ::C::E}\ - {C::D::(5,m) = 1 2}\ - {C::E::(4,n) = 1 2}\ - {C::E::(5,n) = 1 2}\ -] - -test stooop-25 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a {} - proc a::a {this} { - lappend ::result "a::a $this" - } - proc a::~a {this} { - lappend ::result "a::~a $this" - } - virtual proc a::f {this p args} {} - proc a::g {this p args} { - lappend ::result "a::g $this $p $args" - } - class b {} - proc b::b {this} a {} { - lappend ::result "b::b $this" - } - proc b::~b {this} { - lappend ::result "b::~b $this" - } - virtual proc b::f {this p args} { - lappend ::result "b::f $this $p $args" - } - set o [new b] - a::f $o {x y} {1 2} 3 - a::g $o {x y} {1 2} 3 - - class A { - proc A {this} { - lappend ::result "A::A $this" - } - proc ~A {this} { - lappend ::result "A::~A $this" - } - virtual proc f {this p args} {} - proc g {this p args} { - lappend ::result "A::g $this $p $args" - } - } - class B { - proc B {this} A {} { - lappend ::result "B::B $this" - } - proc ~B {this} { - lappend ::result "B::~B $this" - } - virtual proc f {this p args} { - lappend ::result "B::f $this $p $args" - } - } - set o [new B] - A::f $o {x y} {1 2} 3 - A::g $o {x y} {1 2} 3 - - class c {} - class c::d {} - proc c::d::d {this} { - lappend ::result "d::d $this" - } - proc c::d::~d {this} { - lappend ::result "d::~d $this" - } - virtual proc c::d::f {this p args} {} - proc c::d::g {this p args} { - lappend ::result "d::g $this $p $args" - } - class c::e {} - proc c::e::e {this} c::d {} { - lappend ::result "e::e $this" - } - proc c::e::~e {this} { - lappend ::result "e::~e $this" - } - virtual proc c::e::f {this p args} { - lappend ::result "e::f $this $p $args" - } - set o [new c::e] - c::d::f $o {x y} {1 2} 3 - c::d::g $o {x y} {1 2} 3 - - class C { - class D { - proc D {this} { - lappend ::result "D::D $this" - } - proc ~D {this} { - lappend ::result "D::~D $this" - } - virtual proc f {this p args} {} - proc g {this p args} { - lappend ::result "D::g $this $p $args" - } - } - class B { - proc B {this} C::D {} { - lappend ::result "B::B $this" - } - proc ~B {this} { - lappend ::result "B::~B $this" - } - virtual proc f {this p args} { - lappend ::result "B::f $this $p $args" - } - } - set o [new B] - D::f $o {x y} {1 2} 3 - D::g $o {x y} {1 2} 3 - } - set o [new C::B] - C::D::f $o {x y} {1 2} 3 - C::D::g $o {x y} {1 2} 3 - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1}\ - {b::b 1}\ - {b::f 1 x y {1 2} 3}\ - {a::g 1 x y {1 2} 3}\ - {A::A 2}\ - {B::B 2}\ - {B::f 2 x y {1 2} 3}\ - {A::g 2 x y {1 2} 3}\ - {d::d 3}\ - {e::e 3}\ - {e::f 3 x y {1 2} 3}\ - {d::g 3 x y {1 2} 3}\ - {D::D 4}\ - {B::B 4}\ - {B::f 4 x y {1 2} 3}\ - {D::g 4 x y {1 2} 3}\ - {D::D 5}\ - {B::B 5}\ - {B::f 5 x y {1 2} 3}\ - {D::g 5 x y {1 2} 3}\ -] - -test stooop-26 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this p q args} { - lappend ::result "a::a $this $p $q $args" - set ($this,m) [lindex $args 0] - set ($this,p) $p - set ($this,q) $q - } - proc a::~a {this} { - lappend ::result "a::~a $this" - } - class b {} - proc b::b {this p q args} a {$p $q $args} { - lappend ::result "b::b $this $p $q $args" - set ($this,n) [lindex $args 0] - } - proc b::~b {this} { - lappend ::result "b::~b $this" - } - new b {x y} {X Y} {1 2} 3 - eval lappend ::result [dumpArrays a:: b::] - - class A { - proc A {this p q args} { - lappend ::result "A::A $this $p $q $args" - set ($this,m) [lindex $args 0] - set ($this,p) $p - set ($this,q) $q - } - proc ~A {this} { - lappend ::result "A::~A $this" - } - } - class B { - proc B {this p q args} A {$p $q $args} { - lappend ::result "B::B $this $p $q $args" - set ($this,n) [lindex $args 0] - } - proc ~B {this} { - lappend ::result "B::~B $this" - } - } - new B {x y} {X Y} {1 2} 3 - eval lappend ::result [dumpArrays A:: B::] - - class c {} - class c::d {} - proc c::d::d {this p q args} { - lappend ::result "d::d $this $p $q $args" - set ($this,m) [lindex $args 0] - set ($this,p) $p - set ($this,q) $q - } - proc c::d::~d {this} { - lappend ::result "d::~d $this" - } - class c::e {} - proc c::e::e {this p q args} c::d {$p $q $args} { - lappend ::result "e::e $this $p $q $args" - set ($this,n) [lindex $args 0] - } - proc c::e::~e {this} { - lappend ::result "e::~e $this" - } - new c::e {x y} {X Y} {1 2} 3 - eval lappend ::result [dumpArrays c::d:: c::e::] - - class C { - class D { - proc D {this p q args} { - lappend ::result "D::D $this $p $q $args" - set ($this,m) [lindex $args 0] - set ($this,p) $p - set ($this,q) $q - } - proc ~D {this} { - lappend ::result "D::~D $this" - } - } - class E { - proc E {this p q args} C::D {$p $q $args} { - lappend ::result "E::E $this $p $q $args" - set ($this,n) [lindex $args 0] - } - proc ~E {this} { - lappend ::result "E::~E $this" - } - } - new E {x y} {X Y} {1 2} 3 - eval lappend ::result [dumpArrays D:: E::] - } - new C::E {x y} {X Y} {1 2} 3 - eval lappend ::result [dumpArrays C::D:: C::E::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1 x y X Y {1 2} 3}\ - {b::b 1 x y X Y {1 2} 3}\ - {a::(1,_derived) = ::b}\ - {a::(1,m) = 1 2}\ - {a::(1,p) = x y}\ - {a::(1,q) = X Y}\ - {b::(1,n) = 1 2}\ - {A::A 2 x y X Y {1 2} 3}\ - {B::B 2 x y X Y {1 2} 3}\ - {A::(2,_derived) = ::B}\ - {A::(2,m) = 1 2}\ - {A::(2,p) = x y}\ - {A::(2,q) = X Y}\ - {B::(2,n) = 1 2}\ - {d::d 3 x y X Y {1 2} 3}\ - {e::e 3 x y X Y {1 2} 3}\ - {c::d::(3,_derived) = ::c::e}\ - {c::d::(3,m) = 1 2}\ - {c::d::(3,p) = x y}\ - {c::d::(3,q) = X Y}\ - {c::e::(3,n) = 1 2}\ - {D::D 4 x y X Y {1 2} 3}\ - {E::E 4 x y X Y {1 2} 3}\ - {D::(4,_derived) = ::C::E}\ - {D::(4,m) = 1 2}\ - {D::(4,p) = x y}\ - {D::(4,q) = X Y}\ - {E::(4,n) = 1 2}\ - {D::D 5 x y X Y {1 2} 3}\ - {E::E 5 x y X Y {1 2} 3}\ - {C::D::(4,_derived) = ::C::E}\ - {C::D::(4,m) = 1 2}\ - {C::D::(4,p) = x y}\ - {C::D::(4,q) = X Y}\ - {C::D::(5,_derived) = ::C::E}\ - {C::D::(5,m) = 1 2}\ - {C::D::(5,p) = x y}\ - {C::D::(5,q) = X Y}\ - {C::E::(4,n) = 1 2}\ - {C::E::(5,n) = 1 2}\ -] - -test stooop-27 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this args} { - lappend ::result "a::a $this $args" - set ($this,m) [lindex $args 0] - } - proc a::~a {this} { - lappend ::result "a::~a $this" - } - class b {} - proc b::b {this p args} a {$args} { - lappend ::result "b::b $this $p $args" - set ($this,n) [lindex $args 0] - } - proc b::~b {this} { - lappend ::result "b::~b $this" - } - new b {x y} {1 2} 3 - eval lappend ::result [dumpArrays a:: b::] - - class A { - proc A {this args} { - lappend ::result "A::A $this $args" - set ($this,m) [lindex $args 0] - } - proc ~A {this} { - lappend ::result "A::~A $this" - } - } - class B { - proc B {this p args} A {$args} { - lappend ::result "B::B $this $p $args" - set ($this,n) [lindex $args 0] - } - proc ~B {this} { - lappend ::result "B::~B $this" - } - } - new B {x y} {1 2} 3 - eval lappend ::result [dumpArrays A:: B::] - - class c {} - class c::d {} - proc c::d::d {this args} { - lappend ::result "d::d $this $args" - set ($this,m) [lindex $args 0] - } - proc c::d::~d {this} { - lappend ::result "d::~d $this" - } - class c::e {} - proc c::e::e {this p args} c::d {$args} { - lappend ::result "e::e $this $p $args" - set ($this,n) [lindex $args 0] - } - proc c::e::~e {this} { - lappend ::result "e::~e $this" - } - new c::e {x y} {1 2} 3 - eval lappend ::result [dumpArrays c::d:: c::e::] - - class C { - class D { - proc D {this args} { - lappend ::result "D::D $this $args" - set ($this,m) [lindex $args 0] - } - proc ~D {this} { - lappend ::result "D::~D $this" - } - } - class E { - proc E {this p args} C::D {$args} { - lappend ::result "E::E $this $p $args" - set ($this,n) [lindex $args 0] - } - proc ~E {this} { - lappend ::result "E::~E $this" - } - } - new E {x y} {1 2} 3 - eval lappend ::result [dumpArrays D:: E::] - } - new C::E {x y} {1 2} 3 - eval lappend ::result [dumpArrays C::D:: C::E::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1 {1 2} 3}\ - {b::b 1 x y {1 2} 3}\ - {a::(1,_derived) = ::b}\ - {a::(1,m) = 1 2}\ - {b::(1,n) = 1 2}\ - {A::A 2 {1 2} 3}\ - {B::B 2 x y {1 2} 3}\ - {A::(2,_derived) = ::B}\ - {A::(2,m) = 1 2}\ - {B::(2,n) = 1 2}\ - {d::d 3 {1 2} 3}\ - {e::e 3 x y {1 2} 3}\ - {c::d::(3,_derived) = ::c::e}\ - {c::d::(3,m) = 1 2}\ - {c::e::(3,n) = 1 2}\ - {D::D 4 {1 2} 3}\ - {E::E 4 x y {1 2} 3}\ - {D::(4,_derived) = ::C::E}\ - {D::(4,m) = 1 2}\ - {E::(4,n) = 1 2}\ - {D::D 5 {1 2} 3}\ - {E::E 5 x y {1 2} 3}\ - {C::D::(4,_derived) = ::C::E}\ - {C::D::(4,m) = 1 2}\ - {C::D::(5,_derived) = ::C::E}\ - {C::D::(5,m) = 1 2}\ - {C::E::(4,n) = 1 2}\ - {C::E::(5,n) = 1 2}\ -] - -test stooop-28 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this args} { - lappend ::result "a::a $this $args" - set ($this,m) [lindex $args 0] - } - proc a::~a {this} { - lappend ::result "a::~a $this" - } - class b {} - proc b::b {this args} a {$args} { - lappend ::result "b::b $this $args" - set ($this,n) [lindex $args 0] - } - proc b::~b {this} { - lappend ::result "b::~b $this" - } - new b {1 2} 3 - eval lappend ::result [dumpArrays a:: b::] - - class A { - proc A {this args} { - lappend ::result "A::A $this $args" - set ($this,m) [lindex $args 0] - } - proc ~A {this} { - lappend ::result "A::~A $this" - } - } - class B { - proc B {this args} A {$args} { - lappend ::result "B::B $this $args" - set ($this,n) [lindex $args 0] - } - proc ~B {this} { - lappend ::result "B::~B $this" - } - } - new B {1 2} 3 - eval lappend ::result [dumpArrays A:: B::] - - class c {} - class c::d {} - proc c::d::d {this args} { - lappend ::result "d::d $this $args" - set ($this,m) [lindex $args 0] - } - proc c::d::~d {this} { - lappend ::result "d::~d $this" - } - class c::e {} - proc c::e::e {this args} c::d {$args} { - lappend ::result "e::e $this $args" - set ($this,n) [lindex $args 0] - } - proc c::e::~e {this} { - lappend ::result "e::~e $this" - } - new c::e {1 2} 3 - eval lappend ::result [dumpArrays c::d:: c::e::] - - class C { - class D { - proc D {this args} { - lappend ::result "D::D $this $args" - set ($this,m) [lindex $args 0] - } - proc ~D {this} { - lappend ::result "D::~D $this" - } - } - class E { - proc E {this args} C::D {$args} { - lappend ::result "E::E $this $args" - set ($this,n) [lindex $args 0] - } - proc ~E {this} { - lappend ::result "E::~E $this" - } - } - new E {1 2} 3 - eval lappend ::result [dumpArrays D:: E::] - } - new C::E {1 2} 3 - eval lappend ::result [dumpArrays C::D:: C::E::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1 {1 2} 3}\ - {b::b 1 {1 2} 3}\ - {a::(1,_derived) = ::b}\ - {a::(1,m) = 1 2}\ - {b::(1,n) = 1 2}\ - {A::A 2 {1 2} 3}\ - {B::B 2 {1 2} 3}\ - {A::(2,_derived) = ::B}\ - {A::(2,m) = 1 2}\ - {B::(2,n) = 1 2}\ - {d::d 3 {1 2} 3}\ - {e::e 3 {1 2} 3}\ - {c::d::(3,_derived) = ::c::e}\ - {c::d::(3,m) = 1 2}\ - {c::e::(3,n) = 1 2}\ - {D::D 4 {1 2} 3}\ - {E::E 4 {1 2} 3}\ - {D::(4,_derived) = ::C::E}\ - {D::(4,m) = 1 2}\ - {E::(4,n) = 1 2}\ - {D::D 5 {1 2} 3}\ - {E::E 5 {1 2} 3}\ - {C::D::(4,_derived) = ::C::E}\ - {C::D::(4,m) = 1 2}\ - {C::D::(5,_derived) = ::C::E}\ - {C::D::(5,m) = 1 2}\ - {C::E::(4,n) = 1 2}\ - {C::E::(5,n) = 1 2}\ -] - -test stooop-29 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a {} - proc a::a {this p q} { - lappend ::result "a::a $this $p $q" - } - proc a::~a {this} {} - class b {} - proc b::b {this p q} a { - $p $q - } { - lappend ::result "b::b $this $p $q" - } - proc b::~b {this} {} - new b {x y} z - - class A { - proc A {this p q} { - lappend ::result "A::A $this $p $q" - } - proc ~A {this} {} - } - class B { - proc B {this p q} A { - $p $q - } { - lappend ::result "B::B $this $p $q" - } - proc ~B {this} {} - } - new B {x y} z - - class c {} - class c::d {} - proc c::d::d {this p q} { - lappend ::result "d::d $this $p $q" - } - proc c::d::~d {this} {} - class c::e {} - proc c::e::e {this p q} c::d { - $p $q - } { - lappend ::result "e::e $this $p $q" - } - proc c::e::~e {this} {} - new c::e {x y} z - - class C { - class D { - proc D {this p q} { - lappend ::result "D::D $this $p $q" - } - proc ~D {this} {} - } - class E { - proc E {this p q} C::D { - $p $q - } { - lappend ::result "E::E $this $p $q" - } - proc ~E {this} {} - } - new E {x y} z - } - new C::E {x y} z - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1 x y z}\ - {b::b 1 x y z}\ - {A::A 2 x y z}\ - {B::B 2 x y z}\ - {d::d 3 x y z}\ - {e::e 3 x y z}\ - {D::D 4 x y z}\ - {E::E 4 x y z}\ - {D::D 5 x y z}\ - {E::E 5 x y z}\ -] - -test stooop-30 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a {} - proc a::a {this} { - lappend ::result "a::a $this" - } - proc a::~a {this} { - lappend ::result "a::~a $this" - } - virtual proc a::f {this p q} { - lappend ::result "a::h $this $p $q" - } - virtual proc a::g {this p args} { - lappend ::result "a::g $this $p $args" - } - class b {} - proc b::b {this} a {} { - lappend ::result "b::b $this" - } - proc b::~b {this} { - lappend ::result "b::~b $this" - } - proc b::f {this p q} { - lappend ::result "b::f $this $p $q" - a::_f $this $p $q - } - proc b::g {this p args} { - lappend ::result "b::g $this $p $args" - eval a::_g $this $p $args - } - set o [new b] - a::f $o x {y z} - a::g $o {x y} {1 2} 3 {4 5} - - class A { - proc A {this} { - lappend ::result "A::A $this" - } - proc ~A {this} { - lappend ::result "A::~A $this" - } - virtual proc f {this p q} { - lappend ::result "A::h $this $p $q" - } - virtual proc g {this p args} { - lappend ::result "A::g $this $p $args" - } - } - class B { - proc B {this} A {} { - lappend ::result "B::B $this" - } - proc ~B {this} { - lappend ::result "B::~B $this" - } - proc f {this p q} { - lappend ::result "B::f $this $p $q" - A::_f $this $p $q - } - proc g {this p args} { - lappend ::result "B::g $this $p $args" - eval A::_g $this $p $args - } - } - set o [new B] - A::f $o x {y z} - A::g $o {x y} {1 2} 3 {4 5} - - class c {} - class c::d {} - proc c::d::d {this} { - lappend ::result "d::d $this" - } - proc c::d::~d {this} { - lappend ::result "d::~d $this" - } - virtual proc c::d::f {this p q} { - lappend ::result "d::h $this $p $q" - } - virtual proc c::d::g {this p args} { - lappend ::result "d::g $this $p $args" - } - class c::e {} - proc c::e::e {this} c::d {} { - lappend ::result "e::e $this" - } - proc c::e::~e {this} { - lappend ::result "e::~e $this" - } - proc c::e::f {this p q} { - lappend ::result "e::f $this $p $q" - c::d::_f $this $p $q - } - proc c::e::g {this p args} { - lappend ::result "e::g $this $p $args" - eval c::d::_g $this $p $args - } - set o [new c::e] - c::d::f $o x {y z} - c::d::g $o {x y} {1 2} 3 {4 5} - - class C { - class D { - proc D {this} { - lappend ::result "D::D $this" - } - proc ~D {this} { - lappend ::result "D::~D $this" - } - virtual proc f {this p q} { - lappend ::result "D::h $this $p $q" - } - virtual proc g {this p args} { - lappend ::result "D::g $this $p $args" - } - } - class E { - proc E {this} C::D {} { - lappend ::result "E::E $this" - } - proc ~E {this} { - lappend ::result "E::~E $this" - } - proc f {this p q} { - lappend ::result "E::f $this $p $q" - C::D::_f $this $p $q - } - proc g {this p args} { - lappend ::result "E::g $this $p $args" - eval C::D::_g $this $p $args - } - } - set o [new E] - D::f $o x {y z} - D::g $o {x y} {1 2} 3 {4 5} - } - set o [new C::E] - C::D::f $o x {y z} - C::D::g $o {x y} {1 2} 3 {4 5} - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1}\ - {b::b 1}\ - {b::f 1 x y z}\ - {a::h 1 x y z}\ - {b::g 1 x y {1 2} 3 {4 5}}\ - {a::g 1 x y {1 2} 3 {4 5}}\ - {A::A 2}\ - {B::B 2}\ - {B::f 2 x y z}\ - {A::h 2 x y z}\ - {B::g 2 x y {1 2} 3 {4 5}}\ - {A::g 2 x y {1 2} 3 {4 5}}\ - {d::d 3}\ - {e::e 3}\ - {e::f 3 x y z}\ - {d::h 3 x y z}\ - {e::g 3 x y {1 2} 3 {4 5}}\ - {d::g 3 x y {1 2} 3 {4 5}}\ - {D::D 4}\ - {E::E 4}\ - {E::f 4 x y z}\ - {D::h 4 x y z}\ - {E::g 4 x y {1 2} 3 {4 5}}\ - {D::g 4 x y {1 2} 3 {4 5}}\ - {D::D 5}\ - {E::E 5}\ - {E::f 5 x y z}\ - {D::h 5 x y z}\ - {E::g 5 x y {1 2} 3 {4 5}}\ - {D::g 5 x y {1 2} 3 {4 5}}\ -] - -test stooop-31 { - check multiple inheritance construction order, destruction order and data - deallocation -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this p} { - lappend ::result "a::a $this" - set ($this,m) $p - } - proc a::~a {this} { - lappend ::result "a::~a $this" - } - class b {} - proc b::b {this p} { - lappend ::result "b::b $this" - set ($this,n) $p - } - proc b::~b {this} { - lappend ::result "b::~b $this" - } - class c {} - proc c::c {this p q r} a {$p} b {$q} { - lappend ::result "c::c $this" - set ($this,o) $r - } - proc c::~c {this} { - lappend ::result "c::~c $this" - } - set o [new c {x y} z {1 2}] - eval lappend ::result [dumpArrays a:: b:: c::] - delete $o - eval lappend ::result [dumpArrays a:: b:: c::] - - class A { - proc A {this p} { - lappend ::result "A::A $this" - set ($this,m) $p - } - proc ~A {this} { - lappend ::result "A::~A $this" - } - } - class B { - proc B {this p} { - lappend ::result "B::B $this" - set ($this,n) $p - } - proc ~B {this} { - lappend ::result "B::~B $this" - } - } - class C { - proc C {this p q r} A {$p} B {$q} { - lappend ::result "C::C $this" - set ($this,o) $r - } - proc ~C {this} { - lappend ::result "C::~C $this" - } - } - set o [new C {x y} z {1 2}] - eval lappend ::result [dumpArrays A:: B:: C::] - delete $o - eval lappend ::result [dumpArrays A:: B:: C::] - - class d {} - class d::e {} - proc d::e::e {this p} { - lappend ::result "e::e $this" - set ($this,m) $p - } - proc d::e::~e {this} { - lappend ::result "e::~e $this" - } - class d::f {} - proc d::f::f {this p} { - lappend ::result "f::f $this" - set ($this,n) $p - } - proc d::f::~f {this} { - lappend ::result "f::~f $this" - } - class d::g {} - proc d::g::g {this p q r} d::e {$p} d::f {$q} { - lappend ::result "g::g $this" - set ($this,o) $r - } - proc d::g::~g {this} { - lappend ::result "g::~g $this" - } - set o [new d::g {x y} z {1 2}] - eval lappend ::result [dumpArrays d::e:: d::f:: d::g::] - delete $o - eval lappend ::result [dumpArrays d::e:: d::f:: d::g::] - - class C { - class E { - proc E {this p} { - lappend ::result "E::E $this" - set ($this,m) $p - } - proc ~E {this} { - lappend ::result "E::~E $this" - } - } - class F { - proc F {this p} { - lappend ::result "F::F $this" - set ($this,n) $p - } - proc ~F {this} { - lappend ::result "F::~F $this" - } - } - class G { - proc G {this p q r} C::E {$p} C::F {$q} { - lappend ::result "G::G $this" - set ($this,o) $r - } - proc ~G {this} { - lappend ::result "G::~G $this" - } - } - set o [new G {x y} z {1 2}] - eval lappend ::result [dumpArrays E:: F:: G::] - delete $o - eval lappend ::result [dumpArrays E:: F:: G::] - } - set o [new C::G {x y} z {1 2}] - eval lappend ::result [dumpArrays C::E:: C::F:: C::G::] - delete $o - eval lappend ::result [dumpArrays C::E:: C::F:: C::G::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1}\ - {b::b 1}\ - {c::c 1}\ - {a::(1,_derived) = ::c}\ - {a::(1,m) = x y}\ - {b::(1,_derived) = ::c}\ - {b::(1,n) = z}\ - {c::(1,o) = 1 2}\ - {c::~c 1}\ - {b::~b 1}\ - {a::~a 1}\ - {A::A 2}\ - {B::B 2}\ - {C::C 2}\ - {A::(2,_derived) = ::C}\ - {A::(2,m) = x y}\ - {B::(2,_derived) = ::C}\ - {B::(2,n) = z}\ - {C::(2,o) = 1 2}\ - {C::~C 2}\ - {B::~B 2}\ - {A::~A 2}\ - {e::e 3}\ - {f::f 3}\ - {g::g 3}\ - {d::e::(3,_derived) = ::d::g}\ - {d::e::(3,m) = x y}\ - {d::f::(3,_derived) = ::d::g}\ - {d::f::(3,n) = z}\ - {d::g::(3,o) = 1 2}\ - {g::~g 3}\ - {f::~f 3}\ - {e::~e 3}\ - {E::E 4}\ - {F::F 4}\ - {G::G 4}\ - {E::(4,_derived) = ::C::G}\ - {E::(4,m) = x y}\ - {F::(4,_derived) = ::C::G}\ - {F::(4,n) = z}\ - {G::(4,o) = 1 2}\ - {G::~G 4}\ - {F::~F 4}\ - {E::~E 4}\ - {E::E 5}\ - {F::F 5}\ - {G::G 5}\ - {C::E::(5,_derived) = ::C::G}\ - {C::E::(5,m) = x y}\ - {C::F::(5,_derived) = ::C::G}\ - {C::F::(5,n) = z}\ - {C::G::(5,o) = 1 2}\ - {G::~G 5}\ - {F::~F 5}\ - {E::~E 5}\ -] - -test stooop-32 { - check that class constructor with multiple base classes has correct number - of base class / argument pairs -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - catch { - class c {} - proc c::c {this} a {} b {} - } message - lappend ::result $message - - catch { - class C { - proc C {this} A {} B {} - } - } message - lappend ::result $message - - catch { - class d {} - class d::g {} - proc d::g::g {this} d::e {} d::f {} - } message - lappend ::result $message - - catch { - class C { - class G { - proc G {this} C::E {} C::F {} - } - } - } message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {bad class ::c constructor declaration, a base class, contructor arguments or body may be missing}\ - {bad class ::C constructor declaration, a base class, contructor arguments or body may be missing}\ - {bad class ::d::g constructor declaration, a base class, contructor arguments or body may be missing}\ - {bad class ::C::G constructor declaration, a base class, contructor arguments or body may be missing}\ -] - -test stooop-33 { - check that base class of class with multiple base classes is defined -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - catch { - class a {} - proc a::a {this} {} - class b {} - class c {} - proc c::c {this} a {} b {} {} - } message - lappend ::result $message - - catch { - class A { - proc A {this} {} - } - class B {} - class C { - proc C {this} A {} B {} {} - } - } message - lappend ::result $message - - catch { - class d {} - class d::e {} - proc d::e::e {this} {} - class d::f {} - class d::g {} - proc d::g::g {this} d::e {} d::f {} {} - } message - lappend ::result $message - - catch { - class C { - class E { - proc E {this} {} - } - class F {} - class G { - proc G {this} C::E {} C::F {} {} - } - } - } message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {class ::c constructor defined before base class b constructor}\ - {class ::C constructor defined before base class B constructor}\ - {class ::d::g constructor defined before base class d::f constructor}\ - {class ::C::G constructor defined before base class C::F constructor}\ -] - -test stooop-34 { - check that a direct base class is not specified more than once in a class - constructor declaration -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - catch { - class a {} - proc a::a {this} {} - class c {} - proc c::c {this} a {} a {} {} - } message - lappend ::result $message - - catch { - class A { - proc A {this} {} - } - class C { - proc C {this} A {} A {} {} - } - } message - lappend ::result $message - - catch { - class d {} - class d::e {} - proc d::e::e {this} {} - class d::g {} - proc d::g::g {this} d::e {} d::e {} {} - } message - lappend ::result $message - - catch { - class D { - class E { - proc E {this} {} - } - class G { - proc G {this} D::E {} D::E {} {} - } - } - } message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {class ::c directly inherits from class ::a more than once}\ - {class ::C directly inherits from class ::A more than once}\ - {class ::d::g directly inherits from class ::d::e more than once}\ - {class ::D::G directly inherits from class ::D::E more than once}\ -] - -test stooop-35 { - check that class constructor with multiple base classes allows new lines - within base class constructors arguments -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this p} { - lappend ::result "a::a $this" - set ($this,m) $p - } - proc a::~a {this} { - lappend ::result "a::~a $this" - } - class b {} - proc b::b {this p} { - lappend ::result "b::b $this" - set ($this,n) $p - } - proc b::~b {this} { - lappend ::result "b::~b $this" - } - class c {} - proc c::c {this p q r} a { - $p - } b { - $q - } { - lappend ::result "c::c $this" - set ($this,o) $r - } - proc c::~c {this} { - lappend ::result "c::~c $this" - } - new c {x y} z {1 2} - eval lappend ::result [dumpArrays a:: b:: c::] - - class A { - proc A {this p} { - lappend ::result "A::A $this" - set ($this,m) $p - } - proc ~A {this} { - lappend ::result "A::~A $this" - } - } - class B { - proc B {this p} { - lappend ::result "B::B $this" - set ($this,n) $p - } - proc ~B {this} { - lappend ::result "B::~B $this" - } - } - class C { - proc C {this p q r} A { - $p - } B { - $q - } { - lappend ::result "C::C $this" - set ($this,o) $r - } - proc ~C {this} { - lappend ::result "C::~C $this" - } - } - new C {x y} z {1 2} - eval lappend ::result [dumpArrays A:: B:: C::] - - class d {} - class d::e {} - proc d::e::e {this p} { - lappend ::result "e::e $this" - set ($this,m) $p - } - proc d::e::~e {this} { - lappend ::result "e::~e $this" - } - class d::f {} - proc d::f::f {this p} { - lappend ::result "f::f $this" - set ($this,n) $p - } - proc d::f::~f {this} { - lappend ::result "f::~f $this" - } - class d::g {} - proc d::g::g {this p q r} d::e { - $p - } d::f { - $q - } { - lappend ::result "g::g $this" - set ($this,o) $r - } - proc d::g::~g {this} { - lappend ::result "g::~g $this" - } - new d::g {x y} z {1 2} - eval lappend ::result [dumpArrays d::e:: d::f:: d::g::] - - class D { - class E { - proc E {this p} { - lappend ::result "E::E $this" - set ($this,m) $p - } - proc ~E {this} { - lappend ::result "E::~E $this" - } - } - class F { - proc F {this p} { - lappend ::result "F::F $this" - set ($this,n) $p - } - proc ~F {this} { - lappend ::result "F::~F $this" - } - } - class G { - proc G {this p q r} D::E { - $p - } D::F { - $q - } { - lappend ::result "G::G $this" - set ($this,o) $r - } - proc ~G {this} { - lappend ::result "G::~G $this" - } - } - new G {x y} z {1 2} - eval lappend ::result [dumpArrays E:: F:: G::] - } - new D::G {x y} z {1 2} - eval lappend ::result [dumpArrays D::E:: D::F:: D::G::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1}\ - {b::b 1}\ - {c::c 1}\ - {a::(1,_derived) = ::c}\ - {a::(1,m) = x y}\ - {b::(1,_derived) = ::c}\ - {b::(1,n) = z}\ - {c::(1,o) = 1 2}\ - {A::A 2}\ - {B::B 2}\ - {C::C 2}\ - {A::(2,_derived) = ::C}\ - {A::(2,m) = x y}\ - {B::(2,_derived) = ::C}\ - {B::(2,n) = z}\ - {C::(2,o) = 1 2}\ - {e::e 3}\ - {f::f 3}\ - {g::g 3}\ - {d::e::(3,_derived) = ::d::g}\ - {d::e::(3,m) = x y}\ - {d::f::(3,_derived) = ::d::g}\ - {d::f::(3,n) = z}\ - {d::g::(3,o) = 1 2}\ - {E::E 4}\ - {F::F 4}\ - {G::G 4}\ - {E::(4,_derived) = ::D::G}\ - {E::(4,m) = x y}\ - {F::(4,_derived) = ::D::G}\ - {F::(4,n) = z}\ - {G::(4,o) = 1 2}\ - {E::E 5}\ - {F::F 5}\ - {G::G 5}\ - {D::E::(4,_derived) = ::D::G}\ - {D::E::(4,m) = x y}\ - {D::E::(5,_derived) = ::D::G}\ - {D::E::(5,m) = x y}\ - {D::F::(4,_derived) = ::D::G}\ - {D::F::(4,n) = z}\ - {D::F::(5,_derived) = ::D::G}\ - {D::F::(5,n) = z}\ - {D::G::(4,o) = 1 2}\ - {D::G::(5,o) = 1 2}\ -] - -test stooop-36 { - check multiple inheritance construction order, destruction order and data - deallocation with a common indirect base class - (see test 71 for nested class version) -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this p} { - lappend ::result "a::a $this" - set ($this,m) $p - } - proc a::~a {this} { - lappend ::result "a::~a $this" - } - class b {} - proc b::b {this p} { - lappend ::result "b::b $this" - set ($this,n) $p - } - proc b::~b {this} { - lappend ::result "b::~b $this" - } - class c {} - proc c::c {this p q r} a {$p} b {$q} { - lappend ::result "c::c $this" - set ($this,o) $r - } - proc c::~c {this} { - lappend ::result "c::~c $this" - } - class d {} - proc d::d {this p q r} a {$p} b {$q} { - lappend ::result "d::d $this" - set ($this,p) $p - } - proc d::~d {this} { - lappend ::result "d::~d $this" - } - class e {} - proc e::e {this p q r} c {$p $q $r} d {$q $q $r} { - lappend ::result "e::e $this" - set ($this,q) $q - } - proc e::~e {this} { - lappend ::result "e::~e $this" - } - set o [new e {x y} z {1 2}] - eval lappend ::result [dumpArrays a:: b:: c:: d:: e::] - delete $o - eval lappend ::result [dumpArrays a:: b:: c:: d:: e::] - - class A { - proc A {this p} { - lappend ::result "A::A $this" - set ($this,m) $p - } - proc ~A {this} { - lappend ::result "A::~A $this" - } - } - class B { - proc B {this p} { - lappend ::result "B::B $this" - set ($this,n) $p - } - proc ~B {this} { - lappend ::result "B::~B $this" - } - } - class C { - proc C {this p q r} A {$p} B {$q} { - lappend ::result "C::C $this" - set ($this,o) $r - } - proc ~C {this} { - lappend ::result "C::~C $this" - } - } - class D { - proc D {this p q r} A {$p} B {$q} { - lappend ::result "D::D $this" - set ($this,p) $p - } - proc ~D {this} { - lappend ::result "D::~D $this" - } - } - class E { - proc E {this p q r} C {$p $q $r} D {$q $q $r} { - lappend ::result "E::E $this" - set ($this,q) $q - } - proc ~E {this} { - lappend ::result "E::~E $this" - } - } - set o [new E {x y} z {1 2}] - eval lappend ::result [dumpArrays A:: B:: C:: D:: E::] - delete $o - eval lappend ::result [dumpArrays A:: B:: C:: D:: E::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1}\ - {b::b 1}\ - {c::c 1}\ - {a::a 1}\ - {b::b 1}\ - {d::d 1}\ - {e::e 1}\ - {a::(1,_derived) = ::d}\ - {a::(1,m) = z}\ - {b::(1,_derived) = ::d}\ - {b::(1,n) = z}\ - {c::(1,_derived) = ::e}\ - {c::(1,o) = 1 2}\ - {d::(1,_derived) = ::e}\ - {d::(1,p) = z}\ - {e::(1,q) = z}\ - {e::~e 1}\ - {d::~d 1}\ - {b::~b 1}\ - {a::~a 1}\ - {c::~c 1}\ - {b::~b 1}\ - {a::~a 1}\ - {A::A 2}\ - {B::B 2}\ - {C::C 2}\ - {A::A 2}\ - {B::B 2}\ - {D::D 2}\ - {E::E 2}\ - {A::(2,_derived) = ::D}\ - {A::(2,m) = z}\ - {B::(2,_derived) = ::D}\ - {B::(2,n) = z}\ - {C::(2,_derived) = ::E}\ - {C::(2,o) = 1 2}\ - {D::(2,_derived) = ::E}\ - {D::(2,p) = z}\ - {E::(2,q) = z}\ - {E::~E 2}\ - {D::~D 2}\ - {B::~B 2}\ - {A::~A 2}\ - {C::~C 2}\ - {B::~B 2}\ - {A::~A 2}\ -] - -test stooop-37 { - check that multiply inherited base classes constructors work with variable - number of arguments (see test 72 for nested class version) -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this args} { - lappend ::result "a::a $this $args" - set ($this,m) [lindex $args 0] - } - class b {} - proc b::b {this p} { - lappend ::result "b::b $this $p" - set ($this,n) $p - } - class c {} - proc c::c {this p args} { - lappend ::result "c::c $this $p $args" - set ($this,o) $p - set ($this,p) [lindex $args 0] - } - class d {} - proc d::d {this p args} a {$args} b {$p} c {$p $args} { - lappend ::result "d::d $this $p $args" - set ($this,q) $p - set ($this,r) [lindex $args 0] - } - new d {x y} {1 2} 3 - eval lappend ::result [dumpArrays a:: b:: c:: d::] - - class A { - proc A {this args} { - lappend ::result "A::A $this $args" - set ($this,m) [lindex $args 0] - } - } - class B { - proc B {this p} { - lappend ::result "B::B $this $p" - set ($this,n) $p - } - } - class C { - proc C {this p args} { - lappend ::result "C::C $this $p $args" - set ($this,o) $p - set ($this,p) [lindex $args 0] - } - } - class D { - proc D {this p args} A {$args} B {$p} C {$p $args} { - lappend ::result "D::D $this $p $args" - set ($this,q) $p - set ($this,r) [lindex $args 0] - } - } - new D {x y} {1 2} 3 - eval lappend ::result [dumpArrays A:: B:: C:: D::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1 {1 2} 3}\ - {b::b 1 x y}\ - {c::c 1 x y {1 2} 3}\ - {d::d 1 x y {1 2} 3}\ - {a::(1,_derived) = ::d}\ - {a::(1,m) = 1 2}\ - {b::(1,_derived) = ::d}\ - {b::(1,n) = x y}\ - {c::(1,_derived) = ::d}\ - {c::(1,o) = x y}\ - {c::(1,p) = 1 2}\ - {d::(1,q) = x y}\ - {d::(1,r) = 1 2}\ - {A::A 2 {1 2} 3}\ - {B::B 2 x y}\ - {C::C 2 x y {1 2} 3}\ - {D::D 2 x y {1 2} 3}\ - {A::(2,_derived) = ::D}\ - {A::(2,m) = 1 2}\ - {B::(2,_derived) = ::D}\ - {B::(2,n) = x y}\ - {C::(2,_derived) = ::D}\ - {C::(2,o) = x y}\ - {C::(2,p) = 1 2}\ - {D::(2,q) = x y}\ - {D::(2,r) = 1 2}\ -] - -test stooop-38 { - check multiple inheritance destruction order and data deallocation with a - common indirect base class (see test 73 for nested class version) -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this p} { - lappend ::result "a::a $this" - set ($this,m) $p - } - proc a::~a {this} { - lappend ::result "a::~a $this" - } - class b {} - proc b::b {this p} { - lappend ::result "b::b $this" - set ($this,n) $p - } - proc b::~b {this} { - lappend ::result "b::~b $this" - } - class c {} - proc c::c {this p q r} a {$p} b {$q} { - lappend ::result "c::c $this" - set ($this,o) $r - } - proc c::~c {this} { - lappend ::result "c::~c $this" - } - class d {} - proc d::d {this p q r} a {$p} b {$q} { - lappend ::result "d::d $this" - set ($this,p) $p - } - proc d::~d {this} { - lappend ::result "d::~d $this" - } - class e {} - proc e::e {this p q r} c {$p $q $r} d {$q $q $r} { - lappend ::result "e::e $this" - set ($this,q) $q - } - proc e::~e {this} { - lappend ::result "e::~e $this" - } - set o [new e {x y} z {1 2}] - eval lappend ::result [dumpArrays a:: b:: c:: d:: e::] - delete $o - eval lappend ::result [dumpArrays a:: b:: c:: d:: e::] - - class A { - proc A {this p} { - lappend ::result "A::A $this" - set ($this,m) $p - } - proc ~A {this} { - lappend ::result "A::~A $this" - } - } - class B { - proc B {this p} { - lappend ::result "B::B $this" - set ($this,n) $p - } - proc ~B {this} { - lappend ::result "B::~B $this" - } - } - class C { - proc C {this p q r} A {$p} B {$q} { - lappend ::result "C::C $this" - set ($this,o) $r - } - proc ~C {this} { - lappend ::result "C::~C $this" - } - } - class D { - proc D {this p q r} A {$p} B {$q} { - lappend ::result "D::D $this" - set ($this,p) $p - } - proc ~D {this} { - lappend ::result "D::~D $this" - } - } - class E { - proc E {this p q r} C {$p $q $r} D {$q $q $r} { - lappend ::result "E::E $this" - set ($this,q) $q - } - proc ~E {this} { - lappend ::result "E::~E $this" - } - } - set o [new E {x y} z {1 2}] - eval lappend ::result [dumpArrays A:: B:: C:: D:: E::] - delete $o - eval lappend ::result [dumpArrays A:: B:: C:: D:: E::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1}\ - {b::b 1}\ - {c::c 1}\ - {a::a 1}\ - {b::b 1}\ - {d::d 1}\ - {e::e 1}\ - {a::(1,_derived) = ::d}\ - {a::(1,m) = z}\ - {b::(1,_derived) = ::d}\ - {b::(1,n) = z}\ - {c::(1,_derived) = ::e}\ - {c::(1,o) = 1 2}\ - {d::(1,_derived) = ::e}\ - {d::(1,p) = z}\ - {e::(1,q) = z}\ - {e::~e 1}\ - {d::~d 1}\ - {b::~b 1}\ - {a::~a 1}\ - {c::~c 1}\ - {b::~b 1}\ - {a::~a 1}\ - {A::A 2}\ - {B::B 2}\ - {C::C 2}\ - {A::A 2}\ - {B::B 2}\ - {D::D 2}\ - {E::E 2}\ - {A::(2,_derived) = ::D}\ - {A::(2,m) = z}\ - {B::(2,_derived) = ::D}\ - {B::(2,n) = z}\ - {C::(2,_derived) = ::E}\ - {C::(2,o) = 1 2}\ - {D::(2,_derived) = ::E}\ - {D::(2,p) = z}\ - {E::(2,q) = z}\ - {E::~E 2}\ - {D::~D 2}\ - {B::~B 2}\ - {A::~A 2}\ - {C::~C 2}\ - {B::~B 2}\ - {A::~A 2}\ -] - -test stooop-39 { - check that optional arguments in constructors and multiple inheritance work - together (see test 74 for nested class version) -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this {p 0}} { - lappend ::result "a::a $this" - set ($this,m) $p - } - proc a::~a {this} { - lappend ::result "a::~a $this" - } - class b {} - proc b::b {this {p 1}} { - lappend ::result "b::b $this" - set ($this,n) $p - } - proc b::~b {this} { - lappend ::result "b::~b $this" - } - class c {} - proc c::c {this {p 2} {q 3}} a {$p} b {$q} { - lappend ::result "c::c $this" - set ($this,o) $p - set ($this,p) $q - } - proc c::~c {this} { - lappend ::result "c::~c $this" - } - set o [new c {x y} z] - eval lappend ::result [dumpArrays a:: b:: c::] - delete $o - set o [new c] - eval lappend ::result [dumpArrays a:: b:: c::] - - class A { - proc A {this {p 0}} { - lappend ::result "A::A $this" - set ($this,m) $p - } - proc ~A {this} { - lappend ::result "A::~A $this" - } - } - class B { - proc B {this {p 1}} { - lappend ::result "B::B $this" - set ($this,n) $p - } - proc ~B {this} { - lappend ::result "B::~B $this" - } - } - class C { - proc C {this {p 2} {q 3}} A {$p} B {$q} { - lappend ::result "C::C $this" - set ($this,o) $p - set ($this,p) $q - } - proc ~C {this} { - lappend ::result "C::~C $this" - } - } - set o [new C {x y} z] - eval lappend ::result [dumpArrays A:: B:: C::] - delete $o - set o [new C] - eval lappend ::result [dumpArrays A:: B:: C::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1}\ - {b::b 1}\ - {c::c 1}\ - {a::(1,_derived) = ::c}\ - {a::(1,m) = x y}\ - {b::(1,_derived) = ::c}\ - {b::(1,n) = z}\ - {c::(1,o) = x y}\ - {c::(1,p) = z}\ - {c::~c 1}\ - {b::~b 1}\ - {a::~a 1}\ - {a::a 2}\ - {b::b 2}\ - {c::c 2}\ - {a::(2,_derived) = ::c}\ - {a::(2,m) = 2}\ - {b::(2,_derived) = ::c}\ - {b::(2,n) = 3}\ - {c::(2,o) = 2}\ - {c::(2,p) = 3}\ - {A::A 3}\ - {B::B 3}\ - {C::C 3}\ - {A::(3,_derived) = ::C}\ - {A::(3,m) = x y}\ - {B::(3,_derived) = ::C}\ - {B::(3,n) = z}\ - {C::(3,o) = x y}\ - {C::(3,p) = z}\ - {C::~C 3}\ - {B::~B 3}\ - {A::~A 3}\ - {A::A 4}\ - {B::B 4}\ - {C::C 4}\ - {A::(4,_derived) = ::C}\ - {A::(4,m) = 2}\ - {B::(4,_derived) = ::C}\ - {B::(4,n) = 3}\ - {C::(4,o) = 2}\ - {C::(4,p) = 3}\ -] - -test stooop-40 { - check various virtual procedures configurations in a 3 level deep class - hierarchy (see test 75 for nested class version) -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a {} - proc a::a {this} {} - proc a::~a {this} {} - virtual proc a::f {this p q} {} - virtual proc a::g {this p q} - virtual proc a::h {this p q} { - lappend ::result "a::h $this $p $q" - } - virtual proc a::i {this p q} { - lappend ::result "a::i $this $p $q" - } - virtual proc a::k {this p q} - virtual proc a::l {this p q} { - lappend ::result "a::l $this $p $q" - } - class b {} - proc b::b {this} a {} {} - proc b::~b {this} {} - virtual proc b::f {this p q} { - lappend ::result "b::f $this $p $q" - } - virtual proc b::g {this p q} - virtual proc b::h {this p q} { - lappend ::result "b::h $this $p $q" - } - proc b::i {this p q} { - lappend ::result "b::i $this $p $q" - } - virtual proc b::k {this p q} { - lappend ::result "b::k $this $p $q" - } - virtual proc b::l {this p q} - class c {} - proc c::c {this} b {} {} - proc c::~c {this} {} - proc c::f {this p q} { - lappend ::result "c::f $this $p $q" - } - proc c::g {this p q} { - lappend ::result "c::g $this $p $q" - } - proc c::i {this p q} { - lappend ::result "c::i $this $p $q" - } - proc c::k {this p q} { - lappend ::result "c::k $this $p $q" - } - proc c::l {this p q} { - lappend ::result "c::l $this $p $q" - } - set o [new c] - a::f $o x {y z} - a::g $o x {y z} - a::h $o x {y z} - a::i $o x {y z} - a::k $o x {y z} - a::l $o x {y z} - - class A { - proc A {this} {} - proc ~A {this} {} - virtual proc f {this p q} {} - virtual proc g {this p q} - virtual proc h {this p q} { - lappend ::result "A::h $this $p $q" - } - virtual proc i {this p q} { - lappend ::result "A::i $this $p $q" - } - virtual proc k {this p q} - virtual proc l {this p q} { - lappend ::result "A::l $this $p $q" - } - } - class B { - proc B {this} A {} {} - proc ~B {this} {} - virtual proc f {this p q} { - lappend ::result "B::f $this $p $q" - } - virtual proc g {this p q} - virtual proc h {this p q} { - lappend ::result "B::h $this $p $q" - } - proc i {this p q} { - lappend ::result "B::i $this $p $q" - } - virtual proc k {this p q} { - lappend ::result "B::k $this $p $q" - } - virtual proc l {this p q} - } - class C { - proc C {this} B {} {} - proc ~C {this} {} - proc f {this p q} { - lappend ::result "C::f $this $p $q" - } - proc g {this p q} { - lappend ::result "C::g $this $p $q" - } - proc i {this p q} { - lappend ::result "C::i $this $p $q" - } - proc k {this p q} { - lappend ::result "C::k $this $p $q" - } - proc l {this p q} { - lappend ::result "C::l $this $p $q" - } - } - set o [new C] - A::f $o x {y z} - A::g $o x {y z} - A::h $o x {y z} - A::i $o x {y z} - A::k $o x {y z} - A::l $o x {y z} - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {c::f 1 x y z}\ - {c::g 1 x y z}\ - {b::h 1 x y z}\ - {b::i 1 x y z}\ - {c::k 1 x y z}\ - {c::l 1 x y z}\ - {C::f 2 x y z}\ - {C::g 2 x y z}\ - {B::h 2 x y z}\ - {B::i 2 x y z}\ - {C::k 2 x y z}\ - {C::l 2 x y z}\ -] - -test stooop-41 { - check various virtual procedures with variable number of arguments - configurations in a 3 level deep class hierarchy - (see 76.tcl for nested class version) -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a {} - proc a::a {this} {} - proc a::~a {this} {} - virtual proc a::f {this p args} {} - virtual proc a::g {this p args} - virtual proc a::h {this p args} { - lappend ::result "a::h $this $p $args" - } - virtual proc a::i {this p args} { - lappend ::result "a::i $this $p $args" - } - virtual proc a::k {this p args} - virtual proc a::l {this p args} { - lappend ::result "a::l $this $p $args" - } - class b {} - proc b::b {this} a {} {} - proc b::~b {this} {} - virtual proc b::f {this p args} { - lappend ::result "b::f $this $p $args" - } - virtual proc b::g {this p args} - virtual proc b::h {this p args} { - lappend ::result "b::h $this $p $args" - } - proc b::i {this p args} { - lappend ::result "b::i $this $p $args" - } - virtual proc b::k {this p args} { - lappend ::result "b::k $this $p $args" - } - virtual proc b::l {this p args} - class c {} - proc c::c {this} b {} {} - proc c::~c {this} {} - proc c::f {this p args} { - lappend ::result "c::f $this $p $args" - } - proc c::g {this p args} { - lappend ::result "c::g $this $p $args" - } - proc c::i {this p args} { - lappend ::result "c::i $this $p $args" - } - proc c::k {this p args} { - lappend ::result "c::k $this $p $args" - } - proc c::l {this p args} { - lappend ::result "c::l $this $p $args" - } - set o [new c] - a::f $o x {y z} - a::g $o x {y z} - a::h $o x {y z} - a::i $o x {y z} - a::k $o x {y z} - a::l $o x {y z} - - class A { - proc A {this} {} - proc ~A {this} {} - virtual proc f {this p args} {} - virtual proc g {this p args} - virtual proc h {this p args} { - lappend ::result "A::h $this $p $args" - } - virtual proc i {this p args} { - lappend ::result "A::i $this $p $args" - } - virtual proc k {this p args} - virtual proc l {this p args} { - lappend ::result "A::l $this $p $args" - } - } - class B { - proc B {this} A {} {} - proc ~B {this} {} - virtual proc f {this p args} { - lappend ::result "B::f $this $p $args" - } - virtual proc g {this p args} - virtual proc h {this p args} { - lappend ::result "B::h $this $p $args" - } - proc i {this p args} { - lappend ::result "B::i $this $p $args" - } - virtual proc k {this p args} { - lappend ::result "B::k $this $p $args" - } - virtual proc l {this p args} - } - class C { - proc C {this} B {} {} - proc ~C {this} {} - proc f {this p args} { - lappend ::result "C::f $this $p $args" - } - proc g {this p args} { - lappend ::result "C::g $this $p $args" - } - proc i {this p args} { - lappend ::result "C::i $this $p $args" - } - proc k {this p args} { - lappend ::result "C::k $this $p $args" - } - proc l {this p args} { - lappend ::result "C::l $this $p $args" - } - } - set o [new C] - A::f $o x {y z} - A::g $o x {y z} - A::h $o x {y z} - A::i $o x {y z} - A::k $o x {y z} - A::l $o x {y z} - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {c::f 1 x {y z}}\ - {c::g 1 x {y z}}\ - {b::h 1 x {y z}}\ - {b::i 1 x {y z}}\ - {c::k 1 x {y z}}\ - {c::l 1 x {y z}}\ - {C::f 2 x {y z}}\ - {C::g 2 x {y z}}\ - {B::h 2 x {y z}}\ - {B::i 2 x {y z}}\ - {C::k 2 x {y z}}\ - {C::l 2 x {y z}}\ -] - -test stooop-42 { - check basic cloning operation (see nested class version in test 70) -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this} { - set ($this,x) 0 - } - new [new a] - eval lappend ::result [dumpArrays a::] - - class A { - proc A {this} { - set ($this,x) 0 - } - } - new [new A] - eval lappend ::result [dumpArrays A::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::(1,x) = 0}\ - {a::(2,x) = 0}\ - {A::(3,x) = 0}\ - {A::(4,x) = 0}\ -] - -test stooop-43 { - check user defined cloning operation (see nested class version in test 69) -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this} { - set ($this,x) 0 - } - proc a::a {this copy} { - set ($this,x) [expr $($copy,x)+1] - } - new [new a] - eval lappend ::result [dumpArrays a::] - - class A { - proc A {this} { - set ($this,x) 0 - } - proc A {this copy} { - set ($this,x) [expr $($copy,x)+1] - } - } - new [new A] - eval lappend ::result [dumpArrays A::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::(1,x) = 0}\ - {a::(2,x) = 1}\ - {A::(3,x) = 0}\ - {A::(4,x) = 1}\ -] - -test stooop-44 { - check cloning operation in a 3 level deep class hierarchy -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this} { - set ($this,x) 0 - } - class b {} - proc b::b {this} a {} { - set ($this,y) 1 - } - class c {} - proc c::c {this} b {} { - set ($this,z) 2 - } - new [new c] - eval lappend ::result [dumpArrays a:: b:: c::] - - class A { - proc A {this} { - set ($this,x) 0 - } - } - class B { - proc B {this} A {} { - set ($this,y) 1 - } - } - class C { - proc C {this} B {} { - set ($this,z) 2 - } - } - new [new C] - eval lappend ::result [dumpArrays A:: B:: C::] - - class d {} - class d::e {} - proc d::e::e {this} { - set ($this,x) 0 - } - class d::f {} - proc d::f::f {this} d::e {} { - set ($this,y) 1 - } - class d::g {} - proc d::g::g {this} d::f {} { - set ($this,z) 2 - } - new [new d::g] - eval lappend ::result [dumpArrays d::e:: d::f:: d::g::] - - class D { - class E { - proc E {this} { - set ($this,x) 0 - } - } - class F { - proc F {this} D::E {} { - set ($this,y) 1 - } - } - class G { - proc G {this} D::F {} { - set ($this,z) 2 - } - } - new [new G] - eval lappend ::result [dumpArrays E:: F:: G::] - } - new [new D::G] - eval lappend ::result [dumpArrays D::E:: D::F:: D::G::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::(1,_derived) = ::b}\ - {a::(1,x) = 0}\ - {a::(2,_derived) = ::b}\ - {a::(2,x) = 0}\ - {b::(1,_derived) = ::c}\ - {b::(1,y) = 1}\ - {b::(2,_derived) = ::c}\ - {b::(2,y) = 1}\ - {c::(1,z) = 2}\ - {c::(2,z) = 2}\ - {A::(3,_derived) = ::B}\ - {A::(3,x) = 0}\ - {A::(4,_derived) = ::B}\ - {A::(4,x) = 0}\ - {B::(3,_derived) = ::C}\ - {B::(3,y) = 1}\ - {B::(4,_derived) = ::C}\ - {B::(4,y) = 1}\ - {C::(3,z) = 2}\ - {C::(4,z) = 2}\ - {d::e::(5,_derived) = ::d::f}\ - {d::e::(5,x) = 0}\ - {d::e::(6,_derived) = ::d::f}\ - {d::e::(6,x) = 0}\ - {d::f::(5,_derived) = ::d::g}\ - {d::f::(5,y) = 1}\ - {d::f::(6,_derived) = ::d::g}\ - {d::f::(6,y) = 1}\ - {d::g::(5,z) = 2}\ - {d::g::(6,z) = 2}\ - {E::(7,_derived) = ::D::F}\ - {E::(7,x) = 0}\ - {E::(8,_derived) = ::D::F}\ - {E::(8,x) = 0}\ - {F::(7,_derived) = ::D::G}\ - {F::(7,y) = 1}\ - {F::(8,_derived) = ::D::G}\ - {F::(8,y) = 1}\ - {G::(7,z) = 2}\ - {G::(8,z) = 2}\ - {D::E::(10,_derived) = ::D::F}\ - {D::E::(10,x) = 0}\ - {D::E::(7,_derived) = ::D::F}\ - {D::E::(7,x) = 0}\ - {D::E::(8,_derived) = ::D::F}\ - {D::E::(8,x) = 0}\ - {D::E::(9,_derived) = ::D::F}\ - {D::E::(9,x) = 0}\ - {D::F::(10,_derived) = ::D::G}\ - {D::F::(10,y) = 1}\ - {D::F::(7,_derived) = ::D::G}\ - {D::F::(7,y) = 1}\ - {D::F::(8,_derived) = ::D::G}\ - {D::F::(8,y) = 1}\ - {D::F::(9,_derived) = ::D::G}\ - {D::F::(9,y) = 1}\ - {D::G::(10,z) = 2}\ - {D::G::(7,z) = 2}\ - {D::G::(8,z) = 2}\ - {D::G::(9,z) = 2}\ -] - -test stooop-45 { - check user defined cloning operation error checking -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - catch { - class a {} - proc a::a {this} { - set ($this,x) 0 - } - proc a::a {destination source} {} - new [new a] - } message - lappend ::result $message - - catch { - class A { - proc A {this} { - set ($this,x) 0 - } - proc A {destination source} {} - } - new [new A] - } message - lappend ::result $message - - catch { - class b {} - class b::c {} - proc b::c::c {this} { - set ($this,x) 0 - } - proc b::c::c {destination source} {} - new [new b::c] - } message - lappend ::result $message - - catch { - class B { - class C { - proc C {this} { - set ($this,x) 0 - } - proc C {destination source} {} - } - new [new C] - } - } message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {class ::a constructor first argument must be this}\ - {class ::A constructor first argument must be this}\ - {class ::b::c constructor first argument must be this}\ - {class ::B::C constructor first argument must be this}\ -] - -test stooop-46 { - check user defined cloning operation error checking -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - catch { - class a {} - proc a::a {this} { - set ($this,x) 0 - } - proc a::a {this copy dummy} {} - new [new a] - } message - lappend ::result $message - - catch { - class A { - proc A {this} { - set ($this,x) 0 - } - proc A {this copy dummy} {} - } - new [new A] - } message - lappend ::result $message - - catch { - class b {} - class b::c {} - proc b::c::c {this} { - set ($this,x) 0 - } - proc b::c::c {this copy dummy} {} - new [new b::c] - } message - lappend ::result $message - - catch { - class B { - class C { - proc C {this} { - set ($this,x) 0 - } - proc C {this copy dummy} {} - } - new [new C] - } - } message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {class ::a copy constructor must have 2 arguments exactly}\ - {class ::A copy constructor must have 2 arguments exactly}\ - {class ::b::c copy constructor must have 2 arguments exactly}\ - {class ::B::C copy constructor must have 2 arguments exactly}\ -] - -test stooop-47 { - check normal and user defined cloning operation with multiple inheritance - and member objects (see test 77 for nested class version) -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this p} { - set ($this,m) $p - } - class b {} - proc b::b {this p} { - set ($this,n) $p - } - class c {} - proc c::c {this p q r} a {$p} b {$q} { - set ($this,o) $r - set ($this,O) [new f] - } - proc c::c {this copy} a {$a::($copy,m)} b 1 { - set ($this,o) $($copy,o) - set ($this,O) [new f] - } - class d {} - proc d::d {this p q r} a {$p} b {$q} { - set ($this,p) $p - } - class e {} - proc e::e {this p q r} c {$p $q $r} d {$q $q $r} { - set ($this,q) $q - } - class f {} - proc f::f {this} { - set ($this,x) 0 - } - new [new e {x y} z {1 2}] - eval lappend ::result [dumpArrays a:: b:: c:: d:: e:: f::] - - class A { - proc A {this p} { - set ($this,m) $p - } - } - class B { - proc B {this p} { - set ($this,n) $p - } - } - class C { - proc C {this p q r} A {$p} B {$q} { - set ($this,o) $r - set ($this,O) [new F] - } - proc C {this copy} A {$A::($copy,m)} B 1 { - set ($this,o) $($copy,o) - set ($this,O) [new F] - } - } - class D { - proc D {this p q r} A {$p} B {$q} { - set ($this,p) $p - } - } - class E { - proc E {this p q r} C {$p $q $r} D {$q $q $r} { - set ($this,q) $q - } - } - class F { - proc F {this} { - set ($this,x) 0 - } - } - new [new E {x y} z {1 2}] - eval lappend ::result [dumpArrays A:: B:: C:: D:: E:: F::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::(1,_derived) = ::d}\ - {a::(1,m) = z}\ - {a::(3,_derived) = ::d}\ - {a::(3,m) = z}\ - {b::(1,_derived) = ::d}\ - {b::(1,n) = z}\ - {b::(3,_derived) = ::d}\ - {b::(3,n) = z}\ - {c::(1,O) = 2}\ - {c::(1,_derived) = ::e}\ - {c::(1,o) = 1 2}\ - {c::(3,O) = 4}\ - {c::(3,_derived) = ::e}\ - {c::(3,o) = 1 2}\ - {d::(1,_derived) = ::e}\ - {d::(1,p) = z}\ - {d::(3,_derived) = ::e}\ - {d::(3,p) = z}\ - {e::(1,q) = z}\ - {e::(3,q) = z}\ - {f::(2,x) = 0}\ - {f::(4,x) = 0}\ - {A::(5,_derived) = ::D}\ - {A::(5,m) = z}\ - {A::(7,_derived) = ::D}\ - {A::(7,m) = z}\ - {B::(5,_derived) = ::D}\ - {B::(5,n) = z}\ - {B::(7,_derived) = ::D}\ - {B::(7,n) = z}\ - {C::(5,O) = 6}\ - {C::(5,_derived) = ::E}\ - {C::(5,o) = 1 2}\ - {C::(7,O) = 8}\ - {C::(7,_derived) = ::E}\ - {C::(7,o) = 1 2}\ - {D::(5,_derived) = ::E}\ - {D::(5,p) = z}\ - {D::(7,_derived) = ::E}\ - {D::(7,p) = z}\ - {E::(5,q) = z}\ - {E::(7,q) = z}\ - {F::(6,x) = 0}\ - {F::(8,x) = 0}\ -] - -test stooop-48 { - check basic cloning operation with array members -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this} { - variable ${this}x - set ${this}x(0) 0 - set ($this,y) 1 - } - proc a::a {this copy} { - variable ${this}x - variable ${copy}x - array set ${this}x [array get ${copy}x] - set ($this,y) $($copy,y) - } - new [new a] - eval lappend ::result [dumpArrays a:: a::1x a::2x] - - class A { - proc A {this} { - variable ${this}x - set ${this}x(0) 0 - set ($this,y) 1 - } - proc A {this copy} { - variable ${this}x - variable ${copy}x - array set ${this}x [array get ${copy}x] - set ($this,y) $($copy,y) - } - } - new [new A] - eval lappend ::result [dumpArrays A:: A::3x A::4x] - - class b {} - class b::c {} - proc b::c::c {this} { - variable ${this}x - set ${this}x(0) 0 - set ($this,y) 1 - } - proc b::c::c {this copy} { - variable ${this}x - variable ${copy}x - array set ${this}x [array get ${copy}x] - set ($this,y) $($copy,y) - } - new [new b::c] - eval lappend ::result [dumpArrays b::c:: b::c::5x b::c::6x] - - class B { - class C { - proc C {this} { - variable ${this}x - set ${this}x(0) 0 - set ($this,y) 1 - } - proc C {this copy} { - variable ${this}x - variable ${copy}x - array set ${this}x [array get ${copy}x] - set ($this,y) $($copy,y) - } - } - new [new C] - eval lappend ::result [dumpArrays C:: C::7x C::8x] - } - new [new B::C] - eval lappend ::result [dumpArrays B::C:: B::C::9x B::C::10x] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::(1,y) = 1}\ - {a::(2,y) = 1}\ - {a::1x(0) = 0}\ - {a::2x(0) = 0}\ - {A::(3,y) = 1}\ - {A::(4,y) = 1}\ - {A::3x(0) = 0}\ - {A::4x(0) = 0}\ - {b::c::(5,y) = 1}\ - {b::c::(6,y) = 1}\ - {b::c::5x(0) = 0}\ - {b::c::6x(0) = 0}\ - {C::(7,y) = 1}\ - {C::(8,y) = 1}\ - {C::7x(0) = 0}\ - {C::8x(0) = 0}\ - {B::C::(10,y) = 1}\ - {B::C::(7,y) = 1}\ - {B::C::(8,y) = 1}\ - {B::C::(9,y) = 1}\ - {B::C::9x(0) = 0}\ - {B::C::10x(0) = 0}\ -] - -test stooop-49 { - check user defined cloning operation error checking -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - catch { - class a {} - proc a::a {this copy} {} - } message - lappend ::result $message - - catch { - class A { - proc A {this copy} {} - } - } message - lappend ::result $message - - catch { - class b {} - class b::c {} - proc b::c::c {this copy} {} - } message - lappend ::result $message - - catch { - class B { - class C { - proc C {this copy} {} - } - } - } message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {class ::a copy constructor defined before constructor}\ - {class ::A copy constructor defined before constructor}\ - {class ::b::c copy constructor defined before constructor}\ - {class ::B::C copy constructor defined before constructor}\ -] - -test stooop-50 { - check copy constructor base class(es) initialization errors -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - catch { - class a {} - proc a::a {this p} {} - class b {} - proc b::b {this} a 0 {} - proc b::b {this copy} {} - new [new b] - } message - lappend ::result $message - - catch { - class A { - proc A {this p} {} - } - class B { - proc B {this} A 0 {} - proc B {this copy} {} - } - new [new B] - } message - lappend ::result $message - - catch { - class c {} - class c::d {} - proc c::d::d {this p} {} - class c::e {} - proc c::e::e {this} c::d 0 {} - proc c::e::e {this copy} {} - new [new c::e] - } message - lappend ::result $message - - catch { - class C { - class D { - proc D {this p} {} - } - class E { - proc E {this} C::D 0 {} - proc E {this copy} {} - } - new [new E] - } - } message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {missing base class ::a constructor arguments from class ::b constructor}\ - {missing base class ::A constructor arguments from class ::B constructor}\ - {missing base class ::c::d constructor arguments from class ::c::e constructor}\ - {missing base class ::C::D constructor arguments from class ::C::E constructor}\ -] - -test stooop-51 { - check that multiple declarations that can occur when a class declaration - file is sourced multiple times have no adverse effects -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a {} - proc a::a {this} {} - class b {} - proc b::b {this} a {} {} - proc b::b {this} a {} {} - - class A { - proc A {this} {} - } - class B { - proc B {this} A {} {} - } - class B { - proc B {this} A {} {} - } - - class c {} - class c::d {} - proc c::d::d {this} {} - class c::e {} - proc c::e::e {this} c::d {} {} - proc c::e::e {this} c::d {} {} - - class C { - class D { - proc D {this} {} - } - class E { - proc E {this} C::D {} {} - } - class E { - proc E {this} C::D {} {} - } - } - - set ::result {} - }] - interp delete $interpreter - set result -} {} - -test stooop-52 { - check that member procedure cannot be defined before constructor - declaration for we need ancestors for global ancestors array declaration -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - catch { - class a {} - proc a::p {this} {} - } message - lappend ::result $message - - catch { - class A { - proc p {this} {} - } - } message - lappend ::result $message - - catch { - class b {} - class b::c {} - proc b::c::p {this} {} - } message - lappend ::result $message - - catch { - class B { - class C { - proc p {this} {} - } - } - } message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {class ::a member procedure p defined before constructor}\ - {class ::A member procedure p defined before constructor}\ - {class ::b::c member procedure p defined before constructor}\ - {class ::B::C member procedure p defined before constructor}\ -] - -test stooop-53 { - check that embedded command in base class constructor arguments does not - interfere with variable number of arguments processing special case -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a {} - proc a::a {this p args} {} - proc a::~a {this} {} - class b {} - proc b::b {this args} a {[list {}] $args} {} - proc b::b {this args} a {[list {}] $args } {} - proc b::b {this args} a { - [list {}] $args - } {} - - class A { - proc A {this p args} {} - proc ~A {this} {} - } - class B { - proc B {this args} A {[list {}] $args} {} - proc B {this args} A {[list {}] $args } {} - proc B {this args} A { - [list {}] $args - } {} - } - - class c {} - class c::d {} - proc c::d::d {this p args} {} - proc c::d::~d {this} {} - class c::e {} - proc c::e::e {this args} c::d {[list {}] $args} {} - proc c::e::e {this args} c::d {[list {}] $args } {} - proc c::e::e {this args} c::d { - [list {}] $args - } {} - - class C { - class D { - proc D {this p args} {} - proc ~D {this} {} - } - class E { - proc E {this args} C::D {[list {}] $args} {} - proc E {this args} C::D {[list {}] $args } {} - proc E {this args} C::D { - [list {}] $args - } {} - } - } - - set ::result {} - }] - interp delete $interpreter - set result -} {} - -test stooop-54 { - check that virtual procedure invocations from base class constructor behave - as in C++ (see test 78 for nested class version) -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a {} - proc a::a {this} { - a::f $this x - a::g $this x {y z} - # pure virtual invocations behavior is undefined - lappend ::result [catch {a::h $this x}] - lappend ::result [catch {a::i $this x {y z}}] - } - proc a::~a {this} {} - virtual proc a::f {this p} { - lappend ::result "a::f $this $p" - } - virtual proc a::g {this p args} { - lappend ::result "a::g $this $p $args" - } - virtual proc a::h {this p} - virtual proc a::i {this p args} - class b {} - proc b::b {this} a {} {} - proc b::~b {this} {} - virtual proc b::f {this p} { - lappend ::result "b::f $this $p" - } - virtual proc b::g {this p args} { - lappend ::result "b::g $this $p $args" - } - virtual proc b::h {this p} { - lappend ::result "b::h $this $p" - } - proc b::i {this p args} { - lappend ::result "b::i $this $p $args" - } - new b - - class A { - proc A {this} { - A::f $this x - A::g $this x {y z} - # pure virtual invocations behavior is undefined - lappend ::result [catch {A::h $this x}] - lappend ::result [catch {A::i $this x {y z}}] - } - proc ~A {this} {} - virtual proc f {this p} { - lappend ::result "A::f $this $p" - } - virtual proc g {this p args} { - lappend ::result "A::g $this $p $args" - } - virtual proc h {this p} - virtual proc i {this p args} - } - class B { - proc B {this} A {} {} - proc ~B {this} {} - virtual proc f {this p} { - lappend ::result "B::f $this $p" - } - virtual proc g {this p args} { - lappend ::result "B::g $this $p $args" - } - virtual proc h {this p} { - lappend ::result "B::h $this $p" - } - proc i {this p args} { - lappend ::result "B::i $this $p $args" - } - } - new B - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::f 1 x}\ - {a::g 1 x {y z}}\ - {1}\ - {1}\ - {A::f 2 x}\ - {A::g 2 x {y z}}\ - {1}\ - {1}\ -] - -test stooop-55 { - check that procedure invocation on variable arguments in derived class base - class constructor arguments works -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this p args} { - lappend ::result "a::a $this $p $args" - set ($this,m) [lindex $args 0] - } - proc a::~a {this} { - lappend ::result "a::~a $this" - } - class b {} - proc b::b {this p args} a {$p [concat $args]} { - lappend ::result "b::b $this $p $args" - set ($this,n) [lindex $args 0] - } - proc b::~b {this} { - lappend ::result "b::~b $this" - } - new b {x y} {1 2} 3 - eval lappend ::result [dumpArrays a:: b::] - - class A { - proc A {this p args} { - lappend ::result "A::A $this $p $args" - set ($this,m) [lindex $args 0] - } - proc ~A {this} { - lappend ::result "A::~A $this" - } - } - class B { - proc B {this p args} A {$p [concat $args]} { - lappend ::result "B::B $this $p $args" - set ($this,n) [lindex $args 0] - } - proc ~B {this} { - lappend ::result "B::~B $this" - } - } - new B {x y} {1 2} 3 - eval lappend ::result [dumpArrays A:: B::] - - class c {} - class c::d {} - proc c::d::d {this p args} { - lappend ::result "d::d $this $p $args" - set ($this,m) [lindex $args 0] - } - proc c::d::~d {this} { - lappend ::result "d::~d $this" - } - class c::e {} - proc c::e::e {this p args} c::d {$p [concat $args]} { - lappend ::result "e::e $this $p $args" - set ($this,n) [lindex $args 0] - } - proc c::e::~e {this} { - lappend ::result "e::~e $this" - } - new c::e {x y} {1 2} 3 - eval lappend ::result [dumpArrays c::d:: c::e::] - - class C { - class D { - proc D {this p args} { - lappend ::result "D::D $this $p $args" - set ($this,m) [lindex $args 0] - } - proc ~D {this} { - lappend ::result "D::~D $this" - } - } - class E { - proc E {this p args} C::D {$p [concat $args]} { - lappend ::result "E::E $this $p $args" - set ($this,n) [lindex $args 0] - } - proc ~E {this} { - lappend ::result "E::~E $this" - } - } - new E {x y} {1 2} 3 - eval lappend ::result [dumpArrays D:: E::] - } - new C::E {x y} {1 2} 3 - eval lappend ::result [dumpArrays C::D:: C::E::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1 x y {1 2} 3}\ - {b::b 1 x y {1 2} 3}\ - {a::(1,_derived) = ::b}\ - {a::(1,m) = 1 2}\ - {b::(1,n) = 1 2}\ - {A::A 2 x y {1 2} 3}\ - {B::B 2 x y {1 2} 3}\ - {A::(2,_derived) = ::B}\ - {A::(2,m) = 1 2}\ - {B::(2,n) = 1 2}\ - {d::d 3 x y {1 2} 3}\ - {e::e 3 x y {1 2} 3}\ - {c::d::(3,_derived) = ::c::e}\ - {c::d::(3,m) = 1 2}\ - {c::e::(3,n) = 1 2}\ - {D::D 4 x y {1 2} 3}\ - {E::E 4 x y {1 2} 3}\ - {D::(4,_derived) = ::C::E}\ - {D::(4,m) = 1 2}\ - {E::(4,n) = 1 2}\ - {D::D 5 x y {1 2} 3}\ - {E::E 5 x y {1 2} 3}\ - {C::D::(4,_derived) = ::C::E}\ - {C::D::(4,m) = 1 2}\ - {C::D::(5,_derived) = ::C::E}\ - {C::D::(5,m) = 1 2}\ - {C::E::(4,n) = 1 2}\ - {C::E::(5,n) = 1 2}\ -] - -test stooop-56 { - check that procedure invocation on variable arguments in derived class base - class constructor arguments works -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this args} { - lappend ::result "a::a $this $args" - set ($this,m) [lindex $args 0] - } - proc a::~a {this} { - lappend ::result "a::~a $this" - } - class b {} - proc b::b {this args} a {[concat $args]} { - lappend ::result "b::b $this $args" - set ($this,n) [lindex $args 0] - } - proc b::~b {this} { - lappend ::result "b::~b $this" - } - new b {1 2} 3 - eval lappend ::result [dumpArrays a:: b::] - - class A { - proc A {this args} { - lappend ::result "A::A $this $args" - set ($this,m) [lindex $args 0] - } - proc ~A {this} { - lappend ::result "A::~A $this" - } - } - class B { - proc B {this args} A {[concat $args]} { - lappend ::result "B::B $this $args" - set ($this,n) [lindex $args 0] - } - proc ~B {this} { - lappend ::result "B::~B $this" - } - } - new B {1 2} 3 - eval lappend ::result [dumpArrays A:: B::] - - class c {} - class c::d {} - proc c::d::d {this args} { - lappend ::result "d::d $this $args" - set ($this,m) [lindex $args 0] - } - proc c::d::~d {this} { - lappend ::result "d::~d $this" - } - class c::e {} - proc c::e::e {this args} c::d {[concat $args]} { - lappend ::result "e::e $this $args" - set ($this,n) [lindex $args 0] - } - proc c::e::~e {this} { - lappend ::result "e::~e $this" - } - new c::e {1 2} 3 - eval lappend ::result [dumpArrays c::d:: c::e::] - - class C { - class D { - proc D {this args} { - lappend ::result "D::D $this $args" - set ($this,m) [lindex $args 0] - } - proc ~D {this} { - lappend ::result "D::~D $this" - } - } - class E { - proc E {this args} C::D {[concat $args]} { - lappend ::result "E::E $this $args" - set ($this,n) [lindex $args 0] - } - proc ~E {this} { - lappend ::result "E::~E $this" - } - } - new E {1 2} 3 - eval lappend ::result [dumpArrays D:: E::] - } - new C::E {1 2} 3 - eval lappend ::result [dumpArrays C::D:: C::E::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1 {1 2} 3}\ - {b::b 1 {1 2} 3}\ - {a::(1,_derived) = ::b}\ - {a::(1,m) = 1 2}\ - {b::(1,n) = 1 2}\ - {A::A 2 {1 2} 3}\ - {B::B 2 {1 2} 3}\ - {A::(2,_derived) = ::B}\ - {A::(2,m) = 1 2}\ - {B::(2,n) = 1 2}\ - {d::d 3 {1 2} 3}\ - {e::e 3 {1 2} 3}\ - {c::d::(3,_derived) = ::c::e}\ - {c::d::(3,m) = 1 2}\ - {c::e::(3,n) = 1 2}\ - {D::D 4 {1 2} 3}\ - {E::E 4 {1 2} 3}\ - {D::(4,_derived) = ::C::E}\ - {D::(4,m) = 1 2}\ - {E::(4,n) = 1 2}\ - {D::D 5 {1 2} 3}\ - {E::E 5 {1 2} 3}\ - {C::D::(4,_derived) = ::C::E}\ - {C::D::(4,m) = 1 2}\ - {C::D::(5,_derived) = ::C::E}\ - {C::D::(5,m) = 1 2}\ - {C::E::(4,n) = 1 2}\ - {C::E::(5,n) = 1 2}\ -] - -test stooop-57 { - check that variable arguments in derived class work with base class - constructor constant arguments -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this p} { - lappend ::result "a::a $this $p" - set ($this,m) $p - } - proc a::~a {this} {} - class b {} - proc b::b {this p args} a {$args} { - lappend ::result "b::b $this $p $args" - } - proc b::~b {this} {} - new b {x y} {1 2} 3 - eval lappend ::result [dumpArrays a::] - - class A { - proc A {this p} { - lappend ::result "A::A $this $p" - set ($this,m) $p - } - proc ~A {this} {} - } - class B { - proc B {this p args} A {$args} { - lappend ::result "B::B $this $p $args" - } - proc ~B {this} {} - } - new B {x y} {1 2} 3 - eval lappend ::result [dumpArrays A::] - - class c {} - class c::d {} - proc c::d::d {this p} { - lappend ::result "d::d $this $p" - set ($this,m) $p - } - proc c::d::~d {this} {} - class c::e {} - proc c::e::e {this p args} c::d {$args} { - lappend ::result "e::e $this $p $args" - } - proc c::e::~e {this} {} - new c::e {x y} {1 2} 3 - eval lappend ::result [dumpArrays c::d::] - - class C { - class D { - proc D {this p} { - lappend ::result "D::D $this $p" - set ($this,m) $p - } - proc ~D {this} {} - } - class E { - proc E {this p args} C::D {$args} { - lappend ::result "E::E $this $p $args" - } - proc ~E {this} {} - } - new E {x y} {1 2} 3 - eval lappend ::result [dumpArrays D::] - } - new C::E {x y} {1 2} 3 - eval lappend ::result [dumpArrays C::D::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1 {1 2} 3}\ - {b::b 1 x y {1 2} 3}\ - {a::(1,_derived) = ::b}\ - {a::(1,m) = {1 2} 3}\ - {A::A 2 {1 2} 3}\ - {B::B 2 x y {1 2} 3}\ - {A::(2,_derived) = ::B}\ - {A::(2,m) = {1 2} 3}\ - {d::d 3 {1 2} 3}\ - {e::e 3 x y {1 2} 3}\ - {c::d::(3,_derived) = ::c::e}\ - {c::d::(3,m) = {1 2} 3}\ - {D::D 4 {1 2} 3}\ - {E::E 4 x y {1 2} 3}\ - {D::(4,_derived) = ::C::E}\ - {D::(4,m) = {1 2} 3}\ - {D::D 5 {1 2} 3}\ - {E::E 5 x y {1 2} 3}\ - {C::D::(4,_derived) = ::C::E}\ - {C::D::(4,m) = {1 2} 3}\ - {C::D::(5,_derived) = ::C::E}\ - {C::D::(5,m) = {1 2} 3}\ -] - -test stooop-58 { - check that variable arguments in derived class work with base class - constructor constant arguments -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this p args} { - lappend ::result "a::a $this $p $args" - set ($this,m) [lindex $args 0] - } - proc a::~a {this} {} - class b {} - proc b::b {this p args} a {$p z} { - lappend ::result "b::b $this $p $args" - set ($this,n) [lindex $args 0] - } - proc b::~b {this} {} - new b {x y} {1 2} 3 - eval lappend ::result [dumpArrays a::] - - class A { - proc A {this p args} { - lappend ::result "A::A $this $p $args" - set ($this,m) [lindex $args 0] - } - proc ~A {this} {} - } - class B { - proc B {this p args} A {$p z} { - lappend ::result "B::B $this $p $args" - set ($this,n) [lindex $args 0] - } - proc ~B {this} {} - } - new B {x y} {1 2} 3 - eval lappend ::result [dumpArrays A::] - - class c {} - class c::d {} - proc c::d::d {this p args} { - lappend ::result "d::d $this $p $args" - set ($this,m) [lindex $args 0] - } - proc c::d::~d {this} {} - class c::e {} - proc c::e::e {this p args} c::d {$p z} { - lappend ::result "e::e $this $p $args" - set ($this,n) [lindex $args 0] - } - proc c::e::~e {this} {} - new c::e {x y} {1 2} 3 - eval lappend ::result [dumpArrays c::d::] - - class C { - class D { - proc D {this p args} { - lappend ::result "D::D $this $p $args" - set ($this,m) [lindex $args 0] - } - proc ~D {this} {} - } - class E { - proc E {this p args} C::D {$p z} { - lappend ::result "E::E $this $p $args" - set ($this,n) [lindex $args 0] - } - proc ~E {this} {} - } - new E {x y} {1 2} 3 - eval lappend ::result [dumpArrays D::] - } - new C::E {x y} {1 2} 3 - eval lappend ::result [dumpArrays C::D::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1 x y z}\ - {b::b 1 x y {1 2} 3}\ - {a::(1,_derived) = ::b}\ - {a::(1,m) = z}\ - {A::A 2 x y z}\ - {B::B 2 x y {1 2} 3}\ - {A::(2,_derived) = ::B}\ - {A::(2,m) = z}\ - {d::d 3 x y z}\ - {e::e 3 x y {1 2} 3}\ - {c::d::(3,_derived) = ::c::e}\ - {c::d::(3,m) = z}\ - {D::D 4 x y z}\ - {E::E 4 x y {1 2} 3}\ - {D::(4,_derived) = ::C::E}\ - {D::(4,m) = z}\ - {D::D 5 x y z}\ - {E::E 5 x y {1 2} 3}\ - {C::D::(4,_derived) = ::C::E}\ - {C::D::(4,m) = z}\ - {C::D::(5,_derived) = ::C::E}\ - {C::D::(5,m) = z}\ -] - -test stooop-59 { - check that construction, copy and deletion work transparently for variable - context -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this p} { - upvar $p q - eval lappend ::result [dumpArrays q] - } - proc a::a {this copy} { - upvar d q - eval lappend ::result [dumpArrays q] - } - proc a::~a {this} { - upvar d q - eval lappend ::result [dumpArrays q] - } - set d(0) 0 - set o [new a d] - new $o - delete $o - - class A { - proc A {this p} { - upvar $p q - eval lappend ::result [dumpArrays q] - } - proc A {this copy} { - upvar d q - eval lappend ::result [dumpArrays q] - } - proc ~A {this} { - upvar d q - eval lappend ::result [dumpArrays q] - } - } - set d(0) 1 - set o [new A d] - new $o - delete $o - - class b {} - class b::c {} - proc b::c::c {this p} { - upvar $p q - eval lappend ::result [dumpArrays q] - } - proc b::c::c {this copy} { - upvar d q - eval lappend ::result [dumpArrays q] - } - proc b::c::~c {this} { - upvar d q - eval lappend ::result [dumpArrays q] - } - set d(0) 2 - set o [new b::c d] - new $o - delete $o - - class B { - class C { - proc C {this p} { - upvar $p q - eval lappend ::result [dumpArrays q] - } - proc C {this copy} { - upvar d q - eval lappend ::result [dumpArrays q] - } - proc ~C {this} { - upvar d q - eval lappend ::result [dumpArrays q] - } - } - set d(0) 3 - set o [new C d] - new $o - delete $o - } - set d(0) 4 - set o [new B::C d] - new $o - delete $o - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {q(0) = 0}\ - {q(0) = 0}\ - {q(0) = 0}\ - {q(0) = 1}\ - {q(0) = 1}\ - {q(0) = 1}\ - {q(0) = 2}\ - {q(0) = 2}\ - {q(0) = 2}\ - {q(0) = 3}\ - {q(0) = 3}\ - {q(0) = 3}\ - {q(0) = 4}\ - {q(0) = 4}\ - {q(0) = 4}\ -] - -test stooop-60 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - catch { - class a {} - proc a::a::p {this} {} - } message - lappend ::result $message - - catch { - class A { - proc A::p {this} {} - } - } message - lappend ::result $message - - catch { - class b {} - class b::c {} - proc b::c::c::p {this} {} - } message - lappend ::result $message - - catch { - class B { - class C { - proc C::p {this} {} - } - } - } message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {can't create procedure "a::a::p": unknown namespace}\ - {can't create procedure "A::p": unknown namespace}\ - {can't create procedure "b::c::c::p": unknown namespace}\ - {can't create procedure "C::p": unknown namespace}\ -] - -test stooop-61 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - catch {new 1} ::result - set ::result - }] - interp delete $interpreter - set result -} {invalid object identifier 1} - -test stooop-62 { - check that multiple class definitions for the same class are possible -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a { - proc a {this} {} - proc ~a {this} {} - } - proc a::p {this p} { - set ($this,m) $p - } - class a { - proc q {this} { - lappend ::result $($this,m) - } - } - set o [new a] - a::p $o 0 - a::q $o - - class b { - class c { - proc c {this} {} - proc ~c {this} {} - } - proc c::p {this p} { - set ($this,m) $p - } - class c { - proc q {this} { - lappend ::result $($this,m) - } - } - set o [new c] - c::p $o 0 - c::q $o - } - set o [new b::c] - b::c::p $o 0 - b::c::q $o - - set ::result - }] - interp delete $interpreter - set result -} [list\ - 0\ - 0\ - 0\ -] - -test stooop-63 { - check that non qualified procedure invocation in derived class base class - constructor arguments works -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - proc p {p} {error "::p invoked"} - - class a {} - proc a::a {this p} { - set ($this,m) $p - } - proc a::~a {this} {} - class b {} - proc b::b {this p} a {[p $p]} { - set ($this,n) $p - } - proc b::~b {this} {} - proc b::p {p} { - return [incr p] - } - new b 0 - eval lappend ::result [dumpArrays a:: b::] - - class A { - proc A {this p} { - set ($this,m) $p - } - proc ~A {this} {} - } - class B { - proc B {this p} A {[p $p]} { - set ($this,n) $p - } - proc ~B {this} {} - proc p {p} { - return [incr p] - } - } - new B 0 - eval lappend ::result [dumpArrays A:: B::] - - class c {} - class c::d {} - proc c::d::d {this p} { - set ($this,m) $p - } - proc c::d::~d {this} {} - class c::e {} - proc c::e::e {this p} c::d {[p $p]} { - set ($this,n) $p - } - proc c::e::~e {this} {} - proc c::e::p {p} { - return [incr p] - } - new c::e 0 - eval lappend ::result [dumpArrays c::d:: c::e::] - - class C { - class D { - proc D {this p} { - set ($this,m) $p - } - proc ~D {this} {} - } - class E { - proc E {this p} C::D {[p $p]} { - set ($this,n) $p - } - proc ~E {this} {} - proc p {p} { - return [incr p] - } - } - new E 0 - eval lappend ::result [dumpArrays D:: E::] - } - new C::E 0 - eval lappend ::result [dumpArrays C::D:: C::E::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::(1,_derived) = ::b}\ - {a::(1,m) = 1}\ - {b::(1,n) = 0}\ - {A::(2,_derived) = ::B}\ - {A::(2,m) = 1}\ - {B::(2,n) = 0}\ - {c::d::(3,_derived) = ::c::e}\ - {c::d::(3,m) = 1}\ - {c::e::(3,n) = 0}\ - {D::(4,_derived) = ::C::E}\ - {D::(4,m) = 1}\ - {E::(4,n) = 0}\ - {C::D::(4,_derived) = ::C::E}\ - {C::D::(4,m) = 1}\ - {C::D::(5,_derived) = ::C::E}\ - {C::D::(5,m) = 1}\ - {C::E::(4,n) = 0}\ - {C::E::(5,n) = 0}\ -] - -test stooop-64 { - check static member initialization within class body -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a { - set (l) {} - } - proc a::a {this} { - lappend (l) $this - } - proc a::~a {this} {} - new a - new a - eval lappend ::result [dumpArrays a::] - - class A { - set A::(l) {} - proc A {this} { - lappend (l) $this - } - proc ~A {this} {} - } - new A - new A - eval lappend ::result [dumpArrays A::] - - class b {} - class b::c { - set (l) {} - } - proc b::c::c {this} { - lappend (l) $this - } - proc b::c::~c {this} {} - new b::c - new b::c - eval lappend ::result [dumpArrays b::c::] - - class B { - class C { - set (l) {} - proc C {this} { - lappend (l) $this - } - proc ~C {this} {} - } - new C - new C - eval lappend ::result [dumpArrays C::] - } - new B::C - new B::C - eval lappend ::result [dumpArrays B::C::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::(l) = 1 2}\ - {A::(l) = 3 4}\ - {b::c::(l) = 5 6}\ - {C::(l) = 7 8}\ - {B::C::(l) = 7 8 9 10}\ -] - -test stooop-65 { - undocumented -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - catch { - class a {} - proc a::a {this} {} - virtual proc a::a::p {this} {} - } message - lappend ::result $message - - catch { - class A { - proc A {this} {} - virtual proc A::p {this} {} - } - } message - lappend ::result $message - - catch { - class b {} - class b::c {} - proc b::c::c {this} {} - virtual proc b::c::c::p {this} {} - } message - lappend ::result $message - - catch { - class B { - class C { - proc C {this} {} - virtual proc C::p {this} {} - } - } - } message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {procedure ::a::a::p class ::a::a is unknown}\ - {procedure ::A::A::p class ::A::A is unknown}\ - {procedure ::b::c::c::p class ::b::c::c is unknown}\ - {procedure ::B::C::C::p class ::B::C::C is unknown}\ -] - -test stooop-66 { - check that nested class procedure definition works inside and outside - nested class or namespace -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a { - class b { - proc b {this} {} - proc p {this} { - lappend ::result 1 - } - } - set o [new b] - b::p $o - proc b::p {this} { - lappend ::result 2 - } - b::p $o - } - - namespace eval c { - class b { - proc b {this} {} - proc p {this} { - lappend ::result 3 - } - } - set o [new b] - b::p $o - proc b::p {this} { - lappend ::result 4 - } - b::p $o - } - - set o [new a::b] - proc a::b::p {this} { - lappend ::result 5 - } - a::b::p $o - - set o [new c::b] - proc c::b::p {this} { - lappend ::result 6 - } - c::b::p $o - - set ::result - }] - interp delete $interpreter - set result -} [list\ - 1\ - 2\ - 3\ - 4\ - 5\ - 6\ -] - -test stooop-67 { - check that nested class procedure definition works inside a separate - namespace and is free from interferences -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a { - proc a {this} {} - proc p {this} { - lappend ::result 1 - } - } - set o [new a] - a::p $o - - namespace eval b { - namespace eval a {} - proc a::p {this} { - lappend ::result 2 - } - } - a::p $o - - namespace eval c { - proc ::a::p {this} { - lappend ::result 3 - } - } - a::p $o - - namespace eval d { - class a { - proc a {this} {} - proc p {this} { - lappend ::result 4 - } - } - set o [new a] - a::p $o - - namespace eval b { - namespace eval a {} - proc a::p {this} { - lappend ::result 5 - } - } - a::p $o - - namespace eval c { - proc ::d::a::p {this} { - lappend ::result 6 - } - } - a::p $o - } - - class e { - proc e {this} {} - class a { - proc a {this} {} - proc p {this} { - lappend ::result 7 - } - } - set o [new a] - a::p $o - - namespace eval b { - namespace eval a {} - proc a::p {this} { - lappend ::result 8 - } - } - a::p $o - - namespace eval c { - proc ::e::a::p {this} { - lappend ::result 9 - } - } - a::p $o - } - - set ::result - }] - interp delete $interpreter - set result -} [list\ - 1\ - 1\ - 3\ - 4\ - 4\ - 6\ - 7\ - 7\ - 9\ -] - -test stooop-68 { - check inheritance within a deep nested class hierarchy -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a { - proc a {this} { - lappend ::result a::a - } - class b { - proc b {this} a {} { - lappend ::result b::b - } - class c { - catch { - proc c {this} b {} {} - } message - lappend ::result $message - proc c {this} a::b {} { - lappend ::result c::c - } - } - new c - } - } - - namespace eval d { - proc d {this} { - lappend ::result d::d - } - namespace eval e { - proc e {this} { - d::d $this - lappend ::result e::e - } - namespace eval f { - proc f {this} { - catch { - e::e $this - } message - lappend ::result $message - d::e::e $this - lappend ::result f::f - } - } - f::f 0 - } - } - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {class ::a::b::c constructor defined before base class b constructor}\ - {a::a}\ - {b::b}\ - {c::c}\ - {invalid command name "e::e"}\ - {d::d}\ - {e::e}\ - {f::f}\ -] - -test stooop-69 { - check user defined cloning operation in nested class context -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this} {} - class a::b {} - proc a::b::b {this} { - set ($this,x) 0 - } - proc a::b::b {this copy} { - set ($this,x) [expr $($copy,x)+1] - } - new [new a::b] - eval lappend ::result [dumpArrays a::b::] - - class A { - proc A {this} {} - class B { - proc B {this} { - set ($this,x) 0 - } - proc B {this copy} { - set ($this,x) [expr $($copy,x)+1] - } - } - new [new B] - eval lappend ::result [dumpArrays B::] - } - new [new A::B] - eval lappend ::result [dumpArrays A::B::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::b::(1,x) = 0}\ - {a::b::(2,x) = 1}\ - {B::(3,x) = 0}\ - {B::(4,x) = 1}\ - {A::B::(3,x) = 0}\ - {A::B::(4,x) = 1}\ - {A::B::(5,x) = 0}\ - {A::B::(6,x) = 1}\ -] - -test stooop-70 { - check basic cloning operation in nested class context -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this} {} - class a::b {} - proc a::b::b {this} { - set ($this,x) 0 - } - new [new a::b] - eval lappend ::result [dumpArrays a::b::] - - class A { - proc A {this} {} - class B { - proc B {this} { - set ($this,x) 0 - } - } - new [new B] - eval lappend ::result [dumpArrays B::] - } - new [new A::B] - eval lappend ::result [dumpArrays A::B::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::b::(1,x) = 0}\ - {a::b::(2,x) = 0}\ - {B::(3,x) = 0}\ - {B::(4,x) = 0}\ - {A::B::(3,x) = 0}\ - {A::B::(4,x) = 0}\ - {A::B::(5,x) = 0}\ - {A::B::(6,x) = 0}\ -] - -test stooop-71 { - check multiple inheritance construction order, destruction order and data - deallocation with a common indirect base class -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class z {} - class z::a {} - proc z::a::a {this p} { - lappend ::result "a::a $this" - set ($this,m) $p - } - proc z::a::~a {this} { - lappend ::result "a::~a $this" - } - class z::b {} - proc z::b::b {this p} { - lappend ::result "b::b $this" - set ($this,n) $p - } - proc z::b::~b {this} { - lappend ::result "b::~b $this" - } - class z::c {} - proc z::c::c {this p q r} z::a {$p} z::b {$q} { - lappend ::result "c::c $this" - set ($this,o) $r - } - proc z::c::~c {this} { - lappend ::result "c::~c $this" - } - class z::d {} - proc z::d::d {this p q r} z::a {$p} z::b {$q} { - lappend ::result "d::d $this" - set ($this,p) $p - } - proc z::d::~d {this} { - lappend ::result "d::~d $this" - } - class z::e {} - proc z::e::e {this p q r} z::c {$p $q $r} z::d {$q $q $r} { - lappend ::result "e::e $this" - set ($this,q) $q - } - proc z::e::~e {this} { - lappend ::result "e::~e $this" - } - set o [new z::e {x y} z {1 2}] - eval lappend ::result [dumpArrays z::a:: z::b:: z::c:: z::d:: z::e::] - delete $o - eval lappend ::result [dumpArrays z::a:: z::b:: z::c:: z::d:: z::e::] - - class Z { - class A { - proc A {this p} { - lappend ::result "A::A $this" - set ($this,m) $p - } - proc ~A {this} { - lappend ::result "A::~A $this" - } - } - class B { - proc B {this p} { - lappend ::result "B::B $this" - set ($this,n) $p - } - proc ~B {this} { - lappend ::result "B::~B $this" - } - } - class C { - proc C {this p q r} Z::A {$p} Z::B {$q} { - lappend ::result "C::C $this" - set ($this,o) $r - } - proc ~C {this} { - lappend ::result "C::~C $this" - } - } - class D { - proc D {this p q r} Z::A {$p} Z::B {$q} { - lappend ::result "D::D $this" - set ($this,p) $p - } - proc ~D {this} { - lappend ::result "D::~D $this" - } - } - class E { - proc E {this p q r} Z::C {$p $q $r} Z::D {$q $q $r} { - lappend ::result "E::E $this" - set ($this,q) $q - } - proc ~E {this} { - lappend ::result "E::~E $this" - } - } - set o [new E {x y} z {1 2}] - eval lappend ::result [dumpArrays A:: B:: C:: D:: E::] - delete $o - eval lappend ::result [dumpArrays A:: B:: C:: D:: E::] - } - set o [new Z::E {x y} z {1 2}] - eval lappend ::result [dumpArrays Z::A:: Z::B:: Z::C:: Z::D:: Z::E::] - delete $o - eval lappend ::result [dumpArrays Z::A:: Z::B:: Z::C:: Z::D:: Z::E::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1}\ - {b::b 1}\ - {c::c 1}\ - {a::a 1}\ - {b::b 1}\ - {d::d 1}\ - {e::e 1}\ - {z::a::(1,_derived) = ::z::d}\ - {z::a::(1,m) = z}\ - {z::b::(1,_derived) = ::z::d}\ - {z::b::(1,n) = z}\ - {z::c::(1,_derived) = ::z::e}\ - {z::c::(1,o) = 1 2}\ - {z::d::(1,_derived) = ::z::e}\ - {z::d::(1,p) = z}\ - {z::e::(1,q) = z}\ - {e::~e 1}\ - {d::~d 1}\ - {b::~b 1}\ - {a::~a 1}\ - {c::~c 1}\ - {b::~b 1}\ - {a::~a 1}\ - {A::A 2}\ - {B::B 2}\ - {C::C 2}\ - {A::A 2}\ - {B::B 2}\ - {D::D 2}\ - {E::E 2}\ - {A::(2,_derived) = ::Z::D}\ - {A::(2,m) = z}\ - {B::(2,_derived) = ::Z::D}\ - {B::(2,n) = z}\ - {C::(2,_derived) = ::Z::E}\ - {C::(2,o) = 1 2}\ - {D::(2,_derived) = ::Z::E}\ - {D::(2,p) = z}\ - {E::(2,q) = z}\ - {E::~E 2}\ - {D::~D 2}\ - {B::~B 2}\ - {A::~A 2}\ - {C::~C 2}\ - {B::~B 2}\ - {A::~A 2}\ - {A::A 3}\ - {B::B 3}\ - {C::C 3}\ - {A::A 3}\ - {B::B 3}\ - {D::D 3}\ - {E::E 3}\ - {Z::A::(3,_derived) = ::Z::D}\ - {Z::A::(3,m) = z}\ - {Z::B::(3,_derived) = ::Z::D}\ - {Z::B::(3,n) = z}\ - {Z::C::(3,_derived) = ::Z::E}\ - {Z::C::(3,o) = 1 2}\ - {Z::D::(3,_derived) = ::Z::E}\ - {Z::D::(3,p) = z}\ - {Z::E::(3,q) = z}\ - {E::~E 3}\ - {D::~D 3}\ - {B::~B 3}\ - {A::~A 3}\ - {C::~C 3}\ - {B::~B 3}\ - {A::~A 3}\ -] - -test stooop-72 { - check that multiply inherited base classes constructors work with variable - number of arguments -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class z {} - class z::a {} - proc z::a::a {this args} { - lappend ::result "a::a $this $args" - set ($this,m) [lindex $args 0] - } - class z::b {} - proc z::b::b {this p} { - lappend ::result "b::b $this $p" - set ($this,n) $p - } - class z::c {} - proc z::c::c {this p args} { - lappend ::result "c::c $this $p $args" - set ($this,o) $p - set ($this,p) [lindex $args 0] - } - class z::d {} - proc z::d::d {this p args} z::a {$args} z::b {$p} z::c {$p $args} { - lappend ::result "d::d $this $p $args" - set ($this,q) $p - set ($this,r) [lindex $args 0] - } - new z::d {x y} {1 2} 3 - eval lappend ::result [dumpArrays z::a:: z::b:: z::c:: z::d::] - - class Z { - class A { - proc A {this args} { - lappend ::result "A::A $this $args" - set ($this,m) [lindex $args 0] - } - } - class B { - proc B {this p} { - lappend ::result "B::B $this $p" - set ($this,n) $p - } - } - class C { - proc C {this p args} { - lappend ::result "C::C $this $p $args" - set ($this,o) $p - set ($this,p) [lindex $args 0] - } - } - class D { - proc D {this p args} Z::A {$args} Z::B {$p} Z::C {$p $args} { - lappend ::result "D::D $this $p $args" - set ($this,q) $p - set ($this,r) [lindex $args 0] - } - } - new D {x y} {1 2} 3 - eval lappend ::result [dumpArrays A:: B:: C:: D::] - } - new Z::D {x y} {1 2} 3 - eval lappend ::result [dumpArrays Z::A:: Z::B:: Z::C:: Z::D::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1 {1 2} 3}\ - {b::b 1 x y}\ - {c::c 1 x y {1 2} 3}\ - {d::d 1 x y {1 2} 3}\ - {z::a::(1,_derived) = ::z::d}\ - {z::a::(1,m) = 1 2}\ - {z::b::(1,_derived) = ::z::d}\ - {z::b::(1,n) = x y}\ - {z::c::(1,_derived) = ::z::d}\ - {z::c::(1,o) = x y}\ - {z::c::(1,p) = 1 2}\ - {z::d::(1,q) = x y}\ - {z::d::(1,r) = 1 2}\ - {A::A 2 {1 2} 3}\ - {B::B 2 x y}\ - {C::C 2 x y {1 2} 3}\ - {D::D 2 x y {1 2} 3}\ - {A::(2,_derived) = ::Z::D}\ - {A::(2,m) = 1 2}\ - {B::(2,_derived) = ::Z::D}\ - {B::(2,n) = x y}\ - {C::(2,_derived) = ::Z::D}\ - {C::(2,o) = x y}\ - {C::(2,p) = 1 2}\ - {D::(2,q) = x y}\ - {D::(2,r) = 1 2}\ - {A::A 3 {1 2} 3}\ - {B::B 3 x y}\ - {C::C 3 x y {1 2} 3}\ - {D::D 3 x y {1 2} 3}\ - {Z::A::(2,_derived) = ::Z::D}\ - {Z::A::(2,m) = 1 2}\ - {Z::A::(3,_derived) = ::Z::D}\ - {Z::A::(3,m) = 1 2}\ - {Z::B::(2,_derived) = ::Z::D}\ - {Z::B::(2,n) = x y}\ - {Z::B::(3,_derived) = ::Z::D}\ - {Z::B::(3,n) = x y}\ - {Z::C::(2,_derived) = ::Z::D}\ - {Z::C::(2,o) = x y}\ - {Z::C::(2,p) = 1 2}\ - {Z::C::(3,_derived) = ::Z::D}\ - {Z::C::(3,o) = x y}\ - {Z::C::(3,p) = 1 2}\ - {Z::D::(2,q) = x y}\ - {Z::D::(2,r) = 1 2}\ - {Z::D::(3,q) = x y}\ - {Z::D::(3,r) = 1 2}\ -] - -test stooop-73 { - check multiple inheritance destruction order and data deallocation with a - common indirect base class -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class z {} - class z::a {} - proc z::a::a {this p} { - lappend ::result "a::a $this" - set ($this,m) $p - } - proc z::a::~a {this} { - lappend ::result "a::~a $this" - } - class z::b {} - proc z::b::b {this p} { - lappend ::result "b::b $this" - set ($this,n) $p - } - proc z::b::~b {this} { - lappend ::result "b::~b $this" - } - class z::c {} - proc z::c::c {this p q r} z::a {$p} z::b {$q} { - lappend ::result "c::c $this" - set ($this,o) $r - } - proc z::c::~c {this} { - lappend ::result "c::~c $this" - } - class z::d {} - proc z::d::d {this p q r} z::a {$p} z::b {$q} { - lappend ::result "d::d $this" - set ($this,p) $p - } - proc z::d::~d {this} { - lappend ::result "d::~d $this" - } - class z::e {} - proc z::e::e {this p q r} z::c {$p $q $r} z::d {$q $q $r} { - lappend ::result "e::e $this" - set ($this,q) $q - } - proc z::e::~e {this} { - lappend ::result "e::~e $this" - } - set o [new z::e {x y} z {1 2}] - eval lappend ::result [dumpArrays z::a:: z::b:: z::c:: z::d:: z::e::] - delete $o - eval lappend ::result [dumpArrays z::a:: z::b:: z::c:: z::d:: z::e::] - - class Z { - class A { - proc A {this p} { - lappend ::result "A::A $this" - set ($this,m) $p - } - proc ~A {this} { - lappend ::result "A::~A $this" - } - } - class B { - proc B {this p} { - lappend ::result "B::B $this" - set ($this,n) $p - } - proc ~B {this} { - lappend ::result "B::~B $this" - } - } - class C { - proc C {this p q r} Z::A {$p} Z::B {$q} { - lappend ::result "C::C $this" - set ($this,o) $r - } - proc ~C {this} { - lappend ::result "C::~C $this" - } - } - class D { - proc D {this p q r} Z::A {$p} Z::B {$q} { - lappend ::result "D::D $this" - set ($this,p) $p - } - proc ~D {this} { - lappend ::result "D::~D $this" - } - } - class E { - proc E {this p q r} Z::C {$p $q $r} Z::D {$q $q $r} { - lappend ::result "E::E $this" - set ($this,q) $q - } - proc ~E {this} { - lappend ::result "E::~E $this" - } - } - set o [new E {x y} z {1 2}] - eval lappend ::result [dumpArrays A:: B:: C:: D:: E::] - delete $o - eval lappend ::result [dumpArrays A:: B:: C:: D:: E::] - } - set o [new Z::E {x y} z {1 2}] - eval lappend ::result [dumpArrays Z::A:: Z::B:: Z::C:: Z::D:: Z::E::] - delete $o - eval lappend ::result [dumpArrays Z::A:: Z::B:: Z::C:: Z::D:: Z::E::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1}\ - {b::b 1}\ - {c::c 1}\ - {a::a 1}\ - {b::b 1}\ - {d::d 1}\ - {e::e 1}\ - {z::a::(1,_derived) = ::z::d}\ - {z::a::(1,m) = z}\ - {z::b::(1,_derived) = ::z::d}\ - {z::b::(1,n) = z}\ - {z::c::(1,_derived) = ::z::e}\ - {z::c::(1,o) = 1 2}\ - {z::d::(1,_derived) = ::z::e}\ - {z::d::(1,p) = z}\ - {z::e::(1,q) = z}\ - {e::~e 1}\ - {d::~d 1}\ - {b::~b 1}\ - {a::~a 1}\ - {c::~c 1}\ - {b::~b 1}\ - {a::~a 1}\ - {A::A 2}\ - {B::B 2}\ - {C::C 2}\ - {A::A 2}\ - {B::B 2}\ - {D::D 2}\ - {E::E 2}\ - {A::(2,_derived) = ::Z::D}\ - {A::(2,m) = z}\ - {B::(2,_derived) = ::Z::D}\ - {B::(2,n) = z}\ - {C::(2,_derived) = ::Z::E}\ - {C::(2,o) = 1 2}\ - {D::(2,_derived) = ::Z::E}\ - {D::(2,p) = z}\ - {E::(2,q) = z}\ - {E::~E 2}\ - {D::~D 2}\ - {B::~B 2}\ - {A::~A 2}\ - {C::~C 2}\ - {B::~B 2}\ - {A::~A 2}\ - {A::A 3}\ - {B::B 3}\ - {C::C 3}\ - {A::A 3}\ - {B::B 3}\ - {D::D 3}\ - {E::E 3}\ - {Z::A::(3,_derived) = ::Z::D}\ - {Z::A::(3,m) = z}\ - {Z::B::(3,_derived) = ::Z::D}\ - {Z::B::(3,n) = z}\ - {Z::C::(3,_derived) = ::Z::E}\ - {Z::C::(3,o) = 1 2}\ - {Z::D::(3,_derived) = ::Z::E}\ - {Z::D::(3,p) = z}\ - {Z::E::(3,q) = z}\ - {E::~E 3}\ - {D::~D 3}\ - {B::~B 3}\ - {A::~A 3}\ - {C::~C 3}\ - {B::~B 3}\ - {A::~A 3}\ -] - -test stooop-74 { - check that optional arguments in constructors and multiple inheritance work - together -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class z {} - class z::a {} - proc z::a::a {this {p 0}} { - lappend ::result "a::a $this" - set ($this,m) $p - } - proc z::a::~a {this} { - lappend ::result "a::~a $this" - } - class z::b {} - proc z::b::b {this {p 1}} { - lappend ::result "b::b $this" - set ($this,n) $p - } - proc z::b::~b {this} { - lappend ::result "b::~b $this" - } - class z::c {} - proc z::c::c {this {p 2} {q 3}} z::a {$p} z::b {$q} { - lappend ::result "c::c $this" - set ($this,o) $p - set ($this,p) $q - } - proc z::c::~c {this} { - lappend ::result "c::~c $this" - } - set o [new z::c {x y} z] - eval lappend ::result [dumpArrays z::a:: z::b:: z::c::] - delete $o - set o [new z::c] - eval lappend ::result [dumpArrays z::a:: z::b:: z::c::] - - class Z { - class A { - proc A {this {p 0}} { - lappend ::result "A::A $this" - set ($this,m) $p - } - proc ~A {this} { - lappend ::result "A::~A $this" - } - } - class B { - proc B {this {p 1}} { - lappend ::result "B::B $this" - set ($this,n) $p - } - proc ~B {this} { - lappend ::result "B::~B $this" - } - } - class C { - proc C {this {p 2} {q 3}} Z::A {$p} Z::B {$q} { - lappend ::result "C::C $this" - set ($this,o) $p - set ($this,p) $q - } - proc ~C {this} { - lappend ::result "C::~C $this" - } - } - set o [new C {x y} z] - eval lappend ::result [dumpArrays A:: B:: C::] - delete $o - set o [new C] - eval lappend ::result [dumpArrays A:: B:: C::] - delete $o - } - set o [new Z::C {x y} z] - eval lappend ::result [dumpArrays Z::A:: Z::B:: Z::C::] - delete $o - set o [new Z::C] - eval lappend ::result [dumpArrays Z::A:: Z::B:: Z::C::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1}\ - {b::b 1}\ - {c::c 1}\ - {z::a::(1,_derived) = ::z::c}\ - {z::a::(1,m) = x y}\ - {z::b::(1,_derived) = ::z::c}\ - {z::b::(1,n) = z}\ - {z::c::(1,o) = x y}\ - {z::c::(1,p) = z}\ - {c::~c 1}\ - {b::~b 1}\ - {a::~a 1}\ - {a::a 2}\ - {b::b 2}\ - {c::c 2}\ - {z::a::(2,_derived) = ::z::c}\ - {z::a::(2,m) = 2}\ - {z::b::(2,_derived) = ::z::c}\ - {z::b::(2,n) = 3}\ - {z::c::(2,o) = 2}\ - {z::c::(2,p) = 3}\ - {A::A 3}\ - {B::B 3}\ - {C::C 3}\ - {A::(3,_derived) = ::Z::C}\ - {A::(3,m) = x y}\ - {B::(3,_derived) = ::Z::C}\ - {B::(3,n) = z}\ - {C::(3,o) = x y}\ - {C::(3,p) = z}\ - {C::~C 3}\ - {B::~B 3}\ - {A::~A 3}\ - {A::A 4}\ - {B::B 4}\ - {C::C 4}\ - {A::(4,_derived) = ::Z::C}\ - {A::(4,m) = 2}\ - {B::(4,_derived) = ::Z::C}\ - {B::(4,n) = 3}\ - {C::(4,o) = 2}\ - {C::(4,p) = 3}\ - {C::~C 4}\ - {B::~B 4}\ - {A::~A 4}\ - {A::A 5}\ - {B::B 5}\ - {C::C 5}\ - {Z::A::(5,_derived) = ::Z::C}\ - {Z::A::(5,m) = x y}\ - {Z::B::(5,_derived) = ::Z::C}\ - {Z::B::(5,n) = z}\ - {Z::C::(5,o) = x y}\ - {Z::C::(5,p) = z}\ - {C::~C 5}\ - {B::~B 5}\ - {A::~A 5}\ - {A::A 6}\ - {B::B 6}\ - {C::C 6}\ - {Z::A::(6,_derived) = ::Z::C}\ - {Z::A::(6,m) = 2}\ - {Z::B::(6,_derived) = ::Z::C}\ - {Z::B::(6,n) = 3}\ - {Z::C::(6,o) = 2}\ - {Z::C::(6,p) = 3}\ -] - -test stooop-75 { - check various virtual procedures configurations in a 3 level deep class - hierarchy -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class z {} - class z::a {} - proc z::a::a {this} {} - proc z::a::~a {this} {} - virtual proc z::a::f {this p q} {} - virtual proc z::a::g {this p q} - virtual proc z::a::h {this p q} { - lappend ::result "a::h $this $p $q" - } - virtual proc z::a::i {this p q} { - lappend ::result "a::i $this $p $q" - } - virtual proc z::a::k {this p q} - virtual proc z::a::l {this p q} { - lappend ::result "a::l $this $p $q" - } - class z::b {} - proc z::b::b {this} z::a {} {} - proc z::b::~b {this} {} - virtual proc z::b::f {this p q} { - lappend ::result "b::f $this $p $q" - } - virtual proc z::b::g {this p q} - virtual proc z::b::h {this p q} { - lappend ::result "b::h $this $p $q" - } - proc z::b::i {this p q} { - lappend ::result "b::i $this $p $q" - } - virtual proc z::b::k {this p q} { - lappend ::result "b::k $this $p $q" - } - virtual proc z::b::l {this p q} - class z::c {} - proc z::c::c {this} z::b {} {} - proc z::c::~c {this} {} - proc z::c::f {this p q} { - lappend ::result "c::f $this $p $q" - } - proc z::c::g {this p q} { - lappend ::result "c::g $this $p $q" - } - proc z::c::i {this p q} { - lappend ::result "c::i $this $p $q" - } - proc z::c::k {this p q} { - lappend ::result "c::k $this $p $q" - } - proc z::c::l {this p q} { - lappend ::result "c::l $this $p $q" - } - set o [new z::c] - z::a::f $o x {y z} - z::a::g $o x {y z} - z::a::h $o x {y z} - z::a::i $o x {y z} - z::a::k $o x {y z} - z::a::l $o x {y z} - - class Z { - class A { - proc A {this} {} - proc ~A {this} {} - virtual proc f {this p q} {} - virtual proc g {this p q} - virtual proc h {this p q} { - lappend ::result "A::h $this $p $q" - } - virtual proc i {this p q} { - lappend ::result "A::i $this $p $q" - } - virtual proc k {this p q} - virtual proc l {this p q} { - lappend ::result "A::l $this $p $q" - } - } - class B { - proc B {this} Z::A {} {} - proc ~B {this} {} - virtual proc f {this p q} { - lappend ::result "B::f $this $p $q" - } - virtual proc g {this p q} - virtual proc h {this p q} { - lappend ::result "B::h $this $p $q" - } - proc i {this p q} { - lappend ::result "B::i $this $p $q" - } - virtual proc k {this p q} { - lappend ::result "B::k $this $p $q" - } - virtual proc l {this p q} - } - class C { - proc C {this} Z::B {} {} - proc ~C {this} {} - proc f {this p q} { - lappend ::result "C::f $this $p $q" - } - proc g {this p q} { - lappend ::result "C::g $this $p $q" - } - proc i {this p q} { - lappend ::result "C::i $this $p $q" - } - proc k {this p q} { - lappend ::result "C::k $this $p $q" - } - proc l {this p q} { - lappend ::result "C::l $this $p $q" - } - } - set o [new C] - A::f $o x {y z} - A::g $o x {y z} - A::h $o x {y z} - A::i $o x {y z} - A::k $o x {y z} - A::l $o x {y z} - } - set o [new Z::C] - Z::A::f $o x {y z} - Z::A::g $o x {y z} - Z::A::h $o x {y z} - Z::A::i $o x {y z} - Z::A::k $o x {y z} - Z::A::l $o x {y z} - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {c::f 1 x y z}\ - {c::g 1 x y z}\ - {b::h 1 x y z}\ - {b::i 1 x y z}\ - {c::k 1 x y z}\ - {c::l 1 x y z}\ - {C::f 2 x y z}\ - {C::g 2 x y z}\ - {B::h 2 x y z}\ - {B::i 2 x y z}\ - {C::k 2 x y z}\ - {C::l 2 x y z}\ - {C::f 3 x y z}\ - {C::g 3 x y z}\ - {B::h 3 x y z}\ - {B::i 3 x y z}\ - {C::k 3 x y z}\ - {C::l 3 x y z}\ -] - -test stooop-76 { - check various virtual procedures with variable number of arguments - configurations in a 3 level deep class hierarchy -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class z {} - class z::a {} - proc z::a::a {this} {} - proc z::a::~a {this} {} - virtual proc z::a::f {this p args} {} - virtual proc z::a::g {this p args} - virtual proc z::a::h {this p args} { - lappend ::result "a::h $this $p $args" - } - virtual proc z::a::i {this p args} { - lappend ::result "a::i $this $p $args" - } - virtual proc z::a::k {this p args} - virtual proc z::a::l {this p args} { - lappend ::result "a::l $this $p $args" - } - class z::b {} - proc z::b::b {this} z::a {} {} - proc z::b::~b {this} {} - virtual proc z::b::f {this p args} { - lappend ::result "b::f $this $p $args" - } - virtual proc z::b::g {this p args} - virtual proc z::b::h {this p args} { - lappend ::result "b::h $this $p $args" - } - proc z::b::i {this p args} { - lappend ::result "b::i $this $p $args" - } - virtual proc z::b::k {this p args} { - lappend ::result "b::k $this $p $args" - } - virtual proc z::b::l {this p args} - class z::c {} - proc z::c::c {this} z::b {} {} - proc z::c::~c {this} {} - proc z::c::f {this p args} { - lappend ::result "c::f $this $p $args" - } - proc z::c::g {this p args} { - lappend ::result "c::g $this $p $args" - } - proc z::c::i {this p args} { - lappend ::result "c::i $this $p $args" - } - proc z::c::k {this p args} { - lappend ::result "c::k $this $p $args" - } - proc z::c::l {this p args} { - lappend ::result "c::l $this $p $args" - } - set o [new z::c] - z::a::f $o x {y z} - z::a::g $o x {y z} - z::a::h $o x {y z} - z::a::i $o x {y z} - z::a::k $o x {y z} - z::a::l $o x {y z} - - class Z { - class A { - proc A {this} {} - proc ~A {this} {} - virtual proc f {this p args} {} - virtual proc g {this p args} - virtual proc h {this p args} { - lappend ::result "A::h $this $p $args" - } - virtual proc i {this p args} { - lappend ::result "A::i $this $p $args" - } - virtual proc k {this p args} - virtual proc l {this p args} { - lappend ::result "A::l $this $p $args" - } - } - class B { - proc B {this} Z::A {} {} - proc ~B {this} {} - virtual proc f {this p args} { - lappend ::result "B::f $this $p $args" - } - virtual proc g {this p args} - virtual proc h {this p args} { - lappend ::result "B::h $this $p $args" - } - proc i {this p args} { - lappend ::result "B::i $this $p $args" - } - virtual proc k {this p args} { - lappend ::result "B::k $this $p $args" - } - virtual proc l {this p args} - } - class C { - proc C {this} Z::B {} {} - proc ~C {this} {} - proc f {this p args} { - lappend ::result "C::f $this $p $args" - } - proc g {this p args} { - lappend ::result "C::g $this $p $args" - } - proc i {this p args} { - lappend ::result "C::i $this $p $args" - } - proc k {this p args} { - lappend ::result "C::k $this $p $args" - } - proc l {this p args} { - lappend ::result "C::l $this $p $args" - } - } - set o [new C] - A::f $o x {y z} - A::g $o x {y z} - A::h $o x {y z} - A::i $o x {y z} - A::k $o x {y z} - A::l $o x {y z} - } - set o [new Z::C] - Z::A::f $o x {y z} - Z::A::g $o x {y z} - Z::A::h $o x {y z} - Z::A::i $o x {y z} - Z::A::k $o x {y z} - Z::A::l $o x {y z} - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {c::f 1 x {y z}}\ - {c::g 1 x {y z}}\ - {b::h 1 x {y z}}\ - {b::i 1 x {y z}}\ - {c::k 1 x {y z}}\ - {c::l 1 x {y z}}\ - {C::f 2 x {y z}}\ - {C::g 2 x {y z}}\ - {B::h 2 x {y z}}\ - {B::i 2 x {y z}}\ - {C::k 2 x {y z}}\ - {C::l 2 x {y z}}\ - {C::f 3 x {y z}}\ - {C::g 3 x {y z}}\ - {B::h 3 x {y z}}\ - {B::i 3 x {y z}}\ - {C::k 3 x {y z}}\ - {C::l 3 x {y z}}\ -] - -test stooop-77 { - check normal and user defined cloning operation with multiple inheritance - and member objects -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class z {} - class z::a {} - proc z::a::a {this p} { - set ($this,m) $p - } - class z::b {} - proc z::b::b {this p} { - set ($this,n) $p - } - class z::c {} - proc z::c::c {this p q r} z::a {$p} z::b {$q} { - set ($this,o) $r - set ($this,O) [new z::f] - } - proc z::c::c {this copy} z::a {$z::a::($copy,m)} z::b 1 { - set ($this,o) $($copy,o) - set ($this,O) [new z::f] - } - class z::d {} - proc z::d::d {this p q r} z::a {$p} z::b {$q} { - set ($this,p) $p - } - class z::e {} - proc z::e::e {this p q r} z::c {$p $q $r} z::d {$q $q $r} { - set ($this,q) $q - } - class z::f {} - proc z::f::f {this} { - set ($this,x) 0 - } - new [new z::e {x y} z {1 2}] - eval lappend ::result [dumpArrays z::a:: z::b:: z::c:: z::d:: z::e:: z::f::] - - class Z { - class A { - proc A {this p} { - set ($this,m) $p - } - } - class B { - proc B {this p} { - set ($this,n) $p - } - } - class C { - proc C {this p q r} Z::A {$p} Z::B {$q} { - set ($this,o) $r - set ($this,O) [new Z::F] - } - proc C {this copy} Z::A {$Z::A::($copy,m)} Z::B 1 { - set ($this,o) $($copy,o) - set ($this,O) [new Z::F] - } - } - class D { - proc D {this p q r} Z::A {$p} Z::B {$q} { - set ($this,p) $p - } - } - class E { - proc E {this p q r} Z::C {$p $q $r} Z::D {$q $q $r} { - set ($this,q) $q - } - } - class F { - proc F {this} { - set ($this,x) 0 - } - } - new [new E {x y} z {1 2}] - eval lappend ::result [dumpArrays A:: B:: C:: D:: E:: F::] - } - new [new Z::E {x y} z {1 2}] - eval lappend ::result [dumpArrays Z::A:: Z::B:: Z::C:: Z::D:: Z::E:: Z::F::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {z::a::(1,_derived) = ::z::d}\ - {z::a::(1,m) = z}\ - {z::a::(3,_derived) = ::z::d}\ - {z::a::(3,m) = z}\ - {z::b::(1,_derived) = ::z::d}\ - {z::b::(1,n) = z}\ - {z::b::(3,_derived) = ::z::d}\ - {z::b::(3,n) = z}\ - {z::c::(1,O) = 2}\ - {z::c::(1,_derived) = ::z::e}\ - {z::c::(1,o) = 1 2}\ - {z::c::(3,O) = 4}\ - {z::c::(3,_derived) = ::z::e}\ - {z::c::(3,o) = 1 2}\ - {z::d::(1,_derived) = ::z::e}\ - {z::d::(1,p) = z}\ - {z::d::(3,_derived) = ::z::e}\ - {z::d::(3,p) = z}\ - {z::e::(1,q) = z}\ - {z::e::(3,q) = z}\ - {z::f::(2,x) = 0}\ - {z::f::(4,x) = 0}\ - {A::(5,_derived) = ::Z::D}\ - {A::(5,m) = z}\ - {A::(7,_derived) = ::Z::D}\ - {A::(7,m) = z}\ - {B::(5,_derived) = ::Z::D}\ - {B::(5,n) = z}\ - {B::(7,_derived) = ::Z::D}\ - {B::(7,n) = z}\ - {C::(5,O) = 6}\ - {C::(5,_derived) = ::Z::E}\ - {C::(5,o) = 1 2}\ - {C::(7,O) = 8}\ - {C::(7,_derived) = ::Z::E}\ - {C::(7,o) = 1 2}\ - {D::(5,_derived) = ::Z::E}\ - {D::(5,p) = z}\ - {D::(7,_derived) = ::Z::E}\ - {D::(7,p) = z}\ - {E::(5,q) = z}\ - {E::(7,q) = z}\ - {F::(6,x) = 0}\ - {F::(8,x) = 0}\ - {Z::A::(11,_derived) = ::Z::D}\ - {Z::A::(11,m) = z}\ - {Z::A::(5,_derived) = ::Z::D}\ - {Z::A::(5,m) = z}\ - {Z::A::(7,_derived) = ::Z::D}\ - {Z::A::(7,m) = z}\ - {Z::A::(9,_derived) = ::Z::D}\ - {Z::A::(9,m) = z}\ - {Z::B::(11,_derived) = ::Z::D}\ - {Z::B::(11,n) = z}\ - {Z::B::(5,_derived) = ::Z::D}\ - {Z::B::(5,n) = z}\ - {Z::B::(7,_derived) = ::Z::D}\ - {Z::B::(7,n) = z}\ - {Z::B::(9,_derived) = ::Z::D}\ - {Z::B::(9,n) = z}\ - {Z::C::(11,O) = 12}\ - {Z::C::(11,_derived) = ::Z::E}\ - {Z::C::(11,o) = 1 2}\ - {Z::C::(5,O) = 6}\ - {Z::C::(5,_derived) = ::Z::E}\ - {Z::C::(5,o) = 1 2}\ - {Z::C::(7,O) = 8}\ - {Z::C::(7,_derived) = ::Z::E}\ - {Z::C::(7,o) = 1 2}\ - {Z::C::(9,O) = 10}\ - {Z::C::(9,_derived) = ::Z::E}\ - {Z::C::(9,o) = 1 2}\ - {Z::D::(11,_derived) = ::Z::E}\ - {Z::D::(11,p) = z}\ - {Z::D::(5,_derived) = ::Z::E}\ - {Z::D::(5,p) = z}\ - {Z::D::(7,_derived) = ::Z::E}\ - {Z::D::(7,p) = z}\ - {Z::D::(9,_derived) = ::Z::E}\ - {Z::D::(9,p) = z}\ - {Z::E::(11,q) = z}\ - {Z::E::(5,q) = z}\ - {Z::E::(7,q) = z}\ - {Z::E::(9,q) = z}\ - {Z::F::(10,x) = 0}\ - {Z::F::(12,x) = 0}\ - {Z::F::(6,x) = 0}\ - {Z::F::(8,x) = 0}\ -] - -test stooop-78 { - check that virtual procedure invocations from base class constructor behave - as in C++ -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class z {} - class z::a {} - proc z::a::a {this} { - z::a::f $this x - z::a::g $this x {y z} - # pure virtual invocations behavior is undefined - lappend ::result [catch {z::a::h $this x}] - lappend ::result [catch {z::a::i $this x {y z}}] - } - proc z::a::~a {this} {} - virtual proc z::a::f {this p} { - lappend ::result "a::f $this $p" - } - virtual proc z::a::g {this p args} { - lappend ::result "a::g $this $p $args" - } - virtual proc z::a::h {this p} - virtual proc z::a::i {this p args} - class z::b {} - proc z::b::b {this} z::a {} {} - proc z::b::~b {this} {} - virtual proc z::b::f {this p} { - lappend ::result "b::f $this $p" - } - virtual proc z::b::g {this p args} { - lappend ::result "b::g $this $p $args" - } - virtual proc z::b::h {this p} { - lappend ::result "b::h $this $p" - } - proc z::b::i {this p args} { - lappend ::result "b::i $this $p $args" - } - new z::b - - class Z { - class A { - proc A {this} { - f $this x - g $this x {y z} - # pure virtual invocations behavior is undefined - lappend ::result [catch {A::h $this x}] - lappend ::result [catch {A::i $this x {y z}}] - } - proc ~A {this} {} - virtual proc f {this p} { - lappend ::result "A::f $this $p" - } - virtual proc g {this p args} { - lappend ::result "A::g $this $p $args" - } - virtual proc h {this p} - virtual proc i {this p args} - } - class B { - proc B {this} Z::A {} {} - proc ~B {this} {} - virtual proc f {this p} { - lappend ::result "B::f $this $p" - } - virtual proc g {this p args} { - lappend ::result "B::g $this $p $args" - } - virtual proc h {this p} { - lappend ::result "B::h $this $p" - } - proc i {this p args} { - lappend ::result "B::i $this $p $args" - } - } - new B - } - new Z::B - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::f 1 x}\ - {a::g 1 x {y z}}\ - {1}\ - {1}\ - {A::f 2 x}\ - {A::g 2 x {y z}}\ - {1}\ - {1}\ - {A::f 3 x}\ - {A::g 3 x {y z}}\ - {1}\ - {1}\ -] - -test stooop-79 { - check that child nested class is visible within parent namespace -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a {} - proc a::a {this} { - lappend ::result "a::a $this" - new b - } - class a::b {} - proc a::b::b {this} { - lappend ::result "b::b $this" - } - new a - - class a { - proc a {this} { - lappend ::result "a::a $this" - new b - } - class b { - proc b {this} { - lappend ::result "b::b $this" - } - } - new a - } - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1}\ - {b::b 2}\ - {a::a 3}\ - {b::b 4}\ -] - -test stooop-80 { - verify regular member procedure checking in procedure checking debug mode -} { - set interpreter [interp create] - $interpreter eval { - # reset any existing environment variables: - foreach name [array names env STOOOP*] {unset env($name)} - set env(STOOOPCHECKPROCEDURES) 1 - } - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a {} - proc a::a {this} {} - proc a::p {this} {} - class b {} - proc b::b {this} {} - proc b::p {this} {} - set o [new a] - a::p $o - catch {b::p $o} message - lappend ::result $message - - class A { - proc A {this} {} - proc p {this} {} - } - class B { - proc B {this} {} - proc p {this} {} - } - set o [new A] - A::p $o - catch {B::p $o} message - lappend ::result $message - - class c {} - class c::d {} - proc c::d::d {this} {} - proc c::d::p {this} {} - class c::e {} - proc c::e::e {this} {} - proc c::e::p {this} {} - set o [new c::d] - c::d::p $o - catch {c::e::p $o} message - lappend ::result $message - - class C { - class D { - proc D {this} {} - proc p {this} {} - } - class E { - proc E {this} {} - proc p {this} {} - } - set o [new D] - D::p $o - catch {E::p $o} message - lappend ::result $message - } - set o [new C::D] - C::D::p $o - catch {C::E::p $o} message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {class b of ::b::p procedure not an ancestor of object 1 class a}\ - {class B of ::B::p procedure not an ancestor of object 2 class A}\ - {class c::e of ::c::e::p procedure not an ancestor of object 3 class c::d}\ - {class C::E of ::C::E::p procedure not an ancestor of object 4 class C::D}\ - {class C::E of ::C::E::p procedure not an ancestor of object 5 class C::D}\ -] - -test stooop-81 { - verify regular member procedure checking within class hierarchy in - procedure checking debug mode -} { - set interpreter [interp create] - $interpreter eval { - # reset any existing environment variables: - foreach name [array names env STOOOP*] {unset env($name)} - set env(STOOOPCHECKPROCEDURES) 1 - } - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a {} - proc a::a {this} {} - proc a::~a {this} {} - proc a::p {this} {} - class b {} - proc b::b {this} a {} {} - proc b::~b {this} {} - proc b::p {this} {} - class c {} - proc c::c {this} b {} {} - proc c::~c {this} {} - proc c::p {this} {} - set o [new a] - a::p $o - catch {b::p $o} message - lappend ::result $message - catch {c::p $o} message - lappend ::result $message - delete $o - set o [new b] - a::p $o - b::p $o - catch {c::p $o} message - lappend ::result $message - delete $o - set o [new c] - a::p $o - b::p $o - c::p $o - delete $o - - class a { - proc a {this} {} - proc ~a {this} {} - proc p {this} {} - } - class b { - proc b {this} a {} {} - proc ~b {this} {} - proc p {this} {} - } - class c { - proc c {this} b {} {} - proc ~c {this} {} - proc p {this} {} - } - set o [new a] - a::p $o - catch {b::p $o} message - lappend ::result $message - catch {c::p $o} message - lappend ::result $message - delete $o - set o [new b] - a::p $o - b::p $o - catch {c::p $o} message - lappend ::result $message - delete $o - set o [new c] - a::p $o - b::p $o - c::p $o - delete $o - - class d {} - class d::e {} - proc d::e::e {this} {} - proc d::e::~e {this} {} - proc d::e::p {this} {} - class d::f {} - proc d::f::f {this} d::e {} {} - proc d::f::~f {this} {} - proc d::f::p {this} {} - class d::g {} - proc d::g::g {this} d::f {} {} - proc d::g::~g {this} {} - proc d::g::p {this} {} - set o [new d::e] - d::e::p $o - catch {d::f::p $o} message - lappend ::result $message - catch {d::g::p $o} message - lappend ::result $message - delete $o - set o [new d::f] - d::e::p $o - d::f::p $o - catch {d::g::p $o} message - lappend ::result $message - delete $o - set o [new d::g] - d::e::p $o - d::f::p $o - d::g::p $o - delete $o - - class C { - class D { - proc D {this} {} - proc ~D {this} {} - proc p {this} {} - } - class E { - proc E {this} C::D {} {} - proc ~E {this} {} - proc p {this} {} - } - class F { - proc F {this} C::E {} {} - proc ~F {this} {} - proc p {this} {} - } - set o [new D] - D::p $o - catch {E::p $o} message - lappend ::result $message - catch {F::p $o} message - lappend ::result $message - delete $o - set o [new E] - D::p $o - E::p $o - catch {F::p $o} message - lappend ::result $message - delete $o - set o [new F] - D::p $o - E::p $o - F::p $o - delete $o - } - set o [new C::D] - C::D::p $o - catch {C::E::p $o} message - lappend ::result $message - catch {C::F::p $o} message - lappend ::result $message - delete $o - set o [new C::E] - C::D::p $o - C::E::p $o - catch {C::F::p $o} message - lappend ::result $message - delete $o - set o [new C::F] - C::D::p $o - C::E::p $o - C::F::p $o - delete $o - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {class b of ::b::p procedure not an ancestor of object 1 class a}\ - {class c of ::c::p procedure not an ancestor of object 1 class a}\ - {class c of ::c::p procedure not an ancestor of object 2 class b}\ - {class b of ::b::p procedure not an ancestor of object 4 class a}\ - {class c of ::c::p procedure not an ancestor of object 4 class a}\ - {class c of ::c::p procedure not an ancestor of object 5 class b}\ - {class d::f of ::d::f::p procedure not an ancestor of object 7 class d::e}\ - {class d::g of ::d::g::p procedure not an ancestor of object 7 class d::e}\ - {class d::g of ::d::g::p procedure not an ancestor of object 8 class d::f}\ - {class C::E of ::C::E::p procedure not an ancestor of object 10 class C::D}\ - {class C::F of ::C::F::p procedure not an ancestor of object 10 class C::D}\ - {class C::F of ::C::F::p procedure not an ancestor of object 11 class C::E}\ - {class C::E of ::C::E::p procedure not an ancestor of object 13 class C::D}\ - {class C::F of ::C::F::p procedure not an ancestor of object 13 class C::D}\ - {class C::F of ::C::F::p procedure not an ancestor of object 14 class C::E}\ -] - -test stooop-82 { - verify regular member procedure checking within multiple inheritance class - hierarchy in procedure checking debug mode -} { - set interpreter [interp create] - $interpreter eval { - # reset any existing environment variables: - foreach name [array names env STOOOP*] {unset env($name)} - set env(STOOOPCHECKPROCEDURES) 1 - } - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a {} - proc a::a {this} {} - proc a::p {this} {} - class b {} - proc b::b {this} {} - proc b::p {this} {} - class c {} - proc c::c {this} a {} b {} {} - proc c::p {this} {} - set o [new a] - a::p $o - catch {b::p $o} message - lappend ::result $message - catch {c::p $o} message - lappend ::result $message - - class A { - proc A {this} {} - proc p {this} {} - } - class B { - proc B {this} {} - proc p {this} {} - } - class C { - proc C {this} A {} B {} {} - proc p {this} {} - } - set o [new A] - A::p $o - catch {B::p $o} message - lappend ::result $message - catch {C::p $o} message - lappend ::result $message - - class d {} - class d::e {} - proc d::e::e {this} {} - proc d::e::p {this} {} - class d::f {} - proc d::f::f {this} {} - proc d::f::p {this} {} - class d::g {} - proc d::g::g {this} d::e {} d::f {} {} - proc d::g::p {this} {} - set o [new d::e] - d::e::p $o - catch {d::f::p $o} message - lappend ::result $message - catch {d::g::p $o} message - lappend ::result $message - - class D { - class E { - proc E {this} {} - proc p {this} {} - } - class F { - proc F {this} {} - proc p {this} {} - } - class G { - proc G {this} D::E {} D::F {} {} - proc p {this} {} - } - set o [new E] - E::p $o - catch {F::p $o} message - lappend ::result $message - catch {G::p $o} message - lappend ::result $message - } - set o [new D::E] - D::E::p $o - catch {D::F::p $o} message - lappend ::result $message - catch {D::G::p $o} message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {class b of ::b::p procedure not an ancestor of object 1 class a}\ - {class c of ::c::p procedure not an ancestor of object 1 class a}\ - {class B of ::B::p procedure not an ancestor of object 2 class A}\ - {class C of ::C::p procedure not an ancestor of object 2 class A}\ - {class d::f of ::d::f::p procedure not an ancestor of object 3 class d::e}\ - {class d::g of ::d::g::p procedure not an ancestor of object 3 class d::e}\ - {class D::F of ::D::F::p procedure not an ancestor of object 4 class D::E}\ - {class D::G of ::D::G::p procedure not an ancestor of object 4 class D::E}\ - {class D::F of ::D::F::p procedure not an ancestor of object 5 class D::E}\ - {class D::G of ::D::G::p procedure not an ancestor of object 5 class D::E}\ -] - -test stooop-83 { - verify object identifier checking in procedure checking debug mode -} { - set interpreter [interp create] - $interpreter eval { - # reset any existing environment variables: - foreach name [array names env STOOOP*] {unset env($name)} - set env(STOOOPCHECKPROCEDURES) 1 - } - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a {} - proc a::a {this} {} - proc a::p {this} {} - catch {a::p 1} message - lappend ::result $message - - class A { - proc A {this} {} - proc p {this} {} - } - catch {A::p 2} message - lappend ::result $message - - class b {} - class b::c {} - proc b::c::c {this} {} - proc b::c::p {this} {} - catch {b::c::p 3} message - lappend ::result $message - - class B { - class C { - proc C {this} {} - proc p {this} {} - } - catch {C::p 4} message - lappend ::result $message - } - catch {B::C::p 5} message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {1 is not a valid object identifier}\ - {2 is not a valid object identifier}\ - {3 is not a valid object identifier}\ - {4 is not a valid object identifier}\ - {5 is not a valid object identifier}\ -] - -test stooop-84 { - verify virtual member procedure checking in procedure checking debug mode -} { - set interpreter [interp create] - $interpreter eval { - # reset any existing environment variables: - foreach name [array names env STOOOP*] {unset env($name)} - set env(STOOOPCHECKPROCEDURES) 1 - } - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a {} - proc a::a {this} {} - proc a::~a {this} {} - virtual proc a::p {this} { - lappend ::result "a::p $this" - } - virtual proc a::q {this} - virtual proc a::r {this} { - lappend ::result "a::r $this" - } - class b {} - proc b::b {this} a {} {} - proc b::~b {this} {} - proc b::p {this} { - lappend ::result "b::p $this" - } - proc b::q {this} { - lappend ::result "b::q $this" - } - set o [new b] - a::p $o - a::q $o - a::r $o - b::p $o - b::q $o - delete $o - catch {a::p $o} message; lappend ::result $message - catch {a::q $o} message; lappend ::result $message - catch {a::r $o} message; lappend ::result $message - catch {b::p $o} message; lappend ::result $message - catch {b::q $o} message; lappend ::result $message - - class A { - proc A {this} {} - proc ~A {this} {} - virtual proc p {this} { - lappend ::result "A::p $this" - } - virtual proc q {this} - virtual proc r {this} { - lappend ::result "A::r $this" - } - } - class B { - proc B {this} A {} {} - proc ~B {this} {} - proc p {this} { - lappend ::result "B::p $this" - } - proc q {this} { - lappend ::result "B::q $this" - } - } - set o [new B] - A::p $o - A::q $o - A::r $o - B::p $o - B::q $o - delete $o - catch {A::p $o} message; lappend ::result $message - catch {A::q $o} message; lappend ::result $message - catch {A::r $o} message; lappend ::result $message - catch {B::p $o} message; lappend ::result $message - catch {B::q $o} message; lappend ::result $message - - class c {} - class c::d {} - proc c::d::d {this} {} - proc c::d::~d {this} {} - virtual proc c::d::p {this} { - lappend ::result "d::p $this" - } - virtual proc c::d::q {this} - virtual proc c::d::r {this} { - lappend ::result "d::r $this" - } - class c::e {} - proc c::e::e {this} c::d {} {} - proc c::e::~e {this} {} - proc c::e::p {this} { - lappend ::result "e::p $this" - } - proc c::e::q {this} { - lappend ::result "e::q $this" - } - set o [new c::e] - c::d::p $o - c::d::q $o - c::d::r $o - c::e::p $o - c::e::q $o - delete $o - catch {c::d::p $o} message; lappend ::result $message - catch {c::d::q $o} message; lappend ::result $message - catch {c::d::r $o} message; lappend ::result $message - catch {c::e::p $o} message; lappend ::result $message - catch {c::e::q $o} message; lappend ::result $message - - class C { - class D { - proc D {this} {} - proc ~D {this} {} - virtual proc p {this} { - lappend ::result "D::p $this" - } - virtual proc q {this} - virtual proc r {this} { - lappend ::result "D::r $this" - } - } - class E { - proc E {this} C::D {} {} - proc ~E {this} {} - proc p {this} { - lappend ::result "E::p $this" - } - proc q {this} { - lappend ::result "E::q $this" - } - } - set o [new E] - D::p $o - D::q $o - D::r $o - E::p $o - E::q $o - delete $o - catch {D::p $o} message; lappend ::result $message - catch {D::q $o} message; lappend ::result $message - catch {D::r $o} message; lappend ::result $message - catch {E::p $o} message; lappend ::result $message - catch {E::q $o} message; lappend ::result $message - } - set o [new C::E] - C::D::p $o - C::D::q $o - C::D::r $o - C::E::p $o - C::E::q $o - delete $o - catch {C::D::p $o} message; lappend ::result $message - catch {C::D::q $o} message; lappend ::result $message - catch {C::D::r $o} message; lappend ::result $message - catch {C::E::p $o} message; lappend ::result $message - catch {C::E::q $o} message; lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {b::p 1}\ - {b::q 1}\ - {a::r 1}\ - {b::p 1}\ - {b::q 1}\ - {1 is not a valid object identifier}\ - {1 is not a valid object identifier}\ - {1 is not a valid object identifier}\ - {1 is not a valid object identifier}\ - {1 is not a valid object identifier}\ - {B::p 2}\ - {B::q 2}\ - {A::r 2}\ - {B::p 2}\ - {B::q 2}\ - {2 is not a valid object identifier}\ - {2 is not a valid object identifier}\ - {2 is not a valid object identifier}\ - {2 is not a valid object identifier}\ - {2 is not a valid object identifier}\ - {e::p 3}\ - {e::q 3}\ - {d::r 3}\ - {e::p 3}\ - {e::q 3}\ - {3 is not a valid object identifier}\ - {3 is not a valid object identifier}\ - {3 is not a valid object identifier}\ - {3 is not a valid object identifier}\ - {3 is not a valid object identifier}\ - {E::p 4}\ - {E::q 4}\ - {D::r 4}\ - {E::p 4}\ - {E::q 4}\ - {4 is not a valid object identifier}\ - {4 is not a valid object identifier}\ - {4 is not a valid object identifier}\ - {4 is not a valid object identifier}\ - {4 is not a valid object identifier}\ - {E::p 5}\ - {E::q 5}\ - {D::r 5}\ - {E::p 5}\ - {E::q 5}\ - {5 is not a valid object identifier}\ - {5 is not a valid object identifier}\ - {5 is not a valid object identifier}\ - {5 is not a valid object identifier}\ - {5 is not a valid object identifier}\ -] - -test stooop-85 { - verify pure interface class object creation in procedure checking debug mode -} { - set interpreter [interp create] - $interpreter eval { - # reset any existing environment variables: - foreach name [array names env STOOOP*] {unset env($name)} - set env(STOOOPCHECKPROCEDURES) 1 - } - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a {} - proc a::a {this} { - lappend ::result "a::a $this" - } - proc a::~a {this} {} - virtual proc a::p {this} {} - set o [new a] - delete $o - virtual proc a::q {this} - catch {new a} message - lappend ::result $message - - class A { - proc A {this} { - lappend ::result "A::A $this" - } - proc ~A {this} {} - virtual proc p {this} {} - } - set o [new A] - delete $o - class A { - virtual proc q {this} - } - catch {new A} message - lappend ::result $message - - class b {} - class b::c {} - proc b::c::c {this} { - lappend ::result "c::c $this" - } - proc b::c::~c {this} {} - virtual proc b::c::p {this} {} - set o [new b::c] - delete $o - virtual proc b::c::q {this} - catch {new b::c} message - lappend ::result $message - - class B { - class C { - proc C {this} { - lappend ::result "C::C $this" - } - proc ~C {this} {} - virtual proc p {this} {} - } - set o [new C] - delete $o - class C { - virtual proc q {this} - } - catch {new C} message - lappend ::result $message - } - catch {new B::C} message - lappend ::result $message - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::a 1}\ - {class ::a with pure virtual procedures should not be instanciated}\ - {A::A 2}\ - {class ::A with pure virtual procedures should not be instanciated}\ - {c::c 3}\ - {class ::b::c with pure virtual procedures should not be instanciated}\ - {C::C 4}\ - {class ::B::C with pure virtual procedures should not be instanciated}\ - {class ::B::C with pure virtual procedures should not be instanciated}\ -] - -test stooop-86 { - verify member writing and unsetting within class procedures in member data - checking mode - (it seems that unset tracing prevents error reporting at this time (bug?)) -} { - set interpreter [interp create] - $interpreter eval { - # reset any existing environment variables: - foreach name [array names env STOOOP*] {unset env($name)} - set env(STOOOPCHECKDATA) 1 - } - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a {} - proc a::a {this} {} - proc a::~a {this} {} - proc a::p {this} { - set b::($this,m) 0 - } - proc a::q {this} { - set b::(n) 0 - } - proc a::r {this} { - unset b::($this,m) - } - proc a::s {this} { - unset b::(n) - } - set o [new a] - class b {} - set b::($o,m) 0 - set b::(n) 0 - catch {a::p $o} message; lappend ::result $message - catch {a::q $o} message; lappend ::result $message - catch {a::r $o} message; lappend ::result bug - catch {a::s $o} message; lappend ::result bug - delete $o - - class A { - proc A {this} {} - proc ~A {this} {} - proc p {this} { - set B::($this,m) 0 - } - proc q {this} { - set B::(n) 0 - } - proc r {this} { - unset B::($this,m) - } - proc s {this} { - unset B::(n) - } - } - set o [new A] - class B { - set ($o,m) 0 - set (n) 0 - } - class A { - catch {p $o} message; lappend ::result $message - catch {q $o} message; lappend ::result $message - catch {r $o} message; lappend ::result bug - catch {s $o} message; lappend ::result bug - } - delete $o - - class c {} - class c::d {} - proc c::d::d {this} {} - proc c::d::~d {this} {} - proc c::d::p {this} { - set c::e::($this,m) 0 - } - proc c::d::q {this} { - set c::e::(n) 0 - } - proc c::d::r {this} { - unset c::e::($this,m) - } - proc c::d::s {this} { - unset c::e::(n) - } - class c::e {} - set o [new c::d] - set c::e::($o,m) 0 - set c::e::(n) 0 - catch {c::d::p $o} message; lappend ::result $message - catch {c::d::q $o} message; lappend ::result $message - catch {c::d::r $o} message; lappend ::result bug - catch {c::d::s $o} message; lappend ::result bug - delete $o - - class C { - class D { - proc D {this} {} - proc ~D {this} {} - proc p {this} { - set C::E::($this,m) 0 - } - proc q {this} { - set C::E::(n) 0 - } - proc r {this} { - unset C::E::($this,m) - } - proc s {this} { - unset C::E::(n) - } - } - set ::o [new D] - class E { - set ($o,m) 0 - set (n) 0 - } - class D { - catch {p $o} message; lappend ::result $message - catch {q $o} message; lappend ::result $message - catch {r $o} message; lappend ::result bug - catch {s $o} message; lappend ::result bug - } - } - catch {C::D::p $o} message; lappend ::result $message - catch {C::D::q $o} message; lappend ::result $message - catch {C::D::r $o} message; lappend ::result bug - catch {C::D::s $o} message; lappend ::result bug - delete $o - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {can't set "b::(1,m)": class access violation in procedure ::a::p}\ - {can't set "b::(n)": class access violation in procedure ::a::q}\ - bug\ - bug\ - {can't set "B::(2,m)": class access violation in procedure ::A::p}\ - {can't set "B::(n)": class access violation in procedure ::A::q}\ - bug\ - bug\ - {can't set "c::e::(3,m)": class access violation in procedure ::c::d::p}\ - {can't set "c::e::(n)": class access violation in procedure ::c::d::q}\ - bug\ - bug\ - {can't set "C::E::(4,m)": class access violation in procedure ::C::D::p}\ - {can't set "C::E::(n)": class access violation in procedure ::C::D::q}\ - bug\ - bug\ - {can't set "C::E::(4,m)": class access violation in procedure ::C::D::p}\ - {can't set "C::E::(n)": class access violation in procedure ::C::D::q}\ - bug\ - bug\ -] - -test stooop-87 { - verify member writing and unsetting within class namespaces in member data - checking mode - (it seems that unset tracing prevents error reporting at this time (bug?)) -} { - set interpreter [interp create] - $interpreter eval { - # reset any existing environment variables: - foreach name [array names env STOOOP*] {unset env($name)} - set env(STOOOPCHECKDATA) 1 - } - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a { - set (m) 0 - } - proc a::a {this} { - set ($this,n) 0 - } - proc a::~a {this} {} - set o [new a] - catch {class b {incr a::(m)}} message; lappend ::result $message - catch {class b {incr a::($o,n)}} message; lappend ::result $message - catch {class b {unset a::(m)}} message; lappend ::result bug - catch {class b {unset a::($o,n)}} message; lappend ::result bug - delete $o - - class A { - set (m) 0 - proc A {this} { - set ($this,n) 0 - } - proc ~A {this} {} - } - set o [new A] - class B { - catch {incr A::(m)} message; lappend ::result $message - catch {incr A::($o,n)} message; lappend ::result $message - catch {unset A::(m)} message; lappend ::result bug - catch {unset A::($o,n)} message; lappend ::result bug - } - delete $o - - class c {} - class c::d { - set (m) 0 - } - proc c::d::d {this} { - set ($this,n) 0 - } - proc c::d::~d {this} {} - set o [new c::d] - catch {class c::e {incr c::d::(m)}} message; lappend ::result $message - catch {class c::e {incr c::d::($o,n)}} message; lappend ::result $message - catch {class c::e {unset c::d::(m)}} message; lappend ::result bug - catch {class c::e {unset c::d::($o,n)}} message; lappend ::result bug - delete $o - - class C { - class D { - set (m) 0 - proc D {this} { - set ($this,n) 0 - } - proc ~D {this} {} - } - set ::o [new D] - class B { - catch {incr C::D::(m)} message; lappend ::result $message - catch {incr C::D::($o,n)} message; lappend ::result $message - catch {unset C::D::(m)} message; lappend ::result bug - catch {unset C::D::($o,n)} message; lappend ::result bug - } - } - catch {incr C::D::(m)} message; lappend ::result $message - catch {incr C::D::($o,n)} message; lappend ::result $message - catch {unset C::D::(m)} message; lappend ::result bug - catch {unset C::D::($o,n)} message; lappend ::result bug - delete $o - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {can't set "a::(m)": class access violation in class b namespace}\ - {can't set "a::(1,n)": class access violation in class b namespace}\ - bug\ - bug\ - {can't set "A::(m)": class access violation in class B namespace}\ - {can't set "A::(2,n)": class access violation in class B namespace}\ - bug\ - bug\ - {can't set "c::d::(m)": class access violation in class c::e namespace}\ - {can't set "c::d::(3,n)": class access violation in class c::e namespace}\ - bug\ - bug\ - {can't set "C::D::(m)": class access violation in class C::B namespace}\ - {can't set "C::D::(4,n)": class access violation in class C::B namespace}\ - bug\ - bug\ - {can't read "C::D::(m)": no such element in array}\ - {can't read "C::D::(4,n)": no such element in array}\ - bug\ - bug\ -] - -test stooop-88 { - verify that object copying still works in member data checking mode -} { - set interpreter [interp create] - $interpreter eval { - # reset any existing environment variables: - foreach name [array names env STOOOP*] {unset env($name)} - set env(STOOOPCHECKDATA) 1 - } - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a {} - proc a::a {this} { - set ($this,n) 0 - } - new [new a] - - class A { - proc A {this} { - set ($this,n) 0 - } - } - new [new A] - - class b {} - class b::c {} - proc b::c::c {this} { - set ($this,n) 0 - } - new [new b::c] - - class B { - class C { - proc C {this} { - set ($this,n) 0 - } - } - new [new C] - } - new [new B::C] - - set ::result {} - }] - interp delete $interpreter - set result -} {} - -test stooop-89 { - verify both data and procedure static access in member data checking mode -} { - set interpreter [interp create] - $interpreter eval { - # reset any existing environment variables: - foreach name [array names env STOOOP*] {unset env($name)} - set env(STOOOPCHECKDATA) 1 - } - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a { - set (m) 0 - } - proc a::a {this} { - set ($this,n) 0 - } - proc a::~a {this} {} - proc a::p {this} { - incr (m) - incr b::(o) - } - proc a::q {object} { - incr ($object,n) - incr b::($object,p) - } - class b { - set (o) 0 - } - proc b::b {this} a {} { - set ($this,p) 0 - } - proc b::~b {this} {} - proc b::r {this} { - incr (o) - incr a::(m) - } - proc b::s {object} { - incr ($object,p) - incr a::($object,n) - } - set o [new b] - catch {a::p $o} message; lappend ::result $message - catch {a::q $o} message; lappend ::result $message - catch {b::r $o} message; lappend ::result $message - catch {b::s $o} message; lappend ::result $message - delete $o - - class A { - set (m) 0 - proc A {this} { - set ($this,n) 0 - } - proc ~A {this} {} - proc p {this} { - incr (m) - incr B::(o) - } - proc q {object} { - incr ($object,n) - incr B::($object,p) - } - } - class B { - set (o) 0 - proc B {this} A {} { - set ($this,p) 0 - } - proc ~B {this} {} - proc r {this} { - incr (o) - incr A::(m) - } - proc s {object} { - incr ($object,p) - incr A::($object,n) - } - } - set o [new B] - catch {A::p $o} message; lappend ::result $message - catch {A::q $o} message; lappend ::result $message - catch {B::r $o} message; lappend ::result $message - catch {B::s $o} message; lappend ::result $message - delete $o - - class c {} - class c::d { - set (m) 0 - } - proc c::d::d {this} { - set ($this,n) 0 - } - proc c::d::~d {this} {} - proc c::d::p {this} { - incr (m) - incr c::e::(o) - } - proc c::d::q {object} { - incr ($object,n) - incr c::e::($object,p) - } - class c::e { - set (o) 0 - } - proc c::e::e {this} c::d {} { - set ($this,p) 0 - } - proc c::e::~e {this} {} - proc c::e::r {this} { - incr (o) - incr c::d::(m) - } - proc c::e::s {object} { - incr ($object,p) - incr c::d::($object,n) - } - set o [new c::e] - catch {c::d::p $o} message; lappend ::result $message - catch {c::d::q $o} message; lappend ::result $message - catch {c::e::r $o} message; lappend ::result $message - catch {c::e::s $o} message; lappend ::result $message - delete $o - - class C { - class D { - set (m) 0 - proc D {this} { - set ($this,n) 0 - } - proc ~D {this} {} - proc p {this} { - incr (m) - incr C::E::(o) - } - proc q {object} { - incr ($object,n) - incr C::E::($object,p) - } - } - class E { - set (o) 0 - proc E {this} C::D {} { - set ($this,p) 0 - } - proc ~E {this} {} - proc r {this} { - incr (o) - incr C::D::(m) - } - proc s {object} { - incr ($object,p) - incr C::D::($object,n) - } - } - set ::o [new E] - catch {D::p $o} message; lappend ::result $message - catch {D::q $o} message; lappend ::result $message - catch {E::r $o} message; lappend ::result $message - catch {E::s $o} message; lappend ::result $message - } - catch {C::D::p $o} message; lappend ::result $message - catch {C::D::q $o} message; lappend ::result $message - catch {C::E::r $o} message; lappend ::result $message - catch {C::E::s $o} message; lappend ::result $message - delete $o - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {can't set "b::(o)": class access violation in procedure ::a::p}\ - {can't set "b::(1,p)": class access violation in procedure ::a::q}\ - {can't set "a::(m)": class access violation in procedure ::b::r}\ - {can't set "a::(1,n)": class access violation in procedure ::b::s}\ - {can't set "B::(o)": class access violation in procedure ::A::p}\ - {can't set "B::(2,p)": class access violation in procedure ::A::q}\ - {can't set "A::(m)": class access violation in procedure ::B::r}\ - {can't set "A::(2,n)": class access violation in procedure ::B::s}\ - {can't set "c::e::(o)": class access violation in procedure ::c::d::p}\ - {can't set "c::e::(3,p)": class access violation in procedure ::c::d::q}\ - {can't set "c::d::(m)": class access violation in procedure ::c::e::r}\ - {can't set "c::d::(3,n)": class access violation in procedure ::c::e::s}\ - {can't set "C::E::(o)": class access violation in procedure ::C::D::p}\ - {can't set "C::E::(4,p)": class access violation in procedure ::C::D::q}\ - {can't set "C::D::(m)": class access violation in procedure ::C::E::r}\ - {can't set "C::D::(4,n)": class access violation in procedure ::C::E::s}\ - {can't set "C::E::(o)": class access violation in procedure ::C::D::p}\ - {can't set "C::E::(4,p)": class access violation in procedure ::C::D::q}\ - {can't set "C::D::(m)": class access violation in procedure ::C::E::r}\ - {can't set "C::D::(4,n)": class access violation in procedure ::C::E::s}\ -] - -test stooop-90 { - verify member data checking when "array set" is used -} { - set interpreter [interp create] - $interpreter eval { - # reset any existing environment variables: - foreach name [array names env STOOOP*] {unset env($name)} - set env(STOOOPCHECKDATA) 1 - } - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a {} - proc a::a {this} {} - proc a::~a {this} {} - proc a::p {this} { - array set b:: "$this,m 0" - } - proc a::q {this} { - array set b:: {n 0} - } - set o [new a] - class b {} - array set b:: "$o,m 0 n 0" - catch {a::p $o} message; lappend ::result $message - catch {a::q $o} message; lappend ::result $message - delete $o - - class A { - proc A {this} {} - proc ~A {this} {} - proc p {this} { - array set B:: "$this,m 0" - } - proc q {this} { - array set B:: {n 0} - } - } - set o [new A] - class B { - array set B:: "$o,m 0 n 0" - } - class A { - catch {p $o} message; lappend ::result $message - catch {q $o} message; lappend ::result $message - } - delete $o - - class c {} - class c::d {} - proc c::d::d {this} {} - proc c::d::~d {this} {} - proc c::d::p {this} { - array set c::e:: "$this,m 0" - } - proc c::d::q {this} { - array set c::e:: {n 0} - } - class c::e {} - set o [new c::d] - array set c::e:: "$o,m 0 n 0" - catch {c::d::p $o} message; lappend ::result $message - catch {c::d::q $o} message; lappend ::result $message - delete $o - - class C { - class D { - proc D {this} {} - proc ~D {this} {} - proc p {this} { - array set C::E:: "$this,m 0" - } - proc q {this} { - array set C::E:: {n 0} - } - } - set ::o [new D] - class E { - array set C::E:: "$o,m 0 n 0" - } - class D { - catch {p $o} message; lappend ::result $message - catch {q $o} message; lappend ::result $message - } - } - catch {C::D::p $o} message; lappend ::result $message - catch {C::D::q $o} message; lappend ::result $message - delete $o - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {can't set "b::(1,m)": class access violation in procedure ::a::p}\ - {can't set "b::(n)": class access violation in procedure ::a::q}\ - {can't set "B::(2,m)": class access violation in procedure ::A::p}\ - {can't set "B::(n)": class access violation in procedure ::A::q}\ - {can't set "c::e::(3,m)": class access violation in procedure ::c::d::p}\ - {can't set "c::e::(n)": class access violation in procedure ::c::d::q}\ - {can't set "C::E::(4,m)": class access violation in procedure ::C::D::p}\ - {can't set "C::E::(n)": class access violation in procedure ::C::D::q}\ - {can't set "C::E::(4,m)": class access violation in procedure ::C::D::p}\ - {can't set "C::E::(n)": class access violation in procedure ::C::D::q}\ -] - -test stooop-91 { - verify that packaged class works even in debugging mode -} { - makeDirectory 91 - makeFile {package ifneeded 91 1 [list tclPkgSetup $dir 91 1 {{p.tcl source {::a::_copy ::a::a}}}]}\ - [file join 91 pkgIndex.tcl] - makeFile {package provide 91 1; class a {proc a {this} {}}}\ - [file join 91 p.tcl] - set interpreter [interp create] - $interpreter eval { - # search in test directory sub-directories: - lappend auto_path [file dirname [info script]] - # reset any existing environment variables: - foreach name [array names env STOOOP*] {unset env($name)} - set env(STOOOPCHECKPROCEDURES) 1 - } - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - package require 91 - new a - set ::result {} - }] - interp delete $interpreter - set result -} {} - -test stooop-92 { - check that parameter passing by reference works with virtual declarations -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this} {} - proc a::~a {this} {} - virtual proc a::f {this a} {} - virtual proc a::g {this a} - virtual proc a::h {this a} { - upvar $a d - set d(0) 0 - } - virtual proc a::i {this a} {} - virtual proc a::j {this a} - virtual proc a::k {this a} {} - class b {} - proc b::b {this} a {} {} - proc b::~b {this} {} - proc b::f {this a} { - upvar $a d - set d(1) 1 - } - proc b::g {this a} { - upvar $a d - set d(2) 2 - } - virtual proc b::i {this a} {} - virtual proc b::j {this a} - virtual proc b::k {this a} { - upvar $a d - set d(3) 3 - } - class c {} - proc c::c {this} b {} {} - proc c::~c {this} {} - proc c::i {this a} { - upvar $a d - set d(4) 4 - } - proc c::j {this a} { - upvar $a d - set d(5) 5 - } - set o [new c] - a::f $o z - a::g $o z - a::h $o z - a::i $o z - a::j $o z - a::k $o z - eval lappend ::result [dumpArrays z] - - class A { - proc A {this} {} - proc ~A {this} {} - virtual proc f {this a} {} - virtual proc g {this a} - virtual proc h {this a} { - upvar $a d - set d(0) 0 - } - virtual proc i {this a} {} - virtual proc j {this a} - virtual proc k {this a} {} - } - class B { - proc B {this} A {} {} - proc ~B {this} {} - proc f {this a} { - upvar $a d - set d(1) 1 - } - proc g {this a} { - upvar $a d - set d(2) 2 - } - virtual proc i {this a} {} - virtual proc j {this a} - virtual proc k {this a} { - upvar $a d - set d(3) 3 - } - } - class C { - proc C {this} B {} {} - proc ~C {this} {} - proc i {this a} { - upvar $a d - set d(4) 4 - } - proc j {this a} { - upvar $a d - set d(5) 5 - } - } - set o [new C] - A::f $o Z - A::g $o Z - A::h $o Z - A::i $o Z - A::j $o Z - A::k $o Z - eval lappend ::result [dumpArrays Z] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {z(0) = 0}\ - {z(1) = 1}\ - {z(2) = 2}\ - {z(3) = 3}\ - {z(4) = 4}\ - {z(5) = 5}\ - {Z(0) = 0}\ - {Z(1) = 1}\ - {Z(2) = 2}\ - {Z(3) = 3}\ - {Z(4) = 4}\ - {Z(5) = 5}\ -] - -test stooop-93 { - check that member procedure invocation within constructor does not break - procedure checking debug mode -} { - set interpreter [interp create] - $interpreter eval { - # reset any existing environment variables: - foreach name [array names env STOOOP*] {unset env($name)} - set env(STOOOPCHECKPROCEDURES) 1 - } - $interpreter eval "source $source; namespace import stooop::*" - set result [$interpreter eval { - class a {} - proc a::a {this} { - p $this - q - } - proc a::~a {this} {} - proc a::p {this} {} - proc a::q {} {} - new a - - class A { - proc A {this} { - p $this - q - } - proc ~A {this} {} - proc p {this} {} - proc q {} {} - } - new A - - class b {} - class b::c {} - proc b::c::c {this} { - p $this - q - } - proc b::c::~c {this} {} - proc b::c::p {this} {} - proc b::c::q {} {} - new b::c - - class B { - class C { - proc C {this} { - p $this - q - } - proc ~C {this} {} - proc p {this} {} - proc q {} {} - } - } - new B::C - - set ::result {} - }] - interp delete $interpreter - set result -} {} - -test stooop-94 { - basic objects checking -} { - set interpreter [interp create] - $interpreter eval { - # reset any existing environment variables: - foreach name [array names env STOOOP*] {unset env($name)} - set env(STOOOPCHECKOBJECTS) 1 - } - $interpreter eval "source $source; namespace import stooop::*" - # alias puts to be able to collect standard output data: - proc appendResult {string} {lappend ::result $string} - $interpreter alias puts appendResult - set result {} - $interpreter eval { - class a {} - proc a::a {this} {} - proc a::~a {this} {} - proc p {} { - new a - } - namespace eval n { - proc p {} { - new a - } - } - stooop::record - new a - stooop::report - p - stooop::report - n::p - stooop::report - stooop::record - delete 1 - stooop::report - delete 2 - stooop::report - delete 3 - stooop::report - - class A { - proc A {this} {} - proc ~A {this} {} - } - proc q {} { - new A - } - namespace eval m { - proc q {} { - new A - } - } - stooop::record - new A - stooop::report - q - stooop::report - m::q - stooop::report - stooop::record - delete 4 - stooop::report - delete 5 - stooop::report - delete 6 - stooop::report - } - interp delete $interpreter - set result -} [list\ - {stooop::record invoked from top level}\ - {stooop::report invoked from top level:}\ - {+ ::a(1) + top level}\ - {stooop::report invoked from top level:}\ - {+ ::a(1) + top level}\ - {+ ::a(2) + ::p}\ - {stooop::report invoked from top level:}\ - {+ ::a(1) + top level}\ - {+ ::a(2) + ::p}\ - {+ ::a(3) + ::n::p}\ - {stooop::record invoked from top level}\ - {stooop::report invoked from top level:}\ - {- ::a(1) - top level + top level}\ - {stooop::report invoked from top level:}\ - {- ::a(1) - top level + top level}\ - {- ::a(2) - top level + ::p}\ - {stooop::report invoked from top level:}\ - {- ::a(1) - top level + top level}\ - {- ::a(2) - top level + ::p}\ - {- ::a(3) - top level + ::n::p}\ - {stooop::record invoked from top level}\ - {stooop::report invoked from top level:}\ - {+ ::A(4) + top level}\ - {stooop::report invoked from top level:}\ - {+ ::A(4) + top level}\ - {+ ::A(5) + ::q}\ - {stooop::report invoked from top level:}\ - {+ ::A(4) + top level}\ - {+ ::A(5) + ::q}\ - {+ ::A(6) + ::m::q}\ - {stooop::record invoked from top level}\ - {stooop::report invoked from top level:}\ - {- ::A(4) - top level + top level}\ - {stooop::report invoked from top level:}\ - {- ::A(4) - top level + top level}\ - {- ::A(5) - top level + ::q}\ - {stooop::report invoked from top level:}\ - {- ::A(4) - top level + top level}\ - {- ::A(5) - top level + ::q}\ - {- ::A(6) - top level + ::m::q}\ -] - -test stooop-95 { - objects checking from namespace body and namespace procedure -} { - set interpreter [interp create] - $interpreter eval { - # reset any existing environment variables: - foreach name [array names env STOOOP*] {unset env($name)} - set env(STOOOPCHECKOBJECTS) 1 - } - $interpreter eval "source $source; namespace import stooop::*" - # alias puts to be able to collect standard output data: - proc appendResult {string} {lappend ::result $string} - $interpreter alias puts appendResult - set result {} - $interpreter eval { - class a { - proc a {this} {} - proc ~a {this} {} - } - namespace eval n { - proc p {} { - new a - } - namespace eval m { - proc q {} { - new a - } - } - } - stooop::record - namespace eval n { - new a - } - stooop::report - n::p - stooop::report - namespace eval n::m { - new a - } - stooop::report - n::m::q - stooop::report - delete 1 2 3 4 - } - interp delete $interpreter - set result -} [list\ - {stooop::record invoked from top level}\ - {stooop::report invoked from top level:}\ - {+ ::a(1) + namespace ::n}\ - {stooop::report invoked from top level:}\ - {+ ::a(1) + namespace ::n}\ - {+ ::a(2) + ::n::p}\ - {stooop::report invoked from top level:}\ - {+ ::a(1) + namespace ::n}\ - {+ ::a(2) + ::n::p}\ - {+ ::a(3) + namespace ::n::m}\ - {stooop::report invoked from top level:}\ - {+ ::a(1) + namespace ::n}\ - {+ ::a(2) + ::n::p}\ - {+ ::a(3) + namespace ::n::m}\ - {+ ::a(4) + ::n::m::q}\ -] - -test stooop-96 { - objects checking from within derived class constructor -} { - set interpreter [interp create] - $interpreter eval { - # reset any existing environment variables: - foreach name [array names env STOOOP*] {unset env($name)} - set env(STOOOPCHECKOBJECTS) 1 - } - $interpreter eval "source $source; namespace import stooop::*" - # alias puts to be able to collect standard output data: - proc appendResult {string} {lappend ::result $string} - $interpreter alias puts appendResult - set result {} - $interpreter eval { - class a { - proc a {this i} {} - proc ~a {this} {} - } - class b { - proc b {this} a {[new c]} {} - proc ~b {this} {} - } - class c { - proc c {this} {} - proc ~c {this} {} - } - stooop::record - new b - stooop::report - - class A { - class a { - proc a {this i} {} - proc ~a {this} {} - } - class b { - proc b {this} a {[new c]} {} - proc ~b {this} {} - } - class c { - proc c {this} {} - proc ~c {this} {} - } - stooop::record - new b - stooop::report - } - - } - interp delete $interpreter - set result -} [list\ - {stooop::record invoked from top level}\ - {stooop::report invoked from top level:}\ - {+ ::b(1) + top level}\ - {+ ::c(2) + ::b::b}\ - {stooop::record invoked from namespace ::A}\ - {stooop::report invoked from namespace ::A:}\ - {+ ::A::b(3) + namespace ::A}\ - {+ ::c(4) + ::A::b::b}\ -] - -test stooop-97 { - objects checking with debugging procedures invocation from namespace body - and namespace procedure -} { - set interpreter [interp create] - $interpreter eval { - # reset any existing environment variables: - foreach name [array names env STOOOP*] {unset env($name)} - set env(STOOOPCHECKOBJECTS) 1 - } - $interpreter eval "source $source; namespace import stooop::*" - # alias puts to be able to collect standard output data: - proc appendResult {string} {lappend ::result $string} - $interpreter alias puts appendResult - set result {} - $interpreter eval { - class a { - proc a {this} {} - proc ~a {this} {} - } - namespace eval n { - proc p {} { - stooop::record - new a - stooop::report - } - namespace eval m { - proc q {} { - stooop::record - new a - stooop::report - } - } - } - n::p - n::m::q - namespace eval n { - stooop::record - new a - stooop::report - } - - } - interp delete $interpreter - set result -} [list\ - {stooop::record invoked from ::n::p}\ - {stooop::report invoked from ::n::p:}\ - {+ ::a(1) + ::n::p}\ - {stooop::record invoked from ::n::m::q}\ - {stooop::report invoked from ::n::m::q:}\ - {+ ::a(2) + ::n::m::q}\ - {stooop::record invoked from namespace ::n}\ - {stooop::report invoked from namespace ::n:}\ - {+ ::a(3) + namespace ::n}\ -] - -test stooop-98 { - objects checking with missing and extra objects -} { - set interpreter [interp create] - $interpreter eval { - # reset any existing environment variables: - foreach name [array names env STOOOP*] {unset env($name)} - set env(STOOOPCHECKOBJECTS) 1 - } - $interpreter eval "source $source; namespace import stooop::*" - # alias puts to be able to collect standard output data: - proc appendResult {string} {lappend ::result $string} - $interpreter alias puts appendResult - set result {} - $interpreter eval { - class a { - proc a {this} {} - proc ~a {this} {} - } - stooop::record - set o [new a] - stooop::report - stooop::record - delete $o - stooop::report - - } - interp delete $interpreter - set result -} [list\ - {stooop::record invoked from top level}\ - {stooop::report invoked from top level:}\ - {+ ::a(1) + top level}\ - {stooop::record invoked from top level}\ - {stooop::report invoked from top level:}\ - {- ::a(1) - top level + top level}\ -] - -test stooop-99 { -} { - set interpreter [interp create] - $interpreter eval { - # reset any existing environment variables: - foreach name [array names env STOOOP*] {unset env($name)} - set env(STOOOPCHECKOBJECTS) 1 - } - $interpreter eval "source $source; namespace import stooop::*" - # alias puts to be able to collect standard output data: - proc appendResult {string} {lappend ::result $string} - $interpreter alias puts appendResult - set result {} - $interpreter eval { - class a {} - proc a::a {this} {} - proc a::~a {this} {} - proc p {} { - new a - } - namespace eval n { - proc p {} { - new a - } - } - stooop::printObjects - new a - stooop::printObjects - p - stooop::printObjects - n::p - stooop::printObjects - delete 1 - stooop::printObjects - delete 2 - stooop::printObjects - delete 3 - stooop::printObjects - - class A { - proc A {this} {} - proc ~A {this} {} - } - proc q {} { - new A - } - namespace eval m { - proc q {} { - new A - } - } - stooop::printObjects - new A - stooop::printObjects - q - stooop::printObjects - m::q - stooop::printObjects - delete 4 - stooop::printObjects - delete 5 - stooop::printObjects - delete 6 - stooop::printObjects - - } - interp delete $interpreter - set result -} [list\ - {stooop::printObjects invoked from top level:}\ - {stooop::printObjects invoked from top level:}\ - {::a(1) + top level}\ - {stooop::printObjects invoked from top level:}\ - {::a(1) + top level}\ - {::a(2) + ::p}\ - {stooop::printObjects invoked from top level:}\ - {::a(1) + top level}\ - {::a(2) + ::p}\ - {::a(3) + ::n::p}\ - {stooop::printObjects invoked from top level:}\ - {::a(2) + ::p}\ - {::a(3) + ::n::p}\ - {stooop::printObjects invoked from top level:}\ - {::a(3) + ::n::p}\ - {stooop::printObjects invoked from top level:}\ - {stooop::printObjects invoked from top level:}\ - {stooop::printObjects invoked from top level:}\ - {::A(4) + top level}\ - {stooop::printObjects invoked from top level:}\ - {::A(4) + top level}\ - {::A(5) + ::q}\ - {stooop::printObjects invoked from top level:}\ - {::A(4) + top level}\ - {::A(5) + ::q}\ - {::A(6) + ::m::q}\ - {stooop::printObjects invoked from top level:}\ - {::A(5) + ::q}\ - {::A(6) + ::m::q}\ - {stooop::printObjects invoked from top level:}\ - {::A(6) + ::m::q}\ - {stooop::printObjects invoked from top level:}\ -] - -test stooop-100 { - objects checking pattern matching -} { - set interpreter [interp create] - $interpreter eval { - # reset any existing environment variables: - foreach name [array names env STOOOP*] {unset env($name)} - set env(STOOOPCHECKOBJECTS) 1 - } - $interpreter eval "source $source; namespace import stooop::*" - # alias puts to be able to collect standard output data: - proc appendResult {string} {lappend ::result $string} - $interpreter alias puts appendResult - set result {} - $interpreter eval { - class aa { - proc aa {this} {} - proc ~aa {this} {} - } - class ab { - proc ab {this} {} - proc ~ab {this} {} - } - class bb { - proc bb {this} {} - proc ~bb {this} {} - } - stooop::record - new aa - new ab - new bb - stooop::printObjects ::a* - stooop::printObjects ::*b - stooop::report ::a* - stooop::report ::*b - stooop::record - delete 1 2 3 - stooop::report ::a* - stooop::report ::*b - - } - interp delete $interpreter - set result -} [list\ - {stooop::record invoked from top level}\ - {stooop::printObjects invoked from top level:}\ - {::aa(1) + top level}\ - {::ab(2) + top level}\ - {stooop::printObjects invoked from top level:}\ - {::ab(2) + top level}\ - {::bb(3) + top level}\ - {stooop::report invoked from top level:}\ - {+ ::aa(1) + top level}\ - {+ ::ab(2) + top level}\ - {stooop::report invoked from top level:}\ - {+ ::ab(2) + top level}\ - {+ ::bb(3) + top level}\ - {stooop::record invoked from top level}\ - {stooop::report invoked from top level:}\ - {- ::aa(1) - top level + top level}\ - {- ::ab(2) - top level + top level}\ - {stooop::report invoked from top level:}\ - {- ::ab(2) - top level + top level}\ - {- ::bb(3) - top level + top level}\ -] - -test stooop-101 { - check that new lines within base class constructors arguments work without - spacing -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this p q} { - set ($this,m) $p - set ($this,n) $q - } - class b {} - proc b::b {this p q r} a { - $p - $q - } { - set ($this,o) $r - } - new b {x y} z {1 2} - eval lappend ::result [dumpArrays a:: b::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::(1,_derived) = ::b}\ - {a::(1,m) = x y}\ - {a::(1,n) = z}\ - {b::(1,o) = 1 2}\ -] - -test stooop-102 { - check that new lines within base class constructors arguments work without - spacing, with a DOS formatted file -} { - set interpreter [interp create] - $interpreter eval "source $source; namespace import stooop::*" - $interpreter eval $dumpArraysCode - set result [$interpreter eval { - class a {} - proc a::a {this p q} { - set ($this,m) $p - set ($this,n) $q - } - class b {} - proc b::b {this p q r} a { - $p - $q - } { - set ($this,o) $r - } - new b {x y} z {1 2} - eval lappend ::result [dumpArrays a:: b::] - - set ::result - }] - interp delete $interpreter - set result -} [list\ - {a::(1,_derived) = ::b}\ - {a::(1,m) = x y}\ - {a::(1,n) = z}\ - {b::(1,o) = 1 2}\ -] - - -cleanupTests -return DELETED modules/stooop/stooop_man.html Index: modules/stooop/stooop_man.html ================================================================== --- modules/stooop/stooop_man.html +++ /dev/null @@ -1,1180 +0,0 @@ - - - - - - stooop (Simple Tcl Only Object Oriented Programming) - - - -

stooop

- -

(Simple Tcl Only Object Oriented Programming)

- -Stooop is an extension to the great Tcl language written in Tcl itself. The object oriented features of stooop are modeled after the C++ programming language while following the Tcl language philosophy. - -

Contents

- - - -

About this document

- -This document contains general information, reference information and many examples designed to help the programmer understand and use the stooop extension (version 4.1.1 and above). - -

A working knowledge of object oriented programming techniques and a related programming language (C++, Java, ...) significantly helps understand this document. - -

Introduction

- -After some time writing Tcl/Tk code, I felt that I needed a way to improve the structure of my code, and why not use an object oriented approach, since I knew (but does anybody really? :-) C++. As I have used Tcl quite extensively in several commercial applications running on different operating systems and hardware, I decided to use a strict Tcl implementation for my object oriented extension. Consequently, stooop is compatible with all the Tcl ports (UNIX, Windows, MacIntosh). - -

Great care was taken so that this extension would no adverse impact on performance. Furthermore, designing your code in an object oriented should improve its performance, by focusing on well written pieces of reusable code. - -

Stooop only introduces a few new commands: class, new, delete, virtual and classof. Along with a few coding conventions, that is basically all you need to know to use stooop. Stooop is meant to be as simple to use as possible. - -

Starting with stooop version 3.2, nested classes are supported (see class), whereas version 3.3 and above support procedure and data members checking as well as tracing (see debugging). - -

Tcl version 8.2 and above supports the empty name array syntax, as in: - -

set (m) 0 ;# set member m of array {} to 0
-set n $(m) ;# which actually sets n to 0
- -This feature greatly simplifies class member manipulation in stooop classes and significantly improves performance. Stooop version 4.0 and above also uses this feature internally for further improvements, without sacrificing backward compatibility: code written against stooop versions 3.7 and below still works with stooop version 4.0 and above, but can be gradually moved to the simpler syntax when convenient.
-Stooop 4.1 and above will only work out of the box with Tcl 8.3 and above. - -

Simple example

- -Let us start with a code sample that will give you some feeling on how stooop works: - -
package require stooop 4                                  ;# load stooop package
-namespace import stooop::*                ;# and import class, new, ... commands
- -
class shape {                                           ;# base class definition
-    proc shape {this x y} {                            ;# base class constructor
-        set ($this,x) $x                           ;# data member initialization
-        set ($this,y) $y
-    }
-    proc ~shape {this} {}                               ;# base class destructor
-    # pure virtual draw: must be implemented in derived classes
-    virtual proc draw {this}
-    virtual proc rotate {this angle} {}                 ;# do nothing by default
-}
-proc shape::move {this x y} {            ;# external member procedure definition
-    set ($this,x) $x
-    set ($this,y) $y
-    draw $this               ;# shape::draw invokes derived class implementation
-}
-
-class triangle {                                             ;# class definition
-    proc triangle {this x y} shape {$x $y} {               ;# derived from shape
-        # triangle constructor implementation
-    }
-    proc ~triangle {this} {}
-    proc draw {this} {
-        # triangle specific implementation
-    }
-    proc rotate {this angle} {
-        # triangle specific implementation
-    }
-}
-
-class circle {}        ;# empty class definition, procedures are defined outside
-proc circle::circle {this x y} shape {$x $y} {             ;# derived from shape
-    # circle constructor implementation
-}
-proc circle::~circle {this} {}
-proc circle::draw {this} {
-    # circle specific implementation
-}
-# circle::rotate procedure is a noop, no need to overload
-
-lappend shapes [new circle 20 20] [new triangle 80 20]
-foreach object $shapes {
-    shape::draw $object
-    shape::rotate $object 45
-}
-eval delete $shapes
- -

Coding conventions

- -I have tried to make stooop Tcl code look like C++ code. There are exceptions of course. - -

Class definition

- -The syntax is very simple: - -
class className { ...
- -

The member procedures are then defined, inside or outside the class definition (see below). Note that the base classes if any are defined within the constructor declaration where they are required for eventually passing constructor parameters, not in the actual class declaration where they would then be redundant. - -

As a class is a namespace, it is just as easy to nest classes as it is namespaces. - -

Member procedures

- -They can be defined inside or outside their class definition. When defined inside the class definition, the class name qualifier (shape:: for example) before the procedure name must be omitted (a class is a Tcl namespace). When defined outside the class definition, the class name qualifier must be present (same reason). You may notice that the class definition and the related member procedures look very much like the Tcl namespace feature: it is because classes are indeed namespaces with a few more features added to support object orientation. - -

Member procedures are named as in C++ (for example, the rotate procedure of the class shape is referred to as shape::rotate in the global namespace). They are defined using the Tcl proc command, which is redefined by stooop in order to do some specific additional processing. Of course, global level and other namespaces procedures are not affected by stooop. - -

Constructor
- -A constructor is used to initialize an object of its class. The constructor is invoked by the new operator when an object of the class is created (instanciated in OO terms). The constructor is named as in C++ (for example, the shape constructor fully qualified name is shape::shape). - -

The constructor always takes the object identifier (a unique value generated by the command new) as the first parameter, plus eventually additional parameters as in the normal Tcl proc command. Arguments with default values are allowed, and so are variable number of arguments (see below). In all cases, the first parameter must be named this. - -

Note: the object identifier is a unique integer value which is internally incremented by stooop each time a new object is created. Consequently, the greater the object identifier, the younger the object. - -

Sample code of a constructor of a simple class with no base class: - -

class shape {
-    proc shape {this x y} {
-        # implementation here
-    }
-}
- -If a class is derived from one or more base classes, the derived class constructor defines the base classes and their constructor arguments before the actual body of the constructor. - -

Note: base classes are not defined at the class command level, because it would be redundant with the constructor definition, which is mandatory. - -

The derived class constructor parameters are followed by "base class names / constructor arguments" pairs. For each base class, there must be a corresponding list of constructor arguments to be used when the object is constructed when the new operator is invoked with the derived class name as argument. - -

Sample code for a class constructor with a single base class: - -

class circle {}
-proc circle::circle {this x y} shape {$x $y} {
-    # circle constructor implementation
-}
- -Sample code for a class constructor with multiple base classes: - -
class hydroplane {
-    proc hydroplane {this wingspan length} plane {
-        $wingspan $length
-    } boat {
-        $length
-    {
-        # constructor implementation
-    }
-}
- -The base class constructor arguments must be prefixed with dollar signs since they will be evaluated at the time the object is constructed, right before the base class constructor is invoked. This technique allows, as in C++, some actual processing to be done on the base class arguments at construction time. The this argument to the base class constructor must not be specified for it is automatically generated by stooop. - -

Sample code for a derived class constructor with base class constructor arguments processing: - -

class circle {
-    proc circle {this x y} shape {
-        [expr round($x)] [expr round($y)]
-    } {
-        # constructor implementation
-    }
-}
- -The base class(es) constructor(s) is(are) automatically invoked before the derived class constructor body is evaluated. Thus layered object construction occurs in the same order as in C++. - -

Variable length arguments are a special case and depend on both the derived class constructor arguments and those of the base class. - -

If both derived and base class constructors take a variable number of arguments (through the args special argument (see Tcl proc manual page)), the base class constructor will also see the variable arguments part as separate arguments. In other words, the following works as expected: - -

class base {}
-proc base::base {this parameter args} {
-    array set options $args
-}
-class derived {}
-proc derived::derived {this parameter args} base {
-    $parameter $args
-} {}
-new derived someData -option value -otherOption otherValue
- -Actually, if you want to get fancy, to allow some processing on the derived class constructor variable arguments, the last element (and only the last) of the derived class constructor arguments is considered variable if it contains the string $args. For example: - -
class base {
-    proc base {this parameter args} {
-        array set options $args
-    }
-}
-class derived {
-    proc derived {this parameter args} base {
-        $parameter [process $args]
-    } {}
-    proc process {arguments} {
-        # do some processing on arguments list
-        return $arguments
-    }
-}
-new derived someData -option value -otherOption otherValue
- -
Destructor
- -The destructor is used to clean up an object before it is removed from memory. The destructor is invoked by the delete operator when an object of the class is deleted. The destructor is named as in C++ (for example, the shape constructor fully qualified name is shape::~shape). - -

The destructor always takes the object identifier (a unique value previously generated and returned by the operator new) as the only parameter, which must be named this. - -

The base class(es) destructor(s) is(are) invoked at the end of the derived class destructor body. Thus layered object destruction occurs in the same order as in C++. - -

Sample code of a class destructor: - -

class shape {
-    proc ~shape {this} {
-        # implementation here
-    }
-}
- -Contrary to C++, a destructor cannot (nor does it need to) be virtual. Even if it does nothing, a destructor must always be defined. - -
Non static
- -A non static member procedure performs some action on an object of a class. The member procedure is named as a member function in C++ (for example, the shape class move member procedure is known as shape::move in the Tcl global namespace). - -

The member procedure always takes the object identifier (a unique value generated and returned by the operator new) as the first parameter, plus eventually additional parameters as in the normal Tcl proc command. Arguments with default values are allowed, and so are variable number of arguments. In all cases, the first parameter must be named this. - -

Sample code of a member procedure: - -

proc shape::move {this x y} {
-    set ($this,x) $x
-    set ($this,y) $y
-    draw $this       ;# invoke another member procedure
-}
- -A non static member procedure may be a virtual procedure. - -
Static
- -A static member procedure performs some action independently of the individual objects of a class. The member procedure is named as a member function in C++ (for example, the shape class add static member procedure is defined as shape::add outside its class definition, add inside). - -

However, with stooop, there is no static specifier: a member procedure is considered static if its first parameter is not named this. Arguments to the procedure are allowed as in the normal Tcl proc command. Arguments with default values are also allowed, and so are variable number of arguments. - -

Sample code of a static member procedure: - -

proc shape::add {newShape} {
-    # append new shape to global list of shape
-    lappend ($shapes) $newShape
-}
- -Often, static member procedures access static member data (see Static Member Data). - -

A static member procedure may not be a virtual procedure. - -

Copy constructor
- -Note: if you never create objects by copying (which is generally the case), you can skip this section. - -

Let us start by making it clear that stooop generates a default copy constructor whenever a class main constructor is defined. This default copy constructor just performs a simple per data member copy, as does C++. - -

The user defined class copy constructor is optional as in C++. If it exists, it will be invoked (instead of the default copy constructor) when the operator new is invoked on an object of the class or a derived class. - -

The copy constructor takes 2 arguments: the this object identifier used to initialize the data members of the object to be copied to, and the copy identifier of the object to be copied from, as in: - -

proc plane::plane {this copy} {
-    set ($this,wingspan) $($copy,wingspan)
-    set ($this,length) $($copy,length)
-    set ($this,engine) [new $($copy,engine)]
-}
- -As in regular member procedures, the first parameter name must be this, whereas the second parameter must be named copy to differentiate from the class constructor. In other words, the copy constructor always takes 2 and only 2 arguments (named this and copy). - -

The copy constructor must be defined when the default behavior (straightforward data members copy) (see the new operator) is not sufficient, as in the example above. It is most often used when the class object contains sub objects. As in C++ when sub objects are referenced through pointers, only the sub object identifiers (see them as pointers) are copied when an object is copied, not the objects they point to. It is then necessary to define a copy procedure that will actually create new sub objects instead of just defaulting to copying identifiers. - -

If the class has one or more base classes, then the copy constructor must pass arguments to the base class(es) constructor(s), just as the main constructor does, as in the following example: - -

class ship {
-    proc ship {this length} {}
-}
-class carrier {}
-proc carrier::carrier {this length} ship {$length} {}
-proc carrier::carrier {this copy} ship {
-    $ship::($copy,length)
-} {
-    set ship::($this,planes) {}
-    foreach plane $ship($copy,planes) {                   ;# copy all the planes
-        lappend ship($this,planes) [new $plane]
-    }
-}
- -The stooop library checks that the copy constructor properly initializes the base class(es) through its(their) constructor(s) by using the regular constructor as reference. Obviously and consequently, stooop also checks that the regular constructor is defined prior to the copy constructor. - -

If you use member arrays, you must copy them within the copy constructor, as they are not automatically handled by stooop, which only knows member data in the automatically generated default copy constructor. - -

Member data

- -All class and object data is stored in an associative array local to the class namespace (remember, a class is actually a namespace). The array name is empty, and the corresponding Tcl variable declaration is automatically inserted within class namespace and procedures (but you do not need to worry about this transparent operation). - -

Sample code: - -

class shape {}
-proc shape::shape {this x y} {
-    # set a few members of the class namespace empty named array
-    set ($this,x) $x
-    set ($this,y) $y
-    # now read them
-    puts "coordinates: $($this,x), $($this,y)"
-}
-In order to access other classes data, whether they are base classes or -not, a fully qualified name is always required, whereas no special declaration -(global, variable, ...) is required. -

Sample code: -

proc circle::circle {this x y diameter} shape {$x $y} {
-    set ($this,diameter) $diameter
-    puts "coordinates: $shape::($this,x), $shape::($this,y)"
-}
- -
Non static
- -Non static data is indexed within the class array by prepending the object identifier (return value of the new operator) to the actual member name. A comma is used to separate the identifier and the member name. - -

Much as an object pointer in C++ is unique, the object identifier in stooop is also unique. Access to any base class data is thus possible by directly indexing the base class array. - -

Sample code: - -

proc shape::shape {this x y} {
-    set ($this,x) $x
-    set ($this,y) $y
-}
-proc circle::circle {this x y diameter} shape {$x $y} {
-    set ($this,diameter) $diameter
-}
-proc circle::print {this} {
-    puts "circle $this data:"
-    puts "diameter: $($this,diameter)"
-    puts "coordinates: $shape::($this,x), $shape::($this,y)"
-}
- -
Static
- -Static (as in C++) data members are simply stored without prepending the object identifier to the member name, as in: - -
proc shape::register {newShape} {
-    lappend (list) $newShape ;# append new shape to global list of shapes
-}
- -

Commands

- -Only 4 new commands class, new, delete and virtual need to be known in order to use stooop. Furthermore, their meaning should be obvious to C++ programmers. There is also a classof command that you can use if you need RTTI (runtime type identification). - -

class

- -The class command introduces a new class declaration. - -

A class is also a namespace although you do not need to worry about it, but it does have some nice side effects. The following code works as expected: - -

class shape {
-    set (list) {} ;# initialize list of shapes, a static data member
-    proc shape {this x y} {
-        lappend (list) $this             ;# keep track of new shapes
-    }
-    ...
-}
- -This works because all data for the class (static and non static) is held in the empty named array, which the class command declares as a variable (see the corresponding Tcl command) for the class namespace and within every member procedure. - -

Starting with version 3.2, nested classes are allowed, which makes the following code possible: - -

class car {
-    proc car {this manufacturer type} {
-        set ($this,wheels) [list\
-            [new wheel 18] [new wheel 18] [new wheel 18] [new wheel 18]\
-        ]
-        ...
-    }
-    ...
-    class part {
-        ...
-    }
-    class wheel {
-        proc wheel {this diameter} car::part {} {
-            set ($this,diameter) $diameter
-            ...
-        }
-        proc print {this} {
-            puts "wheel of $($this,diameter) diameter"
-        }
-        ...
-    }
-}
- -There is quite a lot to say about the example above. - -

First, why would I use a nested class? Because it is cleaner that creating carPart and carWheel classes and saves on global namespace pollution. - -

Second, why does "new wheel" work from inside the car constructor? Because it invokes the wheel::wheel constructor, visible from the car namespace. - -

Third, why can't I simply derive wheel from part instead of car::part? Well, you must fully qualify the class that you derive from because the part::part constructor is not visible from within the wheel namespace. - -

Whenever you have a problem with nested classes, think in terms of namespaces, as classes are indeed namespaces (it should be clear to you by now :-). - -

new

- -The new operator is used to create an object of a class, either by explicit construction, or by copying an existing object. - -

When explicitly creating an object, the first argument is the class name and is followed by the arguments needed by the class constructor. New when invoked generates a unique identifier for the object to be created. This identifier is the value of the this parameter, first argument to the class constructor, which is invoked by new. - -

Sample code: - -

proc shape::shape {this x y} {
-    set ($this,x) $x
-    set ($this,y) $y
-}
-set object [new shape 100 50]
- -new generates a new object identifier, say 1234. shape constructor is then called, as in: - -
shape::shape 1234 100 50
- -If the class is derived from one or more base classes, the base class(es) constructor(s) will be automatically called in the proper order, as in: - -
proc hydroplane::hydroplane {this wingspan length} plane {
-    $wingspan $length
-} boat {
-    $length
-} {}
-set object [new hydroplane 10 7]
- -new generates a new object identifier, say 1234, plane constructor is called, as in: - -
plane::plane 1234 10 7
- -then boat constructor is called, as in: - -

boat::boat 1234 7 - -

finally hydroplane constructor is called, as in: - -

hydroplane::hydroplane 1234 10 7 - -

The new operator can also be used to copy objects when an object identifier is its only argument. A new object of the same class is then created, copy of the original object. - -

An object is copied by copying all its data members (but not including member arrays) starting from the base class layers. If the copy constructor procedure exists for any class layer, it is invoked by the new operator instead of the default data member copy procedure (see the copy constructor section for examples). - -

Sample code: - -

set plane [new plane 100 57 RollsRoyce]
-set planes [list $plane [new $plane] [new $plane]]
- -

delete operator

- -The delete operator is used to delete one or several objects. It takes one or more object identifiers as argument(s). Each object identifier is the value returned by new when the object was created. Delete invokes the class destructor for each object to be deleted. - -

Sample code: - -

proc shape::shape {this x y} {}
-proc shape::~shape {this} {
-
-proc triangle::triangle {this x y} shape {$x $y} {}
-proc triangle::~triangle {this} {}
-
-proc circle::circle {this x y} shape {$x $y} {}
-proc circle::~circle {this} {}
-
-set circle [new circle 100 50]
-set triangle [new triangle 200 50]
-delete $circle $triangle
- -circle identifier is set to, say 1234, triangle identifier is set to, say 1235. delete circle object first, circle destructor is invoked, as in: - -
circle::~circle 1234
- -then shape destructor is invoked, as in: - -

shape::~shape 1234 - -

then delete triangle object... - -

For each object class, if it is derived from one or more base classes, the base class(es) destructor(s) are automatically called in reverse order of the construction order for base class(es) constructor(s), as in C++. - -

If an error occurs during the deletion process, an error is returned and the remaining delete argument objects are left undeleted. - -

virtual specifier

- -The virtual specifier may be used on member procedures to achieve dynamic binding. A procedure in a base class can then be redefined (overloaded) in the derived class(es). - -

If the base class procedure is invoked on an object, it is actually the derived class procedure which is invoked, if it exists*. If the base class procedure has no body, then it is considered to be a pure virtual and the derived class procedure is always invoked. - -

* as in C++, virtual procedures invoked from the base class constructor result in the base class procedure being invoked, not the derived class procedure. In stooop, an error always occurs when pure virtual procedures are invoked from the base class constructor (whereas in C++, behavior is undefined).
-* but there is a small difference with C++ behavior: for a virtual procedure to keep his nature down the derived classes hierarchy, it must be defined at each derivation level. That is, the virtual nature may be lost, for example in indirectly derived classes (see example below). Fixing this difference would have a non negligible impact on performance for a small gain in usefulness. - -

Sample code: - -

class shape {
-    proc shape {this x y} {}
-    # pure virtual draw: must be implemented in derived classes
-    virtual proc draw {this}
-    virtual proc transform {this x y} {
-        # base implementation
-    }
-}
-class circle {}
-proc circle::circle {this x y} shape {$x $y} {}
-proc circle::draw {this} {
-    # circle specific implementation
-}
-proc circle::transform {this} {
-    shape::_transform $this ;# use base class implementation
-    # add circle specific implementation here...
-}
-
-lappend shapes [new circle 100 50]
-foreach object $shapes {
-    # draw and move each shape
-    shape::draw $object
-    shape::move $object 20 10
-}
- -It is possible to invoke a virtual procedure as a non virtual one, which is handy when the derived class procedure must use the base class procedure. In this case, directly invoking the virtual base class procedure would result in an infinite loop. The non virtual base class procedure name is simply the virtual procedure name with 1 underscore ( _ ) prepended to the member procedure name (see sample code above). - -

Constructors, destructors and static member procedures cannot be virtual. - -

Sample code highlighting small difference with C++: - -

class A {
-    proc A {this} {}
-    proc ~A {this} {}
-    virtual proc p {this} {puts A}
-}
-class B {
-    proc B {this} A {} {}
-    proc ~B {this} {}
-}
-class C {
-    proc C {this} B {}{}
-    proc ~C {this} {}
-    virtual proc p {this} {puts C}
-}
-
-set object [new C]
-A::p $object ;# prints "A" instead of "C"
-
-virtual proc B::p {this} {puts B}
-
-A::p $object ;# now prints "C"
- -

classof operator

- -The classof command takes an object identifier as its only argument. It returns the class name of the object (name used with new when the object was created). Thus if needed, RTTI (runtime type identification) can be used as in C++, for example to create "virtual constructors". - -
proc shape::shape {this x y} {}
-set id [new shape 100 50]
-puts "object $id class name is [classof $id]"
- -

Package

- -For general information about the Tcl (version 7.5 and above) package facilities, refer to the corresponding manual pages. - -

Installation

- -A pkgIndex.tcl file is provided so that stooop and the switched class can be installed as a package. Refer to the INSTALL file for complete instructions and examples. - -

Creation

- -Before creating a package that uses stooop, stooop itself must be installed as a package (see above). - -

If you have created an object oriented library which uses stooop, you may want to make a package out of it. Unfortunately, using the default Tcl pkg_mkIndex procedure (see the corresponding manual page) will not work. - -

Stooop checks that a base class constructor is defined before any of its derived classes constructors. Thus, the first time a derived class object is created, the base class definition file must be sourced to avoid an error. The specific mkpkgidx.tcl utility handles such cases and must be used to create stooop compatible package index files. - -

Let us suppose that you created a library with different classes spread in different source files: lib1.tcl, lib2.tcl, ..., libn.tcl. Of course, some of these files may contain base classes for derived classes in other files. As recommended in the pkg_mkIndex Tcl manual page, each source file should contain a package provide command (although it seems to be needed only in the first source file). For example, if your package name is foo and the version 1.2, the following line should appear around the beginning of each of the libn.tcl files: - -

package provide foo 1.2
- -It is now time to create the pkgIndex.tcl file, which is the missing piece for your foo package, with the mkpkgidx.tcl utility. The syntax is: - -
interpreter mkpkgidx.tcl packageName file [file ...]
- -where interpreter can be either tclsh or wish depending on whether your library uses Tk or not. - -

Enter the following command in the directory where the libn.tcl files reside: - -

$ tclsh mkpkgidx.tcl foo lib1.tcl lib2.tcl ... libn.tcl
- -or - -
$ wish mkpkgidx.tcl foo lib1.tcl lib2.tcl ... libn.tcl
- -For this to work, the source files must be ordered so that base classes are defined before any of their derived classes. If not the case, such errors are automatically caught by the stooop package index utility, which uses the stooop library itself. - -

If your package requires other packages and you do not wish to add the corresponding "package require" to your package source files, use the -p option, as in: - -

$ wish mkpkgidx.tcl -p ppp.1 -p qqq -p rrr.3.2 foo lib1.tcl lib2.tcl ... libn.tcl
- -Note that you may use as many -p option / value pairs as needed. Each package name is optionally followed by its version number after a . separator. If specified, the version number follows the same rules as the "package require" Tcl command. Of course, each specified package must be installed and working properly before attempting the mkpkgidx.tcl utility. - -

Once this is done, a pkgIndex.tcl file will have been created in the current directory. To install the package, enter for example: - -

$ mkdir /usr/local/lib/foo
-$ cp pkgIndex.tcl lib1.tcl lib2.tcl ... libn.tcl /usr/local/lib/foo/
- -You may of course install the foo package in another directory: refer to the pkg_mkIndex Tcl manual page for further instructions. - -

Now in order to use your newly created packaged library in your application, just insert the following 3 lines at the beginning of the application source file: - -

package require stooop
-namespace import stooop::*
-package require foo 1.2
- -

Examples

- -

Parallel with C++

- -For C++ programmers, this simple parallel with C++ may make things easier to understand. First without virtual functions: - -

C++: - -

    class className {
-    public:
-        someType someMember;
-        className(someType parameter)
-        {
-            someMember = parameter;
-        }
-        className(className &object)
-        {
-            ...
-        }
-        doSomething(someType parameter);
-        ~className(void) {
-            ...
-        }
-    };
-    someType className::doSomething(someType parameter)
-    {
-        ...
-    }
-    someType someValue;
-    className *someObject = new className(someValue);
-    someType a = someObject->doSomething(someValue);
-    someType b = someObject->someMember;
-    className *otherObject = new className(*someObject);
-    delete someObject;
- -(stooop'd up :) Tcl: - -
    class className {
-        proc className {this parameter} {
-            # new keeps track of object identifiers and passes a unique one
-            # to the constructor
-            set ($this,someMember) $parameter
-        }
-        proc className {this copy} {
-            # copy constructor
-            ...
-        }
-        proc ~className {this} {
-            # delete invokes this procedure then takes care of deallocating
-            # className array data members for this object identifier
-            ...
-        }
-    }
-    proc className::doSomething {this parameter} {
-        ...
-    }
-    set someObject [new className $someValue]
-    # invokes className::className
-    set a [className::doSomething $someObject $someValue]
-    set b $className::($someObject,someMember)
-    # copy object, className copy constructor is invoked
-    set otherObject [new $someObject]
-    delete $someObject
-    # invokes className::~className then frees members data
- -Now, with virtual functions: - -

C++: - -

    class baseClassName {
-    public:
-        virtual void doSomething(someType) {}
-        baseClassName(void) {}
-        virtual ~baseClassName(void) {}
-    };
-    class derivedClassName: public baseClassName {
-    public:
-        void doSomething(someType);
-        derivedClassName(void) {}
-        ~derivedClassName(void) {}
-    };
-    void derivedClassName::doSomething(someType parameter)
-    {
-        ...
-    }
-    derivedClassName *someObject = new derivedClassName();
-    someObject->doSomething(someValue);      // derived function actually called
-    cout << typeid(*someObject).name() << endl;       // print object class name
-    delete someObject;                        // derived destructor called first
- -Tcl with stooop: - -
    class baseClassName {
-        proc baseClassName {this} {
-            # sub-class is remembered so that virtual procedures may be used
-            ...
-        }
-        proc ~baseClassName {this} {
-            # cleanup at base level here...
-        }
-        virtual proc doSomething {this parameter} {
-            # derived class procedure with the same name may be invoked
-            # any code that follows is not executed if this procedure is
-            # overloaded in derived class
-            ...
-        }
-    }
-    class derivedClassName {
-        proc derivedClassName {this} baseClassName {} {
-            # base class constructor is automatically invoked
-            ...
-        }
-        proc ~derivedClassName {this} {
-            # cleanup at derived level here...
-            # base class destructor is automatically invoked
-        }
-    }
-    proc derivedClassName::doSomething {this parameter} {
-        # code that follows is executed when base class procedure is called
-        ...
-    }
-    set someObject [new derivedClassName]
-    # access object as base object, derived class procedure is actually invoked
-    baseClassName::doSomething $someObject $someValue
-    puts [classof $someObject]                        ;# print object class name
-    delete $someObject                                          ;# delete object
- -

Graphical demonstration

- -A demonstration using the Composite pattern from the great book Design Patterns, Elements of Reusable Object Oriented Software, which I heartily recommend. - -

The pattern is used to define a class hierarchy of the graphic base class, picture, oval and rectangle derived classes. A picture object can contain any number of other graphic objects, thus allowing graphical composition. - -

The following paragraphs drawn from the book best describe what the Composite pattern does: - -

Compose objects into tree structures to represent part-whole hierarchies. Composite lets clients treat individual objects and compositions of objects uniformly. - -

The key to the Composite pattern is an abstract class that represents both primitives and their containers. For the graphic system, this class is Graphic. Graphic declares operations like Draw that are specific to graphical objects. It also declares operations that all composite objects share, such as operations for accessing and managing its children. - -

Gamma/Helm/Johnson/Vlissides, DESIGN PATTERNS, ELEMENTS OF REUSABLE OBJECT-ORIENTED SOFTWARE, (c) 1995 by Addison-Wesley Publishing Company, Reprinted by permission of Addison-Wesley Publishing Company, Inc.

- -Instructions: - -

Run gdemo as in: - -

$ wish gdemo
- -Several buttons are placed below a canvas area. Picture, Rectangle and Oval are used to create Graphic objects. Clear is used to delete all the objects created so far, Exit is self explanatory. - -

A Picture object can contain any number of Graphic objects, such as other Picture objects, Rectangle objects, ... - -

For each Graphic object, the point used for moving and for the object coordinates is the upper left corner of the object. - -

First create a Picture object by clicking on the Picture button. Move the red rectangle that appears by drag clicking on any of its edges. Then create a Rectangle object by clicking on the Rectangle button. Drag the Rectangle object in the Picture object, it is then a child of the Picture object. - -

Move the Picture object to verify that its Rectangle child moves along. - -

Create another Picture object and place an Oval object within. - -

Move that Picture object to verify that its Oval child moves along. - -

Now move the upper left corner of that last Picture within the first Picture area. - -

Then move that Picture to verify that all the Graphic objects move along. - -

Widget class

- -A widget usually can take a variable number of option / value pairs as arguments when created and any time later when configured. It is a good application for the variable number of arguments technique. - -

Sample code (without error checking): - -

class widget {
-    proc widget {this parent args} {
-        # create Tk widget(s)
-        # set widget options default in an array
-        array set options {-background white -width 10}
-        array set options $args              ;# then overwrite with user options
-        eval configure $this [array get options]               ;# then configure
-    }
-    virtual proc configure {this args} {
-        foreach {option value} $args {
-            switch -- $option {
-                -background {             ;# filter widget specific options here
-                    set ($this,background) $value
-                    # configure Tk widget(s)
-                }
-                ...
-            }
-        }
-    }
-}
-
-class gizmo {}
-proc gizmo::gizmo {this parent args} widget {$parent $args} {
-    # create more Tk widget(s)
-    # set gizmo options default in an array
-    array set options {-spacetimecoordinates {0 0 0 now}}
-    array set options $args                  ;# then overwrite with user options
-    eval ownConfigure $this [array get options]                ;# then configure
-}
-proc gizmo::ownConfigure {this args} {
-    foreach {option value} $args {
-        switch -- $option {                ;# filter gizmo specific options here
-            -spacetimecoordinates {
-                set ($this,location) $value
-                # configure Tk widget(s)
-            }
-            ...
-        }
-    }
-}
-proc gizmo::configure {this args} {
-    eval ownConfigure $this $args                    ;# configure at gizmo level
-    eval widget::_configure $this $args             ;# configure at widget level
-}
-
-new gizmo . -width 20 -spacetimecoordinates {1p 10ly 2p 24.2y}
- -In this example, invalid (unknown) options are simply ignored. - -

Member array

- -You simply cannot use a member array, as member data is already held in an array. But you can use a namespace array, with a name specific to the object, including the object identifier. Just make sure the array is deleted in the destructor. - -

Sample code: - -

class container {
-    proc container {this} {}
-    proc ~container {this} {
-        variable ${this}data
-        unset ${this}data
-    }
-    proc container::add {this item id} {
-        variable ${this}data
-        set ${this}data($id) $item
-    }
-}
- -Memory management of the array is the programmer's responsibility, as is its duplication when copying objects. For example, use the following code if you ever copy objects with member arrays: - -
class container {
-    proc container {this} {                                  ;# main constructor
-        ...
-    }               ;# default copy constructor has been generated at this point
-    proc container {this copy} {      ;# copy constructor (replaces default one)
-        variable ${this}data
-        variable ${copy}data
-        array set ${this}data [array get ${copy}data]       ;# copy member array
-    }
-    ...
-}
- -

Utility classes

- -

switched

- -Note: if you have been using scwoop (a stooop based mega widget extension to the Tk widget library), you must certainly know about the composite class. The switched class is a generic (not widget oriented) derivative of the composite class. - -

Find the complete documentation here. - -

Debugging

- -As stooop is meant to be lean and fast, no checking is done during run-time, that is after all classes and their procedures have been defined. - -

Starting from version 3.3, debugging aids were added to the stooop library (still held in a single file). Member checking insures that basic object oriented concepts and rules are applied. Tracing provides means for member procedures and data access logging to a file or to the screen. - -

The above features are triggered and configured using environment variables. When not in use, they have absolutely no impact on stooop's performance (however, if you are really picky, you could say that since the stooop.tcl file has grown larger, load time got longer :). - -

Please note that any stooop debugging environment variable must be set prior to the stooop library being loaded: - -

$ STOOOPTRACEDATA=stdout
-$ export STOOOPTRACEDATA
-$ tclsh myfile.tcl
-around the beginning of myfile.tcl: -
...
-set env(STOOOPCHECKPROCEDURES) 1
-source stooop.tcl
-namespace import stooop::*
-set env(STOOOPCHECKDATA) 1
-...
- -In the example above, data tracing is enabled as well as procedure checking, but data checking is not turned on. - -

Member check

- -Both procedure and data member checking can be activated by setting the single environment variable STOOOPCHECKALL to a true value (1, true or on). Of course only one of those features can be activated as described below. - -

Note: if you have an idea about any other thing that could be checked in the following sections, please share it with me. - -

Procedure
- -Procedure checking is activated by setting the environment variable STOOOPCHECKPROCEDURES to a true value. The stooop library will then generate an error while the application is running in the following cases: - -
    -
  • an invalid this parameter (a non existing object identifier) is passed as argument to a non static member procedure -
  • the object identified by the this parameter passed as argument to a class non static member procedure is neither an instance of the procedure class nor an instance of a derived class (at any level of derivation) of the procedure class. -
  • a pure interface class (a class with at least 1 pure virtual member procedure) is instanciated -
- -
Data
- -Procedure checking is activated by setting the environment variable STOOOPCHECKDATA to a true value. The stooop library will then generate an error while the application is running in the following cases: - -
    -
  • in a class namespace but outside a member procedure, a data member of another class is written or unset -
  • in a class member procedure (static or not), a data member of another class is written or unset -
  • in a non static member procedure, a data member of an object different from the object identified by the this parameter passed as argument is written or unset -
- -

Member trace

- -Tracing is activated by setting a specific environment variable to either stdout, stderr or any file name that can be created and written to by the user. Setting the STOOOPTRACEALL variable enables both procedure and data tracing. Of course only one of those features can be activated as described below. - -
Procedure
- -Procedure tracing is activated by setting the environment variable STOOOPTRACEPROCEDURES to either stdout, stderr or a file name. The stooop library will then output to the specified channel 1 line of informational text for each member procedure invocation. - -

The user can define the output format by redefining the STOOOPTRACEPROCEDURESFORMAT (look at the beginning of the stooop.tcl file for the default format). The following substitutions will be performed prior to the output: - -

    -
  • %C by the fully qualified class name -
  • %c by the class name (tail of the fully qualified class name) -
  • %P by the fully qualified procedure name -
  • %p by the procedure name (tail of the fully qualified procedure name) -
  • %O by the object identifier (this value) -
  • %a by the remaining procedure arguments (not including this) -
- -At the time this document is being written, the default format is: - -
class: %C, procedure: %p, object: %O, arguments: %a
- -example output from the gdemo application: - -
class: picture, procedure: constructor, object: 1, arguments: .canvas
-class: graphic, procedure: constructor, object: 1, arguments: .canvas 1
-class: rectangle, procedure: constructor, object: 2, arguments: .canvas
-class: graphic, procedure: constructor, object: 2, arguments: .canvas 2
-class: graphic, procedure: moveTo, object: 2, arguments: 13 4
-class: graphic, procedure: _moveTo, object: 2, arguments: 13 4
-class: graphic, procedure: moveTo, object: 2, arguments: 18 9
-class: graphic, procedure: add, object: 1, arguments: 2
-class: picture, procedure: add, object: 1, arguments: 2
-class: graphic, procedure: add, object: 2, arguments: 2
-class: rectangle, procedure: add, object: 2, arguments: 2
-class: picture, procedure: destructor, object: 1, arguments:
-class: graphic, procedure: destructor, object: 1, arguments:
-class: rectangle, procedure: destructor, object: 2, arguments:
-class: graphic, procedure: destructor, object: 2, arguments:
- -
Data
- -Data tracing is activated by setting the environment variable STOOOPTRACEDATA to either stdout, stderr or a file name. The stooop library will then output to the specified channel 1 line of informational text for each member data access. By default, all read, write and unsetting accesses are reported, but the user can set the STOOOPTRACEDATAOPERATIONS environment variable to any combination of the r, w and u letters for more specific tracing (please refer to the trace Tcl manual page for more information). - -

Note that operations internal to the stooop library, such as automatic unsetting of data members during objects destruction do not appear in the trace. - -

The user can define the output format by redefining the STOOOPTRACEDATAFORMAT (look at the beginning of the stooop.tcl file for the default format). The following substitutions will be performed prior to the output: - -

    -
  • %C by the fully qualified class name -
  • %c by the class name (tail of the fully qualified class name) -
  • %P by the fully qualified procedure name -
  • %p by the procedure name (tail of the fully qualified procedure name) -
  • %A by the fully qualified array name -
  • %m by the data member name (right after the this, array name part for a non static data member) -
  • %O by the object identifier (this value or empty for a static procedure) -
  • %o by the access operation (read, write or unset) -
  • %v by the new or current value (empty for an unset operation) -
- -At the time this document is being written, the default format is: - -
class: %C, procedure: %p, array: %A, object: %O, member: %m, operation: %o, value: %v
- -example output from the gdemo application: - -
class: graphic, procedure: constructor, array: graphic::, object: 1, member: canvas, operation: write, value: .canvas
-class: graphic, procedure: constructor, array: graphic::, object: 1, member: item, operation: write, value: 1
-class: picture, procedure: constructor, array: picture::, object: 1, member: graphics, operation: write, value: 
-class: picture, procedure: moveTo, array: graphic::, object: 1, member: canvas, operation: read, value: .canvas
-class: picture, procedure: moveTo, array: graphic::, object: 1, member: item, operation: read, value: 1
-class: picture, procedure: moveBy, array: picture::, object: 1, member: graphics, operation: read, value: 
-class: graphic, procedure: _moveBy, array: graphic::, object: 1, member: canvas, operation: read, value: .canvas
-class: graphic, procedure: _moveBy, array: graphic::, object: 1, member: item, operation: read, value: 1
-class: graphic, procedure: constructor, array: graphic::, object: 2, member: canvas, operation: write, value: .canvas
-class: graphic, procedure: constructor, array: graphic::, object: 2, member: item, operation: write, value: 2
-class: graphic, procedure: _moveTo, array: graphic::, object: 2, member: canvas, operation: read, value: .canvas
-class: graphic, procedure: _moveTo, array: graphic::, object: 2, member: item, operation: read, value: 2
-class: graphic, procedure: _moveTo, array: graphic::, object: 2, member: canvas, operation: read, value: .canvas
-class: graphic, procedure: _moveTo, array: graphic::, object: 2, member: item, operation: read, value: 2
-class: graphic, procedure: _moveTo, array: graphic::, object: 2, member: canvas, operation: read, value: .canvas
-class: graphic, procedure: _moveTo, array: graphic::, object: 2, member: item, operation: read, value: 2
-class: graphic, procedure: _moveTo, array: graphic::, object: 2, member: canvas, operation: read, value: .canvas
-class: graphic, procedure: _moveTo, array: graphic::, object: 2, member: item, operation: read, value: 2
-class: picture, procedure: add, array: graphic::, object: 1, member: canvas, operation: read, value: .canvas
-class: picture, procedure: add, array: graphic::, object: 1, member: item, operation: read, value: 2
-class: picture, procedure: add, array: graphic::, object: 1, member: canvas, operation: read, value: .canvas
-class: picture, procedure: add, array: graphic::, object: 1, member: item, operation: read, value: 1
-class: graphic, procedure: destructor, array: graphic::, object: 1, member: canvas, operation: read, value: .canvas
-class: graphic, procedure: destructor, array: graphic::, object: 1, member: item, operation: read, value: 1
-class: graphic, procedure: destructor, array: graphic::, object: 2, member: canvas, operation: read, value: .canvas
-class: graphic, procedure: destructor, array: graphic::, object: 2, member: item, operation: read, value: 2
- -

Objects

- -Objects checking can be activated by setting the single environment variable STOOOPCHECKOBJECTS to a true value. The following stooop namespace procedures then become available for debugging; printObjects, record and report. - -

Before outputting any data, all the object checking procedures print which procedure they were invoked from, or the namespace name if invoked from a namespace body or "top level" if invoked outside any procedure or namespace. - -

Printing
- -The stooop::printObjects procedure when invoked prints an ordered list of existing objects with their creation location (a fully qualified procedure name or "top level") after a + sign. The objects are printed in creation order, with the oldest (lowest identifier) first. The printObjects procedure takes an optional class pattern (as in the Tcl "array names" or "string match" commands) for limiting the output to objects of certain classes, as the following example shows (classes are assumed to exist and be valid): - -
% new foo
-1
-% stooop::printObjects
-stooop::printObjects invoked from top level:
-::foo(1) + top level
-% new bar
-2
-% stooop::printObjects
-stooop::printObjects invoked from top level:
-::foo(1) + top level
-::bar(2) + top level
-% new Foo
-3
-% stooop::printObjects ::?oo
-stooop::printObjects invoked from top level:
-::foo(1) + top level
-::Foo(3) + top level
-% new barmaid
-4
-% stooop::printObjects ::bar*
-stooop::printObjects invoked from top level:
-::bar(2) + top level
-::barmaid(4) + top level
- -Please note that all object classes are always fully qualified, so do not forget about the :: header in the patterns. - -
Recording
- -By invoking the stooop::record procedure, you take a snapshot of all existing stooop objects at the time of invocation. Reporting can then be used at a later time to see which objects were created or deleted in the interval. - -

The record procedure does not take any arguments and it only prints its context of invocation. - -

Reporting
- -The stooop::report procedure prints the created and deleted objects since the stooop::record procedure was invoked last. It optionally takes a pattern argument in order to limit the output to a specific set of classes, as for the printObjects procedure. A + sign is placed at the beginning of each created object description line in the output trace, followed by another + sign and the creation location (a fully qualified procedure name or "top level"). A - sign is placed at the beginning of each deleted object description line in the output trace, followed by another - sign, the deletion location (a fully qualified procedure name or "top level"), a + sign and the creation location (a fully qualified procedure name or "top level"). - -

Reporting is typically used between 2 spots in the debugged application code: the first spot where a bunch of objects (which can include sub objects) are created, the second spot where all or most of these objects are supposed to be deleted. On the first spot, stooop::record is invoked whereas on the second spot, the stooop::report invocation will print the created and/or deleted objects, in other words the "object difference" between the 2 spots. In most cases, the programmer would expect a difference of 0 objects, sign of a well behaved application, memory wise. - -

Consider the following example: - -

class foo {
-    proc foo {this} {}
-    proc ~foo {this} {}
-}
-class bar {
-    proc bar {this} {
-        new foo
-    }
-    proc ~bar {this} {}
-}
-stooop::record
-delete [new bar]
-stooop::report
-stooop::record
-delete 2
-stooop::report
- -It gives the following result: - -
stooop::record invoked from top level
-stooop::report invoked from top level:
-+ ::foo(2) + ::bar::bar
-stooop::record invoked from top level
-stooop::report invoked from top level:
-- ::foo(2) - top level + ::bar::bar
- -Examining the printout, one can see that the bar class does not properly clean things up as the foo sub object is left undeleted. - -

Notes

- -

On design choices

- -Performance would have to as good as possible. - -

A familiar C++ syntax should serve as a model (not all, though, I didn't feel like writing 700 pages of documentation :-). - -

Tcl being a non declarative language (which I really enjoy), stooop would have to try to comply with that approach. - -

Error checking would have to be strong with little impact on performance. - -

On implementation

- -For a Tcl only extension, I think performance is the main issue. The performance / functionality compromise was handled by moving as much processing as possible to the preprocessing stage, handled by the proc and virtual commands. Furthermore, all the costly error checking could be done there as well, having no impact on runtime performance. - -

The delete operation was greatly simplified, especially for classes that would require a virtual destructor in C++, by storing in an array the class of each object. It then became trivial to delete any object from its identifier only. This approach has an impact on memory use, though, but I consider that one is not very likely to create a huge number of objects in a Tcl application. Furthermore, a classof RTTI operator was then added with no effort. - -

Stooop learns class hierarchies through the constructor definition whichserves as an implementation as well, thus (kind of) better fitting the non declarative nature of Tcl. - -

All member data is public but access control is somewhat enforced by having to explicitly name the class layer of external data being accessed. - -

Since, for performance reasons, the stooop library performs very little checking during run-time (after all classes and their procedures were defined), debugging aids are provided starting from version 3.3. They attempt to insure that your code is well written in an object oriented sense. They also provide means for tracing data access and procedures. - -

Miscellaneous information

- -For downloading other Tcl software (such as scwoop, moodss, ...), visit my web page. - -

Send your comments, complaints, ... to Jean-Luc Fontaine. - - - DELETED modules/stooop/switched.html Index: modules/stooop/switched.html ================================================================== --- modules/stooop/switched.html +++ /dev/null @@ -1,242 +0,0 @@ - - - - - - stooop switched class - - - -

-
-the switched class
- -

  -
  -
-

The switched class serves as base class for user classes with -switch / option configuration method. It provides facilities for managing -options through a simple interface. -

For example: -

set vehicle [new car -length 4.5 -width 2 -power 100 -fuel diesel]
-puts "my car was running on [switched::cget $vehicle -fuel]"
-switched::configure $vehicle -power 40 -fuel electricity
-puts "but is now running on clean [switched::cget $vehicle -fuel]"
-Of course, as you might have guessed, the car class is derived from -the switched class. Let us see how it works: -
class car {
-    proc car {this args} switched {$args} {
-        # car specific initialization code here
-        switched::complete $this
-    }
-    ...
-}
-The switched class constructor takes the optional configuration option -/ value pairs as parameters. The switched class layer then completely manages -the switched options: it checks their validity, stores their values and -provides a clean interface to the user layer configuration setting procedures. -

The switched class members available to the programmer are: -

switched -

    -
  • -complete{}
    • - -
  • -options{}
    • - -
  • -set-option{}
    • - -
  • -...
    • - -
  • -complete
    • - -
  • --option
    • - -
  • -...
    • -
-The complete procedure is used to tell the switched layer that the -derived class object (a car in the examples) is completely built. At that -time, the initial configuration of the switched object occurs, using default -option values (see options procedure) eventually overridden by construction -time values, passed at the time of the new operator invocation. -The complete procedure must be called once only, usually around or at the -end of the derived class constructor. (Note: also check the complete -data member later in this chapter) -

The options procedure must return the configuration description -for all options that the switched object will accept. It is a pure -virtual member procedure and therefore its implementation is mandatory -in the derived class layer. The procedure must return a list of lists. -Each list pertains to a single option and is composed of the switch name, -the default value for the option and an optional initial value. For example: -

class car {
-    ...
-    proc options {this} {
-        return [list\
-            [list -fuel petrol petrol]\
-            [list -length {} {}]\
-            [list -power {} {}]\
-            [list -width {} {}]\
-        ]
-    }
-    proc set-fuel {this value} {
-        ...
-    }
-    ...
-}
-In this case, 4 options are specified: fuel, length, power -and width. The default and initial values for the fuel option -are identical and set to petrol. For the other options, values are -all empty. -

For each option, there must be a corresponding set-option procedure -defined in the derived class layer. For example, since we defined a fuel -option, there is a set-fuel procedure in the car class. The parameters -always are the object identifier (since this is not a static procedure, -but rather a dynamically defined virtual one), followed by the new value -for the option. The set-option procedure is only invoked if the -new value differs from the current one (a cache scheme for improving performance), -or if there is no initial value set in the options procedure for that option. -

In the options procedure, if the initial value differs from  the -default value or is omitted, then initial configuration is forced and the -corresponding set-option procedure is invoked by the switched complete -procedure located at the end of the derived class constructor. For example: -

class car {
-    ...
-    proc options {this} {
-        return [list\
-            [list -fuel petrol]\
-            [list -length {} {}]\
-            [list -power 100 50]\
-            [list -width {} {}]\
-        ]
-    }
-    ...
-}
-In this case, configuration is forced on the fuel and power -options, that is the corresponding set-option procedures will be -invoked when the switched object is constructed (see set-option -procedures documentation below). -

For the fuel option, since there is no initial value, the set-fuel -procedure is called with the default value (petrol) as argument. -For the power option, since the initial value differs from the default -value, the set-power procedure is called with the initial value -as argument (50). -

For the other options, since the initial values (last elements of the -option lists) are identical to their default values, the corresponding -set-option procedures will not be invoked. It is the programmer's -responsibility to insure that the initial option values are correct. -

The set-option procedures may be viewed as dynamic virtual -functions. There must be one implementation per supported option, as returned -by the options procedure. For example: -

class car {
-    ...
-    proc options {this} {
-        return [list\
-            ...
-            [list -width {} {}]\
-        ]
-    }
-    ...
-    proc set-width {this value} {
-        ...
-    }
-    ...
-}
-Since the -width option was listed in the options procedure, a set-width -procedure implementation is provided, which of course would proceed to -set the width of the car (and would modify the looks of a graphical representation, -for example). -

As you add a supported option in the list returned by the options -procedure, the corresponding set-option procedure may be called -as soon as the switched object is complete, which occurs when the switched -level complete procedure is invoked. For example: -
  -

class car {
-    proc car {this args} switched {args} {
-        ...
-        switched::complete $this
-   }
-    ...
-    proc options {this} {
-        return [list\
-            [list -fuel petrol]\
-            [list -length 4.5]\
-            [list -power 350]\
-            [list -width 1.8]\
-        ]
-    }
-    proc set-fuel {this value} {
-        ...
-    }
-    proc set-length {this value} {
-        ...
-    }
-    proc set-power {this value} {
-        ...
-    }
-    proc set-width {this value} {
-        ...
-    }
-}
- -
new car
-In this case, a new car is created with no options, which causes the car -constructor to be called, which in turns calls the switched level complete -procedure after the car object layer is completely initialized. At this -point, since there are no initial values in any option list in the options -procedure, the set-fuel procedure is called with its default value of petrol -as parameter, followed by the set-length call with 4.5 value, set-power -with 350 value and finally with set-width with 1.8 as parameter. -This is a good way to test the set-option procedures when debugging, and -when done, just fill-in the initial option values. -

The switched layer checks that an option is valid (that is, listed in -the options procedure) but obviously does not check the validity of the -value passed to the set-option procedure, which should throw an -error (for example by using the Tcl error command) if the value is invalid. -

The switched layer also keeps track of the options current values, so -that a set-option procedure is called only when the corresponding -option value passed as parameter is different from the current value (see --option -data members description). -

The -option data member is the option current value. There -is one for each option listed in the options procedure. It is a read-only -value which the switched layer checks against when an option is changed. -It is rarely used at the layer derived from switched, except in the few -cases, such as in the following example: -

...
- -
proc car::options {this} {
-    return {
-        ...
-        {-manufacturer {} {}}
-        ...
-    }
-}
- -
proc car::set-manufacturer {this value} {}
- -
proc car::printData {this} {
-    puts "manufacturer: $switched::($this,-manufacturer)"
-    ...
-}
-In this case, the manufacturer's name is stored at the switched layer level -(this is why the set-manufacturer procedure has nothing to do) and later -retrieved in the printData procedure. -

The complete data member (not to be confused with the complete -procedure) is a boolean. Its initial value is false and it is set -to true at the very end of the switched complete procedure. It becomes -useful when some options should be set at construction time only and not -dynamically, as the following example shows: -

proc car::set-width {this value} {
-    if {$switched::($this,complete)} {
-        error {option -width cannot be set dynamically}
-    }
-    ...
-}
- - - DELETED modules/stooop/switched.tcl Index: modules/stooop/switched.tcl ================================================================== --- modules/stooop/switched.tcl +++ /dev/null @@ -1,132 +0,0 @@ -# The switched class (for the stooop object oriented extension) -# -# Copyright (c) 2001 by Jean-Luc Fontaine . -# This code may be distributed under the same terms as Tcl. -# -# $Id: switched.tcl,v 1.2 2001/11/27 11:46:52 jfontain Exp $ - -package provide switched 2.2 - - -::stooop::class switched { - - proc switched {this args} { ;# arguments are option / value pairs - if {([llength $args]%2)!=0} { - error "value for \"[lindex $args end]\" missing" - } - set ($this,complete) 0 - # delay arguments processing till completion as pure virtual procedure - # invocations do not work from base class constructor - set ($this,arguments) $args - } - - proc ~switched {this} {} - - # derived class implementation must return a list of - # {name "default value" "initial value"} lists - ::stooop::virtual proc options {this} - - # must be invoked once only at the end of derived class constructor so that - # configuration occurs once derived object is completely built: - proc complete {this} { - foreach description [options $this] { - set option [lindex $description 0] - # by default always set option to default value: - set ($this,$option) [set default [lindex $description 1]] - if {[llength $description]<3} { - # no initial value so force initialization with default value - set initialize($option) {} - } elseif {![string equal $default [lindex $description 2]]} { - set ($this,$option) [lindex $description 2] - # initial value different from default value so force - # initialization - set initialize($option) {} - } - } - # check validity of constructor options, which always take precedence - # for initialization - foreach {option value} $($this,arguments) { - if {[catch {string compare $($this,$option) $value} different]} { - error "$($this,_derived): unknown option \"$option\"" - } - if {$different} { - set ($this,$option) $value - set initialize($option) {} - } - } - unset ($this,arguments) - # all option values are initialized before any of the set procedures are - # called - foreach option [array names initialize] { - $($this,_derived)::set$option $this $($this,$option) - } - set ($this,complete) 1 - } - - proc configure {this args} { ;# should not be invoked before completion - if {[llength $args]==0} { - return [descriptions $this] - } - foreach {option value} $args { - # check all options validity before doing anything else - if {![info exists ($this,$option)]} { - error "$($this,_derived): unknown option \"$option\"" - } - } - if {[llength $args]==1} { - return [description $this [lindex $args 0]] - } - if {([llength $args]%2)!=0} { - error "value for \"[lindex $args end]\" missing" - } - # derived (dynamic virtual) procedure must either accept (or eventually - # adjust) the value or throw an error - # option data member is set prior to invoking the procedure in case - # other procedures are invoked and expect the new value - foreach {option value} $args { - if {![string equal $($this,$option) $value]} { - $($this,_derived)::set$option $this [set ($this,$option) $value] - } - } - } - - proc cget {this option} { - if {[catch {set value $($this,$option)}]} { - error "$($this,_derived): unknown option \"$option\"" - } - return $value ;# return specified option current value - } - - proc description {this option} { ;# build specified option description list - foreach description [options $this] { - if {[string equal [lindex $description 0] $option]} { - if {[llength $description]<3} { ;# no initial value - lappend description $($this,$option) ;# append current value - return $description - } else { - # set current value: - return [lreplace $description 2 2 $($this,$option)] - } - } - } - } - - # build option descriptions list for all supported options: - proc descriptions {this} { - set descriptions {} - foreach description [options $this] { - if {[llength $description]<3} { ;# no initial value - # append current value: - lappend description $($this,[lindex $description 0]) - lappend descriptions $description - } else { - # set current value: - lappend descriptions [lreplace\ - $description 2 2 $($this,[lindex $description 0])\ - ] - } - } - return $descriptions - } - -} DELETED modules/stooop/xifo.tcl Index: modules/stooop/xifo.tcl ================================================================== --- modules/stooop/xifo.tcl +++ /dev/null @@ -1,134 +0,0 @@ -# The lifo and fifo classes (for the stooop object oriented extension) -# -# Copyright (c) 2001 by Jean-Luc Fontaine . -# This code may be distributed under the same terms as Tcl. -# -# $Id: xifo.tcl,v 1.2 2001/11/27 11:46:52 jfontain Exp $ - - -# Here is a sample FIFO/LIFO implementation with stooop. -# Sample test code is at the bottom of this file. - - -# Uncomment the following lines for the bottom sample code to work: -# package require stooop -# namespace import stooop::* - -::stooop::class xifo { - proc xifo {this size} { - set ($this,size) $size - empty $this - } - - proc ~xifo {this} { - variable ${this}data - catch {unset ${this}data} - } - - proc in {this data} { - variable ${this}data - tidyUp $this - if {[array size ${this}data]>=$($this,size)} { - unset ${this}data($($this,first)) - incr ($this,first) - } - set ${this}data([incr ($this,last)]) $data - } - - proc tidyUp {this} { ;# warning: for internal use only - variable ${this}data - catch { - unset ${this}data($($this,unset)) - unset ($this,unset) - } - } - - proc empty {this} { - variable ${this}data - catch {unset ${this}data} - catch {unset ($this,unset)} - set ($this,first) 0 - set ($this,last) -1 - } - - proc isEmpty {this} { - variable ${this}data - return [expr {[array size ${this}data]==0}] - } - - ::stooop::virtual proc out {this} - - ::stooop::virtual proc data {this} -} - -::stooop::class lifo { - proc lifo {this {size 2147483647}} xifo {$size} {} - - proc ~lifo {this} {} - - proc out {this} { - xifo::tidyUp $this - if {[array size xifo::${this}data]==0} { - error "lifo $this out error, empty" - } - # delay unsetting popped data to improve performance by avoiding a data - # copy: - set xifo::($this,unset) $xifo::($this,last) - incr xifo::($this,last) -1 - return [set xifo::${this}data($xifo::($this,unset))] - } - - proc data {this} { - set list {} - set first $xifo::($this,first) - for {set index $xifo::($this,last)} {$index>=$first} {incr index -1} { - lappend list [set xifo::${this}data($index)] - } - return $list - } -} - -::stooop::class fifo { - proc fifo {this {size 2147483647}} xifo {$size} {} - - proc ~fifo {this} {} - - proc out {this} { - xifo::tidyUp $this - if {[array size xifo::${this}data]==0} { - error "fifo $this out error, empty" - } - # delay unsetting popped data to improve performance by avoiding a data - # copy: - set xifo::($this,unset) $xifo::($this,first) - incr xifo::($this,first) - return [set xifo::${this}data($xifo::($this,unset))] - } - - proc data {this} { - set list {} - set last $xifo::($this,last) - for {set index $xifo::($this,first)} {$index<=$last} {incr index} { - lappend list [set xifo::${this}data($index)] - } - return $list - } -} - -# Here are a few lines of sample code: -# proc exercise {id} { -# for {set u 0} {$u<10} {incr u} { -# xifo::in $id $u -# } -# puts [xifo::out $id] -# puts [xifo::data $id] -# xifo::in $id $u -# xifo::in $id [incr u] -# puts [xifo::data $id] -# } -# set id [stooop::new lifo 10] -# exercise $id -# stooop::delete $id -# set id [stooop::new fifo 10] -# exercise $id -# stooop::delete $id DELETED modules/struct/ChangeLog Index: modules/struct/ChangeLog ================================================================== --- modules/struct/ChangeLog +++ /dev/null @@ -1,401 +0,0 @@ -2003-04-16 Andreas Kupries - - * prioqueue.tcl (__elementcompare): Failures in testsuite fixed, - patch provided by original author, Michael Schlenker - . - -2003-04-15 Andreas Kupries - - * skiplist.man: - * skiplist.tcl: - * skiplist.test: New files. Patch #553980 submitted by Eric Melski - on behalf of Keith Vetter. - - * prioqueue.tcl: - * prioqueue.test: New files. Patch #607085 submitted by Michael - Schlenker . - -2003-04-15 Andreas Kupries - - * tcllib_list.man: Changed name to struct_list.man. Allows for - usage of struct outside of tcllib, not as big a coupling. - - * graph.tcl: Redone the setting up of namespace a bit to prevent - problem with the generation of a master package - index. strcut.tcl bailed out with an error because the namespace - was net set up when using [pkg_mkIndex] in this directory. - -2003-04-13 Andreas Kupries - - * graph.test: - * graph.man: - * graph.tcl: Added code to look for the C-implementation, cgraph, - first, and to fall back to the Tcl implementation if cgraph is - not present (#720348). The documentation links to the place - where cgraph can be had from. Note presence of cgraph when - executing the testsuite. - -2003-04-12 Andreas Kupries - - * list.man: Changed name to tcllib_list.man to prevent a clash - with tcl's manpages. - -2003-04-11 Andreas Kupries - - * struct.tcl: - * list.man: - * matrix.man: - * pool.man: - * queue.man: - * record.man: - * stack.man: - * tree.man: - * pkgIndex.tcl: Set version of the package to 1.3. - -2003-04-09 Andreas Kupries - - * list.man: - * list.test: - * list.tcl: Added 'lcsInvertMerge'. - -2003-04-08 Andreas Kupries - - * list.man: - * list.test: - * list.tcl: Added and documented commands [iota], [equal], and - [repeat]. Extended the testsuite. - -2003-04-02 Andreas Kupries - - * list.cl: - * list.test: Fixed SF tcllib bug #714209. - - * ../../../examples/struct: Added example applications for usage - of longestCommonSubsequence and lcsInvert. - - * struct.tcl: Integrated new list commands. - - * list.tcl: Added commands 'reverse', 'assign', 'flatten', - * list.man: 'map', and 'fold' to the suite of list functions. - * list.test: - -2003-04-01 Andreas Kupries - - * list.man: New files, extended list manipulation - * list.tcl: facilities. Started out with Kevin Kenny's - * list.test: implementation of the algorithm to find the longest - common subsequence of two sequences, aka lists. - Added myself a method to invert a LCS into a - description of differences instead. - -2003-04-01 Andreas Kupries - - * record.test: Applied changes provided by Brett Schwarz - . His comments: I had changed - the return when encountering a circular record; previously I - returned "", but now I return an error. This fixes record.test - to reflect the change. Part of fix for Tcllib SF Bug #709375. - - Additional changes by myself: Reformatted (proper tcl - indentations). Renumbered so that all tests have unique id - numbers (Before all tests had id 0.1). - -2003-02-25 David N. Welton - - * matrix.tcl: Require Tcl 8.2 because of string map. Use string - map instead of regexp. - -2003-01-16 Andreas Kupries - - * graph.man: More semantic markup, less visual one. - * matrix.man: - * pool.man: - * record.man: - * tree.man: - -2002-11-06 Brett Schwarz - - * record.tcl: cleaned up code based on output from frink - -2002-11-05 Brett Schwarz - - * struct.tcl: modified to include record.tcl - - * record.man: - * record.html: - * record.n: - * record.test: - * record.tcl: new data structure - -2002-10-16 Andreas Kupries - - * graph.test: - * graph.man: - * graph.tcl: Implemented FR 603924. getall, keys, keyexists - methods for keys of the whole graph. - -2002-08-08 Andreas Kupries - - * tree.test: Followup to fix for bug SF #587533. Had to update the - test suite too. - -2002-08-06 Andreas Kupries - - * tree.tcl (lappend): Fixed bug SF #587533 reported by Evan Rempel - . - - * pool.tcl: Fixed bug SF #585093, reported by Michael Cleverly - . Patch provided by Michael too. - -2002-07-08 Andreas Kupries - - * tree.man: Updated the documentation to clarify the behaviour. - - * test.tcl: Updated testsuite, part of the patch below. - - * tree.tcl (_move): Accepted patch by Brian Theado - fixing the behaviour of mov, SF - bug #578460. The command now also validates all nodes before - trying to move any of them. - -2002-05-27 Andreas Kupries - - * matrix.man: Fixed typo (graph -> matrix). - - * struct.tcl: Added pool files to list of files to source. - - * pool.man: New documentation for pool based upon the original - HTML manpage. - - * pool.html: - * pooltest.tcl: - * pool.tcl: New data structure, pool, by Erik Leunissen - . Modified code to be a sub-namespace of - ::struct, made it a part of the struct package. No regular - testsuite yet (see pooltest.tcl for the irregular testsuite). - -2002-05-08 Andreas Kupries - - * graph.n: This file is out of sync. - * graph.man: - * graph.test: - * graph.tcl: See tree, for arcs and nodes. - - * tree.man: - * tree.n: - * tree.test: - * tree.tcl: Accepted FR #552972 (new methods append, lappend, - getall, keys, keyexists) for tree structures. - -2002-04-01 Andreas Kupries - - * matrix.tcl: Fixed SF Tcllib #532791 about unsetting of elements - in linked arrays as reported by Ken Jones - . Unsetting an element in a linked - array now sets the corresponding cell in the matrix to the empty - string, and the corresponding elements in other linked arrays - are now unset too. - - * tree.man: New file, doctools manpage. - -2002-03-25 Andreas Kupries - - * matrix.tcl: Fixed bug #532783 reported by Ken Jones - . Any operation adding new material - to a linked matrix causes a circular trace (op -> "MatTraceOut" - -> "MatTraceIn" -> set cell) and the inbound trace fails because - the data structures are not uptodate causing the range checks in - "set cell" to fail. Fixed by breaking the cycle. Calls to - "MatTraceIn" are now disabled while we are in "MatTraceOut". - -2002-03-15 Andreas Kupries - - * matrix.man: Added example of formatting a matrix using tabular - reports (See tcllib module "reports" too.). Fixes #530207. - -2002-03-09 Andreas Kupries - - * matrix.n: - * matrix.man: - * matrix.test: - * matrix.tcl: Accepted FR #524430 and added option -nocase to the - 'search' method. - - * matrix.man: Added doctools manpage. - -2002-03-02 Andreas Kupries - - * graph.man: Added doctools manpage. - -2002-02-14 Andreas Kupries - - * matrix.tcl: Frink run. - -2002-02-01 Andreas Kupries - - * Version up to 1.2.1 to differentiate development from the - version in the tcllib 1.2 release. - - * matrix.test: - * matrix.tcl: See below, but not complete. - * queue.test - * stack.test: - * graph.tcl: - * graph.test: - * tree.tcl: - * tree.test: Updated code and tests to cover all paths through the - code. - -2002-01-15 Andreas Kupries - - * Bumped version to 1.2 - -2001-11-26 Andreas Kupries - - * matrix.tcl (add rows): Indices were transposed. Fixed. - -2001-11-23 Andreas Kupries - - * matrix.test: - * matrix.n: - * matrix.tcl: Implementation of FR #481022: matrix printing and - searching. - -2001-11-19 Andreas Kupries - - * graph.test: - * graph.n: - * graph.tcl: Applied patch #483125 provided by Frank Pilhofer - . The patch adds key/value information for the whole - graph and extends the selection methods 'arcs' and 'nodes' to - allow selection based on keys and their values. - -2001-10-16 Andreas Kupries - - * pkgIndex.tcl: - * struct.tcl: - * graph.n: - * matrix.n: - * queue.n: - * stack.n: - * tree.n: Version up to 1.1.1 - -2001-09-05 Andreas Kupries - - * The changes below fix bug [458011]. - - * tree.test (6.16): New test. Checks verificator of forbidden names. - - * tree.tcl (::struct::tree::_insert): Added verification that node - names do not contain forbidden characters. - - * tree.n: Documented limitations on node names. Documented allowed - index "end" for insert. - -2001-07-10 Andreas Kupries - - * matrix.tcl: Frink 2.2 run, fixed dubious code. - -2001-06-21 Andreas Kupries - - * tree.tcl: - * graph.tcl: Fixed dubious code reported by frink. - -2001-06-19 Andreas Kupries - - * matrix.n: Fixed nroff trouble. - -2001-05-20 Andreas Kupries - - * matrix.tcl (insert row/column): Fixed wrong references to the - internal add row/column procedures. - - * modules/struct/matrix.test: Added 8.11 and 8.12 to test the case - of 'insert FOO' devolving to 'add FOO'. - -2001-05-01 Andreas Kupries - - * Committed changes (matrix) to CVS head at SF. - -2001-04-17 Andreas Kupries - - * matrix.n: updated and completed documentation - * matrix:test: Added testsuite - * matrix.tcl: Added the implementation. - -2001-04-12 Andreas Kupries - - * struct.tcl: Added loading of the matrix definition. - - * matrix.n: Adding matrix structure. - -2000-04-07 Eric Melski - - * stack.test: - * queue.test: Changed "package require struct" to "source [file - join [file dirname [info script]] xxxx.tcl]", which is more reliable. - - * tree.test: - * tree.tcl: Added support for different walk orders (post, - in, and both) [RFE: 4420]. Added support for percent substitution - on walk command. (WalkCall) Added protection against node/tree - names with spaces. - - * graph.tcl: - * graph.test: - * graph.n: Graph implementation from Andreas Kupries. - -2000-03-20 Eric Melski - - * tree.test: - * tree.n: - * tree.tcl: Added support for inserting/moving multiple nodes at - once. Changed behavior of insert with respect to inserting nodes - that already exist; instead of an error, it will move the node. - -2000-03-14 Eric Melski - - * tree.n: Added a brief description of what a tree is. - -2000-03-10 Eric Melski - - * tree.n: - * tree.tcl: - * tree.test: Applied patch from [RFE: 4337], with enhancements for - better efficiency, and additional test cases; adds cut and splice - functions to tree. - -2000-03-09 Eric Melski - - * tree.n: - * tree.tcl: - * tree.test: Applied patch from [RFE: 4338]; adds index function to - tree. Applied patch from [RFE: 4339], with slight modification; adds - numchildren function to tree. Applied patch from [RFE: 4336], - with additional error checks and test cases; adds next, previous - functions to tree. Added extra tests for walk command. - - * tree.tcl: Added isleaf function and tests [RFE: 4340] - - * struct.tcl: Changed order of namespace import/namespace export - calls. Added -force to namespace import calls. - - * tree.test: - * stack.test: - * queue.test: Adapted tests to run in/out of tcllib test framework. - - * tree.test: - * tree.tcl: Added code to auto-generate node names on insert if no - name is given [RFE: 4345] - -2000-03-08 Eric Melski - - * tree.test: - * tree.tcl: Added check for node existance in children function - [Bug: 4341] - -2000-03-03 Eric Melski - - * tree.tcl: Changed usage information for tree::_walk. - - * tree.n: Enhanced description of walk function, fixed a typo. DELETED modules/struct/graph.man Index: modules/struct/graph.man ================================================================== --- modules/struct/graph.man +++ /dev/null @@ -1,398 +0,0 @@ -[comment {-*- tcl -*-}] -[manpage_begin graph n 1.2.1] -[copyright {2002 Andreas Kupries }] -[moddesc {Tcl Data Structures}] -[titledesc {Create and manipulate directed graph objects}] -[require Tcl 8.2] -[require struct [opt 1.3]] -[description] -[para] - -The [cmd ::struct::graph] command creates a new graph object with an -associated global Tcl command whose name is [arg graphName]. This -command may be used to invoke various operations on the graph. It has -the following general form: - -[list_begin definitions] -[call [cmd graphName] [arg option] [opt [arg "arg arg ..."]]] - -[arg Option] and the [arg arg]s determine the exact behavior of the -command. - -[list_end] - -[para] - -[emph Note:] A C-implementation of the command can be had from the -location [uri http://physnet.uni-oldenburg.de/~schlenk/tcl/graph/]. -This implementation uses a bit less memory than the tcl version -provided here directly, and is faster. - - -[para] - -A directed graph is a structure containing two collections of -elements, called [emph nodes] and [emph arcs] respectively, together -with a relation ("connectivity") that places a general structure upon -the nodes and arcs. - -[para] - -Each arc is connected to two nodes, one of which is called the - -[emph source] and the other the [emph target]. This imposes a -direction upon the arc, which is said to go from the source to the -target. It is allowed that source and target of an arc are the same -node. Such an arc is called a [emph loop]. Whenever a node is source -or target of an arc both are said to be [emph adjacent]. This extends -into a relation between nodes, i.e. if two nodes are connected through -at least one arc they are said to be [emph adjacent] too. - -[para] - -Each node can be the source and target for any number of arcs. The -former are called the [emph {outgoing arcs}] of the node, the latter -the [emph {incoming arcs}] of the node. The number of edges in either -set is called the [emph in-] resp. the [emph out-degree] of the node. - -[para] - -In addition to maintaining the node and arc relationships, this graph -implementation allows any number of keyed values to be associated with -each node and arc. - -[para] - -The following commands are possible for graph objects: - -[list_begin definitions] - -[call [arg graphName] [method destroy]] - -Destroy the graph, including its storage space and associated command. - -[call [arg graphName] [method {arc append}] [arg arc] [opt "-key [arg key]"] [arg value]] - -Appends a [arg value] to one of the keyed values associated with an -[arg arc]. If no [arg key] is specified, the key [const data] is -assumed. - - -[call [arg graphName] [method {arc delete}] [arg arc] [opt "[arg arc] ..."]] - -Remove the specified arcs from the graph. - - -[call [arg graphName] [method {arc exists}] [arg arc]] - -Return true if the specified [arg arc] exists in the graph. - - -[call [arg graphName] [method {arc get}] [arg arc] [opt "-key [arg key]"]] - -Return the value associated with the key [arg key] for the [arg arc]. -If no key is specified, the key [const data] is assumed. - -[call [arg graphName] [method {arc getall}] [arg arc]] - -Returns a serialized list of key/value pairs (suitable for use with -[lb][cmd {array set}][rb]) for the [arg arc]. - - -[call [arg graphName] [method {arc keys}] [arg arc]] - -Returns a list of keys for the [arg arc]. - - -[call [arg graphName] [method {arc keyexists}] [arg arc] [opt "-key [arg key]"]] - -Return true if the specified [arg key] exists for the [arg arc]. If no -[arg key] is specified, the key [const data] is assumed. - - -[call [arg graphName] [method {arc insert}] [arg start] [arg end] [opt [arg child]]] - -Insert an arc named [arg child] into the graph beginning at the node -[arg start] and ending at the node [arg end]. If the name of the new -arc is not specified the system will generate a unique name of the -form [emph arc][arg x]. - - -[call [arg graphName] [method {arc lappend}] [arg arc] [opt "-key [arg key]"] [arg value]] - -Appends a [arg value] (as a list) to one of the keyed values -associated with an [arg arc]. If no [arg key] is specified, the key -[const data] is assumed. - - -[call [arg graphName] [method {arc set}] [arg arc] [opt "-key [arg key]"] [opt [arg value]]] - -Set or get one of the keyed values associated with an arc. If no key -is specified, the key [const data] is assumed. Each arc that is -added to a graph has the empty string assigned to the key - -[const data] automatically. An arc may have any number of keyed -values associated with it. If [arg value] is not specified, this -command returns the current value assigned to the key; if [arg value] -is specified, this command assigns that value to the key. - - -[call [arg graphName] [method {arc source}] [arg arc]] - -Return the node the given [arg arc] begins at. - - -[call [arg graphName] [method {arc target}] [arg arc]] - -Return the node the given [arg arc] ends at. - - -[call [arg graphName] [method {arc unset}] [arg arc] [opt "-key [arg key]"]] - -Remove a keyed value from the arc [arg arc]. If no key is specified, -the key [const data] is assumed. - - -[call [arg graphName] [method arcs] [opt "-key [arg key]"] [opt "-value [arg value]"] [opt "-in|-out|-adj|-inner|-embedding [arg nodelist]"]] - -Return a list of arcs in the graph. If no restriction is specified a -list containing all arcs is returned. Restrictions can limit the list -of returned arcs based on the nodes that are connected by the arc, on -the keyed values associated with the arc, or both. The restrictions -that involve connected nodes have a list of nodes as argument, -specified after the name of the restriction itself. - -[list_begin definitions] -[lst_item [option -in]] - -Return a list of all arcs whose target is one of the nodes in the -[arg nodelist]. - -[lst_item [option -out]] - -Return a list of all arcs whose source is one of the nodes in the -[arg nodelist]. - -[lst_item [option -adj]] - -Return a list of all arcs adjacent to at least one of the nodes in the -[arg nodelist]. This is the union of the nodes returned by - -[option -in] and [option -out]. - -[lst_item [option -inner]] - -Return a list of all arcs adjacent to two of the nodes in the - -[arg nodelist]. This is the set of arcs in the subgraph spawned by the -specified nodes. - -[lst_item [option -embedding]] - -Return a list of all arcs adjacent to exactly one of the nodes in the -[arg nodelist]. This is the set of arcs connecting the subgraph -spawned by the specified nodes to the rest of the graph. - -[lst_item "[option -key] [arg key]"] - -Limit the list of arcs that are returned to those arcs that have an -associated key [arg key]. - -[lst_item "[option -value] [arg value]"] - -This restriction can only be used in combination with - -[option -key]. It limits the list of arcs that are returned to those -arcs whose associated key [arg key] has the value [arg value]. - -[list_end] - -[call [arg graphName] [method {node append}] [arg node] [opt "-key [arg key]"] [arg value]] - -Appends a [arg value] to one of the keyed values associated with an -[arg node]. If no [arg key] is specified, the key [const data] is -assumed. - - -[call [arg graphName] [method {node degree}] [opt -in|-out] [arg node]] - -Return the number of arcs adjacent to the specified [arg node]. If one -of the restrictions [option -in] or [option -out] is given only the -incoming resp. outgoing arcs are counted. - - -[call [arg graphName] [method {node delete}] [arg node] [opt "[arg node] ..."]] - -Remove the specified nodes from the graph. All of the nodes' arcs -will be removed as well to prevent unconnected arcs. - - -[call [arg graphName] [method {node exists}] [arg node]] - -Return true if the specified [arg node] exists in the graph. - - -[call [arg graphName] [method {node get}] [arg node] [opt "-key [arg key]"]] - -Return the value associated with the key [arg key] for the [arg node]. -If no key is specified, the key [const data] is assumed. - -[call [arg graphName] [method {node getall}] [arg node]] - -Returns a serialized list of key/value pairs (suitable for use with -[lb][cmd {array set}][rb]) for the [arg node]. - - -[call [arg graphName] [method {node keys}] [arg node]] - -Returns a list of keys for the [arg node]. - - -[call [arg graphName] [method {node keyexists}] [arg node] [opt "-key [arg key]"]] - -Return true if the specified [arg key] exists for the [arg node]. If -no [arg key] is specified, the key [const data] is assumed. - - -[call [arg graphName] [method {node insert}] [opt [arg child]]] - -Insert a node named [arg child] into the graph. The nodes has no arcs -connected to it. If the name of the new child is not specified the -system will generate a unique name of the form [emph node][arg x]. - -[call [arg graphName] [method {node lappend}] [arg node] [opt "-key [arg key]"] [arg value]] - -Appends a [arg value] (as a list) to one of the keyed values -associated with an [arg node]. If no [arg key] is specified, the key -[const data] is assumed. - - -[call [arg graphName] [method {node opposite}] [arg node] [arg arc]] - -Return the node at the other end of the specified [arg arc], which has -to be adjacent to the given [arg node]. - - -[call [arg graphName] [method {node set}] [arg node] [opt "-key [arg key]"] [opt [arg value]]] - -Set or get one of the keyed values associated with a node. If no key -is specified, the key [const data] is assumed. Each node that is -added to a graph has the empty string assigned to the key - -[const data] automatically. A node may have any number of keyed -values associated with it. If [arg value] is not specified, this -command returns the current value assigned to the key; if [arg value] -is specified, this command assigns that value to the key. - - -[call [arg graphName] [method {node unset}] [arg node] [opt "-key [arg key]"]] - -Remove a keyed value from the node [arg node]. If no key is -specified, the key [method data] is assumed. - -[call [arg graphName] [method nodes] [opt "-key [arg key]"] [opt "-value [arg value]"] [opt "-in|-out|-adj|-inner|-embedding [arg nodelist]"]] - -Return a list of nodes in the graph. Restrictions can limit the list -of returned nodes based on neighboring nodes, or based on the keyed -values associated with the node. The restrictions that involve -neighboring nodes have a list of nodes as argument, specified after -the name of the restriction itself. - -[nl] - -The possible restrictions are the same as for method - -[method arcs]. The set of nodes to return is computed as the union of -all source and target nodes for all the arcs satisfying the -restriction as defined for [method arcs]. - - -[call [arg graphName] [method get] [opt "-key [arg key]"]] - -Return the value associated with the key [arg key] for the graph. If -no key is specified, the key [const data] is assumed. - - -[call [arg graphName] [method getall]] - -Returns a serialized list of key/value pairs (suitable for use with -[lb][cmd {array set}][rb]) for the whole graph. - - -[call [arg graphName] [method keys]] - -Returns a list of keys for the whole graph. - - -[call [arg graphName] [method keyexists] [opt "-key [arg key]"]] - -Return true if the specified [arg key] exists for the whole graph. If no -[arg key] is specified, the key [const data] is assumed. - - -[call [arg graphName] [method set] [opt "-key [arg key]"] [opt [arg value]]] - -Set or get one of the keyed values associated with a graph. If no key -is specified, the key [const data] is assumed. Each graph has the -empty string assigned to the key [const data] automatically. A graph -may have any number of keyed values associated with it. If [arg value] -is not specified, this command returns the current value assigned to -the key; if [arg value] is specified, this command assigns that value -to the key. - - -[call [arg graphName] [method swap] [arg node1] [arg node2]] - -Swap the position of [arg node1] and [arg node2] in the graph. - - -[call [arg graphName] [method unset] [opt "-key [arg key]"]] - -Remove a keyed value from the graph. If no key is specified, the key -[const data] is assumed. - -[call [arg graphName] [method walk] [arg node] [opt "-order [arg order]"] [opt "-type [arg type]"] [opt "-dir [arg direction]"] -command [arg cmd]] - -Perform a breadth-first or depth-first walk of the graph starting at -the node [arg node] going in either the direction of outgoing or -opposite to the incoming arcs. - -[nl] - -The type of walk, breadth-first or depth-first, is determined by the -value of [arg type]; [const bfs] indicates breadth-first, - -[const dfs] indicates depth-first. Depth-first is the default. - -[nl] - -The order of the walk, pre-order, post-order or both-order is -determined by the value of [arg order]; [const pre] indicates -pre-order, [const post] indicates post-order, [const both] indicates -both-order. Pre-order is the default. Pre-order walking means that a -node is visited before any of its neighbors (as defined by the - -[arg direction], see below). Post-order walking means that a parent is -visited after any of its neighbors. Both-order walking means that a -node is visited before [emph and] after any of its neighbors. The -combination of a bread-first walk with post- or both-order is illegal. - -[nl] - -The direction of the walk is determined by the value of [arg dir]; -[const backward] indicates the direction opposite to the incoming -arcs, [const forward] indicates the direction of the outgoing arcs. - -[nl] - -As the walk progresses, the command [arg cmd] will be evaluated at -each node, with the mode of the call ([const enter] or -[const leave]) and values [arg graphName] and the name of the current -node appended. For a pre-order walk, all nodes are [const enter]ed, for a -post-order all nodes are left. In a both-order walk the first visit of -a node [const enter]s it, the second visit [const leave]s it. - -[list_end] - -[keywords graph cgraph] -[manpage_end] DELETED modules/struct/graph.n Index: modules/struct/graph.n ================================================================== --- modules/struct/graph.n +++ /dev/null @@ -1,241 +0,0 @@ -'\" -'\" Copyright (c) 1998-2000 by Ajuba Solutions. -'\" All rights reserved. -'\" -'\" RCS: @(#) $Id: graph.n,v 1.8 2002/02/01 22:59:08 andreas_kupries Exp $ -'\" -.so man.macros -.TH graph n 1.2.1 Struct "Tcl Data Structures" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -::struct::graph \- Create and manipulate directed graph objects -.SH SYNOPSIS -\fBpackage require Tcl 8.2\fR -.sp -\fBpackage require struct ?1.2.1?\fR -.sp -\fB::struct::graph\fR \fIgraphName\fR -.sp -.BE -.SH DESCRIPTION -.PP -The \fB::struct::graph\fR command creates a new graph object with an -associated global Tcl command whose name is \fIgraphName\fR. This command -may be used to invoke various operations on the graph. -It has the -following general form: -.CS -\fIgraphName option \fR?\fIarg arg ...\fR? -.CE -\fIOption\fR and the \fIarg\fRs -determine the exact behavior of the command. -.PP -A directed graph is a structure containing two collections of -elements, called \fInodes\fR and \fIarcs\fR resp., together with a -relation ("connectivity") that places a general structure upon the -nodes and arcs. - -Each arc is connected to two nodes, one of which is called the -\fIsource\fR and the other the \fItarget\fR. This imposes a direction -upon the arc, which is said to go from the source to the target. It is -allowed that source and target of an arc are the same node. Such an -arc is called a \fIloop\fR. Whenever a node is source or target of an -arc both are said to be \fIadjacent\fR. This extends into a relation -between nodes, i.e. if two nodes are connected through at least one -arc they are said to be \fIadjacent\fR too. - -Each node can be the source and target for any number of arcs. The -former are called the \fIoutgoing arcs\fR of the node, the latter the -\fIincoming arcs\fR of the node. The number of edges in either set is -called the \fIin-\fR resp. the \fIout-degree\fR of the node. - -In addition to maintaining the node and arc relationships, this graph -implementation allows any number of keyed values to be associated with -each node and arc. -.PP -The following commands are possible for graph objects: -.TP -\fIgraphName \fBdestroy\fR -Destroy the graph, including its storage space and associated command. -.TP -\fIgraphName\fR \fBarc delete\fR \fIarc\fR ?\fIarc\fR ...? -Remove the specified arcs from the graph. -.TP -\fIgraphName\fR \fBarc exists\fR \fIarc\fR -Return true if the specified \fIarc\fR exists in the graph. -.TP -\fIgraphName\fR \fBarc get\fR \fIarc\fR ?\fI-key key\fR? -Return the value associated with the key \fIkey\fR for the -\fIarc\fR. If no key is specified, the key \fBdata\fR is assumed. -.TP -\fIgraphName \fBarc insert\fR \fIstart\fR \fIend\fR ?\fIchild\fR? -Insert an arc named \fIchild\fR into the graph beginning at the node -\fIstart\fR and ending at the node \fIend\fR. If the name of the new -arc is not specified the system will generate a unique name of the -form \fBarc\fR\fIx\fR. -.TP -\fIgraphName\fR \fBarc set\fR \fIarc\fR ?\fI-key key\fR? ?\fIvalue\fR? -Set or get one of the keyed values associated with an arc. If no key -is specified, the key \fBdata\fR is assumed. Each arc that is added -to a graph has the value "" assigned to the key \fBdata\fR -automatically. An arc may have any number of keyed values associated -with it. If \fIvalue\fR is not specified, this command returns the -current value assigned to the key; if \fIvalue\fR is specified, this -command assigns that value to the key. -.TP -\fIgraphName\fR \fBarc source\fR \fIarc\fR -Return the node the given \fIarc\fR begins at. -.TP -\fIgraphName\fR \fBarc target\fR \fIarc\fR -Return the node the given \fIarc\fR ends at. -.TP -\fIgraphName\fR \fBarc unset\fR \fIarc\fR ?\fI-key key\fR? -Remove a keyed value from the arc \fIarc\fR. If no key is -specified, the key \fBdata\fR is assumed. -.TP -\fIgraphName\fR \fBarcs\fR ?-key \fIkey\fR? ?-value \fIvalue\fR? ?-in|-out|-adj|-inner|-embedding \fInodelist\fR? -Return a list of arcs in the graph. If no restriction is specified a -list containing all arcs is returned. Restrictions can limit the list -of returned arcs based on the nodes that are connected by the arc, on -the keyed values associated with the arc, or both. The restrictions -that involve connected nodes have a list of nodes as argument, -specified after the name of the restriction itself. -.RS -.TP -\fB-in\fR -Return a list of all arcs whose target is one of the nodes in the -\fInodelist\fR. -.TP -\fB-out\fR -Return a list of all arcs whose source is one of the nodes in the -\fInodelist\fR. -.TP -\fB-adj\fR -Return a list of all arcs adjacent to at least one of the nodes in -the \fInodelist\fR. This is the union of the nodes returned by -\fB-in\fR and \fB-out\fR. -.TP -\fB-inner\fR -Return a list of all arcs adjacent to two of the nodes in the -\fInodelist\fR. This is the set of arcs in the subgraph spawned by -the specified nodes. -.TP -\fB-embedding\fR -Return a list of all arcs adjacent to exactly one of the nodes in the -\fInodelist\fR. This is the set of arcs connecting the subgraph -spawned by the specified nodes to the rest of the graph. -.TP -\fB-key\fR \fIkey\fR -Limit the list of arcs that are returned to those arcs that have an -associated key \fIkey\fR. -.TP -\fB-value\fR \fIvalue\fR -This restriction can only be used in combination with \fB-key\fR. It -limits the list of arcs that are returned to those arcs whose -associated key \fIkey\fR has the value \fIvalue\fR. -.RE -.TP -\fIgraphName\fR \fBnode degree\fR ?-in|-out? \fInode\fR -Return the number of arcs adjacent to the specified \fInode\fR. If -one of the restrictions \fB-in\fR or \fB-out\fR is given only the -incoming resp. outgoing arcs are counted. -.TP -\fIgraphName\fR \fBnode delete\fR \fInode\fR ?\fInode\fR ...? -Remove the specified nodes from the graph. All of the nodes' arcs -will be removed as well to prevent unconnected arcs. -.TP -\fIgraphName\fR \fBnode exists\fR \fInode\fR -Return true if the specified \fInode\fR exists in the graph. -.TP -\fIgraphName\fR \fBnode get\fR \fInode\fR ?\fI-key key\fR? -Return the value associated with the key \fIkey\fR for the -\fInode\fR. If no key is specified, the key \fBdata\fR is assumed. -.TP -\fIgraphName \fBnode insert\fR ?\fIchild\fR? -Insert a node named \fIchild\fR into the graph. The nodes has no arcs -connected to it. If the name of the new child is not specified the -system will generate a unique name of the form \fBnode\fR\fIx\fR. -.TP -\fIgraphName\fR \fBnode opposite\fR \fInode\fR \fIarc\fR -Return the node at the other end of the specified \fIarc\fR, which -has to be adjacent to the given \fInode\fR. -.TP -\fIgraphName\fR \fBnode set\fR \fInode\fR ?\fI-key key\fR? ?\fIvalue\fR? -Set or get one of the keyed values associated with a node. If no key -is specified, the key \fBdata\fR is assumed. Each node that is added -to a graph has the value "" assigned to the key \fBdata\fR -automatically. A node may have any number of keyed values associated -with it. If \fIvalue\fR is not specified, this command returns the -current value assigned to the key; if \fIvalue\fR is specified, this -command assigns that value to the key. -.TP -\fIgraphName\fR \fBnode unset\fR \fInode\fR ?\fI-key key\fR? -Remove a keyed value from the node \fInode\fR. If no key is -specified, the key \fBdata\fR is assumed. -.TP -\fIgraphName\fR \fBnodes\fR ?-key \fIkey\fR? ?-value \fIvalue\fR? ?-in|-out|-adj|-inner|-embedding \fInodelist\fR? -Return a list of nodes in the graph. Restrictions can limit the list -of returned nodes based on neighboring nodes, or based on the keyed -values associated with the node. The restrictions that involve -neighboring nodes have a list of nodes as argument, specified after -the name of the restriction itself. -.sp -The possible restrictions are the same as for method \fBarcs\fR. The -set of nodes to return is computed as the union of all source and -target nodes for all the arcs satisfying the restriction as defined -for \fBarcs\fR. -.TP -\fIgraphName\fR \fBget\fR ?\fI-key key\fR? -Return the value associated with the key \fIkey\fR for the graph. If -no key is specified, the key \fBdata\fR is assumed. -.TP -\fIgraphName\fR \fBset\fR ?\fI-key key\fR? ?\fIvalue\fR? -Set or get one of the keyed values associated with a graph. If no key -is specified, the key \fBdata\fR is assumed. Each graph has the value -"" assigned to the key \fBdata\fR automatically. A graph may have any -number of keyed values associated with it. If \fIvalue\fR is not -specified, this command returns the current value assigned to the key; -if \fIvalue\fR is specified, this command assigns that value to the -key. -.TP -\fIgraphName\fR \fBswap\fR \fInode1\fR \fInode2\fR -Swap the position of \fInode1\fR and \fInode2\fR in the graph. -.TP -\fIgraphName\fR \fBunset\fR ?\fI-key key\fR? -Remove a keyed value from the graph. If no key is specified, the key -\fBdata\fR is assumed. -.TP -\fIgraphName\fR \fBwalk\fR \fInode\fR ?\fI-order order\fR? ?\fI-type type\fR? ?\fI-dir direction\fR? \fI-command cmd\fR - -Perform a breadth-first or depth-first walk of the graph starting at -the node \fInode\fR going in either the direction of outgoing or -opposite to the incoming arcs. - -The type of walk, breadth-first or depth-first, is determined by the -value of \fItype\fR; \fBbfs\fR indicates breadth-first, \fBdfs\fR -indicates depth-first. Depth-first is the default. - -The order of the walk, pre-order, post-order or both-order is -determined by the value of \fIorder\fR; \fBpre\fR indicates pre-order, -\fBpost\fR indicates post-order, \fBboth\fR indicates -both-order. Pre-order is the default. Pre-order walking means that a -node is visited before any of its neighbors (as defined by the -\fIdirection\fR, see below). Post-order walking means that a parent is -visited after any of its neighbors. Both-order walking means that a -node is visited before \fBand\fR after any of its neighbors. The -combination of a bread-first walk with post- or both-order is illegal. - -The direction of the walk is determined by the value of \fIdir\fR; -\fBbackward\fR indicates the direction opposite to the incoming arcs, -\fBforward\fR indicates the direction of the outgoing arcs. - -As the walk progresses, the command \fIcmd\fR will be evaluated at -each node, with the mode of the call (\fBenter\fR or \fBleave\fR) and -values \fIgraphName\fR and the name of the current node appended. For -a pre-order walk all nodes are Bentered, for a post-order all nodes -are left. In a both-order walk the first visit of a node \fBenter\fRs -it, the second visit \fBleave\fRs it. - -.SH KEYWORDS -graph DELETED modules/struct/graph.tcl Index: modules/struct/graph.tcl ================================================================== --- modules/struct/graph.tcl +++ /dev/null @@ -1,2117 +0,0 @@ -# graph.tcl -- -# -# Implementation of a graph data structure for Tcl. -# -# Copyright (c) 2000 by Andreas Kupries -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: graph.tcl,v 1.9 2003/04/15 17:44:51 andreas_kupries Exp $ - -# Create the namespace before determining cgraph vs. tcl -# Otherwise the loading 'struct.tcl' may get into trouble -# when trying to import commands from them - -namespace eval ::struct {} -namespace eval ::struct::graph {} - -# Try to load the cgraph package -# Get it at http://physnet.uni-oldenburg.de/~schlenk/tcl/graph/ - -if {![catch {package require cgraph 0.6}]} { - # the cgraph package takes over, so we can return - return -} - -namespace eval ::struct {} -namespace eval ::struct::graph { - # Data storage in the graph module - # ------------------------------- - # - # There's a lot of bits to keep track of for each graph: - # nodes - # node values - # node relationships (arcs) - # arc values - # - # It would quickly become unwieldy to try to keep these in arrays or lists - # within the graph namespace itself. Instead, each graph structure will - # get its own namespace. Each namespace contains: - # node:$node array mapping keys to values for the node $node - # arc:$arc array mapping keys to values for the arc $arc - # inArcs array mapping nodes to the list of incoming arcs - # outArcs array mapping nodes to the list of outgoing arcs - # arcNodes array mapping arcs to the two nodes (start & end) - - # counter is used to give a unique name for unnamed graph - variable counter 0 - - # commands is the list of subcommands recognized by the graph - variable commands [list \ - "arc" \ - "arcs" \ - "destroy" \ - "get" \ - "getall" \ - "keys" \ - "keyexists" \ - "node" \ - "nodes" \ - "set" \ - "swap" \ - "unset" \ - "walk" \ - ] - - variable arcCommands [list \ - "append" \ - "delete" \ - "exists" \ - "get" \ - "getall" \ - "insert" \ - "keys" \ - "keyexists" \ - "lappend" \ - "set" \ - "source" \ - "target" \ - "unset" \ - ] - - variable nodeCommands [list \ - "append" \ - "degree" \ - "delete" \ - "exists" \ - "get" \ - "getall" \ - "insert" \ - "keys" \ - "keyexists" \ - "lappend" \ - "opposite" \ - "set" \ - "unset" \ - ] - - # Only export one command, the one used to instantiate a new graph - namespace export graph -} - -# ::struct::graph::graph -- -# -# Create a new graph with a given name; if no name is given, use -# graphX, where X is a number. -# -# Arguments: -# name name of the graph; if null, generate one. -# -# Results: -# name name of the graph created - -proc ::struct::graph::graph {{name ""}} { - variable counter - - if { [llength [info level 0]] == 1 } { - incr counter - set name "graph${counter}" - } - - if { ![string equal [info commands ::$name] ""] } { - error "command \"$name\" already exists, unable to create graph" - } - - # Set up the namespace - namespace eval ::struct::graph::graph$name { - - # Set up the map for values associated with the graph itself - variable graphData - array set graphData {data ""} - - # Set up the map from nodes to the arcs coming to them - variable inArcs - array set inArcs {} - - # Set up the map from nodes to the arcs going out from them - variable outArcs - array set outArcs {} - - # Set up the map from arcs to the nodes they touch. - variable arcNodes - array set arcNodes {} - - # Set up a value for use in creating unique node names - variable nextUnusedNode - set nextUnusedNode 1 - - # Set up a value for use in creating unique arc names - variable nextUnusedArc - set nextUnusedArc 1 - } - - # Create the command to manipulate the graph - interp alias {} ::$name {} ::struct::graph::GraphProc $name - - return $name -} - -########################## -# Private functions follow - -# ::struct::graph::GraphProc -- -# -# Command that processes all graph object commands. -# -# Arguments: -# name name of the graph object to manipulate. -# args command name and args for the command -# -# Results: -# Varies based on command to perform - -proc ::struct::graph::GraphProc {name {cmd ""} args} { - # Do minimal args checks here - if { [llength [info level 0]] == 2 } { - error "wrong # args: should be \"$name option ?arg arg ...?\"" - } - - # Split the args into command and args components - if { [llength [info commands ::struct::graph::_$cmd]] == 0 } { - variable commands - set optlist [join $commands ", "] - set optlist [linsert $optlist "end-1" "or"] - error "bad option \"$cmd\": must be $optlist" - } - eval [list ::struct::graph::_$cmd $name] $args -} - -# ::struct::graph::_arc -- -# -# Dispatches the invocation of arc methods to the proper handler -# procedure. -# -# Arguments: -# name name of the graph. -# cmd arc command to invoke -# args arguments to propagate to the handler for the arc command -# -# Results: -# As of the invoked handler. - -proc ::struct::graph::_arc {name cmd args} { - - # Split the args into command and args components - if { [llength [info commands ::struct::graph::__arc_$cmd]] == 0 } { - variable arcCommands - set optlist [join $arcCommands ", "] - set optlist [linsert $optlist "end-1" "or"] - error "bad option \"$cmd\": must be $optlist" - } - - eval [list ::struct::graph::__arc_$cmd $name] $args -} - -# ::struct::graph::__arc_delete -- -# -# Remove an arc from a graph, including all of its values. -# -# Arguments: -# name name of the graph. -# args list of arcs to delete. -# -# Results: -# None. - -proc ::struct::graph::__arc_delete {name args} { - - foreach arc $args { - if { ![__arc_exists $name $arc] } { - error "arc \"$arc\" does not exist in graph \"$name\"" - } - } - - upvar ::struct::graph::graph${name}::inArcs inArcs - upvar ::struct::graph::graph${name}::outArcs outArcs - upvar ::struct::graph::graph${name}::arcNodes arcNodes - - foreach arc $args { - foreach {source target} $arcNodes($arc) break ; # lassign - - unset arcNodes($arc) - # FRINK: nocheck - unset ::struct::graph::graph${name}::arc$arc - - # Remove arc from the arc lists of source and target nodes. - - set index [lsearch -exact $outArcs($source) $arc] - set outArcs($source) [lreplace $outArcs($source) $index $index] - - set index [lsearch -exact $inArcs($target) $arc] - set inArcs($target) [lreplace $inArcs($target) $index $index] - } - - return -} - -# ::struct::graph::__arc_exists -- -# -# Test for existance of a given arc in a graph. -# -# Arguments: -# name name of the graph. -# arc arc to look for. -# -# Results: -# 1 if the arc exists, 0 else. - -proc ::struct::graph::__arc_exists {name arc} { - return [info exists ::struct::graph::graph${name}::arcNodes($arc)] -} - -# ::struct::graph::__arc_get -- -# -# Get a keyed value from an arc in a graph. -# -# Arguments: -# name name of the graph. -# arc arc to query. -# flag -key; anything else is an error -# key key to lookup; defaults to data -# -# Results: -# value value associated with the key given. - -proc ::struct::graph::__arc_get {name arc {flag -key} {key data}} { - if { ![__arc_exists $name $arc] } { - error "arc \"$arc\" does not exist in graph \"$name\"" - } - - upvar ::struct::graph::graph${name}::arc${arc} data - - if { ![info exists data($key)] } { - error "invalid key \"$key\" for arc \"$arc\"" - } - - return $data($key) -} - -# ::struct::graph::__arc_getall -- -# -# Get a serialized array of key/value pairs from an arc in a graph. -# -# Arguments: -# name name of the graph. -# arc arc to query. -# -# Results: -# value serialized array of key/value pairs. - -proc ::struct::graph::__arc_getall {name arc args} { - if { ![__arc_exists $name $arc] } { - error "arc \"$arc\" does not exist in graph \"$name\"" - } - - if { [llength $args] } { - error "wrong # args: should be none" - } - - upvar ::struct::graph::graph${name}::arc${arc} data - - return [array get data] -} - -# ::struct::graph::__arc_keys -- -# -# Get a list of keys for an arc in a graph. -# -# Arguments: -# name name of the graph. -# arc arc to query. -# -# Results: -# value value associated with the key given. - -proc ::struct::graph::__arc_keys {name arc args} { - if { ![__arc_exists $name $arc] } { - error "arc \"$arc\" does not exist in graph \"$name\"" - } - - if { [llength $args] } { - error "wrong # args: should be none" - } - - upvar ::struct::graph::graph${name}::arc${arc} data - - return [array names data] -} - -# ::struct::graph::__arc_keyexists -- -# -# Test for existance of a given key for a given arc in a graph. -# -# Arguments: -# name name of the graph. -# arc arc to query. -# flag -key; anything else is an error -# key key to lookup; defaults to data -# -# Results: -# 1 if the key exists, 0 else. - -proc ::struct::graph::__arc_keyexists {name arc {flag -key} {key data}} { - if { ![__arc_exists $name $arc] } { - error "arc \"$arc\" does not exist in graph \"$name\"" - } - - if { ![string equal $flag "-key"] } { - error "invalid option \"$flag\": should be -key" - } - - upvar ::struct::graph::graph${name}::arc${arc} data - - return [info exists data($key)] -} - -# ::struct::graph::__arc_insert -- -# -# Add an arc to a graph. -# -# Arguments: -# name name of the graph. -# source source node of the new arc -# target target node of the new arc -# args arc to insert; must be unique. If none is given, -# the routine will generate a unique node name. -# -# Results: -# arc The name of the new arc. - -proc ::struct::graph::__arc_insert {name source target args} { - - if { [llength $args] == 0 } { - # No arc name was given; generate a unique one - set arc [__generateUniqueArcName $name] - } else { - set arc [lindex $args 0] - } - - if { [__arc_exists $name $arc] } { - error "arc \"$arc\" already exists in graph \"$name\"" - } - - if { ![__node_exists $name $source] } { - error "source node \"$source\" does not exist in graph \"$name\"" - } - - if { ![__node_exists $name $target] } { - error "target node \"$target\" does not exist in graph \"$name\"" - } - - upvar ::struct::graph::graph${name}::inArcs inArcs - upvar ::struct::graph::graph${name}::outArcs outArcs - upvar ::struct::graph::graph${name}::arcNodes arcNodes - upvar ::struct::graph::graph${name}::arc${arc} data - - # Set up the new arc - set data(data) "" - set arcNodes($arc) [list $source $target] - - # Add this arc to the arc lists of its source resp. target nodes. - lappend outArcs($source) $arc - lappend inArcs($target) $arc - - return $arc -} - -# ::struct::graph::__arc_set -- -# -# Set or get a value for an arc in a graph. -# -# Arguments: -# name name of the graph. -# arc arc to modify or query. -# args ?-key key? ?value? -# -# Results: -# val value associated with the given key of the given arc - -proc ::struct::graph::__arc_set {name arc args} { - if { ![__arc_exists $name $arc] } { - error "arc \"$arc\" does not exist in graph \"$name\"" - } - - upvar ::struct::graph::graph${name}::arc$arc data - - if { [llength $args] > 3 } { - error "wrong # args: should be \"$name arc set $arc ?-key key?\ - ?value?\"" - } - - set key "data" - set haveValue 0 - if { [llength $args] > 1 } { - foreach {flag key} $args break - if { ![string match "${flag}*" "-key"] } { - error "invalid option \"$flag\": should be key" - } - if { [llength $args] == 3 } { - set haveValue 1 - set value [lindex $args end] - } - } elseif { [llength $args] == 1 } { - set haveValue 1 - set value [lindex $args end] - } - - if { $haveValue } { - # Setting a value - return [set data($key) $value] - } else { - # Getting a value - if { ![info exists data($key)] } { - error "invalid key \"$key\" for arc \"$arc\"" - } - return $data($key) - } -} - -# ::struct::graph::__arc_append -- -# -# Append a value for an arc in a graph. -# -# Arguments: -# name name of the graph. -# arc arc to modify or query. -# args ?-key key? value -# -# Results: -# val value associated with the given key of the given arc - -proc ::struct::graph::__arc_append {name arc args} { - if { ![__arc_exists $name $arc] } { - error "arc \"$arc\" does not exist in graph \"$name\"" - } - - upvar ::struct::graph::graph${name}::arc$arc data - - if { [llength $args] != 1 && [llength $args] != 3 } { - error "wrong # args: should be \"$name arc append $arc ?-key key?\ - value\"" - } - - if { [llength $args] == 3 } { - foreach {flag key} $args break - if { ![string equal $flag "-key"] } { - error "invalid option \"$flag\": should be -key" - } - } else { - set key "data" - } - - set value [lindex $args end] - - return [append data($key) $value] -} - -# ::struct::graph::__arc_lappend -- -# -# lappend a value for an arc in a graph. -# -# Arguments: -# name name of the graph. -# arc arc to modify or query. -# args ?-key key? value -# -# Results: -# val value associated with the given key of the given arc - -proc ::struct::graph::__arc_lappend {name arc args} { - if { ![__arc_exists $name $arc] } { - error "arc \"$arc\" does not exist in graph \"$name\"" - } - - upvar ::struct::graph::graph${name}::arc$arc data - - if { [llength $args] != 1 && [llength $args] != 3 } { - error "wrong # args: should be \"$name arc lappend $arc ?-key key?\ - value\"" - } - - if { [llength $args] == 3 } { - foreach {flag key} $args break - if { ![string equal $flag "-key"] } { - error "invalid option \"$flag\": should be -key" - } - } else { - set key "data" - } - - set value [lindex $args end] - - return [lappend data($key) $value] -} - -# ::struct::graph::__arc_source -- -# -# Return the node at the beginning of the specified arc. -# -# Arguments: -# name name of the graph object. -# arc arc to look up. -# -# Results: -# node name of the node. - -proc ::struct::graph::__arc_source {name arc} { - if { ![__arc_exists $name $arc] } { - error "arc \"$arc\" does not exist in graph \"$name\"" - } - - upvar ::struct::graph::graph${name}::arcNodes arcNodes - return [lindex $arcNodes($arc) 0] -} - -# ::struct::graph::__arc_target -- -# -# Return the node at the end of the specified arc. -# -# Arguments: -# name name of the graph object. -# arc arc to look up. -# -# Results: -# node name of the node. - -proc ::struct::graph::__arc_target {name arc} { - if { ![__arc_exists $name $arc] } { - error "arc \"$arc\" does not exist in graph \"$name\"" - } - - upvar ::struct::graph::graph${name}::arcNodes arcNodes - return [lindex $arcNodes($arc) 1] -} - -# ::struct::graph::__arc_unset -- -# -# Remove a keyed value from a arc. -# -# Arguments: -# name name of the graph. -# arc arc to modify. -# args additional args: ?-key key? -# -# Results: -# None. - -proc ::struct::graph::__arc_unset {name arc {flag -key} {key data}} { - if { ![__arc_exists $name $arc] } { - error "arc \"$arc\" does not exist in graph \"$name\"" - } - - if { ![string match "${flag}*" "-key"] } { - error "invalid option \"$flag\": should be \"$name arc unset\ - $arc ?-key key?\"" - } - - upvar ::struct::graph::graph${name}::arc${arc} data - if { [info exists data($key)] } { - unset data($key) - } - return -} - -# ::struct::graph::_arcs -- -# -# Return a list of all arcs in a graph satisfying some -# node based restriction. -# -# Arguments: -# name name of the graph. -# -# Results: -# arcs list of arcs - -proc ::struct::graph::_arcs {name args} { - - # Discriminate between conditions and nodes - - set haveCond 0 - set haveKey 0 - set haveValue 0 - set cond "none" - set condNodes [list] - - for {set i 0} {$i < [llength $args]} {incr i} { - set arg [lindex $args $i] - switch -glob -- $arg { - -in - - -out - - -adj - - -inner - - -embedding { - set haveCond 1 - set cond [string range $arg 1 end] - } - -key { - incr i - set key [lindex $args $i] - set haveKey 1 - } - -value { - incr i - set value [lindex $args $i] - set haveValue 1 - } - -* { - error "invalid restriction \"$arg\": should be -in, -out,\ - -adj, -inner, -embedding, -key or -value" - } - default { - lappend condNodes $arg - } - } - } - - # Validate that there are nodes to use in the restriction. - # otherwise what's the point? - if {$haveCond} { - if {[llength $condNodes] == 0} { - set usage "$name arcs ?-key key? ?-value value? ?-in|-out|-adj|-inner|-embedding node node...?" - error "no nodes specified: should be \"$usage\"" - } - - # Make sure that the specified nodes exist! - foreach node $condNodes { - if { ![__node_exists $name $node] } { - error "node \"$node\" does not exist in graph \"$name\"" - } - } - } - - # Now we are able to go to work - upvar ::struct::graph::graph${name}::inArcs inArcs - upvar ::struct::graph::graph${name}::outArcs outArcs - upvar ::struct::graph::graph${name}::arcNodes arcNodes - - set arcs [list] - - switch -exact -- $cond { - in { - # Result is all arcs going to at least one node - # in the list of arguments. - - foreach node $condNodes { - foreach e $inArcs($node) { - # As an arc has only one destination, i.e. is the - # in-arc of exactly one node it is impossible to - # count an arc twice. IOW the [info exists] below - # is never true. Found through coverage analysis - # and then trying to think up a testcase invoking - # the continue. - # if {[info exists coll($e)]} {continue} - lappend arcs $e - #set coll($e) . - } - } - } - out { - # Result is all arcs coming from at least one node - # in the list of arguments. - - foreach node $condNodes { - foreach e $outArcs($node) { - # See above 'in', same reasoning, one source per arc. - # if {[info exists coll($e)]} {continue} - lappend arcs $e - #set coll($e) . - } - } - } - adj { - # Result is all arcs coming from or going to at - # least one node in the list of arguments. - - array set coll {} - # Here we do need 'coll' as each might be an in- and - # out-arc for one or two nodes in the list of arguments. - - foreach node $condNodes { - foreach e $inArcs($node) { - if {[info exists coll($e)]} {continue} - lappend arcs $e - set coll($e) . - } - foreach e $outArcs($node) { - if {[info exists coll($e)]} {continue} - lappend arcs $e - set coll($e) . - } - } - } - inner { - # Result is all arcs running between nodes in the list. - - array set coll {} - # Here we do need 'coll' as each might be an in- and - # out-arc for one or two nodes in the list of arguments. - - array set group {} - foreach node $condNodes { - set group($node) . - } - - foreach node $condNodes { - foreach e $inArcs($node) { - set n [lindex $arcNodes($e) 0] - if {![info exists group($n)]} {continue} - if { [info exists coll($e)]} {continue} - lappend arcs $e - set coll($e) . - } - foreach e $outArcs($node) { - set n [lindex $arcNodes($e) 1] - if {![info exists group($n)]} {continue} - if { [info exists coll($e)]} {continue} - lappend arcs $e - set coll($e) . - } - } - } - embedding { - # Result is all arcs from -adj minus the arcs from -inner. - # IOW all arcs going from a node in the list to a node - # which is *not* in the list - - # This also means that no arc can be counted twice as it - # is either going to a node, or coming from a node in the - # list, but it can't do both, because then it is part of - # -inner, which was excluded! - - array set group {} - foreach node $condNodes { - set group($node) . - } - - foreach node $condNodes { - foreach e $inArcs($node) { - set n [lindex $arcNodes($e) 0] - if {[info exists group($n)]} {continue} - # if {[info exists coll($e)]} {continue} - lappend arcs $e - # set coll($e) . - } - foreach e $outArcs($node) { - set n [lindex $arcNodes($e) 1] - if {[info exists group($n)]} {continue} - # if {[info exists coll($e)]} {continue} - lappend arcs $e - # set coll($e) . - } - } - } - none { - set arcs [array names arcNodes] - } - default {error "Can't happen, panic"} - } - - # - # We have a list of arcs that match the relation to the nodes. - # Now filter according to -key and -value. - # - - set filteredArcs [list] - - if {$haveKey} { - foreach arc $arcs { - catch { - set aval [__arc_get $name $arc -key $key] - if {$haveValue} { - if {$aval == $value} { - lappend filteredArcs $arc - } - } else { - lappend filteredArcs $arc - } - } - } - } else { - set filteredArcs $arcs - } - - return $filteredArcs -} - -# ::struct::graph::_destroy -- -# -# Destroy a graph, including its associated command and data storage. -# -# Arguments: -# name name of the graph. -# -# Results: -# None. - -proc ::struct::graph::_destroy {name} { - namespace delete ::struct::graph::graph$name - interp alias {} ::$name {} -} - -# ::struct::graph::__generateUniqueArcName -- -# -# Generate a unique arc name for the given graph. -# -# Arguments: -# name name of the graph. -# -# Results: -# arc name of a arc guaranteed to not exist in the graph. - -proc ::struct::graph::__generateUniqueArcName {name} { - upvar ::struct::graph::graph${name}::nextUnusedArc nextUnusedArc - while {[__arc_exists $name "arc${nextUnusedArc}"]} { - incr nextUnusedArc - } - return "arc${nextUnusedArc}" -} - -# ::struct::graph::__generateUniqueNodeName -- -# -# Generate a unique node name for the given graph. -# -# Arguments: -# name name of the graph. -# -# Results: -# node name of a node guaranteed to not exist in the graph. - -proc ::struct::graph::__generateUniqueNodeName {name} { - upvar ::struct::graph::graph${name}::nextUnusedNode nextUnusedNode - while {[__node_exists $name "node${nextUnusedNode}"]} { - incr nextUnusedNode - } - return "node${nextUnusedNode}" -} - -# ::struct::graph::_get -- -# -# Get a keyed value from the graph itself -# -# Arguments: -# name name of the graph. -# flag -key; anything else is an error -# key key to lookup; defaults to data -# -# Results: -# value value associated with the key given. - -proc ::struct::graph::_get {name {flag -key} {key data}} { - upvar ::struct::graph::graph${name}::graphData data - - if { ![info exists data($key)] } { - error "invalid key \"$key\" for graph \"$name\"" - } - - return $data($key) -} - -# ::struct::graph::_getall -- -# -# Get a serialized list of key/value pairs from a graph. -# -# Arguments: -# name name of the graph. -# -# Results: -# value value associated with the key given. - -proc ::struct::graph::_getall {name args} { - if { [llength $args] } { - error "wrong # args: should be none" - } - - upvar ::struct::graph::graph${name}::graphData data - return [array get data] -} - -# ::struct::graph::_keys -- -# -# Get a list of keys from a graph. -# -# Arguments: -# name name of the graph. -# -# Results: -# value list of known keys - -proc ::struct::graph::_keys {name args} { - if { [llength $args] } { - error "wrong # args: should be none" - } - - upvar ::struct::graph::graph${name}::graphData data - return [array names data] -} - -# ::struct::graph::_keyexists -- -# -# Test for existance of a given key in a graph. -# -# Arguments: -# name name of the graph. -# flag -key; anything else is an error -# key key to lookup; defaults to data -# -# Results: -# 1 if the key exists, 0 else. - -proc ::struct::graph::_keyexists {name {flag -key} {key data}} { - if { ![string equal $flag "-key"] } { - error "invalid option \"$flag\": should be -key" - } - - upvar ::struct::graph::graph${name}::graphData data - return [info exists data($key)] -} - -# ::struct::graph::_node -- -# -# Dispatches the invocation of node methods to the proper handler -# procedure. -# -# Arguments: -# name name of the graph. -# cmd node command to invoke -# args arguments to propagate to the handler for the node command -# -# Results: -# As of the the invoked handler. - -proc ::struct::graph::_node {name cmd args} { - - # Split the args into command and args components - if { [llength [info commands ::struct::graph::__node_$cmd]] == 0 } { - variable nodeCommands - set optlist [join $nodeCommands ", "] - set optlist [linsert $optlist "end-1" "or"] - error "bad option \"$cmd\": must be $optlist" - } - - eval [list ::struct::graph::__node_$cmd $name] $args -} - -# ::struct::graph::__node_degree -- -# -# Return the number of arcs adjacent to the specified node. -# If one of the restrictions -in or -out is given only -# incoming resp. outgoing arcs are counted. -# -# Arguments: -# name name of the graph. -# args option, followed by the node. -# -# Results: -# None. - -proc ::struct::graph::__node_degree {name args} { - - if {([llength $args] < 1) || ([llength $args] > 2)} { - error "wrong # args: should be \"$name node degree ?-in|-out? node\"" - } - - switch -exact -- [llength $args] { - 1 { - set opt {} - set node [lindex $args 0] - } - 2 { - set opt [lindex $args 0] - set node [lindex $args 1] - } - default {error "Can't happen, panic"} - } - - # Validate the option. - - switch -exact -- $opt { - {} - - -in - - -out {} - default { - error "invalid option \"$opt\": should be -in or -out" - } - } - - # Validate the node - - if { ![__node_exists $name $node] } { - error "node \"$node\" does not exist in graph \"$name\"" - } - - upvar ::struct::graph::graph${name}::inArcs inArcs - upvar ::struct::graph::graph${name}::outArcs outArcs - - switch -exact -- $opt { - -in { - set result [llength $inArcs($node)] - } - -out { - set result [llength $outArcs($node)] - } - {} { - set result [expr {[llength $inArcs($node)] \ - + [llength $outArcs($node)]}] - - # loops count twice, don't do arithmetics, i.e. no union! - if {0} { - array set coll {} - set result [llength $inArcs($node)] - - foreach e $inArcs($node) { - set coll($e) . - } - foreach e $outArcs($node) { - if {[info exists coll($e)]} {continue} - incr result - set coll($e) . - } - } - } - default {error "Can't happen, panic"} - } - - return $result -} - -# ::struct::graph::__node_delete -- -# -# Remove a node from a graph, including all of its values. -# Additionally removes the arcs connected to this node. -# -# Arguments: -# name name of the graph. -# args list of the nodes to delete. -# -# Results: -# None. - -proc ::struct::graph::__node_delete {name args} { - - foreach node $args { - if { ![__node_exists $name $node] } { - error "node \"$node\" does not exist in graph \"$name\"" - } - } - - upvar ::struct::graph::graph${name}::inArcs inArcs - upvar ::struct::graph::graph${name}::outArcs outArcs - - foreach node $args { - # Remove all the arcs connected to this node - foreach e $inArcs($node) { - __arc_delete $name $e - } - foreach e $outArcs($node) { - # Check existence to avoid problems with - # loops (they are in and out arcs! at - # the same time and thus already deleted) - if { [__arc_exists $name $e] } { - __arc_delete $name $e - } - } - - unset inArcs($node) - unset outArcs($node) - # FRINK: nocheck - unset ::struct::graph::graph${name}::node$node - } - - return -} - -# ::struct::graph::__node_exists -- -# -# Test for existance of a given node in a graph. -# -# Arguments: -# name name of the graph. -# node node to look for. -# -# Results: -# 1 if the node exists, 0 else. - -proc ::struct::graph::__node_exists {name node} { - return [info exists ::struct::graph::graph${name}::inArcs($node)] -} - -# ::struct::graph::__node_get -- -# -# Get a keyed value from a node in a graph. -# -# Arguments: -# name name of the graph. -# node node to query. -# flag -key; anything else is an error -# key key to lookup; defaults to data -# -# Results: -# value value associated with the key given. - -proc ::struct::graph::__node_get {name node {flag -key} {key data}} { - if { ![__node_exists $name $node] } { - error "node \"$node\" does not exist in graph \"$name\"" - } - - upvar ::struct::graph::graph${name}::node${node} data - - if { ![info exists data($key)] } { - error "invalid key \"$key\" for node \"$node\"" - } - - return $data($key) -} - -# ::struct::graph::__node_getall -- -# -# Get a serialized list of key/value pairs from a node in a graph. -# -# Arguments: -# name name of the graph. -# node node to query. -# -# Results: -# value value associated with the key given. - -proc ::struct::graph::__node_getall {name node args} { - if { ![__node_exists $name $node] } { - error "node \"$node\" does not exist in graph \"$name\"" - } - - if { [llength $args] } { - error "wrong # args: should be none" - } - - upvar ::struct::graph::graph${name}::node${node} data - - return [array get data] -} - -# ::struct::graph::__node_keys -- -# -# Get a list of keys from a node in a graph. -# -# Arguments: -# name name of the graph. -# node node to query. -# -# Results: -# value value associated with the key given. - -proc ::struct::graph::__node_keys {name node args} { - if { ![__node_exists $name $node] } { - error "node \"$node\" does not exist in graph \"$name\"" - } - - if { [llength $args] } { - error "wrong # args: should be none" - } - - upvar ::struct::graph::graph${name}::node${node} data - - return [array names data] -} - -# ::struct::graph::__node_keyexists -- -# -# Test for existance of a given key for a node in a graph. -# -# Arguments: -# name name of the graph. -# node node to query. -# flag -key; anything else is an error -# key key to lookup; defaults to data -# -# Results: -# 1 if the key exists, 0 else. - -proc ::struct::graph::__node_keyexists {name node {flag -key} {key data}} { - if { ![__node_exists $name $node] } { - error "node \"$node\" does not exist in graph \"$name\"" - } - - if { ![string equal $flag "-key"] } { - error "invalid option \"$flag\": should be -key" - } - - upvar ::struct::graph::graph${name}::node${node} data - - return [info exists data($key)] -} - -# ::struct::graph::__node_insert -- -# -# Add a node to a graph. -# -# Arguments: -# name name of the graph. -# args node to insert; must be unique. If none is given, -# the routine will generate a unique node name. -# -# Results: -# node The namee of the new node. - -proc ::struct::graph::__node_insert {name args} { - - if { [llength $args] == 0 } { - # No node name was given; generate a unique one - set node [__generateUniqueNodeName $name] - } else { - set node [lindex $args 0] - } - - if { [__node_exists $name $node] } { - error "node \"$node\" already exists in graph \"$name\"" - } - - upvar ::struct::graph::graph${name}::inArcs inArcs - upvar ::struct::graph::graph${name}::outArcs outArcs - upvar ::struct::graph::graph${name}::node${node} data - - # Set up the new node - set inArcs($node) [list] - set outArcs($node) [list] - set data(data) "" - - return $node -} - -# ::struct::graph::__node_opposite -- -# -# Retrieve node opposite to the specified one, along the arc. -# -# Arguments: -# name name of the graph. -# node node to look up. -# arc arc to look up. -# -# Results: -# nodex Node opposite to - -proc ::struct::graph::__node_opposite {name node arc} { - if {![__node_exists $name $node] } { - error "node \"$node\" does not exist in graph \"$name\"" - } - - if {![__arc_exists $name $arc] } { - error "arc \"$arc\" does not exist in graph \"$name\"" - } - - upvar ::struct::graph::graph${name}::arcNodes arcNodes - - # Node must be connected to at least one end of the arc. - - if {[string equal $node [lindex $arcNodes($arc) 0]]} { - set result [lindex $arcNodes($arc) 1] - } elseif {[string equal $node [lindex $arcNodes($arc) 1]]} { - set result [lindex $arcNodes($arc) 0] - } else { - error "node \"$node\" and arc \"$arc\" are not connected\ - in graph \"$name\"" - } - - return $result -} - -# ::struct::graph::__node_set -- -# -# Set or get a value for a node in a graph. -# -# Arguments: -# name name of the graph. -# node node to modify or query. -# args ?-key key? ?value? -# -# Results: -# val value associated with the given key of the given node - -proc ::struct::graph::__node_set {name node args} { - if { ![__node_exists $name $node] } { - error "node \"$node\" does not exist in graph \"$name\"" - } - upvar ::struct::graph::graph${name}::node$node data - - if { [llength $args] > 3 } { - error "wrong # args: should be \"$name node set $node ?-key key?\ - ?value?\"" - } - - set key "data" - set haveValue 0 - if { [llength $args] > 1 } { - foreach {flag key} $args break - if { ![string match "${flag}*" "-key"] } { - error "invalid option \"$flag\": should be key" - } - if { [llength $args] == 3 } { - set haveValue 1 - set value [lindex $args end] - } - } elseif { [llength $args] == 1 } { - set haveValue 1 - set value [lindex $args end] - } - - if { $haveValue } { - # Setting a value - return [set data($key) $value] - } else { - # Getting a value - if { ![info exists data($key)] } { - error "invalid key \"$key\" for node \"$node\"" - } - return $data($key) - } -} - -# ::struct::graph::__node_append -- -# -# Append a value for a node in a graph. -# -# Arguments: -# name name of the graph. -# node node to modify or query. -# args ?-key key? value -# -# Results: -# val value associated with the given key of the given node - -proc ::struct::graph::__node_append {name node args} { - if { ![__node_exists $name $node] } { - error "node \"$node\" does not exist in graph \"$name\"" - } - upvar ::struct::graph::graph${name}::node$node data - - if { [llength $args] != 1 && [llength $args] != 3 } { - error "wrong # args: should be \"$name node append $node ?-key key?\ - value\"" - } - - if { [llength $args] == 3 } { - foreach {flag key} $args break - if { ![string equal $flag "-key"] } { - error "invalid option \"$flag\": should be -key" - } - } else { - set key "data" - } - - set value [lindex $args end] - - return [append data($key) $value] -} - -# ::struct::graph::__node_lappend -- -# -# lappend a value for a node in a graph. -# -# Arguments: -# name name of the graph. -# node node to modify or query. -# args ?-key key? value -# -# Results: -# val value associated with the given key of the given node - -proc ::struct::graph::__node_lappend {name node args} { - if { ![__node_exists $name $node] } { - error "node \"$node\" does not exist in graph \"$name\"" - } - upvar ::struct::graph::graph${name}::node$node data - - if { [llength $args] != 1 && [llength $args] != 3 } { - error "wrong # args: should be \"$name node lappend $node ?-key key?\ - value\"" - } - - if { [llength $args] == 3 } { - foreach {flag key} $args break - if { ![string equal $flag "-key"] } { - error "invalid option \"$flag\": should be -key" - } - } else { - set key "data" - } - - set value [lindex $args end] - - return [lappend data($key) $value] -} - -# ::struct::graph::__node_unset -- -# -# Remove a keyed value from a node. -# -# Arguments: -# name name of the graph. -# node node to modify. -# args additional args: ?-key key? -# -# Results: -# None. - -proc ::struct::graph::__node_unset {name node {flag -key} {key data}} { - if { ![__node_exists $name $node] } { - error "node \"$node\" does not exist in graph \"$name\"" - } - - if { ![string match "${flag}*" "-key"] } { - error "invalid option \"$flag\": should be \"$name node unset\ - $node ?-key key?\"" - } - - upvar ::struct::graph::graph${name}::node${node} data - if { [info exists data($key)] } { - unset data($key) - } - return -} - -# ::struct::graph::_nodes -- -# -# Return a list of all nodes in a graph satisfying some restriction. -# -# Arguments: -# name name of the graph. -# args list of options and nodes specifying the restriction. -# -# Results: -# nodes list of nodes - -proc ::struct::graph::_nodes {name args} { - - # Discriminate between conditions and nodes - - set haveCond 0 - set haveKey 0 - set haveValue 0 - set cond "none" - set condNodes [list] - - for {set i 0} {$i < [llength $args]} {incr i} { - set arg [lindex $args $i] - switch -glob -- $arg { - -in - - -out - - -adj - - -inner - - -embedding { - set haveCond 1 - set cond [string range $arg 1 end] - } - -key { - incr i - set key [lindex $args $i] - set haveKey 1 - } - -value { - incr i - set value [lindex $args $i] - set haveValue 1 - } - -* { - error "invalid restriction \"$arg\": should be -in, -out,\ - -adj, -inner, -embedding, -key or -value" - } - default { - lappend condNodes $arg - } - } - } - - # Validate that there are nodes to use in the restriction. - # otherwise what's the point? - if {$haveCond} { - if {[llength $condNodes] == 0} { - set usage "$name nodes ?-key key? ?-value value? ?-in|-out|-adj|-inner|-embedding node node...?" - error "no nodes specified: should be \"$usage\"" - } - - # Make sure that the specified nodes exist! - foreach node $condNodes { - if { ![__node_exists $name $node] } { - error "node \"$node\" does not exist in graph \"$name\"" - } - } - } - - # Now we are able to go to work - upvar ::struct::graph::graph${name}::inArcs inArcs - upvar ::struct::graph::graph${name}::outArcs outArcs - upvar ::struct::graph::graph${name}::arcNodes arcNodes - - set nodes [list] - array set coll {} - - switch -exact -- $cond { - in { - # Result is all nodes with at least one arc going to - # at least one node in the list of arguments. - - foreach node $condNodes { - foreach e $inArcs($node) { - set n [lindex $arcNodes($e) 0] - if {[info exists coll($n)]} {continue} - lappend nodes $n - set coll($n) . - } - } - } - out { - # Result is all nodes with at least one arc coming from - # at least one node in the list of arguments. - - foreach node $condNodes { - foreach e $outArcs($node) { - set n [lindex $arcNodes($e) 1] - if {[info exists coll($n)]} {continue} - lappend nodes $n - set coll($n) . - } - } - } - adj { - # Result is all nodes with at least one arc coming from - # or going to at least one node in the list of arguments. - - foreach node $condNodes { - foreach e $inArcs($node) { - set n [lindex $arcNodes($e) 0] - if {[info exists coll($n)]} {continue} - lappend nodes $n - set coll($n) . - } - foreach e $outArcs($node) { - set n [lindex $arcNodes($e) 1] - if {[info exists coll($n)]} {continue} - lappend nodes $n - set coll($n) . - } - } - } - inner { - # Result is all nodes from the list! with at least one arc - # coming from or going to at least one node in the list of - # arguments. - - array set group {} - foreach node $condNodes { - set group($node) . - } - - foreach node $condNodes { - foreach e $inArcs($node) { - set n [lindex $arcNodes($e) 0] - if {![info exists group($n)]} {continue} - if { [info exists coll($n)]} {continue} - lappend nodes $n - set coll($n) . - } - foreach e $outArcs($node) { - set n [lindex $arcNodes($e) 1] - if {![info exists group($n)]} {continue} - if { [info exists coll($n)]} {continue} - lappend nodes $n - set coll($n) . - } - } - } - embedding { - # Result is all nodes with at least one arc coming from - # or going to at least one node in the list of arguments, - # but not in the list itself! - - array set group {} - foreach node $condNodes { - set group($node) . - } - - foreach node $condNodes { - foreach e $inArcs($node) { - set n [lindex $arcNodes($e) 0] - if {[info exists group($n)]} {continue} - if {[info exists coll($n)]} {continue} - lappend nodes $n - set coll($n) . - } - foreach e $outArcs($node) { - set n [lindex $arcNodes($e) 1] - if {[info exists group($n)]} {continue} - if {[info exists coll($n)]} {continue} - lappend nodes $n - set coll($n) . - } - } - } - none { - set nodes [array names inArcs] - } - default {error "Can't happen, panic"} - } - - # - # We have a list of nodes that match the relation to the nodes. - # Now filter according to -key and -value. - # - - set filteredNodes [list] - - if {$haveKey} { - foreach node $nodes { - catch { - set nval [__node_get $name $node -key $key] - if {$haveValue} { - if {$nval == $value} { - lappend filteredNodes $node - } - } else { - lappend filteredNodes $node - } - } - } - } else { - set filteredNodes $nodes - } - - return $filteredNodes -} - -# ::struct::graph::_set -- -# -# Set or get a keyed value from the graph itself -# -# Arguments: -# name name of the graph. -# flag -key; anything else is an error -# args ?-key key? ?value? -# -# Results: -# value value associated with the key given. - -proc ::struct::graph::_set {name args} { - upvar ::struct::graph::graph${name}::graphData data - - if { [llength $args] > 3 } { - error "wrong # args: should be \"$name set ?-key key?\ - ?value?\"" - } - - set key "data" - set haveValue 0 - if { [llength $args] > 1 } { - foreach {flag key} $args break - if { ![string match "${flag}*" "-key"] } { - error "invalid option \"$flag\": should be key" - } - if { [llength $args] == 3 } { - set haveValue 1 - set value [lindex $args end] - } - } elseif { [llength $args] == 1 } { - set haveValue 1 - set value [lindex $args end] - } - - if { $haveValue } { - # Setting a value - return [set data($key) $value] - } else { - # Getting a value - if { ![info exists data($key)] } { - error "invalid key \"$key\" for graph \"$name\"" - } - return $data($key) - } -} - -# ::struct::graph::_swap -- -# -# Swap two nodes in a graph. -# -# Arguments: -# name name of the graph. -# node1 first node to swap. -# node2 second node to swap. -# -# Results: -# None. - -proc ::struct::graph::_swap {name node1 node2} { - # Can only swap two real nodes - if { ![__node_exists $name $node1] } { - error "node \"$node1\" does not exist in graph \"$name\"" - } - if { ![__node_exists $name $node2] } { - error "node \"$node2\" does not exist in graph \"$name\"" - } - - # Can't swap a node with itself - if { [string equal $node1 $node2] } { - error "cannot swap node \"$node1\" with itself" - } - - # Swapping nodes means swapping their labels, values and arcs - upvar ::struct::graph::graph${name}::outArcs outArcs - upvar ::struct::graph::graph${name}::inArcs inArcs - upvar ::struct::graph::graph${name}::arcNodes arcNodes - upvar ::struct::graph::graph${name}::node${node1} node1Vals - upvar ::struct::graph::graph${name}::node${node2} node2Vals - - # Redirect arcs to the new nodes. - - foreach e $inArcs($node1) { - set arcNodes($e) [lreplace $arcNodes($e) end end $node2] - } - foreach e $inArcs($node2) { - set arcNodes($e) [lreplace $arcNodes($e) end end $node1] - } - foreach e $outArcs($node1) { - set arcNodes($e) [lreplace $arcNodes($e) 0 0 $node2] - } - foreach e $outArcs($node2) { - set arcNodes($e) [lreplace $arcNodes($e) 0 0 $node1] - } - - # Swap arc lists - - set tmp $inArcs($node1) - set inArcs($node1) $inArcs($node2) - set inArcs($node2) $tmp - - set tmp $outArcs($node1) - set outArcs($node1) $outArcs($node2) - set outArcs($node2) $tmp - - # Swap the values - set value1 [array get node1Vals] - unset node1Vals - array set node1Vals [array get node2Vals] - unset node2Vals - array set node2Vals $value1 - - return -} - -# ::struct::graph::_unset -- -# -# Remove a keyed value from the graph itself -# -# Arguments: -# name name of the graph. -# flag -key; anything else is an error -# args additional args: ?-key key? -# -# Results: -# None. - -proc ::struct::graph::_unset {name {flag -key} {key data}} { - upvar ::struct::graph::graph${name}::graphData data - - if { ![string match "${flag}*" "-key"] } { - error "invalid option \"$flag\": should be \"$name unset\ - ?-key key?\"" - } - - if { [info exists data($key)] } { - unset data($key) - } - - return -} - -# ::struct::graph::_walk -- -# -# Walk a graph using a pre-order depth or breadth first -# search. Pre-order DFS is the default. At each node that is visited, -# a command will be called with the name of the graph and the node. -# -# Arguments: -# name name of the graph. -# node node at which to start. -# args additional args: ?-order pre|post|both? ?-type {bfs|dfs}? -# -command cmd -# -# Results: -# None. - -proc ::struct::graph::_walk {name node args} { - set usage "$name walk $node ?-dir forward|backward?\ - ?-order pre|post|both? ?-type {bfs|dfs}? -command cmd" - - if {[llength $args] > 8 || [llength $args] < 2} { - error "wrong # args: should be \"$usage\"" - } - - if { ![__node_exists $name $node] } { - error "node \"$node\" does not exist in graph \"$name\"" - } - - # Set defaults - set type dfs - set order pre - set cmd "" - set dir forward - - # Process specified options - for {set i 0} {$i < [llength $args]} {incr i} { - set flag [lindex $args $i] - incr i - if { $i >= [llength $args] } { - error "value for \"$flag\" missing: should be \"$usage\"" - } - switch -glob -- $flag { - "-type" { - set type [string tolower [lindex $args $i]] - } - "-order" { - set order [string tolower [lindex $args $i]] - } - "-command" { - set cmd [lindex $args $i] - } - "-dir" { - set dir [string tolower [lindex $args $i]] - } - default { - error "unknown option \"$flag\": should be \"$usage\"" - } - } - } - - # Make sure we have a command to run, otherwise what's the point? - if { [string equal $cmd ""] } { - error "no command specified: should be \"$usage\"" - } - - # Validate that the given type is good - switch -glob -- $type { - "dfs" { - set type "dfs" - } - "bfs" { - set type "bfs" - } - default { - error "invalid search type \"$type\": should be dfs, or bfs" - } - } - - # Validate that the given order is good - switch -glob -- $order { - "both" { - set order both - } - "pre" { - set order pre - } - "post" { - set order post - } - default { - error "invalid search order \"$order\": should be both,\ - pre or post" - } - } - - # Validate that the given direction is good - switch -glob -- $dir { - "forward" { - set dir -out - } - "backward" { - set dir -in - } - default { - error "invalid search direction \"$dir\": should be\ - forward or backward" - } - } - - # Do the walk - - set st [list ] - lappend st $node - array set visited {} - - if { [string equal $type "dfs"] } { - if { [string equal $order "pre"] } { - # Pre-order Depth-first search - - while { [llength $st] > 0 } { - set node [lindex $st end] - set st [lreplace $st end end] - - # Evaluate the command at this node - set cmdcpy $cmd - lappend cmdcpy enter $name $node - uplevel 2 $cmdcpy - - set visited($node) . - - # Add this node's neighbours (according to direction) - # Have to add them in reverse order - # so that they will be popped left-to-right - - set next [_nodes $name $dir $node] - set len [llength $next] - - for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { - set nextnode [lindex $next $i] - if {[info exists visited($nextnode)]} { - # Skip nodes already visited - continue - } - lappend st $nextnode - } - } - } elseif { [string equal $order "post"] } { - # Post-order Depth-first search - - while { [llength $st] > 0 } { - set node [lindex $st end] - - if {[info exists visited($node)]} { - # Second time we are here, pop it, - # then evaluate the command. - - set st [lreplace $st end end] - - # Evaluate the command at this node - set cmdcpy $cmd - lappend cmdcpy leave $name $node - uplevel 2 $cmdcpy - } else { - # First visit. Remember it. - set visited($node) . - - # Add this node's neighbours. - set next [_nodes $name $dir $node] - set len [llength $next] - - for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { - set nextnode [lindex $next $i] - if {[info exists visited($nextnode)]} { - # Skip nodes already visited - continue - } - lappend st $nextnode - } - } - } - } else { - # Both-order Depth-first search - - while { [llength $st] > 0 } { - set node [lindex $st end] - - if {[info exists visited($node)]} { - # Second time we are here, pop it, - # then evaluate the command. - - set st [lreplace $st end end] - - # Evaluate the command at this node - set cmdcpy $cmd - lappend cmdcpy leave $name $node - uplevel 2 $cmdcpy - } else { - # First visit. Remember it. - set visited($node) . - - # Evaluate the command at this node - set cmdcpy $cmd - lappend cmdcpy enter $name $node - uplevel 2 $cmdcpy - - # Add this node's neighbours. - set next [_nodes $name $dir $node] - set len [llength $next] - - for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { - set nextnode [lindex $next $i] - if {[info exists visited($nextnode)]} { - # Skip nodes already visited - continue - } - lappend st $nextnode - } - } - } - } - - } else { - if { [string equal $order "pre"] } { - # Pre-order Breadth first search - while { [llength $st] > 0 } { - set node [lindex $st 0] - set st [lreplace $st 0 0] - # Evaluate the command at this node - set cmdcpy $cmd - lappend cmdcpy enter $name $node - uplevel 2 $cmdcpy - - set visited($node) . - - # Add this node's neighbours. - foreach child [_nodes $name $dir $node] { - if {[info exists visited($child)]} { - # Skip nodes already visited - continue - } - lappend st $child - } - } - } else { - # Post-order Breadth first search - # Both-order Breadth first search - # Haven't found anything in Knuth - # and unable to define something - # consistent for myself. Leave it - # out. - - error "unable to do a ${order}-order breadth first walk" - } - } - return -} - -# ::struct::graph::Union -- -# -# Return a list which is the union of the elements -# in the specified lists. -# -# Arguments: -# args list of lists representing sets. -# -# Results: -# set list representing the union of the argument lists. - -proc ::struct::graph::Union {args} { - switch -- [llength $args] { - 0 { - return {} - } - 1 { - return [lindex $args 0] - } - default { - foreach set $args { - foreach e $set { - set tmp($e) . - } - } - return [array names tmp] - } - } -} DELETED modules/struct/graph.test Index: modules/struct/graph.test ================================================================== --- modules/struct/graph.test +++ /dev/null @@ -1,1840 +0,0 @@ -# -*- tcl -*- -# graph.test: tests for the graph structure. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 1998-2000 by Ajuba Solutions. -# All rights reserved. -# -# RCS: @(#) $Id: graph.test,v 1.8 2003/04/14 06:58:16 andreas_kupries Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -source [file join [file dirname [info script]] graph.tcl] -namespace import ::struct::graph::graph - -catch {puts "-- cgraph [package present cgraph]"} - - - -# --------------------------------------------------- - -test graph-0.1 {graph errors} { - graph mygraph - catch {graph mygraph} msg - mygraph destroy - set msg -} "command \"mygraph\" already exists, unable to create graph" - -test graph-0.2 {graph errors} { - graph mygraph - catch {mygraph} msg - mygraph destroy - set msg -} "wrong # args: should be \"mygraph option ?arg arg ...?\"" - -test graph-0.3 {graph errors} { - graph mygraph - catch {mygraph foo} msg - mygraph destroy - set msg -} "bad option \"foo\": must be arc, arcs, destroy, get, getall, keys, keyexists, node, nodes, set, swap, unset, or walk" - -test graph-0.4 {graph errors} { - catch {graph set} msg - set msg -} "command \"set\" already exists, unable to create graph" - -test graph-0.5 {graph errors} { - graph mygraph - catch {mygraph arc foo} msg - mygraph destroy - set msg -} "bad option \"foo\": must be append, delete, exists, get, getall, insert, keys, keyexists, lappend, set, source, target, or unset" - -test graph-0.6 {graph errors} { - graph mygraph - catch {mygraph node foo} msg - mygraph destroy - set msg -} "bad option \"foo\": must be append, degree, delete, exists, get, getall, insert, keys, keyexists, lappend, opposite, set, or unset" - -# --------------------------------------------------- - -test graph-1.1 {create} { - graph mygraph - set result [string equal [info commands ::mygraph] "::mygraph"] - mygraph destroy - set result -} 1 - -test graph-1.2 {create} { - set name [graph] - set result [list $name [string equal [info commands ::$name] "::$name"]] - $name destroy - set result -} [list graph1 1] - -test graph-1.3 {destroy} { - graph mygraph - mygraph destroy - string equal [info commands ::mygraph] "" -} 1 - -# --------------------------------------------------- - -test graph-2.1 {arc delete} { - graph mygraph - catch {mygraph arc delete arc0} msg - mygraph destroy - set msg -} "arc \"arc0\" does not exist in graph \"mygraph\"" - -test graph-2.2 {arc delete} { - graph mygraph - - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - mygraph arc delete arc0 - - set result [mygraph arc exists arc0] - mygraph destroy - set result -} {0} - -# --------------------------------------------------- - -test graph-3.1 {arc exists} { - graph mygraph - set result [list] - lappend result [mygraph arc exists arc1] - mygraph node insert node1 - mygraph node insert node2 - mygraph arc insert node1 node2 arc1 - lappend result [mygraph arc exists arc1] - mygraph arc delete arc1 - lappend result [mygraph arc exists arc1] - mygraph destroy - set result -} {0 1 0} - -# --------------------------------------------------- - -test graph-4.1 {arc get gives error on bogus arc} { - graph mygraph - catch {mygraph arc get arc0} msg - mygraph destroy - set msg -} "arc \"arc0\" does not exist in graph \"mygraph\"" - -test graph-4.2 {arc get gives error on bogus key} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - catch {mygraph arc get arc0 -key bogus} msg - mygraph destroy - set msg -} "invalid key \"bogus\" for arc \"arc0\"" - -test graph-4.3 {arc get uses data as default key} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - mygraph arc set arc0 foobar - set result [mygraph arc get arc0] - mygraph destroy - set result -} "foobar" - -test graph-4.4 {arc get respects -key flag} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - mygraph arc set arc0 -key boom foobar - set result [mygraph arc get arc0 -key boom] - mygraph destroy - set result -} "foobar" - -# --------------------------------------------------- - -test graph-5.1 {arc insert gives error on duplicate arc name} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - catch {mygraph arc insert node0 node1 arc0} msg - mygraph destroy - set msg -} "arc \"arc0\" already exists in graph \"mygraph\"" - -test graph-5.2 {arc insert creates and initializes arc} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - set result [list ] - lappend result [mygraph arc exists arc0] - lappend result [mygraph arc source arc0] - lappend result [mygraph arc target arc0] - lappend result [mygraph arc set arc0] - mygraph destroy - set result -} {1 node0 node1 {}} - -test graph-5.3 {arc insert arcs in correct location} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - - mygraph arc insert node0 node1 arc0 - mygraph arc insert node0 node1 arc1 - mygraph arc insert node0 node1 arc2 - set result [lsort [mygraph arcs -out node0]] - mygraph destroy - set result -} {arc0 arc1 arc2} - -test graph-5.4 {arc insert gives error when trying to insert to a fake node} { - graph mygraph - catch {mygraph arc insert node0 node1 arc0} msg - mygraph destroy - set msg -} "source node \"node0\" does not exist in graph \"mygraph\"" - -test graph-5.5 {arc insert gives error when trying to insert to a fake node} { - graph mygraph - mygraph node insert node0 - catch {mygraph arc insert node0 node1 arc0} msg - mygraph destroy - set msg -} "target node \"node1\" does not exist in graph \"mygraph\"" - -test graph-5.6 {arc insert generates arc name when none is given} { - graph mygraph - mygraph node insert n0 - - set result [list [mygraph arc insert n0 n0]] - lappend result [mygraph arc insert n0 n0] - mygraph arc insert n0 n0 arc3 - lappend result [mygraph arc insert n0 n0] - mygraph destroy - set result -} [list arc1 arc2 arc4] - -if {0} { - # if feature used, fix this test... - test graph-5.6 {arc insert generates arc name when none is given} { - graph mygraph - set result [list [mygraph insert root end]] - lappend result [mygraph insert root end] - mygraph insert root end arc3 - lappend result [mygraph insert root end] - mygraph destroy - set result - } [list arc1 arc2 arc4] ; # {} -} - -# --------------------------------------------------- - -test graph-6.1 {arc set gives error on bogus arc} { - graph mygraph - catch {mygraph arc set arc0} msg - mygraph destroy - set msg -} "arc \"arc0\" does not exist in graph \"mygraph\"" - -test graph-6.2 {arc set with arc name gets/sets "data" value} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - mygraph arc set arc0 foobar - set result [mygraph arc set arc0] - mygraph destroy - set result -} "foobar" - -test graph-6.3 {arc set with arc name and key gets/sets key value} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - mygraph arc set arc0 -key baz foobar - set result [list [mygraph arc set arc0] [mygraph arc set arc0 -key baz]] - mygraph destroy - set result -} [list "" "foobar"] - -test graph-6.4 {arc set with too many args gives error} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - catch {mygraph arc set arc0 foo bar baz boo} msg - mygraph destroy - set msg -} "wrong # args: should be \"mygraph arc set arc0 ?-key key? ?value?\"" - -test graph-6.5 {arc set with bad args} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - catch {mygraph arc set arc0 foo bar} msg - mygraph destroy - set msg -} "invalid option \"foo\": should be key" - -test graph-6.6 {arc set with bad args} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - catch {mygraph arc set arc0 foo bar baz} msg - mygraph destroy - set msg -} "invalid option \"foo\": should be key" - -test graph-6.7 {arc set with bad key gives error} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - catch {mygraph arc set arc0 -key foo} msg - mygraph destroy - set msg -} "invalid key \"foo\" for arc \"arc0\"" - -# --------------------------------------------------- - -test graph-7.1 {arc source gives error on bogus arc} { - graph mygraph - catch {mygraph arc source arc0} msg - mygraph destroy - set msg -} "arc \"arc0\" does not exist in graph \"mygraph\"" - -test graph-7.2 {arc source} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - set result [mygraph arc source arc0] - mygraph destroy - set result -} node0 - -# --------------------------------------------------- - -test graph-8.1 {arc target gives error on bogus arc} { - graph mygraph - catch {mygraph arc target arc0} msg - mygraph destroy - set msg -} "arc \"arc0\" does not exist in graph \"mygraph\"" - -test graph-8.2 {arc target} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - set result [mygraph arc target arc0] - mygraph destroy - set result -} node1 - -# --------------------------------------------------- - -test graph-9.1 {arc unset gives error on bogus arc} { - graph mygraph - catch {mygraph arc unset arc0} msg - mygraph destroy - set msg -} "arc \"arc0\" does not exist in graph \"mygraph\"" - -test graph-9.2 {arc unset does not give error on bogus key} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - set result [catch {mygraph arc unset arc0 -key bogus}] - mygraph destroy - set result -} 0 - -test graph-9.3 {arc unset removes a keyed value from a arc} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - mygraph arc set arc0 -key foobar foobar - mygraph arc unset arc0 -key foobar - catch {mygraph arc get arc0 -key foobar} msg - mygraph destroy - set msg -} "invalid key \"foobar\" for arc \"arc0\"" - -test graph-9.4 {arc unset requires -key} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - mygraph arc set arc0 -key foobar foobar - catch {mygraph arc unset arc0 flaboozle foobar} msg - mygraph destroy - set msg -} "invalid option \"flaboozle\": should be \"mygraph arc unset arc0 ?-key key?\"" - -# --------------------------------------------------- - -test graph-10.1 {arcs} { - graph mygraph - set result [mygraph arcs] - mygraph destroy - set result -} {} - -test graph-10.2 {arcs} { - graph mygraph - catch {mygraph arcs -foo} msg - mygraph destroy - set msg -} {invalid restriction "-foo": should be -in, -out, -adj, -inner, -embedding, -key or -value} - -test graph-10.3 {arcs} { - graph mygraph - catch {mygraph arcs -in} msg - mygraph destroy - set msg -} {no nodes specified: should be "mygraph arcs ?-key key? ?-value value? ?-in|-out|-adj|-inner|-embedding node node...?"} - -test graph-10.4 {arcs} { - graph mygraph - catch {mygraph arcs -in node0} msg - mygraph destroy - set msg -} {node "node0" does not exist in graph "mygraph"} - -test graph-10.5 {arcs} { - graph mygraph - mygraph node insert node1 - mygraph node insert node2 - mygraph node insert node3 - mygraph node insert node4 - mygraph node insert node5 - mygraph node insert node6 - - mygraph arc insert node4 node1 arcA - mygraph arc insert node5 node2 arcB - mygraph arc insert node6 node3 arcC - mygraph arc insert node3 node1 arcD - mygraph arc insert node1 node2 arcE - mygraph arc insert node2 node3 arcF - - set result [list \ - [lsort [mygraph arcs ]] \ - \ - [lsort [mygraph arcs -in node1 node2 node3]] \ - [lsort [mygraph arcs -out node1 node2 node3]] \ - [lsort [mygraph arcs -adj node1 node2 node3]] \ - [lsort [mygraph arcs -inner node1 node2 node3]] \ - [lsort [mygraph arcs -embedding node1 node2 node3]] \ - \ - [lsort [mygraph arcs -in node4 node5 node6]] \ - [lsort [mygraph arcs -out node4 node5 node6]] \ - [lsort [mygraph arcs -adj node4 node5 node6]] \ - [lsort [mygraph arcs -inner node4 node5 node6]] \ - [lsort [mygraph arcs -embedding node4 node5 node6]] \ - ] - mygraph destroy - set result -} [list \ - {arcA arcB arcC arcD arcE arcF} \ - \ - {arcA arcB arcC arcD arcE arcF} \ - {arcD arcE arcF} \ - {arcA arcB arcC arcD arcE arcF} \ - {arcD arcE arcF} \ - {arcA arcB arcC} \ - \ - {} \ - {arcA arcB arcC} \ - {arcA arcB arcC} \ - {} \ - {arcA arcB arcC} \ - ] - -test graph-10.6 {arcs} { - graph mygraph - mygraph node insert node1 - mygraph node insert node2 - mygraph arc insert node1 node2 arcE - mygraph arc insert node2 node1 arcF - set result [lsort [mygraph arcs -adj node1 node2]] - mygraph destroy - set result -} {arcE arcF} - -test graph-10.7 {arcs} { - graph mygraph - mygraph node insert n0 - mygraph node insert n1 - mygraph arc insert n0 n1 a1 - mygraph arc insert n0 n1 a2 - mygraph arc set a1 -key foobar 1 - mygraph arc set a2 -key blubber 2 - catch {mygraph arcs -key foobar} msg - mygraph destroy - set msg -} {a1} - -test graph-10.8 {arcs} { - graph mygraph - mygraph node insert n0 - mygraph node insert n1 - mygraph arc insert n0 n1 a1 - mygraph arc insert n0 n1 a2 - mygraph arc set a1 -key foobar 1 - mygraph arc set a2 -key foobar 2 - catch {mygraph arcs -key foobar -value 1} msg - mygraph destroy - set msg -} {a1} - -# --------------------------------------------------- - -test graph-11.1 {node degree} { - graph mygraph - catch {mygraph node degree} msg - mygraph destroy - set msg -} "wrong # args: should be \"mygraph node degree ?-in|-out? node\"" - -test graph-11.2 {node degree} { - graph mygraph - catch {mygraph node degree foo bar baz} msg - mygraph destroy - set msg -} "wrong # args: should be \"mygraph node degree ?-in|-out? node\"" - -test graph-11.3 {node degree} { - graph mygraph - catch {mygraph node degree node0} msg - mygraph destroy - set msg -} "node \"node0\" does not exist in graph \"mygraph\"" - -test graph-11.4 {node degree} { - graph mygraph - catch {mygraph node degree -foo node0} msg - mygraph destroy - set msg -} "invalid option \"-foo\": should be -in or -out" - -test graph-11.5 {node degree} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph node insert node2 - mygraph node insert node3 - mygraph node insert node4 - mygraph node insert node5 - - mygraph arc insert node1 node2 arc0 - mygraph arc insert node3 node3 arc1 - mygraph arc insert node4 node5 arc2 - mygraph arc insert node4 node5 arc3 - mygraph arc insert node4 node5 arc4 - mygraph arc insert node5 node2 arc5 - - set result [list \ - [mygraph node degree node0] \ - [mygraph node degree -in node0] \ - [mygraph node degree -out node0] \ - [mygraph node degree node1] \ - [mygraph node degree -in node1] \ - [mygraph node degree -out node1] \ - [mygraph node degree node2] \ - [mygraph node degree -in node2] \ - [mygraph node degree -out node2] \ - [mygraph node degree node3] \ - [mygraph node degree -in node3] \ - [mygraph node degree -out node3] \ - [mygraph node degree node4] \ - [mygraph node degree -in node4] \ - [mygraph node degree -out node4] \ - [mygraph node degree node5] \ - [mygraph node degree -in node5] \ - [mygraph node degree -out node5] \ - ] - - mygraph destroy - set result -} [list 0 0 0 \ - 1 0 1 \ - 2 2 0 \ - 2 1 1 \ - 3 0 3 \ - 4 3 1 - ] - -# --------------------------------------------------- - -test graph-12.1 {node delete} { - graph mygraph - catch {mygraph node delete node0} msg - mygraph destroy - set msg -} "node \"node0\" does not exist in graph \"mygraph\"" - -test graph-12.2 {node delete} { - graph mygraph - mygraph node insert node0 - mygraph node delete node0 - set result [mygraph node exists node0] - mygraph destroy - set result -} {0} - -test graph-12.3 {node delete} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - mygraph node delete node0 - - set result [list \ - [mygraph node exists node0] \ - [mygraph node exists node1] \ - [mygraph arc exists arc0] \ - ] - mygraph destroy - set result -} {0 1 0} - -test graph-12.4 {node delete} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - mygraph node delete node1 - - set result [list \ - [mygraph node exists node0] \ - [mygraph node exists node1] \ - [mygraph arc exists arc0] \ - ] - mygraph destroy - set result -} {1 0 0} - -# --------------------------------------------------- - -test graph-13.1 {node exists} { - graph mygraph - set result [list] - lappend result [mygraph node exists node1] - mygraph node insert node1 - lappend result [mygraph node exists node1] - mygraph node delete node1 - lappend result [mygraph node exists node1] - mygraph destroy - set result -} {0 1 0} - -# --------------------------------------------------- - -test graph-14.1 {node get gives error on bogus node} { - graph mygraph - catch {mygraph node get node0} msg - mygraph destroy - set msg -} "node \"node0\" does not exist in graph \"mygraph\"" - -test graph-14.2 {node get gives error on bogus key} { - graph mygraph - mygraph node insert node0 - catch {mygraph node get node0 -key bogus} msg - mygraph destroy - set msg -} "invalid key \"bogus\" for node \"node0\"" - -test graph-14.3 {node get uses data as default key} { - graph mygraph - mygraph node insert node0 - mygraph node set node0 foobar - set result [mygraph node get node0] - mygraph destroy - set result -} "foobar" - -test graph-14.4 {node get respects -key flag} { - graph mygraph - mygraph node insert node0 - mygraph node set node0 -key boom foobar - set result [mygraph node get node0 -key boom] - mygraph destroy - set result -} "foobar" - -# --------------------------------------------------- - -test graph-15.1 {node insert gives error on duplicate node name} { - graph mygraph - mygraph node insert node0 - catch {mygraph node insert node0} msg - mygraph destroy - set msg -} "node \"node0\" already exists in graph \"mygraph\"" - -test graph-15.2 {node insert creates and initializes node} { - graph mygraph - mygraph node insert node0 - set result [list ] - lappend result [mygraph node exists node0] - lappend result [mygraph node set node0] - mygraph destroy - set result -} {1 {}} - -test graph-15.3 {node insert generates node name when none is given} { - graph mygraph - set result [list [mygraph node insert]] - - lappend result [mygraph node insert] - mygraph node insert node3 - lappend result [mygraph node insert] - mygraph destroy - set result -} [list node1 node2 node4] - -if {0} { - # fix if this feature is used ... - test graph-15.x {node insert generates node name when none is given} { - graph mygraph - set result [list [mygraph node insert root end]] - lappend result [mygraph node insert root end] - mygraph node insert root end node3 - lappend result [mygraph node insert root end] - mygraph destroy - set result - } [list node1 node2 node4] ; # {} -} - -# --------------------------------------------------- - -test graph-16.1 {node opposite gives error on bogus node} { - graph mygraph - catch {mygraph node opposite node0 arc0} msg - mygraph destroy - set msg -} "node \"node0\" does not exist in graph \"mygraph\"" - -test graph-16.2 {node opposite gives error on bogus arc} { - graph mygraph - mygraph node insert node0 - catch {mygraph node opposite node0 arc0} msg - mygraph destroy - set msg -} "arc \"arc0\" does not exist in graph \"mygraph\"" - -test graph-16.3 {node opposite gives error on bogus node/arc combination} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph node insert node2 - mygraph arc insert node1 node2 arc0 - - catch {mygraph node opposite node0 arc0} msg - mygraph destroy - set msg -} "node \"node0\" and arc \"arc0\" are not connected in graph \"mygraph\"" - -test graph-16.4 {node opposite} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - - set result [list \ - [mygraph node opposite node0 arc0] \ - [mygraph node opposite node1 arc0] \ - ] - mygraph destroy - set result -} {node1 node0} - -test graph-16.5 {node opposite} { - graph mygraph - mygraph node insert node0 - mygraph arc insert node0 node0 arc0 - set result [mygraph node opposite node0 arc0] - mygraph destroy - set result -} {node0} - -# --------------------------------------------------- - -test graph-17.1 {node set gives error on bogus node} { - graph mygraph - catch {mygraph node set node0} msg - mygraph destroy - set msg -} "node \"node0\" does not exist in graph \"mygraph\"" - -test graph-17.2 {node set with node name gets/sets "data" value} { - graph mygraph - mygraph node insert node0 - mygraph node set node0 foobar - set result [mygraph node set node0] - mygraph destroy - set result -} "foobar" - -test graph-17.3 {node set with node name and key gets/sets key value} { - graph mygraph - mygraph node insert node0 - mygraph node set node0 -key baz foobar - set result [list [mygraph node set node0] [mygraph node set node0 -key baz]] - mygraph destroy - set result -} [list "" "foobar"] - -test graph-17.4 {node set with too many args gives error} { - graph mygraph - mygraph node insert node0 - catch {mygraph node set node0 foo bar baz boo} msg - mygraph destroy - set msg -} "wrong # args: should be \"mygraph node set node0 ?-key key? ?value?\"" - -test graph-17.5 {node set with bad args} { - graph mygraph - mygraph node insert node0 - catch {mygraph node set node0 foo bar} msg - mygraph destroy - set msg -} "invalid option \"foo\": should be key" - -test graph-17.6 {node set with bad args} { - graph mygraph - mygraph node insert node0 - catch {mygraph node set node0 foo bar baz} msg - mygraph destroy - set msg -} "invalid option \"foo\": should be key" - -test graph-17.7 {node set with bad key gives error} { - graph mygraph - mygraph node insert node0 - catch {mygraph node set node0 -key foo} msg - mygraph destroy - set msg -} "invalid key \"foo\" for node \"node0\"" - -# --------------------------------------------------- - -test graph-18.1 {node unset gives error on bogus node} { - graph mygraph - catch {mygraph node unset node0} msg - mygraph destroy - set msg -} "node \"node0\" does not exist in graph \"mygraph\"" - -test graph-18.2 {node unset does not give error on bogus key} { - graph mygraph - mygraph node insert node0 - set result [catch {mygraph node unset node0 -key bogus}] - mygraph destroy - set result -} 0 - -test graph-18.3 {node unset removes a keyed value from a node} { - graph mygraph - mygraph node insert node0 - mygraph node set node0 -key foobar foobar - mygraph node unset node0 -key foobar - catch {mygraph node get node0 -key foobar} msg - mygraph destroy - set msg -} "invalid key \"foobar\" for node \"node0\"" - -test graph-18.4 {unset requires -key} { - graph mygraph - mygraph node insert node0 - mygraph node set node0 -key foobar foobar - catch {mygraph node unset node0 flaboozle foobar} msg - mygraph destroy - set msg -} "invalid option \"flaboozle\": should be \"mygraph node unset node0 ?-key key?\"" - -# --------------------------------------------------- - -test graph-19.1 {nodes} { - graph mygraph - set result [mygraph nodes] - mygraph destroy - set result -} {} - -test graph-19.2 {nodes} { - graph mygraph - catch {mygraph nodes -foo} msg - mygraph destroy - set msg -} {invalid restriction "-foo": should be -in, -out, -adj, -inner, -embedding, -key or -value} - -test graph-19.3 {nodes} { - graph mygraph - catch {mygraph nodes -in} msg - mygraph destroy - set msg -} {no nodes specified: should be "mygraph nodes ?-key key? ?-value value? ?-in|-out|-adj|-inner|-embedding node node...?"} - -test graph-19.4 {nodes} { - graph mygraph - catch {mygraph nodes -in node0} msg - mygraph destroy - set msg -} {node "node0" does not exist in graph "mygraph"} - -test graph-19.5 {nodes} { - graph mygraph - mygraph node insert node1 - mygraph node insert node2 - mygraph node insert node3 - mygraph node insert node4 - mygraph node insert node5 - mygraph node insert node6 - - mygraph arc insert node4 node1 arcA - mygraph arc insert node5 node2 arcB - mygraph arc insert node6 node3 arcC - mygraph arc insert node3 node1 arcD - mygraph arc insert node1 node2 arcE - mygraph arc insert node2 node3 arcF - - set result [list \ - [lsort [mygraph nodes ]] \ - \ - [lsort [mygraph nodes -in node1 node2 node3]] \ - [lsort [mygraph nodes -out node1 node2 node3]] \ - [lsort [mygraph nodes -adj node1 node2 node3]] \ - [lsort [mygraph nodes -inner node1 node2 node3]] \ - [lsort [mygraph nodes -embedding node1 node2 node3]] \ - \ - [lsort [mygraph nodes -in node4 node5 node6]] \ - [lsort [mygraph nodes -out node4 node5 node6]] \ - [lsort [mygraph nodes -adj node4 node5 node6]] \ - [lsort [mygraph nodes -inner node4 node5 node6]] \ - [lsort [mygraph nodes -embedding node4 node5 node6]] \ - ] - mygraph destroy - set result -} [list \ - {node1 node2 node3 node4 node5 node6} \ - \ - {node1 node2 node3 node4 node5 node6} \ - {node1 node2 node3} \ - {node1 node2 node3 node4 node5 node6} \ - {node1 node2 node3} \ - {node4 node5 node6} \ - \ - {} \ - {node1 node2 node3} \ - {node1 node2 node3} \ - {} \ - {node1 node2 node3} \ - ] - -test graph-19.6 {nodes} { - graph mygraph - mygraph node insert node1 - mygraph node insert node2 - mygraph node insert node3 - - mygraph arc insert node1 node2 arcE - mygraph arc insert node1 node2 arcD - mygraph arc insert node2 node3 arcF - mygraph arc insert node2 node3 arcG - - set result [lsort [mygraph nodes -embedding node1 node3]] - mygraph destroy - set result -} {node2} - - -test graph-19.7 {nodes} { - graph mygraph - mygraph node insert n0 - mygraph node insert n1 - mygraph node set n0 -key foobar 1 - mygraph node set n1 -key blubber 2 - catch {mygraph nodes -key foobar} msg - mygraph destroy - set msg -} {n0} - -test graph-19.8 {nodes} { - graph mygraph - mygraph node insert n0 - mygraph node insert n1 - mygraph node set n0 -key foobar 1 - mygraph node set n1 -key foobar 2 - catch {mygraph nodes -key foobar -value 1} msg - mygraph destroy - set msg -} {n0} - - -# --------------------------------------------------- - -test graph-20.1 {swap gives error when trying to swap non existant node} { - graph mygraph - catch {mygraph swap node0 node1} msg - mygraph destroy - set msg -} "node \"node0\" does not exist in graph \"mygraph\"" - -test graph-20.2 {swap gives error when trying to swap non existant node} { - graph mygraph - mygraph node insert node0 - catch {mygraph swap node0 node1} msg - mygraph destroy - set msg -} "node \"node1\" does not exist in graph \"mygraph\"" - -test graph-20.3 {swap gives error when trying to swap node with self} { - graph mygraph - mygraph node insert node0 - catch {mygraph swap node0 node0} msg - mygraph destroy - set msg -} "cannot swap node \"node0\" with itself" - -test graph-20.4 {swap swaps node relationships correctly} { - graph mygraph - mygraph node insert node0 - mygraph node insert node0.1 - mygraph node insert node0.2 - mygraph node insert node0.1.1 - mygraph node insert node0.1.2 - - mygraph arc insert node0 node0.1 a1 - mygraph arc insert node0 node0.2 a2 - mygraph arc insert node0.1 node0.1.1 a3 - mygraph arc insert node0.1 node0.1.2 a4 - - mygraph swap node0 node0.1 - - set result [list \ - [lsort [mygraph nodes -out node0]] \ - [lsort [mygraph nodes -out node0.1]] \ - ] - mygraph destroy - set result -} {{node0.1.1 node0.1.2} {node0 node0.2}} - -test graph-20.5 {swap swaps node relationships correctly} { - graph mygraph - mygraph node insert node0 - mygraph node insert node0.1 - mygraph node insert node0.2 - mygraph node insert node0.1.1 - mygraph node insert node0.1.2 - - mygraph arc insert node0 node0.1 a1 - mygraph arc insert node0 node0.2 a2 - mygraph arc insert node0.1 node0.1.1 a3 - mygraph arc insert node0.1 node0.1.2 a4 - - mygraph swap node0 node0.1.1 - - set result [list \ - [lsort [mygraph nodes -out node0]] \ - [lsort [mygraph nodes -out node0.1.1]] \ - ] - mygraph destroy - set result -} {{} {node0.1 node0.2}} - -test graph-20.6 {swap swaps node relationships correctly} { - graph mygraph - mygraph node insert node0 - mygraph node insert node0.1 - mygraph node insert node0.2 - mygraph node insert node0.1.1 - mygraph node insert node0.1.2 - - mygraph arc insert node0 node0.1 a1 - mygraph arc insert node0 node0.2 a2 - mygraph arc insert node0.1 node0.1.1 a3 - mygraph arc insert node0.1 node0.1.2 a4 - - mygraph swap node0.1 node0 - - set result [list \ - [lsort [mygraph nodes -out node0]] \ - [lsort [mygraph nodes -out node0.1]] \ - ] - mygraph destroy - set result -} {{node0.1.1 node0.1.2} {node0 node0.2}} - -test graph-22.1 {arc getall gives error on bogus arc} { - graph mygraph - catch {mygraph arc getall arc0} msg - mygraph destroy - set msg -} "arc \"arc0\" does not exist in graph \"mygraph\"" -test graph-22.2 {arc getall gives error when key specified} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - catch {mygraph arc getall arc0 -key data} msg - mygraph destroy - set msg -} "wrong # args: should be none" -test graph-22.3 {arc getall with node name returns list of key/value pairs} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - mygraph arc set arc0 foobar - mygraph arc set arc0 -key other thing - set results [mygraph arc getall arc0] - mygraph destroy - lsort $results -} "data foobar other thing" - -test graph-23.1 {node getall gives error on bogus node} { - graph mygraph - catch {mygraph node getall node0} msg - mygraph destroy - set msg -} "node \"node0\" does not exist in graph \"mygraph\"" -test graph-23.2 {node getall gives error when key specified} { - graph mygraph - mygraph node insert node0 - catch {mygraph node getall node0 -key data} msg - mygraph destroy - set msg -} "wrong # args: should be none" -test graph-23.3 {node getall with node name returns list of key/value pairs} { - graph mygraph - mygraph node insert node0 - mygraph node set node0 foobar - mygraph node set node0 -key other thing - set results [mygraph node getall node0] - mygraph destroy - lsort $results -} "data foobar other thing" - -test graph-24.1 {arc keys gives error on bogus arc} { - graph mygraph - catch {mygraph arc keys arc0} msg - mygraph destroy - set msg -} "arc \"arc0\" does not exist in graph \"mygraph\"" -test graph-24.2 {arc keys gives error when key specified} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - catch { mygraph arc keys arc0 -key bogus } msg - mygraph destroy - set msg -} "wrong # args: should be none" -test graph-24.3 {arc keys with arc name returns list of keys} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - mygraph arc set arc0 -key other things - set results [mygraph arc keys arc0] - mygraph destroy - lsort $results -} "data other" - -test graph-25.1 {node keys gives error on bogus node} { - graph mygraph - catch {mygraph node keys node0} msg - mygraph destroy - set msg -} "node \"node0\" does not exist in graph \"mygraph\"" -test graph-25.2 {node keys gives error when key specified} { - graph mygraph - mygraph node insert node0 - catch { mygraph node keys node0 -key bogus } msg - mygraph destroy - set msg -} "wrong # args: should be none" -test graph-25.3 {node keys with node name returns list of keys} { - graph mygraph - mygraph node insert node0 - mygraph node set node0 -key other things - set results [mygraph node keys node0] - mygraph destroy - lsort $results -} "data other" - -test graph-26.1 {arc keyexists gives error on bogus arc} { - graph mygraph - catch {mygraph arc keyexists arc0} msg - mygraph destroy - set msg -} "arc \"arc0\" does not exist in graph \"mygraph\"" -test graph-26.2 {arc keyexists returns false on non-existant key} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - set result [mygraph arc keyexists arc0 -key bogus] - mygraph destroy - set result -} "0" -test graph-26.3 {arc keyexists uses data as default key} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - set result [mygraph arc keyexists arc0] - mygraph destroy - set result -} "1" -test graph-26.4 {arc keyexists respects -key flag} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - mygraph arc set arc0 -key boom foobar - set result [mygraph arc keyexists arc0 -key boom] - mygraph destroy - set result -} "1" - -test graph-27.1 {node keyexists gives error on bogus node} { - graph mygraph - catch {mygraph node keyexists node0} msg - mygraph destroy - set msg -} "node \"node0\" does not exist in graph \"mygraph\"" -test graph-27.2 {node keyexists returns false on non-existant key} { - graph mygraph - mygraph node insert node0 - set result [mygraph node keyexists node0 -key bogus] - mygraph destroy - set result -} "0" -test graph-27.3 {node keyexists uses data as default key} { - graph mygraph - mygraph node insert node0 - set result [mygraph node keyexists node0] - mygraph destroy - set result -} "1" -test graph-27.4 {node keyexists respects -key flag} { - graph mygraph - mygraph node insert node0 - mygraph node set node0 -key boom foobar - set result [mygraph node keyexists node0 -key boom] - mygraph destroy - set result -} "1" - -test graph-28.1 {arc append gives error on bogus arc} { - graph mygraph - catch {mygraph arc append arc0} msg - mygraph destroy - set msg -} "arc \"arc0\" does not exist in graph \"mygraph\"" -test graph-28.2 {arc append with arc name appends to "data" value} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - mygraph arc set arc0 foo - set result [mygraph arc append arc0 bar] - mygraph destroy - set result -} "foobar" -test graph-28.3 {arc append with arc name and key appends key value} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - mygraph arc set arc0 -key baz foo - set result [mygraph arc append arc0 -key baz bar] - mygraph destroy - set result -} "foobar" -test graph-28.4 {arc append with too many args gives error} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - catch {mygraph arc append arc0 foo bar baz boo} msg - mygraph destroy - set msg -} "wrong # args: should be \"mygraph arc append arc0 ?-key key? value\"" -test graph-28.5 {arc append with bad args} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - catch {mygraph arc append arc0 -foo bar baz} msg - mygraph destroy - set msg -} "invalid option \"-foo\": should be -key" -test graph-28.6 {arc append respects -key flag} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - mygraph arc set arc0 -key baz foo - set result [mygraph arc append arc0 -key baz bar] - mygraph destroy - set result -} "foobar" - -test graph-29.1 {arc lappend gives error on bogus arc} { - graph mygraph - catch {mygraph arc lappend arc0} msg - mygraph destroy - set msg -} "arc \"arc0\" does not exist in graph \"mygraph\"" -test graph-29.2 {arc lappend with node arc lappends to "data" value} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - mygraph arc set arc0 foo - set result [mygraph arc lappend arc0 bar] - mygraph destroy - set result -} "foo bar" -test graph-29.3 {arc lappend with arc name and key lappends key value} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - mygraph arc set arc0 -key baz foo - set result [mygraph arc lappend arc0 -key baz bar] - mygraph destroy - set result -} "foo bar" -test graph-29.4 {arc lappend with too many args gives error} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - catch {mygraph arc lappend arc0 foo bar baz boo} msg - mygraph destroy - set msg -} "wrong # args: should be \"mygraph arc lappend arc0 ?-key key? value\"" -test graph-29.5 {arc lappend with bad args} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - catch {mygraph arc lappend arc0 -foo bar baz} msg - mygraph destroy - set msg -} "invalid option \"-foo\": should be -key" -test graph-29.6 {arc lappend respects -key flag} { - graph mygraph - mygraph node insert node0 - mygraph node insert node1 - mygraph arc insert node0 node1 arc0 - mygraph arc set arc0 -key baz foo - set result [mygraph arc lappend arc0 -key baz bar] - mygraph destroy - set result -} "foo bar" - -test graph-30.1 {node append gives error on bogus node} { - graph mygraph - catch {mygraph node append node0} msg - mygraph destroy - set msg -} "node \"node0\" does not exist in graph \"mygraph\"" -test graph-30.2 {node append with node name appends to "data" value} { - graph mygraph - mygraph node insert node0 - mygraph node set node0 foo - set result [mygraph node append node0 bar] - mygraph destroy - set result -} "foobar" -test graph-30.3 {node append with node name and key appends key value} { - graph mygraph - mygraph node insert node0 - mygraph node set node0 -key baz foo - set result [mygraph node append node0 -key baz bar] - mygraph destroy - set result -} "foobar" -test graph-30.4 {node append with too many args gives error} { - graph mygraph - mygraph node insert node0 - catch {mygraph node append node0 foo bar baz boo} msg - mygraph destroy - set msg -} "wrong # args: should be \"mygraph node append node0 ?-key key? value\"" -test graph-30.5 {node append with bad args} { - graph mygraph - mygraph node insert node0 - catch {mygraph node append node0 -foo bar baz} msg - mygraph destroy - set msg -} "invalid option \"-foo\": should be -key" -test graph-30.6 {node append respects -key flag} { - graph mygraph - mygraph node insert node0 - mygraph node set node0 -key baz foo - set result [mygraph node append node0 -key baz bar] - mygraph destroy - set result -} "foobar" - -test graph-31.1 {node lappend gives error on bogus node} { - graph mygraph - catch {mygraph node lappend node0} msg - mygraph destroy - set msg -} "node \"node0\" does not exist in graph \"mygraph\"" -test graph-32.2 {node lappend with node name lappends to "data" value} { - graph mygraph - mygraph node insert node0 - mygraph node set node0 foo - set result [mygraph node lappend node0 bar] - mygraph destroy - set result -} "foo bar" -test graph-32.3 {node lappend with node name and key lappends key value} { - graph mygraph - mygraph node insert node0 - mygraph node set node0 -key baz foo - set result [mygraph node lappend node0 -key baz bar] - mygraph destroy - set result -} "foo bar" -test graph-32.4 {node lappend with too many args gives error} { - graph mygraph - mygraph node insert node0 - catch {mygraph node lappend node0 foo bar baz boo} msg - mygraph destroy - set msg -} "wrong # args: should be \"mygraph node lappend node0 ?-key key? value\"" -test graph-32.5 {node lappend with bad args} { - graph mygraph - mygraph node insert node0 - catch {mygraph node lappend node0 -foo bar baz} msg - mygraph destroy - set msg -} "invalid option \"-foo\": should be -key" -test graph-32.6 {node lappend respects -key flag} { - graph mygraph - mygraph node insert node0 - mygraph node set node0 -key baz foo - set result [mygraph node lappend node0 -key baz bar] - mygraph destroy - set result -} "foo bar" - - -# --------------------------------------------------- - -proc makegraph {} { - graph mygraph - - mygraph node insert i - mygraph node insert ii - mygraph node insert iii - mygraph node insert iv - mygraph node insert v - mygraph node insert vi - mygraph node insert vii - mygraph node insert viii - mygraph node insert ix - - mygraph arc insert i ii 1 - mygraph arc insert ii iii 2 - mygraph arc insert ii iii 3 - mygraph arc insert ii iii 4 - mygraph arc insert iii iv 5 - mygraph arc insert iii iv 6 - mygraph arc insert iv v 7 - mygraph arc insert v vi 8 - mygraph arc insert vi viii 9 - mygraph arc insert viii i 10 - mygraph arc insert i ix 11 - mygraph arc insert ix ix 12 - mygraph arc insert i vii 13 - mygraph arc insert vii vi 14 -} - - -test graph-21.1 {walk with too few args} {badTest} { - graph mygraph - catch {mygraph walk} msg - mygraph destroy - set msg -} "no value given for parameter \"node\" to \"::struct::graph::_walk\"" - -test graph-21.2 {walk with too few args} { - graph mygraph - catch {mygraph walk node0} msg - mygraph destroy - set msg -} "wrong # args: should be \"mygraph walk node0 ?-dir forward|backward? ?-order pre|post|both? ?-type {bfs|dfs}? -command cmd\"" - -test graph-21.3 {walk with too many args} { - graph mygraph - catch {mygraph walk node0 -foo bar -baz boo -foo2 boo -foo3 baz -foo4 baz} msg - mygraph destroy - set msg -} "wrong # args: should be \"mygraph walk node0 ?-dir forward|backward? ?-order pre|post|both? ?-type {bfs|dfs}? -command cmd\"" - -test graph-21.4 {walk with fake node} { - graph mygraph - catch {mygraph walk node0 -command {}} msg - mygraph destroy - set msg -} "node \"node0\" does not exist in graph \"mygraph\"" - -test graph-21.5 {walk using unknown option} { - makegraph - catch {mygraph walk i -foo x -command {}} msg - mygraph destroy - set msg -} "unknown option \"-foo\": should be \"mygraph walk i ?-dir forward|backward? ?-order pre|post|both? ?-type {bfs|dfs}? -command cmd\"" - -test graph-21.6 {walk with empty command} { - makegraph - catch {mygraph walk i -command {}} msg - mygraph destroy - set msg -} "no command specified: should be \"mygraph walk i ?-dir forward|backward? ?-order pre|post|both? ?-type {bfs|dfs}? -command cmd\"" - -test graph-21.7 {walk with illegal specifications} { - makegraph - catch {mygraph walk i -command foo -type foo} msg - mygraph destroy - set msg -} "invalid search type \"foo\": should be dfs, or bfs" - -test graph-21.8 {walk with illegal specifications} { - makegraph - catch {mygraph walk i -command foo -type dfs -dir oneway} msg - mygraph destroy - set msg -} "invalid search direction \"oneway\": should be forward or backward" - -test graph-21.9 {walk with illegal specifications} { - makegraph - catch {mygraph walk i -command foo -type dfs -dir forward -order none} msg - mygraph destroy - set msg -} "invalid search order \"none\": should be both, pre or post" - - -test graph-21.10 {forward pre-order dfs is default walk} { - makegraph - set t [list ] - mygraph walk i -command {lappend t} - mygraph destroy - set t -} [list \ - enter mygraph i enter mygraph ii enter mygraph iii \ - enter mygraph iv enter mygraph v enter mygraph vi \ - enter mygraph viii enter mygraph ix enter mygraph vii \ - ] - -test graph-21.11 {forward post-order dfs walk} { - makegraph - set t [list ] - mygraph walk i -order post -command {lappend t} - mygraph destroy - set t -} [list \ - leave mygraph viii leave mygraph vi leave mygraph v \ - leave mygraph iv leave mygraph iii leave mygraph ii \ - leave mygraph ix leave mygraph vii leave mygraph i \ - ] - -test graph-21.12 {forward both-order dfs walk} { - makegraph - set t [list ] - mygraph walk i -order both -command {lappend t} - mygraph destroy - set t -} [list \ - enter mygraph i enter mygraph ii enter mygraph iii \ - enter mygraph iv enter mygraph v enter mygraph vi \ - enter mygraph viii leave mygraph viii leave mygraph vi \ - leave mygraph v leave mygraph iv leave mygraph iii \ - leave mygraph ii enter mygraph ix leave mygraph ix \ - enter mygraph vii leave mygraph vii leave mygraph i \ - ] - -test graph-21.13 {forward pre-order bfs walk} { - makegraph - set t [list ] - mygraph walk i -type bfs -command {lappend t} - mygraph destroy - set t -} [list \ - enter mygraph i enter mygraph ii enter mygraph ix \ - enter mygraph vii enter mygraph iii enter mygraph vi \ - enter mygraph iv enter mygraph viii enter mygraph v \ - ] - -test graph-21.14 {backward pre-order bfs walk} { - makegraph - set t [list ] - mygraph walk ix -type bfs -dir backward -command {lappend t} - mygraph destroy - set t -} [list \ - enter mygraph ix enter mygraph i enter mygraph viii \ - enter mygraph vi enter mygraph v enter mygraph vii \ - enter mygraph iv enter mygraph iii enter mygraph ii \ - ] - -test graph-21.15 {backward pre-order dfs walk} { - makegraph - set t [list ] - mygraph walk ix -dir backward -command {lappend t} - mygraph destroy - set t -} [list \ - enter mygraph ix enter mygraph i enter mygraph viii \ - enter mygraph vi enter mygraph v enter mygraph iv \ - enter mygraph iii enter mygraph ii enter mygraph vii \ - ] - -test graph-21.16 {backward post-order dfs walk} { - makegraph - set t [list ] - mygraph walk ix -dir backward -order post -command {lappend t} - mygraph destroy - set t -} [list \ - leave mygraph ii leave mygraph iii leave mygraph iv \ - leave mygraph v leave mygraph vii leave mygraph vi \ - leave mygraph viii leave mygraph i leave mygraph ix \ - ] - -test graph-21.17 {backward both-order dfs walk} { - makegraph - set t [list ] - mygraph walk ix -dir backward -order both -command {lappend t} - mygraph destroy - set t -} [list \ - enter mygraph ix enter mygraph i enter mygraph viii \ - enter mygraph vi enter mygraph v enter mygraph iv \ - enter mygraph iii enter mygraph ii leave mygraph ii \ - leave mygraph iii leave mygraph iv leave mygraph v \ - enter mygraph vii leave mygraph vii leave mygraph vi \ - leave mygraph viii leave mygraph i leave mygraph ix \ - ] - -test graph-21.18 {walk, option without value} { - makegraph - catch {mygraph walk ix -type dfs -order} msg - mygraph destroy - set msg -} "value for \"-order\" missing: should be \"mygraph walk ix ?-dir forward|backward? ?-order pre|post|both? ?-type {bfs|dfs}? -command cmd\"" - -test graph-21.19 {forward post-order bfs walk not implemented} { - makegraph - catch {mygraph walk i -order post -type bfs -command {lappend t}} msg - mygraph destroy - set msg -} {unable to do a post-order breadth first walk} - -test graph-21.20 {forward both-order bfs walk not implemented} { - makegraph - catch {mygraph walk i -order both -type bfs -command {lappend t}} msg - mygraph destroy - set msg -} {unable to do a both-order breadth first walk} - -test graph-21.21 {backward post-order bfs walk not implemented} { - makegraph - catch {mygraph walk i -dir backward -order post -type bfs -command {lappend t}} msg - mygraph destroy - set msg -} {unable to do a post-order breadth first walk} - -test graph-21.22 {backward both-order bfs walk not implemented} { - makegraph - catch {mygraph walk i -dir backward -order both -type bfs -command {lappend t}} msg - mygraph destroy - set msg -} {unable to do a both-order breadth first walk} - - -# --------------------------------------------------- - -test graph-33.1 {get gives error on bogus key} { - graph mygraph - catch {mygraph get -key bogus} msg - mygraph destroy - set msg -} "invalid key \"bogus\" for graph \"mygraph\"" - -test graph-33.2 {get uses data as default key} { - graph mygraph - mygraph set foobar - set result [mygraph get] - mygraph destroy - set result -} "foobar" - -test graph-33.3 {get respects -key flag} { - graph mygraph - mygraph set -key boom foobar - set result [mygraph get -key boom] - mygraph destroy - set result -} "foobar" - -# --------------------------------------------------- - -test graph-34.1 {set alone gets/sets "data" value} { - graph mygraph - mygraph set foobar - set result [mygraph set] - mygraph destroy - set result -} "foobar" - -test graph-34.2 {set with key gets/sets key value} { - graph mygraph - mygraph set -key baz foobar - set result [list [mygraph set] [mygraph set -key baz]] - mygraph destroy - set result -} [list "" "foobar"] - -test graph-34.3 {set with too many args gives error} { - graph mygraph - catch {mygraph set foo bar baz boo} msg - mygraph destroy - set msg -} "wrong # args: should be \"mygraph set ?-key key? ?value?\"" - -test graph-34.4 {set with bad args} { - graph mygraph - catch {mygraph set foo bar} msg - mygraph destroy - set msg -} "invalid option \"foo\": should be key" - -test graph-34.5 {set with bad args} { - graph mygraph - catch {mygraph set foo bar baz} msg - mygraph destroy - set msg -} "invalid option \"foo\": should be key" - -test graph-34.6 {set with bad key gives error} { - graph mygraph - catch {mygraph set -key foo} msg - mygraph destroy - set msg -} "invalid key \"foo\" for graph \"mygraph\"" - -# --------------------------------------------------- - -test graph-35.1 {unset does not give error on bogus key} { - graph mygraph - set result [catch {mygraph unset -key bogus}] - mygraph destroy - set result -} 0 - -test graph-35.2 {unset removes a keyed value} { - graph mygraph - mygraph set -key foobar foobar - mygraph unset -key foobar - catch {mygraph get -key foobar} msg - mygraph destroy - set msg -} "invalid key \"foobar\" for graph \"mygraph\"" - -test graph-35.3 {unset requires -key} { - graph mygraph - mygraph set -key foobar foobar - catch {mygraph unset flaboozle foobar} msg - mygraph destroy - set msg -} "invalid option \"flaboozle\": should be \"mygraph unset ?-key key?\"" - -# --------------------------------------------------- - -test graph-36.1 {getall gives error when key specified} { - graph mygraph - catch {mygraph getall -key data} msg - mygraph destroy - set msg -} "wrong # args: should be none" -test graph-36.2 {getall returns list of key/value pairs} { - graph mygraph - mygraph set foobar - mygraph set -key other thing - set results [mygraph getall] - mygraph destroy - lsort $results -} "data foobar other thing" - -test graph-37.1 {keys gives error when key specified} { - graph mygraph - catch { mygraph keys -key bogus } msg - mygraph destroy - set msg -} "wrong # args: should be none" -test graph-37.2 {keys returns list of keys} { - graph mygraph - mygraph set -key other things - set results [mygraph keys] - mygraph destroy - lsort $results -} "data other" - -test graph-38.1 {keyexists returns false on non-existant key} { - graph mygraph - set result [mygraph keyexists -key bogus] - mygraph destroy - set result -} "0" -test graph-38.2 {keyexists uses data as default key} { - graph mygraph - set result [mygraph keyexists] - mygraph destroy - set result -} "1" -test graph-38.3 {keyexists respects -key flag} { - graph mygraph - mygraph set -key boom foobar - set result [mygraph keyexists -key boom] - mygraph destroy - set result -} "1" - -# --------------------------------------------------- -::tcltest::cleanupTests DELETED modules/struct/list.tcl Index: modules/struct/list.tcl ================================================================== --- modules/struct/list.tcl +++ /dev/null @@ -1,757 +0,0 @@ -#---------------------------------------------------------------------- -# -# list.tcl -- -# -# Definitions for extended processing of Tcl lists. -# -# Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: list.tcl,v 1.5 2003/04/09 18:25:31 andreas_kupries Exp $ -# -#---------------------------------------------------------------------- - -package require Tcl 8.0 - -namespace eval ::struct { namespace eval list {} } - -namespace eval ::struct::list { - namespace export list - - if 0 { - # Possibly in the future. - namespace export LongestCommonSubsequence - namespace export LongestCommonSubsequence2 - namespace export LcsInvert - namespace export LcsInvert2 - namespace export LcsInvertMerge - namespace export LcsInvertMerge2 - namespace export Reverse - namespace export Assign - namespace export Flatten - namespace export Map - namespace export Fold - namespace export Iota - namespace export Equal - namespace export Repeat - } -} - -########################## -# Public functions - -# ::struct::list::list -- -# -# Command that access all list commands. -# -# Arguments: -# cmd Name of the subcommand to dispatch to. -# args Arguments for the subcommand. -# -# Results: -# Whatever the result of the subcommand is. - -proc ::struct::list::list {cmd args} { - # Do minimal args checks here - if { [llength [info level 0]] == 1 } { - return -code error "wrong # args: should be \"$cmd ?arg arg ...?\"" - } - set sub [string toupper [string index $cmd 0]][string range $cmd 1 end] - - if { [llength [info commands ::struct::list::$sub]] == 0 } { - set optlist [info commands ::struct::list::L*] - set xlist {} - foreach p $optlist { - lappend xlist [string tolower [string index $p 0]][string range $p 1 end] - } - return -code error \ - "bad option \"$cmd\": must be [linsert [join $xlist ", "] "end-1" "or"]" - } - return [eval [linsert $args 0 ::struct::list::$sub]] -} - -########################## -# Private functions follow -# -# Do a compatibility version of [lset] for pre-8.4 versions of Tcl. -# This version does not do multi-arg [lset]! - -if { [package vcompare [package provide Tcl] 8.4] < 0 } { - proc ::struct::list::K { x y } { set x } - proc ::struct::list::lset { var index arg } { - upvar 1 $var list - set list [::lreplace [K $list [set list {}]] $index $index $arg] - } -} - -########################## -# Implementations of the functionality. -# - -# ::struct::list::LongestCommonSubsequence -- -# -# Computes the longest common subsequence of two lists. -# -# Parameters: -# sequence1, sequence2 -- Two lists to compare. -# maxOccurs -- If provided, causes the procedure to ignore -# lines that appear more than $maxOccurs times -# in the second sequence. See below for a discussion. -# Results: -# Returns a list of two lists of equal length. -# The first sublist is of indices into sequence1, and the -# second sublist is of indices into sequence2. Each corresponding -# pair of indices corresponds to equal elements in the sequences; -# the sequence returned is the longest possible. -# -# Side effects: -# None. -# -# Notes: -# -# While this procedure is quite rapid for many tasks of file -# comparison, its performance degrades severely if the second list -# contains many equal elements (as, for instance, when using this -# procedure to compare two files, a quarter of whose lines are blank. -# This drawback is intrinsic to the algorithm used (see the References -# for details). One approach to dealing with this problem that is -# sometimes effective in practice is arbitrarily to exclude elements -# that appear more than a certain number of times. This number is -# provided as the 'maxOccurs' parameter. If frequent lines are -# excluded in this manner, they will not appear in the common subsequence -# that is computed; the result will be the longest common subsequence -# of infrequent elements. -# -# The procedure struct::list::LongestCommonSubsequence2 -# functions as a wrapper around this procedure; it computes the longest -# common subsequence of infrequent elements, and then subdivides the -# subsequences that lie between the matches to approximate the true -# longest common subsequence. -# -# References: -# J. W. Hunt and M. D. McIlroy, "An algorithm for differential -# file comparison," Comp. Sci. Tech. Rep. #41, Bell Telephone -# Laboratories (1976). Available on the Web at the second -# author's personal site: http://www.cs.dartmouth.edu/~doug/ - -proc ::struct::list::LongestCommonSubsequence { - sequence1 - sequence2 - {maxOccurs 0x7fffffff} -} { - # Construct a set of equivalence classes of lines in file 2 - - set index 0 - foreach string $sequence2 { - lappend eqv($string) $index - incr index - } - - # K holds descriptions of the common subsequences. - # Initially, there is one common subsequence of length 0, - # with a fence saying that it includes line -1 of both files. - # The maximum subsequence length is 0; position 0 of - # K holds a fence carrying the line following the end - # of both files. - - lappend K [::list -1 -1 {}] - lappend K [::list [llength $sequence1] [llength $sequence2] {}] - set k 0 - - # Walk through the first file, letting i be the index of the line and - # string be the line itself. - - set i 0 - foreach string $sequence1 { - # Consider each possible corresponding index j in the second file. - - if { [info exists eqv($string)] - && [llength $eqv($string)] <= $maxOccurs } { - - # c is the candidate match most recently found, and r is the - # length of the corresponding subsequence. - - set r 0 - set c [lindex $K 0] - - foreach j $eqv($string) { - # Perform a binary search to find a candidate common - # subsequence to which may be appended this match. - - set max $k - set min $r - set s [expr { $k + 1 }] - while { $max >= $min } { - set mid [expr { ( $max + $min ) / 2 }] - set bmid [lindex [lindex $K $mid] 1] - if { $j == $bmid } { - break - } elseif { $j < $bmid } { - set max [expr {$mid - 1}] - } else { - set s $mid - set min [expr { $mid + 1 }] - } - } - - # Go to the next match point if there is no suitable - # candidate. - - if { $j == [lindex [lindex $K $mid] 1] || $s > $k} { - continue - } - - # s is the sequence length of the longest sequence - # to which this match point may be appended. Make - # a new candidate match and store the old one in K - # Set r to the length of the new candidate match. - - set newc [::list $i $j [lindex $K $s]] - if { $r >= 0 } { - lset K $r $c - } - set c $newc - set r [expr { $s + 1 }] - - # If we've extended the length of the longest match, - # we're done; move the fence. - - if { $s >= $k } { - lappend K [lindex $K end] - incr k - break - } - } - - # Put the last candidate into the array - - lset K $r $c - } - - incr i - } - - # Package the common subsequence in a convenient form - - set seta {} - set setb {} - set q [lindex $K $k] - - for { set i 0 } { $i < $k } {incr i } { - lappend seta {} - lappend setb {} - } - while { [lindex $q 0] >= 0 } { - incr k -1 - lset seta $k [lindex $q 0] - lset setb $k [lindex $q 1] - set q [lindex $q 2] - } - - return [::list $seta $setb] -} - -# ::struct::list::LongestCommonSubsequence2 -- -# -# Derives an approximation to the longest common subsequence -# of two lists. -# -# Parameters: -# sequence1, sequence2 - Lists to be compared -# maxOccurs - Parameter for imprecise matching - see below. -# -# Results: -# Returns a list of two lists of equal length. -# The first sublist is of indices into sequence1, and the -# second sublist is of indices into sequence2. Each corresponding -# pair of indices corresponds to equal elements in the sequences; -# the sequence returned is an approximation to the longest possible. -# -# Side effects: -# None. -# -# Notes: -# This procedure acts as a wrapper around the companion procedure -# struct::list::LongestCommonSubsequence and accepts the same -# parameters. It first computes the longest common subsequence of -# elements that occur no more than $maxOccurs times in the -# second list. Using that subsequence to align the two lists, -# it then tries to augment the subsequence by computing the true -# longest common subsequences of the sublists between matched pairs. - -proc ::struct::list::LongestCommonSubsequence2 { - sequence1 - sequence2 - {maxOccurs 0x7fffffff} -} { - # Derive the longest common subsequence of elements that occur at - # most $maxOccurs times - - foreach { l1 l2 } \ - [LongestCommonSubsequence $sequence1 $sequence2 $maxOccurs] { - break - } - - # Walk through the match points in the sequence just derived. - - set result1 {} - set result2 {} - set n1 0 - set n2 0 - foreach i1 $l1 i2 $l2 { - if { $i1 != $n1 && $i2 != $n2 } { - # The match points indicate that there are unmatched - # elements lying between them in both input sequences. - # Extract the unmatched elements and perform precise - # longest-common-subsequence analysis on them. - - set subl1 [lrange $sequence1 $n1 [expr { $i1 - 1 }]] - set subl2 [lrange $sequence2 $n2 [expr { $i2 - 1 }]] - foreach { m1 m2 } [LongestCommonSubsequence $subl1 $subl2] break - foreach j1 $m1 j2 $m2 { - lappend result1 [expr { $j1 + $n1 }] - lappend result2 [expr { $j2 + $n2 }] - } - } - - # Add the current match point to the result - - lappend result1 $i1 - lappend result2 $i2 - set n1 [expr { $i1 + 1 }] - set n2 [expr { $i2 + 1 }] - } - - # If there are unmatched elements after the last match in both files, - # perform precise longest-common-subsequence matching on them and - # add the result to our return. - - if { $n1 < [llength $sequence1] && $n2 < [llength $sequence2] } { - set subl1 [lrange $sequence1 $n1 end] - set subl2 [lrange $sequence2 $n2 end] - foreach { m1 m2 } [LongestCommonSubsequence $subl1 $subl2] break - foreach j1 $m1 j2 $m2 { - lappend result1 [expr { $j1 + $n1 }] - lappend result2 [expr { $j2 + $n2 }] - } - } - - return [::list $result1 $result2] -} - -# ::struct::list::LcsInvert -- -# -# Takes the data describing a longest common subsequence of two -# lists and inverts the information in the sense that the result -# of this command will describe the differences between the two -# sequences instead of the identical parts. -# -# Parameters: -# lcsData longest common subsequence of two lists as -# returned by longestCommonSubsequence(2). -# Results: -# Returns a single list whose elements describe the differences -# between the original two sequences. Each element describes -# one difference through three pieces, the type of the change, -# a pair of indices in the first sequence and a pair of indices -# into the second sequence, in this order. -# -# Side effects: -# None. - -proc ::struct::list::LcsInvert {lcsData len1 len2} { - return [LcsInvert2 [::lindex $lcsData 0] [::lindex $lcsData 1] $len1 $len2] -} - -proc ::struct::list::LcsInvert2 {idx1 idx2 len1 len2} { - set result {} - set last1 -1 - set last2 -1 - - foreach a $idx1 b $idx2 { - # Four possible cases. - # a) last1 ... a and last2 ... b are not empty. - # This is a 'change'. - # b) last1 ... a is empty, last2 ... b is not. - # This is an 'addition'. - # c) last1 ... a is not empty, last2 ... b is empty. - # This is a deletion. - # d) If both ranges are empty we can ignore the - # two current indices. - - set empty1 [expr {($a - $last1) <= 1}] - set empty2 [expr {($b - $last2) <= 1}] - - if {$empty1 && $empty2} { - # Case (d), ignore the indices - } elseif {$empty1} { - # Case (b), 'addition'. - incr last2 ; incr b -1 - lappend result [::list added [::list $last1 $a] [::list $last2 $b]] - incr b - } elseif {$empty2} { - # Case (c), 'deletion' - incr last1 ; incr a -1 - lappend result [::list deleted [::list $last1 $a] [::list $last2 $b]] - incr a - } else { - # Case (q), 'change'. - incr last1 ; incr a -1 - incr last2 ; incr b -1 - lappend result [::list changed [::list $last1 $a] [::list $last2 $b]] - incr a - incr b - } - - set last1 $a - set last2 $b - } - - # Handle the last chunk, using the information about the length of - # the original sequences. - - set empty1 [expr {($len1 - $last1) <= 1}] - set empty2 [expr {($len2 - $last2) <= 1}] - - if {$empty1 && $empty2} { - # Case (d), ignore the indices - } elseif {$empty1} { - # Case (b), 'addition'. - incr last2 ; incr len2 -1 - lappend result [::list added [::list $last1 $len1] [::list $last2 $len2]] - } elseif {$empty2} { - # Case (c), 'deletion' - incr last1 ; incr len1 -1 - lappend result [::list deleted [::list $last1 $len1] [::list $last2 $len2]] - } else { - # Case (q), 'change'. - incr last1 ; incr len1 -1 - incr last2 ; incr len2 -1 - lappend result [::list changed [::list $last1 $len1] [::list $last2 $len2]] - } - - return $result -} - -proc ::struct::list::LcsInvertMerge {lcsData len1 len2} { - return [LcsInvertMerge2 [::lindex $lcsData 0] [::lindex $lcsData 1] $len1 $len2] -} - -proc ::struct::list::LcsInvertMerge2 {idx1 idx2 len1 len2} { - set result {} - set last1 -1 - set last2 -1 - - foreach a $idx1 b $idx2 { - # Four possible cases. - # a) last1 ... a and last2 ... b are not empty. - # This is a 'change'. - # b) last1 ... a is empty, last2 ... b is not. - # This is an 'addition'. - # c) last1 ... a is not empty, last2 ... b is empty. - # This is a deletion. - # d) If both ranges are empty we can ignore the - # two current indices. For merging we simply - # take the information from the input. - - set empty1 [expr {($a - $last1) <= 1}] - set empty2 [expr {($b - $last2) <= 1}] - - if {$empty1 && $empty2} { - # Case (d), add 'unchanged' chunk. - foreach {type left right} [lindex $result end] break - if {[string equal $type unchanged]} { - # We extend the 'unchanged' chunk found at the end. - lset result end [::list unchanged [::list [lindex $left 0] $a] [::list [lindex $right 0] $b]] - } else { - lappend result [::list unchanged [::list $last1 $a] [::list $last2 $b]] - } - - } elseif {$empty1} { - # Case (b), 'addition'. - incr last2 ; incr b -1 - lappend result [::list added [::list $last1 $a] [::list $last2 $b]] - incr b - } elseif {$empty2} { - # Case (c), 'deletion' - incr last1 ; incr a -1 - lappend result [::list deleted [::list $last1 $a] [::list $last2 $b]] - incr a - } else { - # Case (q), 'change'. - incr last1 ; incr a -1 - incr last2 ; incr b -1 - lappend result [::list changed [::list $last1 $a] [::list $last2 $b]] - incr a - incr b - } - - set last1 $a - set last2 $b - } - - # Handle the last chunk, using the information about the length of - # the original sequences. - - set empty1 [expr {($len1 - $last1) <= 1}] - set empty2 [expr {($len2 - $last2) <= 1}] - - if {$empty1 && $empty2} { - # Case (d), ignore the indices - } elseif {$empty1} { - # Case (b), 'addition'. - incr last2 ; incr len2 -1 - lappend result [::list added [::list $last1 $len1] [::list $last2 $len2]] - } elseif {$empty2} { - # Case (c), 'deletion' - incr last1 ; incr len1 -1 - lappend result [::list deleted [::list $last1 $len1] [::list $last2 $len2]] - } else { - # Case (q), 'change'. - incr last1 ; incr len1 -1 - incr last2 ; incr len2 -1 - lappend result [::list changed [::list $last1 $len1] [::list $last2 $len2]] - } - - return $result -} - -# ::struct::list::Reverse -- -# -# Reverses the contents of the list and returns the reversed -# list as the result of the command. -# -# Parameters: -# sequence List to be reversed. -# -# Results: -# The sequence in reverse. -# -# Side effects: -# None. - -proc ::struct::list::Reverse {sequence} { - set l [::llength $sequence] - - # Shortcut for lists where reversing yields the list itself - if {$l < 2} {return $sequence} - - # Perform true reversal - set res [::list] - while {$l} { - ::lappend res [::lindex $sequence [incr l -1]] - } - return $res -} - - -# ::struct::list::Assign -- -# -# Assign list elements to variables. -# -# Parameters: -# sequence List to assign -# args Names of the variables to assign to. -# -# Results: -# The unassigned part of the sequence. Can be empty. -# -# Side effects: -# None. - -proc ::struct::list::Assign {sequence args} { - set l [::llength $sequence] - set a [::llength $args] - - # Nothing to assign. - if {$a == 0} {return $sequence} - - # Perform assignments - set i 0 - foreach v $args { - upvar 2 $v var - set var [::lindex $sequence $i] - incr i - } - - # Return remainder, if there is any. - return [::lrange $sequence $a end] -} - - -# ::struct::list::Flatten -- -# -# Remove nesting from the input -# -# Parameters: -# sequence List to flatten -# -# Results: -# The input list with one or all levels of nesting removed. -# -# Side effects: -# None. - -proc ::struct::list::Flatten {args} { - if {[::llength $args] < 1} { - return -code error \ - "wrong#args: should be \"::struct::list::Assign ?-full? ?--? sequence\"" - } - - set full 0 - while {[string match -* [set opt [::lindex $args 0]]]} { - switch -glob -- $opt { - -full {set full 1} - -- {break} - default {return -code error ""} - } - set args [::lrange $args 1 end] - } - - if {[::llength $args] != 1} { - return -code error \ - "wrong#args: should be \"::struct::list::Assign ?-full? ?--? sequence\"" - } - - set sequence [::lindex $args 0] - set cont 1 - while {$cont} { - set cont 0 - set result [::list] - foreach item $sequence { - eval [::list ::lappend result] $item - } - if {$full && [string compare $sequence $result]} {set cont 1} - set sequence $result - } - return $result -} - - -# ::struct::list::Map -- -# -# Apply command to each element of a list and return concatenated results. -# -# Parameters: -# sequence List to operate on -# cmdprefix Operation to perform on the elements. -# -# Results: -# List containing the result of applying cmdprefix to the elements of the -# sequence. -# -# Side effects: -# None of its own, but the command prefix can perform arbitry actions. - -proc ::struct::list::Map {sequence cmdprefix} { - # Shortcut when nothing is to be done. - if {[::llength $sequence] == 0} {return $sequence} - - set res [::list] - foreach item $sequence { - lappend res [uplevel 2 [linsert $cmdprefix end $item]] - } - return $res -} - -# ::struct::list::Fold -- -# -# Fold list into one value. -# -# Parameters: -# sequence List to operate on -# cmdprefix Operation to perform on the elements. -# -# Results: -# Result of applying cmdprefix to the elements of the -# sequence. -# -# Side effects: -# None of its own, but the command prefix can perform arbitry actions. - -proc ::struct::list::Fold {sequence initialvalue cmdprefix} { - # Shortcut when nothing is to be done. - if {[::llength $sequence] == 0} {return $initialvalue} - - set res $initialvalue - foreach item $sequence { - set res [uplevel 2 [linsert $cmdprefix end $res $item]] - } - return $res -} - -# ::struct::list::Iota -- -# -# Return a list containing the integer numbers 0 ... n-1 -# -# Parameters: -# n First number not in the generated list. -# -# Results: -# A list containing integer numbers. -# -# Side effects: -# None - -proc ::struct::list::Iota {n} { - set retval [::list] - for {set i 0} {$i < $n} {incr i} { - ::lappend retval $i - } - return $retval -} - -# ::struct::list::Equal -- -# -# Compares two lists for equality -# (Same length, Same elements in same order). -# -# Parameters: -# a First list to compare. -# b Second list to compare. -# -# Results: -# A boolean. True if the lists are equal. -# -# Side effects: -# None - -proc ::struct::list::Equal {a b} { - # Author of this command is "Richard Suchenwirth" - - if {[::llength $a] != [::llength $b]} {return 0} - if {[::lindex $a 0] == $a} {return [string equal $a $b]} - foreach i $a j $b {if {![Equal $i $j]} {return 0}} - return 1 -} - -# ::struct::list::Repeat -- -# -# Create a list repeating the same value over again. -# -# Parameters: -# value value to use in the created list. -# args Dimension(s) of the (nested) list to create. -# -# Results: -# A list -# -# Side effects: -# None - -proc ::struct::list::Repeat {value args} { - if {[::llength $args] == 1} {set args [::lindex $args 0]} - set buf {} - foreach number $args { - incr number 0 ;# force integer (1) - set buf {} - for {set i 0} {$i<$number} {incr i} { - ::lappend buf $value - } - set value $buf - } - return $buf - # (1): See 'Stress testing' (wiki) for why this makes the code safer. -} DELETED modules/struct/list.test Index: modules/struct/list.test ================================================================== --- modules/struct/list.test +++ /dev/null @@ -1,478 +0,0 @@ -# Tests for the 'list' module in the 'struct' library. -*- tcl -*- -# -# This file contains a collection of tests for one or more of the Tcllib -# procedures. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. -# -# RCS: @(#) $Id: list.test,v 1.5 2003/04/09 18:25:32 andreas_kupries Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -source [file join [file dirname [info script]] list.tcl] - -# Fake [lset] for Tcl releases that don't have it. We need only -# lset into a flat list. - -if { [string compare lset [info commands lset]] } { - proc K { x y } { set x } - proc lset { listVar index var } { - upvar 1 $listVar list - set list [lreplace [K $list [set list {}]] $index $index $var] - } -} - -# Service procedure to develop the error message for "wrong # args" - -proc wrongNumArgs {name arglist count} { - set ver [info patchlevel] - # strip "a1", etc. designations - regsub {(a|b)[1-9]$} $ver {} ver - if {[package vcompare $ver 8.4] < 0} { - set arg [lindex $arglist $count] - set msg "no value given for parameter \"$arg\" to \"$name\"" - } else { - set msg "wrong # args: should be \"$name $arglist\"" - } - return $msg -} - -#---------------------------------------------------------------------- - -interp alias {} lcs {} ::struct::list::list longestCommonSubsequence - -test list-lcs-1.1 {longestCommonSubsequence, no args} { - catch { lcs } msg - set msg -} [wrongNumArgs ::struct::list::LongestCommonSubsequence \ - {sequence1 sequence2 ?maxOccurs?} 0] - -test list-lcs-1.2 {longestCommonSubsequence, one arg} { - catch { lcs x } msg - set msg -} [wrongNumArgs ::struct::list::LongestCommonSubsequence \ - {sequence1 sequence2 ?maxOccurs?} 1] - -test list-lcs-2.1 {longestCommonSubsequence, two empty lists} { - list [catch { lcs {} {} } msg] $msg -} {0 {{} {}}} - -test list-lcs-2.2 {longestCommonSubsequence, insert 1 into an empty list} { - list [catch { lcs {} {a} } msg] $msg -} {0 {{} {}}} - -test list-lcs-2.3 {longestCommonSubsequence, delete 1 from singleton list} { - list [catch { lcs {a} {} } msg] $msg -} {0 {{} {}}} - -test list-lcs-2.4 {longestCommonSubsequence, preserve singleton list} { - list [catch { lcs {a} {a} } msg] $msg -} {0 {0 0}} - -test list-lcs-2.5 {longestCommonSubsequence, 1-element change in singleton list} { - list [catch { lcs {a} {b} } msg] $msg -} {0 {{} {}}} - -test list-lcs-2.6 {longestCommonSubsequence, insert 1 in front of singleton list} { - list [catch { lcs {a} {b a} } msg] $msg -} {0 {0 1}} - -test list-lcs-2.7 {longestCommonSubsequence, insert 1 at end of singleton list} { - list [catch {lcs {a} {a b}} msg] $msg -} {0 {0 0}} - -test list-lcs-2.8 {longestCommonSubsequence, duplicate element} { - list [catch {lcs {a} {a a}} msg] $msg -} {0 {0 0}} - -test list-lcs-2.9 {longestCommonSubsequence, interchange 2} { - list [catch {lcs {a b} {b a}} msg] $msg -} {0 {1 0}} - -test list-lcs-2.10 {longestCommonSubsequence, insert before 2} { - list [catch {lcs {a b} {b a b}} msg] $msg -} {0 {{0 1} {1 2}}} - -test list-lcs-2.11 {longestCommonSubsequence, insert inside 2} { - list [catch {lcs {a b} {a a b}} msg] $msg -} {0 {{0 1} {0 2}}} - -test list-lcs-2.13 {longestCommonSubsequence, insert after 2} { - list [catch {lcs {a b} {a b a}} msg] $msg -} {0 {{0 1} {0 1}}} - -test list-lcs-2.13 {longestCommonSubsequence, delete first of 2} { - list [catch {lcs {a b} a} msg] $msg -} {0 {0 0}} - -test list-lcs-2.14 {longestCommonSubsequence, delete second of 2} { - list [catch {lcs {a b} b} msg] $msg -} {0 {1 0}} - -test list-lcs-2.15 {longestCommonSubsequence, change first of 2} { - list [catch {lcs {a b} {c b}} msg] $msg -} {0 {1 1}} - -test list-lcs-2.16 {longestCommonSubsequence, change first of 2 to dupe} { - list [catch {lcs {a b} {b b}} msg] $msg -} {0 {1 0}} - -test list-lcs-2.17 {longestCommonSubsequence, change second of 2} { - list [catch {lcs {a b} {a c}} msg] $msg -} {0 {0 0}} - -test list-lcs-2.18 {longestCommonSubsequence, change second of 2 to dupe} { - list [catch {lcs {a b} {a a}} msg] $msg -} {0 {0 0}} - -test list-lcs-2.19 {longestCommonSubsequence, mixed changes} { - list [catch {lcs {a b r a c a d a b r a} {b r i c a b r a c}} msg] $msg -} {0 {{1 2 4 5 8 9 10} {0 1 3 4 5 6 7}}} - -test list-lcs-2.20 {longestCommonSubsequence, mixed changes} { - list [catch {lcs {b r i c a b r a c} {a b r a c a d a b r a}} msg] $msg -} {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} - -test list-lcs-3.1 {longestCommonSubsequence, length limit} { - list [catch {lcs {b r i c a b r a c} {a b r a c a d a b r a} 5} msg] $msg -} {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} - -test list-lcs-3.2 {longestCommonSubsequence, length limit} { - list [catch {lcs {b r i c a b r a c} {a b r a c a d a b r a} 4} msg] $msg -} {0 {{0 1 3 5 6} {1 2 4 8 9}}} - -test list-lcs-3.3 {longestCommonSubsequence, length limit} { - list [catch {lcs {b r i c a b r a c} {a b r a c a d a b r a} 1} msg] $msg -} {0 {3 4}} - -test list-lcs-3.4 {longestCommonSubsequence, stupid length limit} { - list [catch {lcs {b r i c a b r a c} {a b r a c a d a b r a} 0} msg] $msg -} {0 {{} {}}} - - -#---------------------------------------------------------------------- - -interp alias {} lcs2 {} ::struct::list::list longestCommonSubsequence2 - -test list-lcs2-1.1 {longestCommonSubsequence2, no args} { - catch { lcs2 } msg - set msg -} [wrongNumArgs ::struct::list::LongestCommonSubsequence2 \ - {sequence1 sequence2 ?maxOccurs?} 0] - -test list-lcs2-1.2 {longestCommonSubsequence2, one arg} { - catch { lcs2 x } msg - set msg -} [wrongNumArgs ::struct::list::LongestCommonSubsequence2 \ - {sequence1 sequence2 ?maxOccurs?} 1] - -test list-lcs2-2.1 {longestCommonSubsequence2, two empty lists} { - list [catch { lcs2 {} {} } msg] $msg -} {0 {{} {}}} - -test list-lcs2-2.2 {longestCommonSubsequence2, insert 1 into an empty list} { - list [catch { lcs2 {} {a} } msg] $msg -} {0 {{} {}}} - -test list-lcs2-2.3 {longestCommonSubsequence2, delete 1 from singleton list} { - list [catch { lcs2 {a} {} } msg] $msg -} {0 {{} {}}} - -test list-lcs2-2.4 {longestCommonSubsequence2, preserve singleton list} { - list [catch { lcs2 {a} {a} } msg] $msg -} {0 {0 0}} - -test list-lcs2-2.5 {longestCommonSubsequence2, 1-element change in singleton list} { - list [catch { lcs2 {a} {b} } msg] $msg -} {0 {{} {}}} - -test list-lcs2-2.6 {longestCommonSubsequence2, insert 1 in front of singleton list} { - list [catch { lcs2 {a} {b a} } msg] $msg -} {0 {0 1}} - -test list-lcs2-2.7 {longestCommonSubsequence2, insert 1 at end of singleton list} { - list [catch {lcs2 {a} {a b}} msg] $msg -} {0 {0 0}} - -test list-lcs2-2.8 {longestCommonSubsequence2, duplicate element} { - list [catch {lcs2 {a} {a a}} msg] $msg -} {0 {0 0}} - -test list-lcs2-2.9 {longestCommonSubsequence2, interchange 2} { - list [catch {lcs2 {a b} {b a}} msg] $msg -} {0 {1 0}} - -test list-lcs2-2.10 {longestCommonSubsequence2, insert before 2} { - list [catch {lcs2 {a b} {b a b}} msg] $msg -} {0 {{0 1} {1 2}}} - -test list-lcs2-2.11 {longestCommonSubsequence2, insert inside 2} { - list [catch {lcs2 {a b} {a a b}} msg] $msg -} {0 {{0 1} {0 2}}} - -test list-lcs2-2.13 {longestCommonSubsequence2, insert after 2} { - list [catch {lcs2 {a b} {a b a}} msg] $msg -} {0 {{0 1} {0 1}}} - -test list-lcs2-2.13 {longestCommonSubsequence2, delete first of 2} { - list [catch {lcs2 {a b} a} msg] $msg -} {0 {0 0}} - -test list-lcs2-2.14 {longestCommonSubsequence2, delete second of 2} { - list [catch {lcs2 {a b} b} msg] $msg -} {0 {1 0}} - -test list-lcs2-2.15 {longestCommonSubsequence2, change first of 2} { - list [catch {lcs2 {a b} {c b}} msg] $msg -} {0 {1 1}} - -test list-lcs2-2.16 {longestCommonSubsequence2, change first of 2 to dupe} { - list [catch {lcs2 {a b} {b b}} msg] $msg -} {0 {1 0}} - -test list-lcs2-2.17 {longestCommonSubsequence2, change second of 2} { - list [catch {lcs2 {a b} {a c}} msg] $msg -} {0 {0 0}} - -test list-lcs2-2.18 {longestCommonSubsequence2, change second of 2 to dupe} { - list [catch {lcs2 {a b} {a a}} msg] $msg -} {0 {0 0}} - -test list-lcs2-2.19 {longestCommonSubsequence2, mixed changes} { - list [catch {lcs2 {a b r a c a d a b r a} {b r i c a b r a c}} msg] $msg -} {0 {{1 2 4 5 8 9 10} {0 1 3 4 5 6 7}}} - -test list-lcs2-2.20 {longestCommonSubsequence2, mixed changes} { - list [catch {lcs2 {b r i c a b r a c} {a b r a c a d a b r a}} msg] $msg -} {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} - -test list-lcs2-3.1 {longestCommonSubsequence2, length limit} { - list [catch {lcs2 {b r i c a b r a c} {a b r a c a d a b r a} 5} msg] $msg -} {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} - -test list-lcs2-3.2 {longestCommonSubsequence2, length limit} { - list [catch {lcs2 {b r i c a b r a c} {a b r a c a d a b r a} 4} msg] $msg -} {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} - -test list-lcs2-3.3 {longestCommonSubsequence2, length limit} { - list [catch {lcs2 {b r i c a b r a c} {a b r a c a d a b r a} 1} msg] $msg -} {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} - -test list-lcs2-3.4 {longestCommonSubsequence2, stupid length limit} { - list [catch {lcs2 {b r i c a b r a c} {a b r a c a d a b r a} 0} msg] $msg -} {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} - - -#---------------------------------------------------------------------- - -interp alias {} lcsi {} ::struct::list::list lcsInvert -interp alias {} lcsim {} ::struct::list::list lcsInvertMerge - -test list-lcsInv-4.0 {longestCommonSubsequence, mixed changes} { - - # sequence 1 = a b r a c a d a b r a - # lcs 1 = 1 2 4 5 8 9 10 - # lcs 2 = 0 1 3 4 5 6 7 - # sequence 2 = b r i c a b r a c - # - # Inversion = deleted {0 0} {-1 0} - # changed {3 3} {2 2} - # deleted {6 7} {4 5} - # added {10 11} {8 8} - - list [catch {lcsi [lcs {a b r a c a d a b r a} {b r i c a b r a c}] 11 9} msg] $msg -} {0 {{deleted {0 0} {-1 0}} {changed {3 3} {2 2}} {deleted {6 7} {4 5}} {added {10 11} {8 8}}}} - -test list-lcsInv-4.1 {longestCommonSubsequence, mixed changes} { - - # sequence 1 = a b r a c a d a b r a - # lcs 1 = 1 2 4 5 8 9 10 - # lcs 2 = 0 1 3 4 5 6 7 - # sequence 2 = b r i c a b r a c - # - # Inversion/Merge = deleted {0 0} {-1 0} - # unchanged {1 2} {0 1} - # changed {3 3} {2 2} - # unchanged {4 5} {3 4} - # deleted {6 7} {4 5} - # unchanged {8 10} {5 7} - # added {10 11} {8 8} - - list [catch {lcsim [lcs {a b r a c a d a b r a} {b r i c a b r a c}] 11 9} msg] $msg -} {0 {{deleted {0 0} {-1 0}} {unchanged {1 2} {0 1}} {changed {3 3} {2 2}} {unchanged {4 5} {3 4}} {deleted {6 7} {4 5}} {unchanged {8 10} {5 7}} {added {10 11} {8 8}}}} - -#---------------------------------------------------------------------- - -interp alias {} reverse {} ::struct::list::list reverse - -test reverse-1.1 {reverse method} { - reverse {a b c} -} {c b a} - -test reverse-1.2 {reverse method} { - reverse a -} {a} - -test reverse-1.3 {reverse method} { - reverse {} -} {} - -test reverse-2.1 {reverse errors} { - list [catch {reverse} msg] $msg -} [list 1 [wrongNumArgs ::struct::list::Reverse {sequence} 0]] - -#---------------------------------------------------------------------- - -interp alias {} assign {} ::struct::list::list assign - -test assign-4.1 {assign method} { - catch {unset ::x ::y} - list [assign {foo bar} x y] $x $y -} {{} foo bar} - -test assign-4.2 {assign method} { - catch {unset x y} - list [assign {foo bar baz} x y] $x $y -} {baz foo bar} - -test assign-4.3 {assign method} { - catch {unset x y z} - list [assign {foo bar} x y z] $x $y $z -} {{} foo bar {}} - -test assign-4.4 {assign method} { - assign {foo bar} -} {foo bar} - -catch {unset x y z} - -#---------------------------------------------------------------------- - -interp alias {} flatten {} ::struct::list::list flatten - -test flatten-1.1 {flatten command} { - flatten {1 2 3 {4 5} {6 7} {{8 9}} 10} -} {1 2 3 4 5 6 7 {8 9} 10} - -test flatten-1.2 {flatten command} { - flatten -full {1 2 3 {4 5} {6 7} {{8 9}} 10} -} {1 2 3 4 5 6 7 8 9 10} - -test flatten-2.1 {flatten errors} { - list [catch {flatten} msg] $msg -} {1 {wrong#args: should be "::struct::list::Assign ?-full? ?--? sequence"}} - -#---------------------------------------------------------------------- - -interp alias {} map {} ::struct::list::list map - -proc cc {a} {return $a$a} -proc + {a} {expr {$a + $a}} -proc * {a} {expr {$a * $a}} -proc projection {n list} {::lindex $list $n} - -test map-4.1 {map command} { - map {a b c d} cc -} {aa bb cc dd} - -test map-4.2 {map command} { - map {1 2 3 4 5} + -} {2 4 6 8 10} - -test map-4.3 {map command} { - map {1 2 3 4 5} * -} {1 4 9 16 25} - -test map-4.4 {map command} { - map {} * -} {} - -test map-4.5 {map command} { - map {{a b c} {1 2 3} {d f g}} {projection 1} -} {b 2 f} - -#---------------------------------------------------------------------- - -interp alias {} fold {} ::struct::list::list fold - -proc cc {a b} {return $a$b} -proc + {a b} {expr {$a + $b}} -proc * {a b} {expr {$a * $b}} - -test fold-4.1 {fold command} { - fold {a b c d} {} cc -} {abcd} - -test fold-4.2 {fold command} { - fold {1 2 3 4 5} 0 + -} {15} - -test fold-4.3 {fold command} { - fold {1 2 3 4 5} 1 * -} {120} - -test fold-4.4 {fold command} { - fold {} 1 * -} {1} - -#---------------------------------------------------------------------- - -interp alias {} iota {} ::struct::list::list iota - -test iota-4.1 {iota command} { - iota 0 -} {} - -test iota-4.2 {iota command} { - iota 1 -} {0} - -test iota-4.3 {iota command} { - iota 11 -} {0 1 2 3 4 5 6 7 8 9 10} - - -#---------------------------------------------------------------------- - -interp alias {} repeat {} ::struct::list::list repeat - -test repeat-4.1 {repeat command} { - repeat 0 -} {} - -test repeat-4.2 {repeat command} { - repeat 0 3 -} {0 0 0} - -test repeat-4.3 {repeat command} { - repeat 0 3 4 -} {{0 0 0} {0 0 0} {0 0 0} {0 0 0}} - -test repeat-4.4 {repeat command} { - repeat 0 {3 4} -} {{0 0 0} {0 0 0} {0 0 0} {0 0 0}} - - -#---------------------------------------------------------------------- - -interp alias {} equal {} ::struct::list::list equal - -test equal-4.1 {equal command} { - equal 0 0 -} 1 - -test equal-4.2 {equal command} { - equal 0 1 -} 0 - -test equal-4.3 {equal command} { - equal {0 0 0} {0 0} -} 0 - -test equal-4.4 {equal command} { - equal {{0 2 3} 1} {{0 2 3} 1} -} 1 DELETED modules/struct/matrix.man Index: modules/struct/matrix.man ================================================================== --- modules/struct/matrix.man +++ /dev/null @@ -1,359 +0,0 @@ -[comment {-*- tcl -*-}] -[manpage_begin matrix n 1.2.1] -[copyright {2002 Andreas Kupries }] -[moddesc {Tcl Data Structures}] -[titledesc {Create and manipulate matrix objects}] -[require Tcl 8.2] -[require struct [opt 1.3]] -[description] -[para] - -The [cmd ::struct::matrix] command creates a new matrix object with an -associated global Tcl command whose name is [arg matrixName]. This -command may be used to invoke various operations on the matrix. It has -the following general form: - -[list_begin definitions] -[call [cmd matrixName] [arg option] [opt [arg "arg arg ..."]]] - -[arg Option] and the [arg arg]s determine the exact behavior of the -command. - -[list_end] - -[para] - -A matrix is a rectangular collection of cells, i.e. organized in rows -and columns. Each cell contains exactly one value of arbitrary -form. The cells in the matrix are addressed by pairs of integer -numbers, with the first (left) number in the pair specifying the -column and the second (right) number specifying the row the cell is -in. These indices are counted from 0 upward. The special non-numeric -index [const end] refers to the last row or column in the matrix, -depending on the context. Indices of the form - -[const end]-[var number] are counted from the end of the row or -column, like they are for standard Tcl lists. Trying to access -non-existing cells causes an error. - -[para] - -The matrices here are created empty, i.e. they have neither rows nor -columns. The user then has to add rows and columns as needed by his -application. A specialty of this structure is the ability to export an -array-view onto its contents. Such can be used by tkTable, for -example, to link the matrix into the display. - -[para] - -The following commands are possible for matrix objects: - -[list_begin definitions] - -[call [arg matrixName] [method {add column}] [opt [arg values]]] - -Extends the matrix by one column and then acts like [method setcolumn] -(see below) on this new column if there were [arg values] -supplied. Without [arg values] the new cells will be set to the empty -string. The new column is appended immediately behind the last -existing column. - -[call [arg matrixName] [method {add row}] [opt [arg values]]] - -Extends the matrix by one row and then acts like [method setrow] (see -below) on this new row if there were [arg values] supplied. Without -[arg values] the new cells will be set to the empty string. The new -row is appended immediately behind the last existing row. - -[call [arg matrixName] [method {add columns}] [arg n]] - -Extends the matrix by [arg n] columns. The new cells will be set to -the empty string. The new columns are appended immediately behind the -last existing column. A value of [arg n] equal to or smaller than 0 is -not allowed. - -[call [arg matrixName] [method {add rows}] [arg n]] - -Extends the matrix by [arg n] rows. The new cells will be set to the -empty string. The new rows are appended immediately behind the last -existing row. A value of [arg n] equal to or smaller than 0 is not -allowed. - -[call [arg matrixName] [method cells]] - -Returns the number of cells currently managed by the matrix. This is -the product of [method rows] and [method columns]. - -[call [arg matrixName] [method cellsize] [arg {column row}]] - -Returns the length of the string representation of the value currently -contained in the addressed cell. - -[call [arg matrixName] [method columns]] - -Returns the number of columns currently managed by the matrix. - -[call [arg matrixName] [method columnwidth] [arg column]] - -Returns the length of the longest string representation of all the -values currently contained in the cells of the addressed column if -these are all spanning only one line. For cell values spanning -multiple lines the length of their longest line goes into the -computation. - -[call [arg matrixName] [method {delete column}] [arg column]] - -Deletes the specified column from the matrix and shifts all columns -with higher indices one index down. - -[call [arg matrixName] [method {delete row}] [arg row]] - -Deletes the specified row from the matrix and shifts all row with -higher indices one index down. - -[call [arg matrixName] [method destroy]] - -Destroys the matrix, including its storage space and associated -command. - -[call [arg matrixName] [method {format 2string}] [opt [arg report]]] - -Formats the matrix using the specified report object and returns the -string containing the result of this operation. The report has to -support the [method printmatrix] method. If no [arg report] is -specified the system will use an internal report definition to format -the matrix. - -[call [arg matrixName] [method {format 2chan}] [opt "[opt [arg report]] [arg channel]"]] - -Formats the matrix using the specified report object and writes the -string containing the result of this operation into the channel. The -report has to support the [method printmatrix2channel] method. If no -[arg report] is specified the system will use an internal report -definition to format the matrix. If no [arg channel] is specified the -system will use [const stdout]. - -[call [arg matrixName] [method {get cell}] [arg {column row}]] - -Returns the value currently contained in the cell identified by row -and column index. - -[call [arg matrixName] [method {get column}] [arg column]] - -Returns a list containing the values from all cells in the column -identified by the index. The contents of the cell in row 0 are stored -as the first element of this list. - -[call [arg matrixName] [method {get rect}] [arg {column_tl row_tl column_br row_br}]] - -Returns a list of lists of cell values. The values stored in the -result come from the sub-matrix whose top-left and bottom-right cells -are specified by [arg {column_tl, row_tl}] and - -[arg {column_br, row_br}] resp. Note that the following equations have -to be true: "[arg column_tl] <= [arg column_br]" and "[arg row_tl] <= -[arg row_br]". The result is organized as follows: The outer list is -the list of rows, its elements are lists representing a single -row. The row with the smallest index is the first element of the outer -list. The elements of the row lists represent the selected cell -values. The cell with the smallest index is the first element in each -row list. - -[call [arg matrixName] [method {get row}] [arg row]] - -Returns a list containing the values from all cells in the row -identified by the index. The contents of the cell in column 0 are -stored as the first element of this list. - -[call [arg matrixName] [method {insert column}] [arg column] [opt [arg values]]] - -Extends the matrix by one column and then acts like [method setcolumn] -(see below) on this new column if there were [arg values] -supplied. Without [arg values] the new cells will be set to the empty -string. The new column is inserted just before the column specified by -the given index. This means, if [arg column] is less than or equal to -zero, then the new column is inserted at the beginning of the matrix, -before the first column. If [arg column] has the value [const end], -or if it is greater than or equal to the number of columns in the -matrix, then the new column is appended to the matrix, behind the last -column. The old column at the chosen index and all columns with higher -indices are shifted one index upward. - -[call [arg matrixName] [method {insert row}] [arg row] [opt [arg values]]] - -Extends the matrix by one row and then acts like [method setrow] (see -below) on this new row if there were [arg values] supplied. Without -[arg values] the new cells will be set to the empty string. The new -row is inserted just before the row specified by the given index. This -means, if [arg row] is less than or equal to zero, then the new row is -inserted at the beginning of the matrix, before the first row. If - -[arg row] has the value [const end], or if it is greater than or -equal to the number of rows in the matrix, then the new row is -appended to the matrix, behind the last row. The old row at that index -and all rows with higher indices are shifted one index upward. - -[call [arg matrixName] [method link] [opt -transpose] [arg arrayvar]] - -Links the matrix to the specified array variable. This means that the -contents of all cells in the matrix is stored in the array too, with -all changes to the matrix propagated there too. The contents of the -cell [arg (column,row)] is stored in the array using the key - -[arg column,row]. If the option [option -transpose] is specified the -key [arg row,column] will be used instead. It is possible to link the -matrix to more than one array. Note that the link is bidirectional, -i.e. changes to the array are mirrored in the matrix too. - -[call [arg matrixName] [method rowheight] [arg row]] - -Returns the height of the specified row in lines. This is the highest -number of lines spanned by a cell over all cells in the row. - -[call [arg matrixName] [method rows]] - -Returns the number of rows currently managed by the matrix. - -[call [arg matrixName] [method search] [opt -nocase] [opt -exact|-glob|-regexp] [method all] [arg pattern]] - -Searches the whole matrix for cells matching the [arg pattern] and -returns a list with all matches. Each item in the aforementioned list -is a list itself and contains the column and row index of the matching -cell, in this order. The results are ordered by column first and row -second, both times in ascending order. This means that matches to the -left and the top of the matrix come before matches to the right and -down. - -[nl] - -The type of the pattern (string, glob, regular expression) is -determined by the option after the [method search] keyword. If no -option is given it defaults to [option -exact]. - -[nl] - -If the option [option -nocase] is specified the search will be -case-insensitive. - -[call [arg matrixName] [method search] [opt -nocase] [opt -exact|-glob|-regexp] [method column] [arg {column pattern}]] - -Like [method {search all}], but the search is restricted to the -specified column. - -[call [arg matrixName] [method search] [opt -nocase] [opt -exact|-glob|-regexp] [method row] [arg {row pattern}]] - -Like [method {search all}], but the search is restricted to the -specified row. - -[call [arg matrixName] [method search] [opt -nocase] [opt -exact|-glob|-regexp] [method rect] [arg {column_tl row_tl column_br row_br pattern}]] - -Like [method {search all}], but the search is restricted to the -specified rectangular area of the matrix. - -[call [arg matrixName] [method {set cell}] [arg {column row value}]] - -Sets the value in the cell identified by row and column index to the -data in the third argument. - -[call [arg matrixName] [method {set column}] [arg {column values}]] - -Sets the values in the cells identified by the column index to the -elements of the list provided as the third argument. Each element of -the list is assigned to one cell, with the first element going into -the cell in row 0 and then upward. If there are less values in the -list than there are rows the remaining rows are set to the empty -string. If there are more values in the list than there are rows the -superfluous elements are ignored. The matrix is not extended by this -operation. - -[call [arg matrixName] [method {set rect}] [arg {column row values}]] - -Takes a list of lists of cell values and writes them into the -submatrix whose top-left cell is specified by the two indices. If the -sublists of the outerlist are not of equal length the shorter sublists -will be filled with empty strings to the length of the longest -sublist. If the submatrix specified by the top-left cell and the -number of rows and columns in the [arg values] extends beyond the -matrix we are modifying the over-extending parts of the values are -ignored, i.e. essentially cut off. This subcommand expects its input -in the format as returned by [method getrect]. - -[call [arg matrixName] [method {set row}] [arg {row values}]] - -Sets the values in the cells identified by the row index to the -elements of the list provided as the third argument. Each element of -the list is assigned to one cell, with the first element going into -the cell in column 0 and then upward. If there are less values in the -list than there are columns the remaining columns are set to the empty -string. If there are more values in the list than there are columns -the superfluous elements are ignored. The matrix is not extended by -this operation. - -[call [arg matrixName] [method {swap columns}] [arg {column_a column_b}]] - -Swaps the contents of the two specified columns. - -[call [arg matrixName] [method {swap rows}] [arg {row_a row_b}]] - -Swaps the contents of the two specified rows. - -[call [arg matrixName] [method unlink] [arg arrayvar]] - -Removes the link between the matrix and the specified arrayvariable, -if there is one. - -[list_end] - -[section EXAMPLES] -[para] - -The examples below assume a 5x5 matrix M with the first row containing -the values 1 to 5, with 1 in the top-left cell. Each other row -contains the contents of the row above it, rotated by one cell to the -right. - -[para] -[example { - % M getrect 0 0 4 4 - {{1 2 3 4 5} {5 1 2 3 4} {4 5 1 2 3} {3 4 5 1 2} {2 3 4 5 1}} -}] - -[para] -[example { - % M setrect 1 1 {{0 0 0} {0 0 0} {0 0 0}} - % M getrect 0 0 4 4 - {{1 2 3 4 5} {5 0 0 0 4} {4 0 0 0 3} {3 0 0 0 2} {2 3 4 5 1}} -}] - -[para] - -Assuming that the style definitions in the example section of the -manpage for the package [package report] are loaded into the -interpreter now an example which formats a matrix into a tabular -report. The code filling the matrix with data is not shown. contains -useful data. - -[para] - -[example { - % ::struct::matrix m - % # ... fill m with data, assume 5 columns - % ::report::report r 5 style captionedtable 1 - % m format 2string r - +---+-------------------+-------+-------+--------+ - |000|VERSIONS: |2:8.4a3|1:8.4a3|1:8.4a3%| - +---+-------------------+-------+-------+--------+ - |001|CATCH return ok |7 |13 |53.85 | - |002|CATCH return error |68 |91 |74.73 | - |003|CATCH no catch used|7 |14 |50.00 | - |004|IF if true numeric |12 |33 |36.36 | - |005|IF elseif |15 |47 |31.91 | - | |true numeric | | | | - +---+-------------------+-------+-------+--------+ - % - % # alternate way of doing the above - % r printmatrix m -}] - -[keywords matrix] -[manpage_end] DELETED modules/struct/matrix.n Index: modules/struct/matrix.n ================================================================== --- modules/struct/matrix.n +++ /dev/null @@ -1,294 +0,0 @@ -'\" -'\" Copyright (c) 2001 by Andreas Kupries -'\" All rights reserved. -'\" -'\" RCS: @(#) $Id: matrix.n,v 1.10 2002/03/10 02:49:52 andreas_kupries Exp $ -'\" -.so man.macros -.TH matrix n 1.2.1 Struct "Tcl Data Structures" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -::struct::matrix \- Create and manipulate matrix objects -.SH SYNOPSIS -\fBpackage require Tcl 8.2\fR -.sp -\fBpackage require struct ?1.2.1?\fR -.sp -\fB::struct::matrix\fR \fImatrixName\fR -.sp -.BE -.SH DESCRIPTION -.PP -The \fB::struct::matrix\fR command creates a new matrix object with an -associated global Tcl command whose name is \fImatrixName\fR. This command -may be used to invoke various operations on the matrix. It has the -following general form: -.CS -\fImatrixName option \fR?\fIarg arg ...\fR? -.CE -\fIOption\fR and the \fIarg\fRs -determine the exact behavior of the command. -.PP -A matrix is a rectangular collection of cells, i.e. organized in rows -and columns. Each cell contains exactly one value of arbitrary -form. The cells in the matrix are addressed by pairs of integer -numbers, with the first (left) number in the pair specifying the -column and the second (right) number specifying the row the cell is -in. These indices are counted from 0 upward. The special non-numeric -index \fBend\fR refers to the last row or column in the matrix, -depending on the context. Indices of the form \fBend\fR -\fInumber\fR -are counted from the end of the row or column, like they are for -standard Tcl lists. Trying to access non-existing cells causes an -error. -.PP -The matrices here are created empty, i.e. they have neither rows nor -columns. The user then has to add rows and columns as needed by his -application. A specialty of this structure is the ability to export an -array-view onto its contents. Such can be used by tkTable, for -example, to link the matrix into the display. -.PP -The following commands are possible for matrix objects: -.TP -\fImatrixName\fR \fBadd column\fR \fI?values?\fR -Extends the matrix by one column and then acts like \fBsetcolumn\fR -(see below) on this new column if there were \fIvalues\fR -supplied. Without \fIvalues\fR the new cells will be set to the empty -string. The new column is appended immediately behind the last existing -column. -.TP -\fImatrixName\fR \fBadd row\fR \fI?values?\fR -Extends the matrix by one row and then acts like \fBsetrow\fR (see -below) on this new row if there were \fIvalues\fR supplied. Without -\fIvalues\fR the new cells will be set to the empty string. The new -row is appended immediately behind the last existing row. -.TP -\fImatrixName\fR \fBadd columns\fR \fIn\fR -Extends the matrix by \fIn\fR columns. The new cells will be set to -the empty string. The new columns are appended immediately behind the -last existing column. A value of \fIn\fR equal to or smaller than 0 is -not allowed. -.TP -\fImatrixName\fR \fBadd rows\fR \fIn\fR -Extends the matrix by \fIn\fR rows. The new cells will be set to the -empty string. The new rows are appended immediately behind the last -existing row. A value of \fIn\fR equal to or smaller than 0 is -not allowed. -.TP -\fImatrixName\fR \fBcells\fR -Returns the number of cells currently managed by the matrix. This is -the product of \fBrows\fR and \fBcolumns\fR. -.TP -\fImatrixName\fR \fBcellsize\fR \fIcolumn row\fR -Returns the length of the string representation of the value currently -contained in the addressed cell. -.TP -\fImatrixName\fR \fBcolumns\fR -Returns the number of columns currently managed by the matrix. -.TP -\fImatrixName\fR \fBcolumnwidth\fR \fIcolumn\fR -Returns the length of the longest string representation of all the -values currently contained in the cells of the addressed column if -these are all spanning only one line. For cell values spanning -multiple lines the length of their longest line goes into the -computation. -.TP -\fImatrixName \fBdelete column\fR \fIcolumn\fR -Deletes the specified column from the matrix and shifts all columns -with higher indices one index down. -.TP -\fImatrixName \fBdelete row\fR \fIrow\fR -Deletes the specified row from the matrix and shifts all row with -higher indices one index down. -.TP -\fImatrixName \fBdestroy\fR -Destroys the matrix, including its storage space and associated -command. -.TP -\fImatrixName \fBformat 2string\fR ?\fIreport\fR? -Formats the matrix using the specified report object and returns the -string containing the result of this operation. The report has to -support the \fBprintmatrix\fR method. If no \fIreport\fR is specified -the system will use an internal report definition to format the -matrix. -.TP -\fImatrixName \fBformat 2chan\fR ??\fIreport\fR? \fIchannel\fR? -Formats the matrix using the specified report object and writes the -string containing the result of this operation into the channel. The -report has to support the \fBprintmatrix2channel\fR method. If no -\fIreport\fR is specified the system will use an internal report -definition to format the matrix. If no \fIchannel\fR is specified the -system will use \fBstdout\fR. -.TP -\fImatrixName\fR \fBget cell\fR \fIcolumn row\fR -Returns the value currently contained in the cell identified by row -and column index. -.TP -\fImatrixName\fR \fBget column\fR \fIcolumn\fR -Returns a list containing the values from all cells in the column -identified by the index. The contents of the cell in row 0 are stored -as the first element of this list. -.TP -\fImatrixName\fR \fBget rect\fR \fIcolumn_tl row_tl column_br row_br\fR -Returns a list of lists of cell values. The values stored in the -result come from the sub-matrix whose top-left and bottom-right cells -are specified by \fIcolumn_tl, row_tl\fR and \fIcolumn_br, row_br\fR -resp. Note that the following equations have to be true: \fIcolumn_tl -<= column_br\fR and \fIrow_tl <= row_br\fR. The result is organized as -follows: The outer list is the list of rows, its elements are lists -representing a single row. The row with the smallest index is the -first element of the outer list. The elements of the row lists -represent the selected cell values. The cell with the smallest index -is the first element in each row list. -.TP -\fImatrixName\fR \fBget row\fR \fIrow\fR -Returns a list containing the values from all cells in the row -identified by the index. The contents of the cell in column 0 are -stored as the first element of this list. -.TP -\fImatrixName\fR \fBinsert column\fR \fIcolumn ?values?\fR -Extends the matrix by one column and then acts like \fBsetcolumn\fR -(see below) on this new column if there were \fIvalues\fR -supplied. Without \fIvalues\fR the new cells will be set to the empty -string. The new column is inserted just before the column specified by -the given index. This means, if \fIcolumn\fR is less than or equal to -zero, then the new column is inserted at the beginning of the matrix, -before the first column. If \fIcolumn\fR has the value \fBend\fR, or -if it is greater than or equal to the number of columns in the matrix, -then the new column is appended to the matrix, behind the last -column. The old column at the chosen index and all columns with higher -indices are shifted one index upward. -.TP -\fImatrixName\fR \fBinsert row\fR \fIrow ?values?\fR -Extends the matrix by one row and then acts like \fBsetrow\fR (see -below) on this new row if there were \fIvalues\fR supplied. Without -\fIvalues\fR the new cells will be set to the empty string. The new -row is inserted just before the row specified by the given index. This -means, if \fIrow\fR is less than or equal to zero, then the new row is -inserted at the beginning of the matrix, before the first row. If -\fIrow\fR has the value \fBend\fR, or if it is greater than or equal -to the number of rows in the matrix, then the new row is appended to -the matrix, behind the last row. The old row at that index and all -rows with higher indices are shifted one index upward. -.TP -\fImatrixName\fR \fBlink\fR \fI?-transpose? arrayvar\fR -Links the matrix to the specified array variable. This means that the -contents of all cells in the matrix is stored in the array too, with -all changes to the matrix propagated there too. The contents of the -cell \fI(column,row)\fR is stored in the array using the key -\fIcolumn,row\fR. If the option \fI-transpose\fR is specified the key -\fIrow,column\fR will be used instead. It is possible to link the -matrix to more than one array. Note that the link is bidirectional, -i.e. changes to the array are mirrored in the matrix too. -.TP -\fImatrixName\fR \fBrowheight\fR \fIrow\fR -Returns the height of the specified row in lines. This is the highest -number of lines spanned by a cell over all cells in the row. -.TP -\fImatrixName\fR \fBrows\fR -Returns the number of rows currently managed by the matrix. -.TP -\fImatrixName\fR \fBsearch\fR ?-nocase? ?-exact|-glob|-regexp? \fBall\fR \fIpattern\fR -Searches the whole matrix for cells matching the \fIpattern\fR and -returns a list with all matches. Each item in the aforementioned list -is a list itself and contains the column and row index of the matching -cell, in this order. The results are ordered by column first and row -second, both times in ascending order. This means that matches to the -left and the top of the matrix come before matches to the right and -down. -.sp -The type of the pattern (string, glob, regular expression) is -determined by the option after the \fBsearch\fR keyword. If no option -is given it defaults to \fB-exact\fR. -.TP -\fImatrixName\fR \fBsearch\fR ?-nocase? ?-exact|-glob|-regexp? \fBcolumn\fR \fIcolumn pattern\fR -Like \fBsearch all\fR, but the search is restricted to the specified -column. -.TP -\fImatrixName\fR \fBsearch\fR ?-nocase? ?-exact|-glob|-regexp? \fBrow\fR \fIrow pattern\fR -Like \fBsearch all\fR, but the search is restricted to the specified -row. -.TP -\fImatrixName\fR \fBsearch\fR ?-nocase? ?-exact|-glob|-regexp? \fBrect\fR \fIcolumn_tl row_tl column_br row_br pattern\fR -Like \fBsearch all\fR, but the search is restricted to the specified -rectangular area of the matrix. -.TP -\fImatrixName\fR \fBset cell\fR \fIcolumn row value\fR -Sets the value in the cell identified by row and column index to the -data in the third argument. -.TP -\fImatrixName\fR \fBset column\fR \fIcolumn values\fR -Sets the values in the cells identified by the column index to the -elements of the list provided as the third argument. Each element of -the list is assigned to one cell, with the first element going into -the cell in row 0 and then upward. If there are less values in the -list than there are rows the remaining rows are set to the empty -string. If there are more values in the list than there are rows the -superfluous elements are ignored. The matrix is not extended by this -operation. -.TP -\fImatrixName\fR \fBset rect\fR \fIcolumn row values\fR -Takes a list of lists of cell values and writes them into the -submatrix whose top-left cell is specified by the two indices. If the -sublists of the outerlist are not of equal length the shorter sublists -will be filled with empty strings to the length of the longest -sublist. If the submatrix specified by the top-left cell and the -number of rows and columns in the \fIvalues\fR extends beyond the -matrix we are modifying the over-extending parts of the values are -ignored, i.e. essentially cut off. This subcommand expects its input -in the format as returned by \fBgetrect\fR. -.TP -\fImatrixName\fR \fBset row\fR \fIrow values\fR -Sets the values in the cells identified by the row index to the -elements of the list provided as the third argument. Each element of -the list is assigned to one cell, with the first element going into -the cell in column 0 and then upward. If there are less values in the -list than there are columns the remaining columns are set to the empty -string. If there are more values in the list than there are columns -the superfluous elements are ignored. The matrix is not extended by -this operation. -.TP -\fImatrixName\fR \fBswap columns\fR \fIcolumn_a column_b\fR -Swaps the contents of the two specified columns. -.TP -\fImatrixName\fR \fBswap rows\fR \fIrow_a row_b\fR -Swaps the contents of the two specified rows. -.TP -\fImatrixName\fR \fBunlink\fR \fIarrayvar\fR -Removes the link between the matrix and the specified arrayvariable, -if there is one. - -.SH EXAMPLES -.PP -The examples below assume a 5x5 matrix M with the first row containing -the values 1 to 5, with 1 in the top-left cell. Each other row -contains the contents of the row above it, rotated by one cell to the -right. -.PP -So -.PP -.CS -M getrect 0 0 4 4 -.CE -.PP -returns -.PP -.CS -{{1 2 3 4 5} {5 1 2 3 4} {4 5 1 2 3} {3 4 5 1 2} {2 3 4 5 1}} -.CE -.PP -And -.PP -.CS -M setrect 1 1 {{0 0 0} {0 0 0} {0 0 0}} - -M getrect 0 0 4 4 -.CE -.PP -returns -.PP -.CS -{{1 2 3 4 5} {5 0 0 0 4} {4 0 0 0 3} {3 0 0 0 2} {2 3 4 5 1}} -.CE -.SH KEYWORDS -matrix DELETED modules/struct/matrix.tcl Index: modules/struct/matrix.tcl ================================================================== --- modules/struct/matrix.tcl +++ /dev/null @@ -1,2089 +0,0 @@ -# matrix.tcl -- -# -# Implementation of a matrix data structure for Tcl. -# -# Copyright (c) 2001 by Andreas Kupries -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: matrix.tcl,v 1.11 2003/02/25 21:12:47 davidw Exp $ - -package require Tcl 8.2 - -namespace eval ::struct {} - -namespace eval ::struct::matrix { - # Data storage in the matrix module - # ------------------------------- - # - # One namespace per object, containing - # - # - Two scalar variables containing the current number of rows and columns. - # - Four array variables containing the array data, the caches for - # rowheights and columnwidths and the information about linked arrays. - # - # The variables are - # - columns #columns in data - # - rows #rows in data - # - data cell contents - # - colw cache of columnwidths - # - rowh cache of rowheights - # - link information about linked arrays - # - lock boolean flag to disable MatTraceIn while in MatTraceOut [#532783] - # - unset string used to convey information about 'unset' traces from MatTraceIn to MatTraceOut. - - # counter is used to give a unique name for unnamed matrixs - variable counter 0 - - # commands is the list of subcommands recognized by the matrix - variable commands - set commands(.) [list \ - "add" \ - "cells" \ - "cellsize" \ - "columns" \ - "columnwidth" \ - "delete" \ - "destroy" \ - "format" \ - "get" \ - "insert" \ - "link" \ - "rowheight" \ - "rows" \ - "search" \ - "set" \ - "swap" \ - "unlink" - ] - - # Some subcommands have their own subcommands. - set commands(add) [list "column" "columns" "row" "rows"] - set commands(delete) [list "column" "row"] - set commands(format) [list "2chan" "2string"] - set commands(get) [list "cell" "column" "rect" "row"] - set commands(insert) [list "column" "row"] - set commands(set) [list "cell" "column" "rect" "row"] - set commands(swap) [list "columns" "rows"] - - # Only export one command, the one used to instantiate a new matrix - namespace export matrix -} - -# ::struct::matrix::matrix -- -# -# Create a new matrix with a given name; if no name is given, use -# matrixX, where X is a number. -# -# Arguments: -# name Optional name of the matrix; if null or not given, generate one. -# -# Results: -# name Name of the matrix created - -proc ::struct::matrix::matrix {{name ""}} { - variable counter - - if { [llength [info level 0]] == 1 } { - incr counter - set name "matrix${counter}" - } - - if { [llength [info commands ::$name]] } { - error "command \"$name\" already exists, unable to create matrix" - } - - # Set up the namespace - namespace eval ::struct::matrix::matrix$name { - variable columns 0 - variable rows 0 - - variable data - variable colw - variable rowh - variable link - variable lock - variable unset - - array set data {} - array set colw {} - array set rowh {} - array set link {} - set lock 0 - set unset {} - } - - # Create the command to manipulate the matrix - interp alias {} ::$name {} ::struct::matrix::MatrixProc $name - - return $name -} - -########################## -# Private functions follow - -# ::struct::matrix::MatrixProc -- -# -# Command that processes all matrix object commands. -# -# Arguments: -# name Name of the matrix object to manipulate. -# cmd Subcommand to invoke. -# args Arguments for subcommand. -# -# Results: -# Varies based on command to perform - -proc ::struct::matrix::MatrixProc {name {cmd ""} args} { - # Do minimal args checks here - if { [llength [info level 0]] == 2 } { - error "wrong # args: should be \"$name option ?arg arg ...?\"" - } - - # Split the args into command and args components - if { [llength [info commands ::struct::matrix::_$cmd]] == 0 } { - variable commands - set optlist [join $commands(.) ", "] - set optlist [linsert $optlist "end-1" "or"] - error "bad option \"$cmd\": must be $optlist" - } - eval [list ::struct::matrix::_$cmd $name] $args -} - -# ::struct::matrix::_add -- -# -# Command that processes all 'add' subcommands. -# -# Arguments: -# name Name of the matrix object to manipulate. -# cmd Subcommand of 'add' to invoke. -# args Arguments for subcommand of 'add'. -# -# Results: -# Varies based on command to perform - -proc ::struct::matrix::_add {name {cmd ""} args} { - # Do minimal args checks here - if { [llength [info level 0]] == 2 } { - error "wrong # args: should be \"$name add option ?arg arg ...?\"" - } - - # Split the args into command and args components - if { [llength [info commands ::struct::matrix::__add_$cmd]] == 0 } { - variable commands - set optlist [join $commands(add) ", "] - set optlist [linsert $optlist "end-1" "or"] - error "bad option \"$cmd\": must be $optlist" - } - eval [list ::struct::matrix::__add_$cmd $name] $args -} - -# ::struct::matrix::_delete -- -# -# Command that processes all 'delete' subcommands. -# -# Arguments: -# name Name of the matrix object to manipulate. -# cmd Subcommand of 'delete' to invoke. -# args Arguments for subcommand of 'delete'. -# -# Results: -# Varies based on command to perform - -proc ::struct::matrix::_delete {name {cmd ""} args} { - # Do minimal args checks here - if { [llength [info level 0]] == 2 } { - error "wrong # args: should be \"$name delete option ?arg arg ...?\"" - } - - # Split the args into command and args components - if { [llength [info commands ::struct::matrix::__delete_$cmd]] == 0 } { - variable commands - set optlist [join $commands(delete) ", "] - set optlist [linsert $optlist "end-1" "or"] - error "bad option \"$cmd\": must be $optlist" - } - eval [list ::struct::matrix::__delete_$cmd $name] $args -} - -# ::struct::matrix::_format -- -# -# Command that processes all 'format' subcommands. -# -# Arguments: -# name Name of the matrix object to manipulate. -# cmd Subcommand of 'format' to invoke. -# args Arguments for subcommand of 'format'. -# -# Results: -# Varies based on command to perform - -proc ::struct::matrix::_format {name {cmd ""} args} { - # Do minimal args checks here - if { [llength [info level 0]] == 2 } { - error "wrong # args: should be \"$name format option ?arg arg ...?\"" - } - - # Split the args into command and args components - if { [llength [info commands ::struct::matrix::__format_$cmd]] == 0 } { - variable commands - set optlist [join $commands(format) ", "] - set optlist [linsert $optlist "end-1" "or"] - error "bad option \"$cmd\": must be $optlist" - } - eval [list ::struct::matrix::__format_$cmd $name] $args -} - -# ::struct::matrix::_get -- -# -# Command that processes all 'get' subcommands. -# -# Arguments: -# name Name of the matrix object to manipulate. -# cmd Subcommand of 'get' to invoke. -# args Arguments for subcommand of 'get'. -# -# Results: -# Varies based on command to perform - -proc ::struct::matrix::_get {name {cmd ""} args} { - # Do minimal args checks here - if { [llength [info level 0]] == 2 } { - error "wrong # args: should be \"$name get option ?arg arg ...?\"" - } - - # Split the args into command and args components - if { [llength [info commands ::struct::matrix::__get_$cmd]] == 0 } { - variable commands - set optlist [join $commands(get) ", "] - set optlist [linsert $optlist "end-1" "or"] - error "bad option \"$cmd\": must be $optlist" - } - eval [list ::struct::matrix::__get_$cmd $name] $args -} - -# ::struct::matrix::_insert -- -# -# Command that processes all 'insert' subcommands. -# -# Arguments: -# name Name of the matrix object to manipulate. -# cmd Subcommand of 'insert' to invoke. -# args Arguments for subcommand of 'insert'. -# -# Results: -# Varies based on command to perform - -proc ::struct::matrix::_insert {name {cmd ""} args} { - # Do minimal args checks here - if { [llength [info level 0]] == 2 } { - error "wrong # args: should be \"$name insert option ?arg arg ...?\"" - } - - # Split the args into command and args components - if { [llength [info commands ::struct::matrix::__insert_$cmd]] == 0 } { - variable commands - set optlist [join $commands(insert) ", "] - set optlist [linsert $optlist "end-1" "or"] - error "bad option \"$cmd\": must be $optlist" - } - eval [list ::struct::matrix::__insert_$cmd $name] $args -} - -# ::struct::matrix::_search -- -# -# Command that processes all 'search' subcommands. -# -# Arguments: -# name Name of the matrix object to manipulate. -# args Arguments for search. -# -# Results: -# Varies based on command to perform - -proc ::struct::matrix::_search {name args} { - set mode exact - set nocase 0 - - while {1} { - switch -glob -- [lindex $args 0] { - -exact - -glob - -regexp { - set mode [string range [lindex $args 0] 1 end] - set args [lrange $args 1 end] - } - -nocase { - set nocase 1 - } - -* { - return -code error \ - "invalid option \"[lindex $args 0]\":\ - should be -nocase, -exact, -glob, or -regexp" - } - default { - break - } - } - } - - # Possible argument signatures after option processing - # - # \ | args - # --+-------------------------------------------------------- - # 2 | all pattern - # 3 | row row pattern, column col pattern - # 6 | rect ctl rtl cbr rbr pattern - # - # All range specifications are internally converted into a - # rectangle. - - switch -exact -- [llength $args] { - 2 - 3 - 6 {} - default { - return -code error \ - "wrong # args: should be\ - \"$name search ?option...? (all|row row|column col|rect c r c r) pattern\"" - } - } - - set range [lindex $args 0] - set pattern [lindex $args end] - set args [lrange $args 1 end-1] - - upvar ::struct::matrix::matrix${name}::data data - upvar ::struct::matrix::matrix${name}::columns cols - upvar ::struct::matrix::matrix${name}::rows rows - - switch -exact -- $range { - all { - set ctl 0 ; set cbr $cols ; incr cbr -1 - set rtl 0 ; set rbr $rows ; incr rbr -1 - } - column { - set ctl [ChkColumnIndex $name [lindex $args 0]] - set cbr $ctl - set rtl 0 ; set rbr $rows ; incr rbr -1 - } - row { - set rtl [ChkRowIndex $name [lindex $args 0]] - set ctl 0 ; set cbr $cols ; incr cbr -1 - set rbr $rtl - } - rect { - foreach {ctl rtl cbr rbr} $args break - set ctl [ChkColumnIndex $name $ctl] - set rtl [ChkRowIndex $name $rtl] - set cbr [ChkColumnIndex $name $cbr] - set rbr [ChkRowIndex $name $rbr] - if {($ctl > $cbr) || ($rtl > $rbr)} { - return -code error "Invalid cell indices, wrong ordering" - } - } - default { - return -code error "invalid range spec \"$range\": should be all, column, row, or rect" - } - } - - if {$nocase} { - set pattern [string tolower $pattern] - } - - set matches [list] - for {set r $rtl} {$r <= $rbr} {incr r} { - for {set c $ctl} {$c <= $cbr} {incr c} { - set v $data($c,$r) - if {$nocase} { - set v [string tolower $v] - } - switch -exact -- $mode { - exact {set matched [string equal $pattern $v]} - glob {set matched [string match $pattern $v]} - regexp {set matched [regexp -- $pattern $v]} - } - if {$matched} { - lappend matches [list $c $r] - } - } - } - return $matches -} - -# ::struct::matrix::_set -- -# -# Command that processes all 'set' subcommands. -# -# Arguments: -# name Name of the matrix object to manipulate. -# cmd Subcommand of 'set' to invoke. -# args Arguments for subcommand of 'set'. -# -# Results: -# Varies based on command to perform - -proc ::struct::matrix::_set {name {cmd ""} args} { - # Do minimal args checks here - if { [llength [info level 0]] == 2 } { - error "wrong # args: should be \"$name set option ?arg arg ...?\"" - } - - # Split the args into command and args components - if { [llength [info commands ::struct::matrix::__set_$cmd]] == 0 } { - variable commands - set optlist [join $commands(set) ", "] - set optlist [linsert $optlist "end-1" "or"] - error "bad option \"$cmd\": must be $optlist" - } - eval [list ::struct::matrix::__set_$cmd $name] $args -} - -# ::struct::matrix::_swap -- -# -# Command that processes all 'swap' subcommands. -# -# Arguments: -# name Name of the matrix object to manipulate. -# cmd Subcommand of 'swap' to invoke. -# args Arguments for subcommand of 'swap'. -# -# Results: -# Varies based on command to perform - -proc ::struct::matrix::_swap {name {cmd ""} args} { - # Do minimal args checks here - if { [llength [info level 0]] == 2 } { - error "wrong # args: should be \"$name swap option ?arg arg ...?\"" - } - - # Split the args into command and args components - if { [llength [info commands ::struct::matrix::__swap_$cmd]] == 0 } { - variable commands - set optlist [join $commands(swap) ", "] - set optlist [linsert $optlist "end-1" "or"] - error "bad option \"$cmd\": must be $optlist" - } - eval [list ::struct::matrix::__swap_$cmd $name] $args -} - -# ::struct::matrix::__add_column -- -# -# Extends the matrix by one column and then acts like -# "setcolumn" (see below) on this new column if there were -# "values" supplied. Without "values" the new cells will be set -# to the empty string. The new column is appended immediately -# behind the last existing column. -# -# Arguments: -# name Name of the matrix object. -# values Optional values to set into the new row. -# -# Results: -# None. - -proc ::struct::matrix::__add_column {name {values {}}} { - upvar ::struct::matrix::matrix${name}::data data - upvar ::struct::matrix::matrix${name}::columns cols - upvar ::struct::matrix::matrix${name}::rows rows - upvar ::struct::matrix::matrix${name}::rowh rh - - if {[set l [llength $values]] < $rows} { - # Missing values. Fill up with empty strings - - for {} {$l < $rows} {incr l} { - lappend values {} - } - } elseif {[llength $values] > $rows} { - # To many values. Remove the superfluous items - set values [lrange $values 0 [expr {$rows - 1}]] - } - - # "values" now contains the information to set into the array. - # Regarding the width and height caches: - - # - The new column is not added to the width cache, the other - # columns are not touched, the cache therefore unchanged. - # - The rows are either removed from the height cache or left - # unchanged, depending on the contents set into the cell. - - set r 0 - foreach v $values { - if {$v != {}} { - # Data changed unpredictably, invalidate cache - catch {unset rh($r)} - } ; # {else leave the row unchanged} - set data($cols,$r) $v - incr r - } - incr cols - return -} - -# ::struct::matrix::__add_row -- -# -# Extends the matrix by one row and then acts like "setrow" (see -# below) on this new row if there were "values" -# supplied. Without "values" the new cells will be set to the -# empty string. The new row is appended immediately behind the -# last existing row. -# -# Arguments: -# name Name of the matrix object. -# values Optional values to set into the new row. -# -# Results: -# None. - -proc ::struct::matrix::__add_row {name {values {}}} { - upvar ::struct::matrix::matrix${name}::data data - upvar ::struct::matrix::matrix${name}::columns cols - upvar ::struct::matrix::matrix${name}::rows rows - upvar ::struct::matrix::matrix${name}::colw cw - - if {[set l [llength $values]] < $cols} { - # Missing values. Fill up with empty strings - - for {} {$l < $cols} {incr l} { - lappend values {} - } - } elseif {[llength $values] > $cols} { - # To many values. Remove the superfluous items - set values [lrange $values 0 [expr {$cols - 1}]] - } - - # "values" now contains the information to set into the array. - # Regarding the width and height caches: - - # - The new row is not added to the height cache, the other - # rows are not touched, the cache therefore unchanged. - # - The columns are either removed from the width cache or left - # unchanged, depending on the contents set into the cell. - - set c 0 - foreach v $values { - if {$v != {}} { - # Data changed unpredictably, invalidate cache - catch {unset cw($c)} - } ; # {else leave the row unchanged} - set data($c,$rows) $v - incr c - } - incr rows - return -} - -# ::struct::matrix::__add_columns -- -# -# Extends the matrix by "n" columns. The new cells will be set -# to the empty string. The new columns are appended immediately -# behind the last existing column. A value of "n" equal to or -# smaller than 0 is not allowed. -# -# Arguments: -# name Name of the matrix object. -# n The number of new columns to create. -# -# Results: -# None. - -proc ::struct::matrix::__add_columns {name n} { - if {$n <= 0} { - return -code error "A value of n <= 0 is not allowed" - } - - upvar ::struct::matrix::matrix${name}::data data - upvar ::struct::matrix::matrix${name}::columns cols - upvar ::struct::matrix::matrix${name}::rows rows - - # The new values set into the cell is always the empty - # string. These have a length and height of 0, i.e. the don't - # influence cached widths and heights as they are at least that - # big. IOW there is no need to touch and change the width and - # height caches. - - while {$n > 0} { - for {set r 0} {$r < $rows} {incr r} { - set data($cols,$r) "" - } - incr cols - incr n -1 - } - - return -} - -# ::struct::matrix::__add_rows -- -# -# Extends the matrix by "n" rows. The new cells will be set to -# the empty string. The new rows are appended immediately behind -# the last existing row. A value of "n" equal to or smaller than -# 0 is not allowed. -# -# Arguments: -# name Name of the matrix object. -# n The number of new rows to create. -# -# Results: -# None. - -proc ::struct::matrix::__add_rows {name n} { - if {$n <= 0} { - return -code error "A value of n <= 0 is not allowed" - } - - upvar ::struct::matrix::matrix${name}::data data - upvar ::struct::matrix::matrix${name}::columns cols - upvar ::struct::matrix::matrix${name}::rows rows - - # The new values set into the cell is always the empty - # string. These have a length and height of 0, i.e. the don't - # influence cached widths and heights as they are at least that - # big. IOW there is no need to touch and change the width and - # height caches. - - while {$n > 0} { - for {set c 0} {$c < $cols} {incr c} { - set data($c,$rows) "" - } - incr rows - incr n -1 - } - return -} - -# ::struct::matrix::_cells -- -# -# Returns the number of cells currently managed by the -# matrix. This is the product of "rows" and "columns". -# -# Arguments: -# name Name of the matrix object. -# -# Results: -# The number of cells in the matrix. - -proc ::struct::matrix::_cells {name} { - upvar ::struct::matrix::matrix${name}::rows rows - upvar ::struct::matrix::matrix${name}::columns columns - return [expr {$rows * $columns}] -} - -# ::struct::matrix::_cellsize -- -# -# Returns the length of the string representation of the value -# currently contained in the addressed cell. -# -# Arguments: -# name Name of the matrix object. -# column Column index of the cell to query -# row Row index of the cell to query -# -# Results: -# The number of cells in the matrix. - -proc ::struct::matrix::_cellsize {name column row} { - set column [ChkColumnIndex $name $column] - set row [ChkRowIndex $name $row] - - upvar ::struct::matrix::matrix${name}::data data - return [string length $data($column,$row)] -} - -# ::struct::matrix::_columns -- -# -# Returns the number of columns currently managed by the -# matrix. -# -# Arguments: -# name Name of the matrix object. -# -# Results: -# The number of columns in the matrix. - -proc ::struct::matrix::_columns {name} { - upvar ::struct::matrix::matrix${name}::columns columns - return $columns -} - -# ::struct::matrix::_columnwidth -- -# -# Returns the length of the longest string representation of all -# the values currently contained in the cells of the addressed -# column if these are all spanning only one line. For cell -# values spanning multiple lines the length of their longest -# line goes into the computation. -# -# Arguments: -# name Name of the matrix object. -# column The index of the column whose width is asked for. -# -# Results: -# See description. - -proc ::struct::matrix::_columnwidth {name column} { - set column [ChkColumnIndex $name $column] - - upvar ::struct::matrix::matrix${name}::colw cw - - if {![info exists cw($column)]} { - upvar ::struct::matrix::matrix${name}::rows rows - upvar ::struct::matrix::matrix${name}::data data - - set width 0 - for {set r 0} {$r < $rows} {incr r} { - foreach line [split $data($column,$r) \n] { - set len [string length $line] - if {$len > $width} { - set width $len - } - } - } - - set cw($column) $width - } - - return $cw($column) -} - -# ::struct::matrix::__delete_column -- -# -# Deletes the specified column from the matrix and shifts all -# columns with higher indices one index down. -# -# Arguments: -# name Name of the matrix. -# column The index of the column to delete. -# -# Results: -# None. - -proc ::struct::matrix::__delete_column {name column} { - set column [ChkColumnIndex $name $column] - - upvar ::struct::matrix::matrix${name}::data data - upvar ::struct::matrix::matrix${name}::rows rows - upvar ::struct::matrix::matrix${name}::columns cols - upvar ::struct::matrix::matrix${name}::colw cw - upvar ::struct::matrix::matrix${name}::rowh rh - - # Move all data from the higher columns down and then delete the - # superfluous data in the old last column. Move the data in the - # width cache too, take partial fill into account there too. - # Invalidate the height cache for all rows. - - for {set r 0} {$r < $rows} {incr r} { - for {set c $column; set cn [expr {$c + 1}]} {$cn < $cols} {incr c ; incr cn} { - set data($c,$r) $data($cn,$r) - if {[info exists cw($cn)]} { - set cw($c) $cw($cn) - unset cw($cn) - } - } - unset data($c,$r) - catch {unset rh($r)} - } - incr cols -1 - return -} - -# ::struct::matrix::__delete_row -- -# -# Deletes the specified row from the matrix and shifts all -# row with higher indices one index down. -# -# Arguments: -# name Name of the matrix. -# row The index of the row to delete. -# -# Results: -# None. - -proc ::struct::matrix::__delete_row {name row} { - set row [ChkRowIndex $name $row] - - upvar ::struct::matrix::matrix${name}::data data - upvar ::struct::matrix::matrix${name}::rows rows - upvar ::struct::matrix::matrix${name}::columns cols - upvar ::struct::matrix::matrix${name}::colw cw - upvar ::struct::matrix::matrix${name}::rowh rh - - # Move all data from the higher rows down and then delete the - # superfluous data in the old last row. Move the data in the - # height cache too, take partial fill into account there too. - # Invalidate the width cache for all columns. - - for {set c 0} {$c < $cols} {incr c} { - for {set r $row; set rn [expr {$r + 1}]} {$rn < $rows} {incr r ; incr rn} { - set data($c,$r) $data($c,$rn) - if {[info exists rh($rn)]} { - set rh($r) $rh($rn) - unset rh($rn) - } - } - unset data($c,$r) - catch {unset cw($c)} - } - incr rows -1 - return -} - -# ::struct::matrix::_destroy -- -# -# Destroy a matrix, including its associated command and data storage. -# -# Arguments: -# name Name of the matrix to destroy. -# -# Results: -# None. - -proc ::struct::matrix::_destroy {name} { - upvar ::struct::matrix::matrix${name}::link link - - # Unlink all existing arrays before destroying the object so that - # we don't leave dangling references / traces. - - foreach avar [array names link] { - _unlink $name $avar - } - - namespace delete ::struct::matrix::matrix$name - interp alias {} ::$name {} -} - -# ::struct::matrix::__format_2string -- -# -# Formats the matrix using the specified report object and -# returns the string containing the result of this -# operation. The report has to support the "printmatrix" method. -# -# Arguments: -# name Name of the matrix. -# report Name of the report object specifying the formatting. -# -# Results: -# A string containing the formatting result. - -proc ::struct::matrix::__format_2string {name {report {}}} { - if {$report == {}} { - # Use an internal hardwired simple report to format the matrix. - # 1. Go through all columns and compute the column widths. - # 2. Then iterate through all rows and dump then into a - # string, formatted to the number of characters per columns - - array set cw {} - set cols [_columns $name] - for {set c 0} {$c < $cols} {incr c} { - set cw($c) [_columnwidth $name $c] - } - - set result [list] - set n [_rows $name] - for {set r 0} {$r < $n} {incr r} { - set rh [_rowheight $name $r] - if {$rh < 2} { - # Simple row. - set line [list] - for {set c 0} {$c < $cols} {incr c} { - set val [__get_cell $name $c $r] - lappend line "$val[string repeat " " [expr {$cw($c)-[string length $val]}]]" - } - lappend result [join $line " "] - } else { - # Complex row, multiple passes - for {set h 0} {$h < $rh} {incr h} { - set line [list] - for {set c 0} {$c < $cols} {incr c} { - set val [lindex [split [__get_cell $name $c $r] \n] $h] - lappend line "$val[string repeat " " [expr {$cw($c)-[string length $val]}]]" - } - lappend result [join $line " "] - } - } - } - return [join $result \n] - } else { - return [$report printmatrix $name] - } -} - -# ::struct::matrix::__format_2chan -- -# -# Formats the matrix using the specified report object and -# writes the string containing the result of this operation into -# the channel. The report has to support the -# "printmatrix2channel" method. -# -# Arguments: -# name Name of the matrix. -# report Name of the report object specifying the formatting. -# chan Handle of the channel to write to. -# -# Results: -# None. - -proc ::struct::matrix::__format_2chan {name {report {}} {chan stdout}} { - if {$report == {}} { - # Use an internal hardwired simple report to format the matrix. - # We delegate this to the string formatter and print its result. - puts -nonewline [__format_2string $name] - } else { - $report printmatrix2channel $name $chan - } - return -} - -# ::struct::matrix::__get_dell -- -# -# Returns the value currently contained in the cell identified -# by row and column index. -# -# Arguments: -# name Name of the matrix. -# column Column index of the addressed cell. -# row Row index of the addressed cell. -# -# Results: -# value Value currently stored in the addressed cell. - -proc ::struct::matrix::__get_cell {name column row} { - set column [ChkColumnIndex $name $column] - set row [ChkRowIndex $name $row] - - upvar ::struct::matrix::matrix${name}::data data - return $data($column,$row) -} - -# ::struct::matrix::__get_column -- -# -# Returns a list containing the values from all cells in the -# column identified by the index. The contents of the cell in -# row 0 are stored as the first element of this list. -# -# Arguments: -# name Name of the matrix. -# column Column index of the addressed cell. -# -# Results: -# List of values stored in the addressed row. - -proc ::struct::matrix::__get_column {name column} { - set column [ChkColumnIndex $name $column] - - upvar ::struct::matrix::matrix${name}::data data - upvar ::struct::matrix::matrix${name}::rows rows - - set result [list] - for {set r 0} {$r < $rows} {incr r} { - lappend result $data($column,$r) - } - return $result -} - -# ::struct::matrix::__get_rect -- -# -# Returns a list of lists of cell values. The values stored in -# the result come from the submatrix whose top-left and -# bottom-right cells are specified by "column_tl", "row_tl" and -# "column_br", "row_br" resp. Note that the following equations -# have to be true: column_tl <= column_br and row_tl <= row_br. -# The result is organized as follows: The outer list is the list -# of rows, its elements are lists representing a single row. The -# row with the smallest index is the first element of the outer -# list. The elements of the row lists represent the selected -# cell values. The cell with the smallest index is the first -# element in each row list. -# -# Arguments: -# name Name of the matrix. -# column_tl Column index of the top-left cell of the area. -# row_tl Row index of the top-left cell of the the area -# column_br Column index of the bottom-right cell of the area. -# row_br Row index of the bottom-right cell of the the area -# -# Results: -# List of a list of values stored in the addressed area. - -proc ::struct::matrix::__get_rect {name column_tl row_tl column_br row_br} { - set column_tl [ChkColumnIndex $name $column_tl] - set row_tl [ChkRowIndex $name $row_tl] - set column_br [ChkColumnIndex $name $column_br] - set row_br [ChkRowIndex $name $row_br] - - if { - ($column_tl > $column_br) || - ($row_tl > $row_br) - } { - return -code error "Invalid cell indices, wrong ordering" - } - - upvar ::struct::matrix::matrix${name}::data data - set result [list] - - for {set r $row_tl} {$r <= $row_br} {incr r} { - set row [list] - for {set c $column_tl} {$c <= $column_br} {incr c} { - lappend row $data($c,$r) - } - lappend result $row - } - - return $result -} - -# ::struct::matrix::__get_row -- -# -# Returns a list containing the values from all cells in the -# row identified by the index. The contents of the cell in -# column 0 are stored as the first element of this list. -# -# Arguments: -# name Name of the matrix. -# row Row index of the addressed cell. -# -# Results: -# List of values stored in the addressed row. - -proc ::struct::matrix::__get_row {name row} { - set row [ChkRowIndex $name $row] - - upvar ::struct::matrix::matrix${name}::data data - upvar ::struct::matrix::matrix${name}::columns cols - - set result [list] - for {set c 0} {$c < $cols} {incr c} { - lappend result $data($c,$row) - } - return $result -} - -# ::struct::matrix::__insert_column -- -# -# Extends the matrix by one column and then acts like -# "setcolumn" (see below) on this new column if there were -# "values" supplied. Without "values" the new cells will be set -# to the empty string. The new column is inserted just before -# the column specified by the given index. This means, if -# "column" is less than or equal to zero, then the new column is -# inserted at the beginning of the matrix, before the first -# column. If "column" has the value "Bend", or if it is greater -# than or equal to the number of columns in the matrix, then the -# new column is appended to the matrix, behind the last -# column. The old column at the chosen index and all columns -# with higher indices are shifted one index upward. -# -# Arguments: -# name Name of the matrix. -# column Index of the column where to insert. -# values Optional values to set the cells to. -# -# Results: -# None. - -proc ::struct::matrix::__insert_column {name column {values {}}} { - # Allow both negative and too big indices. - set column [ChkColumnIndexAll $name $column] - - upvar ::struct::matrix::matrix${name}::data data - upvar ::struct::matrix::matrix${name}::columns cols - upvar ::struct::matrix::matrix${name}::rows rows - upvar ::struct::matrix::matrix${name}::rowh rh - - if {$column > $cols} { - # Same as 'addcolumn' - __add_column $name $values - return - } - - set firstcol $column - if {$firstcol < 0} { - set firstcol 0 - } - - if {[set l [llength $values]] < $rows} { - # Missing values. Fill up with empty strings - - for {} {$l < $rows} {incr l} { - lappend values {} - } - } elseif {[llength $values] > $rows} { - # To many values. Remove the superfluous items - set values [lrange $values 0 [expr {$rows - 1}]] - } - - # "values" now contains the information to set into the array. - # Regarding the width and height caches: - # Invalidate all rows, move all columns - - # Move all data from the higher columns one up and then insert the - # new data into the freed space. Move the data in the - # width cache too, take partial fill into account there too. - # Invalidate the height cache for all rows. - - for {set r 0} {$r < $rows} {incr r} { - for {set cn $cols ; set c [expr {$cn - 1}]} {$c >= $firstcol} {incr c -1 ; incr cn -1} { - set data($cn,$r) $data($c,$r) - if {[info exists cw($c)]} { - set cw($cn) $cw($c) - unset cw($c) - } - } - set data($firstcol,$r) [lindex $values $r] - catch {unset rh($r)} - } - incr cols - return -} - -# ::struct::matrix::__insert_row -- -# -# Extends the matrix by one row and then acts like "setrow" (see -# below) on this new row if there were "values" -# supplied. Without "values" the new cells will be set to the -# empty string. The new row is inserted just before the row -# specified by the given index. This means, if "row" is less -# than or equal to zero, then the new row is inserted at the -# beginning of the matrix, before the first row. If "row" has -# the value "end", or if it is greater than or equal to the -# number of rows in the matrix, then the new row is appended to -# the matrix, behind the last row. The old row at that index and -# all rows with higher indices are shifted one index upward. -# -# Arguments: -# name Name of the matrix. -# row Index of the row where to insert. -# values Optional values to set the cells to. -# -# Results: -# None. - -proc ::struct::matrix::__insert_row {name row {values {}}} { - # Allow both negative and too big indices. - set row [ChkRowIndexAll $name $row] - - upvar ::struct::matrix::matrix${name}::data data - upvar ::struct::matrix::matrix${name}::columns cols - upvar ::struct::matrix::matrix${name}::rows rows - upvar ::struct::matrix::matrix${name}::rowh rh - - if {$row > $rows} { - # Same as 'addrow' - __add_row $name $values - return - } - - set firstrow $row - if {$firstrow < 0} { - set firstrow 0 - } - - if {[set l [llength $values]] < $cols} { - # Missing values. Fill up with empty strings - - for {} {$l < $cols} {incr l} { - lappend values {} - } - } elseif {[llength $values] > $cols} { - # To many values. Remove the superfluous items - set values [lrange $values 0 [expr {$cols - 1}]] - } - - # "values" now contains the information to set into the array. - # Regarding the width and height caches: - # Invalidate all columns, move all rows - - # Move all data from the higher rows one up and then insert the - # new data into the freed space. Move the data in the - # height cache too, take partial fill into account there too. - # Invalidate the width cache for all columns. - - for {set c 0} {$c < $cols} {incr c} { - for {set rn $rows ; set r [expr {$rn - 1}]} {$r >= $firstrow} {incr r -1 ; incr rn -1} { - set data($c,$rn) $data($c,$r) - if {[info exists rh($r)]} { - set rh($rn) $rh($r) - unset rh($r) - } - } - set data($c,$firstrow) [lindex $values $c] - catch {unset cw($c)} - } - incr rows - return -} - -# ::struct::matrix::_link -- -# -# Links the matrix to the specified array variable. This means -# that the contents of all cells in the matrix is stored in the -# array too, with all changes to the matrix propagated there -# too. The contents of the cell "(column,row)" is stored in the -# array using the key "column,row". If the option "-transpose" -# is specified the key "row,column" will be used instead. It is -# possible to link the matrix to more than one array. Note that -# the link is bidirectional, i.e. changes to the array are -# mirrored in the matrix too. -# -# Arguments: -# name Name of the matrix object. -# option Either empty of '-transpose'. -# avar Name of the variable to link to -# -# Results: -# None - -proc ::struct::matrix::_link {name args} { - switch -exact -- [llength $args] { - 0 { - return -code error "$name: wrong # args: link ?-transpose? arrayvariable" - } - 1 { - set transpose 0 - set variable [lindex $args 0] - } - 2 { - foreach {t variable} $args break - if {[string compare $t -transpose]} { - return -code error "$name: illegal syntax: link ?-transpose? arrayvariable" - } - set transpose 1 - } - default { - return -code error "$name: wrong # args: link ?-transpose? arrayvariable" - } - } - - upvar ::struct::matrix::matrix${name}::link link - - if {[info exists link($variable)]} { - return -code error "$name link: Variable \"$variable\" already linked to matrix" - } - - # Ok, a new variable we are linked to. Record this information, - # dump our current contents into the array, at last generate the - # traces actually performing the link. - - set link($variable) $transpose - - upvar #0 $variable array - upvar ::struct::matrix::matrix${name}::data data - - foreach key [array names data] { - foreach {c r} [split $key ,] break - if {$transpose} { - set array($r,$c) $data($key) - } else { - set array($c,$r) $data($key) - } - } - - trace variable array wu [list ::struct::matrix::MatTraceIn $variable $name] - trace variable data w [list ::struct::matrix::MatTraceOut $variable $name] - return -} - -# ::struct::matrix::_links -- -# -# Retrieves the names of all array variable the matrix is -# officialy linked to. -# -# Arguments: -# name Name of the matrix object. -# -# Results: -# List of variables the matrix is linked to. - -proc ::struct::matrix::_links {name} { - upvar ::struct::matrix::matrix${name}::link link - return [array names link] -} - -# ::struct::matrix::_rowheight -- -# -# Returns the height of the specified row in lines. This is the -# highest number of lines spanned by a cell over all cells in -# the row. -# -# Arguments: -# name Name of the matrix -# row Index of the row queried for its height -# -# Results: -# The height of the specified row in lines. - -proc ::struct::matrix::_rowheight {name row} { - set row [ChkRowIndex $name $row] - - upvar ::struct::matrix::matrix${name}::rowh rh - - if {![info exists rh($row)]} { - upvar ::struct::matrix::matrix${name}::columns cols - upvar ::struct::matrix::matrix${name}::data data - - set height 1 - for {set c 0} {$c < $cols} {incr c} { - set cheight [llength [split $data($c,$row) \n]] - if {$cheight > $height} { - set height $cheight - } - } - - set rh($row) $height - } - return $rh($row) -} - -# ::struct::matrix::_rows -- -# -# Returns the number of rows currently managed by the matrix. -# -# Arguments: -# name Name of the matrix object. -# -# Results: -# The number of rows in the matrix. - -proc ::struct::matrix::_rows {name} { - upvar ::struct::matrix::matrix${name}::rows rows - return $rows -} - -# ::struct::matrix::__set_cell -- -# -# Sets the value in the cell identified by row and column index -# to the data in the third argument. -# -# Arguments: -# name Name of the matrix object. -# column Column index of the cell to set. -# row Row index of the cell to set. -# value THe new value of the cell. -# -# Results: -# None. - -proc ::struct::matrix::__set_cell {name column row value} { - set column [ChkColumnIndex $name $column] - set row [ChkRowIndex $name $row] - - upvar ::struct::matrix::matrix${name}::data data - - if {![string compare $value $data($column,$row)]} { - # No change, ignore call! - return - } - - set data($column,$row) $value - - if {$value != {}} { - upvar ::struct::matrix::matrix${name}::colw colw - upvar ::struct::matrix::matrix${name}::rowh rowh - catch {unset colw($column)} - catch {unset rowh($row)} - } - return -} - -# ::struct::matrix::__set_column -- -# -# Sets the values in the cells identified by the column index to -# the elements of the list provided as the third argument. Each -# element of the list is assigned to one cell, with the first -# element going into the cell in row 0 and then upward. If there -# are less values in the list than there are rows the remaining -# rows are set to the empty string. If there are more values in -# the list than there are rows the superfluous elements are -# ignored. The matrix is not extended by this operation. -# -# Arguments: -# name Name of the matrix. -# column Index of the column to set. -# values Values to set into the column. -# -# Results: -# None. - -proc ::struct::matrix::__set_column {name column values} { - set column [ChkColumnIndex $name $column] - - upvar ::struct::matrix::matrix${name}::data data - upvar ::struct::matrix::matrix${name}::columns cols - upvar ::struct::matrix::matrix${name}::rows rows - upvar ::struct::matrix::matrix${name}::rowh rh - upvar ::struct::matrix::matrix${name}::colw cw - - if {[set l [llength $values]] < $rows} { - # Missing values. Fill up with empty strings - - for {} {$l < $rows} {incr l} { - lappend values {} - } - } elseif {[llength $values] > $rows} { - # To many values. Remove the superfluous items - set values [lrange $values 0 [expr {$rows - 1}]] - } - - # "values" now contains the information to set into the array. - # Regarding the width and height caches: - - # - Invalidate the column in the width cache. - # - The rows are either removed from the height cache or left - # unchanged, depending on the contents set into the cell. - - set r 0 - foreach v $values { - if {$v != {}} { - # Data changed unpredictably, invalidate cache - catch {unset rh($r)} - } ; # {else leave the row unchanged} - set data($column,$r) $v - incr r - } - catch {unset cw($column)} - return -} - -# ::struct::matrix::__set_rect -- -# -# Takes a list of lists of cell values and writes them into the -# submatrix whose top-left cell is specified by the two -# indices. If the sublists of the outerlist are not of equal -# length the shorter sublists will be filled with empty strings -# to the length of the longest sublist. If the submatrix -# specified by the top-left cell and the number of rows and -# columns in the "values" extends beyond the matrix we are -# modifying the over-extending parts of the values are ignored, -# i.e. essentially cut off. This subcommand expects its input in -# the format as returned by "getrect". -# -# Arguments: -# name Name of the matrix object. -# column Column index of the topleft cell to set. -# row Row index of the topleft cell to set. -# values Values to set. -# -# Results: -# None. - -proc ::struct::matrix::__set_rect {name column row values} { - # Allow negative indices! - set column [ChkColumnIndexNeg $name $column] - set row [ChkRowIndexNeg $name $row] - - upvar ::struct::matrix::matrix${name}::data data - upvar ::struct::matrix::matrix${name}::columns cols - upvar ::struct::matrix::matrix${name}::rows rows - upvar ::struct::matrix::matrix${name}::colw colw - upvar ::struct::matrix::matrix${name}::rowh rowh - - if {$row < 0} { - # Remove rows from the head of values to restrict it to the - # overlapping area. - - set values [lrange $values [expr {0 - $row}] end] - set row 0 - } - - # Restrict it at the end too. - if {($row + [llength $values]) > $rows} { - set values [lrange $values 0 [expr {$rows - $row - 1}]] - } - - # Same for columns, but store it in some vars as this is required - # in a loop. - set firstcol 0 - if {$column < 0} { - set firstcol [expr {0 - $column}] - set column 0 - } - - # Now pan through values and area and copy the external data into - # the matrix. - - set r $row - foreach line $values { - set line [lrange $line $firstcol end] - - set l [expr {$column + [llength $line]}] - if {$l > $cols} { - set line [lrange $line 0 [expr {$cols - $column - 1}]] - } elseif {$l < [expr {$cols - $firstcol}]} { - # We have to take the offset into the line into account - # or we add fillers we don't need, overwriting part of the - # data array we shouldn't. - - for {} {$l < [expr {$cols - $firstcol}]} {incr l} { - lappend line {} - } - } - - set c $column - foreach cell $line { - if {$cell != {}} { - catch {unset rh($r)} - catch {unset cw($c)} - } - set data($c,$r) $cell - incr c - } - incr r - } - return -} - -# ::struct::matrix::__set_row -- -# -# Sets the values in the cells identified by the row index to -# the elements of the list provided as the third argument. Each -# element of the list is assigned to one cell, with the first -# element going into the cell in column 0 and then upward. If -# there are less values in the list than there are columns the -# remaining columns are set to the empty string. If there are -# more values in the list than there are columns the superfluous -# elements are ignored. The matrix is not extended by this -# operation. -# -# Arguments: -# name Name of the matrix. -# row Index of the row to set. -# values Values to set into the row. -# -# Results: -# None. - -proc ::struct::matrix::__set_row {name row values} { - set row [ChkRowIndex $name $row] - - upvar ::struct::matrix::matrix${name}::data data - upvar ::struct::matrix::matrix${name}::columns cols - upvar ::struct::matrix::matrix${name}::rows rows - upvar ::struct::matrix::matrix${name}::colw cw - upvar ::struct::matrix::matrix${name}::rowh rh - - if {[set l [llength $values]] < $cols} { - # Missing values. Fill up with empty strings - - for {} {$l < $cols} {incr l} { - lappend values {} - } - } elseif {[llength $values] > $cols} { - # To many values. Remove the superfluous items - set values [lrange $values 0 [expr {$cols - 1}]] - } - - # "values" now contains the information to set into the array. - # Regarding the width and height caches: - - # - Invalidate the row in the height cache. - # - The columns are either removed from the width cache or left - # unchanged, depending on the contents set into the cell. - - set c 0 - foreach v $values { - if {$v != {}} { - # Data changed unpredictably, invalidate cache - catch {unset cw($c)} - } ; # {else leave the row unchanged} - set data($c,$row) $v - incr c - } - catch {unset rh($row)} - return -} - -# ::struct::matrix::__swap_columns -- -# -# Swaps the contents of the two specified columns. -# -# Arguments: -# name Name of the matrix. -# column_a Index of the first column to swap -# column_b Index of the second column to swap -# -# Results: -# None. - -proc ::struct::matrix::__swap_columns {name column_a column_b} { - set column_a [ChkColumnIndex $name $column_a] - set column_b [ChkColumnIndex $name $column_b] - - upvar ::struct::matrix::matrix${name}::data data - upvar ::struct::matrix::matrix${name}::rows rows - upvar ::struct::matrix::matrix${name}::colw colw - - # Note: This operation does not influence the height cache for all - # rows and the width cache only insofar as its contents has to be - # swapped too for the two columns we are touching. Note that the - # cache might be partially filled or not at all, so we don't have - # to "swap" in some situations. - - for {set r 0} {$r < $rows} {incr r} { - set tmp $data($column_a,$r) - set data($column_a,$r) $data($column_b,$r) - set data($column_b,$r) $tmp - } - - set cwa [info exists colw($column_a)] - set cwb [info exists colw($column_b)] - - if {$cwa && $cwb} { - set tmp $colw($column_a) - set colw($column_a) $colw($column_b) - set colw($column_b) $tmp - } elseif {$cwa} { - # Move contents, don't swap. - set colw($column_b) $colw($column_a) - unset colw($column_a) - } elseif {$cwb} { - # Move contents, don't swap. - set colw($column_a) $colw($column_b) - unset colw($column_b) - } ; # else {nothing to do at all} - return -} - -# ::struct::matrix::__swap_rows -- -# -# Swaps the contents of the two specified rows. -# -# Arguments: -# name Name of the matrix. -# row_a Index of the first row to swap -# row_b Index of the second row to swap -# -# Results: -# None. - -proc ::struct::matrix::__swap_rows {name row_a row_b} { - set row_a [ChkRowIndex $name $row_a] - set row_b [ChkRowIndex $name $row_b] - - upvar ::struct::matrix::matrix${name}::data data - upvar ::struct::matrix::matrix${name}::columns cols - upvar ::struct::matrix::matrix${name}::rowh rowh - - # Note: This operation does not influence the width cache for all - # columns and the height cache only insofar as its contents has to be - # swapped too for the two rows we are touching. Note that the - # cache might be partially filled or not at all, so we don't have - # to "swap" in some situations. - - for {set c 0} {$c < $cols} {incr c} { - set tmp $data($c,$row_a) - set data($c,$row_a) $data($c,$row_b) - set data($c,$row_b) $tmp - } - - set rha [info exists rowh($row_a)] - set rhb [info exists rowh($row_b)] - - if {$rha && $rhb} { - set tmp $rowh($row_a) - set rowh($row_a) $rowh($row_b) - set rowh($row_b) $tmp - } elseif {$rha} { - # Move contents, don't swap. - set rowh($row_b) $rowh($row_a) - unset rowh($row_a) - } elseif {$rhb} { - # Move contents, don't swap. - set rowh($row_a) $rowh($row_b) - unset rowh($row_b) - } ; # else {nothing to do at all} - return -} - -# ::struct::matrix::_unlink -- -# -# Removes the link between the matrix and the specified -# arrayvariable, if there is one. -# -# Arguments: -# name Name of the matrix. -# avar Name of the linked array. -# -# Results: -# None. - -proc ::struct::matrix::_unlink {name avar} { - - upvar ::struct::matrix::matrix${name}::link link - - if {![info exists link($avar)]} { - # Ignore unlinking of unkown variables. - return - } - - # Delete the traces first, then remove the link management - # information from the object. - - upvar #0 $avar array - upvar ::struct::matrix::matrix${name}::data data - - trace vdelete array wu [list ::struct::matrix::MatTraceIn $avar $name] - trace vdelete date w [list ::struct::matrix::MatTraceOut $avar $name] - - unset link($avar) - return -} - -# ::struct::matrix::ChkColumnIndex -- -# -# Helper to check and transform column indices. Returns the -# absolute index number belonging to the specified -# index. Rejects indices out of the valid range of columns. -# -# Arguments: -# matrix Matrix to look at -# column The incoming index to check and transform -# -# Results: -# The absolute index to the column - -proc ::struct::matrix::ChkColumnIndex {name column} { - upvar ::struct::matrix::matrix${name}::columns c - - switch -regex -- $column { - {end-[0-9]+} { - set column [string map {end- ""} $column] - set cc [expr {$c - 1 - $column}] - if {($cc < 0) || ($cc >= $c)} { - return -code error "bad column index end-$column, column does not exist" - } - return $cc - } - end { - if {$c <= 0} { - return -code error "bad column index $column, column does not exist" - } - return [expr {$c - 1}] - } - {[0-9]+} { - if {($column < 0) || ($column >= $c)} { - return -code error "bad column index $column, column does not exist" - } - return $column - } - default { - return -code error "bad column index \"$column\", syntax error" - } - } - # Will not come to this place -} - -# ::struct::matrix::ChkRowIndex -- -# -# Helper to check and transform row indices. Returns the -# absolute index number belonging to the specified -# index. Rejects indices out of the valid range of rows. -# -# Arguments: -# matrix Matrix to look at -# row The incoming index to check and transform -# -# Results: -# The absolute index to the row - -proc ::struct::matrix::ChkRowIndex {name row} { - upvar ::struct::matrix::matrix${name}::rows r - - switch -regex -- $row { - {end-[0-9]+} { - set row [string map {end- ""} $row] - set rr [expr {$r - 1 - $row}] - if {($rr < 0) || ($rr >= $r)} { - return -code error "bad row index end-$row, row does not exist" - } - return $rr - } - end { - if {$r <= 0} { - return -code error "bad row index $row, row does not exist" - } - return [expr {$r - 1}] - } - {[0-9]+} { - if {($row < 0) || ($row >= $r)} { - return -code error "bad row index $row, row does not exist" - } - return $row - } - default { - return -code error "bad row index \"$row\", syntax error" - } - } - # Will not come to this place -} - -# ::struct::matrix::ChkColumnIndexNeg -- -# -# Helper to check and transform column indices. Returns the -# absolute index number belonging to the specified -# index. Rejects indices out of the valid range of columns -# (Accepts negative indices). -# -# Arguments: -# matrix Matrix to look at -# column The incoming index to check and transform -# -# Results: -# The absolute index to the column - -proc ::struct::matrix::ChkColumnIndexNeg {name column} { - upvar ::struct::matrix::matrix${name}::columns c - - switch -regex -- $column { - {end-[0-9]+} { - set column [string map {end- ""} $column] - set cc [expr {$c - 1 - $column}] - if {$cc >= $c} { - return -code error "bad column index end-$column, column does not exist" - } - return $cc - } - end { - return [expr {$c - 1}] - } - {[0-9]+} { - if {$column >= $c} { - return -code error "bad column index $column, column does not exist" - } - return $column - } - default { - return -code error "bad column index \"$column\", syntax error" - } - } - # Will not come to this place -} - -# ::struct::matrix::ChkRowIndexNeg -- -# -# Helper to check and transform row indices. Returns the -# absolute index number belonging to the specified -# index. Rejects indices out of the valid range of rows -# (Accepts negative indices). -# -# Arguments: -# matrix Matrix to look at -# row The incoming index to check and transform -# -# Results: -# The absolute index to the row - -proc ::struct::matrix::ChkRowIndexNeg {name row} { - upvar ::struct::matrix::matrix${name}::rows r - - switch -regex -- $row { - {end-[0-9]+} { - set row [string map {end- ""} $row] - set rr [expr {$r - 1 - $row}] - if {$rr >= $r} { - return -code error "bad row index end-$row, row does not exist" - } - return $rr - } - end { - return [expr {$r - 1}] - } - {[0-9]+} { - if {$row >= $r} { - return -code error "bad row index $row, row does not exist" - } - return $row - } - default { - return -code error "bad row index \"$row\", syntax error" - } - } - # Will not come to this place -} - -# ::struct::matrix::ChkColumnIndexAll -- -# -# Helper to transform column indices. Returns the -# absolute index number belonging to the specified -# index. -# -# Arguments: -# matrix Matrix to look at -# column The incoming index to check and transform -# -# Results: -# The absolute index to the column - -proc ::struct::matrix::ChkColumnIndexAll {name column} { - upvar ::struct::matrix::matrix${name}::columns c - - switch -regex -- $column { - {end-[0-9]+} { - set column [string map {end- ""} $column] - set cc [expr {$c - 1 - $column}] - return $cc - } - end { - return $c - } - {[0-9]+} { - return $column - } - default { - return -code error "bad column index \"$column\", syntax error" - } - } - # Will not come to this place -} - -# ::struct::matrix::ChkRowIndexAll -- -# -# Helper to transform row indices. Returns the -# absolute index number belonging to the specified -# index. -# -# Arguments: -# matrix Matrix to look at -# row The incoming index to check and transform -# -# Results: -# The absolute index to the row - -proc ::struct::matrix::ChkRowIndexAll {name row} { - upvar ::struct::matrix::matrix${name}::rows r - - switch -regex -- $row { - {end-[0-9]+} { - set row [string map {end- ""} $row] - set rr [expr {$r - 1 - $row}] - return $rr - } - end { - return $r - } - {[0-9]+} { - return $row - } - default { - return -code error "bad row index \"$row\", syntax error" - } - } - # Will not come to this place -} - -# ::struct::matrix::MatTraceIn -- -# -# Helper propagating changes made to an array -# into the matrix the array is linked to. -# -# Arguments: -# avar Name of the array which was changed. -# name Matrix to write the changes to. -# var,idx,op Standard trace arguments -# -# Results: -# None. - -proc ::struct::matrix::MatTraceIn {avar name var idx op} { - # Propagate changes in the linked array back into the matrix. - - upvar ::struct::matrix::matrix${name}::lock lock - if {$lock} {return} - - # We have to cover two possibilities when encountering an "unset" operation ... - # 1. The external array was destroyed: perform automatic unlink. - # 2. An individual element was unset: Set the corresponding cell to the empty string. - # See SF Tcllib Bug #532791. - - if {(![string compare $op u]) && ($idx == {})} { - # Possibility 1: Array was destroyed - $name unlink $avar - return - } - - upvar #0 $avar array - upvar ::struct::matrix::matrix${name}::data data - upvar ::struct::matrix::matrix${name}::link link - - set transpose $link($avar) - if {$transpose} { - foreach {r c} [split $idx ,] break - } else { - foreach {c r} [split $idx ,] break - } - - # Use standard method to propagate the change. - # => Get automatically index checks, cache updates, ... - - if {![string compare $op u]} { - # Unset possibility 2: Element was unset. - # Note: Setting the cell to the empty string will - # invoke MatTraceOut for this array and thus try - # to recreate the destroyed element of the array. - # We don't want this. But we do want to propagate - # the change to other arrays, as "unset". To do - # all of this we use another state variable to - # signal this situation. - - upvar ::struct::matrix::matrix${name}::unset unset - set unset $avar - - $name set cell $c $r "" - - set unset {} - return - } - - $name set cell $c $r $array($idx) - return -} - -# ::struct::matrix::MatTraceOut -- -# -# Helper propagating changes made to the matrix into the linked arrays. -# -# Arguments: -# avar Name of the array to write the changes to. -# name Matrix which was changed. -# var,idx,op Standard trace arguments -# -# Results: -# None. - -proc ::struct::matrix::MatTraceOut {avar name var idx op} { - # Propagate changes in the matrix data array into the linked array. - - upvar ::struct::matrix::matrix${name}::unset unset - - if {![string compare $avar $unset]} { - # Do not change the variable currently unsetting - # one of its elements. - return - } - - upvar ::struct::matrix::matrix${name}::lock lock - set lock 1 ; # Disable MatTraceIn [#532783] - - upvar #0 $avar array - upvar ::struct::matrix::matrix${name}::data data - upvar ::struct::matrix::matrix${name}::link link - - set transpose $link($avar) - - if {$transpose} { - foreach {r c} [split $idx ,] break - } else { - foreach {c r} [split $idx ,] break - } - - if {$unset != {}} { - # We are currently propagating the unset of an - # element in a different linked array to this - # array. We make sure that this is an unset too. - - unset array($c,$r) - } else { - set array($c,$r) $data($idx) - } - set lock 0 - return -} - - - DELETED modules/struct/matrix.test Index: modules/struct/matrix.test ================================================================== --- modules/struct/matrix.test +++ /dev/null @@ -1,1767 +0,0 @@ -# -*- tcl -*- -# matrix.test: tests for the matrix structure. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 2001 by Andreas Kupries -# All rights reserved. -# -# RCS: @(#) $Id: matrix.test,v 1.7 2002/04/01 19:54:49 andreas_kupries Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -source [file join [file dirname [info script]] matrix.tcl] -namespace import struct::matrix::matrix - -# Simple "report object" to test the format methods. - -proc tclformat {cmd matrix {chan stdout}} { - switch -exact -- $cmd { - printmatrix { - set r [$matrix rows] - set c [$matrix rows] - set out [list "# $matrix $c x $r"] - lappend out "matrix $matrix" - lappend out "$matrix add rows $r" - lappend out "$matrix add columns $c" - lappend out "$matrix set rect 0 0 [list [$matrix get rect 0 0 end end]]" - return [join $out \n] - } - printmatrix2channel { - set r [$matrix rows] - set c [$matrix rows] - puts $chan "# $matrix $c x $r" - puts $chan "matrix $matrix" - puts $chan "$matrix add rows $r" - puts $chan "$matrix add columns $c" - puts $chan "$matrix set rect 0 0 [list [$matrix get rect 0 0 end end]]" - return "" - } - default { - return -code error "Unknown method $cmd" - } - } -} - -# Retrieve the contents of an array as a list, with sorted keys, to -# test the linking between matrices and array variables. - -proc aget {avar} { - upvar 1 $avar a - set out [list] - foreach key [lsort [array names a]] { - lappend out $key $a($key) - } - return $out -} - - - -test matrix-0.1 {matrix errors} { - matrix mymatrix - catch {matrix mymatrix} msg - mymatrix destroy - set msg -} "command \"mymatrix\" already exists, unable to create matrix" - -test matrix-0.2 {matrix errors} { - matrix mymatrix - catch {mymatrix} msg - mymatrix destroy - set msg -} "wrong # args: should be \"mymatrix option ?arg arg ...?\"" - -test matrix-0.3 {matrix errors} { - matrix mymatrix - catch {mymatrix foo} msg - mymatrix destroy - set msg -} "bad option \"foo\": must be add, cells, cellsize, columns, columnwidth, delete, destroy, format, get, insert, link, rowheight, rows, search, set, swap, or unlink" - -test matrix-0.4 {matrix errors} { - matrix mymatrix - catch {mymatrix add foo} msg - mymatrix destroy - set msg -} "bad option \"foo\": must be column, columns, row, or rows" - -test matrix-0.5 {matrix errors} { - matrix mymatrix - catch {mymatrix delete foo} msg - mymatrix destroy - set msg -} "bad option \"foo\": must be column, or row" - -test matrix-0.6 {matrix errors} { - matrix mymatrix - catch {mymatrix get foo} msg - mymatrix destroy - set msg -} "bad option \"foo\": must be cell, column, rect, or row" - -test matrix-0.7 {matrix errors} { - matrix mymatrix - catch {mymatrix set foo} msg - mymatrix destroy - set msg -} "bad option \"foo\": must be cell, column, rect, or row" - -test matrix-0.8 {matrix errors} { - matrix mymatrix - catch {mymatrix format foo} msg - mymatrix destroy - set msg -} "bad option \"foo\": must be 2chan, or 2string" - -test matrix-0.9 {matrix errors} { - matrix mymatrix - catch {mymatrix swap foo} msg - mymatrix destroy - set msg -} "bad option \"foo\": must be columns, or rows" - -test matrix-0.10 {matrix errors} { - catch {matrix set} msg - set msg -} "command \"set\" already exists, unable to create matrix" - -test matrix-0.11 {matrix errors} { - matrix mymatrix - catch {mymatrix set cell 0 0 foo} msg - mymatrix destroy - set msg -} {bad column index 0, column does not exist} - -test matrix-0.12 {matrix errors} { - matrix mymatrix - mymatrix add column - catch {mymatrix set cell 0 0 foo} msg - mymatrix destroy - set msg -} {bad row index 0, row does not exist} - -test matrix-0.13 {matrix errors} { - matrix mymatrix - catch {mymatrix insert foo} msg - mymatrix destroy - set msg -} "bad option \"foo\": must be column, or row" - -test matrix-1.0 {create} { - set name [matrix] - set result [list $name [string equal [info commands ::$name] "::$name"]] - $name destroy - set result -} [list matrix1 1] - - -test matrix-1.1 {columns, rows & cells} { - matrix mymatrix - set result [list [mymatrix rows] [mymatrix columns] [mymatrix cells]] - mymatrix destroy - set result -} {0 0 0} - -test matrix-1.2 {columns, rows & cells} { - matrix mymatrix - mymatrix add column - set result [list [mymatrix rows] [mymatrix columns] [mymatrix cells]] - mymatrix destroy - set result -} {0 1 0} - -test matrix-1.3 {columns, rows & cells} { - matrix mymatrix - mymatrix add row - set result [list [mymatrix rows] [mymatrix columns] [mymatrix cells]] - mymatrix destroy - set result -} {1 0 0} - -test matrix-1.4 {columns, rows & cells} { - matrix mymatrix - mymatrix add column - mymatrix add row - set result [list [mymatrix rows] [mymatrix columns] [mymatrix cells]] - mymatrix destroy - set result -} {1 1 1} - -test matrix-1.5 {columns, rows & cells} { - matrix mymatrix - mymatrix add column - mymatrix add row - mymatrix add column - mymatrix add row - set result [list [mymatrix rows] [mymatrix columns] [mymatrix cells]] - mymatrix destroy - set result -} {2 2 4} - -test matrix-2.0 {add error} { - matrix mymatrix - catch {mymatrix add} msg - mymatrix destroy - set msg -} {wrong # args: should be "mymatrix add option ?arg arg ...?"} - -test matrix-2.1 {add column, add row} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{1 2} {3 4}} - -test matrix-2.2 {add column, add row} { - matrix mymatrix - mymatrix add column - mymatrix add row - mymatrix add column - mymatrix add row - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{{} {}} {{} {}}} - -test matrix-2.3 {add columns, add rows} { - matrix mymatrix - mymatrix add columns 4 - mymatrix add rows 4 - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{{} {} {} {}} {{} {} {} {}} {{} {} {} {}} {{} {} {} {}}} - -test matrix-2.4 {add columns, add rows} { - matrix mymatrix - mymatrix add rows 4 - mymatrix add columns 4 - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{{} {} {} {}} {{} {} {} {}} {{} {} {} {}} {{} {} {} {}}} - -test matrix-2.5 {add columns, add rows} { - matrix mymatrix - catch {mymatrix add columns 0} result - mymatrix destroy - set result -} {A value of n <= 0 is not allowed} - -test matrix-2.6 {add columns, add rows} { - matrix mymatrix - catch {mymatrix add rows 0} result - mymatrix destroy - set result -} {A value of n <= 0 is not allowed} - -test matrix-2.7 {add column, add row, cut off} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2 5 6 7} - mymatrix add row {3 4 8 9 10} - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{1 2} {3 4}} - - - -test matrix-3.1 {sizes, widths, heights} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {23} - mymatrix add row [list "4\n5" 6] - set result [list [mymatrix cellsize 0 0] [mymatrix columnwidth 1] [mymatrix rowheight 1]] - mymatrix destroy - set result -} {1 2 2} - -test matrix-3.2 {sizes, widths, heights} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {23} - mymatrix add row [list "4\n5" 6] - catch {mymatrix cellsize -1 -1} result - mymatrix destroy - set result -} {bad column index -1, column does not exist} - -test matrix-3.3 {sizes, widths, heights} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {23} - mymatrix add row [list "4\n5" 6] - catch {mymatrix cellsize 5 -1} result - mymatrix destroy - set result -} {bad column index 5, column does not exist} - -test matrix-3.4 {sizes, widths, heights} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {23} - mymatrix add row [list "4\n5" 6] - catch {mymatrix cellsize 0 -1} result - mymatrix destroy - set result -} {bad row index -1, row does not exist} - -test matrix-3.5 {sizes, widths, heights} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {23} - mymatrix add row [list "4\n5" 6] - catch {mymatrix cellsize 0 5} result - mymatrix destroy - set result -} {bad row index 5, row does not exist} - -test matrix-3.6 {sizes, widths, heights} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {23} - mymatrix add row [list "4\n5" 6] - catch {mymatrix rowheight -1} result - mymatrix destroy - set result -} {bad row index -1, row does not exist} - -test matrix-3.7 {sizes, widths, heights} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {23} - mymatrix add row [list "4\n5" 6] - catch {mymatrix rowheight 5} result - mymatrix destroy - set result -} {bad row index 5, row does not exist} - -test matrix-3.8 {sizes, widths, heights} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {23} - mymatrix add row [list "4\n5" 6] - catch {mymatrix columnwidth -1} result - mymatrix destroy - set result -} {bad column index -1, column does not exist} - -test matrix-3.9 {sizes, widths, heights} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {23} - mymatrix add row [list "4\n5" 6] - catch {mymatrix columnwidth 5} result - mymatrix destroy - set result -} {bad column index 5, column does not exist} - -test matrix-4.0 {delete error} { - matrix mymatrix - catch {mymatrix delete} msg - mymatrix destroy - set msg -} {wrong # args: should be "mymatrix delete option ?arg arg ...?"} - -test matrix-4.1 {deletion of rows and columns} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2a} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row [list 7 8 "9\na"] - - set resa [list [mymatrix columnwidth 0]] - lappend resa [mymatrix columnwidth 1] - lappend resa [mymatrix columnwidth 2] - - set result [list [mymatrix get rect 0 0 end end]] - mymatrix delete column 1 - lappend result [mymatrix get rect 0 0 end end] - mymatrix delete row 1 - lappend result [mymatrix get rect 0 0 end end] - - lappend resa [mymatrix columnwidth 0] - lappend resa [mymatrix columnwidth 1] - - mymatrix destroy - lappend result $resa - set result -} {{{1 2a 5} {3 4 6} {7 8 {9 -a}}} {{1 5} {3 6} {7 {9 -a}}} {{1 5} {7 {9 -a}}} {1 2 1 1 1}} - -test matrix-4.1a {deletion of rows and columns} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2a} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row [list 7 8 "9\na"] - - set resb [list [mymatrix rowheight 0]] - lappend resb [mymatrix rowheight 1] - lappend resb [mymatrix rowheight 2] - - set result [list [mymatrix get rect 0 0 end end]] - mymatrix delete row 1 - mymatrix delete column 1 - lappend result [mymatrix get rect 0 0 end end] - - lappend resb [mymatrix rowheight 0] - lappend resb [mymatrix rowheight 1] - - mymatrix destroy - lappend result $resb - set result -} {{{1 2a 5} {3 4 6} {7 8 {9 -a}}} {{1 5} {7 {9 -a}}} {1 1 2 1 2}} - -test matrix-4.2 {deletion of rows and columns} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - set result [list [mymatrix get rect 0 0 end end]] - mymatrix delete column 0 - lappend result [mymatrix get rect 0 0 end end] - mymatrix delete row 0 - lappend result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{{1 2 5} {3 4 6} {7 8 9}} {{2 5} {4 6} {8 9}} {{4 6} {8 9}}} - -test matrix-4.3 {deletion of rows and columns} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - set result [list [mymatrix get rect 0 0 end end]] - mymatrix delete column end - lappend result [mymatrix get rect 0 0 end end] - mymatrix delete row end - lappend result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{{1 2 5} {3 4 6} {7 8 9}} {{1 2} {3 4} {7 8}} {{1 2} {3 4}}} - -test matrix-4.4 {deletion of rows and columns} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix delete column -1} result - mymatrix destroy - set result -} {bad column index -1, column does not exist} - -test matrix-4.5 {deletion of rows and columns} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix delete column 5} result - mymatrix destroy - set result -} {bad column index 5, column does not exist} - -test matrix-4.6 {deletion of rows and columns} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix delete row -1} result - mymatrix destroy - set result -} {bad row index -1, row does not exist} - -test matrix-4.7 {deletion of rows and columns} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix delete row 5} result - mymatrix destroy - set result -} {bad row index 5, row does not exist} - -test matrix-5.0 {format error} { - matrix mymatrix - catch {mymatrix format} msg - mymatrix destroy - set msg -} {wrong # args: should be "mymatrix format option ?arg arg ...?"} - -test matrix-5.1 {formatting} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - set result [mymatrix format 2string tclformat] - mymatrix destroy - set result -} "# mymatrix 3 x 3 -matrix mymatrix -mymatrix add rows 3 -mymatrix add columns 3 -mymatrix set rect 0 0 {{1 2 5} {3 4 6} {7 8 9}}" - -test matrix-5.2 {internal format} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - set result [mymatrix format 2string] - mymatrix destroy - set result -} "1 2 5\n3 4 6\n7 8 9" - -test matrix-5.3 {internal format} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3a 4} - mymatrix add column {5 6} - mymatrix add row [list 7 8 "9\nb"] - set result [mymatrix format 2string] - mymatrix destroy - set result -} "1 2 5\n3a 4 6\n7 8 9\n b" - -if {![catch {package require memchan}]} { - # We have memory channels and can therefore test - # 'format2channel-via' too. - - test matrix-5.4 {formatting} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - - set chan [memchan] - mymatrix format 2chan tclformat $chan - mymatrix destroy - - seek $chan 0 - set result [read $chan] - close $chan - set result - } "# mymatrix 3 x 3 -matrix mymatrix -mymatrix add rows 3 -mymatrix add columns 3 -mymatrix set rect 0 0 {{1 2 5} {3 4 6} {7 8 9}}" -} - -test matrix-6.0 {set/get error} { - matrix mymatrix - catch {mymatrix set} msga - catch {mymatrix get} msgb - mymatrix destroy - list $msga $msgb -} {{wrong # args: should be "mymatrix set option ?arg arg ...?"} {wrong # args: should be "mymatrix get option ?arg arg ...?"}} - -test matrix-6.1 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - set result [mymatrix get cell 0 2] - mymatrix destroy - set result -} 7 - -test matrix-6.2 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - set result [mymatrix get column 1] - mymatrix destroy - set result -} {2 4 8} - -test matrix-6.3 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - set result [mymatrix get row 2] - mymatrix destroy - set result -} {7 8 9} - -test matrix-6.4 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - set result [mymatrix get rect 1 1 end end] - mymatrix destroy - set result -} {{4 6} {8 9}} - -test matrix-6.5 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - mymatrix set cell 0 2 foo - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{1 2 5} {3 4 6} {foo 8 9}} - -test matrix-6.6 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - mymatrix set column 1 {a b c} - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{1 a 5} {3 b 6} {7 c 9}} - -test matrix-6.7 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - mymatrix set row 2 {bar buz nex} - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{1 2 5} {3 4 6} {bar buz nex}} - -test matrix-6.8 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - mymatrix set rect 1 1 {{c d} {e f}} - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{1 2 5} {3 c d} {7 e f}} - -test matrix-6.9 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - mymatrix set column 1 {a b} - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{1 a 5} {3 b 6} {7 {} 9}} - -test matrix-6.10 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - mymatrix set column 1 {a b c d e f} - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{1 a 5} {3 b 6} {7 c 9}} - -test matrix-6.11 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - mymatrix set row 2 {bar buz} - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{1 2 5} {3 4 6} {bar buz {}}} - -test matrix-6.12 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - mymatrix set row 2 {bar buz nex floz} - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{1 2 5} {3 4 6} {bar buz nex}} - -test matrix-6.13 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - mymatrix set rect 1 1 {{c d e} {f g h} {i j k}} - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{1 2 5} {3 c d} {7 f g}} - -test matrix-6.14 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - mymatrix set rect -1 -1 {{c d e} {f g h} {i j k}} - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{g h 5} {j k 6} {7 8 9}} - -test matrix-6.15 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix get cell -1 2} result - mymatrix destroy - set result -} {bad column index -1, column does not exist} - -test matrix-6.16 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix get cell 5 2} result - mymatrix destroy - set result -} {bad column index 5, column does not exist} - -test matrix-6.17 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix get cell 0 -1} result - mymatrix destroy - set result -} {bad row index -1, row does not exist} - -test matrix-6.18 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix get cell 0 5} result - mymatrix destroy - set result -} {bad row index 5, row does not exist} - -test matrix-6.19 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix get column -1} result - mymatrix destroy - set result -} {bad column index -1, column does not exist} - -test matrix-6.20 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix get column 5} result - mymatrix destroy - set result -} {bad column index 5, column does not exist} - -test matrix-6.21 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix get row -1} result - mymatrix destroy - set result -} {bad row index -1, row does not exist} - -test matrix-6.22 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix get row 5} result - mymatrix destroy - set result -} {bad row index 5, row does not exist} - -test matrix-6.23 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix get rect -1 1 end end} result - mymatrix destroy - set result -} {bad column index -1, column does not exist} - -test matrix-6.24 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix get rect 5 1 end end} result - mymatrix destroy - set result -} {bad column index 5, column does not exist} - -test matrix-6.25 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix get rect 1 1 -1 end} result - mymatrix destroy - set result -} {bad column index -1, column does not exist} - -test matrix-6.26 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix get rect 1 1 5 end} result - mymatrix destroy - set result -} {bad column index 5, column does not exist} - -test matrix-6.27 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix get rect 1 -1 end end} result - mymatrix destroy - set result -} {bad row index -1, row does not exist} - -test matrix-6.28 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix get rect 1 5 end end} result - mymatrix destroy - set result -} {bad row index 5, row does not exist} - -test matrix-6.29 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix get rect 1 1 end -1} result - mymatrix destroy - set result -} {bad row index -1, row does not exist} - -test matrix-6.30 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix get rect 1 1 end 5} result - mymatrix destroy - set result -} {bad row index 5, row does not exist} - -test matrix-6.31 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix set column -1 {a b c}} result - mymatrix destroy - set result -} {bad column index -1, column does not exist} - -test matrix-6.32 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix set column 5 {a b c}} result - mymatrix destroy - set result -} {bad column index 5, column does not exist} - -test matrix-6.33 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix set row -1 {a b c}} result - mymatrix destroy - set result -} {bad row index -1, row does not exist} - -test matrix-6.34 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix set row 5 {a b c}} result - mymatrix destroy - set result -} {bad row index 5, row does not exist} - -test matrix-6.35 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix set rect 5 1 {{a b} {c d}}} result - mymatrix destroy - set result -} {bad column index 5, column does not exist} - -test matrix-6.36 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix set rect 1 5 {{a b} {c d}}} result - mymatrix destroy - set result -} {bad row index 5, row does not exist} - - -test matrix-6.43 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix get rect end end 1 1} result - mymatrix destroy - set result -} {Invalid cell indices, wrong ordering} - -test matrix-6.44 {set and get in all forms} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix set cell 0 0 foo - set result [list [mymatrix get rect 0 0 end end]] - mymatrix set cell 0 0 foo - lappend result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {foo foo} - - - - -test matrix-7.0 {swap error} { - matrix mymatrix - catch {mymatrix swap} msg - mymatrix destroy - set msg -} {wrong # args: should be "mymatrix swap option ?arg arg ...?"} - -test matrix-7.1 {swapping} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - mymatrix swap columns 1 end - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{1 5 2} {3 6 4} {7 9 8}} - -test matrix-7.2 {swapping} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - mymatrix swap rows 1 end - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{1 2 5} {7 8 9} {3 4 6}} - -test matrix-7.3 {swapping} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix swap columns -1 end} result - mymatrix destroy - set result -} {bad column index -1, column does not exist} - -test matrix-7.4 {swapping} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix swap columns 5 end} result - mymatrix destroy - set result -} {bad column index 5, column does not exist} - -test matrix-7.5 {swapping} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix swap columns 1 -1} result - mymatrix destroy - set result -} {bad column index -1, column does not exist} - -test matrix-7.6 {swapping} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix swap columns 1 5} result - mymatrix destroy - set result -} {bad column index 5, column does not exist} - -test matrix-7.7 {swapping} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix swap rows -1 end} result - mymatrix destroy - set result -} {bad row index -1, row does not exist} - -test matrix-7.8 {swapping} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix swap rows 5 end} result - mymatrix destroy - set result -} {bad row index 5, row does not exist} - -test matrix-7.9 {swapping} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix swap rows 1 -1} result - mymatrix destroy - set result -} {bad row index -1, row does not exist} - -test matrix-7.10 {swapping} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - catch {mymatrix swap rows 1 5} result - mymatrix destroy - set result -} {bad row index 5, row does not exist} - -test matrix-8.0 {insert error} { - matrix mymatrix - catch {mymatrix insert} msg - mymatrix destroy - set msg -} {wrong # args: should be "mymatrix insert option ?arg arg ...?"} - -test matrix-8.1 {insertion} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - - mymatrix insert column 0 {a b c} - - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{a 1 2 5} {b 3 4 6} {c 7 8 9}} - -test matrix-8.2 {insertion} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - - mymatrix insert column 1 {a b c} - - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{1 a 2 5} {3 b 4 6} {7 c 8 9}} - -test matrix-8.3 {insertion} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - - mymatrix insert column end {a b c} - - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{1 2 5 a} {3 4 6 b} {7 8 9 c}} - -test matrix-8.4 {insertion} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - - mymatrix insert column 3 {a b c} - - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{1 2 5 a} {3 4 6 b} {7 8 9 c}} - -test matrix-8.5 {insertion} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - - mymatrix insert column -1 {a b c} - - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{a 1 2 5} {b 3 4 6} {c 7 8 9}} - - -test matrix-8.6 {insertion} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - - mymatrix insert row 0 {a b c} - - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{a b c} {1 2 5} {3 4 6} {7 8 9}} - -test matrix-8.7 {insertion} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - - mymatrix insert row 1 {a b c} - - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{1 2 5} {a b c} {3 4 6} {7 8 9}} - -test matrix-8.8 {insertion} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - - mymatrix insert row end {a b c} - - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{1 2 5} {3 4 6} {7 8 9} {a b c}} - -test matrix-8.9 {insertion} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - - mymatrix insert row 3 {a b c} - - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{1 2 5} {3 4 6} {7 8 9} {a b c}} - -test matrix-8.10 {insertion} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - - mymatrix insert row -1 {a b c} - - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{a b c} {1 2 5} {3 4 6} {7 8 9}} - -test matrix-8.11 {insertion} { - matrix mymatrix - mymatrix add column - mymatrix insert row 1 {1} - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {1} - -test matrix-8.12 {insertion} { - matrix mymatrix - mymatrix add row - mymatrix insert column 1 {1} - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {1} - -test matrix-9.0 {link errors} { - matrix mymatrix - catch {mymatrix link} msg - mymatrix destroy - set msg -} {mymatrix: wrong # args: link ?-transpose? arrayvariable} - -test matrix-9.1 {link errors} { - matrix mymatrix - catch {mymatrix link 1 2 3} msg - mymatrix destroy - set msg -} {mymatrix: wrong # args: link ?-transpose? arrayvariable} - -test matrix-9.2 {link errors} { - matrix mymatrix - catch {mymatrix link foo 2} msg - mymatrix destroy - set msg -} {mymatrix: illegal syntax: link ?-transpose? arrayvariable} - -test matrix-9.3 {link errors} { - matrix mymatrix - mymatrix link foo - catch {mymatrix link foo} msg - mymatrix destroy - set msg -} {mymatrix link: Variable "foo" already linked to matrix} - -test matrix-9.4 {linking, initial transfer} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - mymatrix link a - set result [aget a] - mymatrix destroy - set result -} {0,0 1 0,1 3 0,2 7 1,0 2 1,1 4 1,2 8 2,0 5 2,1 6 2,2 9} - -test matrix-9.5 {linking, initial transfer} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - mymatrix link -transpose a - set result [aget a] - mymatrix destroy - set result -} {0,0 1 0,1 2 0,2 5 1,0 3 1,1 4 1,2 6 2,0 7 2,1 8 2,2 9} - - -test matrix-9.6 {linking, trace array -> matrix} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - mymatrix link a - set a(1,0) foo - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{1 foo 5} {3 4 6} {7 8 9}} - -test matrix-9.7 {linking, trace array -> matrix} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - mymatrix link -transpose a - set a(1,0) foo - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{1 2 5} {foo 4 6} {7 8 9}} - -test matrix-9.8 {linking, trace and unlink} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - mymatrix link a - set a(1,0) foo - set result [list [mymatrix get rect 0 0 end end]] - mymatrix unlink a - set a(1,0) 2 - lappend result [aget a] - mymatrix destroy - set result -} {{{1 foo 5} {3 4 6} {7 8 9}} {0,0 1 0,1 3 0,2 7 1,0 2 1,1 4 1,2 8 2,0 5 2,1 6 2,2 9}} - -test matrix-9.9 {linking} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - mymatrix link a - catch {set a(1,5) foo} result - mymatrix destroy - set result -} {can't set "a(1,5)": bad row index 5, row does not exist} - -test matrix-9.10 {unlink unknown} { - matrix mymatrix - set result [list [mymatrix links]] - mymatrix unlink foo - lappend result [mymatrix links] - mymatrix destroy - set result -} {{} {}} - -test matrix-9.11 {auto unlink} { - matrix mymatrix - mymatrix add column - mymatrix add row {1} - mymatrix add column {2} - mymatrix add row {3 4} - mymatrix add column {5 6} - mymatrix add row {7 8 9} - mymatrix link a - set result [list [mymatrix links]] - unset a - lappend result [mymatrix links] - mymatrix destroy - set result -} {a {}} - -test matrix-9.12 {unset in linked array} { - matrix mymatrix - mymatrix add columns 3 - mymatrix add row {1 2 3} - mymatrix add row {a b c} - - catch {unset a} - mymatrix link a - - set result [list] - lappend result [aget a] - unset a(0,0) - lappend result [mymatrix get rect 0 0 end end] - - mymatrix destroy - set result -} {{0,0 1 0,1 a 1,0 2 1,1 b 2,0 3 2,1 c} {{{} 2 3} {a b c}}} - -test matrix-9.12a {unset in linked array} { - matrix mymatrix - mymatrix add columns 3 - mymatrix add row {1 2 3} - mymatrix add row {a b c} - - catch {unset a} - mymatrix link a - catch {unset b} - mymatrix link b - - set result [list] - lappend result [aget a] - unset a(0,0) - lappend result [aget b] - - mymatrix destroy - set result -} {{0,0 1 0,1 a 1,0 2 1,1 b 2,0 3 2,1 c} {0,1 a 1,0 2 1,1 b 2,0 3 2,1 c}} - -test matrix-9.13 {operation on linked matrix} { - catch {unset a} - matrix mymatrix - mymatrix add columns 4 - mymatrix add row {1 2 3} - mymatrix link a - mymatrix add row {a b c d} - set result [mymatrix get rect 0 0 end end] - mymatrix destroy - set result -} {{1 2 3 {}} {a b c d}} - -test 10.1 {search errors} { - matrix mymatrix - catch {mymatrix search} msg - mymatrix destroy - set msg -} {wrong # args: should be "mymatrix search ?option...? (all|row row|column col|rect c r c r) pattern"} - -test 10.2 {search errors} { - matrix mymatrix - catch {mymatrix search 1} msg - mymatrix destroy - set msg -} {wrong # args: should be "mymatrix search ?option...? (all|row row|column col|rect c r c r) pattern"} - -test 10.3 {search errors} { - matrix mymatrix - catch {mymatrix search 1 2 3 4 5} msg - mymatrix destroy - set msg -} {wrong # args: should be "mymatrix search ?option...? (all|row row|column col|rect c r c r) pattern"} - -test 10.4 {search errors} { - matrix mymatrix - catch {mymatrix search 1 2 3 4 5 6 7 8} msg - mymatrix destroy - set msg -} {wrong # args: should be "mymatrix search ?option...? (all|row row|column col|rect c r c r) pattern"} - -test 10.5 {search errors} { - matrix mymatrix - catch {mymatrix search -foo 2 3 4} msg - mymatrix destroy - set msg -} {invalid option "-foo": should be -nocase, -exact, -glob, or -regexp} - -test 10.6 {search errors} { - matrix mymatrix - catch {mymatrix search -exact foo 3 4} msg - mymatrix destroy - set msg -} {invalid range spec "foo": should be all, column, row, or rect} - -test 10.7 {search errors} { - matrix mymatrix - mymatrix add columns 5 - mymatrix add row {1 2 3 4 5} - mymatrix add row {6 7 8 9 0} - mymatrix add row {a b c d e} - mymatrix add row {ab ba f g h} - mymatrix add row {cd 4d x y z} - catch {mymatrix search -exact rect 4 0 2 1 foo} msg - mymatrix destroy - set msg -} {Invalid cell indices, wrong ordering} - -test 10.8 {search errors} { - matrix mymatrix - mymatrix add columns 5 - mymatrix add row {1 2 3 4 5} - mymatrix add row {6 7 8 9 0} - mymatrix add row {a b c d e} - mymatrix add row {ab ba f g h} - mymatrix add row {cd 4d x y z} - catch {mymatrix search -exact rect 2 1 4 0 foo} msg - mymatrix destroy - set msg -} {Invalid cell indices, wrong ordering} - - -test matrix-10.9 "searching, default" { - matrix mymatrix - mymatrix add columns 5 - mymatrix add row {1 2 3 4 5} - mymatrix add row {6 7 8 9 0} - mymatrix add row {a b c d e} - mymatrix add row {ab ba f g h} - mymatrix add row {cd 4d x y z} - set result [mymatrix search row 2 b] - mymatrix destroy - set result -} {{1 2}} - -foreach {n mode range pattern result} { - 10 -exact {all} {ab} {{0 3}} - 11 -glob {all} {a*} {{0 2} {0 3}} - 12 -regexp {all} {b.} {{1 3}} - 13 -exact {row 2} {b} {{1 2}} - 14 -glob {row 3} {b*} {{1 3}} - 15 -regexp {row 4} {d} {{0 4} {1 4}} - 16 -exact {column 2} {c} {{2 2}} - 17 -glob {column 0} {a*} {{0 2} {0 3}} - 18 -regexp {column 1} {b.*} {{1 2} {1 3}} - 19 -exact {rect 1 1 3 3} {c} {{2 2}} - 20 -glob {rect 1 1 3 3} {b*} {{1 2} {1 3}} - 21 -regexp {rect 1 1 3 3} {b.*} {{1 2} {1 3}} -} { - test matrix-10.$n "searching ($mode $range $pattern)" { - matrix mymatrix - mymatrix add columns 5 - mymatrix add row {1 2 3 4 5} - mymatrix add row {6 7 8 9 0} - mymatrix add row {a b c d e} - mymatrix add row {ab ba f g h} - mymatrix add row {cd 4d x y z} - set result [eval mymatrix search $mode $range $pattern] - mymatrix destroy - set result - } $result ; # {} -} - - -# Future tests: query rowheight, column width before and after delete -# row/column to ascertain that the cached values are correctly -# shifted. - -# Test 'format 2chan', have to redirect a channel for this. - -# Future: Tests involving cached information (row heights, col widths) -# should use special commands to peek at the cache only, without -# recalculation. - -# Document 'links' method. - -::tcltest::cleanupTests - DELETED modules/struct/pkgIndex.tcl Index: modules/struct/pkgIndex.tcl ================================================================== --- modules/struct/pkgIndex.tcl +++ /dev/null @@ -1,12 +0,0 @@ -# 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. - -if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded struct 1.3 [list source [file join $dir struct.tcl]] DELETED modules/struct/pool.html Index: modules/struct/pool.html ================================================================== --- modules/struct/pool.html +++ /dev/null @@ -1,1151 +0,0 @@ - - - - - - - - - - - - - - - - - - -
- -

 

- -

POOL 0.1

- -

 

- -

Author: Erik -Leunissen

- -

 

- -

 

- -

NAME

- -

 

- -

pool -– Managing a pool of discrete items.

- -

 

- -

 

- -

SYNOPSIS

- -

 

- -

              pool -?poolName? ?maxsize?

- -

 

- -

 

- -

DESCRIPTION

- -

 

- -

The -pool command creates a new instance of a pool data structure. The command -takes the name of the new pool as its first argument. If no name is supplied, -then the new pool will be named pool<X>, where X is a positive integer. -The optional second argument maxsize is a positive integer indicating -the maximum size of the pool; this is the maximum number of items the pool may -hold.

- -

 

- -

 

- -

POOLS AND ALLOCATION

- -

 

- -

The -purpose of the pool command and the pool object command that it -generates, is to manage pools of discrete items.

- -

 

- -

Examples -of a pool of discrete items are:

- -

-        -the seats in a cinema, theatre, -train etc.. for which visitors/travellers can  -make a reservation;

- -

-        -the dynamic IP-addresses that an ISP -can dole out  to subscribers;

- -

-        -a car rental's collection of cars, -which can be rented by customers;

- -

-        -the class rooms in a school -building, which need to be scheduled;

- -

-        -the database connections available -to client-threads in a web-server application;

- -

-        -the books in a library that -customers can borrow;

- -

etc ...

- -

 

- -

The -common denominator in the examples is that there is a more or less fixed number -of items (seats, IP-addresses, cars, ...) that are supposed to be allocated on -a more or less regular basis. An item can be allocated only once at a time. An -item that is allocated, must be released before it can be re-allocated. While -several items in a pool are being allocated and released continuously, the -total number of items in the pool remains constant.

- -

 

- -

Keeping -track of which items are allocated, and by whom, is the purpose of the pool -command and its subordinates.

- -

 

- -

Pool parlance

- -

If -we say that an item is allocated, it means that the item is busy, owned -or occupied; it is not available anymore. If an item is free, it is -available. Deallocating an item is equivalent to setting free or releasing -an item. The person or entity to which the item has been allotted is said to own -the item.

- -

 

- -

 

- -

ITEMS

- -

 

- -

Discrete items

- -

The -pool command is designed for discrete items only. Note that there -are pools where allocation occurs on a non-discrete basis, for example computer -memory. There are also pools from which the shares that are doled out are not -expected to be returned, for example a charity fund or a pan of soup from which -you may receive a portion. Finally, there are even pools from which nothing is -ever allocated or returned, like a swimming pool or a cesspool.

- -

 

- -

Unique item names

- -

A pool cannot manage duplicate item names. Therefore, items in a pool -must have unique names.

- -

 

- -

Item equivalence

- -

From -the point of view of the manager of a pool, items are equivalent. The manager -of a pool is indifferent about which entity/person occupies a given item. -However, clients may have preferences for a particular item, based on some item -property they know.

- -

 

- -

Preferences

- -

A -future owner may have a preference for a particular item. Preference based -allocation is supported (see the –prefer option to the request -subcommand). A preference for a particular item is most likely to result from -variability among features associated with the items. Note that the pool -commands themselves are not designed to manage such item properties. If item -properties play a role in an application, they should be  managed separately.

- -

 

- -

 

- -

POOL OBJECT COMMAND

- -

 

- -

The -pool command creates a new Tcl command whose name is poolName . -This pool object command is used to manipulate or query the pool object. The -general syntax of a pool object command is:

- -

 

- -

              poolName subcommand ?arg -arg …?

- -

 

- -

The -following subcommands and corresponding arguments are available:

- -

 

- -

poolName add itemName1 ?itemName2 itemName3 ...?

- -

This -command adds the items on the command line to the pool. If duplicate item names -occur on the command line, an error is raised. If one or more of the items -already exist in the pool, this also is considered an error.

- -

             

- -

poolName clear ?-force?

- -

Removes -all items from the pool. If there are any allocated items at the time when the -command is invoked, an error is raised. This behaviour may be modified through -the -force argument. If it is supplied on the command line, the pool -will be cleared regardless the allocation state of its items.

- -

 

- -

poolName destroy ?-force?

- -

Destroys -the pool data structure, all associated variables and the associated pool -object command. By default, the command checks whether any items are still -allocated and raises an error if such is the case. This behaviour may be -modified through the argument -force. If it is supplied on the command -line, the pool data structure will be destroyed regardless allocation state of -its items.

- -

 

- -
- - -

poolName info type ?arg?

- -

Returns -various information about the pool for further programmatic use. The type -argument indicates the type of information requested. Only the allocID -type uses an additional argument.

- -

 

- -

allocID itemName

- -

returns the allocID of the item whose name is itemName. -Free items have an allocation ID -1.

- -

 

- -

allitems

- -

             returns a list of all items in the pool.

- -

 

- -

allocstate

- -

Returns a list of key-value pairs, where the keys are -the items and the values  are the corresponding allocation ID's. Free -items have an allocation ID -1.

- -

 

- -

cursize

- -

returns  the current pool size, i.e. the - number of items in the pool.

- -

 

- -

freeitems

- -

returns -a list of items that currently are not allocated.

- -

 

- -

maxsize

- -

returns  the maximum size of the pool.

- -

 

- -

 

- -

poolName maxsize ?maxsize?

- -

Sets or queries the maximum size of the pool, -depending on whether the maxsize argument is supplied. If the optional -argument maxsize is supplied, the maximum size of the pool will  be set to that value. If no argument maxsize -is supplied, the current maximum size of the pool is returned. In this variant, -the command is an alias for: poolName info maxsize.

- -

The maxsize argument needs to be a positive -integer.

- -

 

- -

 

- -

poolName release itemName

- -

Releases the item whose name is itemName that -was allocated previously. An error is raised if the item was not allocated at -the time when the command was issued.

- -

 

- -

poolName remove itemName ?-force?

- -

Removes -the item whose name is itemName  -from the pool. If the item was allocated at the time when the command -was invoked, an error is raised. This behaviour may be modified through the -optional argument -force. If it is supplied on the command line, the -item will be removed regardless its allocation state.

- -

 

- -
- - -

poolName request itemVar ?options?

- -

Handles -a request for an item, taking into account a possible preference for a -particular item.

- -

 

- -

There -are two possible outcomes depending on the availability of items:

- -

1.      The request is honoured, an item is allocated and the variable whose -name is passed with the argument itemVar will be set to the name of the -item that was allocated. The command returns 1.

- -

2.      The request is denied. No item is allocated. The variable whose name is itemVar -is not set. Attempts to read itemVar  -may raise an error if the variable was not defined before issuing the -request. The command returns 0.

- -

The -return values from this command are meant to be inspected. The examples below -show how to do this. Failure to check the return value may result in erroneous -behaviour.

- -

 

- -

If -no preference for a particular item is supplied through the option –prefer -(see below), then all requests are honoured as long as items are available.

- -

 

- -

The -following options are supported:

- -

 

- -

-allocID allocID

- -

If -the request is honoured, an item will be allocated to the entity identified by allocID. -If the allocation state of an item is queried, it is this allocation ID that -will be returned. If the option –allocID is not supplied, the item will -be allocated to  dummyID. -Allocation ID’s may be anything except the value -1, which is reserved for free -items.

- -

 

- -

-prefer -preferredItem

- -

This -option modifies the allocation strategy as follows:

- -

If -the item whose name is preferredItem is not allocated at the time when -the command is invoked, the request is honoured (return value is 1). If the item -was allocated at the time when the command was invoked, the request is denied -(return value is 0).

- -

 

- -

 

- -

 

- -

EXAMPLES

- -

 

- -

Two -examples are provided. The first one mimics a step by step interactive tclsh session, -where each step is explained. The second example shows the usage in a server -application that talks to a back-end application.

- -

 

- -

Example 1

- -

This -example presents an interactive tclsh session which considers the case of a Car -rental's collection of cars. Ten steps explain its usage in chronological -order, from the creation of the pool, via the most important stages in the -usage of a pool, to the final destruction.

- -

 

- -

Note aside:

- -

In this example, brand names are used to label the various items. -However, a brand name could be regarded as a property of an item. Because the pool -command is not designed to manage properties of items, they need to be managed -separately. In the latter case the items should be labelled with more neutral -names such as: car1, car2, car3 , etc ... and a separate database or array -should hold the brand names associated with the car labels.

- -

 

- -

 

- -

1. -Load the package into an interpreter

- -

% -package require pool

- -

0.1

- -

 

- -

2. -Create a pool object called `CarPool' with a maximum size of 55 items (cars):

- -

% -pool CarPool 55

- -

CarPool

- -

 

- -

4. -Add items to the pool:

- -

% -CarPool add Toyota Trabant Chrysler1 Chrysler2 Volkswagen

- -

             

- -

5. -Somebody crashed the Toyota? Remove it from the pool as follows:

- -

% -CarPool remove Toyota

- -

 

- -

6. -Acquired a new car for the pool? Add it as follows:

- -

% -CarPool add Nissan

- -

 

- -

7. -Check whether the pool was adjusted correctly:

- -

% CarPool info allitems

- -

Trabant Chrysler1 Chrysler2 Volkswagen Nissan

- -

 

- -

 

- -

Suspend -interactive session temporarily, and show the programmatic use of the request -subcommand:

- -

 

- -

 

- -

# -Mrs. Swift needs a car. She doesn't have a preference for a

- -

# -particular car. We'll issue a request on her behalf as follows:

- -

if { -[CarPool request car -allocID "Mrs. Swift"] }  {

- -

# request was honoured, process the variable `car’

- -

puts "$car has been allocated to [CarPool info allocID $car]."

- -

} else {

- -

# request was denied

- -

     puts "No car available."

- -

}

- -

 

- -

(note how the if command uses the value returned by the request -subcommand.)

- -

 

- -

# -Suppose mr. Wiggly has a preference for the Trabant:

- -

if { -[CarPool request car -allocID "Mr. Wiggly" –prefer Trabant] }  {

- -

# request was honoured, process the variable `car’

- -

puts "$car has been allocated to [CarPool info allocID $car]."

- -

} else {

- -

# request was denied

- -

     puts "The Trabant was not -available."

- -

}

- -

 

- -

 

- -

Resume -interactive session:

- -

 

- -

 

- -

8. -When the car is returned then you can render it available by:

- -

% -CarPool release Trabant

- -

 

- -

9. -When done, you delete the pool.

- -

% CarPool destroy

- -

Couldn't destroy `CarPool' because some items are still allocated.

- -

 

- -

Oops, -… forgot that Mrs. Swift still occupies a car.

- -

 

- -

10. -We force the destruction of the pool as follows:

- -

% -CarPool destroy -force

- -

 

- -

 

- -

Example 2

- -

This -example describes the case from which the author’s need for pool management -originated. It is an example of a server application that receives requests -from client applications. The client requests are dispatched onto a back-end -application before being returned to the client application. In many cases -there are a few equivalent instances of back-end applications to which a client -request may be passed along. The file descriptors that identify the channels to -these back-end instances make up a pool of connections. A particular connection -may be allocated to just one client request at a time.

- -

 

- -

# Create -the pool of connections (pipes)

- -

set -maxpipes 10

- -

pool -Pipes $maxpipes

- -

for -{set i 0} {$i < $maxpipes} {incr i} {

- -

         set fd {open “|backendApplication” w+}

- -

         Pipes add $fd

- -

     }

- -

 

- -

# A -client request comes in. The request is identified as `clientX’.

- -

# Dispatch it onto an instance of a back-end application

- -

if { -[Pipes request fd –allocID clientX] } {

- -

    # a connection was allocated

- -

    # communicate to the back-end application -via the variable `fd’

- -

    puts $fd “someInstruction”

- -

    # ...... etc.

- -

} -else {

- -

    # all connections are -currently occupied

- -

    # store the client request in a queue for -later processing,

- -

    # or return a “Server busy” message to the -client.

- -

}

- -

 

- -

 

- -

# -CVS: $Id: pool.html,v 1.1 2002/05/28 06:29:31 andreas_kupries Exp $

- -

# EOF pool.html

- -

 

- -
- - - - DELETED modules/struct/pool.man Index: modules/struct/pool.man ================================================================== --- modules/struct/pool.man +++ /dev/null @@ -1,444 +0,0 @@ -[comment {-*- tcl -*-}] -[manpage_begin pool n 1.2.1] -[copyright {2002, Erik Leunissen }] -[moddesc {Tcl Data Structures}] -[titledesc {Create and manipulate pool objects (of discrete items)}] -[require Tcl 8.2] -[require struct [opt 1.3]] -[description] -[para] - -This package provides pool objects which can be used to manage -finite collections of discrete items. - -[list_begin definitions] - -[call [cmd ::struct::pool] [opt [arg poolName]] [opt [arg maxsize]]] - -Creates a new pool object. If no [arg poolName] is supplied, then the -new pool will be named pool[var X], where X is a positive integer. -The optional second argument [arg maxsize] has to be a positive -integer indicating the maximum size of the pool; this is the maximum -number of items the pool may hold. The default for this value is -[const 10]. - -[nl] - -The pool object has an associated global Tcl command whose name is -[arg poolName]. This command may be used to invoke various -configuration operations on the report. It has the following general -form: - -[list_begin definitions] -[call [cmd poolName] [arg option] [opt [arg "arg arg ..."]]] - -[arg Option] and the [arg arg]s determine the exact behavior of the -command. See section [sectref {POOL OBJECT COMMAND}] for a detailed -list of options and their behaviour. - -[list_end] -[list_end] - -[para] - -[section {POOLS AND ALLOCATION}] - -The purpose of the pool command and the pool object command that it -generates, is to manage pools of discrete items. - -Examples of a pool of discrete items are: - -[list_begin bullet] - -[bullet] -the seats in a cinema, theatre, train etc.. for which visitors/travelers can make a reservation; -[bullet] -the dynamic IP-addresses that an ISP can dole out to subscribers; -[bullet] -a car rental's collection of cars, which can be rented by customers; -[bullet] -the class rooms in a school building, which need to be scheduled; -[bullet] -the database connections available to client-threads in a web-server application; -[bullet] -the books in a library that customers can borrow; -[bullet] -etc ... - -[list_end] -[para] - -The common denominator in the examples is that there is a more or less -fixed number of items (seats, IP-addresses, cars, ...) that are -supposed to be allocated on a more or less regular basis. An item can -be allocated only once at a time. An item that is allocated, must be -released before it can be re-allocated. While several items in a pool -are being allocated and released continuously, the total number of -items in the pool remains constant. - -[para] - -Keeping track of which items are allocated, and by whom, is the -purpose of the pool command and its subordinates. - -[para] - -[emph {Pool parlance}]: If we say that an item is - -[term allocated], it means that the item is [term busy], - -[term owned] or [term occupied]; it is not available anymore. If -an item is [term free], it is [term available]. Deallocating an -item is equivalent to setting free or releasing an item. The person or -entity to which the item has been allotted is said to own the item. - - -[section ITEMS] - -[emph {Discrete items}] -[para] - -The [cmd pool] command is designed for - -[emph {discrete items only}]. Note that there are pools where -allocation occurs on a non-discrete basis, for example computer -memory. There are also pools from which the shares that are doled out -are not expected to be returned, for example a charity fund or a pan -of soup from which you may receive a portion. Finally, there are even -pools from which nothing is ever allocated or returned, like a -swimming pool or a cesspool. - -[para] -[emph {Unique item names}] -[para] - -A pool cannot manage duplicate item names. Therefore, items in a pool -must have unique names. - -[para] -[emph {Item equivalence}] -[para] - -From the point of view of the manager of a pool, items are -equivalent. The manager of a pool is indifferent about which -entity/person occupies a given item. However, clients may have -preferences for a particular item, based on some item property they -know. - -[para] -[emph Preferences] -[para] - -A future owner may have a preference for a particular item. Preference -based allocation is supported (see the [option -prefer] option to the -request subcommand). A preference for a particular item is most likely -to result from variability among features associated with the -items. Note that the pool commands themselves are not designed to -manage such item properties. If item properties play a role in an -application, they should be managed separately. - - -[section {POOL OBJECT COMMAND}] - -The following subcommands and corresponding arguments are available to -any pool object command. - -[list_begin definitions] - -[call [arg poolName] [method add] [arg itemName1] [opt [arg {itemName2 itemName3 ...}]]] - -This command adds the items on the command line to the pool. If -duplicate item names occur on the command line, an error is raised. If -one or more of the items already exist in the pool, this also is -considered an error. - - -[call [arg poolName] [method clear] [opt [option -force]]] - -Removes all items from the pool. If there are any allocated items at -the time when the command is invoked, an error is raised. This -behaviour may be modified through the [option -force] argument. If it -is supplied on the command line, the pool will be cleared regardless -the allocation state of its items. - -[call [arg poolName] [method destroy] [opt [option -force]]] - -Destroys the pool data structure, all associated variables and the -associated pool object command. By default, the command checks whether -any items are still allocated and raises an error if such is the -case. This behaviour may be modified through the argument - -[option -force]. If it is supplied on the command line, the pool data -structure will be destroyed regardless allocation state of its items. - - -[call [arg poolName] [method info] [arg type] [opt [arg arg]]] - -Returns various information about the pool for further programmatic -use. The [arg type] argument indicates the type of information -requested. Only the type [const allocID] uses an additional argument. - -[list_begin definitions] - -[lst_item "[const allocID] [arg itemName]"] - -returns the allocID of the item whose name is [arg itemName]. Free -items have an allocation id of [const -1]. - -[lst_item [const allitems]] - -returns a list of all items in the pool. - -[lst_item [const allocstate]] - -Returns a list of key-value pairs, where the keys are the items and -the values are the corresponding allocation id's. Free items have an -allocation id of [const -1]. - -[lst_item [const cursize]] - -returns the current pool size, i.e. the number of items in the pool. - -[lst_item [const freeitems]] - -returns a list of items that currently are not allocated. - -[lst_item [const maxsize]] - -returns the maximum size of the pool. - -[list_end] -[nl] - -[call [arg poolName] [method maxsize] [opt [arg maxsize]]] - -Sets or queries the maximum size of the pool, depending on whether the -[arg maxsize] argument is supplied or not. If [arg maxsize] is -supplied, the maximum size of the pool will be set to that value. If -no argument is supplied, the current maximum size of the pool is -returned. In this variant, the command is an alias for: - -[nl] -[cmd {poolName info maxsize}]. -[nl] - -The [arg maxsize] argument has to be a positive integer. - - -[call [arg poolName] [method release] [arg itemName]] - -Releases the item whose name is [arg itemName] that was allocated -previously. An error is raised if the item was not allocated at the -time when the command was issued. - - -[call [arg poolName] [method remove] [arg itemName] [opt [option -force]]] - -Removes the item whose name is [arg itemName] from the pool. If the -item was allocated at the time when the command was invoked, an error -is raised. This behaviour may be modified through the optional -argument [option -force]. If it is supplied on the command line, the -item will be removed regardless its allocation state. - - -[call [arg poolName] [method request] itemVar [opt options]] - -Handles a request for an item, taking into account a possible -preference for a particular item. There are two possible outcomes -depending on the availability of items: - -[list_begin enum] - -[enum] - -The request is honoured, an item is allocated and the variable whose -name is passed with the argument [arg itemVar] will be set to the name -of the item that was allocated. The command returns 1. - -[enum] - -The request is denied. No item is allocated. The variable whose name -is itemVar is not set. Attempts to read [arg itemVar] may raise an -error if the variable was not defined before issuing the request. The -command returns 0. - -[list_end] -[nl] - -The return values from this command are meant to be inspected. The -examples below show how to do this. Failure to check the return value -may result in erroneous behaviour. If no preference for a particular -item is supplied through the option [option -prefer] (see below), then -all requests are honoured as long as items are available. - -[nl] -The following options are supported: - -[list_begin definitions] - -[lst_item "[option -allocID] [arg allocID]"] - -If the request is honoured, an item will be allocated to the entity -identified by allocID. If the allocation state of an item is queried, -it is this allocation ID that will be returned. If the option - -[option -allocID] is not supplied, the item will be given to and owned -by [const dummyID]. Allocation id's may be anything except the value --1, which is reserved for free items. - - -[lst_item "[option -prefer] [arg preferredItem]"] - -This option modifies the allocation strategy as follows: If the item -whose name is [arg preferredItem] is not allocated at the time when -the command is invoked, the request is honoured (return value is -1). If the item was allocated at the time when the command was -invoked, the request is denied (return value is 0). - -[list_end] -[list_end] - -[section EXAMPLES] - -Two examples are provided. The first one mimics a step by step -interactive tclsh session, where each step is explained. The second -example shows the usage in a server application that talks to a -back-end application. - -[para] -[emph {Example 1}] -[para] - -This example presents an interactive tclsh session which considers the -case of a Car rental's collection of cars. Ten steps explain its usage -in chronological order, from the creation of the pool, via the most -important stages in the usage of a pool, to the final destruction. - -[para] -[emph {Note aside:}] -[para] - -In this example, brand names are used to label the various -items. However, a brand name could be regarded as a property of an -item. Because the pool command is not designed to manage properties of -items, they need to be managed separately. In the latter case the -items should be labeled with more neutral names such as: car1, car2, -car3 , etc ... and a separate database or array should hold the brand -names associated with the car labels. - -[para] -[example { - 1. Load the package into an interpreter - % package require pool - 0.1 - - 2. Create a pool object called `CarPool' with a maximum size of 55 items (cars): - % pool CarPool 55 - CarPool - - 4. Add items to the pool: - % CarPool add Toyota Trabant Chrysler1 Chrysler2 Volkswagen - - 5. Somebody crashed the Toyota. Remove it from the pool as follows: - % CarPool remove Toyota - - 6. Acquired a new car for the pool. Add it as follows: - % CarPool add Nissan - - 7. Check whether the pool was adjusted correctly: - % CarPool info allitems - Trabant Chrysler1 Chrysler2 Volkswagen Nissan -}] - -[para] - -Suspend the interactive session temporarily, and show the programmatic -use of the request subcommand: - -[para] -[example { - # Mrs. Swift needs a car. She doesn't have a preference for a - # particular car. We'll issue a request on her behalf as follows: - if { [CarPool request car -allocID "Mrs. Swift"] } { - # request was honoured, process the variable `car' - puts "$car has been allocated to [CarPool info allocID $car]." - } else { - # request was denied - puts "No car available." - } -}] -[para] - -Note how the [cmd if] command uses the value returned by the -[method request] subcommand. - -[para] -[example { - # Suppose Mr. Wiggly has a preference for the Trabant: - if { [CarPool request car -allocID "Mr. Wiggly" -prefer Trabant] } { - # request was honoured, process the variable `car' - puts "$car has been allocated to [CarPool info allocID $car]." - } else { - # request was denied - puts "The Trabant was not available." - } -}] -[para] - -Resume the interactive session: - -[para] -[example { - 8. When the car is returned then you can render it available by: - % CarPool release Trabant - - 9. When done, you delete the pool. - % CarPool destroy - Couldn't destroy `CarPool' because some items are still allocated. - - Oops, forgot that Mrs. Swift still occupies a car. - - 10. We force the destruction of the pool as follows: - % CarPool destroy -force -}] - -[para] -[emph {Example 2}] -[para] - -This example describes the case from which the author's need for pool -management originated. It is an example of a server application that -receives requests from client applications. The client requests are -dispatched onto a back-end application before being returned to the -client application. In many cases there are a few equivalent instances -of back-end applications to which a client request may be passed -along. The file descriptors that identify the channels to these -back-end instances make up a pool of connections. A particular -connection may be allocated to just one client request at a time. - -[para] -[example { - # Create the pool of connections (pipes) - set maxpipes 10 - pool Pipes $maxpipes - for {set i 0} {$i < $maxpipes} {incr i} { - set fd {open "|backendApplication" w+} - Pipes add $fd - } - - # A client request comes in. The request is identified as `clientX'. - # Dispatch it onto an instance of a back-end application - if { [Pipes request fd -allocID clientX] } { - # a connection was allocated - # communicate to the back-end application via the variable `fd' - puts $fd "someInstruction" - # ...... etc. - } else { - # all connections are currently occupied - # store the client request in a queue for later processing, - # or return a 'Server busy' message to the client. - } -}] - -[keywords struct pool finite {discrete items}] -[manpage_end] DELETED modules/struct/pool.tcl Index: modules/struct/pool.tcl ================================================================== --- modules/struct/pool.tcl +++ /dev/null @@ -1,697 +0,0 @@ -################################################################################ -# pool.tcl -# -# -# Author: Erik Leunissen -# -# -# Acknowledgement: -# The author is grateful for the advice provided by -# Andreas Kupries during the development of this code. -# -# -# $Id: pool.tcl,v 1.2 2002/08/06 20:40:42 andreas_kupries Exp $ -# -################################################################################ - -package require cmdline - -namespace eval ::struct {} -namespace eval ::struct::pool { - - # a list of all current pool names - variable pools {} - - # counter is used to give a unique name to a pool if - # no name was supplied, e.g. pool1, pool2 etc. - variable counter 0 - - # `commands' is the list of subcommands recognized by a pool-object command - variable commands {add clear destroy info maxsize release remove request} - - # All errors with corresponding (unformatted) messages. - # The format strings will be replaced by the appropriate - # values when an error occurs. - variable Errors - array set Errors { - BAD_SUBCMD {bad subcommand "%s": must be %s} - DUPLICATE_ITEM_IN_ARGS {Duplicate item `%s' in arguments.} - DUPLICATE_POOLNAME {The pool `%s' already exists.} - EXCEED_MAXSIZE "This command would increase the total number of items\ - \nbeyond the maximum size of the pool. No items registered." - FORBIDDEN_ALLOCID "The value -1 is not allowed as an allocID." - INVALID_POOLSIZE {The pool currently holds %s items.\ - Can't set maxsize to a value less than that.} - ITEM_ALREADY_IN_POOL {`%s' already is a member of the pool. No items registered.} - ITEM_NOT_IN_POOL {`%s' is not a member of %s.} - ITEM_NOT_ALLOCATED {Can't release `%s' because it isn't allocated.} - ITEM_STILL_ALLOCATED {Can't remove `%s' because it is still allocated.} - NONINT_REQSIZE {The second argument must be a positive integer value} - SOME_ITEMS_NOT_FREE {Couldn't %s `%s' because some items are still allocated.} - UNKNOWN_ARG {Unknown argument `%s'} - UNKNOWN_POOL {Nothing known about `%s'.} - VARNAME_EXISTS "A variable `::struct::pool::%s' already exists." - WRONG_INFO_TYPE "Expected second argument to be one of:\ - \n allitems, allocstate, cursize, freeitems, maxsize,\ - \nbut received: `%s'." - WRONG_NARGS {Wrong nr. of arguments.} - } - - namespace export pool -} - - -# A small helper routine to check list membership -proc ::struct::pool::lmember {list element} { - if { [lsearch -exact $list $element] >= 0 } { - return 1 - } else { - return 0 - } -} - - -# General note -# ============ -# -# All procedures below use the following method to reference -# a particular pool-object: -# -# variable $poolname -# upvar #0 ::struct::pool::$poolname pool -# upvar #0 ::struct::pool::Allocstate_$poolname state -# -# Therefore, the names `pool' and `state' refer to a particular -# instance of a pool. -# -# In the comments to the code below, the words `pool' and `state' -# also refer to a particular pool. -# - -# ::struct::pool::create -# -# Creates a new instance of a pool (a pool-object). -# ::struct::pool::pool (see right below) is an alias to this procedure. -# -# -# Arguments: -# poolname: name of the pool-object -# maxsize: the maximum number of elements that the pool is allowed -# consist of. -# -# -# Results: -# the name of the newly created pool -# -# -# Side effects: -# - Registers the pool-name in the variable `pools'. -# -# - Creates the pool array which holds general state about the pool. -# The following elements are initialized: -# pool(freeitems): a list of non-allocated items -# pool(cursize): the current number of elements in the pool -# pool(maxsize): the maximum allowable number of pool elements -# Additional state may be hung off this array as long as the three -# elements above are not corrupted. -# -# - Creates a separate array `state' that will hold allocation state -# of the pool elements. -# -# - Creates an object-procedure that has the same name as the pool. -# -proc ::struct::pool::create { {poolname ""} {maxsize 10} } { - variable pools - variable counter - variable Errors - - # check maxsize argument - if { ![string equal $maxsize 10] } { - if { ![regexp {^\+?[1-9][0-9]*$} $maxsize] } { - return -code error $Errors(NONINT_REQSIZE) - } - } - - # create a name if no name was supplied - if { [string length $poolname]==0 } { - incr counter - set poolname pool$counter - set incrcnt 1 - } - - # check whether there exists a pool named $poolname - if { [lmember $pools $poolname] } { - if { [::info exists incrcnt] } { - incr counter -1 - } - return -code error [format $Errors(DUPLICATE_POOLNAME) $poolname] - } - - # check whether the namespace variable exists - if { [::info exists ::struct::pool::$poolname] } { - if { [::info exists incrcnt] } { - incr counter -1 - } - return -code error [format $Errors(VARNAME_EXISTS) $poolname] - } - - variable $poolname - - # register - lappend pools $poolname - - # create and initialize the new pool data structure - upvar #0 ::struct::pool::$poolname pool - set pool(freeitems) {} - set pool(maxsize) $maxsize - set pool(cursize) 0 - - # the array that holds allocation state - upvar #0 ::struct::pool::Allocstate_$poolname state - array set state {} - - # create a pool-object command and map it to the pool commands - interp alias {} ::$poolname {} ::struct::pool::poolCmd $poolname - return $poolname -} - -# -# This alias provides compatibility with the implementation of the -# other data structures (stack, queue etc...) in the tcllib::struct package. -# -proc ::struct::pool::pool { {poolname ""} {maxsize 10} } { - ::struct::pool::create $poolname $maxsize -} - - -# ::struct::pool::poolCmd -# -# This proc constitutes a level of indirection between the pool-object -# subcommand and the pool commands (below); it's sole function is to pass -# the command along to one of the pool commands, and receive any results. -# -# Arguments: -# poolname: name of the pool-object -# subcmd: the subcommand, which identifies the pool-command to -# which calls will be passed. -# args: any arguments. They will be inspected by the pool-command -# to which this call will be passed along. -# -# Results: -# Whatever result the pool command returns, is once more returned. -# -# Side effects: -# Dispatches the call onto a specific pool command and receives any results. -# -proc ::struct::pool::poolCmd {poolname subcmd args} { - variable Errors - - # check the subcmd argument - if { [lsearch -exact $::struct::pool::commands $subcmd] == -1 } { - set optlist [join $::struct::pool::commands ", "] - set optlist [linsert $optlist "end-1" "or"] - return -code error [format $Errors(BAD_SUBCMD) $subcmd $optlist] - } - - # pass the call to the pool command indicated by the subcmd argument, - # and return the result from that command. - return [eval ::struct::pool::$subcmd $poolname $args] -} - - -# ::struct::pool::destroy -# -# Destroys a pool-object, its associated variables and "object-command" -# -# Arguments: -# poolname: name of the pool-object -# forceArg: if set to `-force', the pool-object will be destroyed -# regardless the allocation state of its objects. -# -# Results: -# none -# -# Side effects: -# - unregisters the pool name in the variable `pools'. -# - unsets `pool' and `state' (poolname specific variables) -# - destroys the "object-procedure" that was associated with the pool. -# -proc ::struct::pool::destroy {poolname {forceArg ""}} { - variable pools - variable Errors - - # check forceArg argument - if { [string length $forceArg] } { - if { [string equal $forceArg -force] } { - set force 1 - } else { - return -code error [format $Errors(UNKNOWN_ARG) $forceArg] - } - } else { - set force 0 - } - - set index [lsearch -exact $pools $poolname] - if {$index == -1 } { - return -code error [format $Errors(UNKNOWN_POOL) $poolname] - } - - if { !$force } { - # check for any lingering allocated items - variable $poolname - upvar #0 ::struct::pool::$poolname pool - upvar #0 ::struct::pool::Allocstate_$poolname state - if { [llength $pool(freeitems)] != $pool(cursize) } { - return -code error [format $Errors(SOME_ITEMS_NOT_FREE) destroy $poolname] - } - } - - rename ::$poolname {} - unset ::struct::pool::$poolname - catch {unset ::struct::pool::Allocstate_$poolname} - set pools [lreplace $pools $index $index] - - return -} - - -# ::struct::pool::add -# -# Add items to the pool -# -# Arguments: -# poolname: name of the pool-object -# args: the items to add -# -# Results: -# none -# -# Side effects: -# sets the initial allocation state of the added items to -1 (free) -# -proc ::struct::pool::add {poolname args} { - variable Errors - variable $poolname - upvar #0 ::struct::pool::$poolname pool - upvar #0 ::struct::pool::Allocstate_$poolname state - - # argument check - if { [llength $args] == 0 } { - return -code error $Errors(WRONG_NARGS) - } - - # will this operation exceed the size limit of the pool? - if {[expr { $pool(cursize) + [llength $args] }] > $pool(maxsize) } { - return -code error $Errors(EXCEED_MAXSIZE) - } - - - # check for duplicate items on the command line - set N [llength $args] - if { $N > 1} { - for {set i 0} {$i<=$N} {incr i} { - foreach item [lrange $args [expr {$i+1}] end] { - if { [string equal [lindex $args $i] $item]} { - return -code error [format $Errors(DUPLICATE_ITEM_IN_ARGS) $item] - } - } - } - } - - # check whether the items exist yet in the pool - foreach item $args { - if { [lmember [array names state] $item] } { - return -code error [format $Errors(ITEM_ALREADY_IN_POOL) $item] - } - } - - # add items to the pool, and initialize their allocation state - foreach item $args { - lappend pool(freeitems) $item - set state($item) -1 - incr pool(cursize) - } - return -} - - - -# ::struct::pool::clear -# -# Removes all items from the pool and clears corresponding -# allocation state. -# -# -# Arguments: -# poolname: name of the pool-object -# forceArg: if set to `-force', all items are removed -# regardless their allocation state. -# -# Results: -# none -# -# Side effects: -# see description above -# -proc ::struct::pool::clear {poolname {forceArg ""} } { - variable Errors - variable $poolname - upvar #0 ::struct::pool::$poolname pool - upvar #0 ::struct::pool::Allocstate_$poolname state - - # check forceArg argument - if { [string length $forceArg] } { - if { [string equal $forceArg -force] } { - set force 1 - } else { - return -code error [format $Errors(UNKNOWN_ARG) $forceArg] - } - } else { - set force 0 - } - - # check whether some items are still allocated - if { !$force } { - if { [llength $pool(freeitems)] != $pool(cursize) } { - return -code error [format $Errors(SOME_ITEMS_NOT_FREE) clear $poolname] - } - } - - # clear the pool, clean up state and adjust the pool size - set pool(freeitems) {} - array unset state - array set state {} - set pool(cursize) 0 - return -} - - - -# ::struct::pool::info -# -# Returns information about the pool in data structures that allow -# further programmatic use. -# -# Arguments: -# poolname: name of the pool-object -# type: the type of info requested -# -# -# Results: -# The info requested -# -# -# Side effects: -# none -# -proc ::struct::pool::info {poolname type args} { - variable Errors - variable $poolname - upvar #0 ::struct::pool::$poolname pool - upvar #0 ::struct::pool::Allocstate_$poolname state - - # check the number of arguments - if { [string equal $type allocID] } { - if { [llength $args]!=1 } { - return -code error $Errors(WRONG_NARGS) - } - } elseif { [llength $args] > 0 } { - return -code error $Errors(WRONG_NARGS) - } - - switch $type { - allitems { - return [array names state] - } - allocstate { - return [array get state] - } - allocID { - set item [lindex $args 0] - if {![lmember [array names state] $item]} { - return -code error [format $Errors(ITEM_NOT_IN_POOL) $item $poolname] - } - return $state($item) - } - cursize { - return $pool(cursize) - } - freeitems { - return $pool(freeitems) - } - maxsize { - return $pool(maxsize) - } - default { - return -code error [format $Errors(WRONG_INFO_TYPE) $type] - } - } -} - - -# ::struct::pool::maxsize -# -# Returns the current or sets a new maximum size of the pool. -# As far as querying only is concerned, this is an alias for -# `::struct::pool::info maxsize'. -# -# -# Arguments: -# poolname: name of the pool-object -# reqsize: if supplied, it is the requested size of the pool, i.e. -# the maximum number of elements in the pool. -# -# -# Results: -# The current/new maximum size of the pool. -# -# -# Side effects: -# Sets pool(maxsize) if a new size is supplied. -# -proc ::struct::pool::maxsize {poolname {reqsize ""} } { - variable Errors - variable $poolname - upvar #0 ::struct::pool::$poolname pool - upvar #0 ::struct::pool::Allocstate_$poolname state - - if { [string length $reqsize] } { - if { [regexp {^\+?[1-9][0-9]*$} $reqsize] } { - if { $pool(cursize) <= $reqsize } { - set pool(maxsize) $reqsize - } else { - return -code error [format $Errors(INVALID_POOLSIZE) $pool(cursize)] - } - } else { - return -code error $Errors(NONINT_REQSIZE) - } - } - return $pool(maxsize) -} - - -# ::struct::pool::release -# -# Deallocates an item -# -# -# Arguments: -# poolname: name of the pool-object -# item: name of the item to be released -# -# -# Results: -# none -# -# Side effects: -# - sets the item's allocation state to free (-1) -# - appends item to the list of free items -# -proc ::struct::pool::release {poolname item} { - variable Errors - variable $poolname - upvar #0 ::struct::pool::$poolname pool - upvar #0 ::struct::pool::Allocstate_$poolname state - - # Is item in the pool? - if {![lmember [array names state] $item]} { - return -code error [format $Errors(ITEM_NOT_IN_POOL) $item $poolname] - } - - # check whether item was allocated - if { $state($item) == -1 } { - return -code error [format $Errors(ITEM_NOT_ALLOCATED) $item] - } else { - - # set item free and return it to the pool of free items - set state($item) -1 - lappend pool(freeitems) $item - - } - return -} - -# ::struct::pool::remove -# -# Removes an item from the pool -# -# -# Arguments: -# poolname: name of the pool-object -# item: the item to be removed -# forceArg: if set to `-force', the item is removed -# regardless its allocation state. -# -# Results: -# none -# -# Side effects: -# - cleans up allocation state related to the item -# -proc ::struct::pool::remove {poolname item {forceArg ""} } { - variable Errors - variable $poolname - upvar #0 ::struct::pool::$poolname pool - upvar #0 ::struct::pool::Allocstate_$poolname state - - # check forceArg argument - if { [string length $forceArg] } { - if { [string equal $forceArg -force] } { - set force 1 - } else { - return -code error [format $Errors(UNKNOWN_ARG) $forceArg] - } - } else { - set force 0 - } - - # Is item in the pool? - if {![lmember [array names state] $item]} { - return -code error [format $Errors(ITEM_NOT_IN_POOL) $item $poolname] - } - - set index [lsearch $pool(freeitems) $item] - if { $index >= 0} { - - # actual removal - set pool(freeitems) [lreplace $pool(freeitems) $index $index] - - } elseif { !$force } { - return -code error [format $Errors(ITEM_STILL_ALLOCATED) $item] - } - - # clean up state and adjust the pool size - unset state($item) - incr pool(cursize) -1 - return -} - - - -# ::struct::pool::request -# -# Handles requests for an item, taking into account a preference -# for a particular item if supplied. -# -# -# Arguments: -# poolname: name of the pool-object -# -# itemvar: variable to which the item-name will be assigned -# if the request is honored. -# -# args: an optional sequence of key-value pairs, indicating the -# following options: -# -prefer: the preferred item to allocate. -# -allocID: An ID for the entity to which the item will be -# allocated. This facilitates reverse lookups. -# -# Results: -# -# 1 if the request was honored; an item is allocated -# 0 if the request couldn't be honored; no item is allocated -# -# The user is strongly advised to check the return values -# when calling this procedure. -# -# -# Side effects: -# -# if the request is honored: -# - sets allocation state to $allocID (or dummyID if it was not supplied) -# if allocation was succesful. Allocation state is maintained in the -# namespace variable state (see: `General note' above) -# - sets the variable passed via `itemvar' to the allocated item. -# -# if the request is denied, no side effects occur. -# -proc ::struct::pool::request {poolname itemvar args} { - variable Errors - variable $poolname - upvar #0 ::struct::pool::$poolname pool - upvar #0 ::struct::pool::Allocstate_$poolname state - - # check args - set nargs [llength $args] - if { ! ($nargs==0 || $nargs==2 || $nargs==4) } { - if { ![string equal $args -?] && ![string equal $args -help]} { - return -code error $Errors(WRONG_NARGS) - } - } elseif { $nargs } { - foreach {name value} $args { - if { ![string match -* $name] } { - return -code error [format $Errors(UNKNOWN_ARG) $name] - } - } - } - - set allocated 0 - - # are there any items available? - if { [llength $pool(freeitems)] > 0} { - - # process command options - set options [cmdline::getoptions args { \ - {prefer.arg {} {The preference for a particular item}} \ - {allocID.arg {} {An ID for the entity to which the item will be allocated} } \ - } \ - "usage: $poolname request itemvar ?options?:"] - foreach {key value} $options { - set $key $value - } - - if { $allocID == -1 } { - return -code error $Errors(FORBIDDEN_ALLOCID) - } - - # let `item' point to a variable two levels up the call stack - upvar 2 $itemvar item - - # check whether a preference was supplied - if { [string length $prefer] } { - if {![lmember [array names state] $prefer]} { - return -code error [format $Errors(ITEM_NOT_IN_POOL) $prefer $poolname] - } - if { $state($prefer) == -1 } { - set index [lsearch $pool(freeitems) $prefer] - set item $prefer - } - } else { - set index 0 - set item [lindex $pool(freeitems) 0] - } - - # do the actual allocation - set pool(freeitems) [lreplace $pool(freeitems) $index $index] - if { [string length $allocID] } { - set state($item) $allocID - } else { - set state($item) dummyID - } - set allocated 1 - } - return $allocated -} - - -# EOF pool.tcl DELETED modules/struct/pooltest.tcl Index: modules/struct/pooltest.tcl ================================================================== --- modules/struct/pooltest.tcl +++ /dev/null @@ -1,203 +0,0 @@ -# pooltest.tcl - -source [file join [file dirname [info script]] pool.tcl] -namespace import pool::* -pool CarPool - -CarPool add Toyota Volkswagen Chrysler Trabant - -CarPool request item -prefer Trabant -allocID me - - -proc poolinfo {} { - puts "Current pool size: [CarPool info cursize]" - puts "Maximum pool size: [CarPool info maxsize]" - puts "Free items: [CarPool info freeitems]" - if { [CarPool info cursize] > 0 } { - set sep_line [string repeat - 40] - puts "Allocation info:\ - \nnr. item allocID (-1 = free)" - puts $sep_line - set i 0 - foreach {item state} [CarPool info allocstate] { - puts "[incr i] $item $state" - } - puts $sep_line - } - return -} -poolinfo -set failedtests {} - -# Exercise all error cases - -proc MatchErrMsg {errid errmsg} { - global failedtests - - set pattern [format $::pool::Errors($errid) * *] - if { ![string match $pattern $errmsg] } { - puts "$errid: failed \ - \nPattern: $pattern \ - \nError message: $errmsg" - lappend failedtests $errid - } else { - puts "$errid: passed" - } -} - -proc VARNAME_EXISTS {} { - set ::pool::existvar 1 - catch {pool::create existvar} errmsg - MatchErrMsg [info level 0] $errmsg - unset ::pool::existvar -} - -proc DUPLICATE_POOLNAME {} { - catch {pool::create CarPool} errmsg - MatchErrMsg [info level 0] $errmsg -} - -proc NONINT_REQSIZE {} { - catch {pool::create CarPool noninteger} errmsg - MatchErrMsg [info level 0] $errmsg - - catch {CarPool maxsize noninteger} errmsg - MatchErrMsg [info level 0] $errmsg -} - -proc UNKNOWN_POOL {} { - catch {pool::destroy NonExistentPool} errmsg - MatchErrMsg [info level 0] $errmsg -} - - -proc BAD_SUBCMD {} { - catch {CarPool badsubcommand whateverargs} errmsg - MatchErrMsg [info level 0] $errmsg -} - - -proc SOME_ITEMS_NOT_FREE {} { - catch {CarPool clear} errmsg - MatchErrMsg [info level 0] $errmsg - - catch {CarPool destroy} errmsg - MatchErrMsg [info level 0] $errmsg -} - - -proc DUPLICATE_ITEM_IN_ARGS {} { - catch {CarPool add Toyota duplicatecar someothercar somestrangecar duplicatecar} errmsg - MatchErrMsg [info level 0] $errmsg -} - - -proc FORBIDDEN_ALLOCID {} { - catch {CarPool request car -allocID -1} errmsg - MatchErrMsg [info level 0] $errmsg -} - - -proc ITEM_ALREADY_IN_POOL {} { - catch {CarPool add Toyota} errmsg - MatchErrMsg [info level 0] $errmsg -} - - -proc ITEM_STILL_ALLOCATED {} { - catch {CarPool remove Trabant} errmsg - MatchErrMsg [info level 0] $errmsg -} - - -proc ITEM_NOT_ALLOCATED {} { - catch {CarPool release Toyota} errmsg - MatchErrMsg [info level 0] $errmsg -} - - -proc ITEM_NOT_IN_POOL {} { - catch {CarPool info allocID Buggy} errmsg - MatchErrMsg [info level 0] $errmsg - - catch {CarPool request item -prefer Buggy} errmsg - MatchErrMsg [info level 0] $errmsg - - catch {CarPool release Buggy} errmsg - MatchErrMsg [info level 0] $errmsg - - catch {CarPool remove Buggy} errmsg - MatchErrMsg [info level 0] $errmsg -} - - -proc EXCEED_MAXSIZE {} { - catch {CarPool add 1 2 3 4 5 6 7} errmsg - MatchErrMsg [info level 0] $errmsg -} - - -proc INVALID_POOLSIZE {} { - catch {CarPool maxsize [expr {[CarPool info cursize] - 1}] } errmsg - MatchErrMsg [info level 0] $errmsg -} - - -proc WRONG_INFO_TYPE {} { - catch {CarPool info wronginfotype} errmsg - MatchErrMsg [info level 0] $errmsg -} - - -proc UNKNOWN_ARG {} { - catch {CarPool clear unknownarg} errmsg - MatchErrMsg [info level 0] $errmsg - - catch {CarPool request item Toyota unknownarg} errmsg - MatchErrMsg [info level 0] $errmsg - - catch {CarPool destroy unknownarg} errmsg - MatchErrMsg [info level 0] $errmsg - - catch {CarPool remove Toyota unknownarg} errmsg - MatchErrMsg [info level 0] $errmsg -} - - -proc WRONG_NARGS {} { - catch {CarPool add} errmsg - MatchErrMsg [info level 0] $errmsg - - catch {CarPool info cursize oneargtoomany} errmsg - MatchErrMsg [info level 0] $errmsg - - catch {CarPool info allocID} errmsg - MatchErrMsg [info level 0] $errmsg - - catch {CarPool info allocID Trabant oneargtoomany} errmsg - MatchErrMsg [info level 0] $errmsg - - catch {CarPool request item Toyota -prefer me} errmsg - MatchErrMsg [info level 0] $errmsg -} - - -puts "TESTING ERROR CASES:\n" - -foreach errid [array names pool::Errors] { - if { [llength [::info procs $errid]] } { - eval $errid - } -} - -puts {} -if { [llength $failedtests] } { - puts "The following tests failed:" - foreach errid $failedtests { - puts $errid - } -} else { - puts "All tests passed." -} - -# EOF pooltest.tcl DELETED modules/struct/prioqueue.tcl Index: modules/struct/prioqueue.tcl ================================================================== --- modules/struct/prioqueue.tcl +++ /dev/null @@ -1,418 +0,0 @@ -# prioqueue.tcl -- -# -# Priority Queue implementation for Tcl. -# -# adapted from queue.tcl -# Copyright (c) 2002,2003 Michael Schlenker -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: prioqueue.tcl,v 1.2 2003/04/16 19:27:41 andreas_kupries Exp $ - -package require Tcl 8.2 - -namespace eval ::struct {} - -namespace eval ::struct::prioqueue { - # The queues array holds all of the queues you've made - variable queues - - # counter is used to give a unique name for unnamed queues - variable counter 0 - - # commands is the list of subcommands recognized by the queue - variable commands [list \ - "clear" \ - "destroy" \ - "get" \ - "peek" \ - "put" \ - "size" \ - "peekpriority" \ - ] - - variable sortopt [list \ - "-integer" \ - "-real" \ - "-ascii" \ - "-dictionary" \ - ] - - # this is a simple design decision, that integer and real - # are sorted decreasing, and -ascii and -dictionary are sorted -increasing - # could be changed to something configurable. - variable sortdir [list \ - "-decreasing" \ - "-decreasing" \ - "-increasing" \ - "-increasing" \ - ] - - - - # Only export one command, the one used to instantiate a new queue - namespace export prioqueue - - proc K {x y} {set x} ;# DKF's K combinator -} - -# ::struct::prioqueue::prioqueue -- -# -# Create a new prioqueue with a given name; if no name is given, use -# prioqueueX, where X is a number. -# -# Arguments: -# sorting sorting option for lsort to use, no -command option -# defaults to integer -# name name of the queue; if null, generate one. -# names may not begin with - -# -# -# Results: -# name name of the queue created - -proc ::struct::prioqueue::prioqueue {args} { - variable queues - variable counter - variable queues_sorting - variable sortopt - - # check args - if {[llength $args] > 2} { - error "wrong # args: should be \"[lindex [info level 0] 0] ?-ascii|-dictionary|-integer|-real? ?name?\"" - } - if {[llength $args] == 0} { - # defaulting to integer priorities - set sorting -integer - } else { - if {[llength $args] == 1} { - if {[string match "-*" [lindex $args 0]]==1} { - set sorting [lindex $args 0] - } else { - set sorting -integer - set name [lindex $args 0] - } - } else { - if {[llength $args] == 2} { - foreach {sorting name} $args {break} - } - } - } - # check option (like lsort sorting options without -command) - if {[lsearch $sortopt $sorting] == -1} { - # if sortoption is unknown, but name is a sortoption we give a better error message - if {[info exists name] && [lsearch $sortopt $name]!=-1} { - error "wrong argument position: should be \"[lindex [info level 0] 0] ?-ascii|-dictionary|-integer|-real? ?name?\"" - } - error "unknown sort option \"$sorting\"" - } - # create name if not given - if {![info exists name]} { - incr counter - set name "prioqueue${counter}" - } - - if { ![string equal [info commands ::$name] ""] } { - error "command \"$name\" already exists, unable to create prioqueue" - } - - # Initialize the queue as empty - set queues($name) [list ] - switch -exact -- $sorting { - -integer { set queues_sorting($name) 0} - -real { set queues_sorting($name) 1} - -ascii { set queues_sorting($name) 2} - -dictionary { set queues_sorting($name) 3} - } - - # Create the command to manipulate the queue - interp alias {} ::$name {} ::struct::prioqueue::QueueProc $name - - return $name -} - -########################## -# Private functions follow - -# ::struct::prioqueue::QueueProc -- -# -# Command that processes all queue object commands. -# -# Arguments: -# name name of the queue object to manipulate. -# args command name and args for the command -# -# Results: -# Varies based on command to perform - -proc ::struct::prioqueue::QueueProc {name {cmd ""} args} { - # Do minimal args checks here - if { [llength [info level 0]] == 2 } { - error "wrong # args: should be \"$name option ?arg arg ...?\"" - } - - # Split the args into command and args components - if { [string equal [info commands ::struct::prioqueue::_$cmd] ""] } { - variable commands - set optlist [join $commands ", "] - set optlist [linsert $optlist "end-1" "or"] - error "bad option \"$cmd\": must be $optlist" - } - return [eval [list ::struct::prioqueue::_$cmd $name] $args] -} - -# ::struct::prioqueue::_clear -- -# -# Clear a queue. -# -# Arguments: -# name name of the queue object. -# -# Results: -# None. - -proc ::struct::prioqueue::_clear {name} { - variable queues - set queues($name) [list] - return -} - -# ::struct::prioqueue::_destroy -- -# -# Destroy a queue object by removing it's storage space and -# eliminating it's proc. -# -# Arguments: -# name name of the queue object. -# -# Results: -# None. - -proc ::struct::prioqueue::_destroy {name} { - variable queues - variable queues_sorting - unset queues($name) - unset queues_sorting($name) - interp alias {} ::$name {} - return -} - -# ::struct::prioqueue::_get -- -# -# Get an item from a queue. -# -# Arguments: -# name name of the queue object. -# count number of items to get; defaults to 1 -# -# Results: -# item first count items from the queue; if there are not enough -# items in the queue, throws an error. -# - -proc ::struct::prioqueue::_get {name {count 1}} { - variable queues - if { $count < 1 } { - error "invalid item count $count" - } - - if { $count > [llength $queues($name)] } { - error "insufficient items in prioqueue to fill request" - } - - if { $count == 1 } { - # Handle this as a special case, so single item gets aren't listified - set item [lindex [lindex $queues($name) 0] 1] - set queues($name) [lreplace [K $queues($name) [set queues($name) ""]] 0 0] - return $item - } - - # Otherwise, return a list of items - incr count -1 - set items [lrange $queues($name) 0 $count] - foreach item $items { - lappend result [lindex $item 1] - } - set items "" - - set queues($name) [lreplace [K $queues($name) [set queues($name) ""]] 0 $count] - return $result -} - -# ::struct::prioqueue::_peek -- -# -# Retrive the value of an item on the queue without removing it. -# -# Arguments: -# name name of the queue object. -# count number of items to peek; defaults to 1 -# -# Results: -# items top count items from the queue; if there are not enough items -# to fufill the request, throws an error. - -proc ::struct::prioqueue::_peek {name {count 1}} { - variable queues - if { $count < 1 } { - error "invalid item count $count" - } - - if { $count > [llength $queues($name)] } { - error "insufficient items in prioqueue to fill request" - } - - if { $count == 1 } { - # Handle this as a special case, so single item pops aren't listified - return [lindex [lindex $queues($name) 0] 1] - } - - # Otherwise, return a list of items - set index [expr {$count - 1}] - foreach item [lrange $queues($name) 0 $index] { - lappend result [lindex $item 1] - } - return $result -} - -# ::struct::prioqueue::_peekpriority -- -# -# Retrive the priority of an item on the queue without removing it. -# -# Arguments: -# name name of the queue object. -# count number of items to peek; defaults to 1 -# -# Results: -# items top count items from the queue; if there are not enough items -# to fufill the request, throws an error. - -proc ::struct::prioqueue::_peekpriority {name {count 1}} { - variable queues - if { $count < 1 } { - error "invalid item count $count" - } - - if { $count > [llength $queues($name)] } { - error "insufficient items in prioqueue to fill request" - } - - if { $count == 1 } { - # Handle this as a special case, so single item pops aren't listified - return [lindex [lindex $queues($name) 0] 0] - } - - # Otherwise, return a list of items - set index [expr {$count - 1}] - foreach item [lrange $queues($name) 0 $index] { - lappend result [lindex $item 0] - } - return $result -} - - -# ::struct::prioqueue::_put -- -# -# Put an item into a queue. -# -# Arguments: -# name name of the queue object -# args list of the form "item1 prio1 item2 prio2 item3 prio3" -# -# Results: -# None. - -proc ::struct::prioqueue::_put {name args} { - variable queues - variable queues_sorting - variable sortopt - variable sortdir - - if { [llength $args] == 0 || [llength $args] % 2} { - error "wrong # args: should be \"$name put item prio ?item prio ...?\"" - } - - # check for prio type before adding - switch -exact -- $queues_sorting($name) { - 0 { - foreach {item prio} $args { - if {![string is integer -strict $prio]} { - error "priority \"$prio\" is not an integer type value" - } - } - } - 1 { - foreach {item prio} $args { - if {![string is double -strict $prio]} { - error "priority \"$prio\" is not a real type value" - } - } - } - default { - #no restrictions for -ascii and -dictionary - } - } - - # sort by priorities - set opt [lindex $sortopt $queues_sorting($name)] - set dir [lindex $sortdir $queues_sorting($name)] - - # add only if check has passed - foreach {item prio} $args { - set new [list $prio $item] - set queues($name) [__linsertsorted [K $queues($name) [set queues($name) ""]] $new $opt $dir] - } - return -} - -# ::struct::prioqueue::_size -- -# -# Return the number of objects on a queue. -# -# Arguments: -# name name of the queue object. -# -# Results: -# count number of items on the queue. - -proc ::struct::prioqueue::_size {name} { - variable queues - return [llength $queues($name)] -} - -# ::struct::prioqueue::__linsertsorted -# -# Helper proc for inserting into a sorted list. -# -# - -proc ::struct::prioqueue::__linsertsorted {list newElement sortopt sortdir} { - set pos 0 - set newPrio [lindex $newElement 0] - foreach element $list { - set prio [lindex $element 0] - if {[__elementcompare $prio $newPrio $sortopt $sortdir]} break - incr pos - } - linsert $list $pos $newElement -} - -# ::struct::prioqueue::__elementcompare -# -# Compare helper with the sort options. -# -# - -proc ::struct::prioqueue::__elementcompare {prio newPrio sortopt sortdir} { - if {[string equal $sortopt "-integer"] || [string equal $sortopt "-real"]} { - set result [expr {$prio < $newPrio}] - } elseif {[string equal $sortopt "-ascii"]} { - set result [expr {[string compare $prio $newPrio] < 0}] - } elseif {[string equal $sortopt "-dictionary"]} { - # need to use lsort to access -dictionary sorting - set result [string equal $prio [lindex \ - [lsort -increasing -dictionary [list $prio $newPrio]] 0]] - } - - return [expr {[string equal $sortdir "-decreasing"] ? $result : !$result}] -} DELETED modules/struct/prioqueue.test Index: modules/struct/prioqueue.test ================================================================== --- modules/struct/prioqueue.test +++ /dev/null @@ -1,426 +0,0 @@ -# -*- tcl -*- -# prioqueue.test: tests for the prioqueue package. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 1998-2000 by Ajuba Solutions. -# Copyright (c) 2002 Michael Schlenker -# All rights reserved. -# -# RCS: @(#) $Id: prioqueue.test,v 1.1 2003/04/15 21:44:51 andreas_kupries Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -source [file join [file dirname [info script]] prioqueue.tcl] -namespace import -force struct::prioqueue::prioqueue - -test prioqueue-0.1 {prioqueue errors} { - prioqueue -integer myprioqueue - catch {prioqueue myprioqueue} msg - myprioqueue destroy - set msg -} "command \"myprioqueue\" already exists, unable to create prioqueue" -test prioqueue-0.2 {prioqueue errors} { - prioqueue myprioqueue - catch {myprioqueue} msg - myprioqueue destroy - set msg -} "wrong # args: should be \"myprioqueue option ?arg arg ...?\"" -test prioqueue-0.3 {prioqueue errors} { - prioqueue myprioqueue - catch {myprioqueue foo} msg - myprioqueue destroy - set msg -} "bad option \"foo\": must be clear, destroy, get, peek, put, size, or peekpriority" -test prioqueue-0.4 {prioqueue errors} { - catch {prioqueue set} msg - set msg -} "command \"set\" already exists, unable to create prioqueue" - -test prioqueue-0.5 {prioqueue errors} { - catch {prioqueue -foo myprioqueue} msg - set msg -} "unknown sort option \"-foo\"" - -test prioqueue-0.6 {prioqueue errors} { - catch {prioqueue -foo} msg - set msg -} "unknown sort option \"-foo\"" - -test prioqueue-0.7 {prioqueue errors} { - catch {prioqueue -integer myprioqueue foo} msg - set msg -} "wrong # args: should be \"prioqueue ?-ascii|-dictionary|-integer|-real? ?name?\"" - -test prioqueue-0.8 {prioqueue errors} { - catch {prioqueue myprioqueue -integer} msg - set msg -} "wrong argument position: should be \"prioqueue ?-ascii|-dictionary|-integer|-real? ?name?\"" - -test prioqueue-1.1 {prioqueue creation} { - set foo [prioqueue myprioqueue] - set cmd [info commands ::myprioqueue] - set size [myprioqueue size] - myprioqueue destroy - list $foo $cmd $size -} {myprioqueue ::myprioqueue 0} - -test prioqueue-1.2 {prioqueue creation} { - set foo [prioqueue] - set cmd [info commands ::$foo] - set size [$foo size] - $foo destroy - list $foo $cmd $size -} {prioqueue1 ::prioqueue1 0} - -test prioqueue-1.3 {prioqueue creation} { - set foo [prioqueue -ascii] - set cmd [info commands ::$foo] - set size [$foo size] - $foo destroy - list $foo $cmd $size -} {prioqueue2 ::prioqueue2 0} - -test prioqueue-1.5 {prioqueue creation} { - set foo [prioqueue -dictionary] - set cmd [info commands ::$foo] - set size [$foo size] - $foo destroy - list $foo $cmd $size -} {prioqueue3 ::prioqueue3 0} - -test prioqueue-1.6 {prioqueue creation} { - set foo [prioqueue -integer] - set cmd [info commands ::$foo] - set size [$foo size] - $foo destroy - list $foo $cmd $size -} {prioqueue4 ::prioqueue4 0} - -test prioqueue-1.7 {prioqueue creation} { - set foo [prioqueue -real] - set cmd [info commands ::$foo] - set size [$foo size] - $foo destroy - list $foo $cmd $size -} {prioqueue5 ::prioqueue5 0} - - -test prioqueue-2.1 {prioqueue destroy} { - prioqueue myprioqueue - myprioqueue destroy - info commands ::myprioqueue -} {} - -test prioqueue-3.2 {size operation} { - prioqueue myprioqueue - myprioqueue put a 1 b 1 c 1 d 1 e 1 f 1 g 1 - set size [myprioqueue size] - myprioqueue destroy - set size -} 7 -test prioqueue-3.3 {size operation} { - prioqueue myprioqueue - myprioqueue put a 1 b 1 c 1 d 1 e 1 f 1 g 1 - myprioqueue get 3 - set size [myprioqueue size] - myprioqueue destroy - set size -} 4 -test prioqueue-3.4 {size operation} { - prioqueue myprioqueue - myprioqueue put a 1 b 1 c 1 d 1 e 1 f 1 g 1 - myprioqueue get 3 - myprioqueue peek 3 - set size [myprioqueue size] - myprioqueue destroy - set size -} 4 - -test prioqueue-4.1 {put operation} { - prioqueue myprioqueue - catch {myprioqueue put} msg - myprioqueue destroy - set msg -} "wrong # args: should be \"myprioqueue put item prio ?item prio ...?\"" - -test prioqueue-4.1a {put operation} { - prioqueue myprioqueue - catch {myprioqueue put a} msg - myprioqueue destroy - set msg -} "wrong # args: should be \"myprioqueue put item prio ?item prio ...?\"" - -test prioqueue-4.2 {put operation, singleton items} { - prioqueue myprioqueue - myprioqueue put a 1 - myprioqueue put b 1 - myprioqueue put c 1 - set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]] - myprioqueue destroy - set result -} "a b c" - -test prioqueue-4.3 {put operation, singleton items} { - prioqueue myprioqueue - myprioqueue put a 1 - myprioqueue put b 2 - myprioqueue put c 3 - set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]] - myprioqueue destroy - set result -} "c b a" - -test prioqueue-4.4 {put operation, singleton items} { - prioqueue myprioqueue - myprioqueue put a 3 - myprioqueue put b 2 - myprioqueue put c 1 - set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]] - myprioqueue destroy - set result -} "a b c" - -test prioqueue-4.5 {put operation, singleton items} { - prioqueue myprioqueue - myprioqueue put a 3 - myprioqueue put b 1 - myprioqueue put c 2 - set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]] - myprioqueue destroy - set result -} "a c b" - -test prioqueue-4.6 {put operation, singleton items} { - prioqueue -ascii myprioqueue - myprioqueue put a a - myprioqueue put b b - myprioqueue put c c - set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]] - myprioqueue destroy - set result -} "a b c" - -test prioqueue-4.7 {put operation, singleton items} { - prioqueue -dictionary myprioqueue - myprioqueue put a a - myprioqueue put b b - myprioqueue put c c - set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]] - myprioqueue destroy - set result -} "a b c" - -test prioqueue-4.8 {put operation, singleton items} { - prioqueue -real myprioqueue - myprioqueue put a 1.0 - myprioqueue put b 2.0 - myprioqueue put c 3.0 - set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]] - myprioqueue destroy - set result -} "c b a" - -test prioqueue-4.9 {put operation, multiple items} { - prioqueue myprioqueue - myprioqueue put a 1 b 1 c 1 - set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]] - myprioqueue destroy - set result -} "a b c" - -test prioqueue-4.10 {put operation, spaces in items} { - prioqueue myprioqueue - myprioqueue put a 1 b 1 "foo bar" 1 - set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]] - myprioqueue destroy - set result -} [list a b "foo bar"] - -test prioqueue-4.11 {put operation, bad chars in items} { - prioqueue myprioqueue - myprioqueue put a 1 b 1 \{ 1 - set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]] - myprioqueue destroy - set result -} [list a b \{] - -test prioqueue-4.12 {put operation, bad priorities} { - prioqueue myprioqueue - catch {myprioqueue put a a} msg - myprioqueue destroy - set msg -} {priority "a" is not an integer type value} - -test prioqueue-4.13 {put operation, bad priorities} { - prioqueue myprioqueue - catch {myprioqueue put a 1.01} msg - myprioqueue destroy - set msg -} {priority "1.01" is not an integer type value} - -test prioqueue-4.14 {put operation, bad priorities} { - prioqueue -real myprioqueue - catch {myprioqueue put a 1a} msg - myprioqueue destroy - set msg -} {priority "1a" is not a real type value} - -test prioqueue-4.15 {put operation, bad priorities} { - prioqueue -real myprioqueue - catch {myprioqueue put a a} msg - myprioqueue destroy - set msg -} {priority "a" is not a real type value} - -test prioqueue-4.16 {put operation, checking priorities} { - prioqueue -ascii myprioqueue - catch {myprioqueue put a 1.0} msg - myprioqueue destroy - set msg -} {} - -test prioqueue-4.17 {put operation, checking priorities} { - prioqueue -dictionary myprioqueue - catch {myprioqueue put a "1.0 +1"} msg - myprioqueue destroy - set msg -} {} - - -test prioqueue-5.1 {get operation} { - prioqueue myprioqueue - myprioqueue put a 1 - myprioqueue put b 1 - myprioqueue put c 1 - set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]] - myprioqueue destroy - set result -} [list a b c] - -test prioqueue-5.2 {get operation, multiple items} { - prioqueue myprioqueue - myprioqueue put a 1 - myprioqueue put b 1 - myprioqueue put c 1 - set result [myprioqueue get 3] - myprioqueue destroy - set result -} [list a b c] - -test prioqueue-6.1 {peek operation} { - prioqueue myprioqueue - myprioqueue put a 1 - myprioqueue put b 1 - myprioqueue put c 1 - set result [list [myprioqueue peek] [myprioqueue peek] [myprioqueue peek]] - myprioqueue destroy - set result -} [list a a a] - -test prioqueue-6.2 {peek operation} { - prioqueue myprioqueue - catch {myprioqueue peek 0} msg - myprioqueue destroy - set msg -} {invalid item count 0} - -test prioqueue-6.3 {peek operation} { - prioqueue myprioqueue - catch {myprioqueue peek -1} msg - myprioqueue destroy - set msg -} {invalid item count -1} - -test prioqueue-6.4 {peek operation} { - prioqueue myprioqueue - catch {myprioqueue peek} msg - myprioqueue destroy - set msg -} {insufficient items in prioqueue to fill request} - -test prioqueue-6.5 {peek operation} { - prioqueue myprioqueue - myprioqueue put a 1 - catch {myprioqueue peek 2} msg - myprioqueue destroy - set msg -} {insufficient items in prioqueue to fill request} - -test prioqueue-6.6 {get operation, multiple items} { - prioqueue myprioqueue - myprioqueue put a 1 - myprioqueue put b 1 - myprioqueue put c 1 - set result [list [myprioqueue peek 3] [myprioqueue get 3]] - myprioqueue destroy - set result -} [list [list a b c] [list a b c]] - -test prioqueue-6.7 {get operation} { - prioqueue myprioqueue - catch {myprioqueue get 0} msg - myprioqueue destroy - set msg -} {invalid item count 0} - -test prioqueue-6.8 {get operation} { - prioqueue myprioqueue - catch {myprioqueue get -1} msg - myprioqueue destroy - set msg -} {invalid item count -1} - -test prioqueue-6.9 {get operation} { - prioqueue myprioqueue - catch {myprioqueue get} msg - myprioqueue destroy - set msg -} {insufficient items in prioqueue to fill request} - -test prioqueue-6.10 {get operation} { - prioqueue myprioqueue - myprioqueue put a 1 - catch {myprioqueue get 2} msg - myprioqueue destroy - set msg -} {insufficient items in prioqueue to fill request} - -test prioqueue-7.1 {clear operation} { - prioqueue myprioqueue - myprioqueue put a 1 - myprioqueue put b 1 - myprioqueue put c 1 - set result [list [myprioqueue peek 3]] - myprioqueue clear - lappend result [myprioqueue size] - myprioqueue destroy - set result -} [list [list a b c] 0] - -test prioqueue-8.1 {peekpriority operation} { - prioqueue myprioqueue - myprioqueue put a 1 - myprioqueue put b 2 - myprioqueue put c 3 - set result [list [myprioqueue peekpriority] [myprioqueue peekpriority] [myprioqueue peekpriority]] - myprioqueue destroy - set result -} [list 3 3 3] - -test prioqueue-8.2 {peekpriority operation, multiple items} { - prioqueue myprioqueue - myprioqueue put a 1 - myprioqueue put b 2 - myprioqueue put c 3 - set result [myprioqueue peekpriority 3] - myprioqueue destroy - set result -} [list 3 2 1] - -::tcltest::cleanupTests DELETED modules/struct/queue.man Index: modules/struct/queue.man ================================================================== --- modules/struct/queue.man +++ /dev/null @@ -1,68 +0,0 @@ -[manpage_begin queue n 1.2.1] -[moddesc {Tcl Data Structures}] -[titledesc {Create and manipulate queue objects}] -[require Tcl 8.2] -[require struct [opt 1.3]] -[description] - -The [cmd ::struct::queue] command creates a new queue object with an -associated global Tcl command whose name is [emph queueName]. This -command may be used to invoke various operations on the queue. It has -the following general form: - -[list_begin definitions] - -[call [arg queueName] [cmd option] [opt [arg "arg arg ..."]]] - -[arg Option] and the [arg arg]s determine the exact behavior of the -command. The following commands are possible for queue objects: - - -[call [arg queueName] [cmd clear]] - -Remove all items from the queue. - - -[call [arg queueName] [cmd destroy]] - -Destroy the queue, including its storage space and associated command. - - -[call [arg queueName] [cmd get] [opt "[arg count]"]] - -Return the front [arg count] items of the queue and remove them from -the queue. If [arg count] is not specified, it defaults to 1. If -[arg count] is 1, the result is a simple string; otherwise, it is a -list. If specified, [arg count] must be greater than or equal to 1. -If there are no items in the queue, this command will return - -[arg count] empty strings. - - -[call [arg queueName] [cmd peek] [opt "[arg count]"]] - -Return the front [arg count] items of the queue, without removing them -from the queue. If [arg count] is not specified, it defaults to 1. -If [arg count] is 1, the result is a simple string; otherwise, it is a -list. If specified, [arg count] must be greater than or equal to 1. -If there are no items in the queue, this command will return - -[arg count] empty strings. - - -[call [arg queueName] [cmd put] [arg item] [opt "[arg "item ..."]"]] - -Put the [arg item] or items specified into the queue. If more than -one [arg item] is given, they will be added in the order they are -listed. - - -[call [arg queueName] [cmd size]] - -Return the number of items in the queue. - - -[list_end] - -[keywords stack matrix tree graph] -[manpage_end] DELETED modules/struct/queue.n Index: modules/struct/queue.n ================================================================== --- modules/struct/queue.n +++ /dev/null @@ -1,64 +0,0 @@ -'\" -'\" Copyright (c) 1998-2000 by Ajuba Solutions. -'\" All rights reserved. -'\" -'\" RCS: @(#) $Id: queue.n,v 1.6 2002/02/01 22:59:08 andreas_kupries Exp $ -'\" -.so man.macros -.TH queue n 1.2.1 Struct "Tcl Data Structures" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -::struct::queue \- Create and manipulate queue objects -.SH SYNOPSIS -\fBpackage require Tcl 8.2\fR -.sp -\fBpackage require struct ?1.2.1?\fR -.sp -\fB::struct::queue\fR \fIqueueName\fR -.sp -.BE -.SH DESCRIPTION -.PP -The \fB::struct::queue\fR command creates a new queue object with an -associated global Tcl command whose name is \fIqueueName\fR. This command -may be used to invoke various operations on the queue. It has the -following general form: -.CS -\fIqueueName option \fR?\fIarg arg ...\fR? -.CE -\fIOption\fR and the \fIarg\fRs -determine the exact behavior of the command. The following -commands are possible for queue objects: -.TP -\fIqueueName \fBclear\fR -Remove all items from the queue. -.TP -\fIqueueName \fBdestroy\fR -Destroy the queue, including its storage space and associated command. -.TP -\fIqueueName \fBget\fR ?\fIcount\fR? -Return the front \fIcount\fR items of the queue and remove them -from the queue. If \fIcount\fR is not specified, it defaults to 1. -If \fIcount\fR is 1, the result is a simple string; otherwise, it is a list. -If specified, \fIcount\fR must be greater than or equal to 1. If -there are no items in the queue, this command will return \fIcount\fR -empty strings. -.TP -\fIqueueName \fBpeek\fR ?\fIcount\fR? -Return the front \fIcount\fR items of the queue, without removing them -from the queue. If \fIcount\fR is not specified, it defaults to 1. -If \fIcount\fR is 1, the result is a simple string; otherwise, it is a list. -If specified, \fIcount\fR must be greater than or equal to 1. If -there are no items in the queue, this command will return \fIcount\fR -empty strings. -.TP -\fIqueueName \fBput\fR \fIitem\fR ?\fIitem ...\fR? -Put the item or items specified into the queue. If more than one -item is given, they will be added in the order they are listed. -.TP -\fIqueueName \fBsize\fR -Return the number of items in the queue. - -.SH KEYWORDS -stack, queue DELETED modules/struct/queue.tcl Index: modules/struct/queue.tcl ================================================================== --- modules/struct/queue.tcl +++ /dev/null @@ -1,236 +0,0 @@ -# queue.tcl -- -# -# Queue implementation for Tcl. -# -# Copyright (c) 1998-2000 by Ajuba Solutions. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: queue.tcl,v 1.3 2000/06/02 18:43:56 ericm Exp $ - -namespace eval ::struct {} - -namespace eval ::struct::queue { - # The queues array holds all of the queues you've made - variable queues - - # counter is used to give a unique name for unnamed queues - variable counter 0 - - # commands is the list of subcommands recognized by the queue - variable commands [list \ - "clear" \ - "destroy" \ - "get" \ - "peek" \ - "put" \ - "size" \ - ] - - # Only export one command, the one used to instantiate a new queue - namespace export queue -} - -# ::struct::queue::queue -- -# -# Create a new queue with a given name; if no name is given, use -# queueX, where X is a number. -# -# Arguments: -# name name of the queue; if null, generate one. -# -# Results: -# name name of the queue created - -proc ::struct::queue::queue {{name ""}} { - variable queues - variable counter - - if { [llength [info level 0]] == 1 } { - incr counter - set name "queue${counter}" - } - - if { ![string equal [info commands ::$name] ""] } { - error "command \"$name\" already exists, unable to create queue" - } - - # Initialize the queue as empty - set queues($name) [list ] - - # Create the command to manipulate the queue - interp alias {} ::$name {} ::struct::queue::QueueProc $name - - return $name -} - -########################## -# Private functions follow - -# ::struct::queue::QueueProc -- -# -# Command that processes all queue object commands. -# -# Arguments: -# name name of the queue object to manipulate. -# args command name and args for the command -# -# Results: -# Varies based on command to perform - -proc ::struct::queue::QueueProc {name {cmd ""} args} { - # Do minimal args checks here - if { [llength [info level 0]] == 2 } { - error "wrong # args: should be \"$name option ?arg arg ...?\"" - } - - # Split the args into command and args components - if { [string equal [info commands ::struct::queue::_$cmd] ""] } { - variable commands - set optlist [join $commands ", "] - set optlist [linsert $optlist "end-1" "or"] - error "bad option \"$cmd\": must be $optlist" - } - return [eval [list ::struct::queue::_$cmd $name] $args] -} - -# ::struct::queue::_clear -- -# -# Clear a queue. -# -# Arguments: -# name name of the queue object. -# -# Results: -# None. - -proc ::struct::queue::_clear {name} { - variable queues - set queues($name) [list ] - return -} - -# ::struct::queue::_destroy -- -# -# Destroy a queue object by removing it's storage space and -# eliminating it's proc. -# -# Arguments: -# name name of the queue object. -# -# Results: -# None. - -proc ::struct::queue::_destroy {name} { - variable queues - unset queues($name) - interp alias {} ::$name {} - return -} - -# ::struct::queue::_get -- -# -# Get an item from a queue. -# -# Arguments: -# name name of the queue object. -# count number of items to get; defaults to 1 -# -# Results: -# item first count items from the queue; if there are not enough -# items in the queue, throws an error. - -proc ::struct::queue::_get {name {count 1}} { - variable queues - if { $count < 1 } { - error "invalid item count $count" - } - - if { $count > [llength $queues($name)] } { - error "insufficient items in queue to fill request" - } - - if { $count == 1 } { - # Handle this as a special case, so single item gets aren't listified - set item [lindex $queues($name) 0] - set queues($name) [lreplace $queues($name) 0 0] - return $item - } - - # Otherwise, return a list of items - set index [expr {$count - 1}] - set result [lrange $queues($name) 0 $index] - set queues($name) [lreplace $queues($name) 0 $index] - - return $result -} - -# ::struct::queue::_peek -- -# -# Retrive the value of an item on the queue without removing it. -# -# Arguments: -# name name of the queue object. -# count number of items to peek; defaults to 1 -# -# Results: -# items top count items from the queue; if there are not enough items -# to fufill the request, throws an error. - -proc ::struct::queue::_peek {name {count 1}} { - variable queues - if { $count < 1 } { - error "invalid item count $count" - } - - if { $count > [llength $queues($name)] } { - error "insufficient items in queue to fill request" - } - - if { $count == 1 } { - # Handle this as a special case, so single item pops aren't listified - return [lindex $queues($name) 0] - } - - # Otherwise, return a list of items - set index [expr {$count - 1}] - return [lrange $queues($name) 0 $index] -} - -# ::struct::queue::_put -- -# -# Put an item into a queue. -# -# Arguments: -# name name of the queue object -# args items to put. -# -# Results: -# None. - -proc ::struct::queue::_put {name args} { - variable queues - if { [llength $args] == 0 } { - error "wrong # args: should be \"$name put item ?item ...?\"" - } - foreach item $args { - lappend queues($name) $item - } - return -} - -# ::struct::queue::_size -- -# -# Return the number of objects on a queue. -# -# Arguments: -# name name of the queue object. -# -# Results: -# count number of items on the queue. - -proc ::struct::queue::_size {name} { - variable queues - return [llength $queues($name)] -} DELETED modules/struct/queue.test Index: modules/struct/queue.test ================================================================== --- modules/struct/queue.test +++ /dev/null @@ -1,232 +0,0 @@ -# -*- tcl -*- -# queue.test: tests for the queue package. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 1998-2000 by Ajuba Solutions. -# All rights reserved. -# -# RCS: @(#) $Id: queue.test,v 1.5 2002/02/01 21:51:42 andreas_kupries Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -source [file join [file dirname [info script]] queue.tcl] -namespace import struct::queue::queue - -test queue-0.1 {queue errors} { - queue myqueue - catch {queue myqueue} msg - myqueue destroy - set msg -} "command \"myqueue\" already exists, unable to create queue" -test queue-0.2 {queue errors} { - queue myqueue - catch {myqueue} msg - myqueue destroy - set msg -} "wrong # args: should be \"myqueue option ?arg arg ...?\"" -test queue-0.3 {queue errors} { - queue myqueue - catch {myqueue foo} msg - myqueue destroy - set msg -} "bad option \"foo\": must be clear, destroy, get, peek, put, or size" -test queue-0.4 {queue errors} { - catch {queue set} msg - set msg -} "command \"set\" already exists, unable to create queue" - -test queue-1.1 {queue creation} { - set foo [queue myqueue] - set cmd [info commands ::myqueue] - set size [myqueue size] - myqueue destroy - list $foo $cmd $size -} {myqueue ::myqueue 0} -test queue-1.2 {queue creation} { - set foo [queue] - set cmd [info commands ::$foo] - set size [$foo size] - $foo destroy - list $foo $cmd $size -} {queue1 ::queue1 0} - -test queue-2.1 {queue destroy} { - queue myqueue - myqueue destroy - info commands ::myqueue -} {} - -test queue-3.2 {size operation} { - queue myqueue - myqueue put a b c d e f g - set size [myqueue size] - myqueue destroy - set size -} 7 -test queue-3.3 {size operation} { - queue myqueue - myqueue put a b c d e f g - myqueue get 3 - set size [myqueue size] - myqueue destroy - set size -} 4 -test queue-3.4 {size operation} { - queue myqueue - myqueue put a b c d e f g - myqueue get 3 - myqueue peek 3 - set size [myqueue size] - myqueue destroy - set size -} 4 - -test queue-4.1 {put operation} { - queue myqueue - catch {myqueue put} msg - myqueue destroy - set msg -} "wrong # args: should be \"myqueue put item ?item ...?\"" -test queue-4.2 {put operation, singleton items} { - queue myqueue - myqueue put a - myqueue put b - myqueue put c - set result [list [myqueue get] [myqueue get] [myqueue get]] - myqueue destroy - set result -} "a b c" -test queue-4.3 {put operation, multiple items} { - queue myqueue - myqueue put a b c - set result [list [myqueue get] [myqueue get] [myqueue get]] - myqueue destroy - set result -} "a b c" -test queue-4.4 {put operation, spaces in items} { - queue myqueue - myqueue put a b "foo bar" - set result [list [myqueue get] [myqueue get] [myqueue get]] - myqueue destroy - set result -} [list a b "foo bar"] -test queue-4.5 {put operation, bad chars in items} { - queue myqueue - myqueue put a b \{ - set result [list [myqueue get] [myqueue get] [myqueue get]] - myqueue destroy - set result -} [list a b \{] - -test queue-5.1 {get operation} { - queue myqueue - myqueue put a - myqueue put b - myqueue put c - set result [list [myqueue get] [myqueue get] [myqueue get]] - myqueue destroy - set result -} [list a b c] -test queue-5.2 {get operation, multiple items} { - queue myqueue - myqueue put a - myqueue put b - myqueue put c - set result [myqueue get 3] - myqueue destroy - set result -} [list a b c] - -test queue-6.1 {peek operation} { - queue myqueue - myqueue put a - myqueue put b - myqueue put c - set result [list [myqueue peek] [myqueue peek] [myqueue peek]] - myqueue destroy - set result -} [list a a a] - -test queue-6.2 {peek operation} { - queue myqueue - catch {myqueue peek 0} msg - myqueue destroy - set msg -} {invalid item count 0} -test queue-6.3 {peek operation} { - queue myqueue - catch {myqueue peek -1} msg - myqueue destroy - set msg -} {invalid item count -1} -test queue-6.4 {peek operation} { - queue myqueue - catch {myqueue peek} msg - myqueue destroy - set msg -} {insufficient items in queue to fill request} -test queue-6.5 {peek operation} { - queue myqueue - myqueue put a - catch {myqueue peek 2} msg - myqueue destroy - set msg -} {insufficient items in queue to fill request} - -test queue-6.6 {get operation, multiple items} { - queue myqueue - myqueue put a - myqueue put b - myqueue put c - set result [list [myqueue peek 3] [myqueue get 3]] - myqueue destroy - set result -} [list [list a b c] [list a b c]] - -test queue-6.7 {get operation} { - queue myqueue - catch {myqueue get 0} msg - myqueue destroy - set msg -} {invalid item count 0} -test queue-6.8 {get operation} { - queue myqueue - catch {myqueue get -1} msg - myqueue destroy - set msg -} {invalid item count -1} -test queue-6.9 {get operation} { - queue myqueue - catch {myqueue get} msg - myqueue destroy - set msg -} {insufficient items in queue to fill request} -test queue-6.10 {get operation} { - queue myqueue - myqueue put a - catch {myqueue get 2} msg - myqueue destroy - set msg -} {insufficient items in queue to fill request} - - - -test queue-7.1 {clear operation} { - queue myqueue - myqueue put a - myqueue put b - myqueue put c - set result [list [myqueue peek 3]] - myqueue clear - lappend result [myqueue size] - myqueue destroy - set result -} [list [list a b c] 0] - -::tcltest::cleanupTests DELETED modules/struct/record.html Index: modules/struct/record.html ================================================================== --- modules/struct/record.html +++ /dev/null @@ -1,436 +0,0 @@ -record - Tcl Data Structures - - - - - -

record(n) 1.2.1 record "Tcl Data Structures"

-

NAME

-

record - Define and create records (similar to 'C' structures) - - - - -

SYNOPSIS

-package require Tcl 8.2
-package require struct ?1.2.1?
-
- - - - - - - - - - - -
record define recordName recordMembers ?instanceName1 instanceName2 ...?
record show record
record show instances recordName
record show members recordName
record show values instanceName
record exists record recordName
record exists instance instanceName
record delete record recordName
record delete instance instanceName
recordName instanceName|#auto ?-member1 value1 -member2 value2 ...?
instanceName cget ?-member1 -member2 ...?
instanceName configure ?-member1 value1 -member2 value2 ...?
-

DESCRIPTION

- -The ::struct::record package provides a mechanism to group variables together -as one data structure, similar to a 'C' structure. The members of a -record can be variables or other records. However, a record can not contain circular -record, i.e. records that contain the same record as a -member. - -

-This package was structured so that it is very similar to how Tk objects work. Each record -definition creates a record object that encompasses that definition. Subsequently, that -record object can create instances of that record. These instances can then -be manipulated with the cget and configure methods. - -

-The package only contains one top level command, but several sub commands (see below). It also obeys the namespace in which the record was define, hence the objects returned are fully qualified. - -

- -
record define recordName recordMembers ?instanceName1 instanceName2 ...?
- - -Defines a record. recordName is the name of the record, and is also -used as an object command. This object command is used to create instances of the -record definition. recordMembers are the members of -the record that make up the record definition. These are variables -and other record. If optional instanceName args are given, then an instance -is generated after the definition is created for each instanceName. - -

-
record show record
- - -Returns a list of records that have been defined. - -

-
record show instances recordName
- - -Returns the instances that have been instantiated by -recordName. - -

-
record show members recordName
- - -Returns the members that are defined for -record recordName. It returns the same format as how the -records were defined. - -

-
record show values instanceName
- - -Returns a list of values that are set for the instance -instanceName. The output is a list of key/value pairs. If there -are nested records, then the values of the nested records will -itself be a list. - -

-
record exists record recordName
- - -Tests for the existence of a record with the -name recordName. - -

-
record exists instance instanceName
- - -Tests for the existence of a instance with the -name instanceName. - -

-
record delete record recordName
- - -Deletes recordName, and all instances of recordName. It will return -an error if the record does not exist. - -

-
record delete instance instanceName
- - -Deletes instance with the name of instanceName. It -will return an error if the instance does not exist. - -
-

- -

RECORD MEMBERS

- -Record members can either be variables, or other records, However, the same -record can not be nested witin itself (circular). To define a nested record, -you need to specify the record keyword, along the with name of the record, and the name of the instance of that nested -record. For example, it would look like this: - -

-

 
-# this is the nested record
-record define mynestedrecord {
-    nest1
-    nest2
-}
-
-# This is the main record
-record define myrecord {
-    mem1
-    mem2
-    {record mynestedrecord mem3}
-}
-
-

- -You can also assign default or initial values to the members of a record, -by enclosing the member entry in braces: - -

-

 
-
-record define myrecord {
-    mem1
-    {mem2 5}
-}
-
-

- -All instances created from this record definition, will initially have 5 as -the value for mem2. If no default is given, then the value will be the empty string. - -

-Getting Values -

- -To get a value of a member, there are several ways to do this. - -

    - -
  1. -To get a member value, then use the instance built-in cget method: -

    - instanceName cget -mem1 - -

    -
  2. -To get multiple member values, you can specify them all in one command: -

    - instanceName cget -mem1 -mem2 - -

    -
  3. -To get a list of the key/value of all of the members, there are 3 ways: -

    - - instanceName cget -

    - - instanceName configure -

    - - instanceName - -

    -
  4. -To get a value of a nested member, then use the dot notation: -

    - instanceName cget -mem3.nest1 - -
- -

-Setting Values -

- -To set a value of a member, there are several ways to do this. - -

    - -
  1. -To set a member value, then use the instance built-in configure method: -

    - instanceName configure -mem1 val1 - -

    -
  2. -To set multiple member values, you can specify them all in one command: -

    - instanceName configure -mem1 va1 -mem2 val2 - -

    -
  3. -To set a value of a nested member, then use the dot notation: -

    - instanceName configure -mem3.nest1 value - -
- -

-Alias access -

- -In the original implementation, access was done by using dot notation similar to how 'C' structures are accessed. However, -there was a concensus to make the interface more Tcl like, which made sense. However, the original alias access still -exists. It might prove to be helpful to some. - -

-Basically, for every member of every instance, an alias is created. This alias is used to get and set values for that -member. An example will illustrate the point, using the above defined records: - -

-

 
-# Create an instance first
-% myrecord inst1
-::inst1
-% # To get a member of an instance, just use the 
-% # alias (it behaves like a Tcl command):
-% inst1.mem1
-%
-% # To set a member via the alias, just include 
-% # a value (optionally the equal sign - syntactic sugar)
-% inst1.mem1 = 5
-5
-% inst1.mem1
-5
-% # For nested records, just continue with the 
-% # dot notation (note no equal sign)
-% inst1.mem3.nest1 10
-10
-% inst1.mem3.nest1
-10
-% # just the instance by itself gives all 
-% # member/values pairs for that instance
-% inst1
--mem1 5 -mem2 {} -mem3 {-nest1 10 -nest2 {}}
-% # and to get all members within the nested record
-% inst1.mem3
--nest1 10 -nest2 {}
-%
-
-

- -

RECORD COMMAND

- -The following subcommands and corresponding arguments are available to any -record command: - -
- -
recordName instanceName|#auto ?-member1 value1 -member2 value2 ...?
- - -Using the recordName object command that was created from the record definition, -instances of the record definition can be created. Once a instance is -created, then it inherits the members of the record definition, very -similar to how objects work. During instance generation, an object command for the instance -is created as well, using instanceName. This object command is used -to access the data members of the instance. During the instantiation, values for -that instance can be given, but all values must be given, and be given -in key/value pairs. Nested records, need to be in list format. - -

-Optionally, #auto can be used in place of instanceName. When #auto is used, -then a instance name will automatically be generated, of the form recordName<integer>, where -<integer> is a unique integer (starting at 0) that is generated. - -
-

- -

INSTANCE COMMAND

- -The following subcommands and corresponding arguments are available to -any record instance command: - -
- -
instanceName cget ?-member1 -member2 ...?
- - -Each instance has the sub command cget associated with it. This -is very similar to how Tk widget's cget command works. It queries -the values of the member for that particular instance. If -no arguments are given, then a key/value list is returned. - -

-
instanceName configure ?-member1 value1 -member2 value2 ...?
- - -Each instance has the sub command configure associated with it. This -is very similar to how Tk widget's configure command works. It sets -the values of the particular member for that particular instance. If -no arguments are given, then a key/value list is returned. - -
- -

EXAMPLES

- -Two examples are provided to give an good illustration on how to use -this package. - -

-Example 1 -

- -Probably the most obvious example would be to hold contact information, -such as addresses, phone numbers, comments, etc. Since a person can have -multiple phone numbers, multiple email addresses, etc, we will use nested -records to define these. So, the first thing we do is define the nested -records: - -

-

 
-
-##
-##  This is an interactive example, to see what is 
-##  returned by each command as well.
-##
-
-% namespace import ::struct::record::*
-
-% # define a nested record. Notice that country has default 'USA'.
-% record define locations {
-    street
-    street2
-    city
-    state
-    zipcode
-    {country USA}
-    phone
-}
-::locations
-% # Define the main record. Notice that it uses the location record twice.
-% record define contacts {
-    first 
-    middle 
-    last 
-    {record locations home}
-    {record locations work}
-}
-::contacts
-% # Create an instance for the contacts record.
-% contacts cont1
-::cont1
-% # Display some introspection values
-% record show records
-::contacts ::locations
-% #
-% record show values cont1
--first {} -middle {} -last {} -home {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -work {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}}
-% #
-% record show instances contacts
-::cont1
-% #
-% cont1 config
--first {} -middle {} -last {} -home {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -work {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}}
-% #
-% cont1 cget
--first {} -middle {} -last {} -home {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -work {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}}
-% # copy one record to another record
-% record define contacts2 [record show members contacts]
-::contacts2
-% record show members contacts2
-first middle last {record locations home} {record locations work}
-% record show members contacts
-first middle last {record locations home} {record locations work}
-%
-

- -

-Example 1 -

- -This next example just illustrates a simple linked list -

-

 
-
-% # define a very simple record for linked list
-% record define llist {
-    value
-    next
-}
-::llist
-% llist lstart
-::lstart
-% lstart config -value 1 -next [llist #auto]
-% [lstart cget -next] config -value 2 -next [llist #auto]
-% [[lstart cget -next] cget -next] config -value 3 -next "end"
-% set next lstart
-lstart
-% while 1 {
-lappend values [$next cget -value]
-set next [$next cget -next]
-if {[string match "end" $next]} {break}
-}
-% puts "$values"
-1 2 3
-% # cleanup linked list
-% # We could just use delete record llist also
-% foreach I [record show instances llist] {
-record delete instance $I
-}
-% record show instances llist
-%
-
-

- -

- -

KEYWORDS

-struct, record, data structures - DELETED modules/struct/record.man Index: modules/struct/record.man ================================================================== --- modules/struct/record.man +++ /dev/null @@ -1,388 +0,0 @@ -[comment {-*- tcl -*-}] -[manpage_begin record n 1.2.1] -[copyright {2002, Brett Schwarz }] -[moddesc {Tcl Data Structures}] -[titledesc {Define and create records (similar to 'C' structures)}] -[require Tcl 8.2] -[require struct [opt 1.3]] -[description] - -The [cmd ::struct::record] package provides a mechanism to group variables together -as one data structure, similar to a 'C' structure. The members of a -record can be variables or other records. However, a record can not contain circular -record, i.e. records that contain the same record as a -member. - -[para] -This package was structured so that it is very similar to how Tk objects work. Each record -definition creates a record object that encompasses that definition. Subsequently, that -record object can create instances of that record. These instances can then -be manipulated with the [method cget] and [method configure] methods. - -[para] -The package only contains one top level command, but several sub commands (see below). It also obeys the namespace in which the record was define, hence the objects returned are fully qualified. - -[list_begin definitions] - -[call [cmd {record define}] [arg recordName] [arg recordMembers] [opt [arg "instanceName1 instanceName2 ..."]]] - -Defines a record. [arg recordName] is the name of the record, and is also -used as an object command. This object command is used to create instances of the -record definition. [arg recordMembers] are the members of -the record that make up the record definition. These are variables -and other record. If optional [arg instanceName] args are given, then an instance -is generated after the definition is created for each [arg instanceName]. - -[call [cmd {record show}] [arg record]] - -Returns a list of records that have been defined. - -[call [cmd {record show}] [arg instances] [arg recordName]] - -Returns the instances that have been instantiated by -[arg recordName]. - -[call [cmd {record show}] [arg members] [arg recordName]] - -Returns the members that are defined for -record [arg recordName]. It returns the same format as how the -records were defined. - -[call [cmd {record show}] [arg values] [arg instanceName]] - -Returns a list of values that are set for the instance -[arg instanceName]. The output is a list of key/value pairs. If there -are nested records, then the values of the nested records will -itself be a list. - -[call [cmd {record exists}] [arg record] [arg recordName]] - -Tests for the existence of a [arg record] with the -name [arg recordName]. - -[call [cmd {record exists}] [arg instance] [arg instanceName]] - -Tests for the existence of a [arg instance] with the -name [arg instanceName]. - -[call [cmd {record delete}] [arg record] [arg recordName]] - -Deletes [arg recordName], and all instances of [arg recordName]. It will return -an error if the record does not exist. - -[call [cmd {record delete}] [arg instance] [arg instanceName]] - -Deletes [arg instance] with the name of [arg instanceName]. It -will return an error if the instance does not exist. - -[list_end] -[para] - -[section {RECORD MEMBERS}] - -Record members can either be variables, or other records, However, the -same record can not be nested witin itself (circular). To define a -nested record, you need to specify the [const record] keyword, along -the with name of the record, and the name of the instance of that -nested record. For example, it would look like this: - -[para] -[example_begin] -# this is the nested record -record define mynestedrecord { - nest1 - nest2 -} - -# This is the main record -record define myrecord { - mem1 - mem2 - {record mynestedrecord mem3} -} - -[example_end] - -You can also assign default or initial values to the members of a record, -by enclosing the member entry in braces: - -[para] -[example_begin] - -record define myrecord { - mem1 - {mem2 5} -} - -[example_end] - -All instances created from this record definition, will initially have 5 as -the value for [arg mem2]. If no default is given, then the value will be the empty string. - -[para] -[emph {Getting Values}] -[para] - -To get a value of a member, there are several ways to do this. - -[list_begin enum] - -[enum] -To get a member value, then use the instance built-in [method cget] method: -[nl] - [arg instanceName] [method cget] -mem1 - -[enum] -To get multiple member values, you can specify them all in one command: -[nl] - [arg instanceName] [method cget] -mem1 -mem2 - -[enum] -To get a list of the key/value of all of the members, there are 3 ways: -[nl] - - [arg instanceName] [method cget] -[nl] - - [arg instanceName] [method configure] -[nl] - - [arg instanceName] - -[enum] -To get a value of a nested member, then use the dot notation: -[nl] - [arg instanceName] [method cget] -mem3.nest1 - -[list_end] - -[para] -[emph {Setting Values}] -[para] - -To set a value of a member, there are several ways to do this. - -[list_begin enum] - -[enum] -To set a member value, then use the instance built-in [method configure] method: -[nl] - [arg instanceName] [method configure] -mem1 val1 - -[enum] -To set multiple member values, you can specify them all in one command: -[nl] - [arg instanceName] [method configure] -mem1 va1 -mem2 val2 - -[enum] -To set a value of a nested member, then use the dot notation: -[nl] - [arg instanceName] [method configure] -mem3.nest1 value - -[list_end] - -[para] -[emph {Alias access}] -[para] - -In the original implementation, access was done by using dot notation similar to how 'C' structures are accessed. However, -there was a concensus to make the interface more Tcl like, which made sense. However, the original alias access still -exists. It might prove to be helpful to some. - -[para] -Basically, for every member of every instance, an alias is created. This alias is used to get and set values for that -member. An example will illustrate the point, using the above defined records: - -[para] -[example_begin] -# Create an instance first -% myrecord inst1 -::inst1 -% # To get a member of an instance, just use the -% # alias (it behaves like a Tcl command): -% inst1.mem1 -% -% # To set a member via the alias, just include -% # a value (optionally the equal sign - syntactic sugar) -% inst1.mem1 = 5 -5 -% inst1.mem1 -5 -% # For nested records, just continue with the -% # dot notation (note no equal sign) -% inst1.mem3.nest1 10 -10 -% inst1.mem3.nest1 -10 -% # just the instance by itself gives all -% # member/values pairs for that instance -% inst1 --mem1 5 -mem2 {} -mem3 {-nest1 10 -nest2 {}} -% # and to get all members within the nested record -% inst1.mem3 --nest1 10 -nest2 {} -% - -[example_end] - -[section {RECORD COMMAND}] - -The following subcommands and corresponding arguments are available to any -record command: - -[list_begin definitions] - -[call [arg recordName] [method [arg instanceName|#auto]] [opt [arg "-member1 value1 -member2 value2 ..."]]] - -Using the [arg recordName] object command that was created from the record definition, -instances of the record definition can be created. Once a instance is -created, then it inherits the members of the record definition, very -similar to how objects work. During instance generation, an object command for the instance -is created as well, using [arg instanceName]. This object command is used -to access the data members of the instance. During the instantiation, values for -that instance can be given, [emph but] all values must be given, and be given -in key/value pairs. Nested records, need to be in list format. - -[nl] -Optionally, [arg #auto] can be used in place of [arg instanceName]. When #auto is used, -then a instance name will automatically be generated, of the form recordName, where - is a unique integer (starting at 0) that is generated. - -[list_end] -[para] - -[section {INSTANCE COMMAND}] - -The following subcommands and corresponding arguments are available to -any record instance command: - -[list_begin definitions] - -[call [arg instanceName] [method cget] [opt [arg "-member1 -member2 ..."]]] - -Each instance has the sub command [method cget] associated with it. This -is very similar to how Tk widget's cget command works. It queries -the values of the member for that particular instance. If -no arguments are given, then a key/value list is returned. - -[call [arg instanceName] [method configure] [opt [arg "-member1 value1 -member2 value2 ..."]]] - -Each instance has the sub command [method configure] associated with it. This -is very similar to how Tk widget's configure command works. It sets -the values of the particular member for that particular instance. If -no arguments are given, then a key/value list is returned. - -[list_end] - -[section EXAMPLES] - -Two examples are provided to give an good illustration on how to use -this package. - -[para] -[emph {Example 1}] -[para] - -Probably the most obvious example would be to hold contact information, -such as addresses, phone numbers, comments, etc. Since a person can have -multiple phone numbers, multiple email addresses, etc, we will use nested -records to define these. So, the first thing we do is define the nested -records: - -[para] -[example { - -## -## This is an interactive example, to see what is -## returned by each command as well. -## - -% namespace import ::struct::record::* - -% # define a nested record. Notice that country has default 'USA'. -% record define locations { - street - street2 - city - state - zipcode - {country USA} - phone -} -::locations -% # Define the main record. Notice that it uses the location record twice. -% record define contacts { - first - middle - last - {record locations home} - {record locations work} -} -::contacts -% # Create an instance for the contacts record. -% contacts cont1 -::cont1 -% # Display some introspection values -% record show records -::contacts ::locations -% # -% record show values cont1 --first {} -middle {} -last {} -home {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -work {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -% # -% record show instances contacts -::cont1 -% # -% cont1 config --first {} -middle {} -last {} -home {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -work {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -% # -% cont1 cget --first {} -middle {} -last {} -home {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -work {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -% # copy one record to another record -% record define contacts2 [record show members contacts] -::contacts2 -% record show members contacts2 -first middle last {record locations home} {record locations work} -% record show members contacts -first middle last {record locations home} {record locations work} -% -}] - -[para] -[emph {Example 1}] -[para] - -This next example just illustrates a simple linked list -[para] -[example { - -% # define a very simple record for linked list -% record define llist { - value - next -} -::llist -% llist lstart -::lstart -% lstart config -value 1 -next [llist #auto] -% [lstart cget -next] config -value 2 -next [llist #auto] -% [[lstart cget -next] cget -next] config -value 3 -next "end" -% set next lstart -lstart -% while 1 { -lappend values [$next cget -value] -set next [$next cget -next] -if {[string match "end" $next]} {break} -} -% puts "$values" -1 2 3 -% # cleanup linked list -% # We could just use delete record llist also -% foreach I [record show instances llist] { -record delete instance $I -} -% record show instances llist -% - -}] - -[para] - -[keywords struct record {data structures}] -[manpage_end] DELETED modules/struct/record.n Index: modules/struct/record.n ================================================================== --- modules/struct/record.n +++ /dev/null @@ -1,350 +0,0 @@ -'\" -'\" Generated from record.man by mpexpand with fmt.nroff -'\" -.so man.macros -.TH "record" n 1.2.1 record "Tcl Data Structures" -.BS -.SH NAME -record \- Define and create records (similar to 'C' structures) -'\" -*- tcl -*- -'\" Author: Brett Schwarz -.SH "SYNOPSIS" -package require \fBTcl 8.2\fR -.sp -package require \fBstruct ?1.2.1?\fR -.sp -\fBrecord define\fR \fIrecordName\fR \fIrecordMembers\fR ?\fIinstanceName1 instanceName2 ...\fR?\fR -.sp -\fBrecord show\fR \fIrecord\fR\fR -.sp -\fBrecord show\fR \fIinstances\fR \fIrecordName\fR\fR -.sp -\fBrecord show\fR \fImembers\fR \fIrecordName\fR\fR -.sp -\fBrecord show\fR \fIvalues\fR \fIinstanceName\fR\fR -.sp -\fBrecord exists\fR \fIrecord\fR \fIrecordName\fR\fR -.sp -\fBrecord exists\fR \fIinstance\fR \fIinstanceName\fR\fR -.sp -\fBrecord delete\fR \fIrecord\fR \fIrecordName\fR\fR -.sp -\fBrecord delete\fR \fIinstance\fR \fIinstanceName\fR\fR -.sp -\fIrecordName\fR \fB\fIinstanceName|#auto\fR\fR ?\fI-member1 value1 -member2 value2 ...\fR?\fR -.sp -\fIinstanceName\fR \fBcget\fR ?\fI-member1 -member2 ...\fR?\fR -.sp -\fIinstanceName\fR \fBconfigure\fR ?\fI-member1 value1 -member2 value2 ...\fR?\fR -.sp -.BE -.SH "DESCRIPTION" -The \fB::struct::record\fR package provides a mechanism to group variables together -as one data structure, similar to a 'C' structure. The members of a -record can be variables or other records. However, a record can not contain circular -record, i.e. records that contain the same record as a -member. -.PP -This package was structured so that it is very similar to how Tk objects work. Each record -definition creates a record object that encompasses that definition. Subsequently, that -record object can create instances of that record. These instances can then -be manipulated with the \fBcget\fR and \fBconfigure\fR methods. -.PP -The package only contains one top level command, but several sub commands (see below). It also obeys the namespace in which the record was define, hence the objects returned are fully qualified. -.TP -\fBrecord define\fR \fIrecordName\fR \fIrecordMembers\fR ?\fIinstanceName1 instanceName2 ...\fR?\fR -Defines a record. \fIrecordName\fR is the name of the record, and is also -used as an object command. This object command is used to create instances of the -record definition. \fIrecordMembers\fR are the members of -the record that make up the record definition. These are variables -and other record. If optional \fIinstanceName\fR args are given, then an instance -is generated after the definition is created for each \fIinstanceName\fR. -.TP -\fBrecord show\fR \fIrecord\fR\fR -Returns a list of records that have been defined. -.TP -\fBrecord show\fR \fIinstances\fR \fIrecordName\fR\fR -Returns the instances that have been instantiated by -\fIrecordName\fR. -.TP -\fBrecord show\fR \fImembers\fR \fIrecordName\fR\fR -Returns the members that are defined for -record \fIrecordName\fR. It returns the same format as how the -records were defined. -.TP -\fBrecord show\fR \fIvalues\fR \fIinstanceName\fR\fR -Returns a list of values that are set for the instance -\fIinstanceName\fR. The output is a list of key/value pairs. If there -are nested records, then the values of the nested records will -itself be a list. -.TP -\fBrecord exists\fR \fIrecord\fR \fIrecordName\fR\fR -Tests for the existence of a \fIrecord\fR with the -name \fIrecordName\fR. -.TP -\fBrecord exists\fR \fIinstance\fR \fIinstanceName\fR\fR -Tests for the existence of a \fIinstance\fR with the -name \fIinstanceName\fR. -.TP -\fBrecord delete\fR \fIrecord\fR \fIrecordName\fR\fR -Deletes \fIrecordName\fR, and all instances of \fIrecordName\fR. It will return -an error if the record does not exist. -.TP -\fBrecord delete\fR \fIinstance\fR \fIinstanceName\fR\fR -Deletes \fIinstance\fR with the name of \fIinstanceName\fR. It -will return an error if the instance does not exist. -.PP -.SH "RECORD MEMBERS" -Record members can either be variables, or other records, However, the same -record can not be nested witin itself (circular). To define a nested record, -you need to specify the \fBrecord\fR keyword, along the with name of the record, and the name of the instance of that nested -record. For example, it would look like this: -.PP -.nf -# this is the nested record -record define mynestedrecord { - nest1 - nest2 -} - -# This is the main record -record define myrecord { - mem1 - mem2 - {record mynestedrecord mem3} -} - -.fi -You can also assign default or initial values to the members of a record, -by enclosing the member entry in braces: -.PP -.nf - -record define myrecord { - mem1 - {mem2 5} -} - -.fi -All instances created from this record definition, will initially have 5 as -the value for \fImem2\fR. If no default is given, then the value will be the empty string. -.PP -\fBGetting Values\fR -.PP -To get a value of a member, there are several ways to do this. -.IP [1] -To get a member value, then use the instance built-in \fBcget\fR method: -.sp -\fIinstanceName\fR \fBcget\fR -mem1 -.IP [2] -To get multiple member values, you can specify them all in one command: -.sp -\fIinstanceName\fR \fBcget\fR -mem1 -mem2 -.IP [3] -To get a list of the key/value of all of the members, there are 3 ways: -.sp -- \fIinstanceName\fR \fBcget\fR -.sp -- \fIinstanceName\fR \fBconfigure\fR -.sp -- \fIinstanceName\fR -.IP [4] -To get a value of a nested member, then use the dot notation: -.sp -\fIinstanceName\fR \fBcget\fR -mem3.nest1 -.PP -\fBSetting Values\fR -.PP -To set a value of a member, there are several ways to do this. -.IP [1] -To set a member value, then use the instance built-in \fBconfigure\fR method: -.sp -\fIinstanceName\fR \fBconfigure\fR -mem1 val1 -.IP [2] -To set multiple member values, you can specify them all in one command: -.sp -\fIinstanceName\fR \fBconfigure\fR -mem1 va1 -mem2 val2 -.IP [3] -To set a value of a nested member, then use the dot notation: -.sp -\fIinstanceName\fR \fBconfigure\fR -mem3.nest1 value -.PP -\fBAlias access\fR -.PP -In the original implementation, access was done by using dot notation similar to how 'C' structures are accessed. However, -there was a concensus to make the interface more Tcl like, which made sense. However, the original alias access still -exists. It might prove to be helpful to some. -.PP -Basically, for every member of every instance, an alias is created. This alias is used to get and set values for that -member. An example will illustrate the point, using the above defined records: -.PP -.nf -# Create an instance first -% myrecord inst1 -::inst1 -% # To get a member of an instance, just use the -% # alias (it behaves like a Tcl command): -% inst1.mem1 -% -% # To set a member via the alias, just include -% # a value (optionally the equal sign - syntactic sugar) -% inst1.mem1 = 5 -5 -% inst1.mem1 -5 -% # For nested records, just continue with the -% # dot notation (note no equal sign) -% inst1.mem3.nest1 10 -10 -% inst1.mem3.nest1 -10 -% # just the instance by itself gives all -% # member/values pairs for that instance -% inst1 --mem1 5 -mem2 {} -mem3 {-nest1 10 -nest2 {}} -% # and to get all members within the nested record -% inst1.mem3 --nest1 10 -nest2 {} -% - -.fi -.SH "RECORD COMMAND" -The following subcommands and corresponding arguments are available to any -record command: -.TP -\fIrecordName\fR \fB\fIinstanceName|#auto\fR\fR ?\fI-member1 value1 -member2 value2 ...\fR?\fR -Using the \fIrecordName\fR object command that was created from the record definition, -instances of the record definition can be created. Once a instance is -created, then it inherits the members of the record definition, very -similar to how objects work. During instance generation, an object command for the instance -is created as well, using \fIinstanceName\fR. This object command is used -to access the data members of the instance. During the instantiation, values for -that instance can be given, \fBbut\fR all values must be given, and be given -in key/value pairs. Nested records, need to be in list format. -.sp -Optionally, \fI#auto\fR can be used in place of \fIinstanceName\fR. When #auto is used, -then a instance name will automatically be generated, of the form recordName, where - is a unique integer (starting at 0) that is generated. -.PP -.SH "INSTANCE COMMAND" -The following subcommands and corresponding arguments are available to -any record instance command: -.TP -\fIinstanceName\fR \fBcget\fR ?\fI-member1 -member2 ...\fR?\fR -Each instance has the sub command \fBcget\fR associated with it. This -is very similar to how Tk widget's cget command works. It queries -the values of the member for that particular instance. If -no arguments are given, then a key/value list is returned. -.TP -\fIinstanceName\fR \fBconfigure\fR ?\fI-member1 value1 -member2 value2 ...\fR?\fR -Each instance has the sub command \fBconfigure\fR associated with it. This -is very similar to how Tk widget's configure command works. It sets -the values of the particular member for that particular instance. If -no arguments are given, then a key/value list is returned. -.SH "EXAMPLES" -Two examples are provided to give an good illustration on how to use -this package. -.PP -\fBExample 1\fR -.PP -Probably the most obvious example would be to hold contact information, -such as addresses, phone numbers, comments, etc. Since a person can have -multiple phone numbers, multiple email addresses, etc, we will use nested -records to define these. So, the first thing we do is define the nested -records: -.PP -.nf - -## -## This is an interactive example, to see what is -## returned by each command as well. -## - -% namespace import ::struct::record::* - -% # define a nested record. Notice that country has default 'USA'. -% record define locations { - street - street2 - city - state - zipcode - {country USA} - phone -} -::locations -% # Define the main record. Notice that it uses the location record twice. -% record define contacts { - first - middle - last - {record locations home} - {record locations work} -} -::contacts -% # Create an instance for the contacts record. -% contacts cont1 -::cont1 -% # Display some introspection values -% record show records -::contacts ::locations -% # -% record show values cont1 --first {} -middle {} -last {} -home {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -work {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -% # -% record show instances contacts -::cont1 -% # -% cont1 config --first {} -middle {} -last {} -home {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -work {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -% # -% cont1 cget --first {} -middle {} -last {} -home {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -work {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -% # copy one record to another record -% record define contacts2 [record show members contacts] -::contacts2 -% record show members contacts2 -first middle last {record locations home} {record locations work} -% record show members contacts -first middle last {record locations home} {record locations work} -% -.fi -.PP -\fBExample 1\fR -.PP -This next example just illustrates a simple linked list -.PP -.nf - -% # define a very simple record for linked list -% record define llist { - value - next -} -::llist -% llist lstart -::lstart -% lstart config -value 1 -next [llist #auto] -% [lstart cget -next] config -value 2 -next [llist #auto] -% [[lstart cget -next] cget -next] config -value 3 -next "end" -% set next lstart -lstart -% while 1 { -lappend values [$next cget -value] -set next [$next cget -next] -if {[string match "end" $next]} {break} -} -% puts "$values" -1 2 3 -% # cleanup linked list -% # We could just use delete record llist also -% foreach I [record show instances llist] { -record delete instance $I -} -% record show instances llist -% - -.fi -.PP -.SH "KEYWORDS" -struct, record, data structures DELETED modules/struct/record.tcl Index: modules/struct/record.tcl ================================================================== --- modules/struct/record.tcl +++ /dev/null @@ -1,756 +0,0 @@ -#============================================================ -# ::struct::record -- -# -# Implements a container data structure similar to a 'C' -# structure. It hides the ugly details about keeping the -# data organized by using a combination of arrays, lists -# and namespaces. -# -# Each record definition is kept in a master array -# (_recorddefn) under the ::struct::record namespace. Each -# instance of a record is kept within a separate namespace -# for each record definition. Hence, instances of -# the same record definition are managed under the -# same namespace. This avoids possible collisions, and -# also limits one big global array mechanism. -# -# Copyright (c) 2002 by Brett Schwarz -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# This code may be distributed under the same terms as Tcl. -# -# $Id: record.tcl,v 1.5 2003/01/29 06:26:03 schwarzkopf Exp $ -# -#============================================================ -# -#### FIX ERROR MESSAGES SO THEY MAKE SENSE (Wrong args) - -namespace eval ::struct {} - -namespace eval ::struct::record { - - ## - ## array of lists that holds the - ## definition (variables) for each - ## record - ## - ## _recorddefn(some_record) var1 var2 var3 ... - ## - variable _recorddefn - - ## - ## holds the count for each record - ## in cases where the instance is - ## automatically generated - ## - ## _count(some_record) 0 - ## - variable _count - - ## - ## array that holds the defining record's - ## name for each instances - ## - ## _defn(some_instances) name_of_defining_record - ## - variable _defn - - ## - ## This holds the defaults for a record definition. - ## If no default is given for a member of a record, - ## then the value is assigned to the empty string - ## - variable _defaults - - ## - ## These are the possible sub commands - ## - variable commands - set commands [list define delete exists show] - - ## - ## This keeps track of the level that we are in - ## when handling nested records. This is kind of - ## a hack, and probably can be handled better - ## - set _level 0 - - namespace export record -} - -#------------------------------------------------------------ -# ::struct::record::record -- -# -# main command used to access the other sub commands -# -# Arguments: -# cmd_ The sub command (i.e. define, show, delete, exists) -# args arguments to pass to the sub command -# -# Results: -# none returned -#------------------------------------------------------------ -# -proc ::struct::record::record {cmd_ args} { - variable commands - - if {[lsearch $commands $cmd_] < 0} { - error "Sub command \"$cmd_\" is not recognized. Must be [join $commands ,]" - } - - set cmd_ [string totitle "$cmd_"] - return [uplevel 1 ::struct::record::${cmd_} $args] - -}; # end proc ::struct::record::record - - -#------------------------------------------------------------ -# ::struct::record::Define -- -# -# Used to define a record -# -# Arguments: -# defn_ the name of the record definition -# vars_ the variables of the record (as a list) -# args instances to be create during definition -# -# Results: -# Returns the name of the definition during successful -# creation. -#------------------------------------------------------------ -# -proc ::struct::record::Define {defn_ vars_ args} { - - variable _recorddefn - variable _count - variable _defaults - - set defn_ [Qualify $defn_] - - if {[info exists _recorddefn($defn_)]} { - error "Record definition $defn_ already exists" - } - - if {[lsearch [info commands] $defn_] >= 0} { - error "Structure definition name can not be a Tcl command name" - } - - set _defaults($defn_) [list] - set _recorddefn($defn_) [list] - - - ## - ## Loop through the members of the record - ## definition - ## - foreach V $vars_ { - - set len [llength $V] - set D "" - - ## - ## 2 --> there is a default value - ## assigned to the member - ## - ## 3 --> there is a nested record - ## definition given as a member - ## - if {$len == 2} { - - set D [lindex $V 1] - set V [lindex $V 0] - - } elseif {$len == 3} { - - if {![string match "record" "[lindex $V 0]"]} { - - Delete record $defn_ - error "$V is a Bad member for record definition - definition creation aborted." - } - - set new [lindex $V 1] - - set new [Qualify $new] - - ## - ## Right now, there can not be circular records - ## so, we abort the creation - ## - if {[string match "$defn_" "$new"]} { - Delete record $defn_ - error "Can not have circular records. Structure was not created." - } - - ## - ## Will take care of the nested record later - ## We just join by :: because this is how it - ## use to be declared, so the parsing code - ## is already there. - ## - set V [join [lrange $V 1 2] "::"] - } - - lappend _recorddefn($defn_) $V - lappend _defaults($defn_) $D - } - - - uplevel #0 [list interp alias {} $defn_ {} ::struct::record::Create $defn_] - - set _count($defn_) 0 - - namespace eval ::struct::record${defn_} { - variable values - variable instances - - set instances [list] - } - - ## - ## If there were args given (instances), then - ## create them now - ## - foreach A $args { - - uplevel 1 [list ::struct::record::Create $defn_ $A] - } - - return $defn_ - -}; # end proc ::struct::record::Define - - -#------------------------------------------------------------ -# ::struct::record::Create -- -# -# Creates an instance of a record definition -# -# Arguments: -# defn_ the name of the record definition -# inst_ the name of the instances to create -# args values to set to the record's members -# -# Results: -# Returns the name of the instance for a successful creation -#------------------------------------------------------------ -# -proc ::struct::record::Create {defn_ inst_ args} { - - variable _recorddefn - variable _count - variable _defn - variable _defaults - variable _level - - set inst_ [Qualify "$inst_"] - - ## - ## test to see if the record - ## definition has been defined yet - ## - if {![info exists _recorddefn($defn_)]} { - error "Structure $defn_ does not exist" - } - - - ## - ## if there was no argument given, - ## then assume that the record - ## variable is automatically - ## generated - ## - if {[string match "[Qualify #auto]" "$inst_"]} { - set c $_count($defn_) - set inst_ [format "%s%s" ${defn_} $_count($defn_)] - incr _count($defn_) - } - - ## - ## Test to see if this instance is already - ## created. This avoids any collisions with - ## previously created instances - ## - if {[info exists _defn($inst_)]} { - incr _count($defn_) -1 - error "Instances $inst_ already exists" - } - - set _defn($inst_) $defn_ - - ## - ## Initialize record variables to - ## defaults - ## - - uplevel #0 [list interp alias {} ${inst_} {} ::struct::record::Cmd $inst_] - - set cnt 0 - foreach V $_recorddefn($defn_) D $_defaults($defn_) { - - set [Ns $inst_]values($inst_,$V) $D - - ## - ## Test to see if there is a nested record - ## - if {[regexp -- {([\w]*)::([\w]*)} $V m def inst]} { - - if {$_level == 0} { - set _level 2 - } - - ## - ## This is to guard against if the creation - ## had failed, that there isn't any - ## lingering variables/alias around - ## - set def [Qualify $def $_level] - - if {![info exists _recorddefn($def)]} { - - Delete inst "$inst_" - - return - } - - ## - ## evaluate the nested record. If there - ## were values for the variables passed - ## in, then we assume that the value for - ## this nested record is a list - ## corresponding the the nested list's - ## variables, and so we pass that to - ## the nested record's instantiation. - ## We then get rid of those args for later - ## processing. - ## - set cnt_plus [expr {$cnt + 1}] - set mem [lindex $args $cnt] - if {![string match "" "$mem"]} { - if {![string match "-$inst" "$mem"]} { - Delete inst "$inst_" - error "$inst is not a member of $defn_" - } - } - incr _level - eval Create $def ${inst_}.${inst} [lindex $args $cnt_plus] - set args [lreplace $args $cnt $cnt_plus] - - } else { - - uplevel #0 [list interp alias {} ${inst_}.$V {} ::struct::record::Access $defn_ $inst_ $V] - incr cnt 2 - } - - }; # end foreach variable - - lappend [Ns $inst_]instances $inst_ - - foreach {k v} $args { - - Access $defn_ $inst_ [string trimleft "$k" -] $v - - }; # end foreach arg - - set _level 0 - - return $inst_ - -}; # end proc ::struct::record::Create - - -#------------------------------------------------------------ -# ::struct::record::Access -- -# -# Provides a common proc to access the variables -# from the aliases create for each variable in the record -# -# Arguments: -# defn_ the name of the record to access -# inst_ the name of the instance to create -# var_ the variable of the record to access -# args a value to set to var_ (if any) -# -# Results: -# Returns the value of the record member (var_) -#------------------------------------------------------------ -# -proc ::struct::record::Access {defn_ inst_ var_ args} { - - variable _recorddefn - variable _defn - - set i [lsearch $_recorddefn($defn_) $var_] - - if {$i < 0} { - error "$var_ does not exist in record $defn_" - } - - if {![info exists _defn($inst_)]} { - - error "$inst_ does not exist" - } - - if {[set idx [lsearch $args "="]] >= 0} { - set args [lreplace $args $idx $idx] - } - - ## - ## If a value was given, then set it - ## - if {[llength $args] != 0} { - - set val_ [lindex $args 0] - - set [Ns $inst_]values($inst_,$var_) $val_ - } - - return [set [Ns $inst_]values($inst_,$var_)] - -}; # end proc ::struct::record::Access - - -#------------------------------------------------------------ -# ::struct::record::Cmd -- -# -# Used to process the set/get requests. -# -# Arguments: -# inst_ the record instance name -# args For 'get' this is the record members to -# retrieve. For 'set' this is a member/value -# pair. -# -# Results: -# For 'set' returns the empty string. For 'get' it returns -# the member values. -#------------------------------------------------------------ -# -proc ::struct::record::Cmd {inst_ args} { - - variable _defn - - set result [list] - - set len [llength $args] - if {$len <= 1} {return [Show values "$inst_"]} - - set cmd [lindex $args 0] - - if {[string match "cget" "$cmd"]} { - - set cnt 0 - foreach k [lrange $args 1 end] { - if {[catch {set r [${inst_}.[string trimleft ${k} -]]} err]} { - error "Bad option \"$k\"" - } - - lappend result $r - incr cnt - } - if {$cnt == 1} {set result [lindex $result 0]} - return $result - - } elseif {[string match "config*" "$cmd"]} { - - set L [lrange $args 1 end] - foreach {k v} $L { - ${inst_}.[string trimleft ${k} -] $v - } - - } else { - error "Wrong argument. - must be \"object cget|configure args\"" - } - - return [list] - -}; # end proc ::struct::record::Cmd - - -#------------------------------------------------------------ -# ::struct::record::Ns -- -# -# This just constructs a fully qualified namespace for a -# particular instance. -# -# Arguments; -# inst_ instance to construct the namespace for. -# -# Results: -# Returns the fully qualified namespace for the instance -#------------------------------------------------------------ -# -proc ::struct::record::Ns {inst_} { - - variable _defn - - if {[catch {set ret $_defn($inst_)} err]} { - return $inst_ - } - - return [format "%s%s%s" "::struct::record" $ret "::"] - -}; # end proc ::struct::record::Ns - - -#------------------------------------------------------------ -# ::struct::record::Show -- -# -# Display info about the record that exist -# -# Arguments: -# what_ subcommand -# record_ record or instance to process -# -# Results: -# if what_ = record, then return list of records -# definition names. -# if what_ = members, then return list of members -# or members of the record. -# if what_ = instance, then return a list of instances -# with record definition of record_ -# if what_ = values, then it will return the values -# for a particular instance -#------------------------------------------------------------ -# -proc ::struct::record::Show {what_ {record_ ""}} { - - variable _recorddefn - variable _defn - variable _defaults - - ## - ## We just prepend :: to the record_ argument - ## - if {![string match "::*" "$record_"]} {set record_ "::$record_"} - - if {[string match "record*" "$what_"]} { - return [lsort [array names _recorddefn]] - } elseif {[string match "mem*" "$what_"]} { - - if {[string match "" "$record_"] || ![info exists _recorddefn($record_)]} { - error "Bad arguments while accessing members. Bad record name" - } - - set res [list] - set cnt 0 - foreach m $_recorddefn($record_) { - set def [lindex $_defaults($record_) $cnt] - if {[regexp -- {([\w]+)::([\w]+)} $m m d i]} { - lappend res [list record $d $i] - } elseif {![string match "" "$def"]} { - lappend res [list $m $def] - } else { - lappend res $m - } - - incr cnt - } - - return $res - - } elseif {[string match "inst*" "$what_"]} { - - if {![info exists ::struct::record${record_}::instances]} { - return [list] - } - return [lsort [set ::struct::record${record_}::instances]] - - } elseif {[string match "val*" "$what_"]} { - - set ns $_defn($record_) - - if {[string match "" "$record_"] || ([lsearch [set [Ns $record_]instances] $record_] < 0)} { - - error "Wrong arguments to values. Bad instance name" - } - - set ret [list] - foreach k $_recorddefn($ns) { - - set v [set [Ns $record_]values($record_,$k)] - - if {[regexp -- {([\w]*)::([\w]*)} $k m def inst]} { - set v [::struct::record::Show values ${record_}.${inst}] - } - - lappend ret -[namespace tail $k] $v - } - return $ret - - } - - return [list] - -}; # end proc ::struct::record::Show - - -#------------------------------------------------------------ -# ::struct::record::Delete -- -# -# Deletes a record instance or a record definition -# -# Arguments: -# sub_ what to delete. Either 'instance' or 'record' -# item_ the specific record instance or definition -# delete. -# -# Returns: -# none -# -#------------------------------------------------------------ -# -proc ::struct::record::Delete {sub_ item_} { - - variable _recorddefn - variable _defn - variable _count - variable _defaults - - ## - ## We just semi-blindly prepend :: to the record_ argument - ## - if {![string match "::*" "$item_"]} {set item_ "::$item_"} - - switch -- $sub_ { - - instance - - instances - - inst { - - - if {[Exists instance $item_]} { - - set ns $_defn($item_) - foreach A [info commands ${item_}.*] { - Delete inst $A - } - - catch { - foreach {k v} [array get [Ns $item_]values $item_,*] { - - unset [Ns $item_]values($k) - } - set i [lsearch [set [Ns $item_]instances] $item_] - set [Ns $item_]instances [lreplace [set [Ns $item_]instances] $i $i] - unset _defn($item_) - } - - incr _count($ns) -1 - - } else { - #error "$item_ is not a instance" - } - } - record - - records { - - - ## - ## Delete the instances for this - ## record - ## - foreach I [Show instance "$item_"] { - catch {Delete instance "$I"} - } - - catch { - unset _recorddefn($item_) - unset _defaults($item_) - unset _count($item_) - namespace delete ::struct::record${item_} - } - - - } - default { - error "Wrong arguments to delete" - } - - }; # end switch - - catch { uplevel #0 [list interp alias {} $item_ {}]} - - return - -}; # end proc ::struct::record::Delete - - -#------------------------------------------------------------ -# ::struct::record::Exists -- -# -# Tests whether a record definition or record -# instance exists. -# -# Arguments: -# sub_ what to test. Either 'instance' or 'record' -# item_ the specific record instance or definition -# that needs to be tested. -# -# Tests to see if a particular instance exists -# -#------------------------------------------------------------ -# -proc ::struct::record::Exists {sub_ item_} { - - - switch -glob -- $sub_ { - inst* { - - if {([lsearch ::[Ns $item_]instances $item_] >=0) || [llength [info commands ::${item_}.*]]} { - return 1 - } else { - return 0 - } - } - record { - - set item_ "::$item_" - if {[info exists _recorddefn($item_)] || [llength [info commands ${item_}]]} { - return 1 - } else { - return 0 - } - } - default { - error "Wrong arguments. Must be exists record|instance target" - } - }; # end switch - -}; # end proc ::struct::record::Exists - - -#------------------------------------------------------------ -# ::struct::record::Qualify -- -# -# Contructs the qualified name of the calling scope. This -# defaults to 2 levels since there is an extra proc call in -# between. -# -# Arguments: -# item_ the command that needs to be qualified -# level_ how many levels to go up (default = 2) -# -# Results: -# the item_ passed in fully qualified -# -#------------------------------------------------------------ -# -proc ::struct::record::Qualify {item_ {level_ 2}} { - - if {![string match "::*" "$item_"]} { - set ns [uplevel $level_ [list namespace current]] - - if {![string match "::" "$ns"]} { - append ns "::" - } - - set item_ "$ns${item_}" - } - - return "$item_" - -}; # end proc ::struct::record::Qualify DELETED modules/struct/record.test Index: modules/struct/record.test ================================================================== --- modules/struct/record.test +++ /dev/null @@ -1,398 +0,0 @@ -# -*- tcl -*- -#------------------------------------------------------------ -# record.test -- -# -# test suite for struct::record module -# -# Tcl tests for testing the struct::record package, which -# loosely immitates a 'C' structure. Invoke this test suite -# by: tclsh record.test -# -#------------------------------------------------------------ -# -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} - -source [file join [file dirname [info script]] record.tcl] -namespace import struct::record::* - -test record-0.1 {record define} { - record define phones {home work cell} -} ::phones - -test record-0.2 {record define - multi line} { - record define contact { - first - middle - last - {record phones phlist} - } -} ::contact - -test record-0.3 {record define - multi line} { - record define mycontact { - age - sex - {record contact cont} - } -} ::mycontact - -test record-0.4 {definition with instantiation} { - record define location { - street - city - state - {country USA} - } loc(1) loc(5) -} ::location - -test record-0.5 {test error with circular records} { - catch { - record define circular { - one - {record circular cir} - } cir(1) - } err - set err -} "Can not have circular records. Structure was not created." - -test record-0.6 {single instance} { - contact cont(1) -} ::cont(1) - -test record-0.7 {auto instance} { - contact #auto -} ::contact0 - -test record-0.8 {instance of double nested record} { - mycontact #auto -} ::mycontact0 - -test record-0.9 {setting a instance var via alias} { - cont(1).first Brett -} Brett - -test record-1.0 {setting a nested instance var via alias} { - cont(1).phlist.cell 425-555-1212 -} 425-555-1212 - -test record-1.1 {setting a double nested instance var via alias} { - mycontact0.cont.phlist.cell 206-555-1212 -} 206-555-1212 - -test record-1.2 {setting values via config} { - cont(1) config -middle Allen -last Schwarz -} "" - -test record-1.3 {setting a double nested instance via config} { - mycontact0 config -cont.phlist.cell 206-555-1212 -} "" - -test record-1.4 {get a value via cget} { - cont(1) cget -first -middle -last -} [list Brett Allen Schwarz] - -test record-1.5 {get a double nested value via cget} { - mycontact0 cget -cont.phlist.cell -} 206-555-1212 - -test record-1.6 {get a value via alias} { - cont(1).first -} Brett - -test record-1.7 {record default value} { - loc(1) cget -country -} USA - -test record-1.8 {setting values via config} { - loc(1) config -street somestreet -city somecity -state somestate -country somecountry -} "" - -test record-1.9 {setting nested vars via config} { - cont(1) config -phlist.home 425-555-1212 -} "" - -test record-2.0 {test value of nested member} { - cont(1) cget -phlist.home -} 425-555-1212 - -test record-2.1 {config with no values} { - loc(1) config -} [list -street somestreet -city somecity -state somestate -country somecountry] - -test record-2.2 {get with no values} { - loc(1) cget -} [list -street somestreet -city somecity -state somestate -country somecountry] - -test record-2.3 {get with just instance command} { - loc(1) -} [list -street somestreet -city somecity -state somestate -country somecountry] - -test record-2.4 {get a nest value via alias} { - cont(1).phlist.cell -} 425-555-1212 - -test record-2.5 {set values during instantiation} { - location loc(2) -street street2 -city city2 -state state2 -country country2 -} ::loc(2) - -test record-2.6 {get the above value via alias} { - loc(2).street -} street2 - -test record-2.7 {set values during instantiation - nested record} { - contact cont(2) -first John -middle Q -last Doe -phlist [list home 425-555-1212 work 425-555-1222 cell 425-555-1111] -} ::cont(2) - -test record-2.8 {copy one instance to another during creation} { - eval contact cont(3) [cont(1)] -} ::cont(3) - -test record-2.9 {get the above values via alias} { - cont(2).phlist.home -} 425-555-1212 - -test record-3.0 {copy one definition to another definition} { - record define new_contact [record show members contact] -} ::new_contact - -test record-3.1 {show defined records} { - record show records -} [lsort [list ::phones ::contact ::location ::new_contact ::mycontact]] - -test record-3.2 {show members} { - record show members phones -} [list home work cell] - -test record-3.3 {show members - with default value} { - record show members location -} [list street city state [list country USA]] - -test record-3.4 {show members - nested record} { - record show members contact -} [list first middle last [list record phones phlist]] - -test record-3.5 {show values} { - record show values loc(1) -} [list -street somestreet -city somecity -state somestate -country somecountry] - -test record-3.6 {show values - nested} { - record show values cont(1) -} [list -first Brett -middle Allen -last Schwarz -phlist [list -home 425-555-1212 -work {} -cell 425-555-1212]] - -test record-3.7 {show instances} { - record show instance location -} [list ::loc(1) ::loc(2) ::loc(5)] - - -test record-3.8 {delete an instance} { - record delete instance loc(2) -} "" - -test record-3.9 {delete a nested instance} { - record delete instance cont(2) -} "" - -test record-4.0 {delete a record} { - record delete record location -} "" - -test record-4.1 {test existence of an instance that was deleted} { - record exists instance loc(1) -} 0 - -test record-4.2 {show existence of an instance} { - record exists instance cont(1) -} 1 - -test record-4.3 {show non-existent instance} { - record exists instance junk -} 0 - -test record-4.4 {show existence of record} { - record exists record contact -} 1 - - -## -## NAMESPACE TESTS -## - -test record-5.0 {record define} { - namespace eval myns { - record define phones {home work cell} - } -} ::myns::phones - -test record-5.1 {record define - multi line} { - record define ::myns::contact { - first - middle - last - {record phones phlist} - } -} ::myns::contact - -test record-5.2 {definition with instantiation} { - namespace eval myns { - record define location { - street - city - state - {country USA} - } loc(1) loc(5) - } -} ::myns::location - -test record-5.3 {test error with circular records} { - catch { - namespace eval myns { - record define circular { - one - {record ::myns::circular cir} - } cir(1) - } - } err - set err -} "Can not have circular records. Structure was not created." - -test record-5.4 {single instance} { - namespace eval myns { - contact cont(1) - } -} ::myns::cont(1) - -test record-5.5 {auto instance} { - namespace eval myns { - contact #auto - } -} ::myns::contact0 - -test record-5.6 {setting a instance var via alias} { - myns::cont(1).first Brett -} Brett - -test record-5.7 {setting a nested instance var via alias} { - myns::cont(1).phlist.cell 425-555-1212 -} 425-555-1212 - -test record-5.8 {setting values via config} { - myns::cont(1) config -middle Allen -last Schwarz -} "" - -test record-5.9 {get a value via cget} { - myns::cont(1) cget -first -middle -last -} [list Brett Allen Schwarz] - -test record-6.0 {record default value} { - myns::loc(1) cget -country -} USA - -test record-6.1 {setting values via config} { - myns::loc(1) config -street somestreet -city somecity -state somestate -country somecountry -} "" - -test record-6.2 {setting nested vars via config} { - myns::cont(1) config -phlist.home 425-555-1212 -} "" - -test record-6.3 {test value of nested member} { - myns::cont(1) cget -phlist.home -} 425-555-1212 - -test record-6.4 {config with no values} { - myns::loc(1) config -} [list -street somestreet -city somecity -state somestate -country somecountry] - -test record-6.5 {get with no values} { - myns::loc(1) cget -} [list -street somestreet -city somecity -state somestate -country somecountry] - -test record-6.6 {get with just instance command} { - myns::loc(1) -} [list -street somestreet -city somecity -state somestate -country somecountry] - -test record-6.7 {get a nest value via alias} { - myns::cont(1).phlist.cell -} 425-555-1212 - -test record-6.8 {set values during instantiation} { - namespace eval myns { - location loc(2) -street street2 -city city2 -state state2 -country country2 - } -} ::myns::loc(2) - -test record-6.9 {get the above value via alias} { - myns::loc(2).street -} street2 - -test record-7.0 {set values during instantiation - nested record} { - namespace eval myns { - contact cont(2) -first John -middle Q -last Doe -phlist [list home 425-555-1212 work 425-555-1222 cell 425-555-1111] - } -} ::myns::cont(2) - -test record-7.1 {get the above values via alias} { - myns::cont(2).phlist.home -} 425-555-1212 - - -test record-7.2 {show defined records} { - record show records -} [lsort [list ::contact ::myns::phones ::myns::contact ::myns::location ::new_contact ::phones ::mycontact]] - -test record-7.3 {show members} { - record show members myns::phones -} [list home work cell] - -test record-7.4 {show members - with default value} { - record show members myns::location -} [list street city state [list country USA]] - -test record-7.5 {show members - nested record} { - record show members myns::contact -} [list first middle last [list record phones phlist]] - -test record-7.6 {show values} { - record show values myns::loc(1) -} [list -street somestreet -city somecity -state somestate -country somecountry] - -test record-7.7 {show values - nested} { - record show values myns::cont(1) -} [list -first Brett -middle Allen -last Schwarz -phlist [list -home 425-555-1212 -work {} -cell 425-555-1212]] - -test record-7.8 {show instances} { - record show instance myns::location -} [list ::myns::loc(1) ::myns::loc(2) ::myns::loc(5)] - - -test record-7.9 {delete an instance} { - record delete instance myns::loc(2) -} "" - -test record-8.0 {delete a nested instance} { - record delete instance myns::cont(2) -} "" - -test record-8.1 {delete a record} { - record delete record myns::location -} "" - -test record-8.2 {test existence of an instance that was deleted} { - record exists instance myns::loc(1) -} 0 - -test record-8.3 {show existence of an instance} { - record exists instance myns::cont(1) -} 1 - -test record-8.4 {show non-existent instance} { - record exists instance myns::junk -} 0 - -test record-8.5 {show existence of record} { - record exists record myns::contact -} 1 - DELETED modules/struct/skiplist.man Index: modules/struct/skiplist.man ================================================================== --- modules/struct/skiplist.man +++ /dev/null @@ -1,87 +0,0 @@ -[comment {-*- tcl -*-}] -[manpage_begin skiplist n 1.3] -[copyright {2000 Keith Vetter}] -[comment { - This software is licensed under a BSD license as described in tcl/tk - license.txt file but with the copyright held by Keith Vetter. -}] -[moddesc {Tcl Data Structures}] -[titledesc {Create and manipulate skiplists}] -[require Tcl 8.2] -[require struct [opt 1.3]] -[description] -[para] - -The [cmd ::struct::skiplist] command creates a new skiplist object -with an associated global Tcl command whose name is -[arg skiplistName]. This command may be used to invoke various -operations on the skiplist. It has the following general form: - -[list_begin definitions] -[call [cmd graphName] [arg option] [opt [arg "arg arg ..."]]] - -[arg Option] and the [arg arg]s determine the exact behavior of the -command. - -[list_end] - -[para] - -Skip lists are an alternative data structure to binary trees. They can -be used to maintain ordered lists over any sequence of insertions and -deletions. Skip lists use randomness to achieve probabilistic -balancing, and as a result the algorithms for insertion and deletion -in skip lists are much simpler and faster than those for binary trees. - -[para] - -To read more about skip lists see Pugh, William. -[emph {Skip lists: a probabilistic alternative to balanced trees}] -In: Communications of the ACM, June 1990, 33(6) 668-676. - -[para] - -Currently, the key can be either a number or a string, and comparisons -are performed with the built in greater than operator. - -The following commands are possible for skiplist objects: - -[list_begin definitions] -[call [arg skiplistName] [method delete] [arg node] [opt [arg node]...]] - -Remove the specified nodes from the skiplist. - - -[call [arg skiplistName] [method destroy]] - -Destroy the skiplist, including its storage space and associated command. - - -[call [arg skiplistName] [method insert] [arg {key value}]] - -Insert a node with the given [arg key] and [arg value] into the -skiplist. If a node with that key already exists, then the that node's -value is updated and its node level is returned. Otherwise a new node -is created and 0 is returned. - - -[call [arg skiplistName] [method search] [arg node] [opt "[const -key] [arg key]"]] - -Search for a given key in a skiplist. If not found then 0 is returned. -If found, then a two element list of 1 followed by the node's value is retuned. - - -[call [arg skiplistName] [method size]] - -Return a count of the number of nodes in the skiplist. - -[call [arg skiplistName] [method walk] [arg cmd]] - -Walk the skiplist from the first node to the last. At each node, the -command [arg cmd] will be evaluated with the key and value of the -current node appended. - -[list_end] - -[keywords skiplist] -[manpage_end] DELETED modules/struct/skiplist.tcl Index: modules/struct/skiplist.tcl ================================================================== --- modules/struct/skiplist.tcl +++ /dev/null @@ -1,427 +0,0 @@ -# skiplist.tcl -- -# -# Implementation of a skiplist data structure for Tcl. -# -# To quote the inventor of skip lists, William Pugh: -# Skip lists are a probabilistic data structure that seem likely -# to supplant balanced trees as the implementation method of -# choice for many applications. Skip list algorithms have the -# same asymptotic expected time bounds as balanced trees and are -# simpler, faster and use less space. -# -# For more details on how skip lists work, see Pugh, William. Skip -# lists: a probabilistic alternative to balanced trees in -# Communications of the ACM, June 1990, 33(6) 668-676. Also, see -# ftp://ftp.cs.umd.edu/pub/skipLists/ -# -# Copyright (c) 2000 by Keith Vetter -# This software is licensed under a BSD license as described in tcl/tk -# license.txt file but with the copyright held by Keith Vetter. -# -# TODO: -# customize key comparison to a user supplied routine - -namespace eval ::struct {} - -namespace eval ::struct::skiplist { - # Data storage in the skiplist module - # ------------------------------- - # - # For each skiplist, we have the following arrays - # state - holds the current level plus some magic constants - # nodes - all the nodes in the skiplist, including a dummy header node - - # counter is used to give a unique name for unnamed skiplists - variable counter 0 - - # Internal constants - variable MAXLEVEL 16 - variable PROB .5 - variable MAXINT [expr {0x7FFFFFFF}] - - # commands is the list of subcommands recognized by the skiplist - variable commands [list \ - "destroy" \ - "delete" \ - "insert" \ - "search" \ - "size" \ - "walk" \ - ] - - # State variables that can be set in the instantiation - variable vars [list maxlevel probability] - - # Only export one command, the one used to instantiate a new skiplist - namespace export skiplist -} - -# ::struct::skiplist::skiplist -- -# -# Create a new skiplist with a given name; if no name is given, use -# skiplistX, where X is a number. -# -# Arguments: -# name name of the skiplist; if null, generate one. -# -# Results: -# name name of the skiplist created - -proc ::struct::skiplist::skiplist {{name ""} args} { - set usage "skiplist name ?-maxlevel ##? ?-probability ##?" - variable counter - - if { [llength [info level 0]] == 1 } { - incr counter - set name "skiplist${counter}" - } - - if { ![string equal [info commands ::$name] ""] } { - error "command \"$name\" already exists, unable to create skiplist" - } - - # Handle the optional arguments - set more_eval "" - for {set i 0} {$i < [llength $args]} {incr i} { - set flag [lindex $args $i] - incr i - if { $i >= [llength $args] } { - error "value for \"$flag\" missing: should be \"$usage\"" - } - set value [lindex $args $i] - switch -glob -- $flag { - "-maxl*" { - set n [catch {set value [expr $value]}] - if {$n || $value <= 0} { - error "value for the maxlevel option must be greater than 0" - } - append more_eval "; set state(maxlevel) $value" - } - "-prob*" { - set n [catch {set value [expr $value]}] - if {$n || $value <= 0 || $value >= 1} { - error "probability must be between 0 and 1" - } - append more_eval "; set state(prob) $value" - } - default { - error "unknown option \"$flag\": should be \"$usage\"" - } - } - } - - # Set up the namespace for this skiplist - namespace eval ::struct::skiplist::skiplist$name { - variable state - variable nodes - - # NB. maxlevel and prob may be overridden by $more_eval at the end - set state(maxlevel) $::struct::skiplist::MAXLEVEL - set state(prob) $::struct::skiplist::PROB - set state(level) 1 - set state(cnt) 0 - set state(size) 0 - - set nodes(nil,key) $::struct::skiplist::MAXINT - set nodes(header,key) "---" - set nodes(header,value) "---" - - for {set i 1} {$i < $state(maxlevel)} {incr i} { - set nodes(header,$i) nil - } - } $more_eval - - # Create the command to manipulate the skiplist - interp alias {} ::$name {} ::struct::skiplist::SkiplistProc $name - - return $name -} - -########################### -# Private functions follow - -# ::struct::skiplist::SkiplistProc -- -# -# Command that processes all skiplist object commands. -# -# Arguments: -# name name of the skiplist object to manipulate. -# args command name and args for the command -# -# Results: -# Varies based on command to perform - -proc ::struct::skiplist::SkiplistProc {name {cmd ""} args} { - # Do minimal args checks here - if { [llength [info level 0]] == 2 } { - error "wrong # args: should be \"$name option ?arg arg ...?\"" - } - - # Split the args into command and args components - if { [llength [info commands ::struct::skiplist::_$cmd]] == 0 } { - variable commands - set optlist [join $commands ", "] - set optlist [linsert $optlist "end-1" "or"] - error "bad option \"$cmd\": must be $optlist" - } - eval [list ::struct::skiplist::_$cmd $name] $args -} - -## ::struct::skiplist::_destroy -- -# -# Destroy a skiplist, including its associated command and data storage. -# -# Arguments: -# name name of the skiplist. -# -# Results: -# None. - -proc ::struct::skiplist::_destroy {name} { - namespace delete ::struct::skiplist::skiplist$name - interp alias {} ::$name {} -} - -# ::struct::skiplist::_search -- -# -# Searches for a key in a skiplist -# -# Arguments: -# name name of the skiplist. -# key key for the node to search for -# -# Results: -# 0 if not found -# [list 1 node_value] if found - -proc ::struct::skiplist::_search {name key} { - upvar ::struct::skiplist::skiplist${name}::state state - upvar ::struct::skiplist::skiplist${name}::nodes nodes - - set x header - for {set i $state(level)} {$i >= 1} {incr i -1} { - while {1} { - set fwd $nodes($x,$i) - if {$nodes($fwd,key) == $::struct::skiplist::MAXINT} break - if {$nodes($fwd,key) >= $key} break - set x $fwd - } - } - set x $nodes($x,1) - if {$nodes($x,key) == $key} { - return [list 1 $nodes($x,value)] - } - return 0 -} - -# ::struct::skiplist::_insert -- -# -# Add a node to a skiplist. -# -# Arguments: -# name name of the skiplist. -# key key for the node to insert -# value value of the node to insert -# -# Results: -# 0 if new node was created -# level if existing node was updated - -proc ::struct::skiplist::_insert {name key value} { - upvar ::struct::skiplist::skiplist${name}::state state - upvar ::struct::skiplist::skiplist${name}::nodes nodes - - set x header - for {set i $state(level)} {$i >= 1} {incr i -1} { - while {1} { - set fwd $nodes($x,$i) - if {$nodes($fwd,key) == $::struct::skiplist::MAXINT} break - if {$nodes($fwd,key) >= $key} break - set x $fwd - } - set update($i) $x - } - set x $nodes($x,1) - - # Does the node already exist? - if {$nodes($x,key) == $key} { - set nodes($x,value) $value - return 0 - } - - # Here to insert item - incr state(size) - set lvl [randomLevel $state(prob) $state(level) $state(maxlevel)] - - # Did the skip list level increase??? - if {$lvl > $state(level)} { - for {set i [expr {$state(level) + 1}]} {$i <= $lvl} {incr i} { - set update($i) header - } - set state(level) $lvl - } - - # Create a unique new node name and fill in the key, value parts - set x [incr state(cnt)] - set nodes($x,key) $key - set nodes($x,value) $value - - for {set i 1} {$i <= $lvl} {incr i} { - set nodes($x,$i) $nodes($update($i),$i) - set nodes($update($i),$i) $x - } - - return $lvl -} - -# ::struct::skiplist::_delete -- -# -# Deletes a node from a skiplist -# -# Arguments: -# name name of the skiplist. -# key key for the node to delete -# -# Results: -# 1 if we deleted a node -# 0 otherwise - -proc ::struct::skiplist::_delete {name key} { - upvar ::struct::skiplist::skiplist${name}::state state - upvar ::struct::skiplist::skiplist${name}::nodes nodes - - set x header - for {set i $state(level)} {$i >= 1} {incr i -1} { - while {1} { - set fwd $nodes($x,$i) - if {$nodes($fwd,key) >= $key} break - set x $fwd - } - set update($i) $x - } - set x $nodes($x,1) - - # Did we find a node to delete? - if {$nodes($x,key) != $key} { - return 0 - } - - # Here when we found a node to delete - incr state(size) -1 - - # Unlink this node from all the linked lists that include to it - for {set i 1} {$i <= $state(level)} {incr i} { - set fwd $nodes($update($i),$i) - if {$nodes($fwd,key) != $key} break - set nodes($update($i),$i) $nodes($x,$i) - } - - # Delete all traces of this node - foreach v [array names nodes($x,*)] { - unset nodes($v) - } - - # Fix up the level in case it went down - while {$state(level) > 1} { - if {! [string equal "nil" $nodes(header,$state(level))]} break - incr state(level) -1 - } - - return 1 -} - -# ::struct::skiplist::_size -- -# -# Returns how many nodes are in the skiplist -# -# Arguments: -# name name of the skiplist. -# -# Results: -# number of nodes in the skiplist - -proc ::struct::skiplist::_size {name} { - upvar ::struct::skiplist::skiplist${name}::state state - - return $state(size) -} - -# ::struct::skiplist::_walk -- -# -# Walks a skiplist performing a specified command on each node. -# Command is executed at the global level with the actual command -# executed is: command key value -# -# Arguments: -# name name of the skiplist. -# cmd command to run on each node -# -# Results: -# none. - -proc ::struct::skiplist::_walk {name cmd} { - upvar ::struct::skiplist::skiplist${name}::nodes nodes - - for {set x $nodes(header,1)} {$x != "nil"} {set x $nodes($x,1)} { - # Evaluate the command at this node - set cmdcpy $cmd - lappend cmdcpy $nodes($x,key) $nodes($x,value) - uplevel 2 $cmdcpy - } -} - -# ::struct::skiplist::randomLevel -- -# -# Generates a random level for a new node. We limit it to 1 greater -# than the current level. -# -# Arguments: -# prob probability to use in generating level -# level current biggest level -# maxlevel biggest possible level -# -# Results: -# an integer between 1 and $maxlevel - -proc ::struct::skiplist::randomLevel {prob level maxlevel} { - - set lvl 1 - while {[expr rand()] < $prob && $lvl < $maxlevel} { - incr lvl - } - - if {$lvl > $level} { - set lvl [expr {$level + 1}] - } - - return $lvl -} - -# ::struct::skiplist::_dump -- -# -# Dumps out a skip list. Useful for debugging. -# -# Arguments: -# name name of the skiplist. -# -# Results: -# none. - -proc ::struct::skiplist::_dump {name} { - upvar ::struct::skiplist::skiplist${name}::state state - upvar ::struct::skiplist::skiplist${name}::nodes nodes - - - puts "Current level $state(level)" - puts "Maxlevel: $state(maxlevel)" - puts "Probability: $state(prob)" - puts "" - puts "NODE KEY FORWARD" - for {set x header} {$x != "nil"} {set x $nodes($x,1)} { - puts -nonewline [format "%-6s %3s %4s" $x $nodes($x,key) $nodes($x,1)] - for {set i 2} {[info exists nodes($x,$i)]} {incr i} { - puts -nonewline [format %4s $nodes($x,$i)] - } - puts "" - } -} DELETED modules/struct/skiplist.test Index: modules/struct/skiplist.test ================================================================== --- modules/struct/skiplist.test +++ /dev/null @@ -1,329 +0,0 @@ -# -*- tcl -*- -# skiplist.test: tests for the skiplist structure. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 2000 by Keith Vetter -# This software is licensed under a BSD license as described in tcl/tk -# license.txt file but with the copyright held by Keith Vetter. - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -#lappend auto_path [pwd] -package require struct -#namespace import struct::* - -# ::shuffle -- -# -# creates a randomly ordered list of the integers from 0 to n-1. -# -# Arguments: -# n size of the list to shuffle -# -# Results: -# list of integers from 0 to n-1 in a random order - -proc shuffle {n} { - set t [list ] - set tt [list ] - for {set i 0} {$i < $n} {incr i} { - lappend t $i - } - - # Select a random item out of list t and append to list tt - - for {set i [expr {$n - 1}]} {$i >= 0} {incr i -1} { - set r [expr rand()] - set x [expr {int($r * ($i + 1))}] - lappend tt [lindex $t $x] - set t [lreplace $t $x $x] - } - - return $tt -} - -test skiplist-0.1 {skiplist errors} { - struct::skiplist myskiplist - catch {struct::skiplist myskiplist} msg - myskiplist destroy - set msg -} "command \"myskiplist\" already exists, unable to create skiplist" - -test skiplist-0.2 {skiplist errors} { - struct::skiplist myskiplist - catch {myskiplist} msg - myskiplist destroy - set msg -} "wrong # args: should be \"myskiplist option ?arg arg ...?\"" - -test skiplist-0.3 {skiplist errors} { - struct::skiplist myskiplist - catch {myskiplist foo} msg - myskiplist destroy - set msg -} "bad option \"foo\": must be destroy, delete, insert, search, size, or walk" - -test skiplist-0.4 {skiplist errors} { - catch {struct::skiplist set} msg - set msg -} "command \"set\" already exists, unable to create skiplist" - -test skiplist-0.5 {skiplist errors} { - catch {struct::skiplist myskiplist -foo bar} msg - set msg -} "unknown option \"-foo\": should be \"skiplist name ?-maxlevel ##? ?-probability ##?\"" - -test skiplist-0.6 {skiplist errors} { - catch {struct::skiplist myskiplist -maxlevel bar} msg - set msg -} "value for the maxlevel option must be greater than 0" - -test skiplist-0.7 {skiplist errors} { - catch {struct::skiplist myskiplist -probability bar} msg - set msg -} "probability must be between 0 and 1" - - - - -test skiplist-1.0 {insert} { - struct::skiplist myskiplist - myskiplist insert 5 value_5 - set t [myskiplist search 5] - myskiplist destroy - set t -} "1 value_5" - -test skiplist-1.1 {insert} { - struct::skiplist myskiplist - myskiplist insert 5 value_5 - myskiplist insert 5 value_5.2 - myskiplist insert 5 value_5.3 - myskiplist insert 5 value_5.4 - set t [myskiplist search 5] - myskiplist destroy - set t -} "1 value_5.4" - -test skiplist-1.2 {insert} { - struct::skiplist myskiplist - unset a - foreach a [list 9 7 5 3 1 8 6 4 2] { - myskiplist insert $a value_$a - } - set t [list ] - myskiplist walk {lappend t} - myskiplist destroy - set t -} "1 value_1 2 value_2 3 value_3 4 value_4 5 value_5 6 value_6 7 value_7 8 value_8 9 value_9" - -test skiplist-1.3 {insert} { - struct::skiplist myskiplist - foreach a [shuffle 500] { - set a2 [expr {$a + 1}] - myskiplist insert $a $a2 - } - set t [list ] - myskiplist walk {lappend t} - myskiplist destroy - set sum [set sum2 0] - foreach {key value} $t { - set sum [expr {$sum + $key}] - set sum2 [expr {$sum2 + $value}] - } - set sum "$sum $sum2" -} "124750 125250" - -test skiplist-1.4 {insert} { - struct::skiplist myskiplist - foreach a [shuffle 500] { - myskiplist insert $a -1 - } - foreach a [shuffle 500] { - myskiplist insert $a $a - } - set t [list ] - myskiplist walk {lappend t} - myskiplist destroy - set sum 0 - foreach {key value} $t { - set sum [expr {$sum + $value}] - } - set sum -} "124750" - -test skiplist-1.5 {insert} { - struct::skiplist myskiplist - foreach a [list k e i t h p o w l v r] { - myskiplist insert $a value_$a - } - set t [list ] - myskiplist walk {lappend t } - set str "" - foreach {key value} $t { - append str $key - } - myskiplist destroy - set str -} "ehikloprtvw" - - - -test skiplist-2.0 {delete} { - struct::skiplist myskiplist - myskiplist insert 4 value_4 - set t [myskiplist delete 4] - myskiplist destroy - set t -} "1" - -test skiplist-2.1 {delete} { - struct::skiplist myskiplist - myskiplist insert 4 value_4 - myskiplist delete 4 - set t [myskiplist search 4] - myskiplist destroy - set t -} "0" - -test skiplist-2.2 {delete} { - struct::skiplist myskiplist - myskiplist insert 4 value_4 - set t [myskiplist delete 5] - myskiplist destroy - set t -} "0" - -test skiplist-2.3 {delete} { - struct::skiplist myskiplist - myskiplist insert 8 value_8 - myskiplist insert 7 value_7 - myskiplist insert 6 value_6 - myskiplist insert 5 value_5 - myskiplist insert 4 value_4 - myskiplist delete 6 - myskiplist delete 5 - myskiplist delete 4 - - set t [myskiplist search 7] - myskiplist destroy - set t -} "1 value_7" - -test skiplist-2.4 {delete} { - struct::skiplist myskiplist - set data [shuffle 100] - foreach a $data { - myskiplist insert $a value_$a - if {$a == 1} { - myskiplist insert 999 value_999 - } - } - foreach a $data { - myskiplist delete $a - } - - set size [myskiplist size] - set search [myskiplist search 999] - myskiplist destroy - - if {$size != 1} { - return "size is $size but should be 1" - } - set search -} "1 value_999" - - - - -test skiplist-3.0 {search} { - struct::skiplist myskiplist - myskiplist insert 5 value_5 - myskiplist insert 4 value_4 - myskiplist insert 3 value_3 - set t [myskiplist search 4] - myskiplist destroy - set t -} "1 value_4" - -test skiplist-3.1 {search} { - struct::skiplist myskiplist - myskiplist insert 5 value_5 - myskiplist insert 4 value_4 - myskiplist insert 3 value_3 - set t [myskiplist search 14] - myskiplist destroy - set t -} "0" - - -test skiplist-4.0 {size} { - struct::skiplist myskiplist - myskiplist insert 5 value_5 - myskiplist insert 4 value_4 - myskiplist insert 3 value_3 - set t [myskiplist size] - myskiplist destroy - set t -} "3" - -test skiplist-4.1 {size} { - struct::skiplist myskiplist - for {set i 0} {$i < 500} {incr i} { - myskiplist insert $i value_$i - } - set t [myskiplist size] - myskiplist destroy - set t -} "500" - - - -test skiplist-5.0 {walk} { - struct::skiplist myskiplist - myskiplist insert 5 value_5 - myskiplist insert 4 value_4 - myskiplist insert 3 value_3 - set t [list ] - myskiplist walk {lappend t } - myskiplist destroy - set t -} "3 value_3 4 value_4 5 value_5" - -test skiplist-5.1 {walk} { - struct::skiplist myskiplist - foreach a [shuffle 500] { - set a2 [expr {$a + 1}] - myskiplist insert $a $a2 - } - set t [list ] - myskiplist walk {lappend t} - myskiplist destroy - set sum 0 - set sum2 0 - foreach {key value} $t { - set sum [expr {$sum + $key}] - set sum2 [expr {$sum2 + $value}] - } - set sum "$sum $sum2" -} "124750 125250" - -test skiplist-5.2 {walk} { - struct::skiplist myskiplist1 - struct::skiplist myskiplist2 - foreach a [shuffle 500] { - myskiplist1 insert $a value_$a - } - myskiplist1 walk {myskiplist2 insert } - set size [myskiplist2 size] - myskiplist1 destroy - myskiplist2 destroy - set size -} "500" - -::tcltest::cleanupTests DELETED modules/struct/stack.man Index: modules/struct/stack.man ================================================================== --- modules/struct/stack.man +++ /dev/null @@ -1,68 +0,0 @@ -[manpage_begin stack n 1.2.1] -[moddesc {Tcl Data Structures}] -[titledesc {Create and manipulate stack objects}] -[require Tcl 8.2] -[require struct [opt 1.3]] -[description] - -The [cmd ::struct::stack] command creates a new stack object with an -associated global Tcl command whose name is [emph stackName]. This -command may be used to invoke various operations on the stack. It has -the following general form: - -[list_begin definitions] - -[call [arg stackName] [cmd option] [opt [arg "arg arg ..."]]] - -[arg Option] and the [arg arg]s determine the exact behavior of the -command. The following commands are possible for stack objects: - - -[call [arg stackName] [cmd clear]] - -Remove all items from the stack. - - -[call [arg stackName] [cmd destroy]] - -Destroy the stack, including its storage space and associated command. - - -[call [arg stackName] [cmd peek] [opt "[arg count]"]] - -Return the top [arg count] items of the stack, without removing them from -the stack. If [arg count] is not specified, it defaults to 1. If -[arg count] is 1, the result is a simple string; otherwise, it is a -list. If specified, [arg count] must be greater than or equal to 1. -If there are no items on the stack, this command will return - -[arg count] empty strings. - - -[call [arg stackName] [cmd pop] [opt "[arg count]"]] - -Return the top [arg count] items of the stack, and remove them -from the stack. If [arg count] is not specified, it defaults to 1. -If [arg count] is 1, the result is a simple string; otherwise, it is a -list. If specified, [arg count] must be greater than or equal to 1. -If there are no items on the stack, this command will return - -[arg count] empty strings. - - -[call [arg stackName] [cmd push] [arg item] [opt "[arg "item ..."]"]] - -Push the [arg item] or items specified onto the stack. If more than -one [arg item] is given, they will be pushed in the order they are -listed. - - -[call [arg stackName] [cmd size]] - -Return the number of items on the stack. - - -[list_end] - -[keywords queue matrix tree graph] -[manpage_end] DELETED modules/struct/stack.n Index: modules/struct/stack.n ================================================================== --- modules/struct/stack.n +++ /dev/null @@ -1,64 +0,0 @@ -'\" -'\" Copyright (c) 1998-2000 by Ajuba Solutions. -'\" All rights reserved. -'\" -'\" RCS: @(#) $Id: stack.n,v 1.6 2002/02/01 22:59:09 andreas_kupries Exp $ -'\" -.so man.macros -.TH stack n 1.2.1 Struct "Tcl Data Structures" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -::struct::stack \- Create and manipulate stack objects -.SH SYNOPSIS -\fBpackage require Tcl 8.2\fR -.sp -\fBpackage require struct ?1.2.1?\fR -.sp -\fB::struct::stack\fR \fIstackName\fR -.sp -.BE -.SH DESCRIPTION -.PP -The \fB::struct::stack\fR command creates a new stack object with an -associated global Tcl command whose name is \fIstackName\fR. This command -may be used to invoke various operations on the stack. It has the -following general form: -.CS -\fIstackName option \fR?\fIarg arg ...\fR? -.CE -\fIOption\fR and the \fIarg\fRs -determine the exact behavior of the command. The following -commands are possible for stack objects: -.TP -\fIstackName \fBclear\fR -Remove all items from the stack. -.TP -\fIstackName \fBdestroy\fR -Destroy the stack, including its storage space and associated command. -.TP -\fIstackName \fBpeek\fR ?\fIcount\fR? -Return the top \fIcount\fR items of the stack, without removing them -from the stack. If \fIcount\fR is not specified, it defaults to 1. -If \fIcount\fR is 1, the result is a simple string; otherwise, it is a list. -If specified, \fIcount\fR must be greater than or equal to 1. If -there are no items on the stack, this command will return \fIcount\fR -empty strings. -.TP -\fIstackName \fBpop\fR ?\fIcount\fR? -Return the top \fIcount\fR items of the stack and remove them -from the stack. If \fIcount\fR is not specified, it defaults to 1. -If \fIcount\fR is 1, the result is a simple string; otherwise, it is a list. -If specified, \fIcount\fR must be greater than or equal to 1. If -there are no items on the stack, this command will return \fIcount\fR -empty strings. -.TP -\fIstackName \fBpush\fR \fIitem\fR ?\fIitem ...\fR? -Push the item or items specified onto the stack. If more than one -item is given, they will be pushed in the order they are listed. -.TP -\fIstackName \fBsize\fR -Return the number of items on the stack. - -.SH KEYWORDS -stack, queue DELETED modules/struct/stack.tcl Index: modules/struct/stack.tcl ================================================================== --- modules/struct/stack.tcl +++ /dev/null @@ -1,266 +0,0 @@ -# stack.tcl -- -# -# Stack implementation for Tcl. -# -# Copyright (c) 1998-2000 by Ajuba Solutions. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: stack.tcl,v 1.3 2000/06/02 18:43:56 ericm Exp $ - -namespace eval ::struct {} - -namespace eval ::struct::stack { - # The stacks array holds all of the stacks you've made - variable stacks - - # counter is used to give a unique name for unnamed stacks - variable counter 0 - - # commands is the list of subcommands recognized by the stack - variable commands [list \ - "clear" \ - "destroy" \ - "peek" \ - "pop" \ - "push" \ - "rotate" \ - "size" \ - ] - - # Only export one command, the one used to instantiate a new stack - namespace export stack -} - -# ::struct::stack::stack -- -# -# Create a new stack with a given name; if no name is given, use -# stackX, where X is a number. -# -# Arguments: -# name name of the stack; if null, generate one. -# -# Results: -# name name of the stack created - -proc ::struct::stack::stack {{name ""}} { - variable stacks - variable counter - - if { [llength [info level 0]] == 1 } { - incr counter - set name "stack${counter}" - } - - if { ![string equal [info commands ::$name] ""] } { - error "command \"$name\" already exists, unable to create stack" - } - set stacks($name) [list ] - - # Create the command to manipulate the stack - interp alias {} ::$name {} ::struct::stack::StackProc $name - - return $name -} - -########################## -# Private functions follow - -# ::struct::stack::StackProc -- -# -# Command that processes all stack object commands. -# -# Arguments: -# name name of the stack object to manipulate. -# args command name and args for the command -# -# Results: -# Varies based on command to perform - -proc ::struct::stack::StackProc {name cmd args} { - # Split the args into command and args components - if { [lsearch -exact $::struct::stack::commands $cmd] == -1 } { - set optlist [join $::struct::stack::commands ", "] - set optlist [linsert $optlist "end-1" "or"] - error "bad option \"$cmd\": must be $optlist" - } - eval [list ::struct::stack::_$cmd $name] $args -} - -# ::struct::stack::_clear -- -# -# Clear a stack. -# -# Arguments: -# name name of the stack object. -# -# Results: -# None. - -proc ::struct::stack::_clear {name} { - set ::struct::stack::stacks($name) [list ] - return -} - -# ::struct::stack::_destroy -- -# -# Destroy a stack object by removing it's storage space and -# eliminating it's proc. -# -# Arguments: -# name name of the stack object. -# -# Results: -# None. - -proc ::struct::stack::_destroy {name} { - unset ::struct::stack::stacks($name) - interp alias {} ::$name {} - return -} - -# ::struct::stack::_peek -- -# -# Retrive the value of an item on the stack without popping it. -# -# Arguments: -# name name of the stack object. -# count number of items to pop; defaults to 1 -# -# Results: -# items top count items from the stack; if there are not enough items -# to fufill the request, throws an error. - -proc ::struct::stack::_peek {name {count 1}} { - variable stacks - if { $count < 1 } { - error "invalid item count $count" - } - - if { $count > [llength $stacks($name)] } { - error "insufficient items on stack to fill request" - } - - if { $count == 1 } { - # Handle this as a special case, so single item pops aren't listified - set item [lindex $stacks($name) end] - return $item - } - - # Otherwise, return a list of items - set result [list ] - for {set i 0} {$i < $count} {incr i} { - lappend result [lindex $stacks($name) "end-${i}"] - } - return $result -} - -# ::struct::stack::_pop -- -# -# Pop an item off a stack. -# -# Arguments: -# name name of the stack object. -# count number of items to pop; defaults to 1 -# -# Results: -# item top count items from the stack; if the stack is empty, -# returns a list of count nulls. - -proc ::struct::stack::_pop {name {count 1}} { - variable stacks - if { $count > [llength $stacks($name)] } { - error "insufficient items on stack to fill request" - } elseif { $count < 1 } { - error "invalid item count $count" - } - - if { $count == 1 } { - # Handle this as a special case, so single item pops aren't listified - set item [lindex $stacks($name) end] - set stacks($name) [lreplace $stacks($name) end end] - return $item - } - - # Otherwise, return a list of items - set result [list ] - for {set i 0} {$i < $count} {incr i} { - lappend result [lindex $stacks($name) "end-${i}"] - } - - # Remove these items from the stack - incr i -1 - set stacks($name) [lreplace $stacks($name) "end-${i}" end] - - return $result -} - -# ::struct::stack::_push -- -# -# Push an item onto a stack. -# -# Arguments: -# name name of the stack object -# args items to push. -# -# Results: -# None. - -proc ::struct::stack::_push {name args} { - if { [llength $args] == 0 } { - error "wrong # args: should be \"$name push item ?item ...?\"" - } - foreach item $args { - lappend ::struct::stack::stacks($name) $item - } -} - -# ::struct::stack::_rotate -- -# -# Rotate the top count number of items by step number of steps. -# -# Arguments: -# name name of the stack object. -# count number of items to rotate. -# steps number of steps to rotate. -# -# Results: -# None. - -proc ::struct::stack::_rotate {name count steps} { - variable stacks - set len [llength $stacks($name)] - if { $count > $len } { - error "insufficient items on stack to fill request" - } - - # Rotation algorithm: - # do - # Find the insertion point in the stack - # Move the end item to the insertion point - # repeat $steps times - - set start [expr {$len - $count}] - set steps [expr {$steps % $count}] - for {set i 0} {$i < $steps} {incr i} { - set item [lindex $stacks($name) end] - set stacks($name) [lreplace $stacks($name) end end] - set stacks($name) [linsert $stacks($name) $start $item] - } - return -} - -# ::struct::stack::_size -- -# -# Return the number of objects on a stack. -# -# Arguments: -# name name of the stack object. -# -# Results: -# count number of items on the stack. - -proc ::struct::stack::_size {name} { - return [llength $::struct::stack::stacks($name)] -} DELETED modules/struct/stack.test Index: modules/struct/stack.test ================================================================== --- modules/struct/stack.test +++ /dev/null @@ -1,285 +0,0 @@ -# -*- tcl -*- -# stack.test: tests for the stack package. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 1998-2000 by Ajuba Solutions. -# All rights reserved. -# -# RCS: @(#) $Id: stack.test,v 1.6 2002/02/01 21:51:42 andreas_kupries Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -source [file join [file dirname [info script]] stack.tcl] -namespace import struct::stack::stack - -test stack-0.1 {stack errors} { - stack mystack - catch {stack mystack} msg - mystack destroy - set msg -} "command \"mystack\" already exists, unable to create stack" -test stack-0.2 {stack errors} {badTest} { - stack mystack - catch {mystack} msg - mystack destroy - set msg -} "wrong # args: should be \"mystack option ?arg arg ...?\"" -test stack-0.3 {stack errors} { - stack mystack - catch {mystack foo} msg - mystack destroy - set msg -} "bad option \"foo\": must be clear, destroy, peek, pop, push, rotate, or size" -test stack-0.4 {stack errors} { - catch {stack set} msg - set msg -} "command \"set\" already exists, unable to create stack" - -test stack-1.1 {stack creation} { - set foo [stack mystack] - set cmd [info commands ::mystack] - set size [mystack size] - mystack destroy - list $foo $cmd $size -} {mystack ::mystack 0} -test stack-1.2 {stack creation} { - set foo [stack] - set cmd [info commands ::$foo] - set size [$foo size] - $foo destroy - list $foo $cmd $size -} {stack1 ::stack1 0} - -test stack-2.1 {stack destroy} { - stack mystack - mystack destroy - info commands ::mystack -} {} - -test stack-3.2 {size operation} { - stack mystack - mystack push a b c d e f g - set size [mystack size] - mystack destroy - set size -} 7 -test stack-3.3 {size operation} { - stack mystack - mystack push a b c d e f g - mystack pop 3 - set size [mystack size] - mystack destroy - set size -} 4 -test stack-3.4 {size operation} { - stack mystack - mystack push a b c d e f g - mystack pop 3 - mystack peek 3 - set size [mystack size] - mystack destroy - set size -} 4 - -test stack-4.1 {push operation} { - stack mystack - catch {mystack push} msg - mystack destroy - set msg -} "wrong # args: should be \"mystack push item ?item ...?\"" -test stack-4.2 {push operation, singleton items} { - stack mystack - mystack push a - mystack push b - mystack push c - set result [list [mystack pop] [mystack pop] [mystack pop]] - mystack destroy - set result -} "c b a" -test stack-4.3 {push operation, multiple items} { - stack mystack - mystack push a b c - set result [list [mystack pop] [mystack pop] [mystack pop]] - mystack destroy - set result -} "c b a" -test stack-4.4 {push operation, spaces in items} { - stack mystack - mystack push a b "foo bar" - set result [list [mystack pop] [mystack pop] [mystack pop]] - mystack destroy - set result -} [list "foo bar" b a] -test stack-4.5 {push operation, bad chars in items} { - stack mystack - mystack push a b \{ - set result [list [mystack pop] [mystack pop] [mystack pop]] - mystack destroy - set result -} [list \{ b a] - -test stack-5.1 {pop operation} { - stack mystack - mystack push a - mystack push b - mystack push c - set result [list [mystack pop] [mystack pop] [mystack pop]] - mystack destroy - set result -} [list c b a] -test stack-5.2 {pop operation, multiple items} { - stack mystack - mystack push a - mystack push b - mystack push c - set result [mystack pop 3] - mystack destroy - set result -} [list c b a] - -test stack-6.1 {peek operation} { - stack mystack - mystack push a - mystack push b - mystack push c - set result [list [mystack peek] [mystack peek] [mystack peek]] - mystack destroy - set result -} [list c c c] - -test stack-6.2 {peek operation} { - stack mystack - catch {mystack peek 0} msg - mystack destroy - set msg -} {invalid item count 0} -test stack-6.3 {peek operation} { - stack mystack - catch {mystack peek -1} msg - mystack destroy - set msg -} {invalid item count -1} -test stack-6.4 {peek operation} { - stack mystack - catch {mystack peek} msg - mystack destroy - set msg -} {insufficient items on stack to fill request} -test stack-6.5 {peek operation} { - stack mystack - mystack push a - catch {mystack peek 2} msg - mystack destroy - set msg -} {insufficient items on stack to fill request} - -test stack-6.6 {pop operation, multiple items} { - stack mystack - mystack push a - mystack push b - mystack push c - set result [list [mystack peek 3] [mystack pop 3]] - mystack destroy - set result -} [list [list c b a] [list c b a]] - -test stack-6.7 {pop operation} { - stack mystack - catch {mystack pop 0} msg - mystack destroy - set msg -} {invalid item count 0} -test stack-6.8 {pop operation} { - stack mystack - catch {mystack pop -1} msg - mystack destroy - set msg -} {invalid item count -1} -test stack-6.9 {pop operation} { - stack mystack - catch {mystack pop} msg - mystack destroy - set msg -} {insufficient items on stack to fill request} -test stack-6.10 {pop operation} { - stack mystack - mystack push a - catch {mystack pop 2} msg - mystack destroy - set msg -} {insufficient items on stack to fill request} - -test stack-7.1 {clear operation} { - stack mystack - mystack push a - mystack push b - mystack push c - set result [list [mystack peek 3]] - mystack clear - lappend result [mystack size] - mystack destroy - set result -} [list [list c b a] 0] - -test stack-8.1 {rotate operation} { - stack mystack - mystack push a b c d e f g h - mystack rotate 3 1 - set result [mystack peek [mystack size]] - mystack destroy - set result -} [list g f h e d c b a] -test stack-8.2 {rotate operation} { - stack mystack - mystack push a b c d e f g h - mystack rotate 3 2 - set result [mystack peek [mystack size]] - mystack destroy - set result -} [list f h g e d c b a] -test stack-8.3 {rotate operation} { - stack mystack - mystack push a b c d e f g h - mystack rotate 3 5 - set result [mystack peek [mystack size]] - mystack destroy - set result -} [list f h g e d c b a] -test stack-8.4 {rotate operation} { - stack mystack - mystack push a b c d e f g h - mystack rotate 8 1 - set result [mystack peek [mystack size]] - mystack destroy - set result -} [list g f e d c b a h] -test stack-8.4 {rotate operation} { - stack mystack - mystack push a b c d e f g h - mystack rotate 8 -1 - set result [mystack peek [mystack size]] - mystack destroy - set result -} [list a h g f e d c b] - -test stack-8.5 {rotate operation} { - stack mystack - catch {mystack rotate 8 -1} msg - mystack destroy - set msg -} {insufficient items on stack to fill request} -test stack-8.6 {rotate operation} { - stack mystack - mystack push a b c d - catch {mystack rotate 8 -1} msg - mystack destroy - set msg -} {insufficient items on stack to fill request} - -::tcltest::cleanupTests DELETED modules/struct/struct.tcl Index: modules/struct/struct.tcl ================================================================== --- modules/struct/struct.tcl +++ /dev/null @@ -1,27 +0,0 @@ -package require Tcl 8.2 -package provide struct 1.3 - -source [file join [file dirname [info script]] graph.tcl] -source [file join [file dirname [info script]] queue.tcl] -source [file join [file dirname [info script]] stack.tcl] -source [file join [file dirname [info script]] tree.tcl] -source [file join [file dirname [info script]] matrix.tcl] -source [file join [file dirname [info script]] pool.tcl] -source [file join [file dirname [info script]] record.tcl] -source [file join [file dirname [info script]] list.tcl] -source [file join [file dirname [info script]] prioqueue.tcl] -source [file join [file dirname [info script]] skiplist.tcl] - -namespace eval ::struct { - namespace import -force graph::* - namespace import -force queue::* - namespace import -force stack::* - namespace import -force tree::* - namespace import -force matrix::* - namespace import -force pool::* - namespace import -force record::* - namespace import -force list::* - namespace import -force prioqueue::* - namespace import -force skiplist::* - namespace export * -} DELETED modules/struct/struct_list.man Index: modules/struct/struct_list.man ================================================================== --- modules/struct/struct_list.man +++ /dev/null @@ -1,464 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[comment {$Id: struct_list.man,v 1.1 2003/04/15 17:44:51 andreas_kupries Exp $}] -[manpage_begin list n 1.2.2] -[copyright {2003 by Kevin B. Kenny. All rights reserved}] -[moddesc {Tcl Data Structures}] -[titledesc {Procedures for manipulating lists}] -[require Tcl 8.0] -[require struct [opt 1.3]] -[description] - -[para] - -The [cmd ::struct::list] namespace contains several useful commands -for processing Tcl lists. Generally speaking, they implement -algorithms more complex or specialized than the ones provided by Tcl -itself. - -[para] - -It exports only a single command, [cmd struct::list]. All -functionality provided here can be reached through a subcommand of -this command. - -[section COMMANDS] -[list_begin definitions] - -[call [cmd ::struct::list] [method longestCommonSubsequence] \ - [arg sequence1] [arg sequence2] [opt [arg maxOccurs]]] - -Returns the longest common subsequence of elements in the two lists -[arg sequence1] and [arg sequence2]. If the [arg maxOccurs] parameter -is provided, the common subsequence is restricted to elements that -occur no more than [arg maxOccurs] times in [arg sequence2]. - -[nl] - -The return value is a list of two lists of equal length. The first -sublist is of indices into [arg sequence1], and the second sublist is -of indices into [arg sequence2]. Each corresponding pair of indices -corresponds to equal elements in the sequences; the sequence returned -is the longest possible. - -[call [cmd ::struct::list] [method longestCommonSubsequence2] \ - [arg {sequence1 sequence2}] [opt [arg maxOccurs]]] - -Returns an approximation to the longest common sequence of elements in -the two lists [arg sequence1] and [arg sequence2]. - -If the [arg maxOccurs] parameter is omitted, the subsequence computed -is exactly the longest common subsequence; otherwise, the longest -common subsequence is approximated by first determining the longest -common sequence of only those elements that occur no more than - -[arg maxOccurs] times in [arg sequence2], and then using that result -to align the two lists, determining the longest common subsequences of -the sublists between the two elements. - -[nl] - -As with [method longestCommonSubsequence], the return value is a list -of two lists of equal length. The first sublist is of indices into -[arg sequence1], and the second sublist is of indices into - -[arg sequence2]. Each corresponding pair of indices corresponds to -equal elements in the sequences. The sequence approximates the -longest common subsequence. - - -[call [cmd ::struct::list] [method lcsInvert] [arg lcsData] [arg len1] [arg len2]] - -This command takes a description of a longest common subsequence - -([arg lcsData]), inverts it, and returns the result. Inversion means -here that as the input describes which parts of the two sequences are -identical the output describes the differences instead. - -[nl] - -To be fully defined the lengths of the two sequences have to be known -and are specified through [arg len1] and [arg len2]. - -[nl] - -The result is a list where each element describes one chunk of the -differences between the two sequences. This description is a list -containing three elements, a type and two pairs of indices into - -[arg sequence1] and [arg sequence2] respectively, in this order. - -The type can be one of three values: - -[list_begin definitions] -[lst_item [const added]] - -Describes an addition. I.e. items which are missing in [arg sequence1] -can be found in [arg sequence2]. - -The pair of indices into [arg sequence1] describes where the added -range had been expected to be in [arg sequence1]. The first index -refers to the item just before the added range, and the second index -refers to the item just after the added range. - -The pair of indices into [arg sequence2] describes the range of items -which has been added to it. The first index refers to the first item -in the range, and the second index refers to the last item in the -range. - -[lst_item [const deleted]] - -Describes a deletion. I.e. items which are in [arg sequence1] are -missing from [arg sequence2]. - -The pair of indices into [arg sequence1] describes the range of items -which has been deleted. The first index refers to the first item in -the range, and the second index refers to the last item in the range. - -The pair of indices into [arg sequence2] describes where the deleted -range had been expected to be in [arg sequence2]. The first index -refers to the item just before the deleted range, and the second index -refers to the item just after the deleted range. - -[lst_item [const changed]] - -Describes a general change. I.e a range of items in [arg sequence1] -has been replaced by a different range of items in [arg sequence2]. - -The pair of indices into [arg sequence1] describes the range of items -which has been replaced. The first index refers to the first item in -the range, and the second index refers to the last item in the range. - -The pair of indices into [arg sequence2] describes the range of items -replacing the original range. Again the first index refers to the -first item in the range, and the second index refers to the last item -in the range. - -[list_end] - -[nl] -[example { - sequence 1 = {a b r a c a d a b r a} - lcs 1 = {1 2 4 5 8 9 10} - lcs 2 = {0 1 3 4 5 6 7} - sequence 2 = {b r i c a b r a c} - - Inversion = {{deleted {0 0} {-1 0}} - {changed {3 3} {2 2}} - {deleted {6 7} {4 5}} - {added {10 11} {8 8}}} -}] - -[emph Notes:] -[nl] -[list_begin bullet] -[bullet] -An index of [const -1] in a [term deleted] chunk refers to just before -the first element of the second sequence. - -[bullet] -Also an index equal to the length of the first sequence in an -[term added] chunk refers to just behind the end of the sequence. - -[list_end] - - -[call [cmd ::struct::list] [method lcsInvert2] [arg lcs1] [arg lcs2] [arg len1] [arg len2]] - -Similar to [method lcsInvert]. Instead of directly taking the result -of a call to [method longestCommonSubsequence] this subcommand expects -the indices for the two sequences in two separate lists. - - -[call [cmd ::struct::list] [method lcsInvertMerge] [arg lcsData] [arg len1] [arg len2]] - -Similar to [method lcsInvert]. It returns essentially the same -structure as that command, except that it may contain chunks of type -[const unchanged] too. - -[nl] - -These new chunks describe the parts which are unchanged between the -two sequences. This means that the result of this command describes -both the changed and unchanged parts of the two sequences in one -structure. - -[nl] -[example { - sequence 1 = {a b r a c a d a b r a} - lcs 1 = {1 2 4 5 8 9 10} - lcs 2 = {0 1 3 4 5 6 7} - sequence 2 = {b r i c a b r a c} - - Inversion/Merge = {{deleted {0 0} {-1 0}} - {unchanged {1 2} {0 1}} - {changed {3 3} {2 2}} - {unchanged {4 5} {3 4}} - {deleted {6 7} {4 5}} - {unchanged {8 10} {5 7}} - {added {10 11} {8 8}}} -}] - - -[call [cmd ::struct::list] [method lcsInvertMerge2] [arg lcs1] [arg lcs2] [arg len1] [arg len2]] - -Similar to [method lcsInvertMerge]. Instead of directly taking the -result of a call to [method longestCommonSubsequence] this subcommand -expects the indices for the two sequences in two separate lists. - - - -[call [cmd ::struct::list] [method reverse] [arg sequence]] - -The subcommand takes a single [arg sequence] as argument and returns a new -sequence containing the elements of the input sequence in reverse -order. - - -[call [cmd ::struct::list] [method assign] [arg sequence] [opt [arg varname]]...] - -The subcommand assigns the first [var n] elements of the input - -[arg sequence] to the zero or more variables whose names were listed -after the sequence, where [var n] is the number of specified -variables. - -[nl] - -If there are more variables specified than there are elements in the -[arg sequence] the empty string will be assigned to the superfluous -variables. - -[nl] - -If there are more elements in the [arg sequence] than variable names -specified the subcommand returns a list containing the unassigned -elements. Else an empty list is returned. - -[example { - tclsh> ::struct::list assign {a b c d e} foo bar - c d e - tclsh> set foo - a - tclsh> set bar - b -}] - - -[call [cmd ::struct::list] [method flatten] [opt [option -full]] [opt [option --]] [arg sequence]] - -The subcommand takes a single [arg sequence] and returns a new -sequence where one level of nesting was removed from the input -sequence. In other words, the sublists in the input sequence are -replaced by their elements. - -[nl] - -The subcommand will remove any nesting it finds if the option -[option -full] is specified. - -[example { - tclsh> ::struct::list flatten {1 2 3 {4 5} {6 7} {{8 9}} 10} - 1 2 3 4 5 6 7 {8 9} 10 - tclsh> ::struct::list flatten -full {1 2 3 {4 5} {6 7} {{8 9}} 10} - 1 2 3 4 5 6 7 8 9 10 -}] - - -[call [cmd ::struct::list] [method map] [arg sequence] [arg cmdprefix]] - -The subcommand takes a [arg sequence] to operate on and a command -prefix ([arg cmdprefix]) specifying an operation, applies the command -prefix to each element of the sequence and returns a sequence -consisting of the results of that application. - -[nl] - -The command prefix will be evaluated with a single word appended to -it. The evaluation takes place in the context of the caller of the -subcommand. - -[nl] - -[example { - tclsh> # squaring all elements in a list - - tclsh> proc sqr {x} {expr {$x*$x}} - tclsh> ::struct::list map {1 2 3 4 5} sqr - 1 4 9 16 25 - - tclsh> # Retrieving the second column from a matrix - tclsh> # given as list of lists. - - tclsh> proc projection {n list} {::lindex $list $n} - tclsh> ::struct::list map {{a b c} {1 2 3} {d f g}} {projection 1} - b 2 f -}] - - -[call [cmd ::struct::list] [method fold] [arg sequence] [arg initialvalue] [arg cmdprefix]] - -The subcommand takes a [arg sequence] to operate on, an arbitrary -string [arg {initial value}] and a command prefix ([arg cmdprefix]) -specifying an operation. - -[nl] - -The command prefix will be evaluated with two words appended to -it. The second of these words will always be an element of the -sequence. The evaluation takes place in the context of the caller of -the subcommand. - -[nl] - -It then reduces the sequence into a single value through repeated -application of the command prefix and returns that value. This -reduction is done by - -[list_begin definitions] -[lst_item [const 1]] - -Application of the command to the initial value and the first element -of the list. - -[lst_item [const 2]] - -Application of the command to the result of the last call and the -second element of the list. - -[lst_item [const ...]] -[lst_item [const i]] - -Application of the command to the result of the last call and the -[var i]'th element of the list. - -[lst_item [const ...]] -[lst_item [const end]] - -Application of the command to the result of the last call and the last -element of the list. The result of this call is returned as the result -of the subcommand. - -[list_end] -[nl] -[example { - tclsh> # summing the elements in a list. - tclsh> proc + {a b} {expr {$a + $b}} - tclsh> ::listx fold {1 2 3 4 5} 0 + - 15 -}] - -[call [cmd ::struct::list] [method iota] [arg n]] - -The subcommand returns a list containing the integer numbers -in the range [const {[0,n)}]. The element at index [var i] -of the list contain the number [const i]. - -[nl] - -For "[arg n] == [const 0]" an empty list will be returned. - - -[call [cmd ::struct::list] [method equal] [arg a] [arg b]] - -The subcommand compares the two lists [arg a] and [arg b] for -equality. In other words, they have to be of the same length and have -to contain the same elements in the same order. If an element is a -list the same definition of equality applies recursively. - -[nl] - -A boolean vlaue will be returned as the result of the command. -This value will be [const true] if the two lists are equal, and -[const false] else. - - -[call [cmd ::struct::list] [method repeat] [arg value] [arg size]...] - -The subcommand creates a (nested) list containing the [arg value] in -all positions. The exact size and degree of nesting is determined by -the [arg size] arguments, all of which have to be integer numbers -greater than or equal to zero. - -[nl] - -A single argument [arg size] which is a list of more than one element -will be treated as if more than argument [arg size] was specified. - -[nl] - -If only one argument [arg size] is present the returned list will not -be nested, of length [arg size] and contain [arg value] in all -positions. - -If more than one [arg size] argument is present the returned -list will be nested, and of the length specified by the last -[arg size] argument given to it. The elements of that list -are defined as the result of [cmd Repeat] for the same arguments, -but with the last [arg size] value removed. - -[nl] - -An empty list will be returned if no [arg size] arguments are present. - -[nl] -[example { - tclsh> lrepeat 0 3 4 - {0 0 0} {0 0 0} {0 0 0} {0 0 0} - tclsh> lrepeat 0 {3 4} - {0 0 0} {0 0 0} {0 0 0} {0 0 0} - tclsh> lrepeat 0 {3 4 5} - {{0 0 0} {0 0 0} {0 0 0} {0 0 0}} {{0 0 0} {0 0 0} {0 0 0} {0 0 0}} {{0 0 0} {0 0 0} {0 0 0} {0 0 0}} {{0 0 0} {0 0 0} {0 0 0} {0 0 0}} {{0 0 0} {0 0 0} {0 0 0} {0 0 0}} -}] - - -[list_end] - -[section {LONGEST COMMON SUBSEQUENCE AND FILE COMPARISON}] - -[para] - -The [method longestCommonSubsequence] subcommand forms the core of a -flexible system for doing differential comparisons of files, similar -to the capability offered by the Unix command [syscmd diff]. - -While this procedure is quite rapid for many tasks of file comparison, -its performance degrades severely if [arg sequence2] contains many -equal elements (as, for instance, when using this procedure to compare -two files, a quarter of whose lines are blank. This drawback is -intrinsic to the algorithm used (see the Reference for details). - -[para] - -One approach to dealing with the performance problem that is sometimes -effective in practice is arbitrarily to exclude elements that appear -more than a certain number of times. - -This number is provided as the [arg maxOccurs] parameter. If frequent -lines are excluded in this manner, they will not appear in the common -subsequence that is computed; the result will be the longest common -subsequence of infrequent elements. - -The procedure [method longestCommonSubsequence2] implements this -heuristic. - -It functions as a wrapper around [method longestCommonSubsequence]; it -computes the longest common subsequence of infrequent elements, and -then subdivides the subsequences that lie between the matches to -approximate the true longest common subsequence. - -[section REFERENCES] - -J. W. Hunt and M. D. McIlroy, "An algorithm for differential -file comparison," Comp. Sci. Tech. Rep. #41, Bell Telephone -Laboratories (1976). Available on the Web at the second -author's personal site: [uri http://www.cs.dartmouth.edu/~doug/] - -[keywords list diff differential comparison common subsequence] -[keywords {longest common subsequence}] -[keywords reverse] -[keywords assign] -[keywords flatten] -[keywords map] -[keywords folding reduce] -[keywords equality equal repetition repeating] -[manpage_end] DELETED modules/struct/tree.man Index: modules/struct/tree.man ================================================================== --- modules/struct/tree.man +++ /dev/null @@ -1,292 +0,0 @@ -[comment {-*- tcl -*-}] -[manpage_begin tree n 1.2.1] -[copyright {2002 Andreas Kupries }] -[moddesc {Tcl Data Structures}] -[titledesc {Create and manipulate tree objects}] -[require Tcl 8.2] -[require struct [opt 1.3]] -[description] -[para] - -The [cmd ::struct::tree] command creates a new tree object with an -associated global Tcl command whose name is [arg treeName]. This -command may be used to invoke various operations on the tree. It has -the following general form: - -[list_begin definitions] -[call [cmd treeName] [method option] [opt [arg "arg arg ..."]]] - -[arg Option] and the [arg arg]s determine the exact behavior of the -command. - -[list_end] - -[para] - -A tree is a collection of elements, called nodes, one of which is -distinguished as a root, along with a relation ("parenthood") that -places a hierarchical structure on the nodes. (Data Structures and -Algorithms; Aho, Hopcroft and Ullman; Addison-Wesley, 1987). In -addition to maintaining the node relationships, this tree -implementation allows any number of keyed values to be associated with -each node. - -[para] - -The following commands are possible for tree objects: - -[list_begin definitions] - -[call [arg treeName] [method append] [arg node] [opt "-key [arg key]"] [arg value]] - -Appends a [arg value] to one of the keyed values associated with an -node. If no [arg key] is specified, the key [const data] is assumed. - - -[call [arg treeName] [method children] [arg node]] - -Return a list of the children of [arg node]. - - -[call [arg treeName] [method cut] [arg node]] - -Removes the node specified by [arg node] from the tree, but not its -children. The children of [arg node] are made children of the parent -of the [arg node], at the index at which [arg node] was located. - - -[call [arg treeName] [method delete] [arg node] [opt "[arg node] ..."]] - -Remove the specified nodes from the tree. All of the nodes' children -will be removed as well to prevent orphaned nodes. - - -[call [arg treeName] [method depth] [arg node]] - -Return the number of steps from node [arg node] to the root node. - - -[call [arg treeName] [method destroy]] - -Destroy the tree, including its storage space and associated command. - - -[call [arg treeName] [method exists] [arg node]] - -Remove true if the specified node exists in the tree. - - -[call [arg treeName] [method get] [arg node] [opt "[option -key] [arg key]"]] - -Return the value associated with the key [arg key] for the node - -[arg node]. If no key is specified, the key [const data] is assumed. - -[call [arg treeName] [method getall] [arg node]] - -Returns a serialized list of key/value pairs (suitable for use with -[lb][cmd {array set}][rb]) for the [arg node]. - - -[call [arg treeName] [method keys] [arg node]] - -Returns a list of keys for the [arg node]. - - -[call [arg treeName] [method keyexists] [arg node] [opt "-key [arg key]"]] - -Return true if the specified [arg key] exists for the [arg node]. If -no [arg key] is specified, the key [const data] is assumed. - - -[call [arg treeName] [method index] [arg node]] - -Returns the index of [arg node] in its parent's list of children. For -example, if a node has [term nodeFoo], [term nodeBar], and - -[term nodeBaz] as children, in that order, the index of - -[term nodeBar] is 1. - - -[call [arg treeName] [method insert] [arg parent] [arg index] [opt "[arg child] [opt "[arg child] ..."]"]] - -Insert one or more nodes into the tree as children of the node - -[arg parent]. The nodes will be added in the order they are given. If -[arg parent] is [const root], it refers to the root of the tree. The -new nodes will be added to the [arg parent] node's child list at the -index given by [arg index]. The [arg index] can be [const end] in -which case the new nodes will be added after the current last child. - -[nl] - -If any of the specified children already exist in [arg treeName], -those nodes will be moved from their original location to the new -location indicated by this command. - -[nl] - -If no [arg child] is specified, a single node will be added, and a -name will be generated for the new node. The generated name is of the -form [emph node][var x], where [var x] is a number. If names are -specified they must neither contain whitespace nor colons (":"). - -[nl] - -The return result from this command is a list of nodes added. - - -[call [arg treeName] [method isleaf] [arg node]] - -Returns true if [arg node] is a leaf of the tree (if [arg node] has no -children), false otherwise. - - -[call [arg treeName] [method lappend] [arg node] [opt "-key [arg key]"] [arg value]] - -Appends a [arg value] (as a list) to one of the keyed values -associated with an [arg node]. If no [arg key] is specified, the key -[const data] is assumed. - - -[call [arg treeName] [method move] [arg parent] [arg index] [arg node] [opt "[arg node] ..."]] - -Make the specified nodes children of [arg parent], inserting them into -the parent's child list at the index given by [arg index]. Note that -the command will take all nodes out of the tree before inserting them -under the new parent, and that it determines the position to place -them into after the removal, before the re-insertion. This behaviour -is important when it comes to moving one or more nodes to a different -index without changing their parent node. - -[call [arg treeName] [method next] [arg node] ] - -Return the right sibling of [arg node], or the empty string if - -[arg node] was the last child of its parent. - - -[call [arg treeName] [method numchildren] [arg node]] - -Return the number of immediate children of [arg node]. - - -[call [arg treeName] [method parent] [arg node]] - -Return the parent of [arg node]. - - -[call [arg treeName] [method previous] [arg node] ] - -Return the left sibling of [arg node], or the empty string if - -[arg node] was the first child of its parent. - - -[call [arg treeName] [method set] [arg node] [opt "[option -key] [arg key]"] [opt [arg value]]] - -Set or get one of the keyed values associated with a node. If no key -is specified, the key [const data] is assumed. Each node that is -added to a tree has the value "" assigned to the key [const data] -automatically. A node may have any number of keyed values associated -with it. If [arg value] is not specified, this command returns the -current value assigned to the key; if [arg value] is specified, this -command assigns that value to the key. - - -[call [arg treeName] [method size] [opt [arg node]]] - - -Return a count of the number of descendants of the node [arg node]; if -no node is specified, [const root] is assumed. - - -[call [arg treeName] [method splice] [arg parent] [arg from] [opt [arg to]] [opt [arg child]]] - -Insert a node named [arg child] into the tree as a child of the node -[arg parent]. If [arg parent] is [const root], it refers to the root -of the tree. The new node will be added to the parent node's child -list at the index given by [arg from]. The children of [arg parent] -which are in the range of the indices [arg from] and [arg to] are made -children of [arg child]. If the value of [arg to] is not specified it -defaults to [const end]. If no name is given for [arg child], a name -will be generated for the new node. The generated name is of the form -[emph node][var x], where [var x] is a number. The return result -from this command is the name of the new node. - - -[call [arg treeName] [method swap] [arg node1] [arg node2]] - -Swap the position of [arg node1] and [arg node2] in the tree. - - -[call [arg treeName] [method unset] [arg node] [opt "[option -key] [arg key]"]] - -Remove a keyed value from the node [arg node]. If no key is -specified, the key [const data] is assumed. - - -[call [arg treeName] [method walk] [arg node] [opt "[option -order] [arg order]"] [opt "[option -type] [arg type]"] [option -command] [arg cmd]] - -Perform a breadth-first or depth-first walk of the tree starting at -the node [arg node]. The type of walk, breadth-first or depth-first, -is determined by the value of [arg type]; [const bfs] indicates -breadth-first, [const dfs] indicates depth-first. Depth-first is the -default. The order of the walk, pre-, post-, both- or in-order is -determined by the value of [arg order]; [const pre] indicates -pre-order, [const post] indicates post-order, [const both] indicates -both-order and [const in] indicates in-order. Pre-order is the -default. - -[nl] - -Pre-order walking means that a parent node is visited before any of -its children. For example, a breadth-first search starting from the -root will visit the root, followed by all of the root's children, -followed by all of the root's grandchildren. Post-order walking means -that a parent node is visited after any of its children. Both-order -walking means that a parent node is visited before [emph and] after -any of its children. In-order walking means that a parent node is -visited after its first child and before the second. This is a -generalization of in-order walking for binary trees and will do the -right thing if a binary is walked. The combination of a breadth-first -walk with in-order is illegal. - -[nl] - -As the walk progresses, the command [arg cmd] will be evaluated at -each node. Percent substitution will be performed on [arg cmd] before -evaluation, just as in a [cmd bind] script. The following -substitutions are recognized: - -[list_begin definitions] - -[lst_item [const %%]] - -Insert the literal % character. - -[lst_item [const %t]] - -Name of the tree object. - -[lst_item [const %n]] - -Name of the current node. - -[lst_item [const %a]] - -Name of the action occurring; one of [const enter], [const leave], -or [const visit]. [const enter] actions occur during pre-order -walks; [const leave] actions occur during post-order walks; - -[const visit] actions occur during in-order walks. In a both-order -walk, the command will be evaluated twice for each node; the action is -[const enter] for the first evaluation, and [const leave] for the -second. - -[list_end] -[list_end] - -[keywords tree] -[manpage_end] DELETED modules/struct/tree.n Index: modules/struct/tree.n ================================================================== --- modules/struct/tree.n +++ /dev/null @@ -1,209 +0,0 @@ -'\" -'\" Copyright (c) 1998-2000 by Ajuba Solutions. -'\" All rights reserved. -'\" -'\" RCS: @(#) $Id: tree.n,v 1.16 2002/05/09 05:46:04 andreas_kupries Exp $ -'\" -.so man.macros -.TH tree n 1.2.1 Struct "Tcl Data Structures" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -::struct::tree \- Create and manipulate tree objects -.SH SYNOPSIS -\fBpackage require Tcl 8.2\fR -.sp -\fBpackage require struct ?1.2.1?\fR -.sp -\fB::struct::tree\fR \fItreeName\fR -.sp -.BE -.SH DESCRIPTION -.PP -The \fB::struct::tree\fR command creates a new tree object with an -associated global Tcl command whose name is \fItreeName\fR. This command -may be used to invoke various operations on the tree. It has the -following general form: -.CS -\fItreeName option \fR?\fIarg arg ...\fR? -.CE -\fIOption\fR and the \fIarg\fRs -determine the exact behavior of the command. -.PP -A tree is a collection of elements, called nodes, one of which is -distinguished as a root, along with a relation ("parenthood") that -places a hierarchical structure on the nodes. (\fIData Structures and -Algorithms\fR; Aho, Hopcroft and Ullman; Addison-Wesley, 1987). In -addition to maintaining the node relationships, this tree -implementation allows any number of keyed values to be associated with -each node. -.PP -The following commands are possible for tree objects: -.TP -\fItreeName\fR \fBappend\fR \fInode\fR ?\fI-key key\fR? \fIvalue\fR -Appends a value to one of the keyed values associated with an node. -If no key is specified, the key \fBdata\fR is assumed. -.TP -\fItreeName\fR \fBchildren\fR \fInode\fR -Return a list of the children of \fInode\fR. -.TP -\fItreeName\fR \fBcut\fR \fInode\fR -Removes the node specified by \fInode\fR from the tree, but not its -children. The children of \fInode\fR are made children of the parent of -the \fInode\fR, at the index at which \fInode\fR was located. -.TP -\fItreeName\fR \fBdelete\fR \fInode\fR ?\fInode\fR ...? -Remove the specified nodes from the tree. All of the nodes' children -will be removed as well to prevent orphaned nodes. -.TP -\fItreeName \fBdepth\fR \fInode\fR -Return the number of steps from node \fInode\fR to the root node. -.TP -\fItreeName \fBdestroy\fR -Destroy the tree, including its storage space and associated command. -.TP -\fItreeName\fR \fBexists\fR \fInode\fR -Remove true if the specified node exists in the tree. -.TP -\fItreeName\fR \fBget\fR \fInode\fR ?\fI-key key\fR? -Return the value associated with the key \fIkey\fR for the node -\fInode\fR. If no key is specified, the key \fBdata\fR is assumed. -.TP -\fItreeName\fR \fBgetall\fR \fInode\fR -Returns a serialized list of key/value pairs (suitable for use with -\fB[array set]\fR) for the \fInode\fR. -.TP -\fItreeName\fR \fBkeys\fR \fInode\fR -Returns a list of keys for the \fInode\fR. -.TP -\fItreeName\fR \fBkeyexists\fR \fInode\fR ?\fI-key key\fR? -Return true if the specified \fIkey\fR exists for the \fInode\fR. -If no key is specified, the key \fBdata\fR is assumed. -.TP -\fItreeName \fBindex\fR \fInode\fR -Returns the index of \fInode\fR in its parent's list of children. For -example, if a node has \fBnodeFoo\fR, \fBnodeBar\fR, and \fBnodeBaz\fR as -children, in that order, the index of \fBnodeBar\fR is 1. -.TP -\fItreeName\fR \fBinsert\fR \fIparent\fR \fIindex\fR ?\fIchild\fR ?\fIchild ...\fR?? -Insert one or more nodes into the tree as children of the node -\fIparent\fR. The nodes will be added in the order they are given. -If \fIparent\fR is \fBroot\fR, it refers to the root of the tree. The -new nodes will be added to the \fIparent\fR node's child list at the -index given by \fIindex\fR. The \fIindex\fR can be \fBend\fR in which -case the new nodes will be added after the current last child. - -If any of the specified children already exist in \fItreeName\fR, -those nodes will be moved from their original location to the new -location indicated by this command. - -If no \fIchild\fR is specified, a single node will be added, and a -name will be generated for the new node. The generated name is of the -form \fBnode\fR\fIx\fR, where \fIx\fR is a number. If names are -specified they must neither contain whitespace nor colons (\fB:\fR). - -The return result from this command is a list of nodes added. -.TP -\fItreeName \fBisleaf\fR \fInode\fR -Returns true if \fInode\fR is a leaf of the tree (if \fInode\fR has no -children), false otherwise. -.TP -\fItreeName\fR \fBlappend\fR \fInode\fR ?\fI-key key\fR? \fIvalue\fR -Appends a value (as a list) to one of the keyed values associated with an node. -If no key is specified, the key \fBdata\fR is assumed. -.TP -\fItreeName\fR \fBmove\fR \fIparent\fR \fIindex\fR \fInode\fR ?\fInode ...\fR? -Make the specified nodes children of \fIparent\fR, inserting them -into the parent's child list at the index given by \fIindex\fR. -.TP -\fItreeName\fR \fBnext\fR \fInode\fR -Return the right sibling of \fInode\fR, or the empty string if -\fInode\fR was the last child of its parent. -.TP -\fItreeName\fR \fBnumchildren\fR \fInode\fR -Return the number of immediate children of \fInode\fR. -.TP -\fItreeName\fR \fBparent\fR \fInode\fR -Return the parent of \fInode\fR. -.TP -\fItreeName\fR \fBprevious\fR \fInode\fR -Return the left sibling of \fInode\fR, or the empty string if -\fInode\fR was the first child of its parent. -.TP -\fItreeName\fR \fBset\fR \fInode\fR ?\fI-key key\fR? ?\fIvalue\fR? -Set or get one of the keyed values associated with a node. If no key -is specified, the key \fBdata\fR is assumed. Each node that is added -to a tree has the value "" assigned to the key \fBdata\fR -automatically. A node may have any number of keyed values associated -with it. If \fIvalue\fR is not specified, this command returns the -current value assigned to the key; if \fIvalue\fR is specified, this -command assigns that value to the key. -.TP -\fItreeName\fR \fBsize\fR ?\fInode\fR? -Return a count of the number of descendants of the node \fInode\fR; if -no node is specified, \fBroot\fR is assumed. -.TP -\fItreeName\fR \fBsplice\fR \fIparent\fR \fIfrom\fR ?\fIto\fR? ?\fIchild\fR? -Insert a node named \fIchild\fR into the tree as a child of the node -\fIparent\fR. If \fIparent\fR is \fBroot\fR, it refers to the root of -the tree. The new node will be added to the parent node's child list -at the index given by \fIfrom\fR. The children of \fIparent\fR which -are in the range of the indices \fIfrom\fR and \fIto\fR are made -children of \fIchild\fR. If the value of \fIto\fR is not specified it -defaults to \fBend\fR. If no name is given for \fIchild\fR, a name -will be generated for the new node. The generated name is of the form -\fBnode\fR\fIx\fR, where \fIx\fR is a number. The return result from -this command is the name of the new node. -.TP -\fItreeName\fR \fBswap\fR \fInode1\fR \fInode2\fR -Swap the position of \fInode1\fR and \fInode2\fR in the tree. -.TP -\fItreeName\fR \fBunset\fR \fInode\fR ?\fI-key key\fR? -Remove a keyed value from the node \fInode\fR. If no key is -specified, the key \fBdata\fR is assumed. -.TP -\fItreeName\fR \fBwalk\fR \fInode\fR ?\fI-order order\fR? ?\fI-type type\fR? \fI-command cmd\fR - -Perform a breadth-first or depth-first walk of the tree starting at -the node \fInode\fR. The type of walk, breadth-first or depth-first, -is determined by the value of \fItype\fR; \fBbfs\fR indicates -breadth-first, \fBdfs\fR indicates depth-first. Depth-first is the -default. The order of the walk, pre-, post-, both- or in-order is -determined by the value of \fIorder\fR; \fBpre\fR indicates pre-order, -\fBpost\fR indicates post-order, \fBboth\fR indicates both-order and -\fBin\fR indicates in-order. Pre-order is the default. - -Pre-order walking means that a parent node is visited before any of -its children. For example, a breadth-first search starting from the -root will visit the root, followed by all of the root's children, -followed by all of the root's grandchildren. Post-order walking means -that a parent node is visited after any of its children. Both-order -walking means that a parent node is visited before \fBand\fR after any -of its children. In-order walking means that a parent node is visited -after its first child and before the second. This is a generalization -of in-order walking for binary trees and will do the right thing if a -binary is walked. The combination of a breadth-first walk with -in-order is illegal. - -As the walk progresses, the command \fIcmd\fR will be evaluated at -each node. Percent substitution will be performed on \fIcmd\fR before -evaluation, just as in a \fBbind\fR script. The following -substitutions are recognized: -.RS -.IP \fB%%\fR -Insert the literal % character. -.IP \fB%t\fR -Name of the tree object. -.IP \fB%n\fR -Name of the current node. -.IP \fB%a\fR -Name of the action occurring; one of \fBenter\fR, \fBleave\fR, or -\fBvisit\fR. \fBenter\fR actions occur during pre-order walks; -\fBleave\fR actions occur during post-order walks; \fBvisit\fR actions -occur during in-order walks. In a both-order walk, the command will -be evaluated twice for each node; the action is \fBenter\fR for the -first evaluation, and \fBleave\fR for the second. -.RE - -.SH KEYWORDS -tree DELETED modules/struct/tree.tcl Index: modules/struct/tree.tcl ================================================================== --- modules/struct/tree.tcl +++ /dev/null @@ -1,1339 +0,0 @@ -# tree.tcl -- -# -# Implementation of a tree data structure for Tcl. -# -# Copyright (c) 1998-2000 by Ajuba Solutions. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: tree.tcl,v 1.18 2002/08/06 20:52:54 andreas_kupries Exp $ - -package require Tcl 8.2 - -namespace eval ::struct {} - -namespace eval ::struct::tree { - # Data storage in the tree module - # ------------------------------- - # - # There's a lot of bits to keep track of for each tree: - # nodes - # node values - # node relationships - # - # It would quickly become unwieldy to try to keep these in arrays or lists - # within the tree namespace itself. Instead, each tree structure will get - # its own namespace. Each namespace contains: - # children array mapping nodes to their children list - # parent array mapping nodes to their parent node - # node:$node array mapping keys to values for the node $node - - # counter is used to give a unique name for unnamed trees - variable counter 0 - - # commands is the list of subcommands recognized by the tree - variable commands [list \ - "append" \ - "children" \ - "cut" \ - "destroy" \ - "delete" \ - "depth" \ - "exists" \ - "get" \ - "getall" \ - "index" \ - "insert" \ - "isleaf" \ - "keys" \ - "keyexists" \ - "lappend" \ - "move" \ - "next" \ - "numchildren" \ - "parent" \ - "previous" \ - "set" \ - "size" \ - "splice" \ - "swap" \ - "unset" \ - "walk" \ - ] - - # Only export one command, the one used to instantiate a new tree - namespace export tree -} - -# ::struct::tree::tree -- -# -# Create a new tree with a given name; if no name is given, use -# treeX, where X is a number. -# -# Arguments: -# name Optional name of the tree; if null or not given, generate one. -# -# Results: -# name Name of the tree created - -proc ::struct::tree::tree {{name ""}} { - variable counter - - if { [llength [info level 0]] == 1 } { - incr counter - set name "tree${counter}" - } - - if { [llength [info commands ::$name]] } { - error "command \"$name\" already exists, unable to create tree" - } - - # Set up the namespace - namespace eval ::struct::tree::tree$name { - # Set up root node's child list - variable children - set children(root) [list ] - - # Set root node's parent - variable parent - set parent(root) [list ] - - # Set up the root node's data - variable noderoot - set noderoot(data) "" - - # Set up a value for use in creating unique node names - variable nextUnusedNode - set nextUnusedNode 1 - } - - # Create the command to manipulate the tree - interp alias {} ::$name {} ::struct::tree::TreeProc $name - - return $name -} - -########################## -# Private functions follow - -# ::struct::tree::TreeProc -- -# -# Command that processes all tree object commands. -# -# Arguments: -# name Name of the tree object to manipulate. -# cmd Subcommand to invoke. -# args Arguments for subcommand. -# -# Results: -# Varies based on command to perform - -proc ::struct::tree::TreeProc {name {cmd ""} args} { - # Do minimal args checks here - if { [llength [info level 0]] == 2 } { - error "wrong # args: should be \"$name option ?arg arg ...?\"" - } - - # Split the args into command and args components - if { [llength [info commands ::struct::tree::_$cmd]] == 0 } { - variable commands - set optlist [join $commands ", "] - set optlist [linsert $optlist "end-1" "or"] - error "bad option \"$cmd\": must be $optlist" - } - eval [list ::struct::tree::_$cmd $name] $args -} - -# ::struct::tree::_children -- -# -# Return the child list for a given node of a tree. -# -# Arguments: -# name Name of the tree object. -# node Node to look up. -# -# Results: -# children List of children for the node. - -proc ::struct::tree::_children {name node} { - if { ![_exists $name $node] } { - error "node \"$node\" does not exist in tree \"$name\"" - } - - upvar ::struct::tree::tree${name}::children children - return $children($node) -} - -# ::struct::tree::_cut -- -# -# Destroys the specified node of a tree, but not its children. -# These children are made into children of the parent of the -# destroyed node at the index of the destroyed node. -# -# Arguments: -# name Name of the tree object. -# node Node to look up and cut. -# -# Results: -# None. - -proc ::struct::tree::_cut {name node} { - if { [string equal $node "root"] } { - # Can't delete the special root node - error "cannot cut root node" - } - - if { ![_exists $name $node] } { - error "node \"$node\" does not exist in tree \"$name\"" - } - - upvar ::struct::tree::tree${name}::parent parent - upvar ::struct::tree::tree${name}::children children - - # Locate our parent, children and our location in the parent - set parentNode $parent($node) - set childNodes $children($node) - - set index [lsearch -exact $children($parentNode) $node] - - # Excise this node from the parent list, - set newChildren [lreplace $children($parentNode) $index $index] - - # Put each of the children of $node into the parent's children list, - # in the place of $node, and update the parent pointer of those nodes. - foreach child $childNodes { - set newChildren [linsert $newChildren $index $child] - set parent($child) $parentNode - incr index - } - set children($parentNode) $newChildren - - # Remove all record of $node - unset parent($node) - unset children($node) - # FRINK: nocheck - unset ::struct::tree::tree${name}::node$node - - return -} - -# ::struct::tree::_delete -- -# -# Remove a node from a tree, including all of its values. Recursively -# removes the node's children. -# -# Arguments: -# name Name of the tree. -# node Node to delete. -# -# Results: -# None. - -proc ::struct::tree::_delete {name node} { - if { [string equal $node "root"] } { - # Can't delete the special root node - error "cannot delete root node" - } - - if { ![_exists $name $node] } { - error "node \"$node\" does not exist in tree \"$name\"" - } - - upvar ::struct::tree::tree${name}::children children - upvar ::struct::tree::tree${name}::parent parent - - # Remove this node from its parent's children list - set parentNode $parent($node) - set index [lsearch -exact $children($parentNode) $node] - set children($parentNode) [lreplace $children($parentNode) $index $index] - - # Yes, we could use the stack structure implemented in ::struct::stack, - # but it's slower than inlining it. Since we don't need a sophisticated - # stack, don't bother. - set st [list ] - foreach child $children($node) { - lappend st $child - } - - unset children($node) - unset parent($node) - # FRINK: nocheck - unset ::struct::tree::tree${name}::node$node - - while { [llength $st] > 0 } { - set node [lindex $st end] - set st [lreplace $st end end] - foreach child $children($node) { - lappend st $child - } - unset children($node) - unset parent($node) - # FRINK: nocheck - unset ::struct::tree::tree${name}::node$node - } - return -} - -# ::struct::tree::_depth -- -# -# Return the depth (distance from the root node) of a given node. -# -# Arguments: -# name Name of the tree. -# node Node to find. -# -# Results: -# depth Number of steps from node to the root node. - -proc ::struct::tree::_depth {name node} { - if { ![_exists $name $node] } { - error "node \"$node\" does not exist in tree \"$name\"" - } - upvar ::struct::tree::tree${name}::parent parent - set depth 0 - while { ![string equal $node "root"] } { - incr depth - set node $parent($node) - } - return $depth -} - -# ::struct::tree::_destroy -- -# -# Destroy a tree, including its associated command and data storage. -# -# Arguments: -# name Name of the tree to destroy. -# -# Results: -# None. - -proc ::struct::tree::_destroy {name} { - namespace delete ::struct::tree::tree$name - interp alias {} ::$name {} -} - -# ::struct::tree::_exists -- -# -# Test for existance of a given node in a tree. -# -# Arguments: -# name Name of the tree to query. -# node Node to look for. -# -# Results: -# 1 if the node exists, 0 else. - -proc ::struct::tree::_exists {name node} { - return [info exists ::struct::tree::tree${name}::parent($node)] -} - -# ::struct::tree::__generateUniqueNodeName -- -# -# Generate a unique node name for the given tree. -# -# Arguments: -# name Name of the tree to generate a unique node name for. -# -# Results: -# node Name of a node guaranteed to not exist in the tree. - -proc ::struct::tree::__generateUniqueNodeName {name} { - upvar ::struct::tree::tree${name}::nextUnusedNode nextUnusedNode - while {[_exists $name "node${nextUnusedNode}"]} { - incr nextUnusedNode - } - return "node${nextUnusedNode}" -} - -# ::struct::tree::_get -- -# -# Get a keyed value from a node in a tree. -# -# Arguments: -# name Name of the tree. -# node Node to query. -# flag Optional flag specifier; if present, must be "-key". -# key Optional key to lookup; defaults to data. -# -# Results: -# value Value associated with the key given. - -proc ::struct::tree::_get {name node {flag -key} {key data}} { - if { ![_exists $name $node] } { - error "node \"$node\" does not exist in tree \"$name\"" - } - - upvar ::struct::tree::tree${name}::node${node} data - if { ![info exists data($key)] } { - error "invalid key \"$key\" for node \"$node\"" - } - return $data($key) -} - -# ::struct::tree::_getall -- -# -# Get a serialized list of key/value pairs from a node in a tree. -# -# Arguments: -# name Name of the tree. -# node Node to query. -# -# Results: -# value A serialized list of key/value pairs. - -proc ::struct::tree::_getall {name node args} { - if { ![_exists $name $node] } { - error "node \"$node\" does not exist in tree \"$name\"" - } - - if { [llength $args] } { - error "wrong # args: should be \"$name getall $node\"" - } - - upvar ::struct::tree::tree${name}::node${node} data - return [array get data] -} - -# ::struct::tree::_keys -- -# -# Get a list of keys from a node in a tree. -# -# Arguments: -# name Name of the tree. -# node Node to query. -# -# Results: -# value A serialized list of key/value pairs. - -proc ::struct::tree::_keys {name node args} { - if { ![_exists $name $node] } { - error "node \"$node\" does not exist in tree \"$name\"" - } - - if { [llength $args] } { - error "wrong # args: should be \"$name keys $node\"" - } - - upvar ::struct::tree::tree${name}::node${node} data - return [array names data] -} - -# ::struct::tree::_keyexists -- -# -# Test for existance of a given key for a node in a tree. -# -# Arguments: -# name Name of the tree. -# node Node to query. -# flag Optional flag specifier; if present, must be "-key". -# key Optional key to lookup; defaults to data. -# -# Results: -# 1 if the key exists, 0 else. - -proc ::struct::tree::_keyexists {name node {flag -key} {key data}} { - if { ![_exists $name $node] } { - error "node \"$node\" does not exist in tree \"$name\"" - } - - if { ![string equal $flag "-key"] } { - error "invalid option \"$flag\": should be -key" - } - - upvar ::struct::tree::tree${name}::node${node} data - return [info exists data($key)] -} - -# ::struct::tree::_index -- -# -# Determine the index of node with in its parent's list of children. -# -# Arguments: -# name Name of the tree. -# node Node to look up. -# -# Results: -# index The index of the node in its parent - -proc ::struct::tree::_index {name node} { - if { [string equal $node "root"] } { - # The special root node has no parent, thus no index in it either. - error "cannot determine index of root node" - } - - if { ![_exists $name $node] } { - error "node \"$node\" does not exist in tree \"$name\"" - } - - upvar ::struct::tree::tree${name}::children children - upvar ::struct::tree::tree${name}::parent parent - - # Locate the parent and ourself in its list of children - set parentNode $parent($node) - - return [lsearch -exact $children($parentNode) $node] -} - -# ::struct::tree::_insert -- -# -# Add a node to a tree; if the node(s) specified already exist, they -# will be moved to the given location. -# -# Arguments: -# name Name of the tree. -# parentNode Parent to add the node to. -# index Index at which to insert. -# args Node(s) to insert. If none is given, the routine -# will insert a single node with a unique name. -# -# Results: -# nodes List of nodes inserted. - -proc ::struct::tree::_insert {name parentNode index args} { - if { [llength $args] == 0 } { - # No node name was given; generate a unique one - set args [list [__generateUniqueNodeName $name]] - } else { - # Validate the node names - foreach child $args { - if {[regexp "\[\r\t\n :\]" $child]} { - return -code error "invalid node name \"$child\"" - } - } - } - - if { ![_exists $name $parentNode] } { - error "parent node \"$parentNode\" does not exist in tree \"$name\"" - } - - upvar ::struct::tree::tree${name}::parent parent - upvar ::struct::tree::tree${name}::children children - - # Make sure the index is numeric - if { ![string is integer $index] } { - # If the index is not numeric, make it numeric by lsearch'ing for - # the value at index, then incrementing index (because "end" means - # just past the end for inserts) - set val [lindex $children($parentNode) $index] - set index [expr {[lsearch -exact $children($parentNode) $val] + 1}] - } - - foreach node $args { - if { [_exists $name $node] } { - # Move the node to its new home - if { [string equal $node "root"] } { - error "cannot move root node" - } - - # Cannot make a node its own descendant (I'm my own grandpaw...) - set ancestor $parentNode - while { ![string equal $ancestor "root"] } { - if { [string equal $ancestor $node] } { - error "node \"$node\" cannot be its own descendant" - } - set ancestor $parent($ancestor) - } - # Remove this node from its parent's children list - set oldParent $parent($node) - set ind [lsearch -exact $children($oldParent) $node] - set children($oldParent) [lreplace $children($oldParent) $ind $ind] - - # If the node is moving within its parent, and its old location - # was before the new location, decrement the new location, so that - # it gets put in the right spot - if { [string equal $oldParent $parentNode] && $ind < $index } { - incr index -1 - } - } else { - # Set up the new node - upvar ::struct::tree::tree${name}::node${node} data - set children($node) [list ] - set data(data) "" - } - - # Add this node to its parent's children list - set children($parentNode) [linsert $children($parentNode) $index $node] - - # Update the parent pointer for this node - set parent($node) $parentNode - incr index - } - - return $args -} - -# ::struct::tree::_isleaf -- -# -# Return whether the given node of a tree is a leaf or not. -# -# Arguments: -# name Name of the tree object. -# node Node to look up. -# -# Results: -# isleaf True if the node is a leaf; false otherwise. - -proc ::struct::tree::_isleaf {name node} { - if { ![_exists $name $node] } { - error "node \"$node\" does not exist in tree \"$name\"" - } - - upvar ::struct::tree::tree${name}::children children - return [expr {[llength $children($node)] == 0}] -} - -# ::struct::tree::_move -- -# -# Move a node (and all its subnodes) from where ever it is to a new -# location in the tree. -# -# Arguments: -# name Name of the tree -# parentNode Parent to add the node to. -# index Index at which to insert. -# node Node to move; the node must exist in the tree. -# args Additional nodes to move; these nodes must exist -# in the tree. -# -# Results: -# None. - -proc ::struct::tree::_move {name parentNode index node args} { - set args [linsert $args 0 $node] - - # Can only move a node to a real location in the tree - if { ![_exists $name $parentNode] } { - error "parent node \"$parentNode\" does not exist in tree \"$name\"" - } - - upvar ::struct::tree::tree${name}::parent parent - upvar ::struct::tree::tree${name}::children children - - # Make sure the index is numeric - if { ![string is integer $index] } { - # If the index is not numeric, make it numeric by lsearch'ing for - # the value at index, then incrementing index (because "end" means - # just past the end for inserts) - set val [lindex $children($parentNode) $index] - set index [expr {[lsearch -exact $children($parentNode) $val] + 1}] - } - - # Validate all nodes to move before trying to move any. - foreach node $args { - if { [string equal $node "root"] } { - error "cannot move root node" - } - - # Can only move real nodes - if { ![_exists $name $node] } { - error "node \"$node\" does not exist in tree \"$name\"" - } - - # Cannot move a node to be a descendant of itself - set ancestor $parentNode - while { ![string equal $ancestor "root"] } { - if { [string equal $ancestor $node] } { - error "node \"$node\" cannot be its own descendant" - } - set ancestor $parent($ancestor) - } - } - - # Remove all nodes from their current parent's children list - foreach node $args { - set oldParent $parent($node) - set ind [lsearch -exact $children($oldParent) $node] - - set children($oldParent) [lreplace $children($oldParent) $ind $ind] - - # Update the nodes parent value - set parent($node) $parentNode - } - - # Add all nodes to their new parent's children list - set children($parentNode) [eval linsert [list $children($parentNode)] $index $args] - - return -} - -# ::struct::tree::_next -- -# -# Return the right sibling for a given node of a tree. -# -# Arguments: -# name Name of the tree object. -# node Node to retrieve right sibling for. -# -# Results: -# sibling The right sibling for the node, or null if node was -# the rightmost child of its parent. - -proc ::struct::tree::_next {name node} { - # The 'root' has no siblings. - if { [string equal $node "root"] } { - return {} - } - - if { ![_exists $name $node] } { - error "node \"$node\" does not exist in tree \"$name\"" - } - - # Locate the parent and our place in its list of children. - upvar ::struct::tree::tree${name}::parent parent - upvar ::struct::tree::tree${name}::children children - - set parentNode $parent($node) - set index [lsearch -exact $children($parentNode) $node] - - # Go to the node to the right and return its name. - return [lindex $children($parentNode) [incr index]] -} - -# ::struct::tree::_numchildren -- -# -# Return the number of immediate children for a given node of a tree. -# -# Arguments: -# name Name of the tree object. -# node Node to look up. -# -# Results: -# numchildren Number of immediate children for the node. - -proc ::struct::tree::_numchildren {name node} { - if { ![_exists $name $node] } { - error "node \"$node\" does not exist in tree \"$name\"" - } - - upvar ::struct::tree::tree${name}::children children - return [llength $children($node)] -} - -# ::struct::tree::_parent -- -# -# Return the name of the parent node of a node in a tree. -# -# Arguments: -# name Name of the tree. -# node Node to look up. -# -# Results: -# parent Parent of node $node - -proc ::struct::tree::_parent {name node} { - if { ![_exists $name $node] } { - error "node \"$node\" does not exist in tree \"$name\"" - } - # FRINK: nocheck - return [set ::struct::tree::tree${name}::parent($node)] -} - -# ::struct::tree::_previous -- -# -# Return the left sibling for a given node of a tree. -# -# Arguments: -# name Name of the tree object. -# node Node to look up. -# -# Results: -# sibling The left sibling for the node, or null if node was -# the leftmost child of its parent. - -proc ::struct::tree::_previous {name node} { - # The 'root' has no siblings. - if { [string equal $node "root"] } { - return {} - } - - if { ![_exists $name $node] } { - error "node \"$node\" does not exist in tree \"$name\"" - } - - # Locate the parent and our place in its list of children. - upvar ::struct::tree::tree${name}::parent parent - upvar ::struct::tree::tree${name}::children children - - set parentNode $parent($node) - set index [lsearch -exact $children($parentNode) $node] - - # Go to the node to the right and return its name. - return [lindex $children($parentNode) [incr index -1]] -} - -# ::struct::tree::_set -- -# -# Set or get a value for a node in a tree. -# -# Arguments: -# name Name of the tree. -# node Node to modify or query. -# args Optional arguments specifying a key and a value. Format is -# ?-key key? ?value? -# If no key is specified, the key "data" is used. -# -# Results: -# val Value associated with the given key of the given node - -proc ::struct::tree::_set {name node args} { - if { ![_exists $name $node] } { - error "node \"$node\" does not exist in tree \"$name\"" - } - upvar ::struct::tree::tree${name}::node$node data - - if { [llength $args] > 3 } { - error "wrong # args: should be \"$name set $node ?-key key?\ - ?value?\"" - } - - set key "data" - set haveValue 0 - if { [llength $args] > 1 } { - foreach {flag key} $args break - if { ![string match "${flag}*" "-key"] } { - error "invalid option \"$flag\": should be key" - } - if { [llength $args] == 3 } { - set haveValue 1 - set value [lindex $args end] - } - } elseif { [llength $args] == 1 } { - set haveValue 1 - set value [lindex $args end] - } - - if { $haveValue } { - # Setting a value - return [set data($key) $value] - } else { - # Getting a value - if { ![info exists data($key)] } { - error "invalid key \"$key\" for node \"$node\"" - } - return $data($key) - } -} - -# ::struct::tree::_append -- -# -# Append a value for a node in a tree. -# -# Arguments: -# name Name of the tree. -# node Node to modify or query. -# args Optional arguments specifying a key and a value. Format is -# ?-key key? ?value? -# If no key is specified, the key "data" is used. -# -# Results: -# val Value associated with the given key of the given node - -proc ::struct::tree::_append {name node args} { - if { ![_exists $name $node] } { - error "node \"$node\" does not exist in tree \"$name\"" - } - upvar ::struct::tree::tree${name}::node$node data - - if { [llength $args] != 1 && [llength $args] != 3 } { - error "wrong # args: should be \"$name set $node ?-key key?\ - value\"" - } - - if { [llength $args] == 3 } { - foreach {flag key} $args break - if { ![string equal $flag "-key"] } { - error "invalid option \"$flag\": should be -key" - } - } else { - set key "data" - } - - set value [lindex $args end] - - return [append data($key) $value] -} - -# ::struct::tree::_lappend -- -# -# lappend a value for a node in a tree. -# -# Arguments: -# name Name of the tree. -# node Node to modify or query. -# args Optional arguments specifying a key and a value. Format is -# ?-key key? ?value? -# If no key is specified, the key "data" is used. -# -# Results: -# val Value associated with the given key of the given node - -proc ::struct::tree::_lappend {name node args} { - if { ![_exists $name $node] } { - error "node \"$node\" does not exist in tree \"$name\"" - } - upvar ::struct::tree::tree${name}::node$node data - - if { [llength $args] != 1 && [llength $args] != 3 } { - error "wrong # args: should be \"$name lappend $node ?-key key?\ - value\"" - } - - if { [llength $args] == 3 } { - foreach {flag key} $args break - if { ![string equal $flag "-key"] } { - error "invalid option \"$flag\": should be -key" - } - } else { - set key "data" - } - - set value [lindex $args end] - - return [lappend data($key) $value] -} - -# ::struct::tree::_size -- -# -# Return the number of descendants of a given node. The default node -# is the special root node. -# -# Arguments: -# name Name of the tree. -# node Optional node to start counting from (default is root). -# -# Results: -# size Number of descendants of the node. - -proc ::struct::tree::_size {name {node root}} { - if { ![_exists $name $node] } { - error "node \"$node\" does not exist in tree \"$name\"" - } - - # If the node is the root, we can do the cheap thing and just count the - # number of nodes (excluding the root node) that we have in the tree with - # array names - if { [string equal $node "root"] } { - set size [llength [array names ::struct::tree::tree${name}::parent]] - return [expr {$size - 1}] - } - - # Otherwise we have to do it the hard way and do a full tree search - upvar ::struct::tree::tree${name}::children children - set size 0 - set st [list ] - foreach child $children($node) { - lappend st $child - } - while { [llength $st] > 0 } { - set node [lindex $st end] - set st [lreplace $st end end] - incr size - foreach child $children($node) { - lappend st $child - } - } - return $size -} - -# ::struct::tree::_splice -- -# -# Add a node to a tree, making a range of children from the given -# parent children of the new node. -# -# Arguments: -# name Name of the tree. -# parentNode Parent to add the node to. -# from Index at which to insert. -# to Optional end of the range of children to replace. -# Defaults to 'end'. -# node Optional node name; if given, must be unique. If not -# given, a unique name will be generated. -# -# Results: -# node Name of the node added to the tree. - -proc ::struct::tree::_splice {name parentNode from {to end} args} { - if { [llength $args] == 0 } { - # No node name given; generate a unique node name - set node [__generateUniqueNodeName $name] - } else { - set node [lindex $args 0] - } - - if { [_exists $name $node] } { - error "node \"$node\" already exists in tree \"$name\"" - } - - upvar ::struct::tree::tree${name}::children children - upvar ::struct::tree::tree${name}::parent parent - - # Save the list of children that are moving - set moveChildren [lrange $children($parentNode) $from $to] - - # Remove those children from the parent - set children($parentNode) [lreplace $children($parentNode) $from $to] - - # Add the new node - _insert $name $parentNode $from $node - - # Move the children - set children($node) $moveChildren - foreach child $moveChildren { - set parent($child) $node - } - - return $node -} - -# ::struct::tree::_swap -- -# -# Swap two nodes in a tree. -# -# Arguments: -# name Name of the tree. -# node1 First node to swap. -# node2 Second node to swap. -# -# Results: -# None. - -proc ::struct::tree::_swap {name node1 node2} { - # Can't swap the magic root node - if { [string equal $node1 "root"] || [string equal $node2 "root"] } { - error "cannot swap root node" - } - - # Can only swap two real nodes - if { ![_exists $name $node1] } { - error "node \"$node1\" does not exist in tree \"$name\"" - } - if { ![_exists $name $node2] } { - error "node \"$node2\" does not exist in tree \"$name\"" - } - - # Can't swap a node with itself - if { [string equal $node1 $node2] } { - error "cannot swap node \"$node1\" with itself" - } - - # Swapping nodes means swapping their labels and values - upvar ::struct::tree::tree${name}::children children - upvar ::struct::tree::tree${name}::parent parent - upvar ::struct::tree::tree${name}::node${node1} node1Vals - upvar ::struct::tree::tree${name}::node${node2} node2Vals - - set parent1 $parent($node1) - set parent2 $parent($node2) - - # Replace node1 with node2 in node1's parent's children list, and - # node2 with node1 in node2's parent's children list - set i1 [lsearch -exact $children($parent1) $node1] - set i2 [lsearch -exact $children($parent2) $node2] - - set children($parent1) [lreplace $children($parent1) $i1 $i1 $node2] - set children($parent2) [lreplace $children($parent2) $i2 $i2 $node1] - - # Make node1 the parent of node2's children, and vis versa - foreach child $children($node2) { - set parent($child) $node1 - } - foreach child $children($node1) { - set parent($child) $node2 - } - - # Swap the children lists - set children1 $children($node1) - set children($node1) $children($node2) - set children($node2) $children1 - - if { [string equal $node1 $parent2] } { - set parent($node1) $node2 - set parent($node2) $parent1 - } elseif { [string equal $node2 $parent1] } { - set parent($node1) $parent2 - set parent($node2) $node1 - } else { - set parent($node1) $parent2 - set parent($node2) $parent1 - } - - # Swap the values - set value1 [array get node1Vals] - unset node1Vals - array set node1Vals [array get node2Vals] - unset node2Vals - array set node2Vals $value1 - - return -} - -# ::struct::tree::_unset -- -# -# Remove a keyed value from a node. -# -# Arguments: -# name Name of the tree. -# node Node to modify. -# args Optional additional args specifying which key to unset; -# if given, must be of the form "-key key". If not given, -# the key "data" is unset. -# -# Results: -# None. - -proc ::struct::tree::_unset {name node {flag -key} {key data}} { - if { ![_exists $name $node] } { - error "node \"$node\" does not exist in tree \"$name\"" - } - - if { ![string match "${flag}*" "-key"] } { - error "invalid option \"$flag\": should be \"$name unset\ - $node ?-key key?\"" - } - - upvar ::struct::tree::tree${name}::node${node} data - if { [info exists data($key)] } { - unset data($key) - } - return -} - -# ::struct::tree::_walk -- -# -# Walk a tree using a pre-order depth or breadth first -# search. Pre-order DFS is the default. At each node that is visited, -# a command will be called with the name of the tree and the node. -# -# Arguments: -# name Name of the tree. -# node Node at which to start. -# args Optional additional arguments specifying the type and order of -# the tree walk, and the command to execute at each node. -# Format is -# ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd -# -# Results: -# None. - -proc ::struct::tree::_walk {name node args} { - set usage "$name walk $node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd" - - if {[llength $args] > 6 || [llength $args] < 2} { - error "wrong # args: should be \"$usage\"" - } - - if { ![_exists $name $node] } { - error "node \"$node\" does not exist in tree \"$name\"" - } - - # Set defaults - set type dfs - set order pre - set cmd "" - - for {set i 0} {$i < [llength $args]} {incr i} { - set flag [lindex $args $i] - incr i - if { $i >= [llength $args] } { - error "value for \"$flag\" missing: should be \"$usage\"" - } - switch -glob -- $flag { - "-type" { - set type [string tolower [lindex $args $i]] - } - "-order" { - set order [string tolower [lindex $args $i]] - } - "-command" { - set cmd [lindex $args $i] - } - default { - error "unknown option \"$flag\": should be \"$usage\"" - } - } - } - - # Make sure we have a command to run, otherwise what's the point? - if { [string equal $cmd ""] } { - error "no command specified: should be \"$usage\"" - } - - # Validate that the given type is good - switch -glob -- $type { - "dfs" { - set type "dfs" - } - "bfs" { - set type "bfs" - } - default { - error "invalid search type \"$type\": should be dfs, or bfs" - } - } - - # Validate that the given order is good - switch -glob -- $order { - "pre" { - set order pre - } - "post" { - set order post - } - "in" { - set order in - } - "both" { - set order both - } - default { - error "invalid search order \"$order\":\ - should be pre, post, both, or in" - } - } - - if {[string equal $order "in"] && [string equal $type "bfs"]} { - error "unable to do a ${order}-order breadth first walk" - } - - # Do the walk - upvar ::struct::tree::tree${name}::children children - set st [list ] - lappend st $node - - # Compute some flags for the possible places of command evaluation - set leave [expr {[string equal $order post] \ - || [string equal $order both]}] - set enter [expr {[string equal $order pre] \ - || [string equal $order both]}] - set touch [string equal $order in] - - if {$leave} { - set lvlabel leave - } elseif {$touch} { - # in-order does not provide a sense - # of nesting for the parent, hence - # no enter/leave, just 'visit'. - set lvlabel visit - } - - if { [string equal $type "dfs"] } { - # Depth-first walk, several orders of visiting nodes - # (pre, post, both, in) - - array set visited {} - - while { [llength $st] > 0 } { - set node [lindex $st end] - - if {[info exists visited($node)]} { - # Second time we are looking at this 'node'. - # Pop it, then evaluate the command (post, both, in). - - set st [lreplace $st end end] - - if {$leave || $touch} { - # Evaluate the command at this node - WalkCall $name $node $lvlabel $cmd - } - } else { - # First visit of this 'node'. - # Do *not* pop it from the stack so that we are able - # to visit again after its children - - # Remember it. - set visited($node) . - - if {$enter} { - # Evaluate the command at this node (pre, both) - WalkCall $name $node "enter" $cmd - } - - # Add the children of this node to the stack. - # The exact behaviour depends on the chosen - # order. For pre, post, both-order we just - # have to add them in reverse-order so that - # they will be popped left-to-right. For in-order - # we have rearrange the stack so that the parent - # is revisited immediately after the first child. - # (but only if there is ore than one child,) - - set clist $children($node) - set len [llength $clist] - - if {$touch && ($len > 1)} { - # Pop node from stack, insert into list of children - set st [lreplace $st end end] - set clist [linsert $clist 1 $node] - incr len - } - - for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { - lappend st [lindex $clist $i] - } - } - } - } else { - # Breadth first walk (pre, post, both) - # No in-order possible. Already captured. - - if {$leave} { - set backward $st - } - - while { [llength $st] > 0 } { - set node [lindex $st 0] - set st [lreplace $st 0 0] - - if {$enter} { - # Evaluate the command at this node - WalkCall $name $node "enter" $cmd - } - - # Add this node's children - # And create a mirrored version in case of post/both order. - - foreach child $children($node) { - lappend st $child - if {$leave} { - set backward [linsert $backward 0 $child] - } - } - } - - if {$leave} { - foreach node $backward { - # Evaluate the command at this node - WalkCall $name $node "leave" $cmd - } - } - } - return -} - -# ::struct::tree::WalkCall -- -# -# Helper command to 'walk' handling the evaluation -# of the user-specified command. Information about -# the tree, node and current action are substituted -# into the command before it evaluation. -# -# Arguments: -# tree Tree we are walking -# node Node we are at. -# action The current action. -# cmd The command to call, already partially substituted. -# -# Results: -# None. - -proc ::struct::tree::WalkCall {tree node action cmd} { - uplevel 3 [string map [list \ - %n [list $node] \ - %a [list $action] \ - %t [list $tree] \ - %% %] \ - $cmd] - return -} DELETED modules/struct/tree.test Index: modules/struct/tree.test ================================================================== --- modules/struct/tree.test +++ /dev/null @@ -1,1286 +0,0 @@ -# tree.test: tests for the tree structure. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 1998-2000 by Ajuba Solutions. -# All rights reserved. -# -# RCS: @(#) $Id: tree.test,v 1.17 2002/08/08 16:49:59 andreas_kupries Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -source [file join [file dirname [info script]] tree.tcl] -namespace import struct::tree::tree - -test tree-0.1 {tree errors} { - tree mytree - catch {tree mytree} msg - mytree destroy - set msg -} "command \"mytree\" already exists, unable to create tree" -test tree-0.2 {tree errors} { - tree mytree - catch {mytree} msg - mytree destroy - set msg -} "wrong # args: should be \"mytree option ?arg arg ...?\"" -test tree-0.3 {tree errors} { - tree mytree - catch {mytree foo} msg - mytree destroy - set msg -} "bad option \"foo\": must be append, children, cut, destroy, delete, depth, exists, get, getall, index, insert, isleaf, keys, keyexists, lappend, move, next, numchildren, parent, previous, set, size, splice, swap, unset, or walk" -test tree-0.4 {tree errors} { - catch {tree set} msg - set msg -} "command \"set\" already exists, unable to create tree" - -test tree-1.1 {children} { - tree mytree - set result [list ] - lappend result [mytree children root] - mytree insert root end node0 - mytree insert root end node1 - mytree insert root end node2 - mytree insert node0 end node3 - mytree insert node0 end node4 - lappend result [mytree children root] - lappend result [mytree children node0] - mytree destroy - set result -} [list {} {node0 node1 node2} {node3 node4}] -test tree-1.2 {children, bad node} { - tree mytree - set result [catch {mytree children foobar} msg] - mytree destroy - list $result $msg -} [list 1 "node \"foobar\" does not exist in tree \"mytree\""] - -test tree-2.1 {create} { - tree mytree - set result [string equal [info commands ::mytree] "::mytree"] - mytree destroy - set result -} 1 -test tree-2.2 {create} { - set name [tree] - set result [list $name [string equal [info commands ::$name] "::$name"]] - $name destroy - set result -} [list tree1 1] - -test tree-3.1 {destroy} { - tree mytree - mytree destroy - string equal [info commands ::mytree] "" -} 1 - -test tree-4.1 {delete} { - tree mytree - catch {mytree delete root} msg - mytree destroy - set msg -} "cannot delete root node" -test tree-4.2 {delete} { - tree mytree - catch {mytree delete node0} msg - mytree destroy - set msg -} "node \"node0\" does not exist in tree \"mytree\"" -test tree-4.3 {delete} { - tree mytree - mytree insert root end node0 - mytree delete node0 - set result [list [mytree exists node0] [mytree children root]] - mytree destroy - set result -} {0 {}} -test tree-4.4 {delete} { - tree mytree - mytree insert root end node0 - mytree insert node0 end node1 - mytree insert node1 end node2 - mytree delete node0 - set result [list [mytree exists node0] \ - [mytree exists node1] \ - [mytree exists node2]] - mytree destroy - set result -} {0 0 0} - -test tree-5.1 {exists} { - tree mytree - set result [list ] - lappend result [mytree exists root] - mytree insert root end node0 - lappend result [mytree exists node0] - mytree delete node0 - lappend result [mytree exists node0] - mytree destroy - set result -} {1 1 0} - -test tree-6.1 {insert creates and initializes node} { - tree mytree - mytree insert root end node0 - set result [list ] - lappend result [mytree exists node0] - lappend result [mytree parent node0] - lappend result [mytree children node0] - lappend result [mytree set node0] - lappend result [mytree children root] - mytree destroy - set result -} {1 root {} {} node0} -test tree-6.2 {insert insert nodes in correct location} { - tree mytree - mytree insert root end node0 - mytree insert root end node1 - mytree insert root 0 node2 - set result [mytree children root] - mytree destroy - set result -} {node2 node0 node1} -test tree-6.3 {insert gives error when trying to insert to a fake parent} { - tree mytree - catch {mytree insert node0 end node1} msg - mytree destroy - set msg -} "parent node \"node0\" does not exist in tree \"mytree\"" -test tree-6.4 {insert generates node name when none is given} { - tree mytree - set result [list [mytree insert root end]] - lappend result [mytree insert root end] - mytree insert root end node3 - lappend result [mytree insert root end] - mytree destroy - set result -} [list node1 node2 node4] -test tree-6.5 {insert inserts multiple nodes properly} { - tree mytree - mytree insert root end a b c d e f - set result [mytree children root] - mytree destroy - set result -} [list a b c d e f] -test tree-6.6 {insert moves nodes that exist} { - tree mytree - mytree insert root end node0 node1 node2 node3 - mytree insert node0 end node4 node5 node6 - mytree insert root end node4 - set result [list [mytree children root] [mytree children node0]] - mytree destroy - set result -} [list [list node0 node1 node2 node3 node4] [list node5 node6]] -test tree-6.7 {insert moves nodes that already exist properly} { - tree mytree - mytree insert root end node0 - mytree insert node0 end node1 - mytree insert node1 end node2 - mytree insert root end node1 node2 - set result [list \ - [mytree children root] \ - [mytree children node0] \ - [mytree children node1] \ - [mytree parent node1] \ - [mytree parent node2] \ - ] - mytree destroy - set result -} [list [list node0 node1 node2] {} {} root root] -test tree-6.8 {insert moves multiple nodes properly} { - tree mytree - mytree insert root end node0 node1 node2 - mytree insert root 0 node1 node2 - set result [list \ - [mytree children root] \ - ] - mytree destroy - set result -} [list [list node1 node2 node0]] -test tree-6.9 {insert moves multiple nodes properly} { - tree mytree - mytree insert root end node0 node1 node2 - mytree insert root 1 node0 node1 - set result [mytree children root] - mytree destroy - set result -} [list node0 node1 node2] -test tree-6.10 {insert moves node within parent properly} { - tree mytree - mytree insert root end node0 node1 node2 node3 - mytree insert root 2 node1 - set result [mytree children root] - mytree destroy - set result -} [list node0 node1 node2 node3] -test tree-6.11 {insert moves node within parent properly} { - tree mytree - mytree insert root end node0 node1 node2 node3 - mytree insert node3 end node4 node5 node6 - mytree insert root 2 node0 node4 node5 node6 - set result [mytree children root] - mytree destroy - set result -} [list node1 node0 node4 node5 node6 node2 node3] -test tree-6.12 {insert moves node in parent properly when oldInd < newInd} { - tree mytree - mytree insert root end node0 node1 node2 node3 - mytree insert root 2 node0 - set result [mytree children root] - mytree destroy - set result -} [list node1 node0 node2 node3] -test tree-6.13 {insert gives error when trying to move root} { - tree mytree - catch {mytree insert root end root} msg - mytree destroy - set msg -} "cannot move root node" -test tree-6.14 {insert gives error when trying to make node its descendant} { - tree mytree - mytree insert root end node0 - catch {mytree insert node0 end node0} msg - mytree destroy - set msg -} "node \"node0\" cannot be its own descendant" -test tree-6.15 {insert gives error when trying to make node its descendant} { - tree mytree - mytree insert root end node0 - mytree insert node0 end node1 - mytree insert node1 end node2 - catch {mytree insert node2 end node0} msg - mytree destroy - set msg -} "node \"node0\" cannot be its own descendant" -test tree-6.16 {insert gives error for invalid node names} { - tree mytree - catch {mytree insert root end ":\n\t "} msg - mytree destroy - set msg -} "invalid node name \":\n\t \"" - -test tree-7.1 {move gives error when trying to move root} { - tree mytree - mytree insert root end node0 - catch {mytree move node0 end root} msg - mytree destroy - set msg -} "cannot move root node" -test tree-7.2 {move gives error when trying to move non existant node} { - tree mytree - catch {mytree move root end node0} msg - mytree destroy - set msg -} "node \"node0\" does not exist in tree \"mytree\"" -test tree-7.3 {move gives error when trying to move to non existant parent} { - tree mytree - catch {mytree move node0 end node0} msg - mytree destroy - set msg -} "parent node \"node0\" does not exist in tree \"mytree\"" -test tree-7.4 {move gives error when trying to make node its own descendant} { - tree mytree - mytree insert root end node0 - catch {mytree move node0 end node0} msg - mytree destroy - set msg -} "node \"node0\" cannot be its own descendant" -test tree-7.5 {move gives error when trying to make node its own descendant} { - tree mytree - mytree insert root end node0 - mytree insert node0 end node1 - mytree insert node1 end node2 - catch {mytree move node2 end node0} msg - mytree destroy - set msg -} "node \"node0\" cannot be its own descendant" -test tree-7.6 {move correctly moves a node} { - tree mytree - mytree insert root end node0 - mytree insert node0 end node1 - mytree insert node1 end node2 - mytree move node0 end node2 - set result [list [mytree children node0] [mytree children node1]] - lappend result [mytree parent node2] - mytree destroy - set result -} {{node1 node2} {} node0} -test tree-7.7 {move moves multiple nodes properly} { - tree mytree - mytree insert root end node0 node1 node2 - mytree move root 0 node1 node2 - set result [list \ - [mytree children root] \ - ] - mytree destroy - set result -} [list [list node1 node2 node0]] -test tree-7.8 {move moves multiple nodes properly} { - tree mytree - mytree insert root end node0 node1 node2 - mytree move root 1 node0 node1 - set result [mytree children root] - mytree destroy - set result -} [list node2 node0 node1] -test tree-7.9 {move moves node within parent properly} { - tree mytree - mytree insert root end node0 node1 node2 node3 - mytree move root 2 node1 - set result [mytree children root] - mytree destroy - set result -} [list node0 node2 node1 node3] -test tree-7.10 {move moves node within parent properly} { - tree mytree - mytree insert root end node0 node1 node2 node3 - mytree insert node3 end node4 node5 node6 - mytree move root 2 node0 node4 node5 node6 - set result [mytree children root] - mytree destroy - set result -} [list node1 node2 node0 node4 node5 node6 node3] -test tree-7.11 {move moves node in parent properly when oldInd < newInd} { - tree mytree - mytree insert root end node0 node1 node2 node3 - mytree move root 2 node0 - set result [mytree children root] - mytree destroy - set result -} [list node1 node2 node0 node3] -test tree-7.12 {move node up one} { - tree mytree - mytree insert root end node0 node1 node2 node3 - mytree move root [mytree index [mytree next node0]] node0 - set result [mytree children root] - mytree destroy - set result -} [list node1 node0 node2 node3] -test tree-7.13 {move node down one} { - tree mytree - mytree insert root end node0 node1 node2 node3 - mytree move root [mytree index [mytree previous node2]] node2 - set result [mytree children root] - mytree destroy - set result -} [list node0 node2 node1 node3] - -test tree-8.1 {parent gives error on fake node} { - tree mytree - catch {mytree parent node0} msg - mytree destroy - set msg -} "node \"node0\" does not exist in tree \"mytree\"" -test tree-8.2 {parent gives correct value} { - tree mytree - mytree insert root end node0 - set result [list [mytree parent node0] [mytree parent root]] - mytree destroy - set result -} {root {}} - -test tree-9.1 {size gives error on bogus node} { - tree mytree - catch {mytree size node0} msg - mytree destroy - set msg -} "node \"node0\" does not exist in tree \"mytree\"" -test tree-9.2 {size uses root node as default} { - tree mytree - set result [mytree size] - mytree destroy - set result -} 0 -test tree-9.3 {size gives correct value} { - tree mytree - mytree insert root end node0 - mytree insert root end node1 - mytree insert root end node2 - mytree insert root end node3 - mytree insert root end node4 - mytree insert root end node5 - set result [mytree size] - mytree destroy - set result -} 6 -test tree-9.4 {size gives correct value} { - tree mytree - mytree insert root end node0 - mytree insert node0 end node1 - mytree insert node0 end node2 - mytree insert node0 end node3 - mytree insert node1 end node4 - mytree insert node1 end node5 - set result [mytree size node0] - mytree destroy - set result -} 5 -test tree-9.5 {size gives correct value} { - tree mytree - mytree insert root end node0 - mytree insert node0 end node1 - mytree insert node0 end node2 - mytree insert node0 end node3 - mytree insert node1 end node4 - mytree insert node1 end node5 - set result [mytree size node1] - mytree destroy - set result -} 2 - -test tree-10.1 {set gives error on bogus node} { - tree mytree - catch {mytree set node0} msg - mytree destroy - set msg -} "node \"node0\" does not exist in tree \"mytree\"" -test tree-10.2 {set with node name gets/sets "data" value} { - tree mytree - mytree insert root end node0 - mytree set node0 foobar - set result [mytree set node0] - mytree destroy - set result -} "foobar" -test tree-10.3 {set with node name and key gets/sets key value} { - tree mytree - mytree insert root end node0 - mytree set node0 -key baz foobar - set result [list [mytree set node0] [mytree set node0 -key baz]] - mytree destroy - set result -} [list "" "foobar"] -test tree-10.4 {set with too many args gives error} { - tree mytree - mytree insert root end node0 - catch {mytree set node0 foo bar baz boo} msg - mytree destroy - set msg -} "wrong # args: should be \"mytree set node0 ?-key key? ?value?\"" -test tree-10.5 {set with bad args} { - tree mytree - mytree insert root end node0 - catch {mytree set node0 foo bar} msg - mytree destroy - set msg -} "invalid option \"foo\": should be key" -test tree-10.6 {set with bad args} { - tree mytree - mytree insert root end node0 - catch {mytree set node0 foo bar baz} msg - mytree destroy - set msg -} "invalid option \"foo\": should be key" -test tree-10.7 {set with bad key gives error} { - tree mytree - mytree insert root end node0 - catch {mytree set node0 -key foo} msg - mytree destroy - set msg -} "invalid key \"foo\" for node \"node0\"" - -test tree-11.1 {depth} { - tree mytree - catch {mytree depth node0} msg - mytree destroy - set msg -} "node \"node0\" does not exist in tree \"mytree\"" -test tree-11.2 {depth of root is 0} { - tree mytree - set result [mytree depth root] - mytree destroy - set result -} 0 -test tree-11.2 {depth is computed correctly} { - tree mytree - mytree insert root end node0 - mytree insert node0 end node1 - mytree insert node1 end node2 - mytree insert node2 end node3 - set result [mytree depth node3] - mytree destroy - set result -} 4 - -test tree-12.1 {pre dfs walk} { - tree mytree - set t [list ] - mytree insert root end node0 - mytree insert root end node1 - mytree insert node0 end node0.1 - mytree insert node0 end node0.2 - mytree insert node1 end node1.1 - mytree insert node1 end node1.2 - mytree walk root -type dfs -command {lappend t %a %t %n} - mytree destroy - set t -} [list enter mytree root enter mytree node0 enter mytree node0.1 \ - enter mytree node0.2 enter mytree node1 \ - enter mytree node1.1 enter mytree node1.2] - -test tree-12.1.0 {post dfs walk} { - tree mytree - set t [list ] - mytree insert root end node0 - mytree insert root end node1 - mytree insert node0 end node0.1 - mytree insert node0 end node0.2 - mytree insert node1 end node1.1 - mytree insert node1 end node1.2 - mytree walk root -order post -type dfs -command {lappend t %a %t %n} - mytree destroy - set t -} [list leave mytree node0.1 leave mytree node0.2 leave mytree node0 \ - leave mytree node1.1 leave mytree node1.2 \ - leave mytree node1 leave mytree root] - -test tree-12.1.1 {both dfs walk} { - tree mytree - set t [list ] - mytree insert root end node0 - mytree insert root end node1 - mytree insert node0 end node0.1 - mytree insert node0 end node0.2 - mytree insert node1 end node1.1 - mytree insert node1 end node1.2 - mytree walk root -order both -type dfs -command {lappend t %a %t %n} - mytree destroy - set t -} [list enter mytree root enter mytree node0 enter mytree node0.1 \ - leave mytree node0.1 enter mytree node0.2 leave mytree node0.2 \ - leave mytree node0 enter mytree node1 enter mytree node1.1 \ - leave mytree node1.1 enter mytree node1.2 leave mytree node1.2 \ - leave mytree node1 leave mytree root] - -test tree-12.1.3 {in dfs walk} { - tree mytree - set t [list ] - mytree insert root end node0 - mytree insert root end node1 - mytree insert node0 end node0.1 - mytree insert node0 end node0.2 - mytree insert node1 end node1.1 - mytree insert node1 end node1.2 - mytree walk root -order in -type dfs -command {lappend t %a %t %n} - mytree destroy - set t -} [list visit mytree node0.1 visit mytree node0 visit mytree node0.2 \ - visit mytree root visit mytree node1.1 visit mytree node1 \ - visit mytree node1.2] - -test tree-12.1.4 {pre dfs walk, different % specifiers} { - tree mytree - set t [list ] - mytree insert root end node0 - mytree insert root end node1 - mytree insert node0 end node0.1 - mytree insert node0 end node0.2 - mytree insert node1 end node1.1 - mytree insert node1 end node1.2 - mytree walk root -type dfs -command {lappend t %n %%} - mytree destroy - set t -} [list root % node0 % node0.1 % \ - node0.2 % node1 % \ - node1.1 % node1.2 %] - -test tree-12.1.5 {pre dfs walk, different % specifiers} { - tree mytree - set t [list ] - mytree insert root end node0 - mytree insert root end node1 - mytree insert node0 end node0.1 - mytree insert node0 end node0.2 - mytree insert node1 end node1.1 - mytree insert node1 end node1.2 - mytree walk root -type dfs -command {lappend t %% %t} - mytree destroy - set t -} [list % mytree % mytree % mytree \ - % mytree % mytree \ - % mytree % mytree] - -test tree-12.1.6 {pre dfs walk, nodes with spaces in names} { - tree mytree - set t [list ] - mytree insert root end "node/0" - mytree insert root end "node/1" - mytree insert "node/0" end "node/0/1" - mytree insert "node/0" end "node/0/2" - mytree insert "node/1" end "node/1/1" - mytree insert "node/1" end "node/1/2" - mytree walk root -type dfs -command {lappend t %n} - mytree destroy - set t -} [list root "node/0" "node/0/1" "node/0/2" "node/1" "node/1/1" "node/1/2"] - -test tree-12.2 {pre bfs walk} { - tree mytree - set t [list ] - mytree insert root end node0 - mytree insert root end node1 - mytree insert node0 end node0.1 - mytree insert node0 end node0.2 - mytree insert node1 end node1.1 - mytree insert node1 end node1.2 - mytree walk root -type bfs -command {lappend t %a %t %n} - mytree destroy - set t -} [list enter mytree root enter mytree node0 enter mytree node1 \ - enter mytree node0.1 enter mytree node0.2 enter mytree node1.1 \ - enter mytree node1.2] - -test tree-12.2.0 {post bfs walk} { - tree mytree - set t [list ] - mytree insert root end node0 - mytree insert root end node1 - mytree insert node0 end node0.1 - mytree insert node0 end node0.2 - mytree insert node1 end node1.1 - mytree insert node1 end node1.2 - mytree walk root -type bfs -order post -command {lappend t %a %t %n} - mytree destroy - set t -} [list leave mytree node1.2 leave mytree node1.1 leave mytree node0.2 \ - leave mytree node0.1 leave mytree node1 leave mytree node0 \ - leave mytree root] - -test tree-12.2.1 {both bfs walk} { - tree mytree - set t [list ] - mytree insert root end node0 - mytree insert root end node1 - mytree insert node0 end node0.1 - mytree insert node0 end node0.2 - mytree insert node1 end node1.1 - mytree insert node1 end node1.2 - mytree walk root -type bfs -order both -command {lappend t %a %t %n} - mytree destroy - set t -} [list enter mytree root enter mytree node0 enter mytree node1 \ - enter mytree node0.1 enter mytree node0.2 enter mytree node1.1 \ - enter mytree node1.2 leave mytree node1.2 leave mytree node1.1 \ - leave mytree node0.2 leave mytree node0.1 leave mytree node1 \ - leave mytree node0 leave mytree root] - -test tree-12.3 {pre dfs is default walk} { - tree mytree - set t [list ] - mytree insert root end node0 - mytree insert root end node1 - mytree insert node0 end node0.1 - mytree insert node0 end node0.2 - mytree insert node1 end node1.1 - mytree insert node1 end node1.2 - mytree walk root -command {lappend t %a %t %n} - mytree destroy - set t -} [list enter mytree root enter mytree node0 enter mytree node0.1 \ - enter mytree node0.2 enter mytree node1 \ - enter mytree node1.1 enter mytree node1.2] -test tree-12.4 {walk with too few args} {badTest} { - tree mytree - catch {mytree walk} msg - mytree destroy - set msg -} "no value given for parameter \"node\" to \"::struct::tree::_walk\"" -test tree-12.5 {walk with too few args} { - tree mytree - catch {mytree walk root} msg - mytree destroy - set msg -} "wrong # args: should be \"mytree walk root ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd\"" -test tree-12.6 {walk with too many args} { - tree mytree - catch {mytree walk root -foo bar -baz boo -foo2 boo -foo3 baz} msg - mytree destroy - set msg -} "wrong # args: should be \"mytree walk root ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd\"" -test tree-12.7 {walk with fake node} { - tree mytree - catch {mytree walk node0 -command {}} msg - mytree destroy - set msg -} "node \"node0\" does not exist in tree \"mytree\"" -test tree-12.8 {walk gives error on invalid search type} { - tree mytree - catch {mytree walk root -type foo -command foo} msg - mytree destroy - set msg -} {invalid search type "foo": should be dfs, or bfs} -test tree-12.9 {walk gives error on invalid search order} { - tree mytree - catch {mytree walk root -order foo -command foo} msg - mytree destroy - set msg -} {invalid search order "foo": should be pre, post, both, or in} -test tree-12.10 {walk gives error on invalid combination of order and type} { - tree mytree - catch {mytree walk root -order in -type bfs -command foo} msg - mytree destroy - set msg -} {unable to do a in-order breadth first walk} -test tree-12.11 {walk with unknown options} { - tree mytree - catch {mytree walk root -foo bar} msg - mytree destroy - set msg -} "unknown option \"-foo\": should be \"mytree walk root ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd\"" -test tree-12.12 {walk, option without value} { - tree mytree - catch {mytree walk root -type dfs -order} msg - mytree destroy - set msg -} "value for \"-order\" missing: should be \"mytree walk root ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd\"" -test tree-12.13 {walk without command} { - tree mytree - catch {mytree walk root -order pre} msg - mytree destroy - set msg -} "no command specified: should be \"mytree walk root ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd\"" - - -test tree-13.1 {swap gives error when trying to swap root} { - tree mytree - catch {mytree swap root node0} msg - mytree destroy - set msg -} "cannot swap root node" -test tree-13.2 {swap gives error when trying to swap non existant node} { - tree mytree - catch {mytree swap node0 node1} msg - mytree destroy - set msg -} "node \"node0\" does not exist in tree \"mytree\"" -test tree-13.3 {swap gives error when trying to swap non existant node} { - tree mytree - mytree insert root end node0 - catch {mytree swap node0 node1} msg - mytree destroy - set msg -} "node \"node1\" does not exist in tree \"mytree\"" -test tree-13.3 {swap gives error when trying to swap node with self} { - tree mytree - mytree insert root end node0 - catch {mytree swap node0 node0} msg - mytree destroy - set msg -} "cannot swap node \"node0\" with itself" -test tree-13.4 {swap swaps node relationships correctly} { - tree mytree - mytree insert root end node0 - mytree insert node0 end node0.1 - mytree insert node0 end node0.2 - mytree insert node0.1 end node0.1.1 - mytree insert node0.1 end node0.1.2 - mytree swap node0 node0.1 - set t [list ] - mytree walk root -command {lappend t %a %t %n} - mytree destroy - set t -} [list enter mytree root enter mytree node0.1 enter mytree node0 \ - enter mytree node0.1.1 enter mytree node0.1.2 enter mytree node0.2] -test tree-13.5 {swap swaps node relationships correctly} { - tree mytree - mytree insert root end node0 - mytree insert node0 end node0.1 - mytree insert node0 end node0.2 - mytree insert node0.1 end node0.1.1 - mytree insert node0.1 end node0.1.2 - mytree swap node0 node0.1.1 - set t [list ] - mytree walk root -command {lappend t %a %t %n} - mytree destroy - set t -} [list enter mytree root enter mytree node0.1.1 enter mytree node0.1 \ - enter mytree node0 enter mytree node0.1.2 enter mytree node0.2] -test tree-13.6 {swap swaps node relationships correctly} { - tree mytree - mytree insert root end node0 - mytree insert root end node1 - mytree insert node0 end node0.1 - mytree insert node1 end node1.1 - mytree swap node0 node1 - set t [list ] - mytree walk root -command {lappend t %a %t %n} - mytree destroy - set t -} [list enter mytree root enter mytree node1 enter mytree node0.1 \ - enter mytree node0 enter mytree node1.1] -test tree-13.7 {swap swaps node relationships correctly} { - tree mytree - mytree insert root end node0 - mytree insert node0 end node0.1 - mytree insert node0 end node0.2 - mytree insert node0.1 end node0.1.1 - mytree insert node0.1 end node0.1.2 - mytree swap node0.1 node0 - set t [list ] - mytree walk root -command {lappend t %a %t %n} - mytree destroy - set t -} [list enter mytree root enter mytree node0.1 enter mytree node0 \ - enter mytree node0.1.1 enter mytree node0.1.2 enter mytree node0.2] - -test tree-14.1 {get gives error on bogus node} { - tree mytree - catch {mytree get node0} msg - mytree destroy - set msg -} "node \"node0\" does not exist in tree \"mytree\"" -test tree-14.2 {get gives error on bogus key} { - tree mytree - mytree insert root end node0 - catch {mytree get node0 -key bogus} msg - mytree destroy - set msg -} "invalid key \"bogus\" for node \"node0\"" -test tree-14.2 {get uses data as default key} { - tree mytree - mytree insert root end node0 - mytree set node0 foobar - set result [mytree get node0] - mytree destroy - set result -} "foobar" -test tree-14.3 {get respects -key flag} { - tree mytree - mytree insert root end node0 - mytree set node0 -key boom foobar - set result [mytree get node0 -key boom] - mytree destroy - set result -} "foobar" - -test tree-15.1 {unset gives error on bogus node} { - tree mytree - catch {mytree unset node0} msg - mytree destroy - set msg -} "node \"node0\" does not exist in tree \"mytree\"" -test tree-15.2 {unset does not give error on bogus key} { - tree mytree - mytree insert root end node0 - set result [catch {mytree unset node0 -key bogus}] - mytree destroy - set result -} 0 -test tree-15.3 {unset removes a keyed value from a node} { - tree mytree - mytree insert root end node0 - mytree set node0 -key foobar foobar - mytree unset node0 -key foobar - catch {mytree get node0 -key foobar} msg - mytree destroy - set msg -} "invalid key \"foobar\" for node \"node0\"" -test tree-15.4 {unset requires -key} { - tree mytree - mytree insert root end node0 - mytree set node0 -key foobar foobar - catch {mytree unset node0 flaboozle foobar} msg - mytree destroy - set msg -} "invalid option \"flaboozle\": should be \"mytree unset node0 ?-key key?\"" - -test tree-16.1 {isleaf} { - tree mytree - set t [mytree isleaf root] - mytree insert root end node0 - lappend t [mytree isleaf root] [mytree isleaf node0] - mytree destroy - set t -} [list 1 0 1] -test tree-16.2 {isleaf} { - tree mytree - catch {mytree isleaf node0} msg - mytree destroy - set msg -} "node \"node0\" does not exist in tree \"mytree\"" - -test tree-17.1 {index of root fails} { - tree mytree - catch {mytree index root} msg - mytree destroy - set msg -} "cannot determine index of root node" -test tree-17.2 {index} { - tree mytree - mytree insert root end node1 - mytree insert root end node0 - set result [list [mytree index node0] [mytree index node1]] - mytree destroy - set result -} [list 1 0] -test tree-17.3 {index of non-existant node} { - tree mytree - catch {mytree index node0} msg - mytree destroy - set msg -} "node \"node0\" does not exist in tree \"mytree\"" - -test tree-18.1 {numchildren} { - tree mytree - set t [mytree numchildren root] - mytree insert root end node0 - lappend t [mytree numchildren root] [mytree numchildren node0] - mytree destroy - set t -} [list 0 1 0] -test tree-18.2 {numchildren} { - tree mytree - catch {mytree numchildren node0} msg - mytree destroy - set msg -} "node \"node0\" does not exist in tree \"mytree\"" - -test tree-19.1 {next from root} { - tree mytree - set res [mytree next root] - mytree destroy - set res -} {} -test tree-19.2 {next from fake node} { - tree mytree - catch {mytree next node0} msg - mytree destroy - set msg -} "node \"node0\" does not exist in tree \"mytree\"" -test tree-19.3 {next} { - tree mytree - mytree insert root end node0 - mytree insert root end node1 - set res [list [mytree next node0] [mytree next node1]] - mytree destroy - set res -} [list node1 {}] - -test tree-20.1 {previous from root} { - tree mytree - set res [mytree previous root] - mytree destroy - set res -} {} -test tree-20.2 {previous from fake node} { - tree mytree - catch {mytree previous node0} msg - mytree destroy - set msg -} "node \"node0\" does not exist in tree \"mytree\"" -test tree-20.3 {next} { - tree mytree - mytree insert root end node0 - mytree insert root end node1 - set res [list [mytree previous node0] [mytree previous node1]] - mytree destroy - set res -} [list {} node0] - -test tree-21.1 {cutting nodes} { - tree mytree - mytree insert root end node0 - mytree insert root end node1 - mytree insert root end node2 - mytree insert node1 end node1.0 - mytree insert node1 end node1.1 - mytree insert node1 end node1.2 - mytree cut node1 - set t [list ] - mytree walk root -command {lappend t %a %t %n} - mytree destroy - set t -} {enter mytree root enter mytree node0 enter mytree node1.0 enter mytree node1.1 enter mytree node1.2 enter mytree node2} -test tree-21.2 {cutting nodes} { - tree mytree - catch {mytree cut root} msg - mytree destroy - set msg -} {cannot cut root node} -test tree-21.3 {cut sets parent values of relocated nodes} { - tree mytree - mytree insert root end node0 - mytree insert root end node1 - mytree insert root end node2 - mytree insert node1 end node1.0 - mytree insert node1 end node1.1 - mytree insert node1 end node1.2 - mytree cut node1 - set res [list \ - [mytree parent node1.0] \ - [mytree parent node1.1] \ - [mytree parent node1.2]] - mytree destroy - set res -} [list root root root] -test tree-21.4 {cut removes node} { - tree mytree - mytree insert root end node0 - mytree insert root end node1 - mytree insert root end node2 - mytree insert node1 end node1.0 - mytree insert node1 end node1.1 - mytree insert node1 end node1.2 - mytree cut node1 - set res [mytree exists node1] - mytree destroy - set res -} 0 -test tree-21.5 {cut removes node} { - tree mytree - catch {mytree cut node0} msg - mytree destroy - set msg -} "node \"node0\" does not exist in tree \"mytree\"" - -test tree-22.1 {splicing nodes} { - tree mytree - mytree insert root end node0 - mytree insert root end node1.0 - mytree insert root end node1.1 - mytree insert root end node1.2 - mytree insert root end node2 - mytree splice root 1 3 node1 - set t [list ] - mytree walk root -command {lappend t %a %t %n} - mytree destroy - set t -} {enter mytree root enter mytree node0 enter mytree node1 enter mytree node1.0 enter mytree node1.1 enter mytree node1.2 enter mytree node2} -test tree-22.2 {splicing nodes with no node name given} { - tree mytree - mytree insert root end node0 - mytree insert root end node1.0 - mytree insert root end node1.1 - mytree insert root end node1.2 - mytree insert root end node2 - set res [mytree splice root 1 3] - set t [list ] - mytree walk root -command {lappend t %a %t %n} - mytree destroy - list $res $t -} [list node1 {enter mytree root enter mytree node0 enter mytree node1 enter mytree node1.0 enter mytree node1.1 enter mytree node1.2 enter mytree node2}] -test tree-22.3 {splicing nodes errors on duplicate node name} { - tree mytree - mytree insert root end node0 - mytree insert root end node1.0 - mytree insert root end node1.1 - mytree insert root end node1.2 - mytree insert root end node2 - catch {mytree splice root 1 3 node0} msg - mytree destroy - set msg -} "node \"node0\" already exists in tree \"mytree\"" -test tree-22.4 {splicing node sets parent values correctly} { - tree mytree - mytree insert root end node0 - mytree insert root end node1.0 - mytree insert root end node1.1 - mytree insert root end node1.2 - mytree insert root end node2 - mytree splice root 1 3 node1 - set res [list \ - [mytree parent node1] \ - [mytree parent node1.0] \ - [mytree parent node1.1] \ - [mytree parent node1.2]] - mytree destroy - set res -} [list root node1 node1 node1] -test tree-22.5 {splicing node works with strange index} { - tree mytree - mytree insert root end node0 - mytree insert root end node1.0 - mytree insert root end node1.1 - mytree insert root end node1.2 - mytree insert root end node2 - mytree splice root -5 12 node1 - set t [list ] - mytree walk root -command {lappend t %a %t %n} - mytree destroy - set t -} {enter mytree root enter mytree node1 enter mytree node0 enter mytree node1.0 enter mytree node1.1 enter mytree node1.2 enter mytree node2} -test tree-22.6 {splicing nodes with no node name and no "to" index given} { - tree mytree - mytree insert root end node0 - mytree insert root end node1.0 - mytree insert root end node1.1 - mytree insert root end node1.2 - mytree insert root end node2 - mytree splice root 1 - set t [list ] - mytree walk root -command {lappend t %a %t %n} - mytree destroy - set t -} {enter mytree root enter mytree node0 enter mytree node1 enter mytree node1.0 enter mytree node1.1 enter mytree node1.2 enter mytree node2} - -test tree-23.1 {getall gives error on bogus node} { - tree mytree - catch {mytree getall node0} msg - mytree destroy - set msg -} "node \"node0\" does not exist in tree \"mytree\"" -test tree-23.2 {getall gives error when key specified} { - tree mytree - catch {mytree getall node0 -key data} msg - mytree destroy - set msg -} "node \"node0\" does not exist in tree \"mytree\"" -test tree-23.3 {getall with node name returns list of key/value pairs} { - tree mytree - mytree insert root end node0 - mytree set node0 foobar - mytree set node0 -key other thing - set results [mytree getall node0] - mytree destroy - lsort $results -} "data foobar other thing" - -test tree-24.1 {keys gives error on bogus node} { - tree mytree - catch {mytree keys node0} msg - mytree destroy - set msg -} "node \"node0\" does not exist in tree \"mytree\"" -test tree-24.2 {keys gives error when key specified} { - tree mytree - catch {mytree keys node0 -key data} msg - mytree destroy - set msg -} "node \"node0\" does not exist in tree \"mytree\"" -test tree-24.3 {keys with node name returns list of keys} { - tree mytree - mytree insert root end node0 - mytree set node0 foobar - mytree set node0 -key other thing - set results [mytree keys node0] - mytree destroy - lsort $results -} "data other" - -test tree-25.1 {keyexists gives error on bogus node} { - tree mytree - catch {mytree keyexists node0} msg - mytree destroy - set msg -} "node \"node0\" does not exist in tree \"mytree\"" -test tree-25.2 {keyexists returns false on non-existant key} { - tree mytree - mytree insert root end node0 - catch {mytree keyexists node0 -key bogus} msg - mytree destroy - set msg -} "0" -test tree-25.3 {keyexists uses data as default key} { - tree mytree - mytree insert root end node0 - mytree set node0 foobar - set result [mytree keyexists node0] - mytree destroy - set result -} "1" -test tree-25.4 {keyexists respects -key flag} { - tree mytree - mytree insert root end node0 - mytree set node0 -key boom foobar - set result [mytree keyexists node0 -key boom] - mytree destroy - set result -} "1" - -test tree-26.1 {append gives error on bogus node} { - tree mytree - catch {mytree append node0} msg - mytree destroy - set msg -} "node \"node0\" does not exist in tree \"mytree\"" -test tree-26.2 {append with node name appends to "data" value} { - tree mytree - mytree insert root end node0 - mytree set node0 foo - set result [mytree append node0 bar] - mytree destroy - set result -} "foobar" -test tree-26.3 {append with node name and key appends key value} { - tree mytree - mytree insert root end node0 - mytree set node0 -key baz foo - set result [mytree append node0 -key baz bar] - mytree destroy - set result -} "foobar" -test tree-26.4 {append with too many args gives error} { - tree mytree - mytree insert root end node0 - catch {mytree append node0 foo bar baz boo} msg - mytree destroy - set msg -} "wrong # args: should be \"mytree set node0 ?-key key? value\"" -test tree-26.5 {append with bad args} { - tree mytree - mytree insert root end node0 - catch {mytree append node0 -foo bar baz} msg - mytree destroy - set msg -} "invalid option \"-foo\": should be -key" -test tree-26.6 {append respects -key flag} { - tree mytree - mytree insert root end node0 - mytree set node0 -key baz foo - set result [mytree append node0 -key baz bar] - mytree destroy - set result -} "foobar" - -test tree-27.1 {lappend gives error on bogus node} { - tree mytree - catch {mytree lappend node0} msg - mytree destroy - set msg -} "node \"node0\" does not exist in tree \"mytree\"" -test tree-27.2 {lappend with node name appends to "data" value} { - tree mytree - mytree insert root end node0 - mytree set node0 foo - set result [mytree lappend node0 bar] - mytree destroy - set result -} "foo bar" -test tree-27.3 {lappend with node name and key appends key value} { - tree mytree - mytree insert root end node0 - mytree set node0 -key baz foo - set result [mytree lappend node0 -key baz bar] - mytree destroy - set result -} "foo bar" -test tree-27.4 {lappend with too many args gives error} { - tree mytree - mytree insert root end node0 - catch {mytree lappend node0 foo bar baz boo} msg - mytree destroy - set msg -} "wrong # args: should be \"mytree lappend node0 ?-key key? value\"" -test tree-27.5 {lappend with bad args} { - tree mytree - mytree insert root end node0 - catch {mytree lappend node0 -foo bar baz} msg - mytree destroy - set msg -} "invalid option \"-foo\": should be -key" -test tree-27.6 {lappend respects -key flag} { - tree mytree - mytree insert root end node0 - mytree set node0 -key baz foo - set result [mytree lappend node0 -key baz bar] - mytree destroy - set result -} "foo bar" - -::tcltest::cleanupTests DELETED modules/textutil/ChangeLog Index: modules/textutil/ChangeLog ================================================================== --- modules/textutil/ChangeLog +++ /dev/null @@ -1,239 +0,0 @@ -2003-04-10 Andreas Kupries - - * pkgIndex.tcl: - * expander.man: - * expander.tcl: Set version of the package to to 1.2 - - * pkgIndex.tcl: - * textutil.man: - * textutil.tcl: Fixed bug #614591. Set version - of the package to to 0.5 - -2003-03-31 Andreas Kupries - - * tabify.tcl (tabify, untabify): Changed from regsub to string map - This closes FR #693194 by David Welton - . - -2003-03-29 Andreas Kupries - - * expander.man: - * expander.tcl: Added method 'ctopandclear' to retrieve data - captured in the current context without having to pop the - context (and loose state information). User: Plain text - formatter in 'doctools'. - -2003-03-28 Andreas Kupries - - * adjust.test: - * textutil.test: Added testsuite for new commands. Fixed typo bug - in yesterday's 'blank' and 'indent'. - - * adjust.tcl: New command 'undent'. - * textutil.tcl: New command 'longestCommonPrefix'. - - * textutil.man: documented the new commands. - -2003-03-27 Andreas Kupries - - * textutil.man: - * adjust.tcl: - * trim.tcl: - * textutil.tcl: New commands: blank, chop, tail, cap, uncap, - indent, trimPrefix, and trimEmptyHeading. Imported from my own - Pool library. Also fixed some typos in the manpage: Superfluous - closing brackets. ... This closes Tcllib FR #514476. - -2003-02-27 Andreas Kupries - - * textutil.man: Added two new commands, - * textutil.tcl: ::textutil::adjust::listPredefined and - ::textutil::adjust::getPredefined to the - package. They allow the user of the package to - find the names and full paths of the hyphenation - files coming with the package itself, making their - use easier. - -2003-01-27 Andreas Kupries - - * expander.man: Fixed typo in documentation. - -2003-01-18 Andreas Kupries - - * adjust_hyph.test: Rewrote the file into a proper testsuite. - -2003-01-16 Andreas Kupries - - * expander.man: More semantic markup, less visual one. - * textutil.man: - -2003-01-07 Andreas Kupries - - * textutil.tcl: Changed patchlevel in provide to match the - ifneeded in pkgIndex.tcl. - -2002-08-11 vogeler - - * adjust.tcl: added hyphenation (TeX). Hyphenation has been - tested for german, english, italian and spanish - -2002-04-24 Andreas Kupries - - * expander.man: Fixed typo. - -2002-03-26 Andreas Kupries - - * expander.man: New file, doctools manpage. - -2002-03-14 Andreas Kupries - - * expander.tcl (Op_expand): Fix for SF Bug #530056. Added code - checking start and end levels for pushed/popped contexts and - alert the caller if the numbers do not match, indicating that - the macros pushed more or less contexts than popped. - -2002-02-26 Joe English - - * expander.tcl: Frink run. - - * Versions are now 1.0.1 and 0.5 to distinguish this from the code - in tcllib release 1.2 - -2002-01-18 Andreas Kupries - - * Bumped version to 0.4, Expander to 1.0. - -2002-01-17 Joe English - - * textutil.n, expander.n: Fixed nroff markup errors. - -2001-12-12 Andreas Kupries - - * expander.n: - * expander.ehtml: - * expander.html: - * expander.tcl: Added 'textcmd' method which is called for all - plain text encountered by the processor. Note: The textcmd is - run through the evalcmd, i.e. it is treated as a special macro - surrounding all plain text. It defaults to empty, meaning - 'identity'. Also moved the code handling errors in a macro into - a separate function to make usage in multiple places - easier. This is patch #492156. - -2001-12-11 Andreas Kupries - - * textutil.n: - * split.test: - * split.tcl: Fixed item #476988, the handling of the empty input - string, reported by Glenn Jackman - . Also added code to detect and - handle an empty regular expression. In that case "splitx" - degenerates to a simple "split". - -2001-12-10 Andreas Kupries - - * expander.test: - * expander.tcl: - * expander.n: - * expander.ehtml: - * expander.html: - * expander_notes.txt: Applied update on behalf of William - implementing the 'evalcmd' feature, i.e. instead of using - 'uplevel #0' directly expander objects now have a configurable - callback for the execution of macros. The default is still - 'uplevel #0' but this can be changed. - -2001-12-07 Andreas Kupries - - * expander.test: Fixed a problem with the expander testsuite. It - checked for the wrong namespace and thus did not load the - functionality to be tested. - -2001-11-28 Reinhard Max - - * split.tcl: Speed improvement by using [regexp -start] instead of - repeatedly copying the tail of the string. - -2001-11-12 Andreas Kupries - - * textutil.n: - * adjust.tcl: - * adjust.tcl: Added code, tests and documentation for option - -strictlength as provided by Dan Kuchler . - - * expander.tcl: - * expander.test: - * expander.ehtml: - * expander.html: - * expander.n: - * expander_license.txt: - * expander_notes.txt: Documentation, code and testsuite for - expander objects; the heart of the expand macro processor by - William H. Duquette packaged up as a - library. - -2001-10-16 Andreas Kupries - - * pkgIndex.tcl: - * textutil.n: - * textutil.tcl: Version up to 0.3 - -2001-09-18 Andreas Kupries - - * tabify.tcl (tabifyLine): Documentation of the algorithm - expanded. Text provided by Helmut Giese. - -2001-09-17 Andreas Kupries - - * tabify.tcl: Added (un)tabify code provided by Helmut Giese - which is more editor-like than the - existing code. The existing code was not deleted so both - behaviours can be used in the future. This fixes [439016]. - -2001-07-10 Andreas Kupries - - * tabify.tcl: Frink 2.2 run, fixed dubious code. - -2001-06-21 Andreas Kupries - - * split.tcl: - * adjust.tcl: - * trim.tcl: Fixed dubious code reported by frink. - -2001-03-23 Andreas Kupries - - * textutil.tcl: Reworked the implementation of 'StrRepeat', made - it much faster (used code from Pool_Base). Renamed to - 'strRepeat' and exported. - - **Note** that the tcl implementation is one order of magnitude - faster than [string repeat] for num >= 1000. - - * textutil.n: Added description of 'strRepeat'. - * repeat.test: New file, tests 'strRepeat'. - -2000-11-02 Eric Melski - - * textutil.test: - * adjust.test: - * split.test: - * tabify.test: - * trim.test: - * adjust.tcl: - * split.tcl: - * tabify.tcl: - * trim.tcl: - * textutil.tcl: Added functions from Joel Saunier (adjust, splitx, - tabify, trim, trimleft, trimright, untabify). - -2000-07-01 Eric Melski - - * pkgIndex.tcl: Standard package index. - - * textutil.tcl: Added [package provide]; no actual functions yet, - just the package stub. DELETED modules/textutil/adjust.tcl Index: modules/textutil/adjust.tcl ================================================================== --- modules/textutil/adjust.tcl +++ /dev/null @@ -1,744 +0,0 @@ -####################################################### -# -# Diese Programmteile stammen aus der tcllib 1.3; sie -# werden hier veraendert, um die Silbentrennung in die -# Routine adjust einzubauen -# -####################################################### - -namespace eval ::textutil { - - namespace eval adjust { - - variable here [file dirname [info script]] - variable StrRepeat [ namespace parent ]::strRepeat - variable Justify left - variable Length 72 - variable FullLine 0 - variable StrictLength 0 - variable Hyphenate 0 - variable HyphPatterns - - namespace export adjust indent undent - - # This will be redefined later. We need it just to let - # a chance for the next import subcommand to work - # - proc adjust { text args } { } - proc indent { text args } { } - proc undent { text args } { } - } - - namespace import -force adjust::adjust adjust::indent adjust::undent - namespace export adjust indent undent - -} - -######################################################################### - -proc ::textutil::adjust::adjust { text args } { - - if { [ string length [ string trim $text ] ] == 0 } then { - return "" - } - - Configure $args - Adjust text newtext - - return $newtext -} - -proc ::textutil::adjust::Configure { args } { - variable Justify left - variable Length 72 - variable FullLine 0 - variable StrictLength 0 - variable Hyphenate 0 - variable HyphPatterns; # hyphenation patterns (TeX) - - set args [ lindex $args 0 ] - foreach { option value } $args { - switch -exact -- $option { - -full { - if { ![ string is boolean -strict $value ] } then { - error "expected boolean but got \"$value\"" - } - set FullLine [ string is true $value ] - } - -hyphenate { - if { ![ string is boolean -strict $value ] } then { - error "expected boolean but got \"$value\"" - } - set Hyphenate [string is true $value] - if { $Hyphenate && ![info exists HyphPatterns(_LOADED_)]} { - error "hyphenation patterns not loaded!" - } - } - -justify { - set lovalue [ string tolower $value ] - switch -exact -- $lovalue { - left - - right - - center - - plain { - set Justify $lovalue - } - default { - error "bad value \"$value\": should be center, left, plain or right" - } - } - } - -length { - if { ![ string is integer $value ] } then { - error "expected positive integer but got \"$value\"" - } - if { $value < 1 } then { - error "expected positive integer but got \"$value\"" - } - set Length $value - } - -strictlength { - if { ![ string is boolean -strict $value ] } then { - error "expected boolean but got \"$value\"" - } - set StrictLength [ string is true $value ] - } - default { - error "bad option \"$option\": must be -full, -hyphenate, \ - -justify, -length, or -strictlength" - } - } - } - - return "" -} - -# -# Dies ist die relevante Routine -# - -proc ::textutil::adjust::Adjust { varOrigName varNewName } { - variable Length - variable StrictLength - variable Hyphenate - - upvar $varOrigName orig - upvar $varNewName text - - regsub -all -- "(\n)|(\t)" $orig " " text - regsub -all -- " +" $text " " text - regsub -all -- "(^ *)|( *\$)" $text "" text - - set ltext [ split $text ] - - if { $StrictLength } then { - - # Limit the length of a line to $Length. If any single - # word is long than $Length, then split the word into multiple - # words. - - set i 0 - foreach tmpWord $ltext { - if { [ string length $tmpWord ] > $Length } then { - - # Since the word is longer than the line length, - # remove the word from the list of words. Then - # we will insert several words that are less than - # or equal to the line length in place of this word. - - set ltext [ lreplace $ltext $i $i ] - incr i -1 - set j 0 - - # Insert a series of shorter words in place of the - # one word that was too long. - - while { $j < [ string length $tmpWord ] } { - - # Calculate the end of the string range for this word. - - if { [ expr { [string length $tmpWord ] - $j } ] > $Length } then { - set end [ expr { $j + $Length - 1} ] - } else { - set end [ string length $tmpWord ] - } - - set ltext [ linsert $ltext [ expr {$i + 1} ] [ string range $tmpWord $j $end ] ] - incr i - incr j [ expr { $end - $j + 1 } ] - } - } - incr i - } - } - - # End if { $StrictLength } ... - - set line [ lindex $ltext 0 ] - set pos [ string length $line ] - set text "" - set numline 0 - set numword 1 - set words(0) 1 - set words(1) [ list $pos $line ] - - foreach word [ lrange $ltext 1 end ] { - set size [ string length $word ] - if { ( $pos + $size ) < $Length } then { - # the word fits into the actual line ... - # - append line " $word" - incr numword - incr words(0) - set words($numword) [ list $size $word ] - incr pos - incr pos $size - } elseif { $Hyphenate } { - # the word does not fit into the line and we must try to hyphenate - - set word2 [Hyphenation $word]; - set word2 [string trim $word2]; - set word3 ""; - set word4 "" - - set i 0; - set iMax [llength $word2]; - - # build up the part of the word to be kept in the current line - - while { $i < $iMax } { - set syl [lindex $word2 $i] - if { $pos + [string length " $word3$syl-"] > $Length } { break } - append word3 $syl; - incr i; - } - - # build up the part of the hyphenated word to be transferred to - # the next line - - while { $i < $iMax } { - set syl [lindex $word2 $i]; - append word4 $syl; - incr i; - } - - # to be done in the future: code that guarantees that the - # parts of the hyphenated word have a minimum length .. - - if {[string length $word3] && [string length $word4]} { - # hyphenation was succesful: keep $word3 and the hyphen in the - # current line and begin next line with $word4 - # - # current line - - append line " $word3-" - incr numword - incr words(0) - set words($numword) [list [string length $word3] $word3]; - incr pos; - incr pos [string length $word3]; - - if [string length $text] { append text "\n" } - append text [ Justification $line [ incr numline ] words ] - - # next line - - set line "$word4" - set pos [string length $word4]; - catch { unset words } - set numword 1 - set words(0) 1 - set words(1) [ list $size $word ] - } else { - # hyphenation failed => close current line and begin - # the next line with the unhyphenated word ($word) - - if [string length $text] { append text "\n" } - append text [Justification $line [incr numline] words] - - set line "$word" - set pos $size - catch { unset words } - set numword 1 - set words(0) 1 - } - } else { - # no hyphenation - if [string length $text] { append text "\n" } - append text [Justification $line [ incr numline ] words ] - - set line "$word" - set pos $size - catch { unset words } - set numword 1 - set words(0) 1 - set words(1) [ list $size $word ] - } - } - if [string length $text] { append text "\n" } - append text [Justification $line end words] - - return $text -} - -# -# Ende der relevanten Routine -# - -proc ::textutil::adjust::Justification { line index arrayName } { - variable Justify - variable Length - variable FullLine - variable StrRepeat - - upvar $arrayName words - - set len [ string length $line ] - if { $Length == $len } then { - return $line - } - - # Special case: - # for the last line, and if the justification is set to 'plain' - # the real justification is 'left' if the length of the line - # is less than 90% (rounded) of the max length allowed. This is - # to avoid expansion of this line when it is too small: without - # it, the added spaces will 'unbeautify' the result. - # - - set justify $Justify - if { ( "$index" == "end" ) && \ - ( "$Justify" == "plain" ) && \ - ( $len < round($Length * 0.90) ) } then { - set justify left - } - - # For a left justification, nothing to do, but to - # add some spaces at the end of the line if requested - # - - if { "$justify" == "left" } then { - set jus "" - if { $FullLine } then { - set jus [ $StrRepeat " " [ expr { $Length - $len } ] ] - } - return "${line}${jus}" - } - - # For a right justification, just add enough spaces - # at the beginning of the line - # - - if { "$justify" == "right" } then { - set jus [ $StrRepeat " " [ expr { $Length - $len } ] ] - return "${jus}${line}" - } - - # For a center justification, add half of the needed spaces - # at the beginning of the line, and the rest at the end - # only if needed. - - if { "$justify" == "center" } then { - set mr [ expr { ( $Length - $len ) / 2 } ] - set ml [ expr { $Length - $len - $mr } ] - set jusl [ $StrRepeat " " $ml ] - set jusr [ $StrRepeat " " $mr ] - if { $FullLine } then { - return "${jusl}${line}${jusr}" - } else { - return "${jusl}${line}" - } - } - - # For a plain justiciation, it's a little bit complex: - # if some spaces are missing, then - # sort the list of words in the current line by - # decreasing size - # foreach word, add one space before it, except if - # it's the first word, until enough spaces are added - # then rebuild the line - # - - if { "$justify" == "plain" } then { - set miss [ expr { $Length - [ string length $line ] } ] - if { $miss == 0 } then { - return "${line}" - } - - for { set i 1 } { $i < $words(0) } { incr i } { - lappend list [ eval list $i $words($i) 1 ] - } - lappend list [ eval list $i $words($words(0)) 0 ] - set list [ SortList $list decreasing 1 ] - - set i 0 - while { $miss > 0 } { - set elem [ lindex $list $i ] - set nb [ lindex $elem 3 ] - incr nb - set elem [ lreplace $elem 3 3 $nb ] - set list [ lreplace $list $i $i $elem ] - incr miss -1 - incr i - if { $i == $words(0) } then { - set i 0 - } - } - set list [ SortList $list increasing 0 ] - set line "" - foreach elem $list { - set jus [ $StrRepeat " " [ lindex $elem 3 ] ] - set word [ lindex $elem 2 ] - if { [ lindex $elem 0 ] == $words(0) } then { - append line "${jus}${word}" - } else { - append line "${word}${jus}" - } - } - - return "${line}" - } - - error "Illegal justification key \"$justify\"" -} - -proc ::textutil::adjust::SortList { list dir index } { - - if { [ catch { lsort -integer -$dir -index $index $list } sl ] != 0 } then { - error "$sl" - } - - return $sl -} - -# Hyphenation utilities based on Knuth's algorithm -# -# Copyright (C) 2001-2002 by Dr.Johannes-Heinrich Vogeler -# These procedures may be used as part of the tcllib - -# textutil::adjust::Hyphenation -# -# Hyphenate a string using Knuth's algorithm -# -# Parameters: -# str string to be hyphenated -# -# Returns: -# the hyphenated string - -proc ::textutil::adjust::Hyphenation { str } { - - variable HyphPatterns; # hyphenation patterns (TeX) - - set w ".[string tolower $str]."; # transform to lower case - set wLen [string length $w]; # and add delimiters - - # Initialize hyphenation weights - - set s {} - for {set i 0} {$i < $wLen} {incr i} { - lappend s 0; - } - - for {set i 0} {$i < $wLen} {incr i} { - set kmax [expr $wLen-$i]; - for {set k 1} {$k < $kmax} {incr k} { - set sw [string range $w $i [expr $i+$k]]; - if [info exists HyphPatterns($sw)] { - set hw $HyphPatterns($sw); - set hwLen [string length $hw]; - for {set l1 0; set l2 0} {$l1 < $hwLen} {incr l1} { - set c [string index $hw $l1]; - if [string is digit $c] { - set sPos [expr $i+$l2]; - if {$c > [lindex $s $sPos]} { - set s [lreplace $s $sPos $sPos $c]; - } - } else { - incr l2; - } - } - } - } - } - - # Replace all even hyphenation weigths by zero - - for {set i 0} {$i < [llength $s]} {incr i} { - set c [lindex $s $i]; - if ![expr $c%2] { set s [lreplace $s $i $i 0] } - } - - # Don't start with a hyphen! Take also care of words enclosed in quotes - # or that someone has forgotten to put a blank between a punctuation - # character and the following word etc. - - for {set i 1} {$i < [expr $wLen-1]} {incr i} { - set c [string range $w $i end] - if [regexp {^[:alpha:][.]*} $c] { - for {set k 1} {$k < [expr $i+1]} {incr k} { - set s [lreplace $s $k $k 0]; - } - break - } - } - - # Don't separate the last character of a word with a hyphen - - set max [expr [llength $s]-2]; - if {$max} {set s [lreplace $s $max end 0]} - - # return the syllabels of the hyphenated word as a list! - - set ret ""; - set w ".$str."; - for {set i 1} {$i < [expr $wLen-1]} {incr i} { - if [lindex $s $i] { append ret - } - append ret [string index $w $i]; - } - return [split $ret -]; -} - -# textutil::adjust::listPredefined -# -# Return the names of the hyphenation files coming with the package. -# -# Parameters: -# None. -# -# Result: -# List of filenames (without directory) - -proc ::textutil::adjust::listPredefined {} { - variable here - return [glob -type f -directory $here -tails *.tex] -} - -# textutil::adjust::getPredefined -# -# Retrieve the full path for a predefined hyphenation file -# coming with the package. -# -# Parameters: -# name Name of the predefined file. -# -# Results: -# Full path to the file, or an error if it doesn't -# exist or is matching the pattern *.tex. - -proc ::textutil::adjust::getPredefined {name} { - variable here - - if {![string match *.tex $name]} { - return -code error \ - "Illegal hyphenation file \"$name\"" - } - set path [file join $here $name] - if {![file exists $path]} { - return -code error \ - "Unknown hyphenation file \"$path\"" - } - return $path -} - -# textutil::adjust::readPatterns -# -# Read hyphenation patterns from a file and store them in an array -# -# Parameters: -# filNam name of the file containing the patterns - -proc ::textutil::adjust::readPatterns { filNam } { - - variable HyphPatterns; # hyphenation patterns (TeX) - - # HyphPatterns(_LOADED_) is used as flag for having loaded - # hyphenation patterns from the respective file (TeX format) - - if [info exists HyphPatterns(_LOADED_)] { - unset HyphPatterns(_LOADED_); - } - - # the array xlat provides translation from TeX encoded characters - # to those of the ISO-8859-1 character set - - set xlat(\"s) \337; # 223 := sharp s - set xlat(\`a) \340; # 224 := a, grave - set xlat(\'a) \341; # 225 := a, acute - set xlat(\^a) \342; # 226 := a, circumflex - set xlat(\"a) \344; # 228 := a, diaeresis - set xlat(\`e) \350; # 232 := e, grave - set xlat(\'e) \351; # 233 := e, acute - set xlat(\^e) \352; # 234 := e, circumflex - set xlat(\`i) \354; # 236 := i, grave - set xlat(\'i) \355; # 237 := i, acute - set xlat(\^i) \356; # 238 := i, circumflex - set xlat(\~n) \361; # 241 := n, tilde - set xlat(\`o) \362; # 242 := o, grave - set xlat(\'o) \363; # 243 := o, acute - set xlat(\^o) \364; # 244 := o, circumflex - set xlat(\"o) \366; # 246 := o, diaeresis - set xlat(\`u) \371; # 249 := u, grave - set xlat(\'u) \372; # 250 := u, acute - set xlat(\^u) \373; # 251 := u, circumflex - set xlat(\"u) \374; # 252 := u, diaeresis - - set fd [open $filNam RDONLY]; - set status 0; - - while {[gets $fd line] >= 0} { - - switch -exact $status { - PATTERNS { - if [regexp {^\}[.]*} $line] { - # End of patterns encountered: set status - # and ignore that line - set status 0; - continue; - } else { - # This seems to be pattern definition line; to process it - # we have first to do some editing - # - # 1) eat comments in a pattern definition line - # 2) eat braces and coded linefeeds - - set z [string first "%" $line]; - if {$z > 0} { set line [string range $line 0 [expr $z-1]] } - - regsub -all {(\\n|\{|\})} $line {} tmp; - set line $tmp; - - # Now $line should consist only of hyphenation patterns - # separated by white space - - # Translate TeX encoded characters to ISO-8859-1 characters - # using the array xlat defined above - - foreach x [array names xlat] { - regsub -all {$x} $line $xlat($x) tmp; - set line $tmp; - } - - # split the line and create a lookup array for - # the repective hyphenation patterns - - foreach item [split $line] { - if [string length $item] { - if ![string match {\\} $item] { - # create index for hyphenation patterns - - set var $item; - regsub -all {[0-9]} $var {} idx; - # store hyphenation patterns as elements of an array - - set HyphPatterns($idx) $item; - } - } - } - } - } - EXCEPTIONS { - if [regexp {^\}[.]*} $line] { - # End of patterns encountered: set status - # and ignore that line - set status 0; - continue; - } else { - # to be done in the future - } - } - default { - if [regexp {^\\endinput[.]*} $line] { - # end of data encountered, stop processing and - # ignore all the following text .. - break; - } elseif [regexp {^\\patterns[.]*} $line] { - # begin of patterns encountered: set status - # and ignore that line - set status PATTERNS; - continue; - } elseif [regexp {^\\hyphenation[.]*} $line] { - # some particular cases to be treated separately - set status EXCEPTIONS - continue; - } else { - set status 0; - } - } - } ;# switch - } - - close $fd; - set HyphPatterns(_LOADED_) 1; - - return; -} - -####################################################### - -# @c The specified block is indented -# @c by ing each line. The first -# @c lines ares skipped. -# -# @a text: The paragraph to indent. -# @a prefix: The string to use as prefix for each line -# @a prefix: of with. -# @a skip: The number of lines at the beginning to leave untouched. -# -# @r Basically , but indented a certain amount. -# -# @i indent -# @n This procedure is not checked by the testsuite. - -proc ::textutil::adjust::indent {text prefix {skip 0}} { - set text [string trim $text] - - set res [list] - foreach line [split $text \n] { - if {[string compare "" [string trim $line]] == 0} { - lappend res {} - } elseif {$skip <= 0} { - lappend res $prefix[string trimright $line] - } else { - lappend res [string trimright $line] - } - if {$skip > 0} {incr skip -1} - } - return [join $res \n] -} - -# Undent the block of text: Compute LCP (restricted to whitespace!) -# and remove that from each line. Note that this preverses the -# shaping of the paragraph (i.e. hanging indent are _not_ flattened) -# We ignore empty lines !! - -proc ::textutil::adjust::undent {text} { - - if {$text == {}} {return {}} - - set lines [split $text \n] - set ne [list] - foreach l $lines { - if {[string length [string trim $l]] == 0} continue - lappend ne $l - } - set lcp [::textutil::longestCommonPrefixList $ne] - - if {[string length $lcp] == 0} {return $text} - - regexp {^([ ]*)} $lcp -> lcp - - if {[string length $lcp] == 0} {return $text} - - set len [string length $lcp] - - set res [list] - foreach l $lines { - if {[string length [string trim $l]] == 0} { - lappend res {} - } else { - lappend res [string range $l $len end] - } - } - return [join $res \n] -} DELETED modules/textutil/adjust.test Index: modules/textutil/adjust.test ================================================================== --- modules/textutil/adjust.test +++ /dev/null @@ -1,341 +0,0 @@ -# -*- tcl -*- -# adjust.test: tests for the adjust sub-package of the textutil package. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -if { [ lsearch [ namespace children ] "::textutil" ] == -1 } then { - source [file join [file dirname [info script]] textutil.tcl] -} - -set string " hello, world " - -set text "Hello, world! - This is the end, my friend. - -You're just another brick in the wall. - Michele, ma belle, sont des mots qui vont trés bien ensembles, -trés bien ensembles. - - Smoke on the water, and fire in the sky. - Oh Lord, don't let me be misunderstood. - -Cause tramp like us, baby we were born to run." - -set text2 "Hello, world! - This is the end, my friend. - -You're just another brick in the wall. - Michele, ma belle, sont des mots qui vont trés bien ensembles, -trés bien ensembles. - -ThisIsSimilarToTextOnlyThisStringHasOneReallyLongWordInIt - - Smoke on the water, and fire in the sky. - Oh Lord, don't let me be misunderstood. - -Cause tramp like us, baby we were born to run." - -################################################### - -test adjust-0.1 {adjust string on left} { - ::textutil::adjust $string -} \ -"hello, world" - -test adjust-0.2 {adjust string on rigth} { - ::textutil::adjust $string -justify right -} \ -" hello, world" - -test adjust-0.3 {adjust string on center} { - ::textutil::adjust $string -justify center -} \ -" hello, world" - -test adjust-0.4 {adjust string with plain justification} { - ::textutil::adjust $string -justify plain -full no -} \ -"hello, world" - -test adjust-0.5 {adjust string on left with full line} { - ::textutil::adjust $string -full yes -} \ -"hello, world " - -test adjust-0.6 {adjust string on right with full line} { - ::textutil::adjust $string -justify right -full yes -} \ -" hello, world" - -test adjust-0.7 {adjust string on center with full line} { - ::textutil::adjust $string -justify center -full 1 -} \ -" hello, world " - -test adjust-0.8 {adjust string with plain justification and full line} { - ::textutil::adjust $string -justify plain -full YES -} \ -"hello, world " - -############################## - -test adjust-1.1 {adjust multi lines on left} { - ::textutil::adjust $text -full no -} \ -"Hello, world! This is the end, my friend. You're just another brick in -the wall. Michele, ma belle, sont des mots qui vont trés bien ensembles, -trés bien ensembles. Smoke on the water, and fire in the sky. Oh Lord, -don't let me be misunderstood. Cause tramp like us, baby we were born to -run." - -test adjust-1.2 {adjust multi lines on right} { - ::textutil::adjust $text -justify right -} \ -" Hello, world! This is the end, my friend. You're just another brick in -the wall. Michele, ma belle, sont des mots qui vont trés bien ensembles, - trés bien ensembles. Smoke on the water, and fire in the sky. Oh Lord, -don't let me be misunderstood. Cause tramp like us, baby we were born to - run." - -test adjust-1.3 {adjust multi lines on center} { - ::textutil::adjust $text -justify center -full yes -} \ -" Hello, world! This is the end, my friend. You're just another brick in -the wall. Michele, ma belle, sont des mots qui vont trés bien ensembles, - trés bien ensembles. Smoke on the water, and fire in the sky. Oh Lord, -don't let me be misunderstood. Cause tramp like us, baby we were born to - run. " - -test adjust-1.4 {adjust multi lines with plain justification} { - ::textutil::adjust $text -justify plain -full yes -} \ -"Hello, world! This is the end, my friend. You're just another brick in -the wall. Michele, ma belle, sont des mots qui vont trés bien ensembles, -trés bien ensembles. Smoke on the water, and fire in the sky. Oh Lord, -don't let me be misunderstood. Cause tramp like us, baby we were born to -run. " - -test adjust-1.5 {adjust multi lines with plain justification} { - ::textutil::adjust $text -justify plain -} \ -"Hello, world! This is the end, my friend. You're just another brick in -the wall. Michele, ma belle, sont des mots qui vont trés bien ensembles, -trés bien ensembles. Smoke on the water, and fire in the sky. Oh Lord, -don't let me be misunderstood. Cause tramp like us, baby we were born to -run." - -############################## - -test adjust-2.1 {adjust multi lines on left with specified length} { - ::textutil::adjust $text -justify left -length 62 -} \ -"Hello, world! This is the end, my friend. You're just another -brick in the wall. Michele, ma belle, sont des mots qui vont -trés bien ensembles, trés bien ensembles. Smoke on the water, -and fire in the sky. Oh Lord, don't let me be misunderstood. -Cause tramp like us, baby we were born to run." - -test adjust-2.2 {adjust multi lines on right with specified length} { - ::textutil::adjust $text -justify right -length 62 -} \ -" Hello, world! This is the end, my friend. You're just another - brick in the wall. Michele, ma belle, sont des mots qui vont - trés bien ensembles, trés bien ensembles. Smoke on the water, - and fire in the sky. Oh Lord, don't let me be misunderstood. - Cause tramp like us, baby we were born to run." - -test adjust-2.3 {adjust multi lines on center with specified length} { - ::textutil::adjust $text -justify center -length 62 -full yes -} \ -" Hello, world! This is the end, my friend. You're just another - brick in the wall. Michele, ma belle, sont des mots qui vont - trés bien ensembles, trés bien ensembles. Smoke on the water, - and fire in the sky. Oh Lord, don't let me be misunderstood. - Cause tramp like us, baby we were born to run. " - -test adjust-2.4 {adjust multi lines with plain justification} { - ::textutil::adjust $text -justify plain -length 62 -full yes -} \ -"Hello, world! This is the end, my friend. You're just another -brick in the wall. Michele, ma belle, sont des mots qui vont -trés bien ensembles, trés bien ensembles. Smoke on the water, -and fire in the sky. Oh Lord, don't let me be misunderstood. -Cause tramp like us, baby we were born to run. " - -test adjust-2.5 {adjust multi lines with plain justification} { - ::textutil::adjust $text -justify plain -length 62 -} \ -"Hello, world! This is the end, my friend. You're just another -brick in the wall. Michele, ma belle, sont des mots qui vont -trés bien ensembles, trés bien ensembles. Smoke on the water, -and fire in the sky. Oh Lord, don't let me be misunderstood. -Cause tramp like us, baby we were born to run." - -test adjust-2.6 {adjust multi lines with plain justification and long word} { - ::textutil::adjust $text2 -justify plain -length 31 -strictlength 1 -} \ -"Hello, world! This is the end, -my friend. You're just another -brick in the wall. Michele, ma -belle, sont des mots qui vont -trés bien ensembles, trés bien - ensembles. -ThisIsSimilarToTextOnlyThisStri - ngHasOneReallyLongWordInIt -Smoke on the water, and fire in -the sky. Oh Lord, don't let me -be misunderstood. Cause tramp -like us, baby we were born to -run." - -test adjust-2.7 {adjust multi lines with plain justification and strictlength} { - ::textutil::adjust $text2 -justify plain -length 31 -strictlength 1 -} \ -"Hello, world! This is the end, -my friend. You're just another -brick in the wall. Michele, ma -belle, sont des mots qui vont -trés bien ensembles, trés bien - ensembles. -ThisIsSimilarToTextOnlyThisStri - ngHasOneReallyLongWordInIt -Smoke on the water, and fire in -the sky. Oh Lord, don't let me -be misunderstood. Cause tramp -like us, baby we were born to -run." - -test adjust-2.8 {adjust multi lines with left justification and strictlength} { - ::textutil::adjust $text2 -justify left -length 31 -strictlength 1 -} \ -"Hello, world! This is the end, -my friend. You're just another -brick in the wall. Michele, ma -belle, sont des mots qui vont -trés bien ensembles, trés bien -ensembles. -ThisIsSimilarToTextOnlyThisStri -ngHasOneReallyLongWordInIt -Smoke on the water, and fire in -the sky. Oh Lord, don't let me -be misunderstood. Cause tramp -like us, baby we were born to -run." - -################################################### - -unset string -unset text -unset text2 - -################################################### -# Indentation - -test indent-1.0 {indent spaces, no skip} { - ::textutil::indent {foo -bar - -bob} { } -} { foo - bar - - bob} - -test indent-1.1 {indent spaces, negative skip} { - ::textutil::indent {foo -bar - -bob} { } -4 -} { foo - bar - - bob} - -test indent-1.2 {indent spaces, skip one} { - ::textutil::indent {foo -bar - -bob} { } 1 -} {foo - bar - - bob} - -test indent-1.3 {indent spaces, skip three} { - ::textutil::indent {foo -bar - -bob} { } 3 -} {foo -bar - - bob} - -test indent-1.4 {indent spaces, skip all} { - ::textutil::indent {foo -bar - -bob} { } 5 -} {foo -bar - -bob} - -test indent-1.5 {indent spaces, skip all, on border} { - ::textutil::indent {foo -bar - -bob} { } 4 -} {foo -bar - -bob} - - - -test undent-1.0 {undent, empty line, completely empty} { - ::textutil::undent { foo - bar - - bob} -} {foo -bar - -bob} - -test undent-1.1 {undent, empty line, whitespace} { - ::textutil::undent { foo - bar - - bob} -} {foo -bar - -bob} - -test undent-1.2 {undent, ignore common non-whitespace prefix} { - ::textutil::undent { foo - foobar - foobob} -} {foo -foobar -foobob} - -test undent-1.3 {undent, ignore common non-whitespace part of prefix} { - ::textutil::undent { foo - foo bar - foo bob} -} {foo -foo bar -foo bob} - - -::tcltest::cleanupTests DELETED modules/textutil/adjust_hyph.test Index: modules/textutil/adjust_hyph.test ================================================================== --- modules/textutil/adjust_hyph.test +++ /dev/null @@ -1,104 +0,0 @@ -# -*- tcl -*- -# adjust.test: tests for the adjust sub-package of the textutil package. - -################################################################## -# Main programme to test adjust/hyphenation: shows some examples # -# of hyphenated text # -# # -# Note: the files dehypht.tex, eshyph_vo.tex and ithyph.tex must # -# reside in the same directory as adjust_hyph.tcl # -################################################################## - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -source [file join $::tcltest::testsDirectory adjust.tcl]; - -########## -# German # -########## - -test adjust-tex-1.0 {German hyphenation} { - #puts "\nTest german hyphenation ...\n"; - - set str "Kurz berichtet: Theodor Holzkopf (Name frei erfunden) promovierte \ -zum Doktor der Rechte über das Thema 'Die Böllerschüsse im Völkerrecht'" - set wid 16 - - # Setup hyphenation patterns, then perform adjustment - textutil::adjust::readPatterns [file join $::tcltest::testsDirectory "dehypht.tex"] - textutil::adjust $str -hyphenate 1 -length $wid -} {Kurz berichtet: -Theodor Holzkopf -(Name frei er- -funden) promo- -vierte zum Dok- -tor der Rechte -über das Thema -'Die Böller- -schüsse im Völ- -kerrecht'} - -########### -# italian # -########### - -test adjust-tex-1.1 {Italian hyphenation} { - #puts "\nTest italian hyphenation ...\n" - - set str "Non sappiamo con precisione quando a Roma furono \ - institutite le prime scuole regolari, cioè 'statali'. \ - Plutarcho dice che nacquero verso il 250 avanti Cristo, \ - cioè circa cinquecent'anni dopo la fondazione della città. \ - (Indro Montanelli)" - set wid 20; - textutil::adjust::readPatterns [file join $::tcltest::testsDirectory "ithyph.tex"] - textutil::adjust $str -hyphenate 1 -length $wid -} {Non sappiamo con -precisione quando a -Roma furono institu- -tite le prime scuole -regolari, cioè 'sta- -tali'. Plutarcho di- -ce che nacquero ver- -so il 250 avanti -Cristo, cioè circa -cinquecent'anni dopo -la fondazione della -città. (Indro Monta- -nelli)} - -########### -# spanish # -########### - -test adjust-tex-1.2 {Spanish hyphenation} { - #puts "\nTest spanish hyphenation ...\n"; - - set str "El panorama politico estará convulsionado porque los emeneristas, \ - además de no contar con el apoyo del NFR para gobernar en el periodo \ - 2002-2007, se proponen junto con los ucesistas a aprobar los \ - cambios a la carta magna (Periodico La Razon, Bolivia)" - set wid 20; - textutil::adjust::readPatterns [file join $::tcltest::testsDirectory "eshyph_vo.tex"] - textutil::adjust $str -hyphenate 1 -length $wid -} {El panorama politico -estará convulsionado -porque los -emeneristas, además -de no contar con el -apoyo del NFR para -gobernar en el peri- -odo 2002-2007, se -proponen junto con -los ucesistas a a- -probar los cambios a -la carta magna (Pe- -riodico La Razon, -Bolivia)} - -########## - -::tcltest::cleanupTests DELETED modules/textutil/dehypht.tex Index: modules/textutil/dehypht.tex ================================================================== --- modules/textutil/dehypht.tex +++ /dev/null @@ -1,902 +0,0 @@ -% This is `dehypht.tex' as of 03 March 1999. -% -% Copyright (C) 1988,1991 Rechenzentrum der Ruhr-Universitaet Bochum -% [german hyphen patterns] -% Copyright (C) 1993,1994,1999 Bernd Raichle/DANTE e.V. -% [macros, adaption for TeX 2] -% -% ----------------------------------------------------------------- -% IMPORTANT NOTICE: -% -% This program can be redistributed and/or modified under the terms -% of the LaTeX Project Public License Distributed from CTAN -% archives in directory macros/latex/base/lppl.txt; either -% version 1 of the License, or any later version. -% ----------------------------------------------------------------- -% -% -% This file contains german hyphen patterns following traditional -% hyphenation rules and includes umlauts and sharp s, but without -% `c-k' and triple consonants. It is based on hyphen patterns -% containing 5719 german hyphen patterns with umlauts in the -% recommended version of September 27, 1990. -% -% For use with TeX generated by -% -% Norbert Schwarz -% Rechenzentrum Ruhr-Universitaet Bochum -% Universitaetsstrasse 150 -% D-44721 Bochum, FRG -% -% -% Adaption of these patterns for TeX, Version 2.x and 3.x and -% all fonts in T1/`Cork'/EC/DC and/or OT1/CM encoding by -% -% Bernd Raichle -% Stettener Str. 73 -% D-73732 Esslingen, FRG -% Email: raichle@Informatik.Uni-Stuttgart.DE -% -% -% Error reports in case of UNCHANGED versions to -% -% DANTE e.V., Koordinator `german.sty' -% Postfach 10 18 40 -% D-69008 Heidelberg, FRG -% Email: german@Dante.DE -% -% or one of the addresses given above. -% -% -% Changes: -% 1990-09-27 First version of `ghyphen3.tex' (Norbert Schwarz) -% 1991-02-13 PC umlauts changed to ^^xx (Norbert Schwarz) -% 1993-08-27 Umlauts/\ss changed to "a/\3 macros, added macro -% definitions and additional logic to select correct -% patterns/encoding (Bernd Raichle) -% 1994-02-13 Release of `ghyph31.tex' V3.1a (Bernd Raichle) -% 1999-03-03 Renamed file to `dehypht.tex' according to the -% naming scheme using the ISO country code `de', the -% common part `hyph' for all hyphenation patterns files, -% and the additional postfix `t' for traditional, -% removed wrong catcode change of ^^e (the comment -% character %) and ^^f (the character &), -% do _not_ change \catcode, \lccode, \uccode to avoid -% problems with other hyphenation pattern files, -% changed code to distinguish TeX 2.x/3.x, -% changed license conditions to LPPL (Bernd Raichle) -% -% -% For more information see the additional documentation -% at the end of this file. -% -% ----------------------------------------------------------------- -% -\message{German Traditional Hyphenation Patterns % - `dehypht' Version 3.2a <1999/03/03>} -\message{(Formerly known under the name `ghyph31' and `ghyphen'.)} -% -% -% Next we define some commands which are used inside the patterns. -% To keep them local, we enclose the rest of the file in a group -% (The \patterns command globally changes the hyphenation trie!). -% -\begingroup -% -% -% Make sure that doublequote is not active: -\catcode`\"=12 -% -% -% Because ^^e4 is used in the following macros which is read by -% TeX 2.x as ^^e or %, the comment character of TeX, some trick -% has to be found to avoid this problem. The same is true for the -% character ^^f or & in the TeX 2.x code. -% Therefore in the code the exclamationmark ! is used instead of -% the circumflex ^ and its \catcode is set appropriately -% (normally \catcode`\!=12, in the code \catcode`\!=7). -% -% The following \catcode, \lccode assignments and macro definitions -% are defined in such a way that the following \pattern{...} list -% can be used for both, TeX 2.x and TeX 3.x. -% -% We first change the \lccode of ^^Y to make sure that we can -% include this character in the hyphenation patterns. -% -\catcode`\^^Y=11 \lccode`\^^Y=`\^^Y -% -% Then we have to define some macros depending on the TeX version. -% Therefore we have to distinguish TeX version 2.x and 3.x: -% -\ifnum`\@=`\^^40 % true => TeX 3.x - % - % For TeX 3: - % ---------- - % - % Assign appropriate \catcode and \lccode values for all - % accented characters used in the patterns (\uccode changes are - % not used within \patterns{...} and thus not necessary): - % - \catcode"E4=11 \catcode"C4=11 % \"a \"A - \catcode"F6=11 \catcode"D6=11 % \"o \"O - \catcode"FC=11 \catcode"DC=11 % \"u \"U - \catcode"FF=11 \catcode"DF=11 % \ss SS - % - \lccode"C4="E4 \uccode"C4="C4 \lccode"E4="E4 \uccode"E4="C4 - \lccode"D6="F6 \uccode"D6="D6 \lccode"F6="F6 \uccode"F6="D6 - \lccode"DC="FC \uccode"DC="DC \lccode"FC="FC \uccode"FC="DC - \lccode"DF="FF \uccode"DF="DF \lccode"FF="FF \uccode"FF="DF - % - % In the following definitions we use ??xy instead of ^^xy - % to avoid errors when reading the following macro definitions - % with TeX 2.x (remember ^^e(4) is the comment character): - % - \catcode`\?=7 - % - % Define the accent macro " in such a way that it - % expands to single letters in font encoding T1. - \catcode`\"=13 - \def"#1{\ifx#1a??e4\else \ifx#1o??f6\else \ifx#1u??fc\else - \errmessage{Hyphenation pattern file corrupted!}% - \fi\fi\fi} - % - % - patterns with umlauts are ok - \def\n#1{#1} - % - % For \ss which exists in T1 _and_ OT1 encoded fonts but with - % different glyph codes, duplicated patterns for both encodings - % are included. Thus you can use these hyphenation patterns for - % T1 and OT1 encoded fonts: - % - define \3 to be code `\^^ff (\ss in font encoding T1) - % - define \9 to be code `\^^Y (\ss in font encoding OT1) - \def\3{??ff} - \def\9{??Y} - % - duplicated patterns to support font encoding OT1 are ok - \def\c#1{#1} - % >>>>>> UNCOMMENT the next line, if you do not want - % >>>>>> to use fonts in font encoding OT1 - %\def\c#1{} - % - \catcode`\?=12 - % -\else - % - % For TeX 2: - % ---------- - % - % Define the accent macro " to throw an error message. - \catcode`\"=13 - \def"#1{\errmessage{Hyphenation pattern file corrupted!}} - % - % - ignore all patterns with umlauts - \def\n#1{} - % - % With TeX 2 fonts in encoding T1 can be used, but all glyphs - % in positions > 127 can not be used in hyphenation patterns. - % Thus only patterns with glyphs in OT1 positions are included: - % - define \3 to be code ^^Y (\ss in CM font encoding) - % - define \9 to throw an error message - \def\3{^^Y} - \def\9{\errmessage{Hyphenation pattern file corrupted!}} - % - ignore all duplicated patterns with \ss in T1 encoding - \def\c#1{} - % -\fi -% -% -\patterns{% -.aa6l .ab3a4s .ab3ei .abi2 .ab3it .ab1l .ab1r .ab3u .ad3o4r .alti6 -.ana3c .an5alg .an1e .ang8s .an1s .ap1p .ar6sc .ar6ta .ar6tei .as2z -.au2f1 .au2s3 .be5erb .be3na .ber6t5r .bie6r5 .bim6s5t .brot3 .bru6s -.ch6 .che6f5 .da8c .da2r .dar5in .dar5u .den6ka .de5r6en .des6pe -.de8spo .de3sz .dia3s4 .dien4 .dy2s1 .ehren5 .eine6 .ei6n5eh .ei8nen -.ein5sa .en6der .en6d5r .en3k4 .en8ta8 .en8tei .en4t3r .epo1 .er6ban -.er6b5ei .er6bla .er6d5um .er3ei .er5er .er3in .er3o4b .erwi5s .es1p -.es8t .ex1a2 .ex3em .fal6sc .fe6st5a .flu4g3 .furch8 .ga6ner .ge3n4a -\n{.ge5r"o} .ges6 .halb5 .halbe6 .hal6br .haup4 .hau4t .heima6 .he4r3e -.her6za .he5x .hin3 .hir8sc .ho4c .hu3sa .hy5o .ibe5 .ima6ge .in1 -.ini6 .is5chi .jagd5 .kal6k5o .ka6ph .ki4e .kop6f3 .kraf6 \n{.k"u5ra} -.lab6br .liie6 .lo6s5k \n{.l"o4s3t} .ma5d .mi2t1 .no6th .no6top -.obe8ri .ob1l .obs2 .ob6st5e .or3c .ort6s5e .ost3a .oste8r .pe4re -.pe3ts .ph6 .po8str .rau4m3 .re5an .ro8q .ru5the \n{.r"u5be} -\n{.r"u8stet} .sch8 .se6e .se5n6h .se5ra .si2e .spi6ke .st4 .sy2n -.tages5 .tan6kl .ta8th .te6e .te8str .to6der .to8nin .to6we .um1 -.umpf4 .un1 .une6 .unge5n .ur1c .ur5en .ve6rin .vora8 .wah6l5 .we8ges -.wo6r .wor3a .wun4s .zi4e .zuch8 \n{."ande8re} \n{."och8} aa1c aa2gr -aal5e aa6r5a a5arti aa2s1t aat2s 6aba ab3art 1abdr 6abel aben6dr -ab5erk ab5err ab5esse 1abf 1abg \n{1abh"a} ab1ir 1abko a1bl ab1la -5ablag a6bla\3 \c{a6bla\9} ab4ler ab1lu \n{a8bl"a} \n{5a6bl"o} abma5c -1abn ab1ra ab1re 5a6brec ab1ro ab1s ab8sk abs2z 3abtei ab1ur 1abw -5abze 5abzu \n{ab1"an} \n{ab"au8} a4ce. a5chal ach5art ach5au a1che -a8chent ach6er. a6ch5erf a1chi ach1l ach3m ach5n a1cho ach3re a1chu -ach1w a1chy \n{ach5"af} ack1o acks6t ack5sta a1d 8ad. a6d5ac ad3ant -ad8ar 5addi a8dein ade5o8 adi5en 1adj 1adle ad1op a2dre 3adres adt1 -1adv \n{a6d"a} a1e2d ae1r a1er. 1aero 8afa a3fal af1an a5far a5fat -af1au a6fentl a2f1ex af1fr af5rau af1re 1afri af6tent af6tra aft5re -a6f5um \n{8af"a} ag5abe 5a4gent ag8er ages5e 1aggr ag5las ag1lo a1gn -ag2ne 1agog a6g5und a1ha a1he ah5ein a4h3erh a1hi ahl1a ah1le ah4m3ar -ahn1a a5ho ahra6 ahr5ab ah1re ah8rei ahren8s ahre4s3 ahr8ti ah1ru a1hu -\n{ah8"o} ai3d2s ai1e aif6 a3inse ai4re. a5isch. ais8e a3ismu ais6n -aiso6 a1j 1akad a4kade a1ke a1ki 1akko 5akro1 a5lal al5ans 3al8arm -al8beb al8berw alb5la 3album al1c a1le a6l5e6be a4l3ein a8lel a8lerb -a8lerh a6lert 5a6l5eth 1algi al4gli al3int al4lab al8lan al4l3ar -alle3g a1lo a4l5ob al6schm al4the altist5 al4t3re 8a1lu alu5i a6lur -alu3ta \n{a1l"a} a6mate 8ame. 5a6meise am6m5ei am6mum am2n ampf3a -am6schw am2ta a1mu \n{a1m"a} a3nac a1nad anadi5e an3ako an3alp 3analy -an3ame an3ara a1nas an5asti a1nat anat5s an8dent ande4s3 an1ec an5eis -an1e2k 4aner. a6n5erd a8nerf a6n5erke 1anfa 5anfert \n{1anf"a} 3angab -5angebo an3gli ang6lis an2gn 3angri ang5t6 \n{5anh"a} ani5g ani4ka -an5i8on an1kl an6kno an4kro 1anl anma5c anmar4 3annah anne4s3 a1no -5a6n1o2d 5a6n3oma 5a6nord 1anr an1sa 5anschl an4soz an1st 5anstal -an1s2z 5antenn an1th \n{5anw"a} a5ny an4z3ed 5anzeig 5anzieh 3anzug -\n{an1"a} \n{5an"as} \n{a1n"o} \n{an"o8d} a1os a1pa 3apfel a2ph1t -\n{aph5"a6} a1pi 8apl apo1c apo1s a6poste a6poth 1appa ap1pr a1pr -\n{a5p"a} \n{a3p"u} a1ra a4r3af ar3all 3arbei 2arbt ar1c 2a1re ar3ein -ar2gl 2a1ri ari5es ar8kers ar6les ar4nan ar5o6ch ar1o2d a1rol ar3ony -a8ror a3ros ar5ox ar6schl 8artei ar6t5ri a1ru a1ry 1arzt arz1w -\n{ar8z"a} \n{ar"a8m} \n{ar"o6} \n{ar5"om} \n{ar1"u2} a1sa a6schec -asch5l asch3m a6schn a3s4hi as1pa asp5l a8steb as5tev 1asth a6stoc -a1str ast3re 8a1ta ata5c ata3la a6tapf ata5pl a1te a6teli aten5a -ate5ran 6atf 6atg a1th at3hal 1athl 2a1ti 5atlant 3atlas 8atmus 6atn -a1to a6t5ops ato6ra a6t5ort. 4a1tr a6t5ru at2t1h \n{at5t6h"a} 6a1tu -atz1w \n{a1t"a} \n{a1t"u} au1a au6bre auch3a au1e aue4l 5aufent -\n{3auff"u} 3aufga 1aufn auf1t 3auftr 1aufw 3auge. au4kle aule8s 6aum -au8mar aum5p 1ausb 3ausd 1ausf 1ausg au8sin 3auss au4sta 1ausw 1ausz -aut5eng au1th 1auto au\3e8 \c{au\9e8} a1v ave5r6a aver6i a1w a6wes a1x -a2xia a6xio a1ya a1z azi5er. 8a\3 \c{8a\9} 1ba 8ba8del ba1la ba1na -ban6k5r ba5ot bardi6n ba1ro basten6 bau3sp 2b1b bb6le b2bli 2b1c 2b1d -1be be1a be8at. be1ch 8becht 8becke. be5el be1en bee8rei be5eta bef2 -8beff be1g2 \n{beh"o8} bei1s 6b5eisen bei3tr b8el bel8o belu3t be3nac -bend6o be6ners be6nerw be4nor ben4se6 bens5el \n{be1n"a} \n{be1n"u} -be1o2 b8er. be1ra be8rac ber8gab. ber1r \n{be1r"u} bes8c bes5erh -bes2p be5tha bet5sc be1un be1ur 8bex be6zwec 2b1f8 bfe6st5e 2b1g2 -bga2s5 bge1 2b1h bhole6 1bi bi1bl b6ie bi1el bi1la \n{bil"a5} bi1na -bi4nok bi5str bi6stu bi5tr bit4t5r b1j 2b1k2 \n{bk"u6} bl8 b6la. -6b1lad 6blag 8blam 1blat b8latt 3blau. b6lav 3ble. b1leb b1led -8b1leg 8b1leh 8bleid 8bleih 6b3lein blei3s ble4m3o 4blich b4lind -8bling b2lio 5blit b4litz b1loh 8b1los 1blu 5blum 2blun blut3a blut5sc -\n{3bl"a} \n{bl"as5c} \n{5bl"o} \n{3bl"u} \n{bl"u8sc} 2b1m 2b1n 1bo -bo1ch bo5d6s boe5 8boff 8bonk bo1ra b1ort 2b1p2 b1q 1br brail6 brast8 -bre4a b5red 8bref 8b5riem b6riga bro1s b1rup b2ruz \n{8br"oh} -\n{br"os5c} 8bs b1sa b8sang b2s1ar b1sc bs3erl bs3erz b8sof b1s2p -bst1h b3stru \n{b5st"a} b6sun 2b1t b2t1h 1bu bu1ie bul6k b8ure bu6sin -6b1v 2b1w 1by1 by6te. 8b1z bzi1s \n{1b"a} \n{b5"a6s5} \n{1b"u} -\n{b6"u5bere} \n{b"uge6} \n{b"ugel5e} \n{b"ur6sc} 1ca cag6 ca5la ca6re -ca5y c1c 1ce celi4c celich5 ce1ro c8h 2ch. 1chae ch1ah ch3akt cha6mer -8chanz 5chara 3chari 5chato 6chb 1chef 6chei ch3eil ch3eis 6cherkl -6chf 4chh 5chiad 5chias 6chins 8chj chl6 5chlor 6ch2m 2chn6 ch8nie -5cho. 8chob choi8d 6chp ch3ren ch6res \n{ch3r"u} 2chs 2cht cht5ha -cht3hi 5chthon ch6tin 6chuh chu4la 6ch3unt chut6t 8chw 1ci ci5tr c2k -2ck. ck1ei 4ckh ck3l ck3n ck5o8f ck1r 2cks ck5stra ck6s5u c2l 1c8o -con6ne 8corb cos6t c3q 1c6r 8c1t 1cu 1cy \n{5c"a1} \n{c"o5} 1da. -8daas 2dabg 8dabr 6dabt 6dabw 1dac da2gr 6d5alk 8d5amt dan6ce. -dani5er dan8ker 2danl danla6 6dans 8danzi 6danzu d1ap da2r1a8 2d1arb -d3arc dar6men 4d3art 8darz 1dat 8datm 2d1auf 2d1aus 2d1b 2d1c 2d1d -d5de d3d2h \n{dd"amme8} 1de 2deal de5an de3cha de1e defe6 6deff 2d1ehr -5d4eic de5isc de8lar del6s5e del6spr de4mag de8mun de8nep dene6r -8denge. 8dengen de5o6d 2deol de5ram 8derdb der5ein de1ro der1r d8ers -der5um de4s3am de4s3an de4sau de6sil de4sin de8sor de4spr de2su 8deul -de5us. 2d1f df2l 2d1g 2d1h 1di dia5c di5ara dice5 di3chr di5ena di1gn -di1la dil8s di1na 8dind 6dinf 4d3inh 2d1ins di5o6d di3p4t di8sen dis1p -di5s8per di6s5to dis5tra di8tan di8tin d1j 6dje 2dju 2d1k 2d1l 2d1m -2d1n6 dni6 dnje6 1do 6d5obe do6berf 6d5ony do3ran 6dord 2d1org dor4t3h -do6ste 6doth dott8e 2d1p d5q dr4 1drah 8drak d5rand 6dre. 4drech -d6reck 4d3reg 8d3reic d5reife 8drem 8d1ren 2drer 8dres. 6d5rh 1dria -d1ric 8drind droi6 dro5x 1dru 8drut \n{dr"os5c} \n{1dr"u} \n{dr"u5b} -\n{dr"u8sc} 2ds d1sa d6san dsat6 d1sc 5d6scha. 5dschik dse8e d8serg -8dsl d1sp d4spak ds2po \n{d8sp"a} d1st \n{d1s"u} 2dt d1ta d1te d1ti -d1to dt1s6 d1tu \n{d5t"a} 1du du5als du1b6 du1e duf4t3r 4d3uh du5ie -8duml 8dumw 2d1und du8ni 6d5unt dur2c durch3 6durl 6dursa 8durt du1s -du8schr 2d1v 2d1w dwa8l 2d1z \n{1d"a} \n{6d"ah} \n{8d"and} \n{d"a6r} -\n{d"o8bl} \n{d5"ol} \n{d"or6fl} \n{d"o8sc} \n{d5"o4st} \n{d"os3te} -\n{1d"u} ea4ben e1ac e1ah e1akt e1al. e5alf e1alg e5a8lin e1alk e1all -e5alp e1alt e5alw e1am e1and ea6nim e1ar. e5arf e1ark e5arm e3art -e5at. e6ate e6a5t6l e8ats e5att e6au. e1aus e1b e6b5am ebens5e -eb4lie eb4ser eb4s3in e1che e8cherz e1chi ech3m 8ech3n ech1r ech8send -ech4su e1chu eck5an e5cl e1d ee5a ee3e ee5g e1ei ee5isc eei4s3t -ee6lend e1ell \n{ee5l"o} e1erd ee3r4e ee8reng eere6s5 \n{ee5r"a} -ee6tat e1ex e1f e6fau e8fe8b 3effek ef3rom ege6ra eglo6si 1egy e1ha -e6h5ach eh5ans e6hap eh5auf e1he e1hi ehl3a eh1le ehl5ein eh1mu ehn5ec -e1ho ehr1a eh1re ehre6n eh1ri eh1ru ehr5um e1hu eh1w e1hy \n{e1h"a} -\n{e1h"o} \n{e3h"ut} ei1a eia6s ei6bar eich3a eich5r ei4dar ei6d5ei -ei8derf ei3d4sc ei1e 8eifen 3eifri 1eign eil1d ei6mab ei8mag ein1a4 -ei8nat ei8nerh ei8ness ei6nete ein1g e8ini ein1k ei6n5od ei8nok ei4nor -\n{e3ins"a} ei1o e1irr ei5ru ei8sab ei5schn ei6s5ent ei8sol ei4t3al -eit3ar eit1h ei6thi ei8tho eit8samt ei6t5um e1j 1ekd e1ke e1ki e1k2l -e1kn ekni4 e1la e2l1al 6elan e6lanf e8lanl e6l5ans el3arb el3arm -e6l3art 5e6lasti e6lauge elbst5a e1le 6elef ele6h e6l5ehe e8leif -e6l5einh 1elek e8lel 3eleme e6lemen e6lente el5epi e4l3err e6l5ersc -elf2l elg2 e6l5ins ell8er 4e1lo e4l3ofe el8soh el8tent 5eltern e1lu -elut2 \n{e1l"a} \n{e1l"u} em8dei em8meis 4emo emo5s 1emp1f 1empt 1emto -e1mu emurk4 emurks5 \n{e1m"a} en5a6ben en5achs en5ack e1nad en5af -en5all en3alt en1am en3an. en3ant en3anz en1a6p en1ar en1a6s 6e1nat -en3auf en3aus en2ce enda6l end5erf end5erg en8dess 4ene. en5eck -e8neff e6n5ehr e6n5eim en3eis 6enem. 6enen e4nent 4ener. e8nerd -e6n3erf e4nerg 5energi e6n5erla en5ers e6nerst en5erw 6enes e6n5ess -e2nex en3glo 2eni enni6s5 ennos4 enns8 e1no e6nober eno8f en5opf -e4n3ord en8sers ens8kl en1sp ens6por en5t6ag enta5go en8terbu en6tid -3entla ent5ric 5entwic 5entwu 1entz enu5i e3ny en8zan \n{en1"of} -\n{e1n"os} \n{e1n"ug} eo1c e5o6fe e5okk e1on. e3onf e5onk e5onl e5onr -e5opf e5ops e5or. e1ord e1org eo5r6h eo1t e1pa e8pee e6p5e6g ep5ent -e1p2f e1pi 5epid e6pidem e1pl 5epos e6pos. ep4p3a e1pr \n{e1p"a} e1q -e1ra. er5aal 8eraba e5rabel er5a6ben e5rabi er3abs er3ach era5e -era5k6l er3all er3amt e3rand e3rane er3ans e5ranz. e1rap er3arc -e3rari er3a6si e1rat erat3s er3auf e3raum 3erbse er1c e1re 4e5re. -er3eck er5egg er5e2h 2erei e3rei. e8reine er5einr 6eren. e4r3enm -4erer. e6r5erm er5ero er5erst e4r3erz er3ess \n{5erf"ul} er8gan. -5ergebn er2g5h \n{5erg"anz} \n{5erh"ohu} 2e1ri eri5ak e6r5iat e4r3ind -e6r5i6n5i6 er5ins e6r5int er5itio er1kl \n{3erkl"a} \n{5erl"os.} -ermen6s er6nab 3ernst 6e1ro. e1rod er1o2f e1rog 6e3roi ero8ide e3rol -e1rom e1ron e3rop8 e2r1or e1ros e1rot er5ox ersch4 5erstat er6t5ein -er2t1h er5t6her 2e1ru eruf4s3 e4r3uhr er3ums e5rus 5erwerb e1ry er5zwa -er3zwu \n{er"a8m} \n{er5"as} \n{er"o8} \n{e3r"os.} \n{e6r1"u2b} e1sa -esa8b e8sap e6s5a6v e1sc esch4l ese1a es5ebe eserve5 e8sh es5ill -es3int es4kop e2sl eso8b e1sp espei6s5 es2po es2pu 5essenz e6stabs -e6staf e6st5ak est3ar e8stob e1str est5res es3ur e2sz \n{e1s"u} e1ta -et8ag etari5e eta8ta e1te eten6te et5hal e5thel e1ti 1etn e1to e1tr -et3rec e8tscha et8se et6tei et2th et2t1r e1tu etu1s et8zent et8zw -\n{e1t"a} \n{e1t"o} \n{e1t"u} eu1a2 eu1e eue8rei eu5fe euin5 euk2 -e1um. eu6nio e5unter eu1o6 eu5p 3europ eu1sp eu5str eu8zo e1v eval6s -eve5r6en ever4i e1w e2wig ex1or 1exp 1extr ey3er. e1z \n{e1"a2} -\n{e5"o8} \n{e1"u} e8\3es \c{e8\9es} fa6ch5i fade8 fa6del fa5el. -fal6lo falt8e fa1na fan4gr 6fanl 6fap far6ba far4bl far6r5a 2f1art -fa1sc fau8str fa3y 2f1b2 6f1c 2f1d 1fe 2f1eck fe6dr feh6lei f6eim -8feins f5eis fel5en 8feltern 8femp fe5rant 4ferd. ferri8 fe8stof -fe6str fe6stum fe8tag fet6ta fex1 2ff f1fa f6f5arm f5fe ffe5in ffe6la -ffe8ler ff1f f1fla ff3lei ff4lie ff8sa ff6s5ta 2f1g2 fgewen6 4f1h 1fi -fid4 fi3ds fieb4 fi1la fi8lei fil4m5a f8in. fi1na 8finf fi8scho fi6u -6f1j 2f1k2 f8lanz fl8e 4f3lein 8flib 4fling f2lix 6f3lon 5flop 1flor -\n{5f8l"ac} \n{3fl"ot} 2f1m 2f1n 1fo foh1 f2on fo6na 2f1op fo5ra -for8mei for8str for8th for6t5r fo5ru 6f5otte 2f1p8 f1q fr6 f5ram -1f8ran f8ra\3 \c{f8ra\9} f8re. frei1 5frei. f3reic f3rest f1rib -8f1ric 6frig 1fris fro8na \n{fr"as5t} 2fs f1sc f2s1er f5str -\n{fs3t"at} 2ft f1tak f1te ft5e6h ftere6 ft1h f1ti f5to f1tr ft5rad -ft1sc ft2so f1tu ftwi3d4 ft1z 1fu 6f5ums 6funf fun4ka fu8\3end -\c{fu8\9end} 6f1v 2f1w 2f1z \n{1f"a} \n{f"a1c} \n{8f"arm} \n{6f"aug} -\n{f"a8\3} \n{\c{f"a8\9}} \n{f"ode3} \n{8f"of} \n{3f"or} \n{1f"u} -\n{f"un4f3u} 1ga ga6bl 6gabw 8gabz g3a4der ga8ho ga5isc 4gak ga1la -6g5amt ga1na gan5erb gan6g5a ga5nj 6ganl 8gansc 6garb 2g1arc 2g1arm -ga5ro 6g3arti ga8sa ga8sc ga6stre 2g1atm 6g5auf gau5fr g5aus 2g1b g5c -6gd g1da 1ge ge1a2 ge6an ge8at. ge1e2 ge6es gef2 8geff ge1g2l ge1im -4g3eise geist5r gel8bra gelt8s \n{ge5l"o} ge8nin gen3k 6g5entf -\n{ge3n"a} ge1or ge1ra ge6rab ger8au \n{8gerh"o} ger8ins ge1ro 6g5erz. -\n{ge1r"a} \n{ge1r"u} ge1s ges2p ge5unt 4g3ex3 2g1f8 2g1g g1ha 6g1hei -5ghel. g5henn 6g1hi g1ho 1ghr \n{g1h"o} 1gi gi5la gi8me. gi1na -4g3ins gi3str g1j 2g1k 8gl. 1glad g5lag glan4z3 1glas 6glass 5glaub -g3lauf 1gle. g5leb 3gleic g3lein 5gleis 1glem 2gler 8g3leu gli8a -g2lie 3glied 1g2lik 1g2lim g6lio 1gloa 5glom 1glon 1glop g1los g4loss -g5luf 1g2ly \n{1gl"u} 2g1m gn8 6gn. 1gna 8gnach 2gnah g1nas g8neu -g2nie g3nis 1gno 8gnot 1go goe1 8gof 2gog 5gogr 6g5oh goni5e 6gonist -go1ra 8gord 2g1p2 g1q 1gr4 g5rahm gra8m gra4s3t 6g1rec gre6ge 4g3reic -g5reit 8grenn gri4e g5riem 5grif 2grig g5ring 6groh 2grot gro6\3 -\c{gro6\9} 4grut 2gs gs1ab g5sah gs1ak gs1an gs8and gs1ar gs1au g1sc -gs1ef g5seil gs5ein g2s1er gs1in g2s1o gso2r gs1pr g2s1u 2g1t g3te -g2t1h 1gu gu5as gu2e 2gue. 6gued 4g3uh 8gums 6g5unt gu1s gut3h gu2tu -4g1v 2g1w gy1n g1z \n{1g"a} \n{8g"a8m} \n{6g"arm} \n{1g"o} \n{1g"u} -\n{6g"ub} 1haa hab8r ha8del hade4n 8hae ha5el. haf6tr 2hal. ha1la -hal4b5a 6hale 8han. ha1na han6dr han6ge. 2hani h5anth 6hanz 6harb -h3arbe h3arme ha5ro ha2t1h h1atm hau6san ha8\3 \c{ha8\9} h1b2 h1c h1d -he2bl he3cho h3echt he5d6s 5heft h5e6he. hei8ds h1eif 2hein he3ism -he5ist. heit8s3 hek6ta hel8lau 8helt he6mer 1hemm 6h1emp hen5end -hen5klo hen6tri he2nu 8heo he8q her3ab he5rak her3an 4herap her3au -h3erbi he1ro he8ro8b he4r3um her6z5er he4spe he1st heta6 het5am he5th -heu3sc he1xa hey5e h1f2 h1g hgol8 h1h h1iat hie6r5i hi5kt hil1a2 -hil4fr hi5nak hin4ta hi2nu hi5ob hirn5e hir6ner hi1sp hi1th hi5tr -5hitz h1j h6jo h1k2 hlabb4 hla4ga hla6gr h5lai hl8am h1las h1la\3 -\c{h1la\9} hl1c h1led h3lein h5ler. h2lif h2lim h8linf hl5int h2lip -h2lit h4lor h3lose \n{h1l"as} hme5e h2nee h2nei hn3eig h2nel hne8n -hne4p3f hn8erz h6netz h2nip h2nit h1nol hn5sp h2nuc h2nud h2nul hoch1 -1hoh hoh8lei 2hoi ho4l3ar 1holz h2on ho1ra 6horg 5horn. ho3sl hos1p -ho4spi h1p hpi6 h1q 6hr h1rai h8rank h5raum hr1c hrcre8 h1red h3reg -h8rei. h4r3erb h8rert hrg2 h1ric hr5ins h2rom hr6t5erl hr2t1h hr6t5ra -hr8tri h6rum hr1z hs3ach h6s5amt h1sc h6s5ec h6s5erl hs8erle h4sob -h1sp h8spa\3 \c{h8spa\9} h8spel hs6po h4spun h1str h4s3tum hs3und -\n{h1s"u} h5ta. h5tab ht3ac ht1ak ht3ang h5tanz ht1ar ht1at h5taub -h1te h2t1ec ht3eff ht3ehe h4t3eif h8teim h4t3ein ht3eis h6temp h8tentf -hte8ren \n{h6terf"u} h8tergr h4t3erh h6t5ersc h8terst h8tese h8tess -h2t1eu h4t3ex ht1he ht5hu h1ti ht5rak hts3ah ht1sc ht6sex ht8sk ht8so -h1tu htz8 \n{h5t"um} hub5l hu6b5r huh1l h5uhr. huld5a6 hu8lent -\n{hu8l"a} h5up. h1v h5weib h3weis h1z \n{h"a8kl} \n{h"al8s} -\n{h"ama8tu8} \n{h"a8sche.} \n{h"at1s} \n{h"au4s3c} \n{2h"o.} -\n{2h"oe} \n{8h"oi} \n{h"o6s} \n{h"os5c} \n{h"uhne6} \n{h"ul4s3t} -\n{h"utte8re} i5adn i1af i5ak. i1al. i1al1a i1alb i1ald i5alei i1alf -i1alg i3alh i1alk i1all i1alp i1alr i1als i1alt i1alv i5alw i3alz -i1an. ia5na i3and ian8e ia8ne8b i1ang i3ank i5ann i1ant i1anz i6apo -i1ar. ia6rab i5arr i1as. i1asm i1ass i5ast. i1at. i5ats i1au i5azz -i6b5eig i6b5eis ib2le i4blis i6brig i6b5unt \n{i6b"ub} i1che ich5ei -i6cherb i1chi ich5ins ich1l ich3m ich1n i1cho icht5an icht3r i1chu -ich1w ick6s5te ic5l i1d id3arm 3ideal ide8na 3ideol \n{ide5r"o} i6diot -id5rec id1t ie1a ie6b5ar iebe4s3 ie2bl ieb1r ie8bra ie4bre \n{ie8b"a} -ie2dr ie1e8 ie6f5ad ief5f ie2f1l ie4fro ief1t i1ei ie4l3ec ie8lei -ie4lek i3ell i1en. i1end ien6e i3enf i5enn ien6ne. i1enp i1enr -i5ensa ien8stal i5env i1enz ie5o ier3a4b ie4rap i2ere ie4rec ie6r5ein -ie6r5eis ier8er i3ern. ie8rum ie8rund ie6s5che ie6tau ie8tert ie5the -ie6t5ri i1ett ie5un iex5 2if i1fa if5ang i6fau if1fr if5lac i5f6lie -i1fre ift5a if6t5r ig3art 2ige i8gess ig5he i5gla ig2ni i5go ig3rot -ig3s2p i1ha i8ham i8hans i1he i1hi ih1n ih1r i1hu i8hum ih1w 8i1i ii2s -ii2t i1j i1k i6kak i8kerz i6kes ik4ler i6k5unt 2il i5lac i1lag il3ans -i5las i1lau il6auf i1le ile8h i8lel il2fl il3ipp il6l5enn i1lo ilt8e -i1lu \n{i1l"a} i8mart imb2 i8mele i8mid imme6l5a i1mu \n{i1m"a} -\n{i5m"o} ina5he i1nat in1au inau8s 8ind. in4d3an 5index ind2r 3indus -i5nec i2n1ei i8nerw 3infek 1info 5ingeni ing5s6o 5inhab ini5er. 5inj -\n{in8k"at} in8nan i1no inoi8d in3o4ku in5sau in1sp 5inspe 5instit -5instru ins4ze 5intere 5interv in3the in5t2r i5ny \n{in"a2} \n{i1n"ar} -\n{in1"as} \n{in"o8} \n{in5"od} \n{i1n"os} 2io io1a8 io1c iode4 io2di -ioi8 i1ol. i1om. i1on. i5onb ion2s1 i1ont i5ops i5o8pt i1or. -i3oral io3rat i5orc i1os. i1ot. i1o8x 2ip i1pa i1pi i1p2l i1pr i1q -i1ra ir6bl i1re i1ri ir8me8d ir2m1o2 ir8nak i1ro ir5rho ir6schl -ir6sch5r i5rus i5ry \n{i5r"a} i1sa i8samt i6sar i2s1au i8scheh i8schei -isch5m isch3r \n{isch"a8} is8ele ise3ra i4s3erh is3err isi6de i8sind -is4kop ison5e is6por i8s5tum i5sty \n{i5s"o} i1ta it5ab. i2t1a2m -i8tax i1te i8tersc i1thi i1tho i5thr \n{it8h"a} i1ti i8ti8d iti6kl -itmen4 i1to i8tof it3ran it3rau i1tri itri5o it1sc it2se it5spa it8tru -i1tu it6z5erg it6z1w \n{i1t"a} \n{it"a6r5e} \n{it"at2} \n{it"ats5} -\n{i1t"u} i1u iu6r 2i1v i6vad iva8tin i8vei i6v5ene i8verh i2vob i8vur -i1w iwi2 i5xa i1xe i1z ize8n i8zir i6z5w \n{i"a8m} \n{i1"a6r} -\n{i5"at.} \n{i5"av} \n{i1"o8} \n{i"u8} i6\35ers \c{i6\95ers} ja5la -je2t3r 6jm 5jo jo5as jo1ra jou6l ju5cha jugen4 jugend5 jung5s6 ju1s -\n{3j"a} 1ka 8kachs 8kakz ka1la kal5d kam5t ka1na 2kanl 8kapf ka6pl -ka5r6a 6k3arbe ka1ro kar6p5f 4k3arti 8karz \n{ka1r"a} kasi5e ka6teb -kat8ta kauf6s kau3t2 2k1b 2k1c 4k1d kehr6s kehrs5a 8keic 2k1eig 6k5ein -6k5eis ke6lar ke8leis ke8lo 8kemp k5ente. k3entf 8k5ents 6kentz ke1ra -k5erlau 2k1f8 2k1g 2k1h ki5fl 8kik king6s5 6kinh ki5os ki5sp ki5th -\n{8ki8"o} 2k1k2 kl8 1kla 8klac k5lager kle4br k3leib 3kleid kle5isc -4k3leit k3lek 6k5ler. 5klet 2klic 8klig k2lim k2lin 5klip 5klop k3lor -\n{1kl"a} 2k1m kmani5e kn8 6kner k2ni \n{kn"a8} 1k2o ko1a2 ko6de. -ko1i koi8t ko6min ko1op ko1or ko6pht ko3ra kor6d5er ko5ru ko5t6sc k3ou -3kow 6k5ox 2k1p2 k1q 1kr8 4k3rad 2k1rec 4k3reic kre5ie 2krib 6krig -2krip 6kroba 2ks k1sa k6sab ksal8s k8samt k6san k1sc k2s1ex k5spat -k5spe k8spil ks6por k1spr kst8 k2s1uf 2k1t kta8l kt5a6re k8tein kte8re -k2t1h k8tinf kt3rec kt1s 1ku ku1ch kuck8 k3uhr ku5ie kum2s1 kunfts5 -kun2s kunst3 ku8rau ku4ro kurz1 ku1st 4kusti ku1ta ku8\3 \c{ku8\9} -6k1v 2k1w ky5n 2k1z \n{1k"a} \n{k"a4m} \n{4k3"ami} \n{k"ase5} \n{1k"o} -\n{k"o1c} \n{k"o1s} \n{1k"u} \n{k"u1c} \n{k"ur6sc} \n{k"u1s} 1la. -8labf 8labh lab2r 2l1abs lach3r la8dr 5ladu 8ladv 6laff laf5t la2gn -5laken 8lamb la6mer 5lampe. 2l1amt la1na 1land lan4d3a lan4d3r lan4gr -8lanme 6lann 8lanw \n{6lan"a} 8lappa lap8pl lap6pr l8ar. la5ra lar4af -la8rag la8ran la6r5a6s l3arbe la8rei 6larm. la8sa la1sc la8sta lat8i -6l5atm 4lauss 4lauto 1law 2lb l8bab l8bauf l8bede l4b3ins l5blo -lbst5an lbst3e 8lc l1che l8chert l1chi lch3m l5cho lch5w 6ld l4d3ei -ld1re \n{l6d"ub} le2bl le8bre lecht6s5 led2r 6leff le4gas 1lehr lei6br -le8inf 8leinn 5leistu 4lektr le6l5ers lemo2 8lemp l8en. 8lends -6lendun le8nend len8erw 6l5ents 4l3entw 4lentz 8lenzy 8leoz 6lepi -le6pip 8lepo 1ler l6er. 8lerbs 6l5erde le8reis le8rend le4r3er 4l3erg -l8ergr 6lerkl 6l5erzie \n{8ler"o} 8lesel lesi5e le3sko le3tha let1s -5leuc 4leuro leu4s3t le5xe 6lexp l1f 2l1g lgend8 l8gh lglie3 lglied6 -6l1h 1li li1ar li1as 2lick li8dr li1en lien6n li8ers li8ert 2lie\3 -\c{2lie\9} 3lig li8ga8b li1g6n li1l8a 8limb li1na 4l3indu lings5 -4l3inh 6linj link4s3 4linkt 2lint 8linv lion5s6t 4lipp 5lipt 4lisam -livi5e 6l1j 6l1k l8keim l8kj lk2l lko8f lkor8 lk2sa lk2se 6ll l1la -ll3a4be l8labt ll8anl ll1b ll1c ll1d6 l1le l4l3eim l6l5eise ller3a -l4leti l5lip l1lo ll3ort ll5ov ll6spr llte8 l1lu ll3urg \n{l1l"a} -\n{l5l"u} \n{l6l"ub} 2l1m l6m5o6d 6ln l1na l1no 8lobl lo6br 3loch. -l5o4fen 5loge. 5lohn 4l3ohr 1lok l2on 4l3o4per lo1ra 2l1ord 6lorg -4lort lo1ru 1los. lo8sei 3losig lo6ve lowi5 6l1p lp2f l8pho l8pn -lp4s3te l2pt l1q 8l1r 2ls l1sa l6sarm l1sc l8sec l6s5erg l4s3ers l8sh -l5s6la l1sp ls4por ls2pu l1str l8suni \n{l1s"u} 2l1t lt5amp l4t3ein -l5ten l6t5eng l6t5erp l4t3hei lt3her l2t1ho l6t5i6b lti1l \n{l8tr"o} -lt1sc lt6ser lt4s3o lt5ums lu8br lu2dr lu1en8 8lu8fe luft3a luf8tr -lu6g5r 2luh l1uhr lu5it 5luk 2l1umf 2l1umw 1lun 6l5u6nio 4l3unte lu5ol -4lurg 6lurs l3urt lu4sto lu3str lu6st5re lu8su lu6tal lu6t5e6g lu8terg -lu3the lu6t5or lu2t1r lu6\35 \c{lu6\95} l1v lve5r6u 2l1w 1ly lya6 -6lymp ly1no l8zess l8zo8f l3zwei lz5wu \n{3l"and} \n{l"a5on} -\n{l"a6sc} \n{l"at1s} \n{5l"auf} \n{2l"aug} \n{l"au6s5c} \n{l"a5v} -\n{l1"ol} \n{1l"os} \n{l"o1\36t} \n{\c{l"o1\96t}} \n{6l1"ube} 1ma -8mabg ma5chan mad2 ma5el 4magg mag8n ma1la ma8lau mal5d 8malde mali5e -malu8 ma8lut 2m1amp 3man mand2 man3ds 8mangr mani5o 8m5anst 6mappa -4m3arbe mar8kr ma1r4o mar8schm 3mas ma1sc \n{ma1t"o} 4m5auf ma5yo 2m1b -mb6r 2m1c 2m1d \n{md6s"a} 1me me1ch me5isc 5meld mel8sa 8memp me5nal -men4dr men8schl men8schw 8mentsp me1ra mer4gl me1ro 3mes me6s5ei me1th -me8\3 \c{me8\9} 2m1f6 2m1g 2m1h 1mi mi1a mi6ale mi1la 2m1imm mi1na -\n{mi5n"u} mi4s3an mit1h mi5t6ra 3mitt mitta8 mi6\35 \c{mi6\95} 6mj -2m1k8 2m1l 2m1m m6mad m6m5ak m8menth m8mentw mme6ra m2mn mm5sp mm5ums -mmut5s \n{m8m"an} m1n8 m5ni 1mo mo5ar mo4dr 8mof mo8gal mo4kla mol5d -m2on mon8do mo4n3od mont8a 6m5ony mopa6 mo1ra mor8d5a mo1sc mo1sp 5mot -moy5 2mp m1pa mpfa6 mpf3l mphe6 m1pi mpin6 m1pl mp2li m2plu mpo8ste -m1pr \n{mpr"a5} mp8th mput6 mpu5ts \n{m1p"o} 8m1q 2m1r 2ms ms5au m1sc -msch4l ms6po m3spri m1str 2m1t mt1ar m8tein m2t1h mt6se \n{mt8s"a} -mu5e 6m5uh mumi1 1mun mun6dr muse5e mu1ta 2m1v mvol2 mvoll3 2m1w 1my -2m1z \n{m"a6kl} \n{1m"an} \n{m"a1s} \n{m"a5tr} \n{m"au4s3c} \n{3m"a\3} -\n{\c{3m"a\9}} \n{m"ob2} \n{6m"ol} \n{1m"u} \n{5m"un} \n{3m"ut} 1na. -n5ab. 8nabn n1abs n1abz \n{na6b"a} na2c nach3e 3nacht 1nae na5el -n1afr 1nag 1n2ah na8ha na8ho 1nai 6nair na4kol n1akt nal1a 8naly 1nama -na4mer na1mn n1amp 8n1amt 5nanc nan6ce n1and n6and. 2n1ang 1nani -1nann n1ans 8nanw 5napf. 1n2ar. na2ra 2n1arc n8ard 1nari n8ark -6n1arm 5n6ars 2n1art n8arv 6natm nat6s5e 1naue 4nauf n3aug 5naui n5auk -na5um 6nausb 6nauto 1nav 2nax 3naz 1na\3 \c{1na\9} n1b2 nbau5s n1c -nche5e nch5m 2n1d nda8d n2d1ak nd5ans n2d1ei nde8lac ndel6sa n8derhi -nde4se nde8stal n2dj ndnis5 n6d5or6t nd3rec nd3rot nd8samt nd6sau -ndt1h n8dumd 1ne ne5as ne2bl 6n5ebn 2nec 5neei ne5en ne1g4l 2negy -4n1ein 8neis 4n3e4lem 8nemb 2n1emp nen1a 6n5energ nen3k 8nentb -4n3en3th 8nentl 8n5entn 8n5ents ne1ra ne5r8al ne8ras 8nerbi 6n5erde. -nere5i6d nerfor6 \n{6n5erh"o} \n{8nerl"o} 2n1err n8ers. 6n5ertra -2n1erz nesi3e net1h neu4ra neu5sc 8neu\3 \c{8neu\9} n1f nf5f nf2l -nflei8 nf5lin nft8st n8g5ac ng5d ng8en nge8ram ngg2 ng1h n6glic ng3rip -ng8ru ng2se4 ng2si n2g1um n1gy \n{n8g"al} n1h nhe6r5e 1ni ni1bl -\n{ni5ch"a} ni8dee n6ie ni1en nie6s5te niet5h ni8etn 4n3i6gel n6ik -ni1la 2n1imp ni5na 2n1ind 8ninf 6n5inh ni8nit 6n5inn 2n1ins 4n1int -n6is ni3str ni1th ni1tr n1j n6ji n8kad nk5ans n1ke n8kerla n1ki nk5inh -\n{n5kl"o} n1k2n n8k5not nk3rot \n{n8kr"u} nk5spo nk6t5r n8kuh -\n{n6k"ub} n5l6 nli4mi n1m nmen4s n1na n8nerg nni5o n1no nn4t3ak nnt1h -nnu1e n1ny \n{n1n"a} \n{n1n"o} \n{n1n"u} no5a no4b3la 4n3obs 2nobt -noche8 no6die no4dis no8ia no5isc 6n5o6leu no4mal noni6er 2n1onk n1ony -4n3o4per 6nopf 6nopti no3ra no4ram nor6da 4n1org 2n1ort n6os no1st -8nost. no8tan no8ter noty6pe 6n5ox n1p2 n1q n1r \n{nr"os3} 6ns n1sac -ns3ang n1sc n8self n8s5erf n8serg n6serk ns5erw n8sint n1s2pe n1spr -n6s5tat. n5s6te. n6stob n1str n1ta n4t3a4go nt5anh nt3ark nt3art -n1te nt3eis nte5n6ar nte8nei nter3a nte6rei nt1ha nt6har n3ther nt5hie -n3thus n1ti nti1c n8tinh nti1t ntlo6b ntmen8 n1to nt3o4ti n1tr ntra5f -ntra5ut nt8rea nt3rec nt8rep n4t3rin nt8rop n4t3rot \n{n4tr"u} nt1s -nts6an nt2sk n1tu nt1z \n{n1t"a} \n{n1t"o} \n{n8t"ol} \n{n1t"u} 1nu -nu1a nu5el nu5en 4n1uhr nu5ie 8numl 6n5ums 6n5umw 2n1und 6nuni 6n5unr -2n1unt 2nup 2nu6r n5uri nu3skr nu5ta n1v 8n1w 1nys n1za n6zab n2z1ar -n6zaus nzi4ga n8zof n6z5unt n1zw n6zwir \n{1n"ac} \n{5n"ae} \n{5n"ai} -\n{n8"al} \n{n"a6m} \n{n"a6re} \n{n5"arz} \n{5n"aus} \n{n1"ol} -\n{1n"ot} \n{n5"oz} \n{5n"u.} \n{6n1"u2b} \n{5n"u\3} \n{\c{5n"u\9}} -o5ab. oa2l o8ala o1a2m o1an ob1ac obe4ra o6berh 5o4bers o4beru -obe6ser 1obj o1bl o2bli ob5sk 3obst. ob8sta obst5re ob5sz o1che -oche8b o8chec o3chi och1l och3m ocho8f o3chro och3to o3chu och1w o1d -o2d1ag od2dr ode5i ode6n5e od1tr o5e6b o5e6der. oe8du o1ef o1e2l -o1e2p o1er. o5e8x o1fa of8fan 1offi of8fin of6f5la o5fla o1fr 8o1g -og2n o1ha o1he o6h5eis o1hi ohl1a oh1le oh4l3er 5ohm. oh2ni o1ho -oh1re oh1ru o1hu oh1w o1hy \n{o1h"a} o5ia o1id. o8idi oi8dr o5ids -o5isch. oiset6 o1ism o3ist. o5i6tu o1j o1k ok2l ok3lau \n{o8kl"a} -1okta o1la old5am old5r o1le ole5in ole1r ole3u ol6gl ol2kl olk4s1 -ol8lak ol8lauf. ol6lel ol8less o1lo ol1s ol6sk o1lu oly1e2 5olym -o2mab om6an o8mau ombe4 o8merz om5sp o1mu o8munt \n{o1m"a} \n{o1m"o} -o1na ona8m on1ax on8ent o6n5erb 8oni oni5er. on1k on6n5a6b o1no ono1c -o4nokt 1ons onts8 \n{o1n"a} oo8f 1oog oo2pe oo2sa o1pa 3o4pera o3pfli -opf3lo opf3r o1pi o1pl o2pli o5p6n op8pa op6pl o1pr o3p4ter 1opti -\n{o1p"a} \n{o5p"o} o1q o1ra. o3rad o8radd 1oram o6rang o5ras o8rauf -or5cha or4d3a4m or8dei or8deu 1ordn or4dos o1re o5re. ore2h o8r5ein -ore5isc or6enn or8fla or8fli 1orga 5orgel. or2gl o1ri 5o6rient or8nan -\n{or8n"a} o1ro or1r2h or6t5an or8tau or8tere o1rus o1ry \n{o1r"a} -\n{or1"u2} o1sa osa3i 6ose o8serk o1sk o6ske o6ski os2kl os2ko os2kr -osni5e o2s1o2d o3s4per o4stam o6stau o3stra ost3re osu6 o6s5ur o5s6ze -o1ta ot3auf o6taus o1te o6terw o1th othe5u o2th1r o1ti o1to oto1a -ot1re o1tri o1tro ot1sc o3tsu ot6t5erg ot2t3h ot2t5r \n{ot8t"o} o1tu -ou3e ouf1 ou5f6l o5u6gr ou5ie ou6rar ou1t6a o1v o1wa o1we o6wer. o1wi -owid6 o1wo o5wu o1xe oy5al. oy1e oy1i o5yo o1z oza2r 1o2zea ozo3is -\n{o"o8} o\35elt \c{o\95elt} o\31t \c{o\91t} 3paa pa6ce 5pad pag2 1pak -pa1la pa8na8t pani5el pa4nor pan1s2 1pap pap8s pa8rei par8kr paro8n -par5o6ti part8e 5partei 3partn pas6sep pa4tha 1pau 6paug pau3sc p1b -8p5c 4p1d 1pe 4peic pe5isc 2pek pen3k pen8to8 p8er pe1ra pere6 per5ea -per5eb pe4rem 2perr per8ran 3pers 4persi \n{pe3r"u} pe4sta pet2s -p2f1ec p4fei pf1f pf2l 5pflanz pf8leg pf3lei 2pft pf3ta p1g 1ph 2ph. -2p1haf 6phb 8phd 6p5heit ph5eme 6phg phi6e 8phk 6phn p5holl pht2 -ph3tha 4ph3the phu6 6phz pi1en pi5err pi1la pi1na 5pinse pioni8e 1pis -pi1s2k pi1th p1k pl8 5pla p2lau 4plei p3lein 2pler 6p5les 2plig p6lik -6p5ling p2liz plo8min 6p1m p1n 1p2o 8poh 5pol po8lan poly1 po3ny po1ra -2porn por4t3h \n{po5r"o} 5poti p1pa p6p5ei ppe6la pp5f p2p1h p1pi pp1l -ppp6 pp5ren pp1s \n{p5p"o} pr6 3preis 1pres 2p3rig 5prinz 1prob 1prod -5prog pro8pt pro6t5a prote5i 8pro\3 \c{8pro\9} \n{pr"a3l} \n{1pr"as} -\n{pr"ate4} \n{1pr"uf} p5schl 2pst 1p2sy p1t p8to8d pt1s 5p6ty 1pu -pu1b2 2puc pu2dr puf8fr 6p5uh pun8s pu8rei pu5s6h pu1ta p1v p3w 5py -py5l p1z \n{p"a6der} \n{p5"a6m} \n{p"a8nu} \n{8p"ar} \n{p"at5h} -\n{p"at1s} qu6 1qui 8rabk ra6bla 3rable ra2br r1abt 6rabz ra4dan ra2dr -5rafal ra4f3er ra5gla ra2g3n 6raha ral5am 5rald 4ralg ra8lins 2rall -ral5t 8ramei r3anal r6and ran8der ran4dr 8ranf 6ranga 5rangi ran8gli -r3angr rans5pa 8ranw r8anz. ra5or 6rapf ra5pl rap6s5er 2r1arb 1rarh -r1arm ra5ro 2r1art 6r1arz ra8tei ra6t5he 6ratl ra4t3ro r5atta raue4n -6raus. r5austa rau8tel raut5s ray1 r1b rb5lass r6bler rb4lie rbon6n -r8brecht \n{rb6s5t"a} r8ces r1che rch1l rch3m rch3re rch3tr rch1w 8rd -r1da r8dachs r8dap rda5ro rde5ins rdio5 r8dir rd3ost r1dr r8drau 1re. -re1ak 3reakt re3als re6am. re1as 4reben re6bl rech5a r8edi re3er -8reff 3refl 2reh 5reha r4ei. reich6s5 8reier 6reign re5imp 4r3eina -6r3einb 6reing 6r5einn 6reinr 4r3eins r3eint reli3e 8r5elt 6rempf -2remt ren5a6b ren8gl r3enni 1reno 5rente 4r3enth 8rentl 4r3entw 8rentz -ren4zw re1on requi5 1rer rer4bl 6rerbs 4r3erd \n{8rerh"o} 8rerkl -4r3erla \n{8rerl"o} 4r3erns \n{6r5ern"a} rer5o 6r5erreg r5ertr r5erwec -\n{r5er"o} re2sa re8schm 2ress re5u8ni 6rewo 2r1ex r1f r8ferd rf4lie -8r1g r8gah rge4bl rge5na rgest4 rg6ne r2gni2 r8gob r4g3ret rg8sel r1h8 -r2hy 5rhyt ri1ar ri5cha rid2g r2ie rieg4s5 ri8ei ri1el ri6ele ri1en -ri3er. ri5ers. ri6fan ri8fer ri8fr 1r2ig ri8kn ri5la \n{rim"a8} -ri1na r8inde rin4ga rin6gr 1rinn 6rinner rino1 r8insp 4rinst -\n{ri1n"a} ri5o6ch ri1o2d ri3o6st 2r1ir r2is ri3sko ri8spr \n{ri8st"u} -ri5sv r2it 6r5i6tal ri5tr ri6ve. 8r1j 6rk r1ke rkehrs5 r1ki r3klin -r1k2n rk3str rk4t3an rk6to r6kuh \n{rk"a4s3t} r1l r5li rline5a 6r1m -r6manl rma4p r4m3aph r8minf r8mob rm5sa 2rn r1na rna8be r5ne rn2ei -r6neif r6nex r6nh rn1k r1no r6n5oc rn1sp \n{r1n"a} \n{r1n"u} ro6bern -6robs ro1ch 3rock. ro5de ro1e 4rofe ro8hert 1rohr ro5id ro1in ro5isc -6rolym r2on 6roog ro6phan r3ort ro1s2p ro5s6w ro4tau ro1tr ro6ts 5rout -r1p rpe8re rp2f r2ps r2pt r1q 2rr r1ra r1re rrer6 rr6hos \n{r5rh"o} -r1ri r1ro rro8f rr8or rror5a r1ru r3ry \n{r1r"a} \n{r1r"o} \n{r1r"u} -2r1s r6sab r4sanf rse6e rse5na r2sh r6ska r6ski rs2kl r8sko r2sl rs2p -r6stauf r8sterw r8stran rswi3d4 r2sz 2r1t rt3art r8taut r5tei rt5eige -r8tepe r4t3erh r8terla r4t3hei r5t6hu r4t3int rt5reif rt1sc rt6ser -rt6s5o rt6s5u rt5und r8turt rube6 ru1en 1r4uf ruf4st ru1ie 2r1umg -2r1uml 2rums run8der run4d5r 6rundz 6runf 8runs 2r1unt 2r1ur r6us -ru6sta ru3str ru6tr 1ruts r1v rven1 rvi2c r1w r1x r1za rz5ac r6z5al -r8z1ar r8zerd r6z5erf rz8erh rz4t3h r8zum \n{r"a4ste} \n{r"au8sc} -\n{r1"of} \n{5r"ohr} \n{r"o5le} \n{3r"oll} \n{5r"omis} \n{r1"or} -\n{r"o2sc} \n{3r"ump} 1sa. 1saa s3a4ben sa2bl 2s1abs 6s1abt 6sabw -3sack. 6s3a4der 1saf sa1fa 4s1aff sa5fr 1sag 1sai sa1i2k1 4s1akt 1sal -sa1la 4s3alpi 6salter salz3a 1sam s5anb san2c 1sand s5angeh 6sanl -2s1ans 6s3antr 8s1anw s1ap s6aph 8sapo sap5p6 s8ar. 2s1arb 3sarg -s1arm sa5ro 2s1art 6s1arz 1sas 1sat sat8a 2s1atl sa8tom 3s8aue s5auff -sau5i s6aur 2s1aus 5s6ause 2s1b2 2sca s4ce 8sch. 3scha. 5schade -3schaf 3schal sch5ame 8schanc 8schb 1sche 6schef 8schex 2schf 2schg -2schh 1schi 2schk 5schlag 5schlu \n{6schm"a\3} \n{\c{6schm"a\9}} -6schna\3 \c{6schna\9} 1scho 6schord 6schp 3schri 8schric 8schrig -8schrou 6schs 2scht sch3ta sch3tr 1schu 8schunt 6schv 2schz \n{5sch"o} -\n{5sch"u} 2sco scre6 6scu 2s1d 1se se5an se1ap se6ben se5ec see5i6g -se3erl 8seff se6han se8hi \n{se8h"o} 6s5eid. 2s1eig s8eil 5sein. -sei5n6e 6s5einh 3s8eit 3sel. se4lar selb4 6s3e4lem se8lerl 2s1emp -sen3ac se5nec 6s5ents 4sentz s8er. se8reim ser5inn \n{8serm"a} -8s5erzi \n{6ser"of} se1um 8sexa 6sexp 2s1f2 sfal8ler 2s3g2 sge5b2 s1h -s8hew 5s6hip 5s4hop 1si 2siat si1b sicht6s 6s5i6dee siege6s5 si1en -si5err si1f2 si1g2n si6g5r si8kau sik1i si4kin si2kl \n{si8k"u} si1la -sil6br si1na 2s1inf sin5gh 2s1inh sinne6s5 2s1ins si5ru si5str 4s1j -s1k2 6sk. 2skau skel6c skelch5 s6kele 1s2ki. 3s4kin. s6kiz s8kj -6skn 2skow 3skrib 3skrip 2sku \n{8sk"u} s1l s8lal slei3t s4low 2s1m -s1n 6sna 6snot 1so so1ch 2s1odo so4dor 6s5o4fen solo3 s2on so5of 4sope -so1ra 2s1ord 4sorga sou5c so3un 4s3ox sp2 8spaa 5spal 1span 2spap -s2pec s4peis 1spek s6perg 4spers s6pes 2s1pf 8sphi \n{1s2ph"a} 1spi -spi4e 6s5pig 6spinse 2spis 2spla 2spol 5s6pom 6s5pos 6spoti 1spra -3s8prec 6spreis 5spring 6sprob 1spru s2pul 1s2pur 6spy \n{5sp"an} -\n{1sp"u} s1q 2s1r 2s1s2 sse8nu ssini6s ssoi6r 2st. 1sta 4stafe 2stag -sta3la 6stale 4stalg 8stalk 8stamt 6st5anf 4stans 6stanw 6starb sta4te -6staus 2stb 6stc 6std 1ste 4steil 3s2tel st3elb 8stemb 6steppi 8stese -8stesse 6stf 2stg 2sth st1ha st3hei s8t1hi st1ho st5hu 1sti sti4el -4stigm sti3na 6stind 4stinf sti8r 2stk 2stl 2stm 1sto 6stoll. 4st3ope -6stopf. 6stord 6stp 5stra. 4strai 3s4tral 6s5traum 3stra\3 -\c{3stra\9} 3strec 6s3tref 8streib 5streif 6streno 6stres 6strev -5s6tria 6strig 5strik 8strisi 3s4troa s8troma st5rose 4struf 3strum -\n{6str"ag} 2st1s6 2stt 1stu stu5a 4stuc 2stue 8stun. 2stv 2stw s2tyl -6stz \n{1st"a} \n{8st"ag} \n{1st"o} \n{1st"u} \n{8st"uch} \n{4st"ur.} -1su su2b1 3suc su1e su2fe su8mar 6sumfa 8sumk 2s1unt sup1p2 6s5u6ran -6surte 2s1v 2s1w 1sy 8syl. sy5la syn1 sy2na syne4 s1z s4zend 5s6zene. -8szu \n{1s"a} \n{6s5"and} \n{6s"augi} \n{6s"au\3} \n{\c{6s"au\9}} -\n{5s"om} \n{2s1"u2b} \n{1s"uc} \n{s"u8di} \n{1s"un} \n{5s"u\3} -\n{\c{5s"u\9}} taats3 4tab. taba6k ta8ban tab2l ta6bre 4tabs t3absc -8tabz 6t3acht ta6der 6tadr tad6s tad2t 1tafe4 1tag ta6ga6 ta8gei -tage4s tag6s5t tah8 tahl3 tai6ne. ta5ir. tak8ta tal3au 1tale ta8leng -tal5ert 6t5a6mer 6tamp tampe6 2t1amt tan5d6a tan8dr tands5a tani5e -6tanl 2tanr t3ans 8t5antr tanu6 t5anw 8tanwa tan8zw ta8rau 6tarbe -1tari 2tark 2t1arm ta1ro 2tart t3arti 6tarz ta1sc ta6sien ta8stem -ta8sto t5aufb 4taufn 8taus. 5tause 8tausf 6tausg t5ausl 2t1b2 2t1c -t6chu 2t1d te2am tea4s te8ben 5techn 4teff te4g3re te6hau 2tehe te4hel -2t1ehr te5id. teig5l 6teign tei8gr 1teil 4teinh t5einhe 4teis t5eisen -8teiw te8lam te4lar 4telek 8telem te6man te6n5ag ten8erw ten5k tens4p -ten8tro 4t3entw 8tentz te6pli 5teppi ter5a6b te3ral ter5au 8terbar -t5erbe. 6terben 8terbs 4t3erbt t5erde. ter5ebe ter5ein te8rers terf4 -\n{8terh"o} \n{6terkl"a} ter8nor ter6re. t8erscha t5e6sel te8stau -t3euro te1xa tex3e 8texp tex6ta 2t1f2 2t1g2 2th. th6a 5tha. 2thaa -6t1hab 6t5haf t5hah 8thak 3thal. 6thals 6t3hand 2t1hau 1the. 3t4hea -t1heb t5heil t3heit t3helf 1theo 5therap 5therf 6t5herz 1thes 1thet -5thi. 2t1hil t3him 8thir 3this t5hj 2th1l 2th1m th1n t5hob t5hof -4tholz 6thopti 1thr6 4ths t1hum 1thy \n{4t1h"a} \n{2t1h"o} \n{t1h"u} -ti1a2m ti1b tie6fer ti1en ti8gerz tig3l ti8kin ti5lat 1tilg t1ind -tin4k3l ti3spa ti5str 5tite ti5tr ti8vel ti8vr 2t1j 2t1k2 2t1l tl8a -2t1m8 2t1n 3tobe 8tobj to3cha 5tocht 8tock tode4 to8del to8du to1e -6t5o6fen to1in toi6r 5toll. to8mene t2ons 2t1ony to4per 5topf. 6topt -to1ra to1s to6ska tos2l 2toti to1tr t8ou 2t1p2 6t1q tr6 tra5cha -tra8far traf5t 1trag tra6gl tra6gr t3rahm 1trai t6rans tra3sc tra6st -3traue t4re. 2trec t3rech t8reck 6t1red t8ree 4t1reg 3treib 4treif -8t3reis 8trepo tre6t5r t3rev 4t3rez 1trib t6rick tri6er 2trig t8rink -tri6o5d trizi5 tro1a 3troc trocke6 troi8d tro8man. tro3ny 5tropf -6t5rosa t5ro\3 \c{t5ro\9} 5trub 5trup trut5 \n{1tr"ag} \n{6t1r"oh} -\n{5tr"ub} \n{tr"u3bu} \n{t1r"uc} \n{t1r"us} 2ts ts1ab t1sac tsa8d -ts1ak t6s5alt ts1an ts1ar ts3auf t3schr \n{t5sch"a} tse6e tsee5i -tsein6s ts3ent ts1er t8serf t4serk t8sh 5t6sik t4s3int ts5ort. -t5s6por t6sprei t1st t6s5tanz ts1th t6stit t4s3tor 1t2sua t2s1uf -t8sum. t2s1u8n t2s1ur 2t1t tt5eif tte6sa tt1ha tt8ret tt1sc tt8ser -tt5s6z 1tuc tuch5a 1tu1e 6tuh t5uhr tu1i tu6it 1tumh 6t5umr 1tums -8tumt 6tund 6tunf 2t1unt tu5ra tu6rau tu6re. tu4r3er 2t1v 2t1w 1ty1 -ty6a ty8la 8tym 6ty6o 2tz tz5al tz1an tz1ar t8zec tzeh6 tzehn5 t6z5ei. -t6zor t4z3um \n{t6z"au} \n{5t"ag} \n{6t"ah} \n{t5"alt} \n{t8"an} -\n{t"are8} \n{8t"a8st} \n{6t"au\3} \n{\c{6t"au\9}} \n{t5"offen} -\n{8t"o8k} \n{1t"on} \n{4t"ub} \n{t6"u5ber.} \n{5t"uch} \n{1t"ur.} -u3al. u5alb u5alf u3alh u5alk u3alp u3an. ua5na u3and u5ans u5ar. -ua6th u1au ua1y u2bab ubi5er. u6b5rit ubs2k \n{u5b"o} \n{u8b"ub} 2uc -u1che u6ch5ec u1chi uch1l uch3m uch5n uch1r uch5to ucht5re u1chu uch1w -uck1a uck5in u1d ud4a u1ei u6ela uene8 u6ep u1er uer1a ue8rerl uer5o -u8esc u2est u8ev u1fa u2f1ei u4f3ent u8ferh uf1fr uf1l uf1ra uf1re -\n{uf1r"a} \n{uf1r"u} uf1s2p uf1st uft1s u8gabt u8gad u6gap ugeb8 u8gn -ugo3s4 u1ha u1he u1hi uh1le u1ho uh1re u1hu uh1w \n{u1h"a} \n{u1h"o} -6ui ui5en u1ig u3ins uin8tes u5isch. u1j 6uk u1ke u1ki u1kl u8klu -u1k6n u5ky u1la uld8se u1le ul8lac ul6lau ul6le6l ul6lo ulni8 u1lo -ulo6i ult6a ult8e u1lu ul2vr \n{u1l"a} \n{u1l"o} 3umfan 5umlau umo8f -um8pho u1mu umu8s \n{u5m"o} u1n1a un2al un6at unau2 6und. 5undein -un4d3um 3undzw \n{und"u8} \n{un8d"ub} une2b un1ec une2h un3eis 3unfal -\n{1unf"a} 5ungea \n{3ungl"u} ung2s1 \n{un8g"a} 1u2nif un4it un8kro -unk5s u1no unpa2 uns2p unvol4 unvoll5 u5os. u1pa u1pi u1p2l u1pr -up4s3t up2t1a u1q u1ra ur5abs ura8d ur5ah u6rak ur3alt u6rana u6r5ans -u8rap ur5a6ri u8ratt u1re ur3eig ur8gri u1ri ur5ins 3urlau urmen6 -ur8nan u1ro 3ursac ur8sau ur8sei ur4sk 3urtei u1ru uru5i6 uru6r u1ry -ur2za \n{ur6z"a} \n{ur5"a6m} \n{u5r"o} \n{u1r"u} \n{ur"uck3} u1sa -usa4gi u2s1ar u2s1au u8schec usch5wi u2s1ei use8kel u8sl u4st3a4b -us3tau u3s4ter u2s1uf u8surn ut1ac u1tal uta8m u1tan ut1ar u1tas ut1au -u1te u8teic u4tent u8terf u6terin u4t3hei ut5ho ut1hu u1ti utine5 -uti6q u1to uto5c u1tr ut1sa ut1s6p ut6stro u1tu utz5w u1u u1v uve5n -\n{uve3r4"a} u1w u1xe u5ya uy5e6 u1yi u2z1eh u8zerh \n{u5"o} u\3e6n -\c{u\9e6n} u\3en5e \c{u\9en5e} 8vanb 6vang 6varb var8d va6t5a va8tei -va2t1r 2v1b 6v5c 6vd 1ve 6ve5g6 ver1 ver5b verb8l ve2re2 verg8 ve2ru8 -ve1s ve2s3p ve3xe 2v1f 2v1g 6v5h vi6el vie6w5 vi1g4 vi8leh vil6le. -8vint vi1ru vi1tr 2v1k 2v1l 2v1m 4v5n 8vo8f voi6le vol8lend vol8li -v2or1 vo2re vo8rin vo2ro 2v1p 8vra v6re 2v1s 2v1t 2v1v 4v3w 2v1z -waffe8 wa6g5n 1wah wah8n wa5la wal8din wal6ta wan4dr 5ware wa8ru -war4za 1was w5c w1d 5wech we6fl 1weg we8geng weg5h weg3l we2g1r -weh6r5er 5weise weit3r wel2t welt3r we6rat 8werc 5werdu wer4fl 5werk. -wer4ka wer8ku wer4ta wer8term we2sp we8stend we6steu we8str -\n{we8st"o} wet8ta wich6s5t 1wid wi2dr wiede4 wieder5 wik6 wim6ma -win4d3r 5wirt wisch5l 1wj 6wk 2w1l 8w1n wo1c woche6 wol6f wor6t5r 6ws2 -w1sk 6w5t 5wunde. wun6gr wu1sc wu2t1 6w5w wy5a \n{w"arme5} \n{w"a1sc} -1xag x1ak x3a4men 8xamt x1an 8x1b x1c 1xe. x3e4g 1xen xe1ro x1erz -1xes 8xf x1g 8x1h 1xi 8xid xi8so 4xiste x1k 6x1l x1m 8xn 1xo 8x5o6d -8x3p2 x1r x1s6 8x1t x6tak x8terf x2t1h 1xu xu1e x5ul 6x3w x1z 5ya. -y5an. y5ank y1b y1c y6cha y4chia y1d yen6n y5ern y1g y5h y5in y1j -y1k2 y1lak yl1al yla8m y5lax y1le y1lo y5lu y8mn ym1p2 y3mu y1na yno2d -yn1t y1on. y1o4p y5ou ypo1 y1pr y8ps y1r yri3e yr1r2 y1s ys5iat ys8ty -y1t y3w y1z \n{y"a8m} z5a6b zab5l 8za6d 1zah za5is 4z3ak 6z1am 5zange. -8zanl 2z1ara 6z5as z5auf 3zaun 2z1b 6z1c 6z1d 1ze ze4dik 4z3eff 8zein -zei4ta zei8ters ze6la ze8lec zel8th 4zemp 6z5engel zen8zin \n{8zerg"a} -zer8i ze1ro zers8 zerta8 zer8tab zer8tag 8zerz ze8ste zeu6gr 2z1ex -2z1f8 z1g 4z1h 1zi zi1en zi5es. 4z3imp zi1na 6z5inf 6z5inni zin6s5er -8zinsuf zist5r zi5th zi1tr 6z1j 2z1k 2z1l 2z1m 6z1n 1zo zo6gl 4z3oh -zo1on zor6na8 4z1p z5q 6z1r 2z1s8 2z1t z4t3end z4t3hei z8thi 1zu zu3al -zu1b4 zu1f2 6z5uhr zun2a 8zunem zunf8 8zungl zu1o zup8fi zu1s8 zu1z -2z1v zw8 z1wal 5zweck zwei3s z1wel z1wer z6werg 8z5wes 1zwi zwi1s -6z1wo 1zy 2z1z zz8a zzi1s \n{1z"a} \n{1z"o} \n{6z"ol.} \n{z"o1le} -\n{1z"u} \n{2z1"u2b} \n{"a1a6} \n{"ab1l} \n{"a1che} \n{"a3chi} -\n{"ach8sc} \n{"ach8sp} \n{"a5chu} \n{"ack5a} \n{"ad1a} \n{"ad5era} -\n{"a6d5ia} \n{"a1e} \n{"a5fa} \n{"af1l} \n{"aft6s} \n{"ag1h} -\n{"ag3le} \n{"a6g5nan} \n{"ag5str} \n{"a1he} \n{"a1hi} \n{"ah1le} -\n{"ah5ne} \n{1"ahnl} \n{"ah1re} \n{"ah5ri} \n{"ah1ru} \n{"a1hu} -\n{"ah1w} \n{6"ai} \n{"a1isc} \n{"a6ische} \n{"a5ism} \n{"a5j} -\n{"a1k} \n{"al1c} \n{"a1le} \n{"a8lei} \n{"al6schl} \n{"ami1e} -\n{"am8n} \n{"am8s} \n{"a5na} \n{5"anderu} \n{"ane5i8} \n{"ang3l} -\n{"ank5l} \n{"a1no} \n{"an6s5c} \n{"a1pa} \n{"ap6s5c} \n{3"aq} -\n{"ar1c} \n{"a1re} \n{"are8m} \n{5"argern} \n{"ar6gl} \n{"a1ri} -\n{3"armel} \n{"a1ro} \n{"art6s5} \n{"a1ru} \n{3"arztl} \n{"a5r"o} -\n{"a6s5chen} \n{"asen8s} \n{"as1th} \n{"ata8b} \n{"a1te} \n{"ateri4} -\n{"ater5it} \n{"a6thy} \n{"a1ti} \n{3"atk} \n{"a1to} \n{"at8schl} -\n{"ats1p} \n{"a5tu} \n{"aub1l} \n{"au1e} \n{1"aug} \n{"au8ga} -\n{"au5i} \n{"a1um.} \n{"a1us.} \n{1"au\3} \n{\c{1"au\9}} \n{"a1z} -\n{"o1b} \n{"o1che} \n{"o5chi} \n{"och8stei} \n{"och8str} \n{"ocht6} -\n{5"o6dem} \n{5"offn} \n{"o1he} \n{"oh1l8} \n{"oh1re} \n{"o1hu} -\n{"o1is} \n{"o1ke} \n{1"o2ko} \n{1"ol.} \n{"ol6k5l} \n{"ol8pl} -\n{"o1mu} \n{"o5na} \n{"onig6s3} \n{"o1no} \n{"o5o6t} \n{"opf3l} -\n{"op6s5c} \n{"o1re} \n{"or8gli} \n{"o1ri} \n{"or8tr} \n{"o1ru} -\n{5"osterr} \n{"o1te} \n{"o5th} \n{"o1ti} \n{"o1tu} \n{"o1v} \n{"o1w} -\n{"owe8} \n{"o2z} \n{"ub6e2} \n{3"u4ber1} \n{"ub1l} \n{"ub1r} -\n{5"u2bu} \n{"u1che} \n{"u1chi} \n{"u8ch3l} \n{"uch6s5c} \n{"u8ck} -\n{"uck1a} \n{"uck5ers} \n{"ud1a2} \n{"u6deu} \n{"udi8t} \n{"u2d1o4} -\n{"ud5s6} \n{"uge4l5a} \n{"ug1l} \n{"uh5a} \n{"u1he} \n{"u8heh} -\n{"u6h5erk} \n{"uh1le} \n{"uh1re} \n{"uh1ru} \n{"u1hu} \n{"uh1w} -\n{"u3k} \n{"u1le} \n{"ul4l5a} \n{"ul8lo} \n{"ul4ps} \n{"ul6s5c} -\n{"u1lu} \n{"un8da} \n{"un8fei} \n{"unk5l} \n{"un8za} \n{"un6zw} -\n{"u5pi} \n{"u1re} \n{"u8rei} \n{"ur8fl} \n{"ur8fr} \n{"ur8geng} -\n{"u1ri} \n{"u1ro} \n{"ur8sta} \n{"ur8ster} \n{"u1ru} \n{"use8n} -\n{"u8sta} \n{"u8stes} \n{"u6s5tete} \n{"u3ta} \n{"u1te} \n{"u1ti} -\n{"ut8tr} \n{"u1tu} \n{"ut8zei} \n{"u1v} \31a8 \c{\91a8} 5\3a. -\c{5\9a.} \38as \c{\98as} \31b8 \c{\91b8} \31c \c{\91c} \31d \c{\91d} -1\3e \c{1\9e} \35ec \c{\95ec} 8\3e8g \c{8\9e8g} 8\3e8h \c{8\9e8h} -2\31ei \c{2\91ei} 8\3em \c{8\9em} \31f8 \c{\91f8} \31g \c{\91g} \31h -\c{\91h} 1\3i \c{1\9i} \31k \c{\91k} \31l \c{\91l} \31m \c{\91m} -\3mana8 \c{\9mana8} \31n \c{\91n} \31o \c{\91o} \31p8 \c{\91p8} \35q -\c{\95q} \31r \c{\91r} \31s2 \c{\91s2} \3st8 \c{\9st8} \31ta \c{\91ta} -\31te \c{\91te} \3t3hei \c{\9t3hei} \31ti \c{\91ti} \35to \c{\95to} -\31tr \c{\91tr} 1\3u8 \c{1\9u8} 6\35um \c{6\95um} \31v \c{\91v} \31w -\c{\91w} \31z \c{\91z} -}% -\endgroup -\relax\endinput -% -% ----------------------------------------------------------------- -% -% =============== Additional Documentation =============== -% -% -% Older Versions of German Hyphenation Patterns: -% ---------------------------------------------- -% -% All older versions of `ghyphen.tex' distributed as -% -% ghyphen.tex/germhyph.tex as of 1986/11/01 -% ghyphen.min/ghyphen.max as of 1988/10/10 -% ghyphen3.tex as of 1990/09/27 & 1991/02/13 -% ghyph31.tex as of 1994/02/13 -% -% are out of date and it is recommended to replace them -% with the new version `dehypht.tex' as of 1999/03/03. -% -% If you are using `ghyphen.min' (a minor version of `ghyphen') -% because of limited trie memory space, try this version and if -% the space is exceeded get a newer TeX implementation with -% larger or configurable trie memory sizes. -% -% -% -% Trie Memory Requirements/Space for Hyphenation Patterns: -% -------------------------------------------------------- -% -% To load this set of german hyphenation patterns the parameters -% of TeX has to have at least these values: -% -% TeX 3.x: -% IniTeX: trie_size >= 9733 trie_op_size >= 207 -% VirTeX: trie_size >= 8375 trie_op_size >= 207 -% -% TeX 2.x: -% IniTeX: trie_size >= 8675 trie_op_size >= 198 -% VirTeX: trie_size >= 7560 trie_op_size >= 198 -% -% If you want to load more than one set of hyphenation patterns -% (in TeX 3.x), the parameters have to be set to a value larger -% than or equal to the sum of all required values for each set. -% -% -% Setting Trie Memory Parameters: -% ------------------------------- -% -% Some implementations allow the user to change the default value -% of a set of the internal TeX parameters including the trie memory -% size parameter specifying the used memory for the hyphenation -% patterns. -% -% Web2c 7.x (Source), teTeX 0.9 (Unix, Amiga), fpTeX (Win32) -% and newer: -% The used memory size of the true is usually set high enough. -% If needed set the size of the trie using the keyword `trie_size' -% in the configuration file `texmf/web2c/texmf.cnf'. For details -% see the included documentation. -% -% emTeX (OS/2, MS-DOS, Windows 3.x/9x/NT): -% You can set the used memory size of the trie using the -% `-mt' option on the command line or in the -% TEXOPTIONS environment variable. -% -% PasTeX (Amiga): -% The values for the parameters can be set using the keywords -% `triesize', `itriesize' and `trieopsize' in the configuration -% file. -% -% others (binaries only): -% See the documentation of the implementation if it is possible -% and how to change these values without recompilation. -% -% others (with sources) -% If the trie memory is too small, you have to recompile TeX -% using larger values for `trie_size' and `trie_op_size'. -% Modify the change file `tex.ch' and recompile TeX. -% For details see the documentation included in the sources. -% -% -% -% Necessary Settings in TeX macro files: -% -------------------------------------- -% -% \lefthyphenmin, \righthyphenmin: -% You can set both parameters to 2. -% -% \lccode : -% To get correct hyphenation points within words containing -% umlauts or \ss, it's necessary to assign values > 0 to the -% appropriate \lccode positions. -% -% These changes are _not_ done when reading this file and have to -% be included in the language switching mechanism as is done in, -% for example, `german.sty' (\lccode change for ^^Y = \ss in OT1, -% \left-/\righthyphenmin settings). -% -% -%% \CharacterTable -%% {Upper-case \A\B\C\D\E\F\G\H\I\J\K\L\M\N\O\P\Q\R\S\T\U\V\W\X\Y\Z -%% Lower-case \a\b\c\d\e\f\g\h\i\j\k\l\m\n\o\p\q\r\s\t\u\v\w\x\y\z -%% Digits \0\1\2\3\4\5\6\7\8\9 -%% Exclamation \! Double quote \" Hash (number) \# -%% Dollar \$ Percent \% Ampersand \& -%% Acute accent \' Left paren \( Right paren \) -%% Asterisk \* Plus \+ Comma \, -%% Minus \- Point \. Solidus \/ -%% Colon \: Semicolon \; Less than \< -%% Equals \= Greater than \> Question mark \? -%% Commercial at \@ Left bracket \[ Backslash \\ -%% Right bracket \] Circumflex \^ Underscore \_ -%% Grave accent \` Left brace \{ Vertical bar \| -%% Right brace \} Tilde \~} -%% -\endinput -%% -%% End of file `dehypht.tex'. DELETED modules/textutil/eshyph_vo.tex Index: modules/textutil/eshyph_vo.tex ================================================================== --- modules/textutil/eshyph_vo.tex +++ /dev/null @@ -1,1104 +0,0 @@ -.\'a2 -.\'aa2 -.\'ae2 -.\'ai2 -.\'ao2 -.\'au2 -.\'e2 -.\'ea2 -.\'ee2 -.\'ei2 -.\'eo2 -.\'eu2 -.\'i2 -.\'ia2 -.\'ie2 -.\'ii2 -.\'io2 -.\'iu2 -.\'o2 -.\'oa2 -.\'oe2 -.\'oi2 -.\'oo2 -.\'ou2 -.\'u2 -.\'ua2 -.\'ue2 -.\'ui2 -.\'uo2 -.\'uu2 -.a2 -.a\'a2 -.a\'e2 -.a\'i2 -.a\'o2 -.a\'u2 -.aa2 -.ae2 -.ai2 -.ao2 -.au2 -.e2 -.e\'a2 -.e\'e2 -.e\'i2 -.e\'o2 -.e\'u2 -.ea2 -.ee2 -.ei2 -.eo2 -.eu2 -.i2 -.i\'a2 -.i\'e2 -.i\'i2 -.i\'o2 -.i\'u2 -.ia2 -.ie2 -.ii2 -.io2 -.iu2 -.o2 -.o\'a2 -.o\'e2 -.o\'i2 -.o\'o2 -.o\'u2 -.oa2 -.oe2 -.oi2 -.oo2 -.ou2 -.u2 -.u\'a2 -.u\'e2 -.u\'i2 -.u\'o2 -.u\'u2 -.ua2 -.ue2 -.ui2 -.uo2 -.uu2 -2\'a. -2\'aa. -2\'ae. -2\'ai. -2\'ao. -2\'au. -2\'e. -2\'ea. -2\'ee. -2\'ei. -2\'eo. -2\'eu. -2\'i. -2\'ia. -2\'ie. -2\'ii. -2\'io. -2\'iu. -2\'o. -2\'oa. -2\'oe. -2\'oi. -2\'oo. -2\'ou. -2\'u. -2\'ua. -2\'ue. -2\'ui. -2\'uo. -2\'uu. -2\~n1\~n -2\~n1b -2\~n1c -2\~n1d -2\~n1f -2\~n1g -2\~n1h -2\~n1j -2\~n1k -2\~n1m -2\~n1n -2\~n1p -2\~n1q -2\~n1s -2\~n1t -2\~n1v -2\~n1w -2\~n1x -2\~n1y -2\~n1z -2a. -2a\'a. -2a\'e. -2a\'i. -2a\'o. -2a\'u. -2aa. -2ae. -2ai. -2ao. -2au. -2b1\~n -2b1b -2b1c -2b1d -2b1f -2b1g -2b1h -2b1j -2b1k -2b1m -2b1n -2b1p -2b1q -2b1s -2b1t -2b1v -2b1w -2b1x -2b1y -2b1z -2c1\~n -2c1b -2c1c -2c1d -2c1f -2c1g -2c1j -2c1k -2c1m -2c1n -2c1p -2c1q -2c1s -2c1t -2c1v -2c1w -2c1x -2c1y -2c1z -2d1\~n -2d1b -2d1c -2d1d -2d1f -2d1g -2d1h -2d1j -2d1k -2d1m -2d1n -2d1p -2d1q -2d1s -2d1t -2d1v -2d1w -2d1x -2d1y -2d1z -2e. -2e\'a. -2e\'e. -2e\'i. -2e\'o. -2e\'u. -2ea. -2ee. -2ei. -2eo. -2eu. -2f1\~n -2f1b -2f1c -2f1d -2f1f -2f1g -2f1h -2f1j -2f1k -2f1m -2f1n -2f1p -2f1q -2f1s -2f1t -2f1v -2f1w -2f1x -2f1y -2f1z -2g1\~n -2g1b -2g1c -2g1d -2g1f -2g1g -2g1h -2g1j -2g1k -2g1m -2g1n -2g1p -2g1q -2g1s -2g1t -2g1v -2g1w -2g1x -2g1y -2g1z -2h1\~n -2h1b -2h1c -2h1d -2h1f -2h1g -2h1h -2h1j -2h1k -2h1m -2h1n -2h1p -2h1q -2h1s -2h1t -2h1v -2h1w -2h1x -2h1y -2h1z -2i. -2i\'a. -2i\'e. -2i\'i. -2i\'o. -2i\'u. -2ia. -2ie. -2ii. -2io. -2iu. -2j1\~n -2j1b -2j1c -2j1d -2j1f -2j1g -2j1h -2j1j -2j1k -2j1m -2j1n -2j1p -2j1q -2j1s -2j1t -2j1v -2j1w -2j1x -2j1y -2j1z -2k1\~n -2k1b -2k1c -2k1d -2k1f -2k1g -2k1h -2k1j -2k1k -2k1m -2k1n -2k1p -2k1q -2k1s -2k1t -2k1v -2k1w -2k1x -2k1y -2k1z -2l1\~n -2l1b -2l1c -2l1d -2l1f -2l1g -2l1h -2l1j -2l1k -2l1m -2l1n -2l1p -2l1q -2l1s -2l1t -2l1v -2l1w -2l1x -2l1y -2l1z -2m1\~n -2m1b -2m1c -2m1d -2m1f -2m1g -2m1h -2m1j -2m1k -2m1l -2m1m -2m1n -2m1p -2m1q -2m1r -2m1s -2m1t -2m1v -2m1w -2m1x -2m1y -2m1z -2n1\~n -2n1b -2n1c -2n1d -2n1f -2n1g -2n1h -2n1j -2n1k -2n1l -2n1m -2n1n -2n1p -2n1q -2n1r -2n1s -2n1t -2n1v -2n1w -2n1x -2n1y -2n1z -2o. -2o\'a. -2o\'e. -2o\'i. -2o\'o. -2o\'u. -2oa. -2oe. -2oi. -2oo. -2ou. -2p1\~n -2p1b -2p1c -2p1d -2p1f -2p1g -2p1h -2p1j -2p1k -2p1m -2p1n -2p1p -2p1q -2p1s -2p1t -2p1v -2p1w -2p1x -2p1y -2p1z -2q1\~n -2q1b -2q1c -2q1d -2q1f -2q1g -2q1h -2q1j -2q1k -2q1m -2q1n -2q1p -2q1q -2q1s -2q1t -2q1v -2q1w -2q1x -2q1y -2q1z -2r1\~n -2r1b -2r1c -2r1d -2r1f -2r1g -2r1h -2r1j -2r1k -2r1m -2r1n -2r1p -2r1q -2r1s -2r1t -2r1v -2r1w -2r1x -2r1y -2r1z -2s1\~n -2s1b -2s1c -2s1d -2s1f -2s1g -2s1h -2s1j -2s1k -2s1m -2s1n -2s1p -2s1q -2s1s -2s1t -2s1v -2s1w -2s1x -2s1y -2s1z -2t1\~n -2t1b -2t1c -2t1d -2t1f -2t1g -2t1h -2t1j -2t1k -2t1m -2t1n -2t1p -2t1q -2t1s -2t1t -2t1v -2t1w -2t1x -2t1y -2t1z -2u. -2u\'a. -2u\'e. -2u\'i. -2u\'o. -2u\'u. -2ua. -2ue. -2ui. -2uo. -2uu. -2v1\~n -2v1b -2v1c -2v1d -2v1f -2v1g -2v1h -2v1j -2v1k -2v1m -2v1n -2v1p -2v1q -2v1s -2v1t -2v1v -2v1w -2v1x -2v1y -2v1z -2w1\~n -2w1b -2w1c -2w1d -2w1f -2w1g -2w1h -2w1j -2w1k -2w1m -2w1n -2w1p -2w1q -2w1s -2w1t -2w1v -2w1w -2w1x -2w1y -2w1z -2x1\~n -2x1b -2x1c -2x1d -2x1f -2x1g -2x1h -2x1j -2x1k -2x1m -2x1n -2x1p -2x1q -2x1s -2x1t -2x1v -2x1w -2x1x -2x1y -2x1z -2y1\~n -2y1b -2y1c -2y1d -2y1f -2y1g -2y1h -2y1j -2y1k -2y1m -2y1n -2y1p -2y1q -2y1s -2y1t -2y1v -2y1w -2y1x -2y1y -2y1z -2z1\~n -2z1b -2z1c -2z1d -2z1f -2z1g -2z1h -2z1j -2z1k -2z1m -2z1n -2z1p -2z1q -2z1s -2z1t -2z1v -2z1w -2z1x -2z1y -2z1z -\'a1\'i -\'a1\'u -\'a1\~n -\'a1a -\'a1b -\'a1c -\'a1d -\'a1e -\'a1f -\'a1g -\'a1h -\'a1j -\'a1k -\'a1l -\'a1m -\'a1n -\'a1o -\'a1p -\'a1q -\'a1r -\'a1s -\'a1t -\'a1v -\'a1w -\'a1x -\'a1y -\'a1z -\'a2\~n. -\'a2b. -\'a2c. -\'a2d. -\'a2f. -\'a2g. -\'a2h. -\'a2j. -\'a2k. -\'a2l. -\'a2m. -\'a2n. -\'a2p. -\'a2q. -\'a2r. -\'a2s. -\'a2t. -\'a2v. -\'a2w. -\'a2x. -\'a2y. -\'a2z. -\'e1\'i -\'e1\'u -\'e1\~n -\'e1a -\'e1b -\'e1c -\'e1d -\'e1e -\'e1f -\'e1g -\'e1h -\'e1j -\'e1k -\'e1l -\'e1m -\'e1n -\'e1o -\'e1p -\'e1q -\'e1r -\'e1s -\'e1t -\'e1v -\'e1w -\'e1x -\'e1y -\'e1z -\'e2\~n. -\'e2b. -\'e2c. -\'e2d. -\'e2f. -\'e2g. -\'e2h. -\'e2j. -\'e2k. -\'e2l. -\'e2m. -\'e2n. -\'e2p. -\'e2q. -\'e2r. -\'e2s. -\'e2t. -\'e2v. -\'e2w. -\'e2x. -\'e2y. -\'e2z. -\'i1\'a -\'i1\'e -\'i1\'o -\'i1\~n -\'i1a -\'i1b -\'i1c -\'i1d -\'i1e -\'i1f -\'i1g -\'i1h -\'i1j -\'i1k -\'i1l -\'i1m -\'i1n -\'i1o -\'i1p -\'i1q -\'i1r -\'i1s -\'i1t -\'i1v -\'i1w -\'i1x -\'i1y -\'i1z -\'i2\~n. -\'i2b. -\'i2c. -\'i2d. -\'i2f. -\'i2g. -\'i2h. -\'i2j. -\'i2k. -\'i2l. -\'i2m. -\'i2n. -\'i2p. -\'i2q. -\'i2r. -\'i2s. -\'i2t. -\'i2v. -\'i2w. -\'i2x. -\'i2y. -\'i2z. -\'o1\'i -\'o1\'u -\'o1\~n -\'o1a -\'o1b -\'o1c -\'o1d -\'o1e -\'o1f -\'o1g -\'o1h -\'o1j -\'o1k -\'o1l -\'o1m -\'o1n -\'o1o -\'o1p -\'o1q -\'o1r -\'o1s -\'o1t -\'o1v -\'o1w -\'o1x -\'o1y -\'o1z -\'o2\~n. -\'o2b. -\'o2c. -\'o2d. -\'o2f. -\'o2g. -\'o2h. -\'o2j. -\'o2k. -\'o2l. -\'o2m. -\'o2n. -\'o2p. -\'o2q. -\'o2r. -\'o2s. -\'o2t. -\'o2v. -\'o2w. -\'o2x. -\'o2y. -\'o2z. -\'u1\'a -\'u1\'e -\'u1\'o -\'u1\~n -\'u1a -\'u1b -\'u1c -\'u1d -\'u1e -\'u1f -\'u1g -\'u1h -\'u1j -\'u1k -\'u1l -\'u1m -\'u1n -\'u1o -\'u1p -\'u1q -\'u1r -\'u1s -\'u1t -\'u1v -\'u1w -\'u1x -\'u1y -\'u1z -\'u2\~n. -\'u2b. -\'u2c. -\'u2d. -\'u2f. -\'u2g. -\'u2h. -\'u2j. -\'u2k. -\'u2l. -\'u2m. -\'u2n. -\'u2p. -\'u2q. -\'u2r. -\'u2s. -\'u2t. -\'u2v. -\'u2w. -\'u2x. -\'u2y. -\'u2z. -a1\'a -a1\'e -a1\'i -a1\'o -a1\'u -a1\~n -a1a -a1b -a1c -a1d -a1e -a1f -a1g -a1h -a1j -a1k -a1l -a1m -a1n -a1o -a1p -a1q -a1r -a1s -a1t -a1v -a1w -a1x -a1y -a1z -a2\~n. -a2b. -a2c. -a2d. -a2f. -a2g. -a2h. -a2j. -a2k. -a2l. -a2m. -a2n. -a2p. -a2q. -a2r. -a2s. -a2t. -a2v. -a2w. -a2x. -a2y. -a2z. -e1\'a -e1\'e -e1\'i -e1\'o -e1\'u -e1\~n -e1a -e1b -e1c -e1d -e1e -e1f -e1g -e1h -e1j -e1k -e1l -e1m -e1n -e1o -e1p -e1q -e1r -e1s -e1t -e1v -e1w -e1x -e1y -e1z -e2\~n. -e2b. -e2c. -e2d. -e2f. -e2g. -e2h. -e2j. -e2k. -e2l. -e2m. -e2n. -e2p. -e2q. -e2r. -e2s. -e2t. -e2v. -e2w. -e2x. -e2y. -e2z. -i1\~n -i1b -i1c -i1d -i1f -i1g -i1h -i1j -i1k -i1l -i1m -i1n -i1p -i1q -i1r -i1s -i1t -i1v -i1w -i1x -i1y -i1z -i2\~n. -i2b. -i2c. -i2d. -i2f. -i2g. -i2h. -i2j. -i2k. -i2l. -i2m. -i2n. -i2p. -i2q. -i2r. -i2s. -i2t. -i2v. -i2w. -i2x. -i2y. -i2z. -o1\'a -o1\'e -o1\'i -o1\'o -o1\'u -o1\~n -o1a -o1b -o1c -o1d -o1e -o1f -o1g -o1h -o1j -o1k -o1l -o1m -o1n -o1o -o1p -o1q -o1r -o1s -o1t -o1v -o1w -o1x -o1y -o1z -o2\~n. -o2b. -o2c. -o2d. -o2f. -o2g. -o2h. -o2j. -o2k. -o2l. -o2m. -o2n. -o2p. -o2q. -o2r. -o2s. -o2t. -o2v. -o2w. -o2x. -o2y. -o2z. -u1\~n -u1b -u1c -u1d -u1f -u1g -u1h -u1j -u1k -u1l -u1m -u1n -u1p -u1q -u1r -u1s -u1t -u1v -u1w -u1x -u1y -u1z -u2\~n. -u2b. -u2c. -u2d. -u2f. -u2g. -u2h. -u2j. -u2k. -u2l. -u2m. -u2n. -u2p. -u2q. -u2r. -u2s. -u2t. -u2v. -u2w. -u2x. -u2y. -u2z. DELETED modules/textutil/expander.ehtml Index: modules/textutil/expander.ehtml ================================================================== --- modules/textutil/expander.ehtml +++ /dev/null @@ -1,362 +0,0 @@ -[pageheader "expander"] - -[section SYNOPSIS] - -
-    package require expander 1.0
-

- -[section DESCRIPTION] - -The Tcl "subst" command is often used to support a kind of template -processing. Given a string with embedded variables or function calls, -"subst" will interpolate the variable and function values, returning -the new string:

- -[listing] -[tclsh {set greeting "Howdy"}] -[tclsh {proc place {} {return "World"}}] -[tclsh {subst {$greeting, [place]!}}] -% -[/listing] - -By defining a suitable set of Tcl commands, "subst" can be used to -implement a markup language similar to HTML.

- -The "subst" command is efficient, but it has three drawbacks for this -kind of template processing:

- -

    -
  • There's no way to identify and process the plain text between two - embedded Tcl commands; that makes it difficult to handle plain - text in a context-sensitive way.

    - -

  • Embedded commands are necessarily bracketed by "[lb]" and - "[rb]"; it's convenient to be able to choose different brackets - in special cases. Someone producing web pages that include a - large quantity of Tcl code examples might easily prefer to use - "<<" and ">>" as the embedded code delimiters instead.

    - -

  • There's no easy way to handle incremental input, as one might - wish to do when reading data from a socket.

    -

- -At present, expander solves the first two problems; eventually it will -solve the third problem as well.

- -To begin, create an expander object:

- -[listing] -[tclsh {package require textutil::expander}] -[tclsh {::textutil::expander myexp}] -% -[/listing] - -The created "::myexp" object can be used to expand text strings containing -embedded Tcl commands. By default, embedded commands are delimited by -square brackets. Note that expander doesn't attempt to interpolate -variables, since variables can be referenced by embedded commands:

- -[listing] -[tclsh {set greeting "Howdy"}] -[tclsh {proc place {} {return "World"}}] -[tclsh {::myexp expand {[set greeting], [place]!}}] -% -[/listing] - -[subsection "Embedding Macros"] - -An expander macro is simply a Tcl script embedded within a text -string. Expander evaluates the script in the global context, and -replaces it with its result string. For example, - -[listing] -[tclsh {set greetings {Howdy Hi "What's up"}}] -[tclsh {::myexp expand {There are many ways to say "Hello, World!": -[set result {} -foreach greeting $greetings { - append result "$greeting, World!\n" -} -set result] -And that's just a small sample!}}] -% -[/listing] - -[subsection "Writing Macro Commands"] - -More typically, "macro commands" are used to create a markup -language. A macro command is just a Tcl command that returns an -output string. For example, expand can be used to implement a generic -document markup language that can be retargeted to HTML or any other -output format: - -[listing] -[tclsh {proc bold {} {return ""}}] -[tclsh {proc /bold {} {return ""}}] -[tclsh {::myexp expand {Some of this text is in [bold]boldface[/bold]}}] -% -[/listing] - -The above definition of "bold" and "/bold" returns HTML, but such -commands can be as complicated as needed; they could, for example, -decide what to return based on the desired output format.

- -[subsection "Changing the Expansion Brackets"] - -By default, embedded macros are enclosed in square brackets, -"[lb]" and "[rb]". If square brackets need to be included in the -output, the input can contain the [command lb] and [command rb] -commands. Alternatively, or if square brackets are objectionable for -some other reason, the macro expansion brackets can be changed to any -pair of non-empty strings.

- -The [command setbrackets] command changes the brackets permanently. -For example, you can write pseudo-html by change them to "<" and ">":

- -[listing] -[tclsh {::myexp setbrackets < >}] -[tclsh {::myexp expand {This is boldface}}] -[/listing] - -Alternatively, you can change the expansion brackets temporarily by -passing the desired brackets to the [command expand] command:

- -[listing] -[tclsh {::myexp setbrackets "\[" "\]"}] -[tclsh {::myexp expand {This is boldface} {< >}}] -% -[/listing] - -[subsection "Customized Macro Expansion"] - -By default, macros are evaluated using the Tcl "uplevel #0" command, so -that the embedded code executes in the global context. The -application can provide a different evaluation command using -[command evalcmd]; this allows the application to use a safe -interpreter, for example, or even to evaluated something other than -Tcl code. There is one caveat: to be recognized as valid, a macro -must return 1 when passed to Tcl's "info complete" command.

- -For example, the following code "evaluates" each macro by returning -the macro text itself.

- -[listing] -proc identity {macro} {return $macro} -::myexp evalcmd identity -[/listing] - -[subsection "Using the Context Stack"] - - Often it's desirable to define a pair of macros -which operate in some way on the plain text between them. Consider a -set of macros for adding footnotes to a web page: one could -have implement something like this:

- -[listing] - Dr. Pangloss, however, thinks that this is the best of all - possible worlds.[lb]footnote "See Candide, by Voltaire"[rb] -[/listing] - -The footnote macro would, presumably, assign a number to -this footnote and save the text to be formatted later on. However, -this solution is ugly if the footnote text is long or should contain -additional markup. Consider the following instead:

- -[listing] - Dr. Pangloss, however, thinks that this is the best of all - possible worlds.[lb]footnote[rb]See [lb]bookTitle "Candide"[rb], by - [lb]authorsName "Voltaire"[rb], for more information.[lb]/footnote[rb] -[/listing] - -Here the footnote text is contained between footnote and -/footnote macros, continues onto a second line, and -contains several macros of its own. This is both clearer and more -flexible; however, with the features presented so far there's no easy -way to do it. That's the purpose of the context stack.

- -All macro expansion takes place in a particular context. -Here, the footnote macro pushes a new -context onto the context stack. Then, all expanded text gets placed -in that new context. /footnote retrieves it by popping -the context. Here's a skeleton implementation of these two macros:

- -[listing] - proc footnote {} { - ::myexp cpush footnote - } - - proc /footnote {} { - set footnoteText [lb]::myexp cpop footnote[rb] - - # Save the footnote text, and return an appropriate footnote - # number and link. - } -[/listing] - -The [command cpush] command pushes a new context onto the stack; the -argument is the context's name. It can be any string, but would -typically be the name of the macro itself. Then, [command cpop] -verifies that the current context has the expected name, pops it off -of the stack, and returns the accumulated text.

- -Expand provides several other tools related to the context stack. -Suppose the first macro in a context pair takes arguments or computes -values which the second macro in the pair needs. After calling -[command cpush], the first macro can define one or more context -variables; the second macro can retrieve their values any time before -calling [command cpop]. For example, suppose the document must -specify the footnote number explicitly:

- -[listing] - proc footnote {footnoteNumber} { - ::myexp cpush footnote - ::myexp csave num $footnoteNumber - # Return an appropriate link - } - - proc /footnote {} { - set footnoteNumber [lb]::myexp cget num[rb] - set footnoteText [lb]::myexp cpop footnote[rb] - - # Save the footnote text and its footnoteNumber for future - # output. - } -[/listing] - -At times, it might be desirable to define macros that are valid only -within a particular context pair; such macros should verify that they -are only called within the correct context using either -[command cis] or [command cname].

- -[section "TCL COMMANDS"] - -The package defines the following Tcl commands:

- -

-
[commanddef expander name] -
This command creates a new expander object; - name is the name of the object, and becomes a new - command. By default, if the name isn't fully qualified, i.e., - if it doesn't completely specify the namespace in which to - create the new command, the command is created in the caller's - current namespace.

-

- -[section "EXPANDER OBJECT COMMANDS"] - -Every expander object will accept the following -subcommands:

- -

-
[commanddef cappend text] -
Appends a string to the output in the current context. This - command should rarely be used by macros or application code.

- -

[commanddef cget varname] -
Retrieves the value of variable varname, defined in the - current context.

- -

[commanddef cis cname] -
Determines whether or not the name of the current context - is cname.

- -

[commanddef cname] -
Returns the name of the current context.

- -

[commanddef cpop cname] -
Pops a context from the context stack, returning all accumulated - output in that context. The context must be named cname, or - an error results.

- -

[commanddef cpush cname] -
Pushes a context named cname onto the context stack. - The context must be popped by [command cpop] before expansion - ends or an error results.

- -

[commanddef cset varname value] -
Sets variable varname to value in the current context.

- -

[commanddef cvar varname] -
Retrieves the internal variable name of context variable - varname; this allows the variable to be passed to - commands like lappend.

- -

[commanddef errmode ?newErrmode?] -
Sets the macro expansion error mode to one of "nothing", - "macro", "error", or "fail"; the default value is "fail". The - value determines what the expander does if an error is detected - during expansion of a macro.

- - If the error mode is "fail", the error propagates normally and - can be caught or ignored by the application.

- - If the error mode is "error", the macro expands into a detailed - error message, and expansion continues.

- - If the error mode is "macro", the macro expands to itself; that - is, it is passed along to the output unchanged.

- - If the error mode is "nothing", the macro expands to the empty - string, and is effectively ignored.

- -

[commanddef evalcmd ?newEvalCmd?] -
Returns the current evaluation command, which defaults to - "uplevel #0". If specified, newEvalCmd will be saved - for future use and then returned; it must be a Tcl - command expecting one additional argument: the macro to evaluate.

- -

[commanddef expand inputString ?brackets?] -
Expands the input string, replacing embedded macros with their - expanded values, and returns the expanded string.

- - If brackets is given, it must be a list of two strings; - the items will be used as the left and right macro expansion - bracket sequences for this expansion only.

- -

[commanddef lb ?newbracket?] -
Returns the current value of the right macro expansion - bracket; this is for use as or within a macro, when the bracket - needs to be included in the output text. If newbracket is - specified, it becomes the new bracket, and is returned.

- -

[commanddef rb ?newbracket?] -
Returns the current value of the right macro expansion - bracket; this is for use as or within a macro, when the bracket - needs to be included in the output text. If newbracket is - specified, it becomes the new bracket, and is returned.

- -

[commanddef reset] -
Resets all expander settings to their initial values. Unusual - results are likely if this command is called from within a call - to [command expand].

- -

[commanddef setbrackets lbrack rbrack] -
Sets the left and right macro expansion brackets. This command - is for use as or within a macro, or to permanently change the - bracket definitions. By default, the brackets are "[lb]" and - "[rb]", but any non-empty string can be used; for example, - "<" and ">" or "(*" and "*)" or even "Hello," and "World!".

- -

[commanddef textcmd ?newTextCmd?] -
Returns the current command for processing polain text, which - defaults to the empty string, meaning identity. If - specified, newTextCmd will be saved for future use and - then returned; it must be a Tcl command expecting one - additional argument: the text to process. The expander object - will this command for all plain text it encounters, giving the - user of the object the ability to process all plain text in - some standard way before writing it to the output. The object - expects that the command returns the processed plain text.

- Note that the combination of textcmd plaintext is - run through the evalcmd for the actual evaluation. In - other words, the textcmd is treated as a special macro - implicitly surrounding all plain text in the template.

-

- -[section "HISTORY"] - -expander was written by William H. Duquette; it is a repackaging of -the central algorithm of the -[link http://www.wjduquette.com/expand "expand"] macro processing tool.

- -[copyright 2001 "William H. Duquette"] DELETED modules/textutil/expander.html Index: modules/textutil/expander.html ================================================================== --- modules/textutil/expander.html +++ /dev/null @@ -1,367 +0,0 @@ - - expander - - - - -

expander

- -

SYNOPSIS

- -
-    package require expander 1.0
-

- -

DESCRIPTION

- -The Tcl "subst" command is often used to support a kind of template -processing. Given a string with embedded variables or function calls, -"subst" will interpolate the variable and function values, returning -the new string:

- -

% set greeting "Howdy"
-Howdy
-% proc place {} {return "World"}
-% subst {$greeting, [place]!}
-Howdy, World!
-%
- -By defining a suitable set of Tcl commands, "subst" can be used to -implement a markup language similar to HTML.

- -The "subst" command is efficient, but it has three drawbacks for this -kind of template processing:

- -

    -
  • There's no way to identify and process the plain text between two - embedded Tcl commands; that makes it difficult to handle plain - text in a context-sensitive way.

    - -

  • Embedded commands are necessarily bracketed by "[" and - "]"; it's convenient to be able to choose different brackets - in special cases. Someone producing web pages that include a - large quantity of Tcl code examples might easily prefer to use - "<<" and ">>" as the embedded code delimiters instead.

    - -

  • There's no easy way to handle incremental input, as one might - wish to do when reading data from a socket.

    -

- -At present, expander solves the first two problems; eventually it will -solve the third problem as well.

- -To begin, create an expander object:

- -

% package require textutil::expander
-1.0
-% ::textutil::expander myexp
-::myexp
-%
- -The created "::myexp" object can be used to expand text strings containing -embedded Tcl commands. By default, embedded commands are delimited by -square brackets. Note that expander doesn't attempt to interpolate -variables, since variables can be referenced by embedded commands:

- -

% set greeting "Howdy"
-Howdy
-% proc place {} {return "World"}
-% ::myexp expand {[set greeting], [place]!}
-Howdy, World!
-%
- -

Embedding Macros

- -An expander macro is simply a Tcl script embedded within a text -string. Expander evaluates the script in the global context, and -replaces it with its result string. For example, - -
% set greetings {Howdy Hi "What's up"}
-Howdy Hi "What's up"
-% ::myexp expand {There are many ways to say "Hello, World!":
-[set result {}
-foreach greeting $greetings {
-    append result "$greeting, World!\n"
-}
-set result]
-And that's just a small sample!}
-There are many ways to say "Hello, World!":
-Howdy, World!
-Hi, World!
-What's up, World!
-
-And that's just a small sample!
-%
- -

Writing Macro Commands

- -More typically, "macro commands" are used to create a markup -language. A macro command is just a Tcl command that returns an -output string. For example, expand can be used to implement a generic -document markup language that can be retargeted to HTML or any other -output format: - -
% proc bold {} {return "<b>"}
-% proc /bold {} {return "</b>"}
-% ::myexp expand {Some of this text is in [bold]boldface[/bold]}
-Some of this text is in <b>boldface</b>
-%
- -The above definition of "bold" and "/bold" returns HTML, but such -commands can be as complicated as needed; they could, for example, -decide what to return based on the desired output format.

- -

Changing the Expansion Brackets

- -By default, embedded macros are enclosed in square brackets, -"[" and "]". If square brackets need to be included in the -output, the input can contain the lb and rb -commands. Alternatively, or if square brackets are objectionable for -some other reason, the macro expansion brackets can be changed to any -pair of non-empty strings.

- -The setbrackets command changes the brackets permanently. -For example, you can write pseudo-html by change them to "<" and ">":

- -

% ::myexp setbrackets < >
-% ::myexp expand {<bold>This is boldface</bold>}
-<b>This is boldface</b>
- -Alternatively, you can change the expansion brackets temporarily by -passing the desired brackets to the expand command:

- -

% ::myexp setbrackets "\[" "\]"
-% ::myexp expand {<bold>This is boldface</bold>} {< >}
-<b>This is boldface</b>
-%
- -

Customized Macro Expansion

- -By default, macros are evaluated using the Tcl "uplevel #0" command, so -that the embedded code executes in the global context. The -application can provide a different evaluation command using -evalcmd; this allows the application to use a safe -interpreter, for example, or even to evaluated something other than -Tcl code. There is one caveat: to be recognized as valid, a macro -must return 1 when passed to Tcl's "info complete" command.

- -For example, the following code "evaluates" each macro by returning -the macro text itself.

- -

proc identity {macro} {return $macro}
-::myexp evalcmd identity
- -

Using the Context Stack

- - Often it's desirable to define a pair of macros -which operate in some way on the plain text between them. Consider a -set of macros for adding footnotes to a web page: one could -have implement something like this:

- -

    Dr. Pangloss, however, thinks that this is the best of all
-    possible worlds.[footnote "See Candide, by Voltaire"]
- -The footnote macro would, presumably, assign a number to -this footnote and save the text to be formatted later on. However, -this solution is ugly if the footnote text is long or should contain -additional markup. Consider the following instead:

- -

    Dr. Pangloss, however, thinks that this is the best of all
-    possible worlds.[footnote]See [bookTitle "Candide"], by
-    [authorsName "Voltaire"], for more information.[/footnote]
- -Here the footnote text is contained between footnote and -/footnote macros, continues onto a second line, and -contains several macros of its own. This is both clearer and more -flexible; however, with the features presented so far there's no easy -way to do it. That's the purpose of the context stack.

- -All macro expansion takes place in a particular context. -Here, the footnote macro pushes a new -context onto the context stack. Then, all expanded text gets placed -in that new context. /footnote retrieves it by popping -the context. Here's a skeleton implementation of these two macros:

- -

    proc footnote {} {
-        ::myexp cpush footnote
-    }
-
-    proc /footnote {} {
-        set footnoteText [::myexp cpop footnote]
-
-        # Save the footnote text, and return an appropriate footnote
-        # number and link.
-    }
- -The cpush command pushes a new context onto the stack; the -argument is the context's name. It can be any string, but would -typically be the name of the macro itself. Then, cpop -verifies that the current context has the expected name, pops it off -of the stack, and returns the accumulated text.

- -Expand provides several other tools related to the context stack. -Suppose the first macro in a context pair takes arguments or computes -values which the second macro in the pair needs. After calling -cpush, the first macro can define one or more context -variables; the second macro can retrieve their values any time before -calling cpop. For example, suppose the document must -specify the footnote number explicitly:

- -

    proc footnote {footnoteNumber} {
-        ::myexp cpush footnote
-        ::myexp csave num $footnoteNumber
-        # Return an appropriate link
-    }
-
-    proc /footnote {} {
-        set footnoteNumber [::myexp cget num]
-        set footnoteText [::myexp cpop footnote]
-
-        # Save the footnote text and its footnoteNumber for future
-        # output.
-    }
- -At times, it might be desirable to define macros that are valid only -within a particular context pair; such macros should verify that they -are only called within the correct context using either -cis or cname.

- -

TCL COMMANDS

- -The package defines the following Tcl commands:

- -

-
expander name -
This command creates a new expander object; - name is the name of the object, and becomes a new - command. By default, if the name isn't fully qualified, i.e., - if it doesn't completely specify the namespace in which to - create the new command, the command is created in the caller's - current namespace.

-

- -

EXPANDER OBJECT COMMANDS

- -Every expander object will accept the following -subcommands:

- -

-
cappend text -
Appends a string to the output in the current context. This - command should rarely be used by macros or application code.

- -

cget varname -
Retrieves the value of variable varname, defined in the - current context.

- -

cis cname -
Determines whether or not the name of the current context - is cname.

- -

cname -
Returns the name of the current context.

- -

cpop cname -
Pops a context from the context stack, returning all accumulated - output in that context. The context must be named cname, or - an error results.

- -

cpush cname -
Pushes a context named cname onto the context stack. - The context must be popped by cpop before expansion - ends or an error results.

- -

cset varname value -
Sets variable varname to value in the current context.

- -

cvar varname -
Retrieves the internal variable name of context variable - varname; this allows the variable to be passed to - commands like lappend.

- -

errmode ?newErrmode? -
Sets the macro expansion error mode to one of "nothing", - "macro", "error", or "fail"; the default value is "fail". The - value determines what the expander does if an error is detected - during expansion of a macro.

- - If the error mode is "fail", the error propagates normally and - can be caught or ignored by the application.

- - If the error mode is "error", the macro expands into a detailed - error message, and expansion continues.

- - If the error mode is "macro", the macro expands to itself; that - is, it is passed along to the output unchanged.

- - If the error mode is "nothing", the macro expands to the empty - string, and is effectively ignored.

- -

evalcmd ?newEvalCmd? -
Returns the current evaluation command, which defaults to - "uplevel #0". If specified, newEvalCmd will be saved - for future use and then returned; it must be a Tcl - command expecting one additional argument: the macro to evaluate.

- -

expand inputString ?brackets? -
Expands the input string, replacing embedded macros with their - expanded values, and returns the expanded string.

- - If brackets is given, it must be a list of two strings; - the items will be used as the left and right macro expansion - bracket sequences for this expansion only.

- -

lb ?newbracket? -
Returns the current value of the right macro expansion - bracket; this is for use as or within a macro, when the bracket - needs to be included in the output text. If newbracket is - specified, it becomes the new bracket, and is returned.

- -

rb ?newbracket? -
Returns the current value of the right macro expansion - bracket; this is for use as or within a macro, when the bracket - needs to be included in the output text. If newbracket is - specified, it becomes the new bracket, and is returned.

- -

reset -
Resets all expander settings to their initial values. Unusual - results are likely if this command is called from within a call - to expand.

- -

setbrackets lbrack rbrack -
Sets the left and right macro expansion brackets. This command - is for use as or within a macro, or to permanently change the - bracket definitions. By default, the brackets are "[" and - "]", but any non-empty string can be used; for example, - "<" and ">" or "(*" and "*)" or even "Hello," and "World!".

- -

textcmd ?newTextCmd?] -
Returns the current command for processing polain text, which - defaults to the empty string, meaning identity. If - specified, newTextCmd will be saved for future use and - then returned; it must be a Tcl command expecting one - additional argument: the text to process. The expander object - will this command for all plain text it encounters, giving the - user of the object the ability to process all plain text in - some standard way before writing it to the output. The object - expects that the command returns the processed plain text.

- Note that the combination of textcmd plaintext is - run through the evalcmd for the actual evaluation. In - other words, the textcmd is treated as a special macro - implicitly surrounding all plain text in the template.

-

- - -

HISTORY

- -expander was written by William H. Duquette; it is a repackaging of -the central algorithm of the -expand macro processing tool.

- - -

-Copyright © 2001, by William H. Duquette. All rights reserved.

- - - - DELETED modules/textutil/expander.man Index: modules/textutil/expander.man ================================================================== --- modules/textutil/expander.man +++ /dev/null @@ -1,550 +0,0 @@ -[comment {-*- tcl -*- doctools manpage}] -[manpage_begin expander n 1.2] -[copyright {William H. Duquette, http://www.wjduquette.com/expand}] -[moddesc {Text expansion and template processing}] -[titledesc {Procedures to process templates and expand text.}] -[require Tcl 8.2] -[require textutil::expander [opt 1.2]] -[description] - - -[para] - -The Tcl [cmd subst] command is often used to support a kind of -template processing. Given a string with embedded variables or -function calls, [cmd subst] will interpolate the variable and function -values, returning the new string: - -[para] - -[example { - % set greeting "Howdy" - Howdy - % proc place {} {return "World"} - % subst {$greeting, [place]!} - Howdy, World! - % -}] - -[para] - -By defining a suitable set of Tcl commands, [cmd subst] can be used to -implement a markup language similar to HTML. - -[para] - -The [cmd subst] command is efficient, but it has three drawbacks for -this kind of template processing: - -[list_begin bullet] - -[bullet] - -There's no way to identify and process the plain text between two -embedded Tcl commands; that makes it difficult to handle plain text in -a context-sensitive way. - -[bullet] - -Embedded commands are necessarily bracketed by [const [lb]] and -[const [rb]]; it's convenient to be able to choose different brackets -in special cases. Someone producing web pages that include a large -quantity of Tcl code examples might easily prefer to use [const <<] -and [const >>] as the embedded code delimiters instead. - -[bullet] - -There's no easy way to handle incremental input, as one might wish to -do when reading data from a socket. - -[list_end] - -[para] - -At present, expander solves the first two problems; eventually it will -solve the third problem as well. - -[para] - -The following section describes the command API to the expander; this -is followed by the tutorial sections, beginning at -[sectref {TUTORIAL: Basics}]. - -[section {EXPANDER API}] -[para] - -The [package textutil::expander] package provides only one command, -described below. The rest of the section is taken by a description of -the methods for the expander objects created by this command. - -[list_begin definitions] - -[call [cmd ::textutil::expander] [arg expanderName]] - -The command creates a new expander object with an associated Tcl -command whose name is [arg expanderName]. This command may be used to -invoke various operations on the graph. If the [arg expanderName] is -not fully qualified it is interpreted as relative to the current -namespace. The command has the following general form: - -[example_begin] - [arg expanderName] option [opt [arg {arg arg ...}]] -[example_end] - -[arg Option] and the [arg arg]s determine the exact behavior of the -command. - -[list_end] - -[para] - -The following commands are possible for expander objects: - -[list_begin definitions] - - -[call [arg expanderName] [method cappend] [arg text]] - -Appends a string to the output in the current context. This command -should rarely be used by macros or application code. - - -[call [arg expanderName] [method cget] [arg varname]] - -Retrieves the value of variable [arg varname], defined in the current -context. - - -[call [arg expanderName] [method cis] [arg cname]] - -Determines whether or not the name of the current context is - -[arg cname]. - - -[call [arg expanderName] [method cname]] - -Returns the name of the current context. - - -[call [arg expanderName] [method cpop] [arg cname]] - -Pops a context from the context stack, returning all accumulated -output in that context. The context must be named [arg cname], or an -error results. - - -[call [arg expanderName] [method ctopandclear]] - -Returns the output currently captured in the topmost context and -clears that buffer. This is similar to a combination of [method cpop] -followed by [method cpush], except that internal state (brackets) is -preserved here. - -[call [arg expanderName] [method cpush] [arg cname]] - -Pushes a context named [arg cname] onto the context stack. The -context must be popped by [method cpop] before expansion ends or an -error results. - - -[call [arg expanderName] [method cset] [arg varname] [arg value]] - -Sets variable [arg varname] to [arg value] in the current context. - - -[call [arg expanderName] [method cvar] [arg varname]] - -Retrieves the internal variable name of context variable - -[arg varname]; this allows the variable to be passed to commands like -[cmd lappend]. - - -[call [arg expanderName] [method errmode] [arg newErrmode]] - -Sets the macro expansion error mode to one of [const nothing], -[const macro], [const error], or [const fail]; the default value is -[const fail]. The value determines what the expander does if an -error is detected during expansion of a macro. - -[list_begin bullet] -[bullet] - -If the error mode is [const fail], the error propagates normally and -can be caught or ignored by the application. - -[bullet] - -If the error mode is [const error], the macro expands into a detailed -error message, and expansion continues. - -[bullet] - -If the error mode is [const macro], the macro expands to itself; that -is, it is passed along to the output unchanged. - -[bullet] - -If the error mode is [const nothing], the macro expands to the empty -string, and is effectively ignored. - -[list_end] - - -[call [arg expanderName] [method evalcmd] [opt [arg newEvalCmd]]] - -Returns the current evaluation command, which defaults to - -[cmd {uplevel #0}]. If specified, [arg newEvalCmd] will be saved for -future use and then returned; it must be a Tcl command expecting one -additional argument: the macro to evaluate. - - -[call [arg expanderName] [method expand] [arg string] [opt [arg brackets]]] - -Expands the input string, replacing embedded macros with their -expanded values, and returns the expanded string. - -[nl] - -If [arg brackets] is given, it must be a list of two strings; the -items will be used as the left and right macro expansion bracket -sequences for this expansion only. - - -[call [arg expanderName] [method lb] [opt [arg newbracket]]] - -Returns the current value of the left macro expansion bracket; this is -for use as or within a macro, when the bracket needs to be included in -the output text. If [arg newbracket] is specified, it becomes the new -bracket, and is returned. - - -[call [arg expanderName] [method rb] [opt [arg newbracket]]] - -Returns the current value of the right macro expansion bracket; this -is for use as or within a macro, when the bracket needs to be included -in the output text. If [arg newbracket] is specified, it becomes the -new bracket, and is returned. - - -[call [arg expanderName] [method reset]] - -Resets all expander settings to their initial values. Unusual results -are likely if this command is called from within a call to - -[method expand]. - - -[call [arg expanderName] [method setbrackets] [arg {lbrack rbrack}]] - -Sets the left and right macro expansion brackets. This command is for -use as or within a macro, or to permanently change the bracket -definitions. By default, the brackets are [const [lb]] and - -[const [rb]], but any non-empty string can be used; for example, -[const <] and [const >] or [const (*] and [const *)] or even -[const Hello,] and [const World!]. - - -[call [arg expanderName] [method textcmd] [opt [arg newTextCmd]]] - -Returns the current command for processing plain text, which defaults -to the empty string, meaning [emph identity]. If specified, - -[arg newTextCmd] will be saved for future use and then returned; it -must be a Tcl command expecting one additional argument: the text to -process. The expander object will this command for all plain text it -encounters, giving the user of the object the ability to process all -plain text in some standard way before writing it to the output. The -object expects that the command returns the processed plain text. - -[nl] - -[emph Note] that the combination of "[cmd textcmd] [arg plaintext]" -is run through the [arg evalcmd] for the actual evaluation. In other -words, the [arg textcmd] is treated as a special macro implicitly -surrounding all plain text in the template. - -[list_end] - -[section {TUTORIAL: Basics}] - -[para] - -To begin, create an expander object: - -[para] - -[example { - % package require expander - 1.2 - % ::expander::expander myexp - ::myexp - % -}] - -[para] - -The created [cmd ::myexp] object can be used to expand text strings -containing embedded Tcl commands. By default, embedded commands are -delimited by square brackets. Note that expander doesn't attempt to -interpolate variables, since variables can be referenced by embedded -commands: - -[para] - -[example { - % set greeting "Howdy" - Howdy - % proc place {} {return "World"} - % ::myexp expand {[set greeting], [place]!} - Howdy, World! - % -}] - -[para] - -[section {TUTORIAL: Embedding Macros}] - -[para] - -An expander macro is simply a Tcl script embedded within a text -string. Expander evaluates the script in the global context, and -replaces it with its result string. For example, - -[para] - -[example { - % set greetings {Howdy Hi "What's up"} - Howdy Hi "What's up" - % ::myexp expand {There are many ways to say "Hello, World!": - [set result {} - foreach greeting $greetings { - append result "$greeting, World!\\n" - } - set result] - And that's just a small sample!} - There are many ways to say "Hello, World!": - Howdy, World! - Hi, World! - What's up, World! - - And that's just a small sample! - % -}] - -[para] - -[section {TUTORIAL: Writing Macro Commands}] - -[para] - -More typically, [emph {macro commands}] are used to create a markup -language. A macro command is just a Tcl command that returns an -output string. For example, expand can be used to implement a generic -document markup language that can be retargeted to HTML or any other -output format: - -[para] - -[example { - % proc bold {} {return ""} - % proc /bold {} {return ""} - % ::myexp expand {Some of this text is in [bold]boldface[/bold]} - Some of this text is in boldface - % -}] - -[para] - -The above definitions of [cmd bold] and [cmd /bold] returns HTML, but -such commands can be as complicated as needed; they could, for -example, decide what to return based on the desired output format. - -[para] - -[section {TUTORIAL: Changing the Expansion Brackets}] - -[para] - -By default, embedded macros are enclosed in square brackets, - -[const [lb]] and [const [rb]]. If square brackets need to be -included in the output, the input can contain the [cmd lb] and - -[cmd rb] commands. Alternatively, or if square brackets are -objectionable for some other reason, the macro expansion brackets can -be changed to any pair of non-empty strings. - -[para] - -The [method setbrackets] command changes the brackets permanently. -For example, you can write pseudo-html by change them to [const <] -and [const >]: - -[para] - -[example { - % ::myexp setbrackets < > - % ::myexp expand {This is boldface} - This is boldface -}] - -[para] - -Alternatively, you can change the expansion brackets temporarily by -passing the desired brackets to the [method expand] command: - -[para] - -[example { - % ::myexp setbrackets "\\[" "\\]" - % ::myexp expand {This is boldface} {< >} - This is boldface - % -}] - -[para] - -[section {TUTORIAL: Customized Macro Expansion}] - -[para] - -By default, macros are evaluated using the Tcl [cmd {uplevel #0}] -command, so that the embedded code executes in the global context. -The application can provide a different evaluation command using -[method evalcmd]; this allows the application to use a safe -interpreter, for example, or even to evaluated something other than -Tcl code. There is one caveat: to be recognized as valid, a macro -must return 1 when passed to Tcl's "info complete" command. - -[para] - -For example, the following code "evaluates" each macro by returning -the macro text itself. - -[para] - -[example { - proc identity {macro} {return $macro} - ::myexp evalcmd identity -}] - -[para] - -[section {TUTORIAL: Using the Context Stack}] - -[para] - -Often it's desirable to define a pair of macros which operate in some -way on the plain text between them. Consider a set of macros for -adding footnotes to a web page: one could have implement something -like this: - -[para] - -[example { - Dr. Pangloss, however, thinks that this is the best of all - possible worlds.[footnote "See Candide, by Voltaire"] -}] - -[para] - -The [cmd footnote] macro would, presumably, assign a number to this -footnote and save the text to be formatted later on. However, this -solution is ugly if the footnote text is long or should contain -additional markup. Consider the following instead: - -[para] - -[example { - Dr. Pangloss, however, thinks that this is the best of all - possible worlds.[footnote]See [bookTitle "Candide"], by - [authorsName "Voltaire"], for more information.[/footnote] -}] - -[para] - -Here the footnote text is contained between [cmd footnote] and -[cmd /footnote] macros, continues onto a second line, and contains -several macros of its own. This is both clearer and more flexible; -however, with the features presented so far there's no easy way to do -it. That's the purpose of the context stack. - -[para] - -All macro expansion takes place in a particular context. Here, the -[cmd footnote] macro pushes a new context onto the context stack. -Then, all expanded text gets placed in that new context. - -[cmd /footnote] retrieves it by popping the context. Here's a -skeleton implementation of these two macros: - -[para] - -[example { - proc footnote {} { - ::myexp cpush footnote - } - - proc /footnote {} { - set footnoteText [::myexp cpop footnote] - - # Save the footnote text, and return an appropriate footnote - # number and link. - } -}] - -[para] - -The [method cpush] command pushes a new context onto the stack; the -argument is the context's name. It can be any string, but would -typically be the name of the macro itself. Then, [method cpop] -verifies that the current context has the expected name, pops it off -of the stack, and returns the accumulated text. - -[para] - -Expand provides several other tools related to the context stack. -Suppose the first macro in a context pair takes arguments or computes -values which the second macro in the pair needs. After calling -[method cpush], the first macro can define one or more context -variables; the second macro can retrieve their values any time before -calling [method cpop]. For example, suppose the document must specify -the footnote number explicitly: - -[para] - -[example { - proc footnote {footnoteNumber} { - ::myexp cpush footnote - ::myexp csave num $footnoteNumber - # Return an appropriate link - } - - proc /footnote {} { - set footnoteNumber [::myexp cget num] - set footnoteText [::myexp cpop footnote] - - # Save the footnote text and its footnoteNumber for future - # output. - } -}] - -[para] - -At times, it might be desirable to define macros that are valid only -within a particular context pair; such macros should verify that they -are only called within the correct context using either [method cis] -or [method cname]. - -[section HISTORY] - -[cmd expander] was written by William H. Duquette; it is a repackaging -of the central algorithm of the expand macro processing tool. - -[see_also regexp split string [uri http://www.wjduquette.com/expand]] -[keywords string {template processing} {text expansion}] -[manpage_end] DELETED modules/textutil/expander.n Index: modules/textutil/expander.n ================================================================== --- modules/textutil/expander.n +++ /dev/null @@ -1,400 +0,0 @@ -'\" -'\" Copyright (c) 1998-2000 by nobody :-) -'\" All rights not reserved. -'\" -'\" RCS: @(#) $Id: expander.n,v 1.5 2002/02/15 05:35:30 andreas_kupries Exp $ -'\" -.so man.macros -.TH expander n 1.0.1 Textutil "Text expansion and template processing" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -textutil::expander \- Procedures to process templates and expand text. -.SH SYNOPSIS -.nf -\fBpackage require Tcl 8.2\fR -\fBpackage require textutil::expander ?1.0.1?\fR -.sp -\fB::textutil::expander\fR \fIexpanderName\fR -.fi -.BE -.SH DESCRIPTION -.PP -The Tcl \fBsubst\fR command is often used to support a kind of -template processing. Given a string with embedded variables or -function calls, \fBsubst\fR will interpolate the variable and function -values, returning the new string: -.PP -.CS - % set greeting "Howdy" - Howdy - % proc place {} {return "World"} - % subst {$greeting, [place]!} - Howdy, World! - % -.CE -.PP -By defining a suitable set of Tcl commands, \fBsubst\fR can be used to -implement a markup language similar to HTML. -.sp -The \fBsubst\fR command is efficient, but it has three drawbacks for -this kind of template processing: -.IP \(bu -There's no way to identify and process the plain text between two -embedded Tcl commands; that makes it difficult to handle plain text in -a context-sensitive way. -.IP \(bu -Embedded commands are necessarily bracketed by \fB[\fR and \fB]\fR; -it's convenient to be able to choose different brackets in special -cases. Someone producing web pages that include a large quantity of -Tcl code examples might easily prefer to use \fB<<\fR and \fB>>\fR as -the embedded code delimiters instead. -.IP \(bu -There's no easy way to handle incremental input, as one might wish to -do when reading data from a socket. - -.PP -At present, expander solves the first two problems; eventually it will -solve the third problem as well. - -The following section describes the command API to the expander; this -is followed by tutorial section. - -.SH "EXPANDER API" -.PP -The \fBtextutil::expander\fR package provides only one command, -described below. The rest of the section is taken by a description of -the methods for the exapnder objects created by this command. -.TP -\fB::textutil::expander\fR \fIexpanderName\fR -The \fB::textutil::expander\fR command creates a new expander object -with an associated Tcl command whose name is \fIexpanderName\fR. This -command may be used to invoke various operations on the graph. If the -\fIexpanderName\fR is not fully qualified it is interpreted as -relative to the current namespace. The command has the following -general form: -.CS -\fIexpanderName option \fR?\fIarg arg ...\fR? -.CE -\fIOption\fR and the \fIarg\fRs determine the exact behavior of the -command. -.PP -The following commands are possible for expander objects: -.TP -\fIexpanderName\fR \fBcappend\fR \fItext\fR -Appends a string to the output in the current context. This command -should rarely be used by macros or application code. -.TP -\fIexpanderName\fR \fBcget\fR \fIvarname\fR -Retrieves the value of variable \fIvarname\fR, defined in the current -context. -.TP -\fIexpanderName\fR \fBcis\fR \fIcname\fR -Determines whether or not the name of the current context is -\fIcname\fR. -.TP -\fIexpanderName\fR \fBcname\fR -Returns the name of the current context. -.TP -\fIexpanderName\fR \fBcpop\fR \fIcname\fR -Pops a context from the context stack, returning all accumulated -output in that context. The context must be named \fIcname\fR, or an -error results. -.TP -\fIexpanderName\fR \fBcpush\fR \fIcname\fR -Pushes a context named \fIcname\fR onto the context stack. The -context must be popped by \fBcpop\fR before expansion ends or an error -results. -.TP -\fIexpanderName\fR \fBcset\fR \fIvarname\fR -Sets variable \fIvarname\fR to \fIvalue\fR in the current context. -.TP -\fIexpanderName\fR \fBcvar\fR \fIvarname\fR -Retrieves the internal variable name of context variable -\fIvarname\fR; this allows the variable to be passed to commands like -\fBlappend\fR. -.TP -\fIexpanderName\fR \fBerrmode\fR \fInewErrmode\fR -Sets the macro expansion error mode to one of \fBnothing\fR, -\fBmacro\fR, \fBerror\fR, or \fBfail\fR; the default value is -\fBfail\fR. The value determines what the expander does if an error -is detected during expansion of a macro. -.RS -.IP \(bu -If the error mode is \fBfail\fR, the error propagates normally and can -be caught or ignored by the application. -.IP \(bu -If the error mode is \fBerror\fR, the macro expands into a detailed -error message, and expansion continues. -.IP \(bu -If the error mode is \fBmacro\fR, the macro expands to itself; that -is, it is passed along to the output unchanged. -.IP \(bu -If the error mode is \fBnothing\fR, the macro expands to the empty -string, and is effectively ignored. -.RE -.TP -\fIexpanderName\fR \fBevalcmd\fR ?\fInewEvalCmd\fR? -Returns the current evaluation command, which defaults to "uplevel -#0". If specified, \fInewEvalCmd\fR will be saved for future use and -then returned; it must be a Tcl command expecting one additional -argument: the macro to evaluate. -.TP -\fIexpanderName\fR \fBexpand\fR \fIstring\fR ?\fIbrackets\fR? -Expands the input string, replacing embedded macros with their -expanded values, and returns the expanded string. -.sp -If \fIbrackets\fR is given, it must be a list of two strings; the -items will be used as the left and right macro expansion bracket -sequences for this expansion only. -.TP -\fIexpanderName\fR \fBlb\fR ?\fInewbracket\fR? -Returns the current value of the right macro expansion bracket; this -is for use as or within a macro, when the bracket needs to be included -in the output text. If \fInewbracket\fR is specified, it becomes the -new bracket, and is returned. -.TP -\fIexpanderName\fR \fBrb\fR ?\fInewbracket\fR? -Returns the current value of the right macro expansion bracket; this -is for use as or within a macro, when the bracket needs to be included -in the output text. If \fInewbracket\fR is specified, it becomes the -new bracket, and is returned. -.TP -\fIexpanderName\fR \fBreset\fR -Resets all expander settings to their initial values. Unusual results -are likely if this command is called from within a call to -\fBexpand\fR. -.TP -\fIexpanderName\fR \fBsetbrackets\fR \fIlbrack rbrack\fR -Sets the left and right macro expansion brackets. This command is for -use as or within a macro, or to permanently change the bracket -definitions. By default, the brackets are \fB[\fR and \fB]\fR, but -any non-empty string can be used; for example, \fB<\fR and \fB>\fR or -\fB(*\fR and \fB*)\fR or even \fBHello,\fR and \fBWorld!\fR. -.TP -\fIexpanderName\fR \fBtextcmd\fR ?\fInewTxtCmd\fR? -Returns the current command for processing polain text, which defaults -to the empty string, meaning \fIidentity\fR. If specified, -\fInewTextCmd\fR will be saved for future use and then returned; it -must be a Tcl command expecting one additional argument: the text to -process. The expander object will this command for all plain text it -encounters, giving the user of the object the ability to process all -plain text in some standard way before writing it to the output. The -object expects that the command returns the processed plain text. -.sp -\fBNote\fR that the combination of \fItextcmd plaintext\fR is run through -the \fIevalcmd\fR for the actual evaluation. In other words, the -\fItextcmd\fR is treated as a special macro implicitly surrounding all -plain text in the template. -.SH TUTORIAL -.PP -To begin, create an expander object: -.PP -.CS - % package require expander - 1.0 - % ::expander::expander myexp - ::myexp - % -.CE -.PP -The created \fB::myexp\fR object can be used to expand text strings -containing embedded Tcl commands. By default, embedded commands are -delimited by square brackets. Note that expander doesn't attempt to -interpolate variables, since variables can be referenced by embedded -commands: -.PP -.CS - % set greeting "Howdy" - Howdy - % proc place {} {return "World"} - % ::myexp expand {[set greeting], [place]!} - Howdy, World! - % -.CE -.PP -\fBEmbedding Macros\fR -.PP -An expander macro is simply a Tcl script embedded within a text -string. Expander evaluates the script in the global context, and -replaces it with its result string. For example, -.PP -.CS - % set greetings {Howdy Hi "What's up"} - Howdy Hi "What's up" - % ::myexp expand {There are many ways to say "Hello, World!": - [set result {} - foreach greeting $greetings { - append result "$greeting, World!\\n" - } - set result] - And that's just a small sample!} - There are many ways to say "Hello, World!": - Howdy, World! - Hi, World! - What's up, World! - - And that's just a small sample! - % -.CE -.PP -\fBWriting Macro Commands\fR -.PP -More typically, \fImacro commands\fR are used to create a markup -language. A macro command is just a Tcl command that returns an -output string. For example, expand can be used to implement a generic -document markup language that can be retargeted to HTML or any other -output format: -.PP -.CS - % proc bold {} {return ""} - % proc /bold {} {return ""} - % ::myexp expand {Some of this text is in [bold]boldface[/bold]} - Some of this text is in boldface - % -.CE -.PP -The above definitions of \fBbold\fR and \fB/bold\fR returns HTML, but -such commands can be as complicated as needed; they could, for -example, decide what to return based on the desired output format. -.PP -\fBChanging the Expansion Brackets\fR -.PP -By default, embedded macros are enclosed in square brackets, \fB[\fR -and \fB]\fR. If square brackets need to be included in the output, -the input can contain the \fBlb\fR and \fBrb\fR commands. -Alternatively, or if square brackets are objectionable for some other -reason, the macro expansion brackets can be changed to any pair of -non-empty strings. -.PP -The \fBsetbrackets\fR command changes the brackets permanently. For -example, you can write pseudo-html by change them to \fB<\fR and -\fB>\fR: -.PP -.CS - % ::myexp setbrackets < > - % ::myexp expand {This is boldface} - This is boldface -.CE -.PP -Alternatively, you can change the expansion brackets temporarily by -passing the desired brackets to the \fBexpand\fR command: -.PP -.CS - % ::myexp setbrackets "\\[" "\\]" - % ::myexp expand {This is boldface} {< >} - This is boldface - % -.CE -.PP -\fBCustomized Macro Expansion\fR -.PP -By default, macros are evaluated using the Tcl "uplevel #0" command, -so that the embedded code executes in the global context. The -application can provide a different evaluation command using -\fBevalcmd\fR; this allows the application to use a safe interpreter, -for example, or even to evaluated something other than Tcl code. -There is one caveat: to be recognized as valid, a macro must return 1 -when passed to Tcl's "info complete" command. -.PP -For example, the following code "evaluates" each macro by returning -the macro text itself. -.PP -.CS - proc identity {macro} {return $macro} - ::myexp evalcmd identity -.CE -.PP -\fBUsing the Context Stack\fR -.PP -Often it's desirable to define a pair of macros which operate in some -way on the plain text between them. Consider a set of macros for -adding footnotes to a web page: one could have implement something -like this: -.PP -.CS - Dr. Pangloss, however, thinks that this is the best of all - possible worlds.[footnote "See Candide, by Voltaire"] -.CE -.PP -The \fBfootnote\fR macro would, presumably, assign a number to this -footnote and save the text to be formatted later on. However, this -solution is ugly if the footnote text is long or should contain -additional markup. Consider the following instead: -.PP -.CS - Dr. Pangloss, however, thinks that this is the best of all - possible worlds.[footnote]See [bookTitle "Candide"], by - [authorsName "Voltaire"], for more information.[/footnote] -.CE -.PP -Here the footnote text is contained between \fBfootnote\fR and -\fB/footnote\fR macros, continues onto a second line, and contains -several macros of its own. This is both clearer and more flexible; -however, with the features presented so far there's no easy way to do -it. That's the purpose of the context stack. -.PP -All macro expansion takes place in a particular context. Here, the -\fBfootnote\fR macro pushes a new context onto the context stack. -Then, all expanded text gets placed in that new context. -\fB/footnote\fR retrieves it by popping the context. Here's a -skeleton implementation of these two macros: -.PP -.CS - proc footnote {} { - ::myexp cpush footnote - } - - proc /footnote {} { - set footnoteText [::myexp cpop footnote] - - # Save the footnote text, and return an appropriate footnote - # number and link. - } -.CE -.PP -The \fBcpush\fR command pushes a new context onto the stack; the -argument is the context's name. It can be any string, but would -typically be the name of the macro itself. Then, \fBcpop\fR verifies -that the current context has the expected name, pops it off of the -stack, and returns the accumulated text. -.PP -Expand provides several other tools related to the context stack. -Suppose the first macro in a context pair takes arguments or computes -values which the second macro in the pair needs. After calling -\fBcpush\fR, the first macro can define one or more context variables; -the second macro can retrieve their values any time before calling -\fBcpop\fR. For example, suppose the document must specify the -footnote number explicitly: -.PP -.CS - proc footnote {footnoteNumber} { - ::myexp cpush footnote - ::myexp csave num $footnoteNumber - # Return an appropriate link - } - - proc /footnote {} { - set footnoteNumber [::myexp cget num] - set footnoteText [::myexp cpop footnote] - - # Save the footnote text and its footnoteNumber for future - # output. - } -.CE -.PP -At times, it might be desirable to define macros that are valid only -within a particular context pair; such macros should verify that they -are only called within the correct context using either \fBcis\fR or -\fBcname\fR. - -.SH HISTORY -.PP -\fBexpander\fR was written by William H. Duquette; it is a repackaging -of the central algorithm of the expand macro processing tool. - -.SH "SEE ALSO" -regexp, split, string, http://www.wjduquette.com/expand - -.SH KEYWORDS -string, template processing, text expansion DELETED modules/textutil/expander.tcl Index: modules/textutil/expander.tcl ================================================================== --- modules/textutil/expander.tcl +++ /dev/null @@ -1,911 +0,0 @@ -#--------------------------------------------------------------------- -# TITLE: -# expander.tcl -# -# AUTHOR: -# Will Duquette -# -# DESCRIPTION: -# -# An expander is an object that takes as input text with embedded -# Tcl code and returns text with the embedded code expanded. The -# text can be provided all at once or incrementally. -# -# See expander.[e]html for usage info. -# Also expander.n -# -# LICENSE: -# Copyright (C) 2001 by William H. Duquette. See expander_license.txt, -# distributed with this file, for license information. -# -# CHANGE LOG: -# -# 10/31/01: V0.9 code is complete. -# 11/23/01: Added "evalcmd"; V1.0 code is complete. - -# Provide the package. - -# Create the package's namespace. - -namespace eval ::textutil { - namespace eval expander { - # All indices are prefixed by "$exp-". - # - # lb The left bracket sequence - # rb The right bracket sequence - # errmode How to handle macro errors: - # nothing, macro, error, fail. - # evalcmd The evaluation command. - # textcmd The plain text processing command. - # level The context level - # output-$level The accumulated text at this context level. - # name-$level The tag name of this context level - # data-$level-$var A variable of this context level - - variable Info - - # In methods, the current object: - variable This "" - - # Export public commands - namespace export expander - } - - #namespace import expander::* - namespace export expander - - proc expander {name} {uplevel ::textutil::expander::expander [list $name]} -} - -#--------------------------------------------------------------------- -# FUNCTION: -# expander name -# -# INPUTS: -# name A proc name for the new object. If not -# fully-qualified, it is assumed to be relative -# to the caller's namespace. -# -# RETURNS: -# nothing -# -# DESCRIPTION: -# Creates a new expander object. - -proc ::textutil::expander::expander {name} { - variable Info - - # FIRST, qualify the name. - if {![string match "::*" $name]} { - # Get caller's namespace; append :: if not global namespace. - set ns [uplevel 1 namespace current] - if {"::" != $ns} { - append ns "::" - } - - set name "$ns$name" - } - - # NEXT, Check the name - if {"" != [info command $name]} { - return -code error "command name \"$name\" already exists" - } - - # NEXT, Create the object. - proc $name {method args} [format { - if {[catch {::textutil::expander::Methods %s $method $args} result]} { - return -code error $result - } else { - return $result - } - } $name] - - # NEXT, Initialize the object - Op_reset $name - - return $name -} - -#--------------------------------------------------------------------- -# FUNCTION: -# Methods name method argList -# -# INPUTS: -# name The object's fully qualified procedure name. -# This argument is provided by the object command -# itself. -# method The method to call. -# argList Arguments for the specific method. -# -# RETURNS: -# Depends on the method -# -# DESCRIPTION: -# Handles all method dispatch for a expander object. -# The expander's object command merely passes its arguments to -# this function, which dispatches the arguments to the -# appropriate method procedure. If the method raises an error, -# the method procedure's name in the error message is replaced -# by the object and method names. - -proc ::textutil::expander::Methods {name method argList} { - variable Info - variable This - - switch -exact -- $method { - expand - - lb - - rb - - setbrackets - - errmode - - evalcmd - - textcmd - - cpush - - ctopandclear - - cis - - cname - - cset - - cget - - cvar - - cpop - - cappend - - reset { - # FIRST, execute the method, first setting This to the object - # name; then, after the method has been called, restore the - # old object name. - set oldThis $This - set This $name - - set retval [catch "Op_$method $name $argList" result] - - set This $oldThis - - # NEXT, handle the result based on the retval. - if {$retval} { - regsub -- "Op_$method" $result "$name $method" result - return -code error $result - } else { - return $result - } - } - default { - return -code error "\"$name $method\" is not defined" - } - } -} - -#--------------------------------------------------------------------- -# FUNCTION: -# Get key -# -# INPUTS: -# key A key into the Info array, excluding the -# object name. E.g., "lb" -# -# RETURNS: -# The value from the array -# -# DESCRIPTION: -# Gets the value of an entry from Info for This. - -proc ::textutil::expander::Get {key} { - variable Info - variable This - - return $Info($This-$key) -} - -#--------------------------------------------------------------------- -# FUNCTION: -# Set key value -# -# INPUTS: -# key A key into the Info array, excluding the -# object name. E.g., "lb" -# -# value A Tcl value -# -# RETURNS: -# The value -# -# DESCRIPTION: -# Sets the value of an entry in Info for This. - -proc ::textutil::expander::Set {key value} { - variable Info - variable This - - return [set Info($This-$key) $value] -} - -#--------------------------------------------------------------------- -# FUNCTION: -# Var key -# -# INPUTS: -# key A key into the Info array, excluding the -# object name. E.g., "lb" -# -# RETURNS: -# The full variable name, suitable for setting or lappending - -proc ::textutil::expander::Var {key} { - variable Info - variable This - - return ::textutil::expander::Info($This-$key) -} - -#--------------------------------------------------------------------- -# FUNCTION: -# Contains list value -# -# INPUTS: -# list any list -# value any value -# -# RETURNS: -# TRUE if the list contains the value, and false otherwise. - -proc ::textutil::expander::Contains {list value} { - if {[lsearch -exact $list $value] == -1} { - return 0 - } else { - return 1 - } -} - - -#--------------------------------------------------------------------- -# FUNCTION: -# Op_lb ?newbracket? -# -# INPUTS: -# newbracket If given, the new bracket token. -# -# RETURNS: -# The current left bracket -# -# DESCRIPTION: -# Returns the current left bracket token. - -proc ::textutil::expander::Op_lb {name {newbracket ""}} { - if {[string length $newbracket] != 0} { - Set lb $newbracket - } - return [Get lb] -} - -#--------------------------------------------------------------------- -# FUNCTION: -# Op_rb ?newbracket? -# -# INPUTS: -# newbracket If given, the new bracket token. -# -# RETURNS: -# The current left bracket -# -# DESCRIPTION: -# Returns the current left bracket token. - -proc ::textutil::expander::Op_rb {name {newbracket ""}} { - if {[string length $newbracket] != 0} { - Set rb $newbracket - } - return [Get rb] -} - -#--------------------------------------------------------------------- -# FUNCTION: -# Op_setbrackets lbrack rbrack -# -# INPUTS: -# lbrack The new left bracket -# rbrack The new right bracket -# -# RETURNS: -# nothing -# -# DESCRIPTION: -# Sets the brackets as a pair. - -proc ::textutil::expander::Op_setbrackets {name lbrack rbrack} { - Set lb $lbrack - Set rb $rbrack - return -} - -#--------------------------------------------------------------------- -# FUNCTION: -# Op_errmode ?newErrmode? -# -# INPUTS: -# newErrmode If given, the new error mode. -# -# RETURNS: -# The current error mode -# -# DESCRIPTION: -# Returns the current error mode. - -proc ::textutil::expander::Op_errmode {name {newErrmode ""}} { - if {[string length $newErrmode] != 0} { - if {![Contains "macro nothing error fail" $newErrmode]} { - error "$name errmode: Invalid error mode: $newErrmode" - } - - Set errmode $newErrmode - } - return [Get errmode] -} - -#--------------------------------------------------------------------- -# FUNCTION: -# Op_evalcmd ?newEvalCmd? -# -# INPUTS: -# newEvalCmd If given, the new eval command. -# -# RETURNS: -# The current eval command -# -# DESCRIPTION: -# Returns the current eval command. This is the command used to -# evaluate macros; it defaults to "uplevel #0". - -proc ::textutil::expander::Op_evalcmd {name {newEvalCmd ""}} { - if {[string length $newEvalCmd] != 0} { - Set evalcmd $newEvalCmd - } - return [Get evalcmd] -} - -#--------------------------------------------------------------------- -# FUNCTION: -# Op_textcmd ?newTextCmd? -# -# INPUTS: -# newTextCmd If given, the new text command. -# -# RETURNS: -# The current text command -# -# DESCRIPTION: -# Returns the current text command. This is the command used to -# process plain text. It defaults to {}, meaning identity. - -proc ::textutil::expander::Op_textcmd {name args} { - switch -exact [llength $args] { - 0 {} - 1 {Set textcmd [lindex $args 0]} - default { - return -code error "wrong#args for textcmd: name ?newTextcmd?" - } - } - return [Get textcmd] -} - -#--------------------------------------------------------------------- -# FUNCTION: -# Op_reset -# -# INPUTS: -# none -# -# RETURNS: -# nothing -# -# DESCRIPTION: -# Resets all object values, as though it were brand new. - -proc ::textutil::expander::Op_reset {name} { - variable Info - - if {[info exists Info($name-lb)]} { - array unset Info "$name-*" - } - - set Info($name-lb) "\[" - set Info($name-rb) "\]" - set Info($name-errmode) "fail" - set Info($name-evalcmd) "uplevel #0" - set Info($name-textcmd) "" - set Info($name-level) 0 - set Info($name-output-0) "" - set Info($name-name-0) ":0" - - return -} - -#------------------------------------------------------------------------- -# Context: Every expansion takes place in its own context; however, -# a macro can push a new context, causing the text it returns and all -# subsequent text to be saved separately. Later, a matching macro can -# pop the context, acquiring all text saved since the first command, -# and use that in its own output. - -#--------------------------------------------------------------------- -# FUNCTION: -# Op_cpush cname -# -# INPUTS: -# cname The context name -# -# RETURNS: -# nothing -# -# DESCRIPTION: -# Pushes an empty macro context onto the stack. All expanded text -# will be added to this context until it is popped. - -proc ::textutil::expander::Op_cpush {name cname} { - # FRINK: nocheck - incr [Var level] - # FRINK: nocheck - set [Var output-[Get level]] {} - # FRINK: nocheck - set [Var name-[Get level]] $cname -} - -#--------------------------------------------------------------------- -# FUNCTION: -# Op_cis cname -# -# INPUTS: -# cname A context name -# -# RETURNS: -# true or false -# -# DESCRIPTION: -# Returns true if the current context has the specified name, and -# false otherwise. - -proc ::textutil::expander::Op_cis {name cname} { - return [expr {[string compare $cname [Op_cname $name]] == 0}] -} - -#--------------------------------------------------------------------- -# FUNCTION: -# Op_cname -# -# INPUTS: -# none -# -# RETURNS: -# The context name -# -# DESCRIPTION: -# Returns the name of the current context. - -proc ::textutil::expander::Op_cname {name} { - return [Get name-[Get level]] -} - -#--------------------------------------------------------------------- -# FUNCTION: -# Op_cset varname value -# -# INPUTS: -# varname The name of a context variable -# value The new value for the context variable -# -# RETURNS: -# The value -# -# DESCRIPTION: -# Sets a variable in the current context. - -proc ::textutil::expander::Op_cset {name varname value} { - Set data-[Get level]-$varname $value -} - -#--------------------------------------------------------------------- -# FUNCTION: -# Op_cget varname -# -# INPUTS: -# varname The name of a context variable -# -# RETURNS: -# The value -# -# DESCRIPTION: -# Returns the value of a context variable. It's an error if -# the variable doesn't exist. - -proc ::textutil::expander::Op_cget {name varname} { - if {![info exists [Var data-[Get level]-$varname]]} { - error "$name cget: $varname doesn't exist in this context ([Get level])" - } - return [Get data-[Get level]-$varname] -} - -#--------------------------------------------------------------------- -# FUNCTION: -# Op_cvar varname -# -# INPUTS: -# varname The name of a context variable -# -# RETURNS: -# The index to the variable -# -# DESCRIPTION: -# Returns the index to a context variable, for use with set, -# lappend, etc. - -proc ::textutil::expander::Op_cvar {name varname} { - if {![info exists [Var data-[Get level]-$varname]]} { - error "$name cvar: $varname doesn't exist in this context" - } - - return [Var data-[Get level]-$varname] -} - -#--------------------------------------------------------------------- -# FUNCTION: -# Op_cpop cname -# -# INPUTS: -# cname The expected context name. -# -# RETURNS: -# The accumulated output in this context -# -# DESCRIPTION: -# Returns the accumulated output for the current context, first -# popping the context from the stack. The expected context name -# must match the real name, or an error occurs. - -proc ::textutil::expander::Op_cpop {name cname} { - variable Info - - if {[Get level] == 0} { - error "$name cpop underflow on '$cname'" - } - - if {[string compare [Op_cname $name] $cname] != 0} { - error "$name cpop context mismatch: expected [Op_cname $name], got $cname" - } - - set result [Get output-[Get level]] - # FRINK: nocheck - set [Var output-[Get level]] "" - # FRINK: nocheck - set [Var name-[Get level]] "" - - array unset "Info data-[Get level]-*" - - # FRINK: nocheck - incr [Var level] -1 - return $result -} - -#--------------------------------------------------------------------- -# FUNCTION: -# Op_ctopandclear -# -# INPUTS: -# None. -# -# RETURNS: -# The accumulated output in the topmost context, clears the context, -# but does not pop it. -# -# DESCRIPTION: -# Returns the accumulated output for the current context, first -# popping the context from the stack. The expected context name -# must match the real name, or an error occurs. - -proc ::textutil::expander::Op_ctopandclear {name} { - variable Info - - if {[Get level] == 0} { - error "$name cpop underflow on '[Op_cname $name]'" - } - - set result [Get output-[Get level]] - Set output-[Get level] "" - return $result -} - -#--------------------------------------------------------------------- -# FUNCTION: -# Op_cappend text -# -# INPUTS: -# text Text to add to the output -# -# RETURNS: -# The accumulated output -# -# DESCRIPTION: -# Appends the text to the accumulated output in the current context. - -proc ::textutil::expander::Op_cappend {name text} { - # FRINK: nocheck - append [Var output-[Get level]] $text -} - -#------------------------------------------------------------------------- -# Macro-expansion: The following code is the heart of the module. -# Given a text string, and the current variable settings, this code -# returns an expanded string, with all macros replaced. - -#--------------------------------------------------------------------- -# FUNCTION: -# Op_expand inputString ?brackets? -# -# INPUTS: -# inputString The text to expand. -# brackets A list of two bracket tokens. -# -# RETURNS: -# The expanded text. -# -# DESCRIPTION: -# Finds all embedded macros in the input string, and expands them. -# If ?brackets? is given, it must be list of length 2, containing -# replacement left and right macro brackets; otherwise the default -# brackets are used. - -proc ::textutil::expander::Op_expand {name inputString {brackets ""}} { - - # FIRST, push a new context onto the stack, and save the current - # brackets. - - Op_cpush $name expand - Op_cset $name lb [Get lb] - Op_cset $name rb [Get rb] - - # SF Tcllib Bug #530056. - set start_level [Get level] ; # remember this for check at end - - # NEXT, use the user's brackets, if given. - if {[llength $brackets] == 2} { - Set lb [lindex $brackets 0] - Set rb [lindex $brackets 1] - } - - # NEXT, loop over the string, finding and expanding macros. - while {[string length $inputString] > 0} { - set plainText [ExtractToToken inputString [Get lb] exclude] - - # FIRST, If there was plain text, append it to the output, and - # continue. - if {$plainText != ""} { - set tc [Get textcmd] - if {[string length $tc] > 0} { - lappend tc $plainText - - if {![catch "[Get evalcmd] [list $tc]" result]} { - set plainText $result - } else { - HandleError $name {plain text} $tc $result - } - } - Op_cappend $name $plainText - if {[string length $inputString] == 0} { - break - } - } - - # NEXT, A macro is the next thing; process it. - if {[catch "GetMacro inputString" macro]} { - error "Error reading macro: $macro" - } - - # Expand the macro, and output the result, or - # handle an error. - if {![catch "[Get evalcmd] [list $macro]" result]} { - Op_cappend $name $result - continue - } - - HandleError $name macro $macro $result - } - - # SF Tcllib Bug #530056. - if {[Get level] > $start_level} { - # The user macros pushed additional contexts, but forgot to - # pop them all. The main work here is to place all the still - # open contexts into the error message, and to produce - # syntactically correct english. - - set c [list] - set n [expr {[Get level] - $start_level}] - if {$n == 1} { - set ctx context - set verb was - } else { - set ctx contexts - set verb were - } - for {incr n -1} {$n >= 0} {incr n -1} { - lappend c [Get name-[expr {[Get level]-$n}]] - } - return -code error \ - "The following $ctx pushed by the macros $verb not popped: [join $c ,]." - } elseif {[Get level] < $start_level} { - set n [expr {$start_level - [Get level]}] - if {$n == 1} { - set ctx context - } else { - set ctx contexts - } - return -code error \ - "The macros popped $n more $ctx than they had pushed." - } - - Op_lb $name [Op_cget $name lb] - Op_rb $name [Op_cget $name rb] - - return [Op_cpop $name expand] -} - -#--------------------------------------------------------------------- -# FUNCTION -# HandleError name title command errmsg -# -# INPUTS: -# name The name of the expander object in question. -# title A title text -# command The command which caused the error. -# errmsg The error message to report -# -# RETURNS: -# Nothing -# -# DESCRIPTIONS -# Is executed when an error in a macro or the plain text handler -# occurs. Generates an error message according to the current -# error mode. - -proc ::textutil::expander::HandleError {name title command errmsg} { - switch [Get errmode] { - nothing { } - macro { - Op_cappend $name "[Get lb]$command[Get rb]" - } - error { - Op_cappend $name "\n=================================\n" - Op_cappend $name "*** Error in $title:\n" - Op_cappend $name "*** [Get lb]$command[Get rb]\n--> $errmsg\n" - Op_cappend $name "=================================\n" - } - fail { - return -code error "Error in $title:\n[Get lb]$command[Get rb]\n--> $errmsg" - } - default { - return -code error "Unknown error mode: [Get errmode]" - } - } -} - -#--------------------------------------------------------------------- -# FUNCTION: -# ExtractToToken string token mode -# -# INPUTS: -# string The text to process. -# token The token to look for -# mode include or exclude -# -# RETURNS: -# The extracted text -# -# DESCRIPTION: -# Extract text from a string, up to or including a particular -# token. Remove the extracted text from the string. -# mode determines whether the found token is removed; -# it should be "include" or "exclude". The string is -# modified in place, and the extracted text is returned. - -proc ::textutil::expander::ExtractToToken {string token mode} { - upvar $string theString - - # First, determine the offset - switch $mode { - include { set offset [expr {[string length $token] - 1}] } - exclude { set offset -1 } - default { error "::expander::ExtractToToken: unknown mode $mode" } - } - - # Next, find the first occurrence of the token. - set tokenPos [string first $token $theString] - - # Next, return the entire string if it wasn't found, or just - # the part upto or including the character. - if {$tokenPos == -1} { - set theText $theString - set theString "" - } else { - set newEnd [expr {$tokenPos + $offset}] - set newBegin [expr {$newEnd + 1}] - set theText [string range $theString 0 $newEnd] - set theString [string range $theString $newBegin end] - } - - return $theText -} - -#--------------------------------------------------------------------- -# FUNCTION: -# GetMacro string -# -# INPUTS: -# string The text to process. -# -# RETURNS: -# The macro, stripped of its brackets. -# -# DESCRIPTION: - -proc ::textutil::expander::GetMacro {string} { - upvar $string theString - - # FIRST, it's an error if the string doesn't begin with a - # bracket. - if {[string first [Get lb] $theString] != 0} { - error "::expander::GetMacro: assertion failure, next text isn't a command! '$theString'" - } - - # NEXT, extract a full macro - set macro [ExtractToToken theString [Get lb] include] - while {[string length $theString] > 0} { - append macro [ExtractToToken theString [Get rb] include] - - # Verify that the command really ends with the [rb] characters, - # whatever they are. If not, break because of unexpected - # end of file. - if {![IsBracketed $macro]} { - break; - } - - set strippedMacro [StripBrackets $macro] - - if {[info complete "puts \[$strippedMacro\]"]} { - return $strippedMacro - } - } - - if {[string length $macro] > 40} { - set macro "[string range $macro 0 39]...\n" - } - error "Unexpected EOF in macro:\n$macro" -} - -# Strip left and right bracket tokens from the ends of a macro, -# provided that it's properly bracketed. -proc ::textutil::expander::StripBrackets {macro} { - set llen [string length [Get lb]] - set rlen [string length [Get rb]] - set tlen [string length $macro] - - return [string range $macro $llen [expr {$tlen - $rlen - 1}]] -} - -# Return 1 if the macro is properly bracketed, and 0 otherwise. -proc ::textutil::expander::IsBracketed {macro} { - set llen [string length [Get lb]] - set rlen [string length [Get rb]] - set tlen [string length $macro] - - set leftEnd [string range $macro 0 [expr {$llen - 1}]] - set rightEnd [string range $macro [expr {$tlen - $rlen}] end] - - if {$leftEnd != [Get lb]} { - return 0 - } elseif {$rightEnd != [Get rb]} { - return 0 - } else { - return 1 - } -} - -# Provide the package only if the code above was read and executed -# without error. - -package provide textutil::expander 1.2 DELETED modules/textutil/expander.test Index: modules/textutil/expander.test ================================================================== --- modules/textutil/expander.test +++ /dev/null @@ -1,350 +0,0 @@ -# -*-Tcl-*- -#--------------------------------------------------------------------- -# TITLE: -# expander.test -# -# AUTHOR: -# Will Duquette -# -# DESCRIPTION: -# Test cases for expander.tcl. Uses the ::tcltest:: harness. - - -#--------------------------------------------------------------------- -# Load the tcltest package - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -#--------------------------------------------------------------------- -# Load the expander package - -if { [ lsearch [ namespace children ] "::textutil::expander" ] == -1 } then { - source [file join [file dirname [info script]] expander.tcl] -} - -#--------------------------------------------------------------------- -# Test cases 1.x: Expander Accessors - -test expander-1.1 {initial expander settings} {} { - catch {::textutil::expander exp} - set result "[exp lb] [exp rb] [exp errmode]" -} {[ ] fail} - -test expander-1.2 {setting/retrieving lbrack} {} { - catch {::textutil::expander exp} - set result "[exp lb FOO] [exp lb] [exp lb {[}]" -} {FOO FOO [} - -test expander-1.3 {setting/retrieving rbrack} {} { - catch {::textutil::expander exp} - set result "[exp rb FOO] [exp rb] [exp rb {]}]" -} {FOO FOO ]} - -test expander-1.4 {setting/retrieving errmode fail} {} { - catch {::textutil::expander exp} - list [exp errmode fail] [exp errmode] -} {fail fail} - -test expander-1.5 {setting/retrieving errmode nothing} {} { - catch {::textutil::expander exp} - list [exp errmode nothing] [exp errmode] -} {nothing nothing} - -test expander-1.6 {setting/retrieving errmode macro} {} { - catch {::textutil::expander exp} - list [exp errmode macro] [exp errmode] -} {macro macro} - -test expander-1.7 {setting/retrieving errmode error} {} { - catch {::textutil::expander exp} - list [exp errmode error] [exp errmode] -} {error error} - -test expander-1.8 {setting/retrieving errmode incorrectly} {} { - catch {::textutil::expander exp} - exp errmode nothing - catch {exp errmode FOO} result - list $result [exp errmode] -} {{::exp errmode: Invalid error mode: FOO} nothing} - -test expander-1.9 {resetting the object} {} { - catch {::textutil::expander exp} - exp errmode macro - exp lb FOO - exp rb BAR - exp reset - set result "[exp lb] [exp rb] [exp errmode]" -} {[ ] fail} - -#--------------------------------------------------------------------- -# Test cases 2.x: The Context Stack - -test expander-2.1 {initial context stack settings} {} { - catch {::textutil::expander exp} - exp reset - list [exp cname] [exp cis [exp cname]] -} {:0 1} - -test expander-2.2 {context stack underflow} {} { - catch {::textutil::expander exp} - exp reset - catch {exp cpop FOO} result - set result -} {::exp cpop underflow on 'FOO'} - -test expander-2.3 {context push} {} { - catch {::textutil::expander exp} - exp reset - exp cpush FOO - list [exp cname] [exp cis [exp cname]] -} {FOO 1} - -test expander-2.4 {cvar error} {} { - catch {::textutil::expander exp} - exp reset - exp cpush FOO - catch {exp cvar BAR} result - set result -} {::exp cvar: BAR doesn't exist in this context} - -test expander-2.5 {cget error} {} { - catch {::textutil::expander exp} - exp reset - exp cpush FOO - catch {exp cget BAR} result - set result -} {::exp cget: BAR doesn't exist in this context (1)} - -test expander-2.6 {cpop mismatch} {} { - catch {::textutil::expander exp} - exp reset - exp cpush FOO - catch {exp cpop BAR} result - set result -} {::exp cpop context mismatch: expected FOO, got BAR} - -test expander-2.7 {cpush, cappend, cpop} {} { - catch {::textutil::expander exp} - exp reset - exp cpush FOO - exp cappend "Hello, " - exp cappend "World!" - set result [exp cpop FOO] - list $result [exp cname] -} {{Hello, World!} :0} - -test expander-2.8 {two-stage cpush, cappend, cpop} {} { - catch {::textutil::expander exp} - exp reset - exp cpush FOO - exp cappend "Goodbye " - exp cpush BAR - exp cappend "Cruel " - exp cappend [exp cpop BAR] - exp cappend "World!" - set result [exp cpop FOO] - list $result [exp cname] -} {{Goodbye Cruel World!} :0} - -test expander-2.9 {cset, cvar, cget} {} { - catch {::textutil::expander exp} - exp reset - exp cpush FOO - exp cset BAR QUUX - list [exp cget BAR] [set [exp cvar BAR]] -} {QUUX QUUX} - -test expander-2.10 {two-stage cset, cvar, cget} {} { - catch {::textutil::expander exp} - exp reset - exp cpush ONE - exp cset FOO BAR - exp cpush TWO - exp cset FOO QUUX - set v2 [exp cget FOO] - exp cpop TWO - set v1 [exp cget FOO] - list $v1 $v2 -} {BAR QUUX} - -#--------------------------------------------------------------------- -# Test cases 3.x: Successful Macro Expansion - -proc howdy {} {return "Howdy"} - -test expander-3.1 {expand the empty string} {} { - catch {::textutil::expander exp} - exp reset - exp expand "" -} {} - -test expander-3.2 {expand a string with no macros} {} { - catch {::textutil::expander exp} - exp reset - exp expand {Hello, world!} -} {Hello, world!} - -test expander-3.3 {expand a string consisting of a macro} {} { - catch {::textutil::expander exp} - exp reset - exp expand {[howdy]} -} {Howdy} - -test expander-3.3 {expand a string beginning with a macro} {} { - catch {::textutil::expander exp} - exp reset - exp expand {[howdy], world!} -} {Howdy, world!} - -test expander-3.4 {expand a string ending with a macro} {} { - catch {::textutil::expander exp} - exp reset - exp expand {Well, [howdy]} -} {Well, Howdy} - -test expander-3.5 {expand a string with macro in middle} {} { - catch {::textutil::expander exp} - exp reset - exp expand {Well, [howdy]!} -} {Well, Howdy!} - -test expander-3.6 {expand macro with changed default brackets} {} { - catch {::textutil::expander exp} - exp reset - exp lb "<<<" - exp rb ">>>" - exp expand {Well, <<>>!} -} {Well, Howdy!} - -test expander-3.7 {expand macro with changed user brackets} {} { - catch {::textutil::expander exp} - exp reset - exp expand {Well, <<>>!} {<<< >>>} -} {Well, Howdy!} - -test expander-3.8 {expand macro with changed user brackets} {} { - catch {::textutil::expander exp} - exp reset - set a [exp expand {[howdy]}] - set b [exp expand {Well, <<>>!} {<<< >>>}] - list $a $b -} {Howdy {Well, Howdy!}} - -test expander-3.9 {macros change brackets} {} { - catch {::textutil::expander exp} - exp reset - string trim [exp expand { - Well, [howdy]! - [exp setbrackets <<< >>>] - Well, <<>>! - <<>> - Well, [howdy]! - }] -} {Well, Howdy! - - Well, Howdy! - - Well, Howdy!} - -test expander-3.10 {brackets are restored correctly} {} { - catch {::textutil::expander exp} - exp reset - list [exp expand {} "< >"] [exp expand {[howdy]}] -} {Howdy Howdy} - -test expander-3.11 {nested expansion: one expander} {} { - catch {::textutil::expander exp} - exp reset - exp expand {[howdy] [exp expand {*[howdy]*}] [howdy]} -} {Howdy *Howdy* Howdy} - -test expander-3.12 {nested expansion: two expanders} {} { - catch {::textutil::expander exp} - catch {::textutil::expander exp2} - exp reset - exp2 reset - exp expand {[howdy] [exp2 expand {*[howdy]*}] [howdy]} -} {Howdy *Howdy* Howdy} - -#--------------------------------------------------------------------- -# Test cases 4.x: Failed Macro Expansion - -test expander-4.1 {error mode fail} {} { - catch {::textutil::expander exp} - exp reset - exp errmode fail - catch {exp expand {+++[nop]+++}} result - set result -} {Error in macro: -[nop] ---> invalid command name "nop"} - -test expander-4.2 {error mode error} {} { - catch {::textutil::expander exp} - exp reset - exp errmode error - catch {exp expand {+++[nop]+++}} result - set result -} {+++ -================================= -*** Error in macro: -*** [nop] ---> invalid command name "nop" -================================= -+++} - -test expander-4.3 {error mode macro} {} { - catch {::textutil::expander exp} - exp reset - exp errmode macro - catch {exp expand {+++[nop]+++}} result - set result -} {+++[nop]+++} - -test expander-4.4 {error mode nothing} {} { - catch {::textutil::expander exp} - exp reset - exp errmode nothing - catch {exp expand {+++[nop]+++}} result - set result -} {++++++} - -#--------------------------------------------------------------------- -# Test cases 5.x: Replacing the evalcmd. - -proc identity {macro} { - return $macro -} - -test expander-5.1 {new evalcmd} {} { - catch {::textutil::expander exp} - exp reset - set oldcmd [exp evalcmd] - exp evalcmd identity - list $oldcmd [exp evalcmd] [exp expand {+++[Bogus Macro]+++}] -} {{uplevel #0} identity {+++Bogus Macro+++}} - -#--------------------------------------------------------------------- -# Test cases 5.x: Replacing the textcmd. - -proc count {text} { - return [string length $text] -} - -test expander-6.1 {new evalcmd} {} { - catch {::textutil::expander exp} - exp reset - set oldcmd [exp textcmd] - exp textcmd count - list $oldcmd [exp textcmd] [exp expand {++++++}] -} {{} count 6} - -#--------------------------------------------------------------------- -# Clean up - -::tcltest::cleanupTests -return - DELETED modules/textutil/expander_license.txt Index: modules/textutil/expander_license.txt ================================================================== --- modules/textutil/expander_license.txt +++ /dev/null @@ -1,38 +0,0 @@ -This software is copyrighted by William H. Duquette. The following -terms apply to all files associated with the software unless -explicitly disclaimed in individual files. - -The authors hereby grant permission to use, copy, modify, distribute, -and license this software and its documentation for any purpose, provided -that existing copyright notices are retained in all copies and that this -notice is included verbatim in any distributions. No written agreement, -license, or royalty fee is required for any of the authorized uses. -Modifications to this software may be copyrighted by their authors -and need not follow the licensing terms described here, provided that -the new terms are clearly indicated on the first page of each file where -they apply. - -IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY -FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES -ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY -DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. - -THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, -INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE -IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE -NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR -MODIFICATIONS. - -GOVERNMENT USE: If you are acquiring this software on behalf of the -U.S. government, the Government shall have only "Restricted Rights" -in the software and related documentation as defined in the Federal -Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you -are acquiring the software on behalf of the Department of Defense, the -software shall be classified as "Commercial Computer Software" and the -Government shall have only "Restricted Rights" as defined in Clause -252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the -authors grant the U.S. Government and others acting in its behalf -permission to use and distribute the software in accordance with the -terms specified in this license. DELETED modules/textutil/expander_notes.txt Index: modules/textutil/expander_notes.txt ================================================================== --- modules/textutil/expander_notes.txt +++ /dev/null @@ -1,47 +0,0 @@ -expander notes: -o expander.tcl is an objectified version of the expansion algorithm - used in expand and Spinster. Goals - - Multiple expanders can be used at one time - - Handling of batch or incremental input - - Support for user-settable brackets - - Support for context stack. -o Next: add and test incremental expansion. - -Things done: 11/23/2001 -x Added the evalcmd command; this allows the application to specify - a different means of evaluating macros than the default "uplevel - #0". - -Things done: 11/3/2001 -x Added a couple of more tests for the nested expander problem I - fixed the other day. -x Finished the man page for the current version. -x Time to zip it up and send it off to Andreas. - -Things done: 10/31/2001 -x Updated the list of possible error modes to match the list in - Expand 2.1 -x Added tests for each of the error modes to expander.test. -x Created a modified version of Expand 2.1 that uses expander; it - was able to process the Ex Libris website without error. -x Found an error: if an expander is used to expand text which - contains a call to another expander, the two get confused--because - of the "::expander::This" variable. - - It works for the recordkeeper, because a recordkeeper method - can never execute a method for a different recordkeeper. - - What if Methods saved the old This, and restored it at the - end? - - Tried it; it works! All existing tests pass. - -Things done: 10/30/2001 -x Wrote more tests; found and fixed bracket restoration bug in expander. - -Things done: 10/25/2001 -x Wrote tests for the lb, rb, and errmode commands. -x Added the reset command. -x Wrote tests for the reset command. -x Added the context stack commands, and wrote tests for them. - -Things done: 10/24/2001 -x Copied recordkeeper code and docs as a template. -x Implemented the lb, rb, and errmode accessor methods. DELETED modules/textutil/ithyph.tex Index: modules/textutil/ithyph.tex ================================================================== --- modules/textutil/ithyph.tex +++ /dev/null @@ -1,223 +0,0 @@ - -%%%%%%%%%%%%%%%%%%%% file ithyph.tex - -%%%%%%%%%%%%%%%%%%%%%%%%%%% file ithyph.tex %%%%%%%%%%%%%%%%%%%%%%%%%%%%% -% -% Prepared by Claudio Beccari e-mail beccari@polito.it -% -% Dipartimento di Elettronica -% Politecnico di Torino -% Corso Duca degli Abruzzi, 24 -% 10129 TORINO -% -% Copyright 1998, 2001 Claudio Beccari -% -% This program can be redistributed and/or modified under the terms -% of the LaTeX Project Public License Distributed from CTAN -% archives in directory macros/latex/base/lppl.txt; either -% version 1 of the License, or any later version. -% -% \versionnumber{4.8d} \versiondate{2001/11/21} -% -% These hyphenation patterns for the Italian language are supposed to comply -% with the Reccomendation UNI 6461 on hyphenation issued by the Italian -% Standards Institution (Ente Nazionale di Unificazione UNI). No guarantee -% or declaration of fitness to any particular purpose is given and any -% liability is disclaimed. -% -% See comments and loading instructions at the end of the file after the -% \endinput line -% -{\lccode`\'=`\' % Apostrophe has its own lccode so that it is treated - % as a letter - %>> 1998/04/14 inserted grouping - % -%\lccode23=23 % Compound word mark is a letter in encoding T1 -%\def\W{^^W} % ^^W =\char23 = \char"17 =\char'27 -% -\patterns{ -.a3p2n % After the Garzanti dictionary: a-pnea, a-pnoi-co,... -.anti1 .anti3m2n -.bio1 -.ca4p3s -.circu2m1 -.di2s3cine -%.e2x -.fran2k3 -.free3 -.narco1 -.opto1 -.orto3p2 -.para1 -.poli3p2 -.pre1 -.p2s -%.ri1a2 .ri1e2 .re1i2 .ri1o2 .ri1u2 -.sha2re3 -.tran2s3c .tran2s3d .tran2s3f .tran2s3l .tran2s3n .tran2s3p .tran2s3r .tran2s3t -.su2b3lu .su2b3r -.wa2g3n -.wel2t1 -a1ia a1ie a1io a1iu a1uo a1ya 2at. -e1iu e2w -o1ia o1ie o1io o1iu -%u1u -% -%1\W0a2 1\W0e2 1\W0i2 1\W0o2 1\W0u2 -'2 -1b 2bb 2bc 2bd 2bf 2bm 2bn 2bp 2bs 2bt 2bv - b2l b2r 2b. 2b'. 2b'' -1c 2cb 2cc 2cd 2cf 2ck 2cm 2cn 2cq 2cs 2ct 2cz - 2chh c2h 2chb ch2r 2chn c2l c2r 2c. 2c'. 2c'' .c2 -1d 2db 2dd 2dg 2dl 2dm 2dn 2dp d2r 2ds 2dt 2dv 2dw - 2d. 2d'. 2d'' .d2 -1f 2fb 2fg 2ff 2fn f2l f2r 2fs 2ft 2f. 2f'. 2f'' -1g 2gb 2gd 2gf 2gg g2h g2l 2gm g2n 2gp g2r 2gs 2gt - 2gv 2gw 2gz 2gh2t 2g. 2g'. 2g'' -1h 2hb 2hd 2hh hi3p2n h2l 2hm 2hn 2hr 2hv 2h. 2h'. 2h'' -1j 2j. 2j'. 2j'' -1k 2kg 2kf k2h 2kk k2l 2km k2r 2ks 2kt 2k. 2k'. 2k'' -1l 2lb 2lc 2ld 2l3f2 2lg l2h 2lk 2ll 2lm 2ln 2lp - 2lq 2lr 2ls 2lt 2lv 2lw 2lz 2l. 2l'. 2l'' -1m 2mb 2mc 2mf 2ml 2mm 2mn 2mp 2mq 2mr 2ms 2mt 2mv 2mw - 2m. 2m'. 2m'' -1n 2nb 2nc 2nd 2nf 2ng 2nk 2nl 2nm 2nn 2np 2nq 2nr - 2ns 2nt 2nv 2nz n2g3n 2nheit. 2n. 2n' 2n'' -1p 2pd p2h p2l 2pn 3p2ne 2pp p2r 2ps 3p2sic 2pt 2pz 2p. 2p'. 2p'' -1q 2qq 2q. 2q'. 2q'' -1r 2rb 2rc 2rd 2rf r2h 2rg 2rk 2rl 2rm 2rn 2rp - 2rq 2rr 2rs 2rt rt2s3 2rv 2rx 2rw 2rz 2r. 2r'. 2r'' -1s2 2shm 2s3s s4s3m 2s3p2n 2stb 2stc 2std 2stf 2stg 2stm 2stn - 2stp 2sts 2stt 2stv 2sz 4s. 4s'. 4s'' -1t 2tb 2tc 2td 2tf 2tg t2h t2l 2tm 2tn 2tp t2r 2ts - 3t2sch 2tt 2tv 2tw t2z 2tzk 2tzs 2t. 2t'. 2t'' -1v 2vc v2l v2r 2vv 2v. 2v'. 2v'' -1w w2h wa2r 2w1y 2w. 2w'. 2w'' -1x 2xt 2xw 2x. 2x'. 2x'' -y1ou y1i -1z 2zb 2zd 2zl 2zn 2zp 2zt 2zs 2zv 2zz 2z. 2z'. 2z'' .z2 -}} % Pattern end - -\endinput - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Information %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - - - LOADING THESE PATTERNS - -These patterns, as well as those for any other language, do not become -effective until they are loaded in a special form into a format file; this -task is performed by the TeX initializer; any TeX system has its own -initializer with its special way of being activated. Before loading these -patterns, then, it is necessary to read very carefully the instructions that -come with your TeX system. - -Here I describe how to load the patterns with the freeware TeX system named -MiKTeX version 2.x for Windows 9x, NT, 2000, XP; with minor changes the -whole procedure is applicable with other TeX systems, but the details must -be deduced from your TeX system documentation at the section/chapter "How to -build or to rebuild a format file". - -With MikTeX: - -a) copy this file and replace the existing file ithyph.tex in the directory - \texmf\tex\generic\hyphen if the existing one has an older version date - and number. -b) select Start|Programs|MiKTeX|MiKTeX options. -c) in the Language tab add a check mark to the line concerning the Italian - language. -d) in the Geneal tab click "Update format files". -e) That's all! - -For the activation of these patterns with the specific Italian typesetting -features, use the babel package as this: - -\documentclass{article} % Or whatever other class -\usepackage[italian]{babel} -... -\begin{document} -... -\end{document} - - - ON ITALIAN HYPHENATION - -I have been working on patterns for the Italian language since 1987; in 1992 -I published - -C. Beccari, "Computer aided hyphenation for Italian and Modern - Latin", TUG vol. 13, n. 1, pp. 23-33 (1992) - -which contained a set of patterns that allowed hyphenation for both Italian -and Latin; a slightly modified version of the patterns published in the -above paper is contained in LAHYPH.TEX available on the CTAN archives. - -From the above patterns I extracted the minimum set necessary for -hyphenating Italian that was made available on the CTAN archives with the -name ITHYPH.tex the version number 3.5 on the 16th of August 1994. - -The original pattern set required 37 ops; being interested in a local -version of TeX/LaTeX capable of dealing with half a dozen languages, I -wanted to reduce memory occupation and therefore the number of ops. - -Th new version (4.0 released in 1996) of ITHYPH.TEX is much simpler than -version 3.5 and requires just 29 ops while it retains all the power of -version 3.5; it contains many more new patterns that allow to hyphenate -unusual words that generally have a root borrowed from a foreign language. -Updated versions 4.x contain minor additions and the number of ops is -increased to 30 (version 4.7 of 1998/06/01). - -This new pattern set has been tested with the same set of difficult Italian -words that was used to test version 3.5 and it yields the same results (a -part a minor change that was deliberately introduced so as to reduce the -typographical hyphenation with hyathi, since hyphenated hyathi are not -appreciated by Italian readers). A new enlarged word set for testing -purposes gets correct hyphen points that were missed or wrongly placed with -version 3.5, although no error had been reported, because such words are of -very specialized nature and are seldom used. - -As the previous version, this new set of patterns does not contain any -accented character so that the hyphenation algorithm behaves properly in -both cases, that is with cm and with dc/ec fonts. With LaTeXe terminology -the difference is between OT1 and T1 encodings; with the former encoding -fonts do not contain accented characters, while with the latter accented -characters are present and sequences such as \`a map directly to slot "E0 -that contains "agrave". - -Of course if you use dc/ec fonts (or any other real or virtual font with T1 -encoding) you get the full power of the hyphenation algorithm, while if you -use cm fonts (or any other real or virtual font with OT1 encoding) you miss -some possible break points; this is not a big inconvenience in Italian -because: - -1) The Regulation UNI 6015 on accents specifies that compulsory accents - appear only on the ending vowel of oxitone words; this means that it is - almost indifferent to have or to miss the dc/ec fonts because the only - difference consists in how TeX evaluates the end of the word; in practice - if you have these special facilities you get "qua-li-t\`a", while if you - miss them, you get "qua-lit\`a" (assuming that \righthyphenmin > 1). - -2) Optional accents are so rare in Italian, that if you absolutely want to - use them in those rare instances, and you miss the T1 encoding - facilities, you should also provide explicit discretionary hyphens as in - "s\'e\-gui\-to". - -There is no explicit hyphenation exception list because these patterns -proved to hyphenate correctly a very large set of words suitably chosen in -order to test them in the most heavy circumstances; these patterns were used -in the preparation of a number of books and no errors were discovered. - -Nevertheless if you frequently use technical terms that you want hyphenated -differently from what is normally done (for example if you prefer -etymological hyphenation of prefixed and/or suffixed words) you should -insert a specific hyphenation list in the preamble of your document, for -example: - -\hyphenation{su-per-in-dut-to-re su-per-in-dut-to-ri} - -Should you find any word that gets hyphenated in a wrong way, please, AFTER -CHECKING ON A RELIABLE MODERN DICTIONARY, report to the author, preferably -by e-mail. - - - Happy multilingual typesetting ! DELETED modules/textutil/pkgIndex.tcl Index: modules/textutil/pkgIndex.tcl ================================================================== --- modules/textutil/pkgIndex.tcl +++ /dev/null @@ -1,16 +0,0 @@ -# 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. - -if {![package vsatisfies [package provide Tcl] 8.2]} { - # FRINK: nocheck - return -} -package ifneeded textutil 0.6 [list source [file join $dir textutil.tcl]] -package ifneeded textutil::expander 1.2 [list source [file join $dir expander.tcl]] DELETED modules/textutil/repeat.test Index: modules/textutil/repeat.test ================================================================== --- modules/textutil/repeat.test +++ /dev/null @@ -1,58 +0,0 @@ -# -*- tcl -*- -# trim.test: tests for the textutil package. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -if { [ lsearch [ namespace children ] "::textutil" ] == -1 } then { - source [file join [file dirname [info script]] textutil.tcl] -} - -################################################### - -test rep-0.1 {repeat < 0} { - set str [::textutil::strRepeat . -1] - set str -} "" - -test rep-0.2 {repeat 0} { - set str [::textutil::strRepeat . 0] - set str -} "" - -test rep-0.3 {repeat 1} { - set str [::textutil::strRepeat . 1] - set str -} "." - -test rep-0.4 {repeat 2} { - set str [::textutil::strRepeat . 2] - set str -} ".." - -test rep-0.5 {repeat 3} { - set str [::textutil::strRepeat . 3] - set str -} "..." - -test rep-0.6 {repeat 5} { - set str [::textutil::strRepeat . 5] - set str -} "....." - -test rep-0.7 {repeat 10} { - set str [::textutil::strRepeat . 10] - set str -} ".........." - -test rep-0.8 {repeat 100} { - set str [::textutil::strRepeat . 100] - set str -} "...................................................................................................." DELETED modules/textutil/split.tcl Index: modules/textutil/split.tcl ================================================================== --- modules/textutil/split.tcl +++ /dev/null @@ -1,72 +0,0 @@ -namespace eval ::textutil { - - namespace eval split { - - namespace export splitx - - # This will be redefined later. We need it just to let - # a chance for the next import subcommand to work - # - proc splitx [list str [list regexp "\[\t \r\n\]+"]] {} - } - - namespace import -force split::splitx - namespace export splitx - -} - -######################################################################## -# This one was written by Bob Techentin (RWT in Tcl'ers Wiki): -# http://www.techentin.net -# mailto:techentin.robert@mayo.edu -# -# Later, he send me an email stated that I can use it anywhere, because -# no copyright was added, so the code is defacto in the public domain. -# -# You can found it in the Tcl'ers Wiki here: -# http://mini.net/cgi-bin/wikit/460.html -# -# Bob wrote: -# If you need to split string into list using some more complicated rule -# than builtin split command allows, use following function. It mimics -# Perl split operator which allows regexp as element separator, but, -# like builtin split, it expects string to split as first arg and regexp -# as second (optional) By default, it splits by any amount of whitespace. -# Note that if you add parenthesis into regexp, parenthesed part of separator -# would be added into list as additional element. Just like in Perl. -- cary -# -# Speed improvement by Reinhard Max: -# Instead of repeatedly copying around the not yet matched part of the -# string, I use [regexp]'s -start option to restrict the match to that -# part. This reduces the complexity from something like O(n^1.5) to -# O(n). My test case for that was: -# -# foreach i {1 10 100 1000 10000} { -# set s [string repeat x $i] -# puts [time {splitx $s .}] -# } -# -proc ::textutil::split::splitx {str {regexp {[\t \r\n]+}}} { - # Bugfix 476988 - if {[string length $str] == 0} { - return {} - } - if {[string length $regexp] == 0} { - return [::split $str ""] - } - set list {} - set start 0 - while {[regexp -start $start -indices -- $regexp $str match submatch]} { - foreach {subStart subEnd} $submatch break - foreach {matchStart matchEnd} $match break - incr matchStart -1 - incr matchEnd - lappend list [string range $str $start $matchStart] - if {$subStart >= $start} { - lappend list [string range $str $subStart $subEnd] - } - set start $matchEnd - } - lappend list [string range $str $start end] - return $list -} DELETED modules/textutil/split.test Index: modules/textutil/split.test ================================================================== --- modules/textutil/split.test +++ /dev/null @@ -1,123 +0,0 @@ -# split.test: tests for the split sub-package of the textutil package. -# -*- tcl -*- -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -if { [ lsearch [ namespace children ] "::textutil" ] == -1 } then { - source [file join [file dirname [info script]] textutil.tcl] -} - -################################################### - -test splitx-0.1 {split simple string} { - ::textutil::splitx "Hello, Word" -} [ list Hello, Word ] - -test splitx-0.2 {split simple string with spaces} { - ::textutil::splitx "Hello, Word" -} [ list Hello, Word ] - -test splitx-0.3 {split simple string with tabs} { - ::textutil::splitx "Hello,\tWord" -} [ list Hello, Word ] - -test splitx-0.4 {split simple string with tabs and spaces ...} { - ::textutil::splitx "Hello,\t \r \n\n\n \r \r \t\t Word" -} [ list Hello, Word ] - -test splitx-0.5 {split simple string with beginning and ending tabs} { - ::textutil::splitx "\t \r \n\Hello, \t Word \t \r \n\n" -} [ list {} Hello, Word {} ] - -test splitx-1.1 {split simple string with regexp} { - ::textutil::splitx "Hello,\t,\n, Word" "\[ ,\t\r\n\]+" -} [ list Hello Word ] - -test splitx-1.2 {split simple string with buggy regexp} { - ::textutil::splitx "Hello, Word,\t,\n" "\[ ,\t\r\n\]" -} [ list Hello {} Word {} {} {} {} ] - -test splitx-2.1 {split text} { - ::textutil::splitx " -Determines whether the regular expression exp matches part or all of -string and returns 1 if it does, 0 if it doesn't, unless -inline is -specified (see below). (Regular expression matching is described in the -re_syntax reference page.) If additional arguments are specified after -string then they are treated as the names of variables in which to -return information about which part(s) of string matched exp. MatchVar -will be set to the range of string that matched all of exp. The first -subMatchVar will contain the characters in string that matched the -leftmost parenthesized subexpression within exp, the next subMatchVar -will contain the characters that matched the next parenthesized -subexpression to the right in exp , and so on. -" -} [ list {} Determines whether the regular expression exp matches part or all of string and returns 1 if it does, 0 if it doesn't, unless -inline is specified (see below). (Regular expression matching is described in the re_syntax reference page.) If additional arguments are specified after string then they are treated as the names of variables in which to return information about which part(s) of string matched exp. MatchVar will be set to the range of string that matched all of exp. The first subMatchVar will contain the characters in string that matched the leftmost parenthesized subexpression within exp, the next subMatchVar will contain the characters that matched the next parenthesized subexpression to the right in exp , and so on. {} ] - -test splitx-2.2 {split text with regexp} { - ::textutil::splitx " -Determines whether the regular expression exp matches part or all of -string and returns 1 if it does, 0 if it doesn't, unless -inline is -specified (see below). (Regular expression matching is described in the -re_syntax reference page.) If additional arguments are specified after -string then they are treated as the names of variables in which to -return information about which part(s) of string matched exp. MatchVar -will be set to the range of string that matched all of exp. The first -subMatchVar will contain the characters in string that matched the -leftmost parenthesized subexpression within exp, the next subMatchVar -will contain the characters that matched the next parenthesized -subexpression to the right in exp , and so on. -" "\[ ,()\.\t\r\n\]+" -} [ list {} Determines whether the regular expression exp matches part or all of string and returns 1 if it does 0 if it doesn't unless -inline is specified see below Regular expression matching is described in the re_syntax reference page If additional arguments are specified after string then they are treated as the names of variables in which to return information about which part s of string matched exp MatchVar will be set to the range of string that matched all of exp The first subMatchVar will contain the characters in string that matched the leftmost parenthesized subexpression within exp the next subMatchVar will contain the characters that matched the next parenthesized subexpression to the right in exp and so on {} ] - -# these tests show the effect inducted by the usage of parenthesed in -# the regexp Basically, the parenthesed operator is returned with the -# splitted list The 3.5 and 3.6 show complex cases. Try to understand. - -test splitx-3.1 {split string with simple regexp} { - ::textutil::splitx "Nobody is perfect" "\[oe\]+" -} [ list N b [ list dy is p ] rf ct ] - -test splitx-3.2 {split string with the same simple regexp but parenthesed} { - ::textutil::splitx "Nobody is perfect" "(\[oe\]+)" -} [ list N o b o [ list dy is p ] e rf e ct ] - -test splitx-3.3 {split string with a not so simple parenthesed regexp} { - ::textutil::splitx "Nobody is perfect" "o+|(rf)" -} [ list N b [ list dy is pe ] rf ect ] - -test splitx-3.4 {split string with a more complexe parenthesed regexp} { - ::textutil::splitx "Nobody is perfect" "\[oe\]+|(rf)" -} [ list N b [ list dy is p ] {} rf {} ct ] - -test splitx-3.5 {split string with an even more complexe parenthesed regexp} { - ::textutil::splitx "Nobody is perfect" "(\[oe\]+)|(rf)" -} [ list N o b o [ list dy is p ] e {} {} e ct ] - -test splitx-3.6 {split string with a totally parenthesed regexp} { - ::textutil::splitx "Nobody is perfect" "(\[oe\]+|rf)" -} [ list N o b o [ list dy is p ] e {} rf {} e ct ] - - -test splitx-4.0 {splitting of empty strings} { - ::textutil::splitx "" "f" -} {} - -test splitx-4.1 {splitting of empty strings} { - ::textutil::splitx "" -} {} - -test splitx-4.2 {splitting of empty strings} { - ::textutil::splitx "" "" -} {} - -test splitx-5.0 {splitting using an empty regexp} { - ::textutil::splitx "fooo bar bas" "" -} {f o o o { } b a r { } b a s} DELETED modules/textutil/tabify.tcl Index: modules/textutil/tabify.tcl ================================================================== --- modules/textutil/tabify.tcl +++ /dev/null @@ -1,284 +0,0 @@ -# -# As the author of the procs 'tabify2' and 'untabify2' I suggest that the -# comments explaining their behaviour be kept in this file. -# 1) Beginners in any programming language (I am new to Tcl so I know what I -# am talking about) can profit enormously from studying 'correct' code. -# Of course comments will help a lot in this regard. -# 2) Many problems newbies face can be solved by directing them towards -# available libraries - after all, libraries have been written to solve -# recurring problems. Then they can just use them, or have a closer look -# to see and to discover how things are done the 'Tcl way'. -# 3) And if ever a proc from a library should be less than perfect, having -# comments explaining the behaviour of the code will surely help. -# -# This said, I will welcome any error reports or suggestions for improvements -# (especially on the 'doing things the Tcl way' aspect). -# -# Use of these sources is licensed under the same conditions as is Tcl. -# -# June 2001, Helmut Giese (hgiese@ratiosoft.com) -# -# ---------------------------------------------------------------------------- -# -# The original procs 'tabify' and 'untabify' each work with complete blocks -# of $num spaces ('num' holding the tab size). While this is certainly useful -# in some circumstances, it does not reflect the way an editor works: -# Counting columns from 1, assuming a tab size of 8 and entering '12345' -# followed by a tab, you expect to advance to column 9. Your editor might -# put a tab into the file or 3 spaces, depending on its configuration. -# Now, on 'tabifying' you will expect to see those 3 spaces converted to a -# tab (and on the other hand expect the tab *at this position* to be -# converted to 3 spaces). -# -# This behaviour is mimicked by the new procs 'tabify2' and 'untabify2'. -# Both have one feature in common: They accept multi-line strings (a whole -# file if you want to) but in order to make life simpler for the programmer, -# they split the incoming string into individual lines and hand each line to -# a proc that does the real work. -# -# One design decision worth mentioning here: -# A single space is never converted to a tab even if its position would -# allow to do so. -# Single spaces occur very often, say in arithmetic expressions like -# [expr (($a + $b) * $c) < $d]. If we didn't follow the above rule we might -# need to replace one or more of them to tabs. However if the tab size gets -# changed, this expression would be formatted quite differently - which is -# probably not a good idea. -# -# 'untabifying' on the other hand might need to replace a tab with a single -# space: If the current position requires it, what else to do? -# As a consequence those two procs are unsymmetric in this aspect, but I -# couldn't think of a better solution. Could you? -# -# ---------------------------------------------------------------------------- -# - -namespace eval ::textutil { - - namespace eval tabify { - variable StrRepeat [ namespace parent ]::strRepeat - variable TabLen 8 - variable TabStr [ $StrRepeat " " $TabLen ] - - namespace export tabify untabify tabify2 untabify2 - - # This will be redefined later. We need it just to let - # a chance for the next import subcommand to work - # - proc tabify { string { num 8 } } { } - proc untabify { string { num 8 } } { } - proc tabify2 { string { num 8 } } { } - proc untabify2 { string { num 8 } } { } - - # The proc 'untabify2' uses the following variables for efficiency. - # Since a tab can be replaced by one up to 'tab size' spaces, it is handy - # to have the appropriate 'space strings' available. This is the use of - # the array 'Spaces', where 'Spaces(n)' contains just 'n' spaces. - # The variable 'TabLen2' remembers the biggest tab size used. - - variable TabLen2 0 - variable Spaces - array set Spaces {0 ""} - } - - namespace import -force tabify::tabify tabify::untabify \ - tabify::tabify2 tabify::untabify2 - namespace export tabify untabify tabify2 untabify2 -} - -######################################################################## - -proc ::textutil::tabify::tabify { string { num 8 } } { - return [string map [list [MakeTabStr $num] \t] $string] -} - -proc ::textutil::tabify::untabify { string { num 8 } } { - return [string map [list \t [MakeTabStr $num]] $string] -} - -proc ::textutil::tabify::MakeTabStr { num } { - variable StrRepeat - variable TabStr - variable TabLen - - if { $TabLen != $num } then { - set TabLen $num - set TabStr [ $StrRepeat " " $num ] - } - - return $TabStr -} - -# ---------------------------------------------------------------------------- -# -# tabifyLine: Works on a single line of text, replacing 'spaces at correct -# positions' with tabs. $num is the requested tab size. -# Returns the (possibly modified) line. -# -# 'spaces at correct positions': Only spaces which 'fill the space' between -# an arbitrary position and the next tab stop can be replaced. -# Example: With tab size 8, spaces at positions 11 - 13 will *not* be replaced, -# because an expansion of a tab at position 11 will jump up to 16. -# See also the comment at the beginning of this file why single spaces are -# *never* replaced by a tab. -# -# The proc works backwards, from the end of the string up to the beginning: -# - Set the position to start the search from ('lastPos') to 'end'. -# - Find the last occurrence of ' ' in 'line' with respect to 'lastPos' -# ('currPos' below). This is a candidate for replacement. -# - Find to 'currPos' the following tab stop using the expression -# set nextTab [expr ($currPos + $num) - ($currPos % $num)] -# and get the previous tab stop as well (this will be the starting -# point for the next iteration). -# - The ' ' at 'currPos' is only a candidate for replacement if -# 1) it is just one position before a tab stop *and* -# 2) there is at least one space at its left (see comment above on not -# touching an isolated space). -# Continue, if any of these conditions is not met. -# - Determine where to put the tab (that is: how many spaces to replace?) -# by stepping up to the beginning until -# -- you hit a non-space or -# -- you are at the previous tab position -# - Do the replacement and continue. -# -# This algorithm only works, if $line does not contain tabs. Otherwise our -# interpretation of any position beyond the tab will be wrong. (Imagine you -# find a ' ' at position 4 in $line. If you got 3 leading tabs, your *real* -# position might be 25 (tab size of 8). Since in real life some strings might -# already contain tabs, we test for it (and eventually call untabifyLine). -# - -proc ::textutil::tabify::tabifyLine { line num } { - if { [string first \t $line] != -1 } { - # assure array 'Spaces' is set up 'comme il faut' - checkArr $num - # remove existing tabs - set line [untabifyLine $line $num] - } - - set lastPos end - - while { $lastPos > 0 } { - set currPos [string last " " $line $lastPos] - if { $currPos == -1 } { - # no more spaces - break; - } - - set nextTab [expr {($currPos + $num) - ($currPos % $num)}] - set prevTab [expr {$nextTab - $num}] - - # prepare for next round: continue at 'previous tab stop - 1' - set lastPos [expr {$prevTab - 1}] - - if { ($currPos + 1) != $nextTab } { - continue ;# crit. (1) - } - - if { [string index $line [expr {$currPos - 1}]] != " " } { - continue ;# crit. (2) - } - - # now step backwards while there are spaces - for {set pos [expr {$currPos - 2}]} {$pos >= $prevTab} {incr pos -1} { - if { [string index $line $pos] != " " } { - break; - } - } - - # ... and replace them - set line [string replace $line [expr {$pos + 1}] $currPos \t] - } - return $line -} - -# -# Helper proc for 'untabifyLine': Checks if all needed elements of array -# 'Spaces' exist and creates the missing ones if needed. -# - -proc ::textutil::tabify::checkArr { num } { - variable TabLen2 - variable Spaces - variable StrRepeat - - if { $num > $TabLen2 } { - for { set i [expr {$TabLen2 + 1}] } { $i <= $num } { incr i } { - set Spaces($i) [$StrRepeat " " $i] - } - set TabLen2 $num - } -} - - -# untabifyLine: Works on a single line of text, replacing tabs with enough -# spaces to get to the next tab position. -# Returns the (possibly modified) line. -# -# The procedure is straight forward: -# - Find the next tab. -# - Calculate the next tab position following it. -# - Delete the tab and insert as many spaces as needed to get there. -# - -proc ::textutil::tabify::untabifyLine { line num } { - variable Spaces - - set currPos 0 - while { 1 } { - set currPos [string first \t $line $currPos] - if { $currPos == -1 } { - # no more tabs - break - } - - # how far is the next tab position ? - set dist [expr {$num - ($currPos % $num)}] - # replace '\t' at $currPos with $dist spaces - set line [string replace $line $currPos $currPos $Spaces($dist)] - - # set up for next round (not absolutely necessary but maybe a trifle - # more efficient) - incr currPos $dist - } - return $line -} - -# tabify2: Replace all 'appropriate' spaces as discussed above with tabs. -# 'string' might hold any number of lines, 'num' is the requested tab size. -# Returns (possibly modified) 'string'. -# -proc ::textutil::tabify::tabify2 { string { num 8 } } { - - # split string into individual lines - set inLst [split $string \n] - - # now work on each line - set outLst [list] - foreach line $inLst { - lappend outLst [tabifyLine $line $num] - } - - # return all as one string - return [join $outLst \n] -} - - -# untabify2: Replace all tabs with the appropriate number of spaces. -# 'string' might hold any number of lines, 'num' is the requested tab size. -# Returns (possibly modified) 'string'. -# -proc ::textutil::tabify::untabify2 { string { num 8 } } { - - # assure array 'Spaces' is set up 'comme il faut' - checkArr $num - - set inLst [split $string \n] - - set outLst [list] - foreach line $inLst { - lappend outLst [untabifyLine $line $num] - } - - return [join $outLst \n] -} DELETED modules/textutil/tabify.test Index: modules/textutil/tabify.test ================================================================== --- modules/textutil/tabify.test +++ /dev/null @@ -1,148 +0,0 @@ -# tabify.test: tests for the tabify sub-package of the textutil package. -# -*- tcl -*- -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -if { [ lsearch [ namespace children ] "::textutil" ] == -1 } then { - source [file join [file dirname [info script]] textutil.tcl] -} - -################################################### - -test tabify-0.1 {tabify string} { - ::textutil::tabify " hello, world " -} "\thello,\tworld\t" - -test tabify-0.2 {tabify string with 4 chars} { - ::textutil::tabify " hello, world " 4 -} "\t\thello,\t\tworld\t\t" - -test tabify-0.3 {tabify string with 5 chars} { - ::textutil::tabify " hello, world " 5 -} "\t hello,\t world\t " - -test tabify-1.1 {untabify string} { - ::textutil::untabify "\thello,\tworld\t" -} " hello, world " - -test tabify-1.2 {untabify string with 4 chars} { - ::textutil::untabify "\t\thello,\t\tworld\t\t" 4 -} " hello, world " - -test tabify-1.3 {untabify string with 5 chars} { - ::textutil::untabify "\t hello,\t world\t " 5 -} " hello, world " - -# -# Tests for version 2 of (un)tabify -# - -# -# tests 2.1 - 2.3: see how a single space (after 'hello') is not converted -# to a tab -# -test tabify-2.1 {version 2: tabify, tab size 3} { - ::textutil::tabify2 "hello world" 3 - # ---|||---|||-- -} "hello \tworld" - -test tabify-2.2 {version 2: tabify, tab size 3, more spaces than needed} { - ::textutil::tabify2 "hello world" 3 -} "hello \t world" - -test tabify-2.3 {version 2: tabify, tab size 3, less spaces than needed} { - ::textutil::tabify2 "hello world" 3 -} "hello world" - -test tabify-2.4 {version 2: tabify, tab size 8} { - ::textutil::tabify2 "hello world" -} "hello\tworld" - -test tabify-2.5 {version 2: tabify, tab size 8, more spaces than needed} { - ::textutil::tabify2 "hello world" -} "hello\t world" - -test tabify-2.6 {version 2: tabify, tab size 8, less spaces than needed} { - ::textutil::tabify2 "hello world" -} "hello world" - -# -# tests 2.7 & 2.8: 'end of line' (\n or not) of last line is preserved -# -test tabify-2.7 {version 2: tabify, tab size 8, multi line} { - ::textutil::tabify2 "line 1 \n line 2\nline 3 \n line 4" -} "line 1\t\n\tline 2\nline 3\t\n\tline 4" - -test tabify-2.8 {version 2: tabify, tab size 8, multi line} { - ::textutil::tabify2 "line 1 \n line 2\nline 3 \n line 4\n" -} "line 1\t\n\tline 2\nline 3\t\n\tline 4\n" - -# Test handling of existing tabs ... 2.9 as test and 2.10 the -# discrimator to check that it is correct if I use spaces -# instead of a tab, to see that my understanding is basically correct. - -test tabify-2.9 {version 2: handling of existing tabs} { - ::textutil::tabify2 "hello\tworld bye" - # hello...world bye - # --------||||||||--- -} "hello\tworld\tbye" - -test tabify-2.10 {version 2: handling of existing tabs} { - ::textutil::tabify2 "hello world bye" -} "hello\tworld\tbye" - - -# -# untabify -# -test tabify-3.1 {version 2: untabify, tab size 3} { - ::textutil::untabify2 "hello \tworld" 3 -} "hello world" - -test tabify-3.2 {version 2: untabify, tab size 3, tab to single space} { - ::textutil::untabify2 "hello\t\tworld" 3 -} "hello world" - -# -# The change in tab size from 3 to 8 (silently) results in building the -# appropriate 'Spaces' strings (in 3.5 'Spaces(6)' is needed) -# -test tabify-3.3 {version 2: untabify, tab size 8} { - ::textutil::untabify2 "hello\tworld" -} "hello world" - -test tabify-3.4 {version 2: untabify, tab size 8, mix of tab and spaces} { - ::textutil::untabify2 "hello \tworld" -} "hello world" - -test tabify-3.5 {version 2: untabify, tab size 8, requires 'long' space string} { - ::textutil::untabify2 "hello\tmy\tworld" -} "hello my world" - - -# -# tests 3.6 & 3.7: 'end of line' (\n or not) of last line is preserved -# -test tabify-3.6 {version 2: untabify, tab size 8, multi line} { - ::textutil::untabify2 "line 1\t\n\tline 2\nline 3\t\n\tline 4" -} "line 1 \n line 2\nline 3 \n line 4" - -test tabify-3.7 {version 2: untabify, tab size 8, multi line} { - ::textutil::untabify2 "line 1\t\n\tline 2\nline 3\t\n\tline 4\n" -} "line 1 \n line 2\nline 3 \n line 4\n" - -# -# Edge cases: test for empty string -# -test tabify-4.1 {tabify empty string} { textutil::tabify "" } "" -test tabify-4.2 {untabify empty string} { textutil::untabify ""} "" -test tabify-4.3 {tabify2 empty string} { textutil::tabify2 "" } "" -test tabify-4.4 {untabify2 empty string} { textutil::untabify2 ""} "" - DELETED modules/textutil/textutil.man Index: modules/textutil/textutil.man ================================================================== --- modules/textutil/textutil.man +++ /dev/null @@ -1,365 +0,0 @@ -[manpage_begin textutil n 0.6] -[moddesc {Texts and strings utils}] -[titledesc {Procedures to manipulate texts and strings.}] -[require Tcl 8.2] -[require textutil [opt 0.6]] -[description] - -The [package textutil] package provides commands that manipulate -strings or texts (a.k.a. long strings or string with embedded newlines -or paragraphs). - -[para] - -The complete set of procedures is described below. - -[list_begin definitions] - -[call [cmd ::textutil::adjust] [arg "string args"]] - -Do a justification on the [arg string] according to [arg args]. The -string is taken as one big paragraph, ignoring any newlines. Then the -line is formatted according to the options used, and the command -return a new string with enough lines to contain all the printable -chars in the input string. A line is a set of chars between the -beginning of the string and a newline, or between 2 newlines, or -between a newline and the end of the string. If the input string is -small enough, the returned string won't contain any newlines. - -[nl] - -Together with [cmd ::textutil::indent] it is possible to create -properly wrapped paragraphs with arbitrary indentations. - -[nl] - -By default, any occurrence of spaces characters or tabulation are -replaced by a single space so each word in a line is separated from -the next one by exactly one space char, and this forms a [emph real] -line. Each [emph real] line is placed in a [emph logical] line, which -have exactly a given length (see [option -length] option below). The -[emph real] line may have a lesser length. Again by default, any -trailing spaces are ignored before returning the string (see - -[option -full] option below). The following options may be used after the -[arg string] parameter, and change the way the command place a - -[emph real] line in a [emph logical] line. - - -[list_begin definitions] - -[lst_item "-full [arg boolean]"] - -If set to [const false], any trailing space chars are deleted before -returning the string. If set to [const true], any trailing space -chars are left in the string. Default to [const false]. - -[lst_item "[option -hyphenate] [arg boolean]"] - -if set to [const false], no hyphenation will be done. If set to -[const true], the last word of a line is tried to be hyphenated. -Defaults to [const false]. Note: hyphenation patterns must be loaded -prior, using the command [cmd ::textutil::adjust::readPatterns]. - - -[lst_item "[option -justify] [const center|left|plain|right]"] - -Set the justification of the returned string to [const center], - -[const left], [const plain] or [const right]. By default, it is set to -[const left]. The justification means that any line in the returned -string but the last one is build according to the value. If the -justification is set to [const plain] and the number of printable -chars in the last line is less than 90% of the length of a line (see -[option -length]), then this line is justified with the [const left] -value, avoiding the expansion of this line when it is too small. The -meaning of each value is: - -[list_begin definitions] - -[lst_item [const center]] - -The real line is centered in the logical line. If needed, a set of -space characters are added at the beginning (half of the needed set) -and at the end (half of the needed set) of the line if required (see -the option [option -full]). - -[lst_item [const left]] - -The real line is set on the left of the logical line. It means that -there are no space chars at the beginning of this line. If required, -all needed space chars are added at the end of the line (see the -option [option -full]). - -[lst_item [const plain]] - -The real line is exactly set in the logical line. It means that there -are no leading or trailing space chars. All the needed space chars are -added in the [emph real] line, between 2 (or more) words. - -[lst_item [const right]] - -The real line is set on the right of the logical line. It means that -there are no space chars at the end of this line, and there may be -some space chars at the beginning, despite of the [option -full] option. - -[list_end] - -[lst_item "[option -length] [arg integer]"] - -Set the length of the [emph logical] line in the string to -[arg integer]. [arg integer] must be a positive integer -value. Defaults to [const 72]. - - -[lst_item "[option -strictlength] [arg boolean]"] - -If set to [const false], a line can exceed the specified - -[option -length] if a single word is longer than [option -length]. If -set to [const true], words that are longer than [option -length] are -split so that no line exceeds the specified [option -length]. Defaults -to [const false]. - -[list_end] - - -[call [cmd ::textutil::adjust::readPatterns] [arg filename]] - -Loads the internal storage for hyphenation patterns with the contents -of the file [arg filename]. This has to be done prior to calling -command [cmd ::textutil::adjust] with - -"[option -hyphenate] [const true]", or the hyphenation process will -not work correctly. - -[nl] - -The package comes with a number of predefined pattern files, and the -command [cmd ::textutil::adjust::listPredefined] can be used to find -out their names. - -[call [cmd ::textutil::adjust::listPredefined]] - -This command returns a list containing the names of the hyphenation -files coming with this package. - -[call [cmd ::textutil::adjust::getPredefined] [arg filename]] - -Use this command to query the package for the full path name of the -hyphenation file [arg filename] coming with the package. Only the -filenames found in the list returned by - -[cmd ::textutil::adjust::listPredefined] are legal arguments for this -command. - - -[call [cmd ::textutil::indent] [arg string] [arg prefix] [opt [arg skip]]] - -Each line in the [arg string] indented by adding the string -[arg prefix] at its beginning. The modified string is returned -as the result of the command. - -[nl] - -If [arg skip] is specified the first [arg skip] lines are left -untouched. The default for [arg skip] is [const 0], causing the -modification of all lines. Negative values for [arg skip] are treated -like [const 0]. In other words, [arg skip] > [const 0] creates a -hanging indentation. - -[nl] - -Together with [cmd ::textutil::adjust] it is possible to create -properly wrapped paragraphs with arbitrary indentations. - - -[call [cmd ::textutil::undent] [arg string]] - -The command computes the common prefix for all -lines in [arg string] consisting solely out of whitespace, -removes this from each line and returns the modified string. - -[nl] - -Lines containing only whitespace are always reduced to completely -empty lines. They and empty lines are also ignored when computing the -prefix to remove. - -[nl] - -Together with [cmd ::textutil::adjust] it is possible to create -properly wrapped paragraphs with arbitrary indentations. - - -[call [cmd ::textutil::splitx] [arg string] [opt [arg regexp]]] - -Split the [arg string] and return a list. The string is split -according to the regular expression [arg regexp] instead of a simple -list of chars. Note that if you add parenthesis into the [arg regexp], -the parentheses part of separator would be added into list as -additional element. If the [arg string] is empty the result is the -empty list, like for [cmd split]. If [arg regexp] is empty the - -[arg string] is split at every character, like [cmd split] does. - -The regular expression [arg regexp] defaults to "[lb]\\t \\r\\n[rb]+". - - -[call [cmd ::textutil::tabify] [arg string] [opt [arg num]]] - -Tabify the [arg string] by replacing any substring of [arg num] space -chars by a tabulation and return the result as a new string. [arg num] -defaults to 8. - - -[call [cmd ::textutil::tabify2] [arg string] [opt [arg num]]] - -Similar to [cmd ::textutil::tabify] this command tabifies the - -[arg string] and returns the result as a new string. A different -algorithm is used however. Instead of replacing any substring of - -[arg num] spaces this command works more like an editor. [arg num] -defaults to 8. - -[nl] - -Each line of the text in [arg string] is treated as if there are -tabstops every [arg num] columns. Only sequences of space characters -containing more than one space character and found immediately before -a tabstop are replaced with tabs. - - -[call [cmd ::textutil::trim] [arg string] [opt [arg regexp]]] - -Remove in [arg string] any leading and trailing substring according to -the regular expression [arg regexp] and return the result as a new -string. This apply on any [emph line] in the string, that is any -substring between 2 newline chars, or between the beginning of the -string and a newline, or between a newline and the end of the string, -or, if the string contain no newline, between the beginning and the -end of the string. - -The regular expression [arg regexp] defaults to "[lb] \\t[rb]+". - - -[call [cmd ::textutil::trimleft] [arg string] [opt [arg regexp]]] - -Remove in [arg string] any leading substring according to the regular -expression [arg regexp] and return the result as a new string. This -apply on any [emph line] in the string, that is any substring between -2 newline chars, or between the beginning of the string and a newline, -or between a newline and the end of the string, or, if the string -contain no newline, between the beginning and the end of the string. - -The regular expression [arg regexp] defaults to "[lb] \\t[rb]+". - -[call [cmd ::textutil::trimright] [arg string] [opt [arg regexp]]] - -Remove in [arg string] any trailing substring according to the regular -expression [arg regexp] and return the result as a new string. This -apply on any [emph line] in the string, that is any substring between -2 newline chars, or between the beginning of the string and a newline, -or between a newline and the end of the string, or, if the string -contain no newline, between the beginning and the end of the string. - -The regular expression [arg regexp] defaults to "[lb] \\t[rb]+". - - -[call [cmd ::textutil::trimPrefix] [arg string] [arg prefix]] - -Removes the [arg prefix] from the beginning of [arg string] and -returns the result. The [arg string] is left unchanged if it doesn't -have [arg prefix] at its beginning. - - -[call [cmd ::textutil::trimEmptyHeading] [arg string]] - -Looks for empty lines (including lines consisting of only whitespace) -at the beginning of the [arg string] and removes it. The modified -string is returned as the result of the command. - - -[call [cmd ::textutil::untabify] [arg string] [opt [arg num]]] - -Untabify the [arg string] by replacing any tabulation char by a -substring of [arg num] space chars and return the result as a new -string. [arg num] defaults to 8. - - -[call [cmd ::textutil::untabify2] [arg string] [opt [arg num]]] - -Untabify the [arg string] by replacing any tabulation char by a -substring of at most [arg num] space chars and return the result as a -new string. Unlike [cmd textutil::untabify] each tab is not replaced -by a fixed number of space characters. The command overlays each line -in the [arg string] with tabstops every [arg num] columns instead and -replaces tabs with just enough space characters to reach the next -tabstop. This is the complement of the actions taken by - -[cmd ::textutil::tabify2]. [arg num] defaults to 8. - -[nl] - -There is one asymmetry though: A tab can be replaced with a single -space, but not the other way around. - - -[call [cmd ::textutil::strRepeat] [arg "text num"]] - -The implementation depends on the core executing the package. Used -[cmd "string repeat"] if it is present, or a fast tcl implementation -if it is not. Returns a string containing the [arg text] repeated - -[arg num] times. The repetitions are joined without characters between -them. A value of [arg num] <= 0 causes the command to return an empty -string. - - -[call [cmd ::textutil::blank] [arg num]] - -A convenience command. Returns a string of [arg num] spaces. - -[call [cmd ::textutil::chop] [arg string]] - -A convenience command. Removes the last character of [arg string] and -returns the shortened string. - -[call [cmd ::textutil::tail] [arg string]] - -A convenience command. Removes the first character of [arg string] and -returns the shortened string. - -[call [cmd ::textutil::cap] [arg string]] - -Capitalizes the first character of [arg string] and returns the modified string. - -[call [cmd ::textutil::uncap] [arg string]] - -The complementary operation to [cmd ::textutil::cap]. Forces the first -character of [arg string] to lower case and returns the modified -string. - - -[call [cmd ::textutil::longestCommonPrefixList] [arg list]] -[call [cmd ::textutil::longestCommonPrefix] [opt [arg string]...]] - -Computes the longest common prefix for either the [arg string]s given -to the command, or the strings specified in the single [arg list], and -returns it as the result of the command. - -[nl] - -If no strings were specified the result is the empty string. If only -one string was specified, the string itself is returned, as it is its -own longest common prefix. - -[list_end] - - -[see_also regexp(n) split(n) string(n)] -[keywords string {regular expression} formatting TeX hyphenation] -[keywords indenting trimming paragraph] -[manpage_end] DELETED modules/textutil/textutil.n Index: modules/textutil/textutil.n ================================================================== --- modules/textutil/textutil.n +++ /dev/null @@ -1,195 +0,0 @@ -'\" -'\" Copyright (c) 1998-2000 by nobody :-) -'\" All rights not reserved. -'\" -'\" RCS: @(#) $Id: textutil.n,v 1.12 2002/02/15 05:35:30 andreas_kupries Exp $ -'\" -.so man.macros -.TH textutil n 0.5 Textutil "Texts and strings utils" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -::textutil \- Procedures to manipulate texts and strings.. -.SH SYNOPSIS -.nf -\fBpackage require Tcl 8.2\fR -\fBpackage require textutil ?0.5?\fR -.sp -\fBtextutil::adjust\fR \fIstring args\fR -\fBtextutil::splitx\fR \fIstring {regexp [\\t \\r\\n]+}\fR -\fBtextutil::tabify\fR \fIstring {num 8}\fR -\fBtextutil::tabify2\fR \fIstring {num 8}\fR -\fBtextutil::trim\fR \fIstring {regexp [ \\t]+}\fR -\fBtextutil::trimleft\fR \fIstring {regexp [ \\t]+}\fR -\fBtextutil::trimright\fR \fIstring {regexp [ \\t]+}\fR -\fBtextutil::untabify\fR \fIstring {num 8}\fR -\fBtextutil::untabify2\fR \fIstring {num 8}\fR -\fBtextutil::strRepeat\fR \fIstring num\fR -.fi -.BE -.SH DESCRIPTION -.PP -The \fB::textutil\fR package provides commands that manipulate -strings or texts (a.k.a. long strings or string with embedded -newlines or paragraphs). - -.PP -The complete set of procedures is described below. - -.TP -\fBtextutil::adjust\fR \fIstring args\fR -Do a justification on the \fIstring\fP according to \fIargs\fP. -The string is taken as one big paragraph, ignoring any newlines. -Then the line is formatted according to the options used, and the -command return a new string with enough lines to contain all the -printable chars in the input string. A line is a set of chars -between the beginning of the string and a newline, or between 2 -newlines, or between a newline and the end of the string. If the -input string is small enough, the returned string won't contain -any newlines. -.sp -By default, any occurrence of spaces characters or tabulation are -replaced by a single space so each word in a line is separated from -the next one by exactly one space char, and this forms a \fIreal\fR -line. Each \fIreal\fR line is placed in a \fIlogical\fR line, which -have exactly a given length (see \fI-length\fR option below). The -\fIreal\fR line may have a lesser length. Again by default, any trailing -spaces are ignored before returning the string (see \fI-full\fR option -below). The following options may be used after the \fIstring\fP -parameter, and change the way the command place a \fIreal\fR line in -a \fIlogical\fR line. -.TP -\fI-full boolean\fR -if set to \fIfalse\fR, any trailing space chars are deleted before -returning the string. If set to \fItrue\fR, any trailing space chars are -left in the string. Default to \fIfalse\fR. -.TP -\fI-justify (center|left|plain|right)\fR -set the justification of the returned string to \fIcenter\fR, \fIleft\fR, -\fIplain\fR or \fIright\fR. By default, it is set to \fIleft\fR. -The justification means that any line in the returned string but the last -one is build according to the value. If the justification is set to -\fIplain\fR and the number of printable chars in the last line is less -than 90% of the length of a line (see \fI-length\fR), then this -line is justified with the \fIleft\fR value, avoiding the expansion of -this line when it is too small. The meaning of each value is: -.RS -.TP -\fIcenter\fR -the real line is centered in the logical line. If needed, a set of space -char are added at the beginning (half of the needed set) and at the end -(half of the needed set) of the line if required (see \fI-full\fR option). -.TP -\fIleft\fR -the real line is set on the left of the logical line. It means that -there are no space chars at the beginning of this line. If required, all -needed space chars are added at the end of the line (see \fI-full\fR -option). -.TP -\fIplain\fR -the real line is exactly set in the logical line. It means that there -are no leading or trailing space chars. All the needed space chars are -added in the \fIreal\fR line, between 2 (or more) words. -.TP -\fIright\fR -the real line is set on the right of the logical line. It means that -there are no space chars at the end of this line, and there may be some -space chars at the beginning, despite of the \fI-full\fR option. -.RE -.TP -\fI-length integer\fR -set the length of the \fIlogical\fR line in the string to \fIinteger\fR. -\fIinteger\fR must be a positive integer value. Default to \fI72\fR. -.TP -\fI-strictlength boolean\fR -if set to \fIfalse\fR, a line can exceed the specified '-length' if a -single word is longer than '-length'. If set to \fItrue\fR, words that -are longer than '-length' are split so that no line exceeds the -specified '-length'. Default to \fIfalse\fR. -.TP -\fBtextutil::splitx\fR \fIstring {regexp [\\t \\r\\n]+}\fR -Split the \fIstring\fP and return a list. The string is split -according to the regular expression \fIregexp\fR instead of a simple -list of chars. Note that if you add parenthesis into the \fIregexp\fR, -the parentheses part of separator would be added into list as -additional element. If the \fIstring\fR is empty the result is the -empty list, like for \fBsplit\fR. If \fIregexp\fR is empty the -\fIstring\fR is split at every character, like \fBsplit\fR does. -.TP -\fBtextutil::tabify\fR \fIstring {num 8}\fR -Tabify the \fIstring\fP by replacing any substring of \fInum\fP space -chars by a tabulation and return the result as a new string. - -.TP -\fBtextutil::tabify2\fR \fIstring {num 8}\fR -Similar to \fBtextutil::tabify\fR this command tabifies the -\fIstring\fR and returns the result as a new string. A different -algorithm is used however. Instead of replacing any substring of -\fInum\fP spaces this comand works more like an editor. -.sp -Each line of the text in \fIstring\fR is treated as if there are -tabstops every \fInum\fR columns. Only sequences of space characters -containing more than one space character and found immediately before -a tabstop are replaced with tabs. - -.TP -\fBtextutil::trim\fR \fIstring {regexp [ \\t]+}\fR -Remove in \fIstring\fP any leading and trailing substring according to -the regular expression \fIregexp\fR and return the result as a new string. -This apply on any \fIline\fR in the string, that is any substring between -2 newline chars, or between the beginning of the string and a newline, or -between a newline and the end of the string, or, if the string contain no -newline, between the beginning and the end of the string. - -.TP -\fBtextutil::trimleft\fR \fIstring {regexp [ \\t]+}\fR -Remove in \fIstring\fP any leading substring according to the regular -expression \fIregexp\fR and return the result as a new string. This apply -on any \fIline\fR in the string, that is any substring between 2 newline -chars, or between the beginning of the string and a newline, or between a -newline and the end of the string, or, if the string contain no newline, -between the beginning and the end of the string. - -.TP -\fBtextutil::trimright\fR \fIstring {regexp [ \\t]+}\fR -Remove in \fIstring\fP any trailing substring according to the regular -expression \fIregexp\fR and return the result as a new string. This apply -on any \fIline\fR in the string, that is any substring between 2 newline -chars, or between the beginning of the string and a newline, or between a -newline and the end of the string, or, if the string contain no newline, -between the beginning and the end of the string. - -.TP -\fBtextutil::untabify\fR \fIstring {num 8}\fR -Untabify the \fIstring\fP by replacing any tabulation char by a substring -of \fInum\fP space chars and return the result as a new string. - -.TP -\fBtextutil::untabify2\fR \fIstring {num 8}\fR - -Untabify the \fIstring\fP by replacing any tabulation char by a -substring of at most \fInum\fP space chars and return the result as a -new string. Unlike \fBtextutil::untabify\fR each tab is not replaced -by a fixed number of space characters. The command overlays each line -in the \fIstring\fR with tabstops every \fInum\fR columns instead and -replaces tabs with just enough space characters to reach the next -tabstop. This is the complement of the actions taken by -\fBtextutil::tabify2\fR. -.sp -There is one asymmetry though: A tab can be replaced with a single -space, but not the other way around. - -.TP -\fBtextutil::strRepeat\fR \fItext num\fR -The implementation depends on the core executing the package. Used -\fBstring repeat\fR if it is present, or a fast tcl implementation if -it is not. Returns a string containing the \fItext\fR repeated -\fInum\fR times. The repetitions are joined without characters between -them. A value of \fInum\fR <= 0 causes the command to return an empty -string. - -.SH "SEE ALSO" -regexp, split, string - -.SH KEYWORDS -string, regular expression DELETED modules/textutil/textutil.tcl Index: modules/textutil/textutil.tcl ================================================================== --- modules/textutil/textutil.tcl +++ /dev/null @@ -1,175 +0,0 @@ -package require Tcl 8.2 - -namespace eval ::textutil { - namespace export strRepeat - - variable HaveStrRepeat [ expr {![ catch { string repeat a 1 } ]} ] - - if {0} { - # Problems with the deactivated code: - # - Linear in 'num'. - # - Tests for 'string repeat' in every call! - # (Ok, just the variable, still a test every call) - # - Fails for 'num == 0' because of undefined 'str'. - - proc StrRepeat { char num } { - variable HaveStrRepeat - if { $HaveStrRepeat == 0 } then { - for { set i 0 } { $i < $num } { incr i } { - append str $char - } - } else { - set str [ string repeat $char $num ] - } - return $str - } - } - -} - -if {$::textutil::HaveStrRepeat} { - proc ::textutil::strRepeat {char num} { - return [string repeat $char $num] - } - - proc ::textutil::blank {n} { - return [string repeat " " $n] - } - -} else { - proc ::textutil::strRepeat {char num} { - if {$num <= 0} { - # No replication required - return "" - } elseif {$num == 1} { - # Quick exit for recursion - return $char - } elseif {$num == 2} { - # Another quick exit for recursion - return $char$char - } elseif {0 == ($num % 2)} { - # Halving the problem results in O (log n) complexity. - set result [strRepeat $char [expr {$num / 2}]] - return "$result$result" - } else { - # Uneven length, reduce problem by one - return "$char[strRepeat $char [incr num -1]]" - } - } - - proc ::textutil::blank {n} { - return [strRepeat " " $n] - } -} - - -# @c Removes the last character from the given . -# -# @a string: The string to manipulate. -# -# @r The without its last character. -# -# @i chopping - -proc ::textutil::chop {string} { - return [string range $string 0 [expr {[string length $string]-2}]] -} - - - -# @c Removes the first character from the given . -# @c Convenience procedure. -# -# @a string: string to manipulate. -# -# @r The without its first character. -# -# @i tail - -proc ::textutil::tail {string} { - return [string range $string 1 end] -} - - - -# @c Capitalizes first character of the given . -# @c Complementary procedure to

. -# -# @a string: string to manipulate. -# -# @r The with its first character capitalized. -# -# @i capitalize - -proc ::textutil::cap {string} { - return [string toupper [string index $string 0]][string range $string 1 end] -} - -# @c unCapitalizes first character of the given . -# @c Complementary procedure to

. -# -# @a string: string to manipulate. -# -# @r The with its first character uncapitalized. -# -# @i uncapitalize - -proc ::textutil::uncap {string} { - return [string tolower [string index $string 0]][string range $string 1 end] -} - - -# Compute the longest string which is common to all strings given to -# the command, and at the beginning of said strings, i.e. a prefix. If -# only one argument is specified it is treated as a list of the -# strings to look at. If more than one argument is specified these -# arguments are the strings to be looked at. If only one string is -# given, in either form, the string is returned, as it is its own -# longest common prefix. - -proc ::textutil::longestCommonPrefix {args} { - return [longestCommonPrefixList $args] -} - -proc ::textutil::longestCommonPrefixList {list} { - if {[llength $list] == 0} { - return "" - } elseif {[llength $list] == 1} { - return [lindex $list 0] - } - - set list [lsort $list] - set min [lindex $list 0] - set max [lindex $list end] - - # Min and max are the two strings which are most different. If - # they have a common prefix, it will also be the common prefix for - # all of them. - - # Fast bailouts for common cases. - - set n [string length $min] - if {$n == 0} {return ""} - if {0 == [string compare $min $max]} {return $min} - - set prefix "" - for {set i 0} {$i < $n} {incr i} { - if {0 == [string compare [set x [string range $min 0 $i]] [string range $max 0 $i]]} { - set prefix $x - continue - } - break - } - return $prefix -} - - - -source [ file join [ file dirname [ info script ] ] adjust.tcl ] -source [ file join [ file dirname [ info script ] ] split.tcl ] -source [ file join [ file dirname [ info script ] ] tabify.tcl ] -source [ file join [ file dirname [ info script ] ] trim.tcl ] - -# Do the [package provide] last, in case there is an error in the code above. -package provide textutil 0.6 - DELETED modules/textutil/textutil.test Index: modules/textutil/textutil.test ================================================================== --- modules/textutil/textutil.test +++ /dev/null @@ -1,131 +0,0 @@ -# -*- tcl -*- -# textutil.test: tests for the textutil package. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -#source [ file join [ file dirname [ info script ] ] [ file rootname [ file tail [ info script ] ] ].tcl ] -#source [ file join [ file dirname [ info script ] ] adjust.test ] -#source [ file join [ file dirname [ info script ] ] split.test ] -#source [ file join [ file dirname [ info script ] ] tabify.test ] -#source [ file join [ file dirname [ info script ] ] trim.test ] -#source [ file join [ file dirname [ info script ] ] repeat.test ] - - -test textutil-1.0 {blank -1} { - textutil::blank -1 -} {} - -test textutil-1.0 {blank 0} { - textutil::blank 0 -} {} - -test textutil-1.0 {blank 1} { - textutil::blank 1 -} { } - -test textutil-1.0 {blank 10} { - textutil::blank 10 -} { } - - - -test textutil-2.0 {chop empty} { - textutil::chop {} -} {} - -test textutil-2.1 {chop single} { - textutil::chop { } -} {} - -test textutil-2.2 {chop long} { - textutil::chop {abcde} -} {abcd} - - - -test textutil-3.0 {tail empty} { - textutil::tail {} -} {} - -test textutil-3.1 {tail single} { - textutil::tail { } -} {} - -test textutil-3.2 {tail long} { - textutil::tail {abcde} -} {bcde} - - - -test textutil-4.0 {cap empty} { - textutil::cap {} -} {} - -test textutil-4.1 {cap single} { - textutil::cap {a} -} {A} - -test textutil-4.2 {cap long} { - textutil::cap {abcde} -} {Abcde} - -test textutil-4.3 {cap capped} { - textutil::cap {Abcde} -} {Abcde} - - - -test textutil-5.0 {uncap empty} { - textutil::uncap {} -} {} - -test textutil-5.1 {uncap single} { - textutil::uncap {A} -} {a} - -test textutil-5.2 {uncap long} { - textutil::uncap {Abcde} -} {abcde} - -test textutil-5.3 {uncap uncapped} { - textutil::uncap {abcde} -} {abcde} - - - -test textutil-6.0 {lcs, no strings} { - textutil::longestCommonPrefixList {} -} {} - -test textutil-6.1 {lcs, one string} { - textutil::longestCommonPrefixList {foo} -} {foo} - -test textutil-6.2 {lcs, two strings, no prefix} { - textutil::longestCommonPrefixList {foo bar} -} {} - -test textutil-6.3 {lcs, two strings, small prefix} { - textutil::longestCommonPrefixList {foo fbar} -} {f} - -test textutil-6.4 {lcs, two strings, common} { - textutil::longestCommonPrefixList {foo foo} -} {foo} - -test textutil-6.5 {lcs, multiple strings} { - textutil::longestCommonPrefixList {foo fox fubar} -} {f} - - - - -::tcltest::cleanupTests DELETED modules/textutil/trim.tcl Index: modules/textutil/trim.tcl ================================================================== --- modules/textutil/trim.tcl +++ /dev/null @@ -1,94 +0,0 @@ -namespace eval ::textutil { - - namespace eval trim { - - variable StrU "\[ \t\]+" - variable StrR "(${StrU})\$" - variable StrL "^(${StrU})" - - namespace export trim trimright trimleft \ - trimPrefix trimEmpyHeading - - # This will be redefined later. We need it just to let - # a chance for the next import subcommand to work - # - proc trimleft { text { trim "[ \t]+" } } { } - proc trimright { text { trim "[ \t]+" } } { } - proc trim { text { trim "[ \t]+" } } { } - - proc trimPrefix {text prefix} {} - proc trimEmptyHeading {text} {} - } - - namespace import -force trim::trim trim::trimleft trim::trimright trim::trimPrefix trim::trimEmpyHeading - namespace export trim trimleft trimright trimPrefix trimEmpyHeading -} - - -proc ::textutil::trim::trimleft {text {trim "[ \t]+"}} { - regsub -line -all -- [MakeStr $trim left] $text {} text - return $text -} - -proc ::textutil::trim::trimright {text {trim "[ \t]+"}} { - regsub -line -all -- [MakeStr $trim right] $text {} text - return $text -} - -proc ::textutil::trim::trim {text {trim "[ \t]+"}} { - regsub -line -all -- [MakeStr $trim left] $text {} text - regsub -line -all -- [MakeStr $trim right] $text {} text - return $text -} - -proc ::textutil::trim::MakeStr { string pos } { - variable StrU - variable StrR - variable StrL - - if { "$string" != "$StrU" } { - set StrU $string - set StrR "(${StrU})\$" - set StrL "^(${StrU})" - } - if { "$pos" == "left" } { - return $StrL - } - if { "$pos" == "right" } { - return $StrR - } - - return -code error "Panic, illegal position key \"$pos\"" -} - - -# @c Strips from , if found at its start. -# -# @a text: The string to check for . -# @a prefix: The string to remove from . -# -# @r The , but without . -# -# @i remove, prefix - -proc ::textutil::trim::trimPrefix {text prefix} { - if {[string first $prefix $text] == 0} { - return [string range $text [string length $prefix] end] - } else { - return $text - } -} - - -# @c Removes the Heading Empty Lines of . -# -# @a text: The text block to manipulate. -# -# @r The , but without heading empty lines. -# -# @i remove, empty lines - -proc ::textutil::trim::trimEmptyHeading {text} { - regsub -- "^(\[ \t\]*\n)*" $text {} text - return $text -} DELETED modules/textutil/trim.test Index: modules/textutil/trim.test ================================================================== --- modules/textutil/trim.test +++ /dev/null @@ -1,172 +0,0 @@ -# stack.test: tests for the stack package. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -if { [ lsearch [ namespace children ] "::textutil" ] == -1 } then { - source [file join [file dirname [info script]] textutil.tcl] -} - -################################################### - -test trim-0.1 {trim string on left} { - set str [ ::textutil::trimleft "\t\t hello, world \t " ] - set str -} "hello, world \t " - -test trim-0.2 {trim string on right} { - set str [ ::textutil::trimright "\t\t hello, world \t " ] - set str -} "\t\t hello, world" - -test trim-0.3 {trim string on both side} { - set str [ ::textutil::trim "\t\t hello, world \t " ] - set str -} "hello, world" - -test trim-0.4 {trim string with embedded spaces and tabs on both side} { - set str [ ::textutil::trim "\t\t hello, \t\t world \t " ] - set str -} "hello, \t\t world" - -test trim-1.1 {trim text on left} { - set str [ ::textutil::trimleft "\t\t hello, \t\n \tworld \t " ] - set str -} "hello, \t -world \t " - -test trim-1.2 {trim text on right} { - set str [ ::textutil::trimright "\t\t hello, \t\n \tworld \t " ] - set str -} "\t\t hello, - \tworld" - -test trim-1.3 {trim string on both side} { - set str [ ::textutil::trim "\t\t hello, \t\n \tworld \t " ] - set str -} "hello, -world" - -test trim-1.4 {trim string with embedded spaces and tabs on both side} { - set str [ ::textutil::trim "\t\t hello\t \t, \t\n \tthe\t \t world \t " ] - set str -} "hello\t \t, -the\t \t world" - -test trim-2.1 {trim text on left with regexp} { - set str [ ::textutil::trimleft "\t\t hello, \t\n \tworld \t " "\[ \thwdo\]+" ] - set str -} "ello, \t -rld \t " - -test trim-2.2 {trim text on right} { - set str [ ::textutil::trimright "\t\t hello, \t\n \tworld \t " "\[ \thwdo\]+" ] - set str -} "\t\t hello, - \tworl" - -test trim-2.3 {trim string on both side} { - set str [ ::textutil::trim "\t\t hello, \t\n \tworld \t " "\[ \thwdo\]+" ] - set str -} "ello, -rl" - -test trim-2.4 {trim string with embedded spaces and tabs on both side} { - set str [ ::textutil::trim "\t\t hello\t \t, \t\n \tthe\t \t world \t " "\[ \thwdo\]+" ] - set str -} "ello\t \t, -the\t \t worl" - -# Not the real parray proc, because the default value of pattern is intentionnally omitted - -set myparray "\t \tproc myparray {a pattern} { - # print nicely an associated array sorted by element - upvar 1 \$a array \t - if {!\[array exists array\]} { - error \"\\\"\$a\\\" isn't an array\" \t - } - set maxl 0 ; # used to find the longest name of element - foreach name \[lsort \[array names array \$pattern\]\] { - if {\[string length \$name\] > \$maxl} { \t\t\t - set maxl \[string length \$name\] - } - } - set maxl \[expr {\$maxl + \[string length \$a\] + 2}\] \t - foreach name \[lsort \[array names array \$pattern\]\] { - set nameString \[format %s(%s) \$a \$name\] - puts stdout \[format \"%-*s = %s\" \$maxl \$nameString \$array(\$name)\] - } -\t\t}\t\t" - -test trim-3.1 {trim block of Tcl code} { - set code [ ::textutil::trim $myparray ] - set code -} "proc myparray {a pattern} { -# print nicely an associated array sorted by element -upvar 1 \$a array -if {!\[array exists array\]} { -error \"\\\"\$a\\\" isn't an array\" -} -set maxl 0 ; # used to find the longest name of element -foreach name \[lsort \[array names array \$pattern\]\] { -if {\[string length \$name\] > \$maxl} { -set maxl \[string length \$name\] -} -} -set maxl \[expr {\$maxl + \[string length \$a\] + 2}\] -foreach name \[lsort \[array names array \$pattern\]\] { -set nameString \[format %s(%s) \$a \$name\] -puts stdout \[format \"%-*s = %s\" \$maxl \$nameString \$array(\$name)\] -} -}" - -test trim-3.2 {trim block of Tcl code with regexp} { - set code [ ::textutil::trim $myparray "\[\] \t{}pu\]+" ] - set code -} "roc myparray {a pattern -# print nicely an associated array sorted by element -var 1 \$a array -if {!\[array exists array -error \"\\\"\$a\\\" isn't an array\" - -set maxl 0 ; # used to find the longest name of element -foreach name \[lsort \[array names array \$pattern -if {\[string length \$name\] > \$maxl -set maxl \[string length \$name - - -set maxl \[expr {\$maxl + \[string length \$a\] + 2 -foreach name \[lsort \[array names array \$pattern -set nameString \[format %s(%s) \$a \$name -ts stdout \[format \"%-*s = %s\" \$maxl \$nameString \$array(\$name) - -" - -test trim-3.3 {trim block of commented Tcl code with regexp} { - set code [ ::textutil::trim $myparray "(\[ \t\]+)|(\[ \t;\]*#.*)" ] - set code -} "proc myparray {a pattern} { - -upvar 1 \$a array -if {!\[array exists array\]} { -error \"\\\"\$a\\\" isn't an array\" -} -set maxl 0 -foreach name \[lsort \[array names array \$pattern\]\] { -if {\[string length \$name\] > \$maxl} { -set maxl \[string length \$name\] -} -} -set maxl \[expr {\$maxl + \[string length \$a\] + 2}\] -foreach name \[lsort \[array names array \$pattern\]\] { -set nameString \[format %s(%s) \$a \$name\] -puts stdout \[format \"%-*s = %s\" \$maxl \$nameString \$array(\$name)\] -} -}" DELETED modules/uri/ChangeLog Index: modules/uri/ChangeLog ================================================================== --- modules/uri/ChangeLog +++ /dev/null @@ -1,196 +0,0 @@ -2003-04-14 Andreas Kupries - - * uri.man: - * uri.tcl (split): Accepted the FR [#545368] by Mark G. Saye - , with a slight difference. To - keep API compatibibility the http stays the default scheme if - none was specified. - -2003-04-13 Andreas Kupries - - * uri-rfc2396.test: Added constraint 'knownBug' to these - tests. And reference to [#581781]. - -2003-04-11 Andreas Kupries - - * uri.test: - * uri.tcl (::uri::split): Fixed bug #676976 reported by Jason - Mills . An incorrect regular - expression (typo in character class) accepted more character - than it should have. - -2003-04-10 Andreas Kupries - - * pkgIndex.tcl: - * uri.man: - * uri.tcl: Fixed bug #614591. Set version - of the package to to 1.1.2. - - * urn-scheme.tcl: Fixed bug #614591. Set version - of the package to to 1.0.1 - -2003-03-28 Andreas Kupries - - * uri.man: - * uri-rfc2396.test: New file. First step towards conformance with - RFC 2396, a testsuite for checking conformant behaviour. Thanks - to Rolf Ade . Bug - #581781. Noted non-conformance in documentation, inviting help. - -2003-02-07 Pat Thoyts - - * uri.test (uri-4.1): Fixed bad test. - -2003-02-06 David N. Welton - - * uri.tcl (uri::SplitMailto): Use 'string match' instead of - regexp. - -2003-01-16 Andreas Kupries - - * uri.man: More semantic markup, less visual one. - -2003-01-07 Andreas Kupries - - * pkgIndex.tcl: Bump ifneeded patchlevel to match the provide in - uri.tcl. See last change. - -2002-11-15 David N. Welton - - * uri.tcl (uri::canonicalize): Take care of trailing .., as in - "http://foobar.com/foo/bar/..". - - * uri.test: Test for the above condition. - - * uri.tcl: Bump patchlevel in 'package provide'. - - * uri.test: Added tests for 'news' splitting and joining. - - * uri.man: Added 'news' to list of supported uri's. - - * uri.tcl (uri::SplitNews) (uri::JoinNews): Join and split 'news' - URI's. Fixes 636977. - - * uri.test: Added test to make sure that a URI can be split and - then joined. to make sure the change below works. - - * uri.tcl (uri::JoinHttpInner): Make this proc deal with - 'fragments' - i.e. the #foo part of a URI. Fixes 638075. - - * uri.test: Added tests relevant to the fix below. - - * uri.tcl (uri::resolve): Fix handling of queries so that the - 'new' query overrides the 'old' one. This is how browsers do it. - Fixes 639036. - -2002-06-05 Andreas Kupries - - * urn-scheme.tcl: Moved provide up to the front to prevent - problems with [pkg_mkIndex]. Added namespace creation commands - to the top for the same reason. - -2002-03-25 Andreas Kupries - - * uri.man: Fixed formatting errors in the doctools manpage. - -2002-02-25 Andreas Kupries - - * uri.tcl: Fixed "::uri::canonicalize" to pass the extended - testsuite. The change to testsuite and command implementation - here was triggered through work on a spider and real life urls, - some of which where handled incorrectly. - - * uri.test: Extended the testsuite for "::uri::canonicalize" a - lot. Handling of uris with a path, without a path, unknown uri - schemes, path components which contain a ".", but are neither - "." nor "..". - -2002-02-14 Andreas Kupries - - * urn-scheme.tcl: Frink run. - - * Version is now 1.1.1 to distinguish from the code in tcllib - release 1.2 - -2002-01-15 Andreas Kupries - - * Bumped version to 1.1 - -2001-11-16 Andreas Kupries - - * uri.n: Updated documentation to cover the change below. - - * uri.tcl: Changed geturl dispatcher to load a scheme::geturl - first and the scheme package only if that fails. See the ftp and - ftp::geturl packages. FR #476804. - -2001-10-31 Pat Thoyts - - * uri.tcl: Fixed the ftptype regexp so that the type identifier - can be extracted. Fixed the ftp join code to follow the specs - for the type identifier. Added tests. - -2001-10-31 Pat Thoyts - - * uri.tcl: Fixes for SF bug 474846 concerning bugs with ftp - userinfo and path construction. - - * uri.test: New tests to chec the above fixes. - -2001-10-21 Andreas Kupries - - * The changes below are made as part of accepting SF patch #470211 - provided by Pat Thoyts - - * uri.n: Documented "uri::register". - - * urn-scheme.tcl: Changed to use the new registration - command. Added declaration of "schemepart" as that variable is - required for the registration. - - * uri.tcl (uri::register): New command to register url - schemes. Rewrote the module to make use of this command when - declaring the standard schemes like ftp, http, ... Fixed a bug - in the url declarations (access to namespace basic was - incorrect). The command takes care to update the overall - variables tracking scheme information. - - * pkgIndex.tcl: Added the new sub-package to our package index. - - * urn.test: - * urn-scheme.tcl: New files, new sub-packages, provide the URN - schema for uri's and associated testsuite. - -2001-08-21 Don Porter - - * uri.n: Corrected title. The 'uri' package does not - provide "Tcl Built-In Commands." - -2001-07-10 Andreas Kupries - - * uri.tcl: Frink 2.2 run, fixed dubious code. - -2001-06-21 Andreas Kupries - - * uri.tcl: Fixed dubious code reported by frink. - -2000-09-06 Brent Welch - - * uri.tcl: - * uri.test: - Added https support - -2000-07-20 Eric Melski - - * uri.test: - * uri.tcl: Applied patch from Andreas Kupries, to correct infinite loop - condition in uri::canonicalize. - -2000-06-16 Eric Melski - - * uri.test: Fixed bad test, added tcltest::cleanupTests call. - -2000-06-13 Eric Melski - - * uri: initial import of uri package. - DELETED modules/uri/pkgIndex.tcl Index: modules/uri/pkgIndex.tcl ================================================================== --- modules/uri/pkgIndex.tcl +++ /dev/null @@ -1,6 +0,0 @@ -if {![package vsatisfies [package provide Tcl] 8.2]} { - # FRINK: nocheck - return -} -package ifneeded uri 1.1.2 [list source [file join $dir uri.tcl]] -package ifneeded uri::urn 1.0.1 [list source [file join $dir urn-scheme.tcl]] DELETED modules/uri/uri-rfc2396.test Index: modules/uri/uri-rfc2396.test ================================================================== --- modules/uri/uri-rfc2396.test +++ /dev/null @@ -1,200 +0,0 @@ -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} -set dirname [file dirname [info script]] -source [file join $dirname uri.tcl] -package require uri - -test uri-rfc2396-1.1 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p?q g:h] -} g:h - -test uri-rfc2396-1.2 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p?q g] -} http://a/b/c/g - -test uri-rfc2396-1.3 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ./g] -} http://a/b/c/g - -test uri-rfc2396-1.4 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p?q g/] -} http://a/b/c/g/ - -test uri-rfc2396-1.5 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p?q /g] -} http://a/g - -test uri-rfc2396-1.6 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p?q //g] -} http://g - -test uri-rfc2396-1.7 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ?y] -} http://a/b/c/?y - -test uri-rfc2396-1.8 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p?q g?y] -} http://a/b/c/g?y - -test uri-rfc2396-1.9 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p?q \#s] -} {(current document)\#s} - -test uri-rfc2396-1.10 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p?q g\#s] -} http://a/b/c/g\#s - -test uri-rfc2396-1.11 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p?q g?y\#s] -} http://a/b/c/g?y\#s - -test uri-rfc2396-1.12 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p?q \;x] -} http://a/b/c/\;x - -test uri-rfc2396-1.13 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p?q g\;x] -} http://a/b/c/g\;x - -test uri-rfc2396-1.14 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p?q g\;x?y#s] -} http://a/b/c/g\;x?y#s - -test uri-rfc2396-1.15 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p?q .] -} http://a/b/c/ - -test uri-rfc2396-1.16 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ./] -} http://a/b/c/ - -test uri-rfc2396-1.17 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ..] -} http://a/b/ - -test uri-rfc2396-1.18 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ../] -} http://a/b/ - -test uri-rfc2396-1.19 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ../g] -} http://a/b/g - -test uri-rfc2396-1.20 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ../..] -} http://a/ - -test uri-rfc2396-1.21 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ../../] -} http://a/ - -test uri-rfc2396-1.22 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ../../g] -} http://a/g - - -test uri-rfc2396-2.1 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p g:h] -} g:h - -test uri-rfc2396-2.2 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p g] -} http://a/b/c/g - -test uri-rfc2396-2.3 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p ./g] -} http://a/b/c/g - -test uri-rfc2396-2.4 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p g/] -} http://a/b/c/g/ - -test uri-rfc2396-2.5 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p /g] -} http://a/g - -test uri-rfc2396-2.6 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p //g] -} http://g - -test uri-rfc2396-2.7 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p ?y] -} http://a/b/c/?y - -test uri-rfc2396-2.8 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p g?y] -} http://a/b/c/g?y - -test uri-rfc2396-2.9 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p \#s] -} {(current document)\#s} - -test uri-rfc2396-2.10 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p g\#s] -} http://a/b/c/g\#s - -test uri-rfc2396-2.11 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p g?y\#s] -} http://a/b/c/g?y\#s - -test uri-rfc2396-2.12 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p \;x] -} http://a/b/c/\;x - -test uri-rfc2396-2.13 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p g\;x] -} http://a/b/c/g\;x - -test uri-rfc2396-2.14 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p g\;x?y#s] -} http://a/b/c/g\;x?y#s - -test uri-rfc2396-2.15 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p .] -} http://a/b/c/ - -test uri-rfc2396-2.16 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p ./] -} http://a/b/c/ - -test uri-rfc2396-2.17 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p ..] -} http://a/b/ - -test uri-rfc2396-2.18 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p ../] -} http://a/b/ - -test uri-rfc2396-2.19 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p ../g] -} http://a/b/g - -test uri-rfc2396-2.20 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p ../..] -} http://a/ - -test uri-rfc2396-2.21 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p ../../] -} http://a/ - -test uri-rfc2396-2.22 {uri::resolve} {knownBug sf-tcllib-bug-581781} { - uri::canonicalize [uri::resolve http://a/b/c/d\;p ../../g] -} http://a/g - - -#test uri-rfc2396-2. {uri::resolve} {knownBug sf-tcllib-bug-581781} { -# uri::resolve http://a/b/c/d\;p -#} - -# ------------------------------------------------------------------------- - -::tcltest::cleanupTests -return - -# ------------------------------------------------------------------------- -# Local Variables: -# mode: tcl -# indent-tabs-mode: nil -# End: DELETED modules/uri/uri.man Index: modules/uri/uri.man ================================================================== --- modules/uri/uri.man +++ /dev/null @@ -1,155 +0,0 @@ -[manpage_begin uri n 1.1.2] -[moddesc {Tcl Uniform Resource Identifier Management}] -[titledesc {URI utilities}] -[require Tcl 8.2] -[require uri [opt 1.1.2]] -[description] - -This package contains two parts. First it provides regular expressions -for a number of url/uri schemes. Second it provides a number of -commands for manipulating urls/uris and fetching data specified by -them. For the latter this package analyses the requested url/uri and -then dispatches it to the appropriate package (http, ftp, ...) for -actual fetching. - -[para] - -The package currently does not conform to -RFC 2396 ([uri http://www.rfc-editor.org/rfc/rfc2396.txt]), -but quite likely should be. Patches and other help are welcome. - - - -[section COMMANDS] - -[list_begin definitions] - -[call [cmd uri::split] [arg url] [opt [arg defaultscheme]]] - -[cmd uri::split] takes an [arg url], decodes it and then returns a -list of key/value pairs suitable for [cmd "array set"] containing the -constituents of the [arg url]. If the scheme is missing from the url -it defaults to the value of [arg defaultscheme] if it was specified, -or [term http] else. Currently only the schemes [term http], - -[term ftp], [term mailto], [term urn], [term news], and [term file] -are supported by the package itself. See section [sectref EXTENDING] -on how to expand that range. - - -[call [cmd uri::join] [opt "[arg key] [arg value]"]...] - -[cmd uri::join] takes a list of key/value pairs (generated by - -[cmd uri::split], for example) and returns the canonical url they -represent. Currently only the schemes [term http], [term ftp], -[term mailto], [term urn], [term news], and [term file] are -supported. See section [sectref EXTENDING] on how to expand that range. - - -[call [cmd uri::resolve] [arg base] [arg url]] - -[cmd uri::resolve] resolves the specified [arg url] relative to - -[arg base]. In other words: A non-relative [arg url] is returned -unchanged, whereas for a relative [arg url] the missing parts are -taken from [arg base] and prepended to it. The result of this -operation is returned. For an empty [arg url] the result is - -[arg base]. - - -[call [cmd uri::isrelative] [arg url]] - -[cmd uri::isrelative] determines whether the specified [arg url] is -absolute or relative. - - -[call [cmd uri::geturl] [arg url] [opt "[arg options]..."]] - -[cmd uri::geturl] decodes the specified [arg url] and then dispatches -the request to the package appropriate for the scheme found in the -url. The command assumes that the package to handle the given scheme -either has the same name as the scheme itself (including possible -capitalization) followed by [cmd ::geturl], or, in case of this -failing, has the same name as the scheme itself (including possible -capitalization). It further assumes that whatever package was loaded -provides a [cmd geturl]-command in the namespace of the same name as -the package itself. This command is called with the given [arg url] -and all given [arg options]. Currently [cmd geturl] does not handle -any options itself. - -[nl] - -[emph Note:] [term file]-urls are an exception to the rule -described above. They are handled internally. - -[nl] - -It is not possible to specify results of the command. They depend on -the [cmd geturl]-command for the scheme the request was dispatched to. - - -[call [cmd uri::canonicalize] [arg uri]] - -[cmd uri::canonicalize] returns the canonical form of a URI. The -canonical form of a URI is one where relative path specifications, -ie. . and .., have been resolved. - - -[call [cmd uri::register] [arg schemeList] [arg script]] - -[cmd uri::register] registers the first element of [arg schemeList] as -a new scheme and the remaining elements as aliases for this scheme. It -creates the namespace for the scheme and executes the [arg script] in -the new namespace. The script has to declare variables containing the -regular expressions relevant to the scheme. At least the variable -[var schemepart] has to be declared as that one is used to extend -the variables keeping track of the registered schemes. - -[list_end] - -[section SCHEMES] - -In addition to the commands mentioned above this package provides -regular expression to recognize urls for a number of url schemes. - -[para] - -For each supported scheme a namespace of the same name as the scheme -itself is provided inside of the namespace [emph uri] containing the -variable [var url] whose contents are a regular expression to -recognize urls of that scheme. Additional variables may contain -regular expressions for parts of urls for that scheme. - -[para] - -The variable [var uri::schemes] contains a list of all supported -schemes. Currently these are [term ftp], [term file], - -[term http], [term gopher], [term mailto], [term news], -[term wais] and [term prospero]. - -[section EXTENDING] - -Extending the range of schemes supported by [cmd uri::split] and - -[cmd uri::join] is easy because both commands do not handle the -request by themselves but dispatch it to another command in the -[emph uri] namespace using the scheme of the url as criterion. - -[para] - -[cmd uri::split] and [cmd uri::join] - -call [cmd "Split[lb]string totitle [rb]"] -and [cmd "Join[lb]string totitle [rb]"] respectively. - -[section CREDITS] -[para] - -Original code (regular expressions) by Andreas Kupries. -Modularisation by Steve Ball, also the split/join/resolve functionality. - -[keywords uri url {fetching information} www http ftp mailto news gopher wais prospero file {rfc 2396}] -[manpage_end] DELETED modules/uri/uri.n Index: modules/uri/uri.n ================================================================== --- modules/uri/uri.n +++ /dev/null @@ -1,117 +0,0 @@ -'\" -'\" Copyright (c) 2000 Andreas Kupries -'\" Copyright (c) 2000 Zveno Pty Ltd -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -'\" SCCS: @(#) uri.n -'\" -.so man.macros -.TH "uri" n 1.1.1 Tcl "Tcl Uniform Resource Identifier Management" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -uri \- URI utilities -.SH "SYNOPSIS" -\fBpackage require Tcl 8.2\fR -.sp -\fBpackage require uri ?1.1.1?\fR -.sp -\fB uri::split \fIurl\fR -\fB uri::join \fR?\fIkey\fR \fIvalue\fR?... -\fB uri::resolve \fIbase\fR \fIurl\fR -\fB uri::isrelative \fIurl\fR -\fB uri::geturl \fIurl\fR ?\fIoptions\fR...? -\fB uri::canonicalize \fIuri\fR -\fB uri::register \fIschemeList\fR \fIscript\fR -.BE -.SH "DESCRIPTION" -.PP -This package contains two parts. First it provides regular expressions -for a number of url/uri schemes. Second it provides a number of -commands for manipulating urls/uris and fetching data specified by -them. For the latter this package analyses the requested url/uri and -then dispatches it to the appropriate package (http, ftp, ...) for -actual fetching. -.SH "COMMANDS" -\fBuri::split\fR takes a single \fIurl\fR, decodes it and then returns -a list of key/value pairs suitable for \fBarray set\fR containing -the constituents of the \fIurl\fR. If the scheme is missing from the -url it defaults to \fBhttp\fR. Currently only the schemes -\fBhttp\fR, \fBftp\fR, \fBmailto\fR, \fBurn\fR and \fBfile\fR are -supported. See section EXTENDING on how to expand that range. -.PP -\fBuri::join\fR takes a list of key/value pairs (generated by -\fBuri::split\fR, for example) and returns the canonical url they -represent. Currently only the schemes \fBhttp\fR, \fBftp\fR, -\fBmailto\fR, \fBurn\fR and \fBfile\fR are supported. See section -EXTENDING on how to expand that range. -.PP -\fBuri::isrelative\fR determines whether the specified \fIurl\fR is -absolute or relative. -.PP -\fBuri::resolve\fR resolves the specified \fIurl\fR relative to -\fIbase\fR. In other words: A non-relative \fIurl\fR is returned -unchanged, whereas for a relative \fIurl\fR the missing parts are -taken from \fIbase\fR and prepended to it. The result of this -operation is returned. For an empty \fIurl\fR the result is -\fIbase\fR. -.PP -\fBuri::geturl\fR decodes the specified \fIurl\fR and then dispatches -the request to the package appropriate for the scheme found in the -url. The command assumes that the package to handle the given scheme -either has the same name as the scheme itself (including possible -capitalization) followed by \fB::geturl\fR, or, in case of this -failing, has the same name as the scheme itself (including possible -capitalization). It further assumes that whatever package was loaded -provides a \fBgeturl\fR-command in the namespace of the same name as -the package itself. This command is called with the given \fIurl\fR -and all given \fIoptions\fR. Currently \fBgeturl\fR does not handle -any options itself. -.PP -\fBNote:\fR \fBfile\fR-urls are an exception to the rule described -above. They are handled internally. -.PP -It is not possible to specify results of the command. They depend on -the \fBgeturl\fR-command for the scheme the request was dispatched to. -.PP -\fBuri::canonicalize\fR returns the canonical form of a URI. -The canonical form of a URI is one where relative path specifications, -ie. . and .., have been resolved. -.PP -\fBuri::register\fR registers the first element of \fIschemeList\fR as -a new scheme and the remaining elements as aliases for this scheme. It -creates the namespace for the scheme and executes the \fIscript\fR in -the new namespace. The script has to declare variables containing the -regular expressions relevant to the scheme. At least the variable -\fBschemepart\fR has to be declared as that one is used to extend the -variables keeping track of the registered schemes. -.SH "SCHEMES" -In addition to the commands mentioned above this package provides -regular expression to recognize urls for a number of url schemes. -.PP -For each supported scheme a namespace of the same name as the scheme -itself is provided inside of the namespace \fBuri\fR containing the -variable \fBurl\fR whose contents are a regular expression to -recognize urls of that scheme. Additional variables may contain -regular expressions for parts of urls for that scheme. -.PP -The variable \fBuri::schemes\fR contains a list of all supported -schemes. Currently these are \fBftp\fR, \fBfile\fR, \fBhttp\fR, -\fBgopher\fR, \fBmailto\fR, \fBnews\fR, \fBwais\fR and -\fBprospero\fR. -.SH "EXTENDING" -Extending the range of schemes supported by \fBuri::split\fR and -\fBuri::join\fR is easy because both commands do not handle the -request by themselves but dispatch it to another command in the -\fBuri\fR namespace using the scheme of the url as criterion. -.PP -\fBuri:split\fR and \fBuri:join\fR call Split[string totitle ] -and Join[string totitle ] respectively. -.SH "SEE ALSO" -.SH "CREDITS" -Original code by Andreas Kupries. Modularisation by Steve Ball. -.PP -.SH "KEYWORDS" -uri, url, fetching information, www, http, ftp, mailto, gopher, wais, prospero, file DELETED modules/uri/uri.tcl Index: modules/uri/uri.tcl ================================================================== --- modules/uri/uri.tcl +++ /dev/null @@ -1,921 +0,0 @@ -# uri.tcl -- -# -# URI parsing and fetch -# -# Copyright (c) 2000 Zveno Pty Ltd -# Steve Ball, http://www.zveno.com/ -# Derived from urls.tcl by Andreas Kupries -# -# TODO: -# Handle www-url-encoding details -# -# CVS: $Id: uri.tcl,v 1.22 2003/04/14 20:15:51 andreas_kupries Exp $ - -package require Tcl 8.2 - -namespace eval ::uri { - - namespace export split join - namespace export resolve isrelative - namespace export geturl - namespace export canonicalize - namespace export register - - variable file:counter 0 - - # extend these variable in the coming namespaces - variable schemes {} - variable schemePattern "" - variable url "" - variable url2part - array set url2part {} - - # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # basic regular expressions used in URL syntax. - - namespace eval basic { - variable loAlpha {[a-z]} - variable hiAlpha {[A-Z]} - variable digit {[0-9]} - variable alpha {[a-zA-Z]} - variable safe {[$_.+-]} - variable extra {[!*'(,)]} - # danger in next pattern, order important for [] - variable national {[][|\}\{\^~`]} - variable punctuation {[<>#%"]} ;#" fake emacs hilit - variable reserved {[;/?:@&=]} - variable hex {[0-9A-Fa-f]} - variable alphaDigit {[A-Za-z0-9]} - variable alphaDigitMinus {[A-Za-z0-9-]} - - # next is - variable unsafe {[][<>"#%\{\}|\\^~`]} ;#" emacs hilit - variable escape "%${hex}${hex}" - - # unreserved = alpha | digit | safe | extra - # xchar = unreserved | reserved | escape - - variable unreserved {[a-zA-Z0-9$_.+!*'(,)-]} - variable uChar "(${unreserved}|${escape})" - variable xCharN {[a-zA-Z0-9$_.+!*'(,);/?:@&=-]} - variable xChar "(${xCharN}|${escape})" - variable digits "${digit}+" - - variable toplabel \ - "(${alpha}${alphaDigitMinus}*${alphaDigit}|${alpha})" - variable domainlabel \ - "(${alphaDigit}${alphaDigitMinus}*${alphaDigit}|${alphaDigit})" - - variable hostname \ - "((${domainlabel}\\.)*${toplabel})" - variable hostnumber \ - "(${digits}\\.${digits}\\.${digits}\\.${digits})" - - variable host "(${hostname}|${hostnumber})" - - variable port $digits - variable hostOrPort "${host}(:${port})?" - - variable usrCharN {[a-zA-Z0-9$_.+!*'(,);?&=-]} - variable usrChar "(${usrCharN}|${escape})" - variable user "${usrChar}*" - variable password $user - variable login "(${user}(:${password})?@)?${hostOrPort}" - } ;# basic {} -} - - -# ::uri::register -- -# -# Register a scheme (and aliases) in the package. The command -# creates a namespace below "::uri" with the same name as the -# scheme and executes the script declaring the pattern variables -# for this scheme in the new namespace. At last it updates the -# uri variables keeping track of overall scheme information. -# -# The script has to declare at least the variable "schemepart", -# the pattern for an url of the registered scheme after the -# scheme declaration. Not declaring this variable is an error. -# -# Arguments: -# schemeList Name of the scheme to register, plus aliases -# script Script declaring the scheme patterns -# -# Results: -# None. - -proc ::uri::register {schemeList script} { - variable schemes - variable schemePattern - variable url - variable url2part - - # Check scheme and its aliases for existence. - foreach scheme $schemeList { - if {[lsearch -exact $schemes $scheme] >= 0} { - return -code error \ - "trying to register scheme (\"$scheme\") which is already known" - } - } - - # Get the main scheme - set scheme [lindex $schemeList 0] - - if {[catch {namespace eval $scheme $script} msg]} { - catch {namespace delete $scheme} - return -code error \ - "error while evaluating scheme script: $msg" - } - - if {![info exists ${scheme}::schemepart]} { - namespace delete $scheme - return -code error \ - "Variable \"schemepart\" is missing." - } - - # Now we can extend the variables which keep track of the registered schemes. - - eval lappend schemes $schemeList - set schemePattern "([::join $schemes |]):" - - foreach s schemeList { - # FRINK: nocheck - set url2part($s) "${s}:[set ${scheme}::schemepart]" - # FRINK: nocheck - append url "(${s}:[set ${scheme}::schemepart])|" - } - set url [string trimright $url |] - return -} - -# ::uri::split -- -# -# Splits the given into its constituents. -# -# Arguments: -# url the URL to split -# -# Results: -# Tcl list containing constituents, suitable for 'array set'. - -proc ::uri::split {url {defaultscheme http}} { - - set url [string trim $url] - set scheme {} - - # RFC 1738: scheme = 1*[ lowalpha | digit | "+" | "-" | "." ] - regexp -- {^([a-z0-9+.-][a-z0-9+.-]*):} $url dummy scheme - - if {$scheme == {}} { - set scheme $defaultscheme - } - - # ease maintenance: dynamic dispatch, able to handle all schemes - # added in future! - - if {[::info procs Split[string totitle $scheme]] == {}} { - error "unknown scheme '$scheme' in '$url'" - } - - regsub -- "^${scheme}:" $url {} url - - set parts(scheme) $scheme - array set parts [Split[string totitle $scheme] $url] - - # should decode all encoded characters! - - return [array get parts] -} - -proc ::uri::SplitFtp {url} { - # @c Splits the given ftp- into its constituents. - # @a url: The url to split, without! scheme specification. - # @r List containing the constituents, suitable for 'array set'. - - # general syntax: - # //:@://...//;type= - # - # additional rules: - # - # : are optional, detectable by presence of @. - # is optional too. - # - # "//" [ [":" ] "@"] [":" ] "/" - # "/" ..."/" "/" [";type=" ] - - upvar \#0 [namespace current]::ftp::typepart ftptype - - array set parts {user {} pwd {} host {} port {} path {} type {}} - - # slash off possible type specification - - if {[regexp -indices -- "${ftptype}$" $url dummy ftype]} { - - set from [lindex $ftype 0] - set to [lindex $ftype 1] - - set parts(type) [string range $url $from $to] - - set from [lindex $dummy 0] - set url [string replace $url $from end] - } - - # Handle user, password, host and port - - if {[string match "//*" $url]} { - set url [string range $url 2 end] - - array set parts [GetUPHP url] - } - - set parts(path) [string trimleft $url /] - - return [array get parts] -} - -proc ::uri::JoinFtp args { - array set components { - user {} pwd {} host {} port {} - path {} type {} - } - array set components $args - - set userPwd {} - if {[string length $components(user)] || [string length $components(pwd)]} { - set userPwd $components(user)[expr {[string length $components(pwd)] ? ":$components(pwd)" : {}}]@ - } - - set port {} - if {[string length $components(port)]} { - set port :$components(port) - } - - set type {} - if {[string length $components(type)]} { - set type \;type=$components(type) - } - - return ftp://${userPwd}$components(host)${port}/[string trimleft $components(path) /]$type -} - -proc ::uri::SplitHttps {url} { - uri::SplitHttp $url -} - -proc ::uri::SplitHttp {url} { - # @c Splits the given http- into its constituents. - # @a url: The url to split, without! scheme specification. - # @r List containing the constituents, suitable for 'array set'. - - # general syntax: - # //:/? - # - # where and are as described in Section 3.1. If : - # is omitted, the port defaults to 80. No user name or password is - # allowed. is an HTTP selector, and is a query - # string. The is optional, as is the and its - # preceding "?". If neither nor is present, the "/" - # may also be omitted. - # - # Within the and components, "/", ";", "?" are - # reserved. The "/" character may be used within HTTP to designate a - # hierarchical structure. - # - # path == "/" ..."/" "/" ["#" ] - - upvar #0 [namespace current]::http::search search - upvar #0 [namespace current]::http::segment segment - - array set parts {host {} port {} path {} query {}} - - set searchPattern "\\?(${search})\$" - set fragmentPattern "#(${segment})\$" - - # slash off possible query - - if {[regexp -indices -- $searchPattern $url match query]} { - set from [lindex $query 0] - set to [lindex $query 1] - - set parts(query) [string range $url $from $to] - - set url [string replace $url [lindex $match 0] end] - } - - # slash off possible fragment - - if {[regexp -indices -- $fragmentPattern $url match fragment]} { - set from [lindex $fragment 0] - set to [lindex $fragment 1] - - set parts(fragment) [string range $url $from $to] - - set url [string replace $url [lindex $match 0] end] - } - - if {[string match "//*" $url]} { - set url [string range $url 2 end] - - array set parts [GetHostPort url] - } - - set parts(path) [string trimleft $url /] - - return [array get parts] -} - -proc ::uri::JoinHttp {args} { - eval uri::JoinHttpInner http 80 $args -} - -proc ::uri::JoinHttps {args} { - eval uri::JoinHttpInner https 443 $args -} - -proc ::uri::JoinHttpInner {scheme defport args} { - array set components [list \ - host {} port $defport path {} query {} \ - ] - array set components $args - - set port {} - if {[string length $components(port)] && $components(port) != $defport} { - set port :$components(port) - } - - set query {} - if {[string length $components(query)]} { - set query ?$components(query) - } - - regsub -- {^/} $components(path) {} components(path) - - if { [info exists components(fragment)] && $components(fragment) != "" } { - set components(fragment) "#$components(fragment)" - } else { - set components(fragment) "" - } - - return $scheme://$components(host)$port/$components(path)$components(fragment)$query -} - -proc ::uri::SplitFile {url} { - # @c Splits the given file- into its constituents. - # @a url: The url to split, without! scheme specification. - # @r List containing the constituents, suitable for 'array set'. - - upvar #0 [namespace current]::basic::hostname hostname - upvar #0 [namespace current]::basic::hostnumber hostnumber - - if {[string match "//*" $url]} { - set url [string range $url 2 end] - - set hostPattern "^($hostname|$hostnumber)" - switch -exact -- $::tcl_platform(platform) { - windows { - # Catch drive letter - append hostPattern :? - } - default { - # Proceed as usual - } - } - - if {[regexp -indices -- $hostPattern $url match host]} { - set fh [lindex $host 0] - set th [lindex $host 1] - - set parts(host) [string range $url $fh $th] - - set matchEnd [lindex $match 1] - incr matchEnd - - set url [string range $url $matchEnd end] - } - } - - set parts(path) $url - - return [array get parts] -} - -proc ::uri::JoinFile args { - array set components { - host {} port {} path {} - } - array set components $args - - switch -exact -- $::tcl_platform(platform) { - windows { - if {[string length $components(host)]} { - return file://$components(host):$components(path) - } else { - return file://$components(path) - } - } - default { - return file://$components(host)$components(path) - } - } -} - -proc ::uri::SplitMailto {url} { - # @c Splits the given mailto- into its constituents. - # @a url: The url to split, without! scheme specification. - # @r List containing the constituents, suitable for 'array set'. - - if {[string match "*@*" $url]} { - set url [::split $url @] - return [list user [lindex $url 0] host [lindex $url 1]] - } else { - return [list user $url] - } -} - -proc ::uri::JoinMailto args { - array set components { - user {} host {} - } - array set components $args - - return mailto:$components(user)@$components(host) -} - -proc ::uri::SplitNews {url} { - if { [string first @ $url] >= 0 } { - return [list message-id $url] - } else { - return [list newsgroup-name $url] - } -} - -proc ::uri::JoinNews args { - array set components { - message-id {} newsgroup-name {} - } - array set components $args - return news:$components(message-id)$components(newsgroup-name) -} - -proc ::uri::GetUPHP {urlvar} { - # @c Parse user, password host and port out of the url stored in - # @c variable . - # @d Side effect: The extracted information is removed from the given url. - # @r List containing the extracted information in a format suitable for - # @r 'array set'. - # @a urlvar: Name of the variable containing the url to parse. - - upvar \#0 [namespace current]::basic::user user - upvar \#0 [namespace current]::basic::password password - upvar \#0 [namespace current]::basic::hostname hostname - upvar \#0 [namespace current]::basic::hostnumber hostnumber - upvar \#0 [namespace current]::basic::port port - - upvar $urlvar url - - array set parts {user {} pwd {} host {} port {}} - - # syntax - # "//" [ [":" ] "@"] [":" ] "/" - # "//" already cut off by caller - - set upPattern "^(${user})(:(${password}))?@" - - if {[regexp -indices -- $upPattern $url match theUser c d thePassword]} { - set fu [lindex $theUser 0] - set tu [lindex $theUser 1] - - set fp [lindex $thePassword 0] - set tp [lindex $thePassword 1] - - set parts(user) [string range $url $fu $tu] - set parts(pwd) [string range $url $fp $tp] - - set matchEnd [lindex $match 1] - incr matchEnd - - set url [string range $url $matchEnd end] - } - - set hpPattern "^($hostname|$hostnumber)(:($port))?" - - if {[regexp -indices -- $hpPattern $url match theHost c d e f g h thePort]} { - set fh [lindex $theHost 0] - set th [lindex $theHost 1] - - set fp [lindex $thePort 0] - set tp [lindex $thePort 1] - - set parts(host) [string range $url $fh $th] - set parts(port) [string range $url $fp $tp] - - set matchEnd [lindex $match 1] - incr matchEnd - - set url [string range $url $matchEnd end] - } - - return [array get parts] -} - -proc ::uri::GetHostPort {urlvar} { - # @c Parse host and port out of the url stored in variable . - # @d Side effect: The extracted information is removed from the given url. - # @r List containing the extracted information in a format suitable for - # @r 'array set'. - # @a urlvar: Name of the variable containing the url to parse. - - upvar #0 [namespace current]::basic::hostname hostname - upvar #0 [namespace current]::basic::hostnumber hostnumber - upvar #0 [namespace current]::basic::port port - - upvar $urlvar url - - set pattern "^(${hostname}|${hostnumber})(:(${port}))?" - - if {[regexp -indices -- $pattern $url match host c d e f g h thePort]} { - set fromHost [lindex $host 0] - set toHost [lindex $host 1] - - set fromPort [lindex $thePort 0] - set toPort [lindex $thePort 1] - - set parts(host) [string range $url $fromHost $toHost] - set parts(port) [string range $url $fromPort $toPort] - - set matchEnd [lindex $match 1] - incr matchEnd - - set url [string range $url $matchEnd end] - } - - return [array get parts] -} - -# ::uri::resolve -- -# -# Resolve an arbitrary URL, given a base URL -# -# Arguments: -# base base URL (absolute) -# url arbitrary URL -# -# Results: -# Returns a URL - -proc ::uri::resolve {base url} { - if {[string length $url]} { - if {[isrelative $url]} { - - array set baseparts [split $base] - - switch -- $baseparts(scheme) { - http - - https - - ftp - - file { - array set relparts [split $url] - if { [string match /* $url] } { - catch { set baseparts(path) $relparts(path) } - } elseif { [string match */ $baseparts(path)] } { - set baseparts(path) "$baseparts(path)$relparts(path)" - } else { - if { [string length $relparts(path)] > 0 } { - set path [lreplace [::split $baseparts(path) /] end end] - set baseparts(path) "[::join $path /]/$relparts(path)" - } - } - catch { set baseparts(query) $relparts(query) } - catch { set baseparts(fragment) $relparts(fragment) } - return [eval join [array get baseparts]] - } - default { - return -code error "unable to resolve relative URL \"$url\"" - } - } - - } else { - return $url - } - } else { - return $base - } -} - -# ::uri::isrelative -- -# -# Determines whether a URL is absolute or relative -# -# Arguments: -# url URL to check -# -# Results: -# Returns 1 if the URL is relative, 0 otherwise - -proc ::uri::isrelative url { - return [expr {![regexp -- {^[a-z0-9+-.][a-z0-9+-.]*:} $url]}] -} - -# ::uri::geturl -- -# -# Fetch the data from an arbitrary URL. -# -# This package provides a handler for the file: -# scheme, since this conflicts with the file command. -# -# Arguments: -# url address of data resource -# args configuration options -# -# Results: -# Depends on scheme - -proc ::uri::geturl {url args} { - array set urlparts [split $url] - - switch -- $urlparts(scheme) { - file { - return [eval file_geturl [list $url] $args] - } - default { - # Load a geturl package for the scheme first and only if - # that fails the scheme package itself. This prevents - # cyclic dependencies between packages. - if {[catch {package require $urlparts(scheme)::geturl}]} { - package require $urlparts(scheme) - } - return [eval [list $urlparts(scheme)::geturl $url] $args] - } - } -} - -# ::uri::file_geturl -- -# -# geturl implementation for file: scheme -# -# TODO: -# This is an initial, basic implementation. -# Eventually want to support all options for geturl. -# -# Arguments: -# url URL to fetch -# args configuration options -# -# Results: -# Returns data from file - -proc ::uri::file_geturl {url args} { - variable file:counter - - set var [namespace current]::file[incr file:counter] - upvar #0 $var state - array set state {data {}} - - array set parts [split $url] - - set ch [open $parts(path)] - # Could determine text/binary from file extension, - # except on Macintosh - # fconfigure $ch -translation binary - set state(data) [read $ch] - close $ch - - return $var -} - -# ::uri::join -- -# -# Format a URL -# -# Arguments: -# args components, key-value format -# -# Results: -# A URL - -proc ::uri::join args { - array set components $args - - return [eval [list Join[string totitle $components(scheme)]] $args] -} - -# ::uri::canonicalize -- -# -# Canonicalize a URL -# -# Acknowledgements: -# Andreas Kupries, a.kupries@westend.com -# -# Arguments: -# uri URI (which contains a path component) -# -# Results: -# The canonical form of the URI - -proc ::uri::canonicalize uri { - - # Make uri canonical with respect to dots (path changing commands) - # - # Remove single dots (.) => pwd not changing - # Remove double dots (..) => gobble previous segment of path - # - # Fixes for this command: - # - # * Ignore any url which cannot be split into components by this - # module. Just assume that such urls do not have a path to - # canonicalize. - # - # * Ignore any url which could be split into components, but does - # not have a path component. - # - # In the text above 'ignore' means - # 'return the url unchanged to the caller'. - - if {[catch {array set u [uri::split $uri]}]} { - return $uri - } - if {![info exists u(path)]} { - return $uri - } - - set uri $u(path) - - # Remove leading "./" "../" "/.." (and "/../") - regsub -all -- {^(\./)+} $uri {} uri - regsub -all -- {^/(\.\./)+} $uri {/} uri - regsub -all -- {^(\.\./)+} $uri {} uri - - # Remove inner /./ and /../ - while {[regsub -all -- {/\./} $uri {/} uri]} {} - while {[regsub -all -- {/[^/]+/\.\./} $uri {/} uri]} {} - while {[regsub -all -- {^[^/]+/\.\./} $uri {} uri]} {} - # Munge trailing /.. - while {[regsub -all -- {/[^/]+/\.\.} $uri {/} uri]} {} - if { $uri == ".." } { set uri "/" } - - set u(path) $uri - set uri [eval uri::join [array get u]] - - return $uri -} - -# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -# regular expressions covering various url schemes - -# Currently known URL schemes: -# -# (RFC 1738) -# ------------------------------------------------ -# scheme basic syntax of scheme specific part -# ------------------------------------------------ -# ftp //:@://...//;type= -# -# http //:/? -# -# gopher //:/ -# %09 -# %09%09 -# -# mailto -# news -# -# nntp //:// -# telnet //:@:/ -# wais //:/ -# //:/? -# //:/// -# file /// -# prospero //:/;= -# ------------------------------------------------ -# -# (RFC 2111) -# ------------------------------------------------ -# scheme basic syntax of scheme specific part -# ------------------------------------------------ -# mid message-id -# message-id/content-id -# cid content-id -# ------------------------------------------------ - -# FTP -uri::register ftp { - set escape [set [namespace parent [namespace current]]::basic::escape] - set login [set [namespace parent [namespace current]]::basic::login] - - variable charN {[a-zA-Z0-9$_.+!*'(,)?:@&=-]} - variable char "(${charN}|${escape})" - variable segment "${char}*" - variable path "${segment}(/${segment})*" - - variable type {[AaDdIi]} - variable typepart ";type=(${type})" - variable schemepart \ - "//${login}(/${path}(${typepart})?)?" - - variable url "ftp:${schemepart}" -} - -# FILE -uri::register file { - set host [set [namespace parent [namespace current]]::basic::host] - set path [set [namespace parent [namespace current]]::ftp::path] - - variable schemepart "//(${host}|localhost)?/${path}" - variable url "file:${schemepart}" -} - -# HTTP -uri::register http { - set escape [set [namespace parent [namespace current]]::basic::escape] - set hostOrPort [set [namespace parent [namespace current]]::basic::hostOrPort] - - variable charN {[a-zA-Z0-9$_.+!*'(,);:@&=-]} - variable char "($charN|${escape})" - variable segment "${char}*" - - variable path "${segment}(/${segment})*" - variable search $segment - variable schemepart \ - "//${hostOrPort}(/${path}(\\?${search})?)?" - - variable url "http:${schemepart}" -} - -# GOPHER -uri::register gopher { - set xChar [set [namespace parent [namespace current]]::basic::xChar] - set hostOrPort [set [namespace parent [namespace current]]::basic::hostOrPort] - set search [set [namespace parent [namespace current]]::http::search] - - variable type $xChar - variable selector "$xChar*" - variable string $selector - variable schemepart \ - "//${hostOrPort}(/(${type}(${selector}(%09${search}(%09${string})?)?)?)?)?" - variable url "gopher:${schemepart}" -} - -# MAILTO -uri::register mailto { - set xChar [set [namespace parent [namespace current]]::basic::xChar] - set host [set [namespace parent [namespace current]]::basic::host] - - variable schemepart "$xChar+(@${host})?" - variable url "mailto:${schemepart}" -} - -# NEWS -uri::register news { - set escape [set [namespace parent [namespace current]]::basic::escape] - set alpha [set [namespace parent [namespace current]]::basic::alpha] - set host [set [namespace parent [namespace current]]::basic::host] - - variable aCharN {[a-zA-Z0-9$_.+!*'(,);/?:&=-]} - variable aChar "($aCharN|${escape})" - variable gChar {[a-zA-Z0-9$_.+-]} - variable newsgroup-name "${alpha}${gChar}*" - variable message-id "${aChar}+@${host}" - variable schemepart "\\*|${newsgroup-name}|${message-id}" - variable url "news:${schemepart}" -} - -# WAIS -uri::register wais { - set uChar [set [namespace parent [namespace current]]::basic::xChar] - set hostOrPort [set [namespace parent [namespace current]]::basic::hostOrPort] - set search [set [namespace parent [namespace current]]::http::search] - - variable db "${uChar}*" - variable type "${uChar}*" - variable path "${uChar}*" - - variable database "//${hostOrPort}/${db}" - variable index "//${hostOrPort}/${db}\\?${search}" - variable doc "//${hostOrPort}/${db}/${type}/${path}" - - #variable schemepart "${doc}|${index}|${database}" - - variable schemepart \ - "//${hostOrPort}/${db}((\\?${search})|(/${type}/${path}))?" - - variable url "wais:${schemepart}" -} - -# PROSPERO -uri::register prospero { - set escape [set [namespace parent [namespace current]]::basic::escape] - set hostOrPort [set [namespace parent [namespace current]]::basic::hostOrPort] - set path [set [namespace parent [namespace current]]::ftp::path] - - variable charN {[a-zA-Z0-9$_.+!*'(,)?:@&-]} - variable char "(${charN}|$escape)" - - variable fieldname "${char}*" - variable fieldvalue "${char}*" - variable fieldspec ";${fieldname}=${fieldvalue}" - - variable schemepart "//${hostOrPort}/${path}(${fieldspec})*" - variable url "prospero:$schemepart" -} - -package provide uri 1.1.2 DELETED modules/uri/uri.test Index: modules/uri/uri.test ================================================================== --- modules/uri/uri.test +++ /dev/null @@ -1,435 +0,0 @@ -# Tests for the uri module. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 2000 by Zveno Pty Ltd. -# -# RCS: @(#) $Id: uri.test,v 1.16 2003/04/11 21:01:29 andreas_kupries Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} -set dirname [file dirname [info script]] -source [file join $dirname uri.tcl] -package require uri - -puts "uri [package present uri]" - -# Take a key-value list and return list sorted by key, -# but with corresponding values staying with their key -proc kvsort args { - array set arr $args - set result {} - foreach key [lsort [array names arr]] { - lappend result $key $arr($key) - } - return $result -} - -# ------------------------------------------------------------------------- -# Split tests - -test uri-1.1 {uri::split - http w/- query} { - eval kvsort [uri::split http://test.net/path/path2?query] -} {host test.net path path/path2 port {} query query scheme http} - -test uri-1.2 {uri::split - https w/- query} { - eval kvsort [uri::split https://test.net/path/path2?query] -} {host test.net path path/path2 port {} query query scheme https} - -test uri-1.3 {uri::split - http w/- port} { - eval kvsort [uri::split http://test.net:8080] -} {host test.net path {} port 8080 query {} scheme http} - -test uri-1.4 {uri::split - https w/- port} { - eval kvsort [uri::split https://test.net:8888] -} {host test.net path {} port 8888 query {} scheme https} - -test uri-1.5 {uri::split - ftp} { - eval kvsort [uri::split ftp://ftp.test.net/path/to/resource] -} {host ftp.test.net path path/to/resource port {} pwd {} scheme ftp type {} user {}} - -test uri-1.6 {uri::split - ftp with userinfo} { - eval kvsort [uri::split {ftp://user:passwd@localhost/a/b/c.d}] -} {host localhost path a/b/c.d port {} pwd passwd scheme ftp type {} user user} - -test uri-1.7 {uri::split - ftp with type} { - eval kvsort [uri::split {ftp://localhost/a/b/c.d;type=i}] -} {host localhost path a/b/c.d port {} pwd {} scheme ftp type i user {}} - -test uri-1.8 {uri::split - ftp with port} { - eval kvsort [uri::split {ftp://localhost:21/a/b/c.d}] -} {host localhost path a/b/c.d port 21 pwd {} scheme ftp type {} user {}} - -test uri-1.9 {uri::split - news with message-id} { - eval kvsort [uri::split {news:87lm40t3v7.fsf@dedasys.com}] -} {message-id 87lm40t3v7.fsf@dedasys.com scheme news} - -test uri-1.10 {uri::split - news with newsgroup-name} { - eval kvsort [uri::split {news:comp.lang.tcl}] -} {newsgroup-name comp.lang.tcl scheme news} - -# ------------------------------------------------------------------------- - -test uri-2.1 {uri::join - http} { - uri::join scheme http path / host www.w3.org -} http://www.w3.org/ - -test uri-2.2 {uri::join - https} { - uri::join scheme https path / host www.w3.org -} https://www.w3.org/ - -test uri-2.3 {uri::join - http w/- query} { - uri::join scheme http query abc=def&ghi=jkl host www.test.net path /path/ -} http://www.test.net/path/?abc=def&ghi=jkl - -test uri-2.4 {uri::join - https w/- query} { - uri::join scheme https query abc=def&ghi=jkl host www.test.net path /path/ -} https://www.test.net/path/?abc=def&ghi=jkl - -test uri-2.5 {uri::join - http w/- port} { - uri::join scheme http port 8080 host www.test.net path /path/ -} http://www.test.net:8080/path/ - -test uri-2.6 {uri::join - https w/- port} { - uri::join scheme https port 8888 host www.test.net path /path/ -} https://www.test.net:8888/path/ - -test uri-2.7 {uri::join - ftp} { - uri::join host ftp.test.net path /my/file scheme ftp -} ftp://ftp.test.net/my/file - -test uri-2.8 {uri::join - identity function} { - eval uri::join [uri::split http://www.w3.org/XML/?abc=def] -} http://www.w3.org/XML/?abc=def - -test uri-2.9 {uri::join - ftp userinfo check} { - eval uri::join scheme ftp host localhost port 21 path /filename user user pwd passwd -} {ftp://user:passwd@localhost:21/filename} - -test uri-2.10 {uri::join - ftp userinfo check with no passwd} { - eval uri::join scheme ftp host localhost path /filename user user -} {ftp://user@localhost/filename} - -test uri-2.11 {uri::join - ftp path prefix} { - eval uri::join scheme ftp host localhost path a/b/c.d -} ftp://localhost/a/b/c.d - -test uri-2.12 {uri::join - ftp w/- image type} { - eval uri::join scheme ftp host localhost path a/b/c.d type i -} {ftp://localhost/a/b/c.d;type=i} - -test uri-2.13 {uri::join - ftp w/- ascii type} { - eval uri::join scheme ftp host localhost path a/b/c.d type a -} {ftp://localhost/a/b/c.d;type=a} - -# I am not sure that this shouldn't produce an error. The semi-colon is -# reserved so in this case with an invalid suffix the semi-colon should -# probably be quoted. [PT] -test uri-2.14 {uri::join - ftp w/- invalid type} { - eval uri::join scheme ftp host localhost path a/b/c.d type X -} {ftp://localhost/a/b/c.d;type=X} - -test uri-2.15 {uri::join - news message-id} { - eval uri::join scheme news message-id 87lm40t3v7.fsf@dedasys.com -} {news:87lm40t3v7.fsf@dedasys.com} - -test uri-2.16 {uri::join - news newsgroup-name} { - eval uri::join scheme news newsgroup-name comp.lang.tcl -} {news:comp.lang.tcl} - - -# ------------------------------------------------------------------------- - -test uri-3.1 {uri::resolve - relative URL, base trailing slash} { - uri::resolve http://www.w3.org/path/ test.html -} http://www.w3.org/path/test.html - -test uri-3.2 {uri::resolve - relative URL path, base trailing slash} { - uri::resolve http://www.w3.org/path/ relpath/test.html -} http://www.w3.org/path/relpath/test.html - -test uri-3.3 {uri::resolve - relative URL, base no trailing slash} { - uri::resolve http://www.w3.org/path test.html -} http://www.w3.org/test.html - -test uri-3.4 {uri::resolve - relative URL path, base no trailing slash} { - uri::resolve http://www.w3.org/path relpath/test.html -} http://www.w3.org/relpath/test.html - -test uri-3.5 {uri::resolve - relative URL w/- query} { - uri::resolve http://www.w3.org/path/ test.html?abc=def -} http://www.w3.org/path/test.html?abc=def - -test uri-3.6 {uri::resolve - absolute URL} { - uri::resolve http://www.w3.org/path/ http://test.net/test.html -} http://test.net/test.html - -test uri-3.7 {uri::resolve - two queries - one sans path} { - uri::resolve http://www.example.com/foo/bar.rvt?foo=bar ?shoo=bee -} http://www.example.com/foo/bar.rvt?shoo=bee - -test uri-3.8 {uri::resolve - two queries} { - uri::resolve http://www.example.com/baz/?foo=bar ?shoo=bee -} http://www.example.com/baz/?shoo=bee - -test uri-3.9 {uri::resolve - two absolute URL's with queries} { - uri::resolve http://www.example.com/?foo=bar http://www.example.com/?shoo=bee -} http://www.example.com/?shoo=bee - -test uri-3.10 {uri::resolve - two queries, - one absolute URL, one absolute path} { - uri::resolve http://www.example.com/baz?foo=bar /baz?shoo=bee -} http://www.example.com/baz?shoo=bee - - -# ------------------------------------------------------------------------- - -test uri-4.1 {uri::geturl} { - removeFile __testdata - set data [info commands] - set file [makeFile {} __testdata] - set f [open $file w] - puts -nonewline $f $data - close $f - - set token [uri::geturl file://$file] - string compare $data [set [subst $token](data)] -} 0 - -# ------------------------------------------------------------------------- - -test uri-5.1-0 {uri::canonicalize} { - uri::canonicalize http://www.test.net/path1/./remove/../path2/resource -} http://www.test.net/path1/path2/resource - -test uri-5.2-0 {uri::canonicalize infinite loop} { - uri::canonicalize http://www.test.net/../path2/resource -} {http://www.test.net/path2/resource} - -test uri-5.3-0 {uri::canonicalize} { - uri::canonicalize http://www.test.net/./path1/./remove/../path2/../resource -} http://www.test.net/path1/resource - -test uri-5.4-0 {uri::canonicalize} { - uri::canonicalize http://www.test.net/./././path1/./remove/../path2/../resource -} http://www.test.net/path1/resource - -test uri-5.5-0 {uri::canonicalize} { - uri::canonicalize http://www.test.net/./././path1/./remove/path2/../../resource -} http://www.test.net/path1/resource - -test uri-5.6-0 {uri::canonicalize infinite loop} { - uri::canonicalize http://www.test.net/../../../path2/resource -} {http://www.test.net/path2/resource} - -test uri-5.7-0 {uri::canonicalize} { - uri::canonicalize http://www.test.net/path1/./remove/../path.html/resource -} http://www.test.net/path1/path.html/resource - -test uri-5.8-0 {uri::canonicalize infinite loop} { - uri::canonicalize http://www.test.net/../path.html/resource -} {http://www.test.net/path.html/resource} - -test uri-5.9-0 {uri::canonicalize} { - uri::canonicalize http://www.test.net/./path1/./remove/../path.html/../resource -} http://www.test.net/path1/resource - -test uri-5.10-0 {uri::canonicalize} { - uri::canonicalize http://www.test.net/./././path1/./remove/../path.html/../resource -} http://www.test.net/path1/resource - -test uri-5.11-0 {uri::canonicalize} { - uri::canonicalize http://www.test.net/./././path1/./remove/path.html/../../resource -} http://www.test.net/path1/resource - -test uri-5.12-0 {uri::canonicalize infinite loop} { - uri::canonicalize http://www.test.net/../../../path.html/resource -} {http://www.test.net/path.html/resource} - -test uri-5.13-0 {uri::canonicalize} { - uri::canonicalize http://www.eldritchpress.org/jc/../help.html -} {http://www.eldritchpress.org/help.html} - -test uri-5.14-0 {uri::canonicalize trailing ..} { - uri::canonicalize http://www.example.com/foo/bar/.. -} {http://www.example.com/foo/} - -test uri-5.14-0 {uri::canonicalize trailing ..} { - uri::canonicalize http://www.example.com/.. -} {http://www.example.com/} - -test uri-5.1-1 {uri::canonicalize} { - uri::canonicalize ftp://ftp.test.net/path1/./remove/../path2/resource -} ftp://ftp.test.net/path1/path2/resource - -test uri-5.2-1 {uri::canonicalize infinite loop} { - uri::canonicalize ftp://ftp.test.net/../path2/resource -} {ftp://ftp.test.net/path2/resource} - -test uri-5.3-1 {uri::canonicalize} { - uri::canonicalize ftp://ftp.test.net/./path1/./remove/../path2/../resource -} ftp://ftp.test.net/path1/resource - -test uri-5.4-1 {uri::canonicalize} { - uri::canonicalize ftp://ftp.test.net/./././path1/./remove/../path2/../resource -} ftp://ftp.test.net/path1/resource - -test uri-5.5-1 {uri::canonicalize} { - uri::canonicalize ftp://ftp.test.net/./././path1/./remove/path2/../../resource -} ftp://ftp.test.net/path1/resource - -test uri-5.6-1 {uri::canonicalize infinite loop} { - uri::canonicalize ftp://ftp.test.net/../../../path2/resource -} {ftp://ftp.test.net/path2/resource} - -test uri-5.7-1 {uri::canonicalize} { - uri::canonicalize ftp://ftp.test.net/path1/./remove/../path.html/resource -} ftp://ftp.test.net/path1/path.html/resource - -test uri-5.8-1 {uri::canonicalize infinite loop} { - uri::canonicalize ftp://ftp.test.net/../path.html/resource -} {ftp://ftp.test.net/path.html/resource} - -test uri-5.9-1 {uri::canonicalize} { - uri::canonicalize ftp://ftp.test.net/./path1/./remove/../path.html/../resource -} ftp://ftp.test.net/path1/resource - -test uri-5.10-1 {uri::canonicalize} { - uri::canonicalize ftp://ftp.test.net/./././path1/./remove/../path.html/../resource -} ftp://ftp.test.net/path1/resource - -test uri-5.11-1 {uri::canonicalize} { - uri::canonicalize ftp://ftp.test.net/./././path1/./remove/path.html/../../resource -} ftp://ftp.test.net/path1/resource - -test uri-5.12-1 {uri::canonicalize infinite loop} { - uri::canonicalize ftp://ftp.test.net/../../../path.html/resource -} {ftp://ftp.test.net/path.html/resource} - -test uri-5.1-2 {uri::canonicalize} { - uri::canonicalize file://goo.test.net/path1/./remove/../path2/resource -} file://goo.test.net/path1/path2/resource - -test uri-5.2-2 {uri::canonicalize infinite loop} { - uri::canonicalize file://goo.test.net/../path2/resource -} {file://goo.test.net/path2/resource} - -test uri-5.3-2 {uri::canonicalize} { - uri::canonicalize file://goo.test.net/./path1/./remove/../path2/../resource -} file://goo.test.net/path1/resource - -test uri-5.4-2 {uri::canonicalize} { - uri::canonicalize file://goo.test.net/./././path1/./remove/../path2/../resource -} file://goo.test.net/path1/resource - -test uri-5.5-2 {uri::canonicalize} { - uri::canonicalize file://goo.test.net/./././path1/./remove/path2/../../resource -} file://goo.test.net/path1/resource - -test uri-5.6-2 {uri::canonicalize infinite loop} { - uri::canonicalize file://goo.test.net/../../../path2/resource -} {file://goo.test.net/path2/resource} - -test uri-5.7-2 {uri::canonicalize} { - uri::canonicalize file://goo.test.net/path1/./remove/../path.html/resource -} file://goo.test.net/path1/path.html/resource - -test uri-5.8-2 {uri::canonicalize infinite loop} { - uri::canonicalize file://goo.test.net/../path.html/resource -} {file://goo.test.net/path.html/resource} - -test uri-5.9-2 {uri::canonicalize} { - uri::canonicalize file://goo.test.net/./path1/./remove/../path.html/../resource -} file://goo.test.net/path1/resource - -test uri-5.10-2 {uri::canonicalize} { - uri::canonicalize file://goo.test.net/./././path1/./remove/../path.html/../resource -} file://goo.test.net/path1/resource - -test uri-5.11-2 {uri::canonicalize} { - uri::canonicalize file://goo.test.net/./././path1/./remove/path.html/../../resource -} file://goo.test.net/path1/resource - -test uri-5.12-2 {uri::canonicalize infinite loop} { - uri::canonicalize file://goo.test.net/../../../path.html/resource -} {file://goo.test.net/path.html/resource} - -test uri-5.1-3 {uri::canonicalize} { - uri::canonicalize file:///path1/./remove/../path2/resource -} file:///path1/path2/resource - -test uri-5.2-3 {uri::canonicalize infinite loop} { - uri::canonicalize file:///../path2/resource -} {file:///path2/resource} - -test uri-5.3-3 {uri::canonicalize} { - uri::canonicalize file:///./path1/./remove/../path2/../resource -} file:///path1/resource - -test uri-5.4-3 {uri::canonicalize} { - uri::canonicalize file:///./././path1/./remove/../path2/../resource -} file:///path1/resource - -test uri-5.5-3 {uri::canonicalize} { - uri::canonicalize file:///./././path1/./remove/path2/../../resource -} file:///path1/resource - -test uri-5.6-3 {uri::canonicalize infinite loop} { - uri::canonicalize file:///../../../path2/resource -} {file:///path2/resource} - -test uri-5.7-3 {uri::canonicalize} { - uri::canonicalize file:///path1/./remove/../path.html/resource -} file:///path1/path.html/resource - -test uri-5.8-3 {uri::canonicalize infinite loop} { - uri::canonicalize file:///../path.html/resource -} {file:///path.html/resource} - -test uri-5.9-3 {uri::canonicalize} { - uri::canonicalize file:///./path1/./remove/../path.html/../resource -} file:///path1/resource - -test uri-5.10-3 {uri::canonicalize} { - uri::canonicalize file:///./././path1/./remove/../path.html/../resource -} file:///path1/resource - -test uri-5.11-3 {uri::canonicalize} { - uri::canonicalize file:///./././path1/./remove/path.html/../../resource -} file:///path1/resource - -test uri-5.12-3 {uri::canonicalize infinite loop} { - uri::canonicalize file:///../../../path.html/resource -} {file:///path.html/resource} - -test uri-6.0 {uri::canonicalize} { - uri::canonicalize telnet://goo.test.net/ -} telnet://goo.test.net/ - -test uri-7.0 {uri::split & uri::join} { - set ls [uri::split http://tcl.apache.org/websh/faq.ws3\#generic?foo=bar] - eval uri::join $ls -} {http://tcl.apache.org/websh/faq.ws3#generic?foo=bar} - -# ------------------------------------------------------------------------- - -test uri-8.0 {uri::split bug #676976, ill. char in scheme} { - set ls [uri::split ht,tp://tcl.apache.org/websh] - eval uri::join $ls -} {http:///ht,tp://tcl.apache.org/websh} - -# ------------------------------------------------------------------------- - - -::tcltest::cleanupTests -return - -# ------------------------------------------------------------------------- -# Local Variables: -# mode: tcl -# indent-tabs-mode: nil -# End: DELETED modules/uri/urn-scheme.tcl Index: modules/uri/urn-scheme.tcl ================================================================== --- modules/uri/urn-scheme.tcl +++ /dev/null @@ -1,104 +0,0 @@ -# urn-scheme.tcl - Copyright (C) 2001 Pat Thoyts -# -# extend the uri package to deal with URN (RFC 2141) -# see http://www.normos.org/ietf/rfc/rfc2141.txt -# -# Released under the tcllib license. -# -# $Id: urn-scheme.tcl,v 1.5 2003/04/11 00:50:37 andreas_kupries Exp $ -# ------------------------------------------------------------------------- - -package provide uri::urn 1.0.1 -package require uri 1.1.2 - -namespace eval ::uri {} -namespace eval ::uri::urn {} - -::uri::register {urn URN} { - variable NIDpart {[a-zA-Z0-9][a-zA-Z0-9-]{0,31}} - variable esc {%[0-9a-fA-F]{2}} - variable trans {a-zA-Z0-9$_.+!*'(,):=@;-} - variable NSSpart "($esc|\[$trans\])+" - variable URNpart "($NIDpart):($NSSpart)" - variable schemepart $URNpart - variable url "urn:$NIDpart:$NSSpart" -} - -# ------------------------------------------------------------------------- - -# Description: -# Called by uri::split with a url to split into its parts. -# -proc ::uri::SplitUrn {uri} { - #@c Split the given uri into then URN component parts - #@a uri: the URI to split without it's scheme part. - #@r List of the component parts suitable for 'array set' - - upvar \#0 [namespace current]::urn::URNpart pattern - array set parts {nid {} nss {}} - if {[regexp -- ^$pattern $uri -> parts(nid) parts(nss)]} { - return [array get parts] - } else { - error "invalid urn syntax: \"$uri\" could not be parsed" - } -} - - -# ------------------------------------------------------------------------- - -proc ::uri::JoinUrn args { - #@c Join the parts of a URN scheme URI - #@a list of nid value nss value - #@r a valid string representation for your URI - variable urn::NIDpart - - array set parts [list nid {} nss {}] - array set parts $args - if {! [regexp -- ^$NIDpart$ $parts(nid)]} { - error "invalid urn: nid is invalid" - } - set url "urn:$parts(nid):[urn::quote $parts(nss)]" - return $url -} - -# ------------------------------------------------------------------------- - -# Quote the disallowed characters according to the RFC for URN scheme. -# ref: RFC2141 sec2.2 -proc ::uri::urn::quote {url} { - variable trans - - set ndx 0 - while {[regexp -start $ndx -indices -- "\[^$trans\]" $url r]} { - set ndx [lindex $r 0] - scan [string index $url $ndx] %c chr - set rep %[format %.2X $chr] - if {[string match $rep %00]} { - error "invalid character: character $chr is not allowed" - } - set url [string replace $url $ndx $ndx $rep] - incr ndx 3 - } - return $url -} - -# ------------------------------------------------------------------------- - -# Perform the reverse of urn::quote. -proc ::uri::urn::unquote {url} { - set ndx 0 - while {[regexp -start $ndx -indices {%([0-9a-zA-Z]{2})} $url r]} { - set first [lindex $r 0] - set last [lindex $r 1] - set str [string replace [string range $url $first $last] 0 0 0x] - set c [format %c $str] - set url [string replace $url $first $last $c] - set ndx [expr {$last + 1}] - } - return $url -} - -# ------------------------------------------------------------------------- -# Local Variables: -# indent-tabs-mode: nil -# End: DELETED modules/uri/urn.test Index: modules/uri/urn.test ================================================================== --- modules/uri/urn.test +++ /dev/null @@ -1,149 +0,0 @@ -# urn.test - Copyright (C) 2001 Pat Thoyts -# -# Provide a set of tests to excercise the urn-scheme package. -# -# @(#)$Id: urn.test,v 1.2 2001/11/03 01:12:58 patthoyts Exp $ - -# Initialize the required packages - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* - #source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -if {[catch {package require uri}]} { - catch {puts stderr "Cannot load the URI package"} - return -} - -if {[catch {package require uri::urn}]} { - catch {puts stderr "Failed to source the URN scheme extension"} - return -} - -# ------------------------------------------------------------------------- - -# Tests to check for valid urn sections. - -test urn-1.1 {Check basic split} { - catch {uri::split urn:tcl:test} result - set result -} {nss test scheme urn nid tcl} - -test urn-1.2 {Check basic join} { - catch {uri::join scheme urn nid tcl nss test} result - set result -} {urn:tcl:test} - -test urn-1.3 {Split permissible NID} { - catch {uri::split urn:tcl-TCL-0123456789:test} result - set result -} {nss test scheme urn nid tcl-TCL-0123456789} - -test urn-1.4 {Join permissible NID} { - catch {uri::join scheme urn nid tcl-TCL-0123456789 nss test} result - set result -} {urn:tcl-TCL-0123456789:test} - -test urn-1.5 {Split permissible NSS} { - catch {uri::split {urn:tcl:Test-0123456789()+,-.:=@;$_!*'}} result - set result -} {nss {Test-0123456789()+,-.:=@;$_!*'} scheme urn nid tcl} - -test urn-1.6 {Join permissible NSS} { - catch {uri::join scheme urn nid tcl nss {Test-0123456789()+,-.:=@;$_!*'}} result - set result -} {urn:tcl:Test-0123456789()+,-.:=@;$_!*'} - -# ------------------------------------------------------------------------- -# Now some tests that should fail. - -test urn-2.1 {NID too long} { - set nid ThisURNNIDparthastoomanycharacters - set nss test - if {[catch {uri:split urn:$nid:$nss} result]} { - set result ok - } - set result -} {ok} - -test urn-2.2 {NID too long} { - set nid ThisURNNIDparthastoomanycharacters - set nss test - if {[catch {uri:join scheme urn nid $nid nss $nss} result]} { - set result ok - } - set result -} {ok} - -test urn-2.3 {NID containing invalid characters} { - set nid {This-NID//notOK} - set nss test - if {[catch {uri::join scheme urn nid $nid nss $nss} result]} { - set result ok - } - set result -} {ok} - -test urn-2.4 {NID containing no characters} { - set nid {} - set nss test - if {[catch {uri::join scheme urn nid $nid nss $nss} result]} { - set result ok - } - set result -} {ok} - -test urn-2.5 {NID beginning with hyphen} { - set nid {-notvalid} - set nss test - if {[catch {uri::join scheme urn nid $nid nss $nss} result]} { - set result ok - } - set result -} {ok} - - -# Check the Namespace Specific String. - -test urn-3.1 {NSS containing reserved characters} { - set nid {tcl} - set nss {%} - catch {uri::join scheme urn nid $nid nss $nss} result - set result -} {urn:tcl:%25} - -test urn-3.2 {NSS containing reserved characters} { - set nid {tcl} - set nss {/?#} - catch {uri::join scheme urn nid $nid nss $nss} result - set result -} {urn:tcl:%2F%3F%23} - -test urn-3.3 {NSS containing reserved characters} { - set nid {tcl} - set nss {urn-test} - catch {uri::join scheme urn nid $nid nss $nss} result - set result -} {urn:tcl:urn-test} - -test urn-3.4 {NSS containing illegal characters} { - set nid {tcl} - set nss "\u00" ;# 0 is the only character explicitly denied. - if {[catch {uri::join scheme urn nid $nid nss $nss} result]} { - set result ok - } - set result -} {ok} - -# ------------------------------------------------------------------------- -# Clean up the tests - -::tcltest::cleanupTests -return - -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: DELETED sak.tcl Index: sak.tcl ================================================================== --- sak.tcl +++ /dev/null @@ -1,446 +0,0 @@ -#!/bin/sh -# -*- tcl -*- \ -exec tclsh "$0" ${1+"$@"} - -# -------------------------------------------------------------- -# Perform various checks and operations on the distribution. -# SAK = Swiss Army Knife. - -set distribution [file dirname [info script]] -lappend auto_path [file join $distribution modules] - -source [file join $distribution tcllib_version.tcl] ; # Get version information. - -# -------------------------------------------------------------- - -proc tclfiles {} { - global distribution - package require fileutil - set fl [fileutil::findByPattern $distribution -glob *.tcl] - proc tclfiles {} [list return $fl] - return $fl -} - -proc modules {} { - global distribution - set fl [list] - foreach f [glob -nocomplain [file join $distribution modules *]] { - if {![file isdirectory $f]} {continue} - if {[string match CVS [file tail $f]]} {continue} - lappend fl [file tail $f] - } - proc modules {} [list return $fl] - return $fl -} - -proc sep {} {puts ~~~~~~~~~~~~~~~~~~~~~~~~} - -proc gendoc {fmt ext {mode user} {flags {}}} { - global distribution - - set mpe [file join $distribution modules doctools mpexpand] - set ::env(TCLLIBPATH) [file join $distribution modules] - - foreach m [modules] { - switch -exact -- $mode { - user {set fl [glob -nocomplain [file join $distribution modules $m *.man]]} - dev {set fl [glob -nocomplain [file join $distribution modules $m *.dev.man]]} - all {set fl [glob -nocomplain [file join $distribution modules $m *.man]]} - single {set fl [list ]} - default {return -code error "Invalid mode $mode"} - } - if {[llength $fl] == 0} {continue} - file mkdir [file join doc $fmt] - - if {$flags == {}} { - foreach f $fl { - puts "Gen ($fmt): $f" - if {[catch { - exec \ - [list $mpe] -module [list $m] \ - $fmt [list $f] [list [file join doc $fmt [file rootname [file tail $f]].$ext]] \ - >@ stdout 2>@ stderr - } msg]} { - puts $msg - } - } - } else { - foreach f $fl { - puts "Gen ($fmt): $f" - if {[catch { - exec \ - [list $mpe] -module [list $m] \ - $flags \ - $fmt [list $f] [list [file join doc $fmt [file rootname [file tail $f]].$ext]] \ - >@ stdout 2>@ stderr - } msg]} { - puts $msg - } - } - } - } -} - - -proc gd-cleanup {} { - global tcllib_version - - puts {Cleaning up...} - - set fl [glob -nocomplain tcllib-${tcllib_version}*] - foreach f $fl { - puts " Deleting $f ..." - catch {file delete -force $f} - } - return -} - -proc gd-gen-archives {} { - global tcllib_version - - puts {Generating archives...} - - puts " Gzipped tarball (tcllib-${tcllib_version}.tar.gz)..." - exec tar cf - tcllib-${tcllib_version} | gzip --best > tcllib-${tcllib_version}.tar.gz - - puts " Zip archive (tcllib-${tcllib_version}.zip)..." - exec zip -r tcllib-${tcllib_version}.zip tcllib-${tcllib_version} - - set bzip [auto_execok bzip2] - if {$bzip != {}} { - puts " Bzipped tarball (tcllib-${tcllib_version}.tar.bz2)..." - exec tar cf - tcllib-${tcllib_version} | bzip2 > tcllib-${tcllib_version}.tar.bz2 - } - - set sdx [auto_execok sdx] - if {$sdx != {}} { - file rename tcllib-${tcllib_version} tcllib.vfs - - puts " Starkit (tcllib-${tcllib_version}.kit)..." - exec sdx wrap tcllib - file rename tcllib tcllib-${tcllib_version}.kit - - if {![file exists tclkit]} { - puts " No tclkit present in current working directory, no starpack." - } else { - puts " Starpack (tcllib-${tcllib_version}.exe)..." - exec sdx wrap tcllib -runtime tclkit - file rename tcllib tcllib-${tcllib_version}.exe - } - - file rename tcllib.vfs tcllib-${tcllib_version} - } - - puts { Keeping directory for other archive types} - - ## Keep the directory for 'sdx' - kit/pack - return -} - -proc xcopy {src dest recurse {pattern *}} { - file mkdir $dest - foreach file [glob [file join $src $pattern]] { - set base [file tail $file] - set sub [file join $dest $base] - - # Exclude CVS automatically, and possibly the temp hierarchy - # itself too. - - if {0 == [string compare CVS $base]} {continue} - if {[string match tcllib-* $base]} {continue} - if {[string match *~ $base]} {continue} - - if {[file isdirectory $file]} then { - if {$recurse} { - file mkdir $sub - xcopy $file $sub $recurse $pattern - } - } else { - puts -nonewline stdout . ; flush stdout - - file copy -force $file $sub - } - } -} - -proc gd-assemble {} { - global tcllib_version distribution - - puts "Assembling distribution in directory 'tcllib-${tcllib_version}'" - - xcopy $distribution tcllib-${tcllib_version} 1 - file delete -force \ - tcllib-${tcllib_version}/config \ - tcllib-${tcllib_version}/modules/ftp/example \ - tcllib-${tcllib_version}/modules/ftpd/examples \ - tcllib-${tcllib_version}/modules/stats \ - tcllib-${tcllib_version}/modules/fileinput - puts "" - return -} - -proc validate_testsuites {} { - global distribution - foreach m [modules] { - if {[llength [glob -nocomplain [file join $distribution modules $m *.test]]] == 0} { - puts " Without testsuite : $m" - } - } - return -} - -proc validate_pkgIndex {} { - global distribution - foreach m [modules] { - if {[llength [glob -nocomplain [file join $distribution modules $m pkgIndex.tcl]]] == 0} { - puts " Without package index : $m" - } - } - return -} - -proc validate_doc_existence {} { - global distribution - foreach m [modules] { - if {[llength [glob -nocomplain [file join $distribution modules $m {*.[13n]}]]] == 0} { - if {[llength [glob -nocomplain [file join $distribution modules $m {*.man}]]] == 0} { - puts " Without * any ** manpages : $m" - } - } elseif {[llength [glob -nocomplain [file join $distribution modules $m {*.man}]]] == 0} { - puts " Without doctools manpages : $m" - } else { - foreach f [glob -nocomplain [file join $distribution modules $m {*.[13n]}]] { - if {![file exists [file rootname $f].man]} { - puts " no .man equivalent : $f" - } - } - } - } - return -} - - -proc validate_doc_markup {} { - gendoc null null user -deprecated - file delete -force [file join doc null] - return -} - - -proc run-frink {} { - global distribution - foreach f [tclfiles] { - puts "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" - puts "$f..." - puts "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" - - catch {exec frink 2>@ stderr -H $f} - } - return -} - -proc run-procheck {} { - global distribution - foreach f [tclfiles] { - puts "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" - puts "$f ..." - puts "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" - - catch {exec procheck >@ stdout $f} - } - return -} - -# -------------------------------------------------------------- -# Help - -proc __help {} { - puts stdout { - Commands avalable through the swiss army knife aka SAK: - - help - This help - - /Configuration - version - Return tcllib version number - major - Return tcllib major version number - minor - Return tcllib minor version number - name - Return tcllib package name - - /Development - modules - Return list of modules. - validate - Check various parts of tcllib for problems. - test ?module...? - Run testsuite for listed modules. - For all modules if none specified. - - /Release engineering - gendist - Generate distribution from CVS snapshot - - /Documentation - nroff - Generate manpages - html - Generate HTML pages - tmml - Generate TMML - list - Generate a list of manpages - wiki - Generate wiki markup - latex - Generate LaTeX pages - dvi - See latex, + conversion to dvi - ps - See dvi, + conversion to PostScript - } -} - -# -------------------------------------------------------------- -# Configuration - -proc __name {} {global tcllib_name ; puts $tcllib_name} -proc __version {} {global tcllib_version ; puts $tcllib_version} -proc __minor {} {global tcllib_version ; puts [lindex [split $tcllib_version .] 1]} -proc __major {} {global tcllib_version ; puts [lindex [split $tcllib_version .] 0]} - -# -------------------------------------------------------------- -# Development - -proc __modules {} {puts [modules]} - - -proc __test {} { - global argv distribution - # Run testsuite - - set modules $argv - if {[llength $modules] == 0} { - set modules [modules] - } - - exec [info nameofexecutable] \ - [file join $distribution all.tcl] \ - -modules $modules \ - >@ stdout 2>@ stderr - return -} - - - -proc __validate {} { - global tcllib_name tcllib_version - set i 0 - - puts "Validating $tcllib_name $tcllib_version development" - puts "===================================================" - puts "[incr i]: Existence of testsuites ..." - puts "------------------------------------------------------" - validate_testsuites - puts "------------------------------------------------------" - puts "" - - puts "[incr i]: Existence of package indices ..." - puts "------------------------------------------------------" - validate_pkgIndex - puts "------------------------------------------------------" - puts "" - - - puts "[incr i]: Existence of documentation ..." - puts "------------------------------------------------------" - validate_doc_existence - puts "------------------------------------------------------" - puts "" - - puts "[incr i]: Validate documentation markup (doctools) ..." - puts "------------------------------------------------------" - validate_doc_markup - puts "------------------------------------------------------" - puts "" - - puts "[incr i]: Static syntax check ..." - puts "------------------------------------------------------" - - set frink [auto_execok frink] - set procheck [auto_execok procheck] - - if {$frink == {}} {puts " Tool 'frink' not found, no check"} - if {$procheck == {}} {puts " Tool 'procheck' not found, no check"} - if {($frink == {}) || ($procheck == {})} { - puts "------------------------------------------------------" - } - if {($frink == {}) && ($procheck == {})} { - return - } - if {$frink != {}} { - run-frink - puts "------------------------------------------------------" - } - if {$procheck != {}} { - run-procheck - puts "------------------------------------------------------" - } - puts "" - - return -} - - -# -------------------------------------------------------------- -# Release engineering - -proc __gendist {} { - gd-cleanup - gd-assemble - gd-gen-archives - - puts ...Done - return -} - -# -------------------------------------------------------------- -# Documentation - -proc __html {} {gendoc html html} -proc __nroff {} {gendoc nroff n} -proc __tmml {} {gendoc tmml tmml} -proc __wiki {} {gendoc wiki wiki} -proc __latex {} {gendoc latex tex} -proc __dvi {} { - __latex - file mkdir [file join doc dvi] - cd [file join doc dvi] - foreach f [glob -nocomplain ../latex/*.tex] { - puts "Gen (dvi): $f" - exec latex $f 1>@ stdout 2>@ stderr - } - cd ../.. -} -proc __ps {} { - __dvi - file mkdir [file join doc ps] - cd [file join doc ps] - foreach f [glob -nocomplain ../dvi/*.dvi] { - puts "Gen (dvi): $f" - exec dvips -o [file rootname [file tail $f]].ps $f 1>@ stdout 2>@ stderr - } - cd ../.. -} - -proc __list {} { - gendoc list l - exec cat [glob -nocomplain doc/list/*.l] > doc/list/manpages.tcl - eval file delete -force [glob -nocomplain doc/list/*.l] - return -} - -# -------------------------------------------------------------- - -set cmd [lindex $argv 0] -if {[llength [info procs __$cmd]] == 0} { - puts stderr "unknown command $cmd" - set fl {} - foreach p [lsort [info procs __*]] { - lappend fl [string range $p 2 end] - } - puts stderr "use: [join $fl ", "]" - exit 1 -} - -set argv [lrange $argv 1 end] -incr argc -1 - -__$cmd -exit 0 DELETED tcllib_version.tcl Index: tcllib_version.tcl ================================================================== --- tcllib_version.tcl +++ /dev/null @@ -1,2 +0,0 @@ -set tcllib_version 1.4 -set tcllib_name tcllib