Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Changes In Branch tcllib-1-6-branch Excluding Merge-Ins
This is equivalent to a diff from cf54baf0cc to 1c7c28356c
2004-08-10
| ||
06:19 | ChangeLog merge. Merging ChangeLog. queue: Updated dispatcher, object command generation. Sync'd to other classes. stack: Dispatcher update, sync'd command generation to other classes. Updated tests. Spelling police, and fix for SF Tcllib Bug 1005380. struct sets, fixed [Tcllib SF Bug 1002143]. Closed-Leaf check-in: 1c7c28356c user: andreas_kupries tags: tcllib-1-6-branch | |
2004-08-05
| ||
05:43 | struct sets, fixed [Tcllib SF Bug 1002143]. Struct graph bugfix for [SF Tcllib Bug 1003671]. check-in: e4463363fc user: andreas_kupries tags: tcllib-1-6-branch | |
2004-05-24
| ||
02:58 | Downgraded to version 1.3.6, removed -decode extension from this branch. Import of ftpd bugfix by Gerald Lester. Last commit was a bad update, caused duplicates of changes to appear. Failed testsuite. Removed all the duplicates now. Fixed SF Tcllib Bug 954328. Mime now adapts at runtime to whatever version of md5 has been loaded. Updated test for rewritten adjust which fixed the infinite looping demonstrated by tests 2.6 and 2.7. Also fixed a var usage typo which caused a copy of the input to appear in the output, before the expected formatted result. Fixed bug in the processing of multi-word section titles for text based formats. Fixed bug 951568, regarding the usage of Trf's generic transform. Fixed problems with jpeg recognition (was unable to detect a jpeg file, if it contained exif data). Changelog for last patch, and updates in related package. Completed application of code for various fixes. Rewritten text adjustment and hyphenation, fixing SF TCllib Bug 882402. Fixed SF Tcllib Bug 936064, and evals more robust. Fixed SF Tcllib Bug 893516 Fixed SF Tcllib Patch 763712 Fixed SF Tcllib Patch 758742 Fixed SF Tcllib Bug 620852 Eval usage made more robust and similar. Fixed SF Tcllib Bug 943146. Fixed SF Tcllib Bug 940651 SF Tcllib Bug 784519 fixed. Pat: sak.tcl update for better use of critcl. Joe: Fix in doctools xml support. Import bugfix by Pat Thoyts, Handling of data starting with hyphen/dash Import of uuencode changes by Jeff Hobbs. Changed defaults for package 'log'. No output for the all levels below 'error'. Unified the startup header of all applications, using suggestions made by Stuart Cassof <[email protected]>. Added testcase for Tcllib SF Bug 860753. The bug itself was already fixed for Tcllib 1.6. Fix for bug 899204. Test data file is opened read-only, and tests made independent of each other. Bugfix 899152, 899209. Require Tcl 8.2 for installer, delete file before writing over it. Import of time fix by Pat Thoyts, patch #905132. Cleanup fix: Snit depends on Tcl 8.4, this is documented, however neither package index, nor testsuite enforced the restriction, allowing for errors. This has been changed now. Fixed typos check-in: 68c5dd3dab user: andreas_kupries tags: tcllib-1-6-branch | |
2004-02-16
| ||
06:29 | Updated version to 1.6.0.1 to differentiate CVS from the released version. check-in: df561077de user: andreas_kupries tags: trunk | |
04:14 | * * Released and tagged Tcllib 1.6 ======================== * * list.tcl (split): New method, like 'filter', but returns lists * list.test: of both passing and failing elements. Extended * struct_list.man: both testsuite and documentation. check-in: cf54baf0cc user: andreas_kupries tags: trunk, release, tcllib-1-6 | |
2004-02-14
| ||
05:59 | * sak.tcl (release): Made functional, added the code which extends all the ChangeLogs with the release notice. (gd-assemble): Extended to exclude SCCS and BitKeeper files from the distribution. (gd-gen-packages): Fixed problem with missing global variable. * all.tcl: 'getErrorMessage' and 'tooManyMessage' renamed to 'wrongNumArgs' anfd 'tooManyArg'. Also placed the common constraints (checking Tcl version: 8.3 only, 8.3+, 8.4+) in here, and removed their declaration from all test files using them. * README-1.5.txt: Updated logger version info to 0.3. * logger.man: Brought the version numbers back into sync * pkgIndex.tcl: with 'logger.tcl' check-in: d5c6e6a60d user: andreas_kupries tags: trunk | |
Changes to ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-14 Andreas Kupries <[email protected]> | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-05-23 Andreas Kupries <[email protected]> * Bumped version in branch to 1.6.1 in preparation of upcoming bugfix release. 2004-04-16 Pat Thoyts <[email protected]> * sak.tcl: Some mods to the critcl build code for use under Windows. If it cannot find critcl.kit, then use env(CRITCL) for the location of the kit file. 2004-03-09 Andreas Kupries <[email protected]> * examples/csv/csv2html.orig: Unified the startup header of all * examples/csv/csvcut.orig: applications, using suggestions * examples/csv/csvdiff.orig: made by Stuart Cassoff <[email protected]>. * examples/csv/csvjoin.orig: * examples/csv/csvsort.orig: * examples/csv/csvuniq.orig: * examples/ftp/ftpdemo.tcl.orig: * examples/ftp/ftpvalid.orig: * examples/ftp/hpupdate.tcl.orig: * examples/ftp/mirror.tcl.orig: * examples/ftp/newer.tcl.orig: * examples/ftpd/ftpd.orig: * examples/ftpd/ftpd.test.orig: * examples/ftpd/ftpd.unix.orig: * examples/irc/irc_example.tcl.orig: * examples/mime/mbot/README.html.orig: * examples/mime/mbot/README.txt.orig: * examples/mime/mbot/README.xml.orig: * examples/mime/mbot/impersonal.tcl.orig: * examples/mime/mbot/personal.tcl.orig: * examples/nntp/postnews.orig: * examples/oreilly-oscon2001/oscon.orig: * examples/smtpd/tcl_smtpd.orig: * examples/smtpd/tk_smtpd.orig: * examples/smtpd/tk_smtpdMIME.orig: * modules/des/des.tcl.orig: * modules/devtools/musub.tcl.orig: * modules/doctools/mpexpand.orig: * modules/doctools/mpexpand.all.orig: * modules/doctools/tocexpand.orig: * modules/fileutil/fileutil.test.orig: * modules/mime/performance.tcl.orig: * modules/pop3/clnt.tcl.orig: * modules/pop3/srv.tcl.orig: 2004-03-01 Andreas Kupries <[email protected]> * installer.tcl: Requiring Tcl 8.2 when executing the installer, as anything below that version does not make any sense. This fixes [Tcllib SF Bug 899152]. * installer.tcl: Fixed [Tcllib SF Bug 899209] by deleting an existing file before trying to overwrite it. 2004-02-18 Andreas Kupries <[email protected]> * tcllib_version.tcl: Moving mainline to 1.6.0.1 to distinguish development from the released version. 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-14 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to PACKAGES.
|
| | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | @@ RELEASE 1.6.1 base64 2.3 calendar 0.2 cksum 1.0.1 cmdline 1.2.2 comm 4.2 control 0.1.2 counter 2.0.2 crc16 1.1 crc32 1.1.1 csv 0.5.1 des 0.8.1 dns 1.1 doctools 1.0.2 doctools::changelog 0.1 doctools::cvs 0.1 doctools::idx 0.1 doctools::toc 0.1 exif 1.1.1 fileutil 1.6.1 ftp 2.4.1 ftp::geturl 0.2 ftpd 1.2.1 html 1.2.2 htmlparse 1.0 inifile 0.1 irc 0.4 javascript 1.0.1 log 1.1.1 logger 0.3 math 1.2.2 math::calculus 0.5.1 math::fuzzy 0.2 math::geometry 1.0.1 math::optimize 0.1 math::statistics 0.1.1 md4 1.0.2 md5 2.0.1 md5crypt 1.0.0 mime 1.3.6 multiplexer 0.2 ncgi 1.2.3 nntp 0.2.1 pop3 1.6.1 pop3d 1.0.2 pop3d::dbox 1.0.1 pop3d::udb 1.1 profiler 0.2.2 report 0.3.1 resolv 1.0.3 sha1 1.0.3 smtp 1.3.6 smtpd 1.2.1 snit 0.93 soundex 1.0 stooop 4.4.1 struct 2.0 sum 1.1.0 switched 2.2 textutil 0.6.1 textutil::expander 1.2.1 time 1.0.3 uri 1.1.4 uri::urn 1.0.1 uuencode 1.1.1 yencode 1.1 |
Added README-1.6.1.txt.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | Overview ======== Tcllib 1.6.1 is a bugfix release. This means that the enhancements and extensions which have been made to the main line are _not_ present in this branch. New in Tcllib 1.6.1 =================== Nothing. See the Overview for an explanation. Changes from Tcllib 1.6 to 1.6.1 ================================ Legend B : Bug fixes. \ D : Documentation updates. > Implies change of patchlevel. EX : New examples. > P : Performance enhancement. / Tcllib 1.6 Tcllib 1.6.1 Module Package Old version New Version Comments ------ ------- ----------- ----------- ------------------------------- base64 uuencode 1.1 1.1.1 B crc crc32 1.1 1.1.1 B csv 0.5 0.5.1 B ------ ------- ----------- ----------- ------------------------------- doctools doctools 1.0.1 1.0.2 B ------ ------- ----------- ----------- ------------------------------- fileutil 1.6 1.6.1 B ftpd 1.2 1.2.1 B inifile 0.1 0.1 B (Testsuite, nothing functional) log log 1.1 1.1.1 B (Defaults) ntp time 1.0.2 1.0.3 B md4 1.0.1 1.0.2 B md5 2.0.0 2.0.1 B ------ ------- ----------- ----------- ------------------------------- mime mime 1.3.4 1.3.6 B smtp 1.3.4 1.3.6 B ------ ------- ----------- ----------- ------------------------------- snit 0.93 0.93 B (Index, testsuite only) struct sets 2.0 2.0 B (Typo police) textutil textutil 0.6 0.6.1 B uri uri 1.1.3 1.1.4 B ------ ------- ----------- ----------- ------------------------------- |
Changes to examples/csv/csv2html.
|
| | | | > | 1 2 3 4 5 6 7 8 9 10 11 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # Generate HTML table from CSV data package require csv package require cmdline package require report package require struct |
︙ | ︙ |
Changes to examples/csv/csvcut.
|
| | | | > | 1 2 3 4 5 6 7 8 9 10 11 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # Cut and reorder fields in a CSV file. package require csv package require cmdline # ---------------------------------------------------- # csvcut ?-sep sepchar? LIST file... |
︙ | ︙ |
Changes to examples/csv/csvdiff.
|
| | | | > | 1 2 3 4 5 6 7 8 9 10 11 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # Perform a diff on two CSV files. # The result is a CSV file package require csv package require cmdline # ---------------------------------------------------- |
︙ | ︙ |
Changes to examples/csv/csvjoin.
|
| | | | > | 1 2 3 4 5 6 7 8 9 10 11 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # Join two CSV files by key package require csv package require cmdline # ---------------------------------------------------- # csvuniq ?-sep sepchar? keycol1 file1.in keycol2 file2.in file.out|- |
︙ | ︙ |
Changes to examples/csv/csvsort.
|
| | | | > | 1 2 3 4 5 6 7 8 9 10 11 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # 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|- |
︙ | ︙ |
Changes to examples/csv/csvuniq.
|
| | | | > | 1 2 3 4 5 6 7 8 9 10 11 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # Make CSV data the specified column unique. package require csv package require cmdline # ---------------------------------------------------- # csvuniq ?-sep sepchar? column file.in|- file.out|- |
︙ | ︙ |
Changes to examples/ftp/ftpdemo.tcl.
|
| | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # - 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: [email protected] # 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.3 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 |
︙ | ︙ |
Changes to examples/ftp/ftpvalid.
|
| | > | 1 2 3 4 5 6 7 8 9 10 11 | #! /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 |
︙ | ︙ |
Changes to examples/ftp/hpupdate.tcl.
|
| | | | | | 1 2 3 4 5 6 7 8 9 10 11 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # - homepage update program using FTP - # # Required: tcl/tk8.2 # # Created: 12/96 # Changed: 7/2000 # Version: 2.0 |
︙ | ︙ | |||
27 28 29 30 31 32 33 34 35 36 37 38 39 40 | # 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 | > | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | # 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 Tcl 8.3 package require ftp 2.0 package require Tk if {![llength [info commands tkButtonInvoke]]} { ::tk::unsupported::ExposePrivateCommand tkButtonInvoke } # LED Colors |
︙ | ︙ |
Changes to examples/ftp/mirror.tcl.
|
| | | | > | 1 2 3 4 5 6 7 8 9 10 11 12 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} package require Tcl 8.3 package require ftp 2.0 # user configuration set server noname set username anonymous set passwd xxxxxx |
︙ | ︙ |
Changes to examples/ftp/newer.tcl.
|
| | | | > | 1 2 3 4 5 6 7 8 9 10 11 12 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} package require Tcl 8.3 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 |
︙ | ︙ |
Changes to examples/ftpd/ftpd.
|
| | > > > < < > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # FTP daemon package require Tcl 8.3 if {[catch {package require ftpd}]} { set here [file dirname [info script]] source [file join .. $here ftpd.tcl] } proc bgerror {args} { global errorInfo |
︙ | ︙ |
Changes to examples/ftpd/ftpd.test.
|
| | < | > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # FTP daemon # 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 Tcl 8.3 package require ftpd package require log proc bgerror {args} { global errorInfo puts stderr "bgerror: [join $args]" puts stderr $errorInfo |
︙ | ︙ |
Changes to examples/ftpd/ftpd.unix.
|
| | > > > < < > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # FTP daemon package require Tcl 8.3 if {[catch {package require ftpd}]} { set here [file dirname [info script]] source [file join .. $here ftpd.tcl] } proc bgerror {args} { global errorInfo |
︙ | ︙ |
Changes to examples/irc/irc_example.tcl.
|
| | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # irc example script, by David N. Welton <[email protected]> # $Id: irc_example.tcl,v 1.7.2.1 2004/05/24 02:58:09 andreas_kupries Exp $ # 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.4 |
︙ | ︙ |
Changes to examples/mime/mbot/impersonal.tcl.
|
| | > | < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # impersonal.tcl - export impersonal mail via the web # # (c) 1999 Marshall T. Rose # Hold harmless the author, and any lawful use is allowed. # package require Tcl 8.3 global options # begin of routines that may be redefined in configFile proc tclLog {message} { global options |
︙ | ︙ |
Changes to examples/mime/mbot/personal.tcl.
|
| | | < | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # 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! # package require Tcl 8.3 global options # begin of routines that may be redefined in configFile proc impersonalMail {originator} {} |
︙ | ︙ |
Changes to examples/nntp/postnews.
|
| | | > | | 1 2 3 4 5 6 7 8 9 10 11 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # 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. |
︙ | ︙ |
Changes to examples/oreilly-oscon2001/oscon.
|
| | | | > | 1 2 3 4 5 6 7 8 9 10 11 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # Extract and report oscon schedule package require struct package require csv package require report package require htmlparse package require textutil |
︙ | ︙ |
Changes to examples/smtpd/tcl_smtpd.
1 | #! /bin/sh | > > | < < > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # tcl_smtpd - Copyright (C) 2001 Pat Thoyts <[email protected]> # # 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. # ------------------------------------------------------------------------- package require Tcl 8.3 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\"" } |
︙ | ︙ |
Changes to examples/smtpd/tk_smtpd.
1 | #! /bin/sh | > > | < < | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # tk_smtpd - Copyright (C) 2001 Pat Thoyts <[email protected]> # # 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. # ------------------------------------------------------------------------- package require Tcl 8.3 package require Tk package require smtpd 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\"" } |
︙ | ︙ |
Changes to examples/smtpd/tk_smtpdMIME.
1 | #! /bin/sh | > > | < < | > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # tk_smtpdMIME -Copyright (C) 2002 Pat Thoyts <[email protected]> # # 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. # ------------------------------------------------------------------------- package require Tcl 8.3 package require Tk package require smtpd package require mime 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] |
︙ | ︙ |
Changes to install_action.tcl.
︙ | ︙ | |||
47 48 49 50 51 52 53 | [file join $libdir $module] return } proc _man {module format ext docdir} { global distribution argv argc argv0 config | > > > > > > | > > > | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 | [file join $libdir $module] return } proc _man {module format ext docdir} { global distribution argv argc argv0 config # [SF Tcllib Bug 784519] # Directly access the bundled doctools package to ensure that # we have the truly latest code for that, and not the doctools # the executing tclsh would find on its own. The present query is # used to ensure that we load the package only once. #package require doctools if {[catch {package present doctools}]} { uplevel #0 [list source [file join $distribution modules doctools doctools.tcl]] } ::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" |
︙ | ︙ |
Changes to installer.tcl.
1 2 3 4 5 | #!/bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # -------------------------------------------------------------- | | > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | #!/bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # -------------------------------------------------------------- # Installer for Tcllib. The lowest version of the tcl core supported # by any module is 8.2. So we enforce that the installer is run with # at least that. package require Tcl 8.2 set distribution [file dirname [info script]] lappend auto_path [file join $distribution modules] # -------------------------------------------------------------- # Version information for tcllib. |
︙ | ︙ | |||
93 94 95 96 97 98 99 100 101 102 103 104 105 106 | } } 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 } # -------------------------------------------------------------- # Use configuration to perform installation | > | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | } } 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} catch {file delete -force $f} puts -nonewline [set of [open $f w]] $text close $of } # -------------------------------------------------------------- # Use configuration to perform installation |
︙ | ︙ |
Changes to modules/base64/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-10-24 Andreas Kupries <[email protected]> | > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-05-23 Andreas Kupries <[email protected]> * uuencode.tcl: Rel. engineering. Updated version number * uuencode.man: of uuencode to reflect its changes, to 1.1.1. * pkgIndex.tcl: 2004-03-09 Jeff Hobbs <[email protected]> * uuencode.tcl (::uuencode::pad): don't use log package 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-10-24 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/base64/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 11 | # 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} | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # 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 base64 2.3 [list source [file join $dir base64.tcl]] package ifneeded uuencode 1.1.1 [list source [file join $dir uuencode.tcl]] package ifneeded yencode 1.1 [list source [file join $dir yencode.tcl]] |
Changes to modules/base64/uuencode.man.
|
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | [manpage_begin uuencode n 1.1.1] [copyright {2002, Pat Thoyts}] [moddesc {encode/decoding a binary file}] [titledesc {encode/decoding a binary file}] [require Tcl 8] [require uuencode [opt 1.1.1]] [description] [para] This package provides a Tcl-only implementation of the uuencode(1) and uudecode(1) commands. This encoding packs binary data into printable ASCII characters. |
︙ | ︙ |
Changes to modules/base64/uuencode.tcl.
1 2 3 4 5 6 7 8 | # uuencode - Copyright (C) 2002 Pat Thoyts <[email protected]> # # Provide a Tcl only implementation of uuencode and uudecode. # # ------------------------------------------------------------------------- # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- | | < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # uuencode - Copyright (C) 2002 Pat Thoyts <[email protected]> # # Provide a Tcl only implementation of uuencode and uudecode. # # ------------------------------------------------------------------------- # 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.13.2.2 2004/05/27 02:47:38 andreas_kupries Exp $ package require Tcl 8.2; # tcl minimum version # Try and get some compiled helper package. if {[catch {package require tcllibc}]} { catch {package require Trf} } namespace eval ::uuencode { variable version 1.1.1 namespace export encode decode uuencode uudecode } proc ::uuencode::Enc {c} { return [format %c [expr {($c != 0) ? (($c & 0x3f) + 0x20) : 0x60}]] } |
︙ | ︙ | |||
160 161 162 163 164 165 166 | # Permit more tolerant decoding of invalid input strings by padding to # a multiple of 4 bytes with nulls. # Result: # Returns the input string - possibly padded with uuencoded null chars. # proc ::uuencode::pad {s} { if {[set mod [expr {[string length $s] % 4}]] != 0} { | < < | 159 160 161 162 163 164 165 166 167 168 169 170 171 172 | # Permit more tolerant decoding of invalid input strings by padding to # a multiple of 4 bytes with nulls. # Result: # Returns the input string - possibly padded with uuencoded null chars. # proc ::uuencode::pad {s} { if {[set mod [expr {[string length $s] % 4}]] != 0} { append s [string repeat "`" [expr {4 - $mod}]] } return $s } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/calendar/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-05 Andreas Kupries <[email protected]> | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-05 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/calendar/gregorian.test.
1 2 3 4 5 6 7 | #---------------------------------------------------------------------- # # calendar.test -- # # Tests for [calendar::CommonCalendar] and # [calendar::GregorianCalendar] # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | #---------------------------------------------------------------------- # # calendar.test -- # # Tests for [calendar::CommonCalendar] and # [calendar::GregorianCalendar] # # RCS: @(#) $Id: gregorian.test,v 1.3.2.1 2004/06/25 04:37:23 andreas_kupries Exp $ # #---------------------------------------------------------------------- package forget calendar catch { namespace delete calendar } # Direct loading of provide script -- support testing even |
︙ | ︙ | |||
25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | # # 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 | > > > > > > > > > > | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | # # TEST CASES # #---------------------------------------------------------------------- # Unix epoch array set gregChange { ERA CE YEAR 1752 MONTH 9 DAY_OF_MONTH 14 } set gregChangeJ [calendar::GregorianCalendar::EYMDToJulianDay gregChange] puts "Gregorian calendar was adopted in England on Julian Day $gregChangeJ" array set gregUnixEpoch { ERA CE YEAR 1970 MONTH 1 DAY_OF_MONTH 1 } set unixEpoch [calendar::GregorianCalendar::EYMDToJulianDay gregUnixEpoch] puts "Posix epoch is Julian day $unixEpoch" # Procedure that tests EYMDToJulianDay, EYDToJulianDay, JulianDayToEYD, # and JulianDayToEYMD proc testCal { month day year } { global unixEpoch |
︙ | ︙ |
Changes to modules/cmdline/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-09 Andreas Kupries <[email protected]> | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-09 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/comm/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-10-23 Andreas Kupries <[email protected]> | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-10-23 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/control/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-05 Andreas Kupries <[email protected]> | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-05 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/counter/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-11-20 Andreas Kupries <[email protected]> | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-11-20 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/crc/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-27 Pat Thoyts <[email protected]> | > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-05-23 Andreas Kupries <[email protected]> * crc32.tcl: Rel. engineering. Updated version number * crc32.man: of crc32 to reflect its changes, to 1.1.1. * pkgIndex.tcl: 2004-04-01 Pat Thoyts <[email protected]> * crc32.tcl: Cope with data begining with hyphen when using Trf (SF bug #914278) 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-27 Pat Thoyts <[email protected]> |
︙ | ︙ |
Changes to modules/crc/crc32.man.
|
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | [manpage_begin crc32 n 1.1.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.1.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 |
︙ | ︙ |
Changes to modules/crc/crc32.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 | # crc32.tcl -- Copyright (C) 2002 Pat Thoyts <[email protected]> # # 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. # ------------------------------------------------------------------------- | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | # crc32.tcl -- Copyright (C) 2002 Pat Thoyts <[email protected]> # # 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.13.2.2 2004/05/27 02:47:39 andreas_kupries Exp $ namespace eval ::crc { variable crc32_version 1.1.1 namespace export crc32 variable crc32_tbl [list 0x00000000 0x77073096 0xEE0E612C 0x990951BA \ 0x076DC419 0x706AF48F 0xE963A535 0x9E6495A3 \ 0x0EDB8832 0x79DCB8A4 0xE0D5E91E 0x97D2D988 \ 0x09B64C2B 0x7EB17CBD 0xE7B82D07 0x90BF1D91 \ |
︙ | ︙ | |||
160 161 162 163 164 165 166 | # 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" } | | | 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 | # 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 } |
︙ | ︙ |
Changes to modules/crc/pkgIndex.tcl.
1 2 3 | 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.1 [list source [file join $dir crc16.tcl]] | | | 1 2 3 4 5 | 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.1 [list source [file join $dir crc16.tcl]] package ifneeded crc32 1.1.1 [list source [file join $dir crc32.tcl]] package ifneeded sum 1.1.0 [list source [file join $dir sum.tcl]] |
Changes to modules/csv/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-11-22 Andreas Kupries <[email protected]> | > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-05-23 Andreas Kupries <[email protected]> * csv.tcl: Rel. engineering. Updated version number * csv.man: of csv to reflect its changes, to 0.5.1. * pkgIndex.tcl: 2004-05-03 Andreas Kupries <[email protected]> * csv.tcl (read2matrix): Fixed bogus switch case. Had case "4" twice, second should have been "5". [SF Tcllib Bug 940651]. 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-11-22 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/csv/csv.man.
1 | [comment {-*- tcl -*-}] | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | [comment {-*- tcl -*-}] [manpage_begin csv n 0.5.1] [copyright {2002 Andreas Kupries <[email protected]>}] [moddesc {CSV processing}] [titledesc {Procedures to handle CSV data.}] [require Tcl 8.3] [require csv [opt 0.5.1]] [description] [para] The [package csv] package provides commands to manipulate information in CSV [sectref FORMAT] (CSV = Comma Separated Values). |
︙ | ︙ |
Changes to modules/csv/csv.tcl.
1 2 3 4 5 6 7 8 9 10 | # csv.tcl -- # # Tcl implementations of CSV reader and writer # # Copyright (c) 2001 by Jeffrey Hobbs # Copyright (c) 2001 by Andreas Kupries <[email protected]> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # csv.tcl -- # # Tcl implementations of CSV reader and writer # # Copyright (c) 2001 by Jeffrey Hobbs # Copyright (c) 2001 by Andreas Kupries <[email protected]> # # 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.16.2.2 2004/05/27 02:47:39 andreas_kupries Exp $ package require Tcl 8.3 package provide csv 0.5.1 namespace eval ::csv { namespace export join joinlist read2matrix read2queue report namespace export split split2matrix split2queue writematrix writequeue } # ::csv::join -- |
︙ | ︙ | |||
125 126 127 128 129 130 131 | } else { set chan $a set m $b set sepChar $c set expand $d } } | | | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 | } else { set chan $a set m $b set sepChar $c set expand $d } } 5 { foreach {a b c d e} $args break if {![string equal $a "-alternate"]} { return -code error "wrong#args: Should be ?-alternate? chan m ?separator? ?expand?" } set alternate 1 set chan $b |
︙ | ︙ |
Changes to modules/csv/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 11 | # 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} | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # 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.5.1 [list source [file join $dir csv.tcl]] |
Changes to modules/des/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-07 Pat Thoyts <[email protected]> | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-07 Pat Thoyts <[email protected]> |
︙ | ︙ |
Changes to modules/devtools/microserv.tcl.
|
| | | 1 2 3 4 5 6 7 8 | # -*- tcl -*- # MicroServer (also MicroServant) # aka muserv (mu = greek micron) # # Copyright (c) 2003 by Andreas Kupries <[email protected]> # #################################################################### |
︙ | ︙ |
Changes to modules/devtools/musub.tcl.
|
| | | 1 2 3 4 5 6 7 8 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # Generic framework for a microserv.tcl based server/ # # Copyright (c) 2003 by Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/dns/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-01-22 Pat Thoyts <[email protected]> | > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | 2004-05-26 Pat Thoyts <[email protected]> * dns.tcl: Fix issue setting the log level properly. 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-01-22 Pat Thoyts <[email protected]> |
︙ | ︙ |
Changes to modules/dns/dns.tcl.
︙ | ︙ | |||
17 18 19 20 21 22 23 | # 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. # ------------------------------------------------------------------------- # | | | | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 | # 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.19.2.1 2004/05/27 03:47:22 andreas_kupries 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.1 variable rcsid {$Id: dns.tcl,v 1.19.2.1 2004/05/27 03:47:22 andreas_kupries 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}::setlevel $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 } |
︙ | ︙ | |||
138 139 140 141 142 143 144 | } } -log* { if {$cget} { return $options(loglevel) } else { set options(loglevel) [Pop args 1] | | | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 | } } -log* { if {$cget} { return $options(loglevel) } else { set options(loglevel) [Pop args 1] ${log}::setlevel $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" |
︙ | ︙ |
Changes to modules/doctools/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-09 Andreas Kupries <[email protected]> | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | 2004-05-30 Andreas Kupries <[email protected]> * mpexpand.man: Updated reference 'dtformat' to 'doctools_fmt'. 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-05-23 Andreas Kupries <[email protected]> * doctools.tcl: Rel. engineering. Updated version number * doctools.man: of doctools to reflect its changes, to 1.0.2. * pkgIndex.tcl: 2004-05-14 Andreas Kupries <[email protected]> * mpformats/_text.tcl (SECT): Fixed a small problem in the text generator which was present for ages. Titles of more than one word would have braces around them. Not fatal but also not so nice looking. It was an argument versus argument list thing. Adding a lindex in the proper place gets rid of the additional level of quoting. 2004-05-04 Andreas Kupries <[email protected]> * mpformats/_nroff.tcl: Fixed [SF Tcllib Bug 943146]. Added markup * mpformats/fmt.nroff: protection code like already in use for HTML and XML to handle nroff's special characters, i.e. the backslash properly. Also fixed handling of leading dashes in 'opt_def'. 2004-04-22 Joe English <[email protected]> * mpformats/fmt.xml: BUGFIX: "puts stderr" ==> "puts_stderr". 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-09 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/doctools/doctools.man.
1 | [comment {-*- tcl -*- doctools manpage}] | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | [comment {-*- tcl -*- doctools manpage}] [manpage_begin doctools n 1.0.2] [copyright {2003 Andreas Kupries <[email protected]>}] [moddesc {Documentation tools}] [titledesc {Create and manipulate doctools converter object}] [require Tcl 8.2] [require doctools [opt 1.0.2]] [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)]. |
︙ | ︙ |
Changes to modules/doctools/doctools.tcl.
1 2 3 4 5 6 7 8 9 | # doctools.tcl -- # # Implementation of doctools objects for Tcl. # # Copyright (c) 2003 Andreas Kupries <[email protected]> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | # doctools.tcl -- # # Implementation of doctools objects for Tcl. # # Copyright (c) 2003 Andreas Kupries <[email protected]> # # 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.7.2.1 2004/05/27 02:47:39 andreas_kupries Exp $ package require Tcl 8.2 package require textutil::expander namespace eval ::doctools { # Data storage in the doctools module # ------------------------------- |
︙ | ︙ | |||
1152 1153 1154 1155 1156 1157 1158 | # => 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]} } | | | 1152 1153 1154 1155 1156 1157 1158 1159 | # => 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.2 |
Changes to modules/doctools/mpexpand.
|
| | | 1 2 3 4 5 6 7 8 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} lappend auto_path [file dirname [file dirname [info script]]] package require doctools # --------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/doctools/mpexpand.all.
|
| | | 1 2 3 4 5 6 7 8 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} set here [file dirname [file join [pwd] [info script]]] set verbose 0 set o [lindex $argv 0] |
︙ | ︙ |
Changes to modules/doctools/mpexpand.man.
1 2 3 4 5 6 7 8 9 10 | [comment {-*- tcl -*- doctools manpage}] [manpage_begin mpexpand n 1.0] [copyright {2002 Andreas Kupries <[email protected]>}] [copyright {2003 Andreas Kupries <[email protected]>}] [moddesc {Documentation toolbox}] [titledesc {Markup processor}] [description] [para] This manpage describes a processor / converter for manpages in the | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | [comment {-*- tcl -*- doctools manpage}] [manpage_begin mpexpand n 1.0] [copyright {2002 Andreas Kupries <[email protected]>}] [copyright {2003 Andreas Kupries <[email protected]>}] [moddesc {Documentation toolbox}] [titledesc {Markup processor}] [description] [para] This manpage describes a processor / converter for manpages in the doctools format as specified in [cmd doctools_fmt]. 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 |
︙ | ︙ |
Changes to modules/doctools/mpformats/_nroff.tcl.
︙ | ︙ | |||
11 12 13 14 15 16 17 | # 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"} | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 | # 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 \1\\fB} proc nr_ul {} {return \1\\fI} proc nr_rst {} {return \1\\fR} proc nr_p {} {return \n.PP\n} proc nr_comment {text} {return "'\1\\\" [join [split $text \n] "\n'\1\\\" "]"} ; # " 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\""} ################################################################ # Handling of nroff special characters 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 unadorned special characters in content # with proper escapes. # global markupMap set markupMap [list "\\" "\1\\"] global finalMap set finalMap [list \ "\1\\" "\\" \ "\\" "\\\\"] global textMap set textMap [list "\\" "\\\\"] proc nroffEscape {text} { global textMap return [string map $textMap $text] } # markup text -- # Protect markup characters in $text. # These will be stripped out in PostProcess. # proc nroffMarkup {text} { global markupMap return [string map $markupMap $text] } proc nroff_postprocess {nroff} { global finalMap # 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 |
︙ | ︙ | |||
75 76 77 78 79 80 81 | set verbatim 0 } set line [string trimright $line] } lappend lines $line } # Return the modified result buffer | | > | 110 111 112 113 114 115 116 117 118 119 | set verbatim 0 } set line [string trimright $line] } lappend lines $line } # Return the modified result buffer return [string map $finalMap [join $lines "\n"]] } |
Changes to modules/doctools/mpformats/_text.tcl.
︙ | ︙ | |||
273 274 275 276 277 278 279 280 281 282 283 284 285 286 | 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 | > > > | 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 | return [join $linebuffer \n] } proc SECT {text} { upvar linebuffer linebuffer # text is actually the list of arguments, having one element, the text. set text [lindex $text 0] #puts_stderr "SECT $text" #puts_stderr "" # Write section title, underline it lappend linebuffer "" lappend linebuffer $text |
︙ | ︙ |
Changes to modules/doctools/mpformats/_xml.tcl.
1 2 | # -*- tcl -*- # | | | 1 2 3 4 5 6 7 8 9 10 | # -*- tcl -*- # # $Id: _xml.tcl,v 1.8.2.1 2004/05/24 02:58:10 andreas_kupries Exp $ # # [expand] utilities for generating XML. # # Copyright (C) 2001 Joe English <[email protected]>. # Freely redistributable. # ###################################################################### |
︙ | ︙ | |||
152 153 154 155 156 157 158 | 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]" | | | 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 | 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 ? -- |
︙ | ︙ |
Changes to modules/doctools/mpformats/fmt.nroff.
︙ | ︙ | |||
40 41 42 43 44 45 46 | 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] | | | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 | 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 \1\\- $description" return [c_held hdr] } c_pass 1 fmt_moddesc {desc} {c_set_module $desc} c_pass 2 fmt_moddesc {desc} NOP |
︙ | ︙ | |||
134 135 136 137 138 139 140 | if {[dt_lnesting] > 0} { return [nr_out] } return {} } proc fmt_enum {} {return [nr_item " \[[c_cnext]\]\n"]} | | | | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 | if {[dt_lnesting] > 0} { return [nr_out] } return {} } proc fmt_enum {} {return [nr_item " \[[c_cnext]\]\n"]} proc fmt_bullet {} {return [nr_item " \1\\(bu"]} proc fmt_lst_item {text} {return [nr_blt $text]} proc fmt_cmd_def {command} {return [nr_blt [fmt_cmd $command]]} proc fmt_arg_def {type name {mode {}}} { set text [nr_blt ""] 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 \1\\$name} set name [fmt_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" |
︙ | ︙ |
Changes to modules/doctools/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 11 | # 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} | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | # 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.2 [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]] |
Changes to modules/doctools/tocexpand.
|
| | | 1 2 3 4 5 6 7 8 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} rename source __source proc source {path} { set f [file join [pwd] $path] uplevel 1 __source $path |
︙ | ︙ |
Changes to modules/exif/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-09 Andreas Kupries <[email protected]> | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-09 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/fileutil/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-09 Andreas Kupries <[email protected]> | > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-05-23 Andreas Kupries <[email protected]> * fileutil.tcl: Rel. engineering. Updated version number * fileutil.man: of fileutil to reflect its changes, to 1.6.1. * pkgIndex.tcl: 2004-05-23 Andreas Kupries <[email protected]> * fileutil.test: Cleaning up after Aaron. Updated the test filetype-1.12 to look for the extended return value of fileType when applied to jpeg images. The last checkin changed this, but the test was not updated as well, most likely not even run. Found and corrected during release preparation and testing. 2004-05-11 Aaron Faupell <[email protected]> * fileutil.tcl: updated the jpeg test to recognize exif format 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-09 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/fileutil/fileutil.man.
1 | [comment {-*- tcl -*- doctools manpage}] | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | [comment {-*- tcl -*- doctools manpage}] [manpage_begin fileutil n 1.6.1] [moddesc {file utilities}] [titledesc {Procedures implementing some file utilities}] [require Tcl 8] [require fileutil [opt 1.6.1]] [description] [para] This package provides implementations of standard unix utilities. [list_begin definitions] |
︙ | ︙ |
Changes to modules/fileutil/fileutil.tcl.
1 2 3 4 5 6 7 8 9 10 | # fileutil.tcl -- # # Tcl implementations of standard UNIX utilities. # # Copyright (c) 1998-2000 by Ajuba Solutions. # Copyright (c) 2002 by Phil Ehrens <[email protected]> (fileType) # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # fileutil.tcl -- # # Tcl implementations of standard UNIX utilities. # # Copyright (c) 1998-2000 by Ajuba Solutions. # Copyright (c) 2002 by Phil Ehrens <[email protected]> (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.37.2.2 2004/05/27 02:47:39 andreas_kupries Exp $ package require Tcl 8.2 package require cmdline package provide fileutil 1.6.1 namespace eval ::fileutil { namespace export grep find findByPattern cat foreachLine } # ::fileutil::grep -- # |
︙ | ︙ | |||
421 422 423 424 425 426 427 | return "." } set pwd [file split $pwd] set npath [file split $path] if {[string match ${pwd}* $npath]} { | | | | 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 | return "." } set pwd [file split $pwd] set npath [file split $path] if {[string match ${pwd}* $npath]} { set path [eval [linsert [lrange $npath [llength $pwd] end] 0 file join ]] } 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 [linsert [lrange $path $n end] 0 file join]] } } # ::fileutil::cat -- # # Tcl implementation of the UNIX "cat" command. Returns the contents # of the specified file. |
︙ | ︙ | |||
684 685 686 687 688 689 690 | 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 | | > > | > > > | 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 | 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*" $test] } { binary scan $test c3H2Sa5 id marker len txt if {$marker == "e0" && $txt == "JFIF\x00"} { lappend type graphic jpeg jfif } elseif { $marker == "e1" && $txt == "Exif\x00" } { lappend type graphic jpeg exif } } 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 "*\<html\>*" $test] } { lappend type html } elseif { [string match "\%\!PS\-*" $test] } { |
︙ | ︙ |
Changes to modules/fileutil/fileutil.test.
1 2 3 4 5 6 7 8 9 10 | # -*- 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. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | # -*- 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.22.2.1 2004/05/24 04:17:30 andreas_kupries Exp $ # ------------------------------------------------------------------------- # Initialise the test package # if {[lsearch [namespace children] ::tcltest] == -1} { set auto_path [linsert $auto_path 0 .] package require tcltest |
︙ | ︙ | |||
465 466 467 468 469 470 471 | 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 | | | 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 | 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 jfif]] 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] |
︙ | ︙ |
Changes to modules/fileutil/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 11 | # 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} | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # 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.6.1 [list source [file join $dir fileutil.tcl]] |
Changes to modules/ftp/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-12-01 Andreas Kupries <[email protected]> | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-12-01 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/ftpd/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-10 Andreas Kupries <[email protected]> | > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-05-23 Andreas Kupries <[email protected]> * ftpd.tcl: Rel. engineering. Updated version number * ftpd.man: of ftpd to reflect its changes, to 1.2.1. * pkgIndex.tcl: 2004-05-23 Andreas Kupries <[email protected]> * Bugfixes by Gerald Lester. No details available. Gerald is asked to replace this entry with one describing his changes. 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-10 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/ftpd/ftpd.man.
1 | [comment {-*- tcl -*- doctools manpage}] | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | [comment {-*- tcl -*- doctools manpage}] [manpage_begin ftpd n 1.2.1] [moddesc {Tcl FTP Server Package}] [titledesc {Tcl FTP server implementation}] [require Tcl 8.3] [require ftpd [opt 1.2.1]] [description] The [package ftpd] package provides a simple Tcl-only server library for the FTP protocol as specified in RFC 959 ([uri http://www.rfc-editor.org/rfc/rfc959.txt]). It works by listening on the standard FTP socket. Most server errors are returned as error messages with the appropriate code attached to |
︙ | ︙ |
Changes to modules/ftpd/ftpd.tcl.
1 2 3 4 5 6 7 8 9 10 11 | # ftpd.tcl -- # # This file contains Tcl/Tk package to create a ftp daemon. # I believe it was originally written by Matt Newman ([email protected]). # Modified by Dan Kuchler ([email protected]) to handle # more ftp commands and to fix some bugs in the original implementation # that was found in the stdtcl module. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | # ftpd.tcl -- # # This file contains Tcl/Tk package to create a ftp daemon. # I believe it was originally written by Matt Newman ([email protected]). # Modified by Dan Kuchler ([email protected]) to handle # more ftp commands and to fix some bugs in the original implementation # that was found in the stdtcl module. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: ftpd.tcl,v 1.21.2.3 2004/05/27 02:47:40 andreas_kupries Exp $ # # Define the ftpd package version 1.1.2 package require Tcl 8.2 namespace eval ::ftpd { |
︙ | ︙ | |||
1070 1071 1072 1073 1074 1075 1076 | } if {$fail || ($res == 0)} { ::ftpd::Log note "AuthUsr: Access denied to <$data(user)> <$data(pass)>." unset data(user) unset data(pass) puts $sock "551 Access Denied" } else { | | | 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 | } if {$fail || ($res == 0)} { ::ftpd::Log note "AuthUsr: Access denied to <$data(user)> <$data(pass)>." unset data(user) unset data(pass) puts $sock "551 Access Denied" } else { puts $sock "230 OK" set data(access) 1 } return } # ::ftpd::command::PORT -- # |
︙ | ︙ | |||
1745 1746 1747 1748 1749 1750 1751 | switch -exact -- $command { append { # # Patched Mark O'Connor # set fhandle [open $path a] if {[lindex $args 0] == "binary"} { | | | | | 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 | switch -exact -- $command { append { # # Patched Mark O'Connor # set fhandle [open $path a] if {[lindex $args 0] == "binary"} { fconfigure $fhandle -translation binary -encoding binary } return $fhandle } retr { # # Patched Mark O'Connor # set fhandle [open $path r] if {[lindex $args 0] == "binary"} { fconfigure $fhandle -translation binary -encoding binary } return $fhandle } store { # # Patched Mark O'Connor # set fhandle [open $path w] if {[lindex $args 0] == "binary"} { fconfigure $fhandle -translation binary -encoding binary } return $fhandle } dlist { foreach {style outchan} $args break ::ftpd::Log debug "at dlist {$style} {$outchan} {$path}" #set path [glob -nocomplain $path] |
︙ | ︙ | |||
1992 1993 1994 1995 1996 1997 1998 | # Only provide the package if it has been successfully # sourced into the interpreter. # # Patched Mark O'Connor # | | | | 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 | # Only provide the package if it has been successfully # sourced into the interpreter. # # Patched Mark O'Connor # package provide ftpd 1.2.1 ## ## Implementation of passive command ## proc ::ftpd::command::PASV {sock args} { upvar #0 ::ftpd::$sock data set data(sock2a) [socket -server [list ::ftpd::PasvAccept $sock] 0] set list1 [fconfigure $sock -sockname] set ip [lindex $list1 0] set list2 [fconfigure $data(sock2a) -sockname] set port [lindex $list2 2] ::ftpd::Log debug "PASV on {$list1} {$list2} $ip $port" set ans [split $ip {.}] lappend ans [expr {($port >> 8) & 0xff}] [expr {$port & 0xff}] set ans [join $ans {,}] puts $sock "227 Entering Passive Mode ($ans)." return } proc ::ftpd::PasvAccept {sock sock2 ip port} { upvar #0 ::ftpd::$sock data |
︙ | ︙ |
Changes to modules/ftpd/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 11 | # 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} | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # 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 ftpd 1.2.1 [list source [file join $dir ftpd.tcl]] |
Changes to modules/html/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-05 Andreas Kupries <[email protected]> | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-05 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/html/html.tcl.
︙ | ︙ | |||
306 307 308 309 310 311 312 | # # Side Effects: # Throws an error if no arguments are given. proc ::html::eval {args} { # The args must be evaluated in the stack frame above this one. | | | 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 | # # Side Effects: # Throws an error if no arguments are given. proc ::html::eval {args} { # The args must be evaluated in the stack frame above this one. ::eval [linsert $args 0 uplevel] return "" } # ::html::init # # Reset state that gets accumulated for the current page. # |
︙ | ︙ | |||
653 654 655 656 657 658 659 | # args Additional attributes for the INPUT tag # # Results: # The html fragment proc ::html::textInputRow {label name {value {}} args} { variable defaults | | | 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 | # args Additional attributes for the INPUT tag # # Results: # The html fragment proc ::html::textInputRow {label name {value {}} args} { variable defaults ::set html [row $label [::eval [linsert $args 0 html::textInput $name $value]]] return $html } # ::html::passwordInputRow -- # # Format a table row containing a password input element and a label. # |
︙ | ︙ |
Changes to modules/htmlparse/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-09 Andreas Kupries <[email protected]> | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-09 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/inifile/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-10 Andreas Kupries <[email protected]> | > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-03-06 Andreas Kupries <[email protected]> * inifile.test: Fixed [Tcllib SF Bug 899204] by (a) rewriting all tests to be completely independent of each other and (b) changing the mode when opening the test file to 'r'. It should be noted that the write facilities of the module are not covered by the testsuite. That is unfortunate. 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-10 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/inifile/ini.tcl.
1 2 3 4 5 6 7 8 9 | # ini.tcl -- # # Querying and modifying old-style windows configuration files (.ini) # # Copyright (c) 2003 Aaron Faupell <[email protected]> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | # ini.tcl -- # # Querying and modifying old-style windows configuration files (.ini) # # Copyright (c) 2003 Aaron Faupell <[email protected]> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: ini.tcl,v 1.5.2.1 2004/05/24 02:58:10 andreas_kupries Exp $ package provide inifile 0.1 namespace eval ini { set nexthandle 0 set commentchar \; } |
︙ | ︙ | |||
260 261 262 263 264 265 266 | if { ![info exists comments($sec)] } { return {} } return $comments($sec) } if { ![info exists comments($sec\000$key)] } { return {} } return $comments($sec\000$key) } if { $key == "" } { | | | | 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 | if { ![info exists comments($sec)] } { return {} } return $comments($sec) } if { ![info exists comments($sec\000$key)] } { return {} } return $comments($sec\000$key) } if { $key == "" } { eval [linsert $args 0 lappend comments($sec)] } else { eval [linsert $args 0 lappend comments($sec\000$key)] } } # return the physical filename for the handle proc ::ini::filename {fh} { _valid_ns $fh |
︙ | ︙ |
Changes to modules/inifile/inifile.test.
︙ | ︙ | |||
27 28 29 30 31 32 33 | puts "- inifile [package present inifile]" #--------------------------------------------------------------------- set testini [file join [file dirname [info script]] test.ini] test inifile-1.1 {ini::open} { | | > > > | > > > | > > > | > > > | > > > | > > > | > > > | > > > | > > > | > > > | > > > | > > > | > > > | > > | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 | puts "- inifile [package present inifile]" #--------------------------------------------------------------------- set testini [file join [file dirname [info script]] test.ini] test inifile-1.1 {ini::open} { set res [ini::open $testini r] ini::close $res set res } {ini0} test inifile-1.2 {ini::sections} { set hdl [ini::open $testini r] set res [ini::sections $hdl] ini::close $hdl set res } {emptysection section1 \{test section2} test inifile-1.3 {ini::keys} { set hdl [ini::open $testini r] set res [ini::keys $hdl section1] ini::close $hdl set res } {testkey key} test inifile-1.4 {ini::keys} { set hdl [ini::open $testini r] set res [ini::keys $hdl \{test] ini::close $hdl set res } {\}key} test inifile-1.5 {ini::get} { set hdl [ini::open $testini r] set res [ini::get $hdl section1] ini::close $hdl set res } {testkey hi key value} test inifile-1.6 {ini::get} { set hdl [ini::open $testini r] set res [ini::get $hdl \{test] ini::close $hdl set res } {\}key {$blah}} test inifile-1.7 {ini::value} { set hdl [ini::open $testini r] set res [ini::value $hdl section1 key] ini::close $hdl set res } {value} test inifile-1.8 {ini::value} { set hdl [ini::open $testini r] set res [ini::value $hdl \{test \}key] ini::close $hdl set res } {$blah} test inifile-1.9 {ini::exists} { set hdl [ini::open $testini r] set res [ini::exists $hdl section1] ini::close $hdl set res } {1} test inifile-1.10 {ini::exists} { set hdl [ini::open $testini r] set res [ini::exists $hdl section] ini::close $hdl set res } {0} test inifile-1.11 {ini::exists} { set hdl [ini::open $testini r] set res [ini::exists $hdl section1 testkey] ini::close $hdl set res } {1} test inifile-1.12 {ini:::exists} { set hdl [ini::open $testini r] set res [ini::exists $hdl section1 blah] ini::close $hdl set res } {0} test inifile-1.13 {ini:::exists} { set hdl [ini::open $testini r] set res [ini::exists $hdl \{test] ini::close $hdl set res } {1} test inifile-1.14 {ini:::exists} { set hdl [ini::open $testini r] set res [ini::exists $hdl \{test \}key] ini::close $hdl set res } {1} #--------------------------------------------------------------------- # Clean up ::tcltest::cleanupTests |
Changes to modules/irc/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-01-24 Andreas Kupries <[email protected]> | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-01-24 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/javascript/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-05 Andreas Kupries <[email protected]> | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-05 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/log/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-13 Andreas Kupries <[email protected]> | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | 2004-05-26 Michael Schlenker <[email protected]> * logger.tcl: Replaced use of != for string comparision with equivalent but correcter 'string compare'. Fixed a bug with special logger names demonstrated by test 1.3. * logger.test: Added test for special logger name. 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-05-23 Andreas Kupries <[email protected]> * log.tcl: Rel. engineering. Updated version number * log.man: of log to reflect its changes, to 1.1.1. * pkgIndex.tcl: 2004-05-26 Michael Schlenker <[email protected]> * logger.tcl: Fixed bug with enable/disable wrong enabled value was reported if disable critical was used. Added "none" as result for currentloglevel for this situation. * logger.test: Added tests 7.1-7.4 to check for the above bug. * logger.man: Fixed docs and replaced the nonsensical "or" with the correct "and" in enable/disable docs. Added a comment how to completely disable logging for a service and its children. 2004-05-25 Michael Schlenker <[email protected]> * logger.tcl: Fixed bug [948273] in ::logger::services Fixed cleanup of services list in delproc Implemented doc'ed but missing ${log}::services subcommand Fixed misuse of set inside namespace eval to prevent overwriting of global variables Version number changed to 0.3.1 * pkgIndex.tcl: updated version number of logger package * logger.man: updated docs for ${log}::services. * logger.test: Added tests for fixed bugs 2004-03-09 Andreas Kupries <[email protected]> * log.tcl: Added initialization code to suppress the lower levels (warning notice info debug) from generating output. In other words, by default only statements with messages of level error or higher will generate output when the package is loaded. 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-13 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/log/log.man.
1 | [comment {-*- tcl -*- doctools manpage}] | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | [comment {-*- tcl -*- doctools manpage}] [manpage_begin log n 1.1.1] [copyright {2001-2002 Andreas Kupries <[email protected]>}] [moddesc {Logging facility}] [titledesc {Procedures to log messages of libraries and applications.}] [require Tcl 8] [require log [opt 1.1.1]] [description] [para] The [package log] package provides commands that allow libraries and applications to selectively log information about their internal operation and state. |
︙ | ︙ |
Changes to modules/log/log.tcl.
1 2 3 4 5 6 7 8 9 | # log.tcl -- # # Tcl implementation of a general logging facility # (Reaped from Pool_Base and modified to fit into tcllib) # # Copyright (c) 2001 by ActiveState Tool Corp. # See the file license.terms. package require Tcl 8 | | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | # log.tcl -- # # Tcl implementation of a general logging facility # (Reaped from Pool_Base and modified to fit into tcllib) # # Copyright (c) 2001 by ActiveState Tool Corp. # See the file license.terms. package require Tcl 8 package provide log 1.1.1 # ### ### ### ######### ######### ######### namespace eval ::log { namespace export levels lv2longform lv2color lv2priority namespace export lv2cmd lv2channel lvCompare namespace export lvSuppress lvSuppressLE lvIsSuppressed namespace export lvCmd lvCmdForall namespace export lvChannel lvChannelForall lvColor lvColorForall |
︙ | ︙ | |||
744 745 746 747 748 749 750 | # Ignore levels without channel. return } puts $chan "$level$fill($level) $text" return } | > > > > > > > | 746 747 748 749 750 751 752 753 754 755 756 757 758 759 | # Ignore levels without channel. return } puts $chan "$level$fill($level) $text" return } # ### ### ### ######### ######### ######### ## Initialization code. Disable logging for the lower levels by ## default. ## log::lvSuppressLE emergency log::lvSuppressLE warning |
Changes to modules/log/log.test.
1 2 3 4 5 6 7 8 9 | # -*- tcl -*- # Tests for the log facility # # 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. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | # -*- tcl -*- # Tests for the log facility # # 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: log.test,v 1.3.2.2 2004/05/27 03:47:22 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::* } if { [lsearch $auto_path [file dirname [info script]]] == -1 } { |
︙ | ︙ | |||
126 127 128 129 130 131 132 | test log-6.1 {channel error} { if {![catch {::log::lv2channel foo} msg]} { error "foo is an unique abbreviation of a level name" } set msg } {"foo" is no unique abbreviation of a level name} | | > > > > > | 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 | test log-6.1 {channel error} { if {![catch {::log::lv2channel foo} msg]} { error "foo is an unique abbreviation of a level name" } set msg } {"foo" is no unique abbreviation of a level name} foreach level {alert critical error emergency} { test log-7.0.$level {query suppression state} { ::log::lvIsSuppressed $level } 0 } foreach level {debug info notice warning} { test log-7.0.$level {query suppression state} { ::log::lvIsSuppressed $level } 1 } test log-7.1 {error when querying suppression state} { if {![catch {::log::lv2cmd foo} msg]} { error "foo is an unique abbreviation of a level name" } set msg |
︙ | ︙ |
Changes to modules/log/logger.man.
1 | [comment {-*- tcl -*- doctools manpage}] | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | [comment {-*- tcl -*- doctools manpage}] [comment {$Id: logger.man,v 1.8.2.1 2004/05/27 03:47:22 andreas_kupries Exp $}] [manpage_begin logger n 0.3.1] [moddesc {Object Oriented logging facility}] [titledesc {System to control logging of events.}] [require Tcl 8.2] [require logger [opt 0.3.1]] [description] [para] The [package logger] package provides a flexible system for logging messages from different services, at priority levels, with different commands. |
︙ | ︙ | |||
37 38 39 40 41 42 43 | [list_begin definitions] [call [cmd logger::init] [arg service]] Initializes the service [arg service] for logging. The service names are actually Tcl namespace names, so they are seperated with '::'. | | > > > | | | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 | [list_begin definitions] [call [cmd logger::init] [arg service]] Initializes the service [arg service] for logging. The service names are actually Tcl namespace names, so they are seperated with '::'. When a logger service is initialized, it "inherits" properties from its parents. For instance, if there were a service [term foo], and we did a [cmd logger::init] [arg foo::bar] (to create a [term bar] service underneath [term foo]), [term bar] would copy the current configuration of the [term foo] service, although it would of course, also be possible to then seperately configure [term bar]. If a logger service is initialized and the parent does not yet exist, the parent is also created. [call [cmd logger::services]] Returns a list of all the available services. [call [cmd logger::enable] [arg level]] Globally enables logging at and "above" the given level. Levels are [const debug], [const info], [const notice], [const warn], [const error], [const critical]. [call [cmd logger::disable] [arg level]] Globally disables logging at and "below" the given level. Levels are those listed above. [call [cmd logger::levels]] Returns a list of the available log levels (also listed above under [cmd enable]). [call [cmd \${log}::debug] [arg message]] |
︙ | ︙ | |||
82 83 84 85 86 87 88 | Enable logging, in the service referenced by [var \${log}], and its children, at or above the level specified, and disable logging below it. [call [cmd \${log}::enable] [arg level]] Enable logging, in the service referenced by [var \${log}], and its | | | > > | 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 | Enable logging, in the service referenced by [var \${log}], and its children, at or above the level specified, and disable logging below it. [call [cmd \${log}::enable] [arg level]] Enable logging, in the service referenced by [var \${log}], and its children, at and above the level specified. Note that this does [emph not] disable logging below this level, so you should probably use [cmd setlevel] instead. [call [cmd \${log}::disable] [arg level]] Disable logging, in the service referenced by [var \${log}], and its children, at and below the level specified. Note that this does [emph not] enable logging above this level, so you should probably use [cmd setlevel] instead. Disabling the loglevel [const critical] switches logging off for the service and its children. [call [cmd \${log}::logproc] [arg level] [arg command]] [call [cmd \${log}::logproc] [arg level] [arg argname] [arg body]] This command comes in two forms - the second, older one is deprecated and may be removed from future versions of the logger package. The current version takes one argument, a command to be executed when the |
︙ | ︙ | |||
116 117 118 119 120 121 122 | } ${log}::logproc notice logtoserver }] [call [cmd \${log}::services]] | | | | | > | 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 | } ${log}::logproc notice logtoserver }] [call [cmd \${log}::services]] Returns a list of the registered logging services which are children of this service. [call [cmd \${log}::currentloglevel]] Returns the currently enabled log level for this service. If no logging is enabled returns [const none]. [call [cmd \${log}::delproc] [arg command]] Set the script to call when the log instance in question is deleted. For example: [example { ${log}::delproc [list closesock $logsock] }] [call [cmd \${log}::delete]] |
︙ | ︙ |
Changes to modules/log/logger.tcl.
1 2 | # logger.tcl -- # | | > | | | | | | | | | | | > | > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | > > > > > > > | > > > > > > > > > > > > > > > > > | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 | # logger.tcl -- # # Tcl implementation of a general logging facility. # # Copyright (c) 2003 by David N. Welton <[email protected]> # Copyright (c) 2004 by Michael Schlenker <[email protected]> # See the file license.terms. # The logger package provides an 'object oriented' log facility that # lets you have trees of services, that inherit from one another. # This is accomplished through the use of Tcl namespaces. package provide logger 0.3.1 package require Tcl 8.2 namespace eval ::logger { namespace eval tree {} namespace export init enable disable services # The active services. variable services {} # The log 'levels'. variable levels [list debug info notice warn error critical] } # ::logger::walk -- # # Walk namespaces, starting in 'start', and evaluate 'code' in # them. # # Arguments: # start - namespace to start in. # code - code to execute in namespaces walked. # # Side Effects: # Side effects of code executed. # # Results: # None. proc ::logger::walk { start code } { set children [namespace children $start] foreach c $children { logger::walk $c $code namespace eval $c $code } } proc ::logger::init {service} { variable levels variable services # We create a 'tree' namespace to house all the services, so # they are in a 'safe' namespace sandbox, and won't overwrite # any commands. namespace eval tree::${service} { variable service variable levels } lappend services $service set [namespace current]::tree::${service}::service $service set [namespace current]::tree::${service}::levels $levels namespace eval tree::${service} { # Defaults to 'debug' level - show everything. I don't # want people to wonder where there debug messages are # going. They can turn it off themselves. variable enabled "debug" # Callback to use when the service in question is shut down. variable delcallback {} # We use this to disable a service completely. In Tcl 8.4 # or greater, by using this, disabled log calls are a # no-op! proc no-op args {} proc stdoutcmd {level text} { variable service puts "\[[clock format [clock seconds]]\] \[$service\] \[$level\] \'$text\'" } proc stderrcmd {level text} { variable service puts stderr "\[[clock format [clock seconds]]\] \[$service\] \[$level\] \'$text\'" } # setlevel -- # # This command differs from enable and disable in that # it disables all the levels below that selected, and # then enables all levels above it, which enable/disable # do not do. # # Arguments: # lv - the level, as defined in $levels. # # Side Effects: # Runs disable for the level, and then enable, in order # to ensure that all levels are set correctly. # # Results: # None. proc setlevel {lv} { disable $lv enable $lv } # enable -- # # Enable a particular 'level', and above, for the # service, and its 'children'. # # Arguments: # lv - the level, as defined in $levels. # # Side Effects: # Enables logging for the particular level, and all # above it (those more important). It also walks # through all services that are 'children' and enables # them at the same level or above. # # Results: # None. proc enable {lv} { variable levels set lvnum [lsearch -exact $levels $lv] if { $lvnum == -1 } { ::error "Invalid level '$lv' - levels are $levels" } variable enabled set elnum [lsearch -exact $levels $enabled] if {($elnum == -1) || ($elnum > $lvnum)} { set enabled $lv } while { $lvnum < [llength $levels] } { interp alias {} [namespace current]::[lindex $levels $lvnum] \ {} [namespace current]::[lindex $levels $lvnum]cmd incr lvnum } logger::walk [namespace current] [list enable $lv] } # disable -- # # Disable a particular 'level', and below, for the # service, and its 'children'. # # Arguments: # lv - the level, as defined in $levels. # # Side Effects: # Disables logging for the particular level, and all # below it (those less important). It also walks # through all services that are 'children' and disables # them at the same level or below. # # Results: # None. proc disable {lv} { variable levels set lvnum [lsearch -exact $levels $lv] if { $lvnum == -1 } { ::error "Levels are $levels" } variable enabled set elnum [lsearch -exact $levels $enabled] if {($elnum > -1) && ($elnum <= $lvnum)} { if {$lvnum+1 >= [llength $levels]} { set enabled "none" } else { set enabled [lindex $levels [expr {$lvnum+1}]] } } while { $lvnum >= 0 } { interp alias {} [namespace current]::[lindex $levels $lvnum] {} \ [namespace current]::no-op incr lvnum -1 } logger::walk [namespace current] [list disable $lv] } # currentloglevel -- # # Get the currently enabled log level for this service. # # Arguments: # none # # Side Effects: # none # # Results: # current log level # proc currentloglevel {} { variable enabled return $enabled } # logproc -- # # Command used to create a procedure that is executed to # perform the logging. This could write to disk, out to # the network, or something else. # If two arguments are given, use an existing command. # If three arguments are given, create a proc. # # Arguments: # lv - the level to log, which must be one of $levels. # args - either one or two arguments. # if one, this is a cmd name that is called for this level # if two, these are an argument and proc body # # Side Effects: # Creates a logging command to take care of the details # of logging an event. # # Results: # None. proc logproc {lv args} { variable levels set lvnum [lsearch -exact $levels $lv] if { $lvnum == -1 } { ::error "Invalid level '$lv' - levels are $levels" } switch -exact -- [llength $args] { 1 { set cmd [lindex $args 0] if {[llength [::info commands $cmd]]} { interp alias {} [namespace current]::${lv}cmd {} $cmd } else { ::error "Invalid cmd '$cmd' - does not exist" } } 2 { foreach {arg body} $args {break} proc ${lv}cmd $arg $body } default { ::error "Usage: \${log}::logproc level cmd\nor \${log}::logproc level argname body" } } } # delproc -- # # Set a callback for when the logger instance is # deleted. # # Arguments: # cmd - the Tcl command to call. # # Side Effects: # None. # # Results: # None. proc delproc {cmd} { variable delcallback set delcallback $cmd } # delete -- # # Delete the namespace and its children. proc delete {} { variable delcallback variable service logger::walk [namespace current] delete catch { uplevel \#0 $delcallback } # clean up the global services list set idx [lsearch -exact [logger::services] $service] if {$idx !=-1} { set ::logger::services [lreplace [logger::services] $idx $idx] } namespace delete [namespace current] } # services -- # # Return all child services proc services {} { variable service set children [list] foreach srv [logger::services] { if {[string match "${service}::*" $srv]} { lappend children $srv } } return $children } # Walk the parent service namespaces to see first, if they # exist, and if any are enabled, and then, as a # consequence, enable this one # too. enable $enabled variable parent [namespace parent] while {[string compare $parent "::logger::tree"]} { # If the 'enabled' variable doesn't exist, create the # whole thing. if { ! [::info exists ${parent}::enabled] } { logger::init [string range $parent 16 end] } set enabled [set ${parent}::enabled] enable $enabled set parent [namespace parent $parent] } } # Now create the commands for different levels. namespace eval tree::${service} { set parent [namespace parent] # We 'inherit' the commands from the parents. This # means that, if you want to share the same methods with # children, they should be instantiated after the parent's # methods have been defined. if {[string compare $parent "::logger::tree"]} { interp alias {} [namespace current]::debugcmd {} ${parent}::debugcmd interp alias {} [namespace current]::infocmd {} ${parent}::infocmd interp alias {} [namespace current]::noticecmd {} ${parent}::noticecmd interp alias {} [namespace current]::warncmd {} ${parent}::warncmd interp alias {} [namespace current]::errorcmd {} ${parent}::errorcmd interp alias {} [namespace current]::criticalcmd {} ${parent}::criticalcmd } else { proc debugcmd {txt} { stdoutcmd debug $txt } proc infocmd {txt} { stdoutcmd info $txt } proc noticecmd {txt} { stdoutcmd notice $txt } proc warncmd {txt} { stderrcmd warn $txt } proc errorcmd {txt} { stderrcmd error $txt } proc criticalcmd {txt} { stderrcmd critical $txt } } } return ::logger::tree::${service} } # ::logger::services -- # # Returns a list of all active services. # # Arguments: # None. # # Side Effects: # None. # # Results: # List of active services. proc ::logger::services {} { variable services return $services } # ::logger::enable -- # # Global enable for a certain level. NOTE - this implementation # isn't terribly effective at the moment, because it might hit # children before their parents, who will then walk down the # tree attempting to disable the children again. # # Arguments: # lv - level above which to enable logging. # # Side Effects: # Enables logging in a given level, and all higher levels. # # Results: # None. proc ::logger::enable {lv} { variable services foreach sv $services { ::logger::tree::${sv}::enable $lv } } proc ::logger::disable {lv} { variable services foreach sv $services { ::logger::tree::${sv}::disable $lv } } # ::logger::levels -- # # Introspect the available log levels. Provided so a caller does # not need to know implementation details or code the list # himself. # # Arguments: # None. # # Side Effects: # None. # # Results: # levels - The list of valid log levels accepted by enable and disable proc ::logger::levels {} { variable levels return $levels } |
Changes to modules/log/logger.test.
1 2 3 4 5 6 7 8 | # -*- tcl -*- # Tests for the logger facility. # # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # # Copyright (c) 2002 by David N. Welton <[email protected]>. # | > | | > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 | # -*- tcl -*- # Tests for the logger facility. # # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # # Copyright (c) 2002 by David N. Welton <[email protected]>. # Copyright (c) 2004 by Michael Schlenker <[email protected]>. # # $Id: logger.test,v 1.5.2.1 2004/05/27 03:47:22 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::* } set auto_path "[file dirname [info script]] $auto_path" package require logger 0.3.1 test logger-1.0 {init basic} { set log [logger::init global] ${log}::delete set log } {::logger::tree::global} test logger-1.1 {init sub-system} { set log [logger::init global::subsystem] ${log}::delete # cleanup the leftover global log ::logger::tree::global::delete set log } {::logger::tree::global::subsystem} test logger-1.2 {instantiate main logger and child} { set log1 [logger::init global] set log2 [logger::init global::subsystem] ${log2}::delete ${log1}::delete list $log1 $log2 } {::logger::tree::global ::logger::tree::global::subsystem} test logger-1.3 {instantiate logger with problematic name} { set log [logger::init foo::logger::tree::bar] set services [logger::services] # direct cleanup of logger namespace foreach srv $services { ::logger::tree::${srv}::delete } set services_post [logger::services] list $log [lsort $services] $services_post } {::logger::tree::foo::logger::tree::bar {foo foo::logger foo::logger::tree foo::logger::tree::bar} {}} test logger-2.0 {delete} { set log [logger::init global] ${log}::delete catch {set ${log}::enabled} err set err } {can't read "::logger::tree::global::enabled": no such variable} |
︙ | ︙ | |||
190 191 192 193 194 195 196 | ${log1}::warn "warn" ${log1}::notice "notice" ${log1}::delete set ::INFO } {{Error Message} {Warning Message}} test logger-6.0 {levels command} { | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > | 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 | ${log1}::warn "warn" ${log1}::notice "notice" ${log1}::delete set ::INFO } {{Error Message} {Warning Message}} test logger-6.0 {levels command} { logger::levels } {debug info notice warn error critical} test logger-7.0 {currentloglevel} { set log [logger::init global] foreach lvl [logger::levels] { ${log}::setlevel $lvl lappend result [${log}::currentloglevel] } ${log}::delete set result } {debug info notice warn error critical} test logger-7.1 {currentloglevel, disable all} { set log [logger::init global] ${log}::disable critical set result [${log}::currentloglevel] ${log}::delete set result } {none} test logger-7.2 {currentloglevel, enable incremental} { set results "" set log [logger::init global] ${log}::disable critical ${log}::enable critical lappend results [${log}::currentloglevel] ${log}::enable debug lappend results [${log}::currentloglevel] ${log}::delete set results } {critical debug} test logger-7.3 {currentloglevel, enable incremental} { set results "" set log [logger::init global] ${log}::disable critical ${log}::enable debug lappend results [${log}::currentloglevel] ${log}::enable critical lappend results [${log}::currentloglevel] ${log}::delete set results } {debug debug} test logger-7.3 {currentloglevel, disable incremental} { set results "" set log [logger::init global] ${log}::enable debug lappend results [${log}::currentloglevel] ${log}::disable critical lappend results [${log}::currentloglevel] ${log}::disable debug lappend results [${log}::currentloglevel] ${log}::delete set results } {debug none none} test logger-7.4 {currentloglevel, disable incremental} { set results "" set log [logger::init global] ${log}::enable debug lappend results [${log}::currentloglevel] ${log}::disable debug lappend results [${log}::currentloglevel] ${log}::disable critical lappend results [${log}::currentloglevel] ${log}::delete set results } {debug info none} test logger-8.0 {logproc with existing proc, non existing proc} { set log [logger::init global] catch { ${log}::logproc warn NoSuchProc } msg ${log}::delete set msg } {Invalid cmd 'NoSuchProc' - does not exist} test logger-8.1 {logproc with existing proc, no arguments} { set log [logger::init global] catch { ${log}::logproc warn } msg ${log}::delete set msg } "Usage: \${log}::logproc level cmd\nor \${log}::logproc level argname body" test logger-8.2 {logproc with existing proc} { set ::INFO "" set log [logger::init global] proc errorlogproc {txt} { lappend ::INFO "Error Message: $txt" } set msg [info commands errorlogproc] ${log}::logproc error errorlogproc ${log}::error "error" ${log}::error "second error" ${log}::delete rename errorlogproc "" list $msg $::INFO } {errorlogproc {{Error Message: error} {Error Message: second error}}} test logger-8.3 {logproc with args and body} { set ::INFO "" set log [logger::init global] ${log}::logproc error txt {lappend ::INFO "Error Message: $txt"} ${log}::error "error" ${log}::error "second error" ${log}::delete set ::INFO } {{Error Message: error} {Error Message: second error}} test logger-8.4 {logproc with existing proc, survive level switching} { set ::INFO "" set log [logger::init global] proc errorlogproc {txt} { lappend ::INFO "Error Message: $txt" } ${log}::logproc error errorlogproc ${log}::error "error" ${log}::setlevel critical ${log}::error "this should not be in the logfile" ${log}::setlevel notice ${log}::error "second error" ${log}::delete rename errorlogproc "" set ::INFO } {{Error Message: error} {Error Message: second error}} test logger-9.0 {services subcommand} { set log [logger::init global] set result [logger::services] ${log}::delete set result } {global} test logger-9.1 {services subcommand, no child services} { set log [logger::init global] set services [${log}::services] ${log}::delete set services } {} test logger-9.2 {services subcommand, children services} { set log [logger::init global] set child [logger::init global::child] set result [list [logger::services] [${log}::services] [${child}::services]] ${log}::delete set result } [list [list global global::child] global::child {}] ::tcltest::cleanupTests return |
Changes to modules/log/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 11 | # 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]} {return} | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # 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]} {return} package ifneeded log 1.1.1 [list source [file join $dir log.tcl]] if {![package vsatisfies [package provide Tcl] 8.2]} {return} package ifneeded logger 0.3.1 [list source [file join $dir logger.tcl]] |
Changes to modules/math/ChangeLog.
1 2 3 4 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== | > > > > > > > > > > > | > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | 2004-06-18 Kevin Kenny <[email protected]> * combinatorics.test: Kevin added the display of the math version number to the test. 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-09 Jeff Hobbs <[email protected]> * combinatorics.tcl (::math::factorial): correct fac 171 off-by-one and use of -strict in string is int|double. 2003-12-22 Joe English <[email protected]> * calculus.man (rungeKuttaStep): Add missing argument in function synopsis (bug report from Richard Body). 2003-10-29 Arjen Markus <[email protected]> * statistics.tcl (BasicStat): Applied fix for [SF Tcllib Bug 820807]. Uniform data may cause a small negative value when computing the base value for a standard deviation, instead of the correct 0.0. The fix now enforces 0.0 when encountering this situation. This entry in the ChangeLog by Andreas Kupries. 2003-05-05 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.4 ======================== * 2003-04-24 Andreas Kupries <[email protected]> * pkgIndex.tcl: Found math::optimize missing in index. * optimize.man: Version number inconsistent with code, corrected. |
︙ | ︙ | |||
59 60 61 62 63 64 65 | 2003-04-21 Andreas Kupries <[email protected]> * optimize.test: Corrected errors in loading the functionality under test, and of accessing tcltest. Now functional. 2003-04-18 Joe English <[email protected] | | | | 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 | 2003-04-21 Andreas Kupries <[email protected]> * optimize.test: Corrected errors in loading the functionality under test, and of accessing tcltest. Now functional. 2003-04-18 Joe English <[email protected] * optimize.man: fix minor markup errors that doctools and tmml were complaining about. 2003-04-16 Andreas Kupries <[email protected]> * pkgIndex.tcl: Added math::statistics after yesterday's commit by Arjen Markus. * statistics.test: Changed to conform to standard of importing |
︙ | ︙ | |||
83 84 85 86 87 88 89 | 2003-04-13 Andreas Kupries <[email protected]> * pkgIndex.tcl: * fuzzy.tcl: Committed new code (see #535216), this also updates the package to version 0.2 | | | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 | 2003-04-13 Andreas Kupries <[email protected]> * pkgIndex.tcl: * fuzzy.tcl: Committed new code (see #535216), this also updates the package to version 0.2 * fuzzy.man: * fuzzy.test: New files for fuzzy comparisons, documentation and testsuite. Fixed some bugs in them. NOTE: There are failures in the testsuite. 2003-04-11 Andreas Kupries <[email protected]> * combinatorics.man: |
︙ | ︙ | |||
174 175 176 177 178 179 180 | 2002-01-11 Kevin Kenny <[email protected]> * combinatorics.tcl: Removed incorrect 'package provide'. 2002-01-11 Kevin Kenny <[email protected]> | | | | | | | | | 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 | 2002-01-11 Kevin Kenny <[email protected]> * combinatorics.tcl: Removed incorrect 'package provide'. 2002-01-11 Kevin Kenny <[email protected]> * math.tcl: * misc.tcl: * pkgIndex.tcl: * tclIndex: Reorganized so that math.tcl is a top-level 'package provide' script and loads a tclIndex. The code from 'math.tcl' moves into 'misc.tcl'. * combinatorics.n: * combinatorics.tcl: * combinatorics.test: Added a 'combinatorics' module containing the Gamma function and several related functions (factorial, binomial coefficient, and Beta). (Feature request #484850). 2001-06-21 Andreas Kupries <[email protected]> * math.tcl: Fixed dubious code reported by frink. 2000-10-06 Eric Melski <[email protected]> * math.test: * math.n: * math.tcl: Added ::math::fibonacci function, to compute numbers in the Fibonacci sequence. 2000-09-08 Eric Melski <[email protected]> * math.test: * math.n: * math.tcl: Added ::math::random function. * pkgIndex.tcl: Bumped version number to 1.1. 2000-06-15 Eric Melski <[email protected]> * math.n: * math.test: * math.tcl: Incorporated sigma, cov, stats, integrate functions (from Philip Ehrens <[email protected]>). [RFE: 5060] 2000-03-27 Eric Melski <[email protected]> * math.n: * math.test: * math.tcl: Added sum, mean, and product functions (from Philip Ehrens <[email protected]>). 2000-03-09 Eric Melski <[email protected]> * math.test: Adapted tests for use in/out of tcllib test framework. 2000-03-07 Eric Melski <[email protected]> * pkgIndex.tcl: * math.tcl: * math.test: * math.n: Initial versions of files for math library. |
Changes to modules/math/combinatorics.test.
1 2 3 4 5 6 7 8 9 | # Tests for combinatorics functions in math 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) 2001 by Kevin B. Kenny # All rights reserved. # | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | # Tests for combinatorics functions in math 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) 2001 by Kevin B. Kenny # All rights reserved. # # RCS: @(#) $Id: combinatorics.test,v 1.6.2.1 2004/06/25 04:37:24 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::* } source [file join [file dirname [info script]] math.tcl] source [file join [file dirname [info script]] combinatorics.tcl] package require math # 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 } { |
︙ | ︙ |
Changes to modules/md4/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-08 Pat Thoyts <[email protected]> | > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-05-23 Andreas Kupries <[email protected]> * md4.tcl: Rel. engineering. Updated version number * md4.man: of md4 to reflect its changes, to 1.0.2. * pkgIndex.tcl: 2004-02-18 Pat Thoyts <[email protected]> * md4.tcl: Streamlined the rotate-left function and fixed a rare bug that occurs if the hash result produces a hypen as the first character and we are using Trf's hex function. 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-08 Pat Thoyts <[email protected]> |
︙ | ︙ |
Changes to modules/md4/md4.man.
|
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | [manpage_begin md4 n 1.0.2] [moddesc {md4}] [copyright {2003, Pat Thoyts <[email protected]>}] [titledesc {MD4 Message-Digest Algorithm}] [require Tcl 8.2] [require md4 [opt 1.0.2]] [description] [para] This package is an implementation in Tcl of the MD4 message-digest algorithm as described in RFC 1320 (1) and (2). This algorithm takes an arbitrary quantity of data and generates a 128-bit message digest from the input. The MD4 algorithm is faster but potentially weaker than |
︙ | ︙ |
Changes to modules/md4/md4.tcl.
1 2 3 4 5 6 7 8 9 10 | # md4.tcl - Copyright (C) 2003 Pat Thoyts <[email protected]> # # This is a Tcl-only implementation of the MD4 hash algorithm as described in # RFC 1320 ( http://www.ietf.org/rfc/rfc1320.txt ) # # ------------------------------------------------------------------------- # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- # | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | # md4.tcl - Copyright (C) 2003 Pat Thoyts <[email protected]> # # This is a Tcl-only implementation of the MD4 hash algorithm as described in # RFC 1320 ( http://www.ietf.org/rfc/rfc1320.txt ) # # ------------------------------------------------------------------------- # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- # # $Id: md4.tcl,v 1.9.2.2 2004/05/27 02:47:41 andreas_kupries Exp $ package require Tcl 8.2; # tcl minimum version catch {package require md4c 1.0}; # tcllib critcl alternative namespace eval ::md4 { variable version 1.0.2 variable rcsid {$Id: md4.tcl,v 1.9.2.2 2004/05/27 02:47:41 andreas_kupries Exp $} namespace export md4 hmac MD4Init MD4Update MD4Final variable uid if {![info exists uid]} { set uid 0 } |
︙ | ︙ | |||
276 277 278 279 280 281 282 | [expr {(0xFF00 & $v) >> 8}] \ [expr {(0xFF0000 & $v) >> 16}] \ [expr {((0xFF000000 & $v) >> 24) & 0xFF}] } # 32bit rotate-left proc ::md4::<<< {v n} { | > > | | | 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 | [expr {(0xFF00 & $v) >> 8}] \ [expr {(0xFF0000 & $v) >> 16}] \ [expr {((0xFF000000 & $v) >> 24) & 0xFF}] } # 32bit rotate-left proc ::md4::<<< {v n} { return [expr {((($v << $n) \ | (($v >> (32 - $n)) \ & (0x7FFFFFFF >> (31 - $n))))) \ & 0xFFFFFFFF}] } # Convert our <<< pseuodo-operator into a procedure call. regsub -all -line \ {\[expr {(.*) <<< (\d+)}\]} \ $::md4::MD4Hash_body \ {[<<< [expr {\1}] \2]} \ |
︙ | ︙ | |||
329 330 331 332 333 334 335 | # Define the MD4 hashing procedure with inline functions. proc ::md4::MD4Hash {token msg} $::md4::MD4Hash_body # ------------------------------------------------------------------------- if {[package provide Trf] != {}} { | | | 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 | # Define the MD4 hashing procedure with inline functions. proc ::md4::MD4Hash {token msg} $::md4::MD4Hash_body # ------------------------------------------------------------------------- if {[package provide Trf] != {}} { interp alias {} ::md4::Hex {} ::hex -mode encode -- } else { proc ::md4::Hex {data} { set result {} binary scan $data c* r foreach c $r { append result [format "%02X" [expr {$c & 0xff}]] } |
︙ | ︙ |
Changes to modules/md4/md4.test.
1 2 | # md4.test - Copyright (C) 2003 Pat Thoyts <[email protected]> # | | | 1 2 3 4 5 6 7 8 9 10 | # md4.test - Copyright (C) 2003 Pat Thoyts <[email protected]> # # $Id: md4.test,v 1.4.2.1 2004/05/24 03:13:33 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::* } package require md4 |
︙ | ︙ | |||
187 188 189 190 191 192 193 | 145 B9FF2575260E2AD08557EEBA52B27CDD 146 BCCCBCFEAB174BDDB81CC74DD97984F6 147 9B98A75EDED6B5AF8C449B75A74C30B3 148 5F9F642231152DD8CD5CAA9B5FC59B5D 149 84D82189C5458F8647D338FD62EF1667 } { test md4-2.$n "md4 block size checks: length $n" { | > | > | | 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 | 145 B9FF2575260E2AD08557EEBA52B27CDD 146 BCCCBCFEAB174BDDB81CC74DD97984F6 147 9B98A75EDED6B5AF8C449B75A74C30B3 148 5F9F642231152DD8CD5CAA9B5FC59B5D 149 84D82189C5458F8647D338FD62EF1667 } { test md4-2.$n "md4 block size checks: length $n" { list [catch { ::md4::md4 -hex [string repeat a $n] } msg] $msg } [list 0 $hash] } ::tcltest::cleanupTests # ------------------------------------------------------------------------- # Local Variables: # mode: tcl # indent-tabs-mode: nil # End: |
Changes to modules/md4/md4_check.c.
1 2 3 4 5 6 7 | /* md4_check.c Copyright (C) 2003 Pat Thoyts <[email protected]> * * Generate test data to permit comparison of the tcl implementation of MD4 * against the OpenSSL library implementation. * * usage: md4_check * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | /* md4_check.c Copyright (C) 2003 Pat Thoyts <[email protected]> * * Generate test data to permit comparison of the tcl implementation of MD4 * against the OpenSSL library implementation. * * usage: md4_check * * $Id: md4_check.c,v 1.2.2.1 2004/05/24 03:13:33 andreas_kupries Exp $ */ #include <stdlib.h> #include <stdio.h> #include <string.h> #include <openssl/md4.h> static const char rcsid[] = "$Id: md4_check.c,v 1.2.2.1 2004/05/24 03:13:33 andreas_kupries Exp $"; void md4(const char *buf, size_t len, unsigned char *res) { MD4_CTX ctx; MD4_Init(&ctx); MD4_Update(&ctx, buf, len); |
︙ | ︙ |
Changes to modules/md4/md4c.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 | # md4c.tcl - Copyright (C) 2003 Pat Thoyts <[email protected]> # # This provides a C implementation of MD4 using the sample code from RFC1320 # and wrapping this up in a Tcl package. # # The tcl interface code is based upon the md5c code from critcl by JCW. # # INSTALLATION # ------------ # This package uses critcl (http://wiki.tcl.tk/critcl). To build do: # critcl -libdir <your-tcl-lib-dir> -pkg md4c md4c # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # md4c.tcl - Copyright (C) 2003 Pat Thoyts <[email protected]> # # This provides a C implementation of MD4 using the sample code from RFC1320 # and wrapping this up in a Tcl package. # # The tcl interface code is based upon the md5c code from critcl by JCW. # # INSTALLATION # ------------ # This package uses critcl (http://wiki.tcl.tk/critcl). To build do: # critcl -libdir <your-tcl-lib-dir> -pkg md4c md4c # # $Id: md4c.tcl,v 1.4.2.1 2004/05/24 03:13:33 andreas_kupries Exp $ package require critcl package provide md4c 1.0.0 critcl::cheaders md4.h critcl::csources md4.c |
︙ | ︙ |
Changes to modules/md4/pkgIndex.tcl.
1 2 3 4 5 6 | # pkgIndex.tcl - # # md4 package index file # # This package has been tested with tcl 8.2.3 and above. # | | | | 1 2 3 4 5 6 7 8 9 10 | # pkgIndex.tcl - # # md4 package index file # # This package has been tested with tcl 8.2.3 and above. # # $Id: pkgIndex.tcl,v 1.3.2.2 2004/05/27 02:47:42 andreas_kupries Exp $ if {![package vsatisfies [package provide Tcl] 8.2]} {return} package ifneeded md4 1.0.2 [list source [file join $dir md4.tcl]] |
Changes to modules/md5/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-12 Andreas Kupries <[email protected]> | > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-05-23 Andreas Kupries <[email protected]> * md5x.tcl: Rel. engineering. Updated version number * md5.man: of md5 v2 to reflect its changes, to 2.0.1. * pkgIndex.tcl: 2004-02-18 Pat Thoyts <[email protected]> * md5x.tcl: Added -- to end options if using Trf's hex in case the hash begins with a - character (possible). Streamlined the <<< proc. 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-12 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/md5/md5.man.
|
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | [manpage_begin md5 n 2.0.1] [moddesc {Perform md5 hashing}] [copyright {2003, Pat Thoyts <[email protected]>}] [titledesc {MD5 Message-Digest Algorithm}] [require Tcl 8.2] [require md5 [opt 2.0.1]] [description] [para] This package is an implementation in Tcl of the MD5 message-digest algorithm as described in RFC 1321 (1). This algorithm takes an arbitrary quantity of data and generates a 128-bit message digest from the input. The MD5 algorithm is related to the MD4 algorithm (2) |
︙ | ︙ |
Changes to modules/md5/md5.test.
1 2 3 4 5 6 7 8 9 10 | # -*- tcl -*- # md5.test: tests for the md5 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. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | # -*- tcl -*- # md5.test: tests for the md5 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: md5.test,v 1.8.2.1 2004/05/24 03:13:33 andreas_kupries Exp $ # ------------------------------------------------------------------------- # Initialize the test package # if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::* |
︙ | ︙ |
Changes to modules/md5/md5c.tcl.
1 2 3 4 5 6 | # md5c.tcl - # # Wrapper for RSA's Message Digest in C # # Written by Jean-Claude Wippler <[email protected]> # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # md5c.tcl - # # Wrapper for RSA's Message Digest in C # # Written by Jean-Claude Wippler <[email protected]> # # $Id: md5c.tcl,v 1.3.2.1 2004/05/24 03:13:33 andreas_kupries Exp $ package require critcl; # needs critcl package provide md5c 0.11; # critcl::cheaders md5.h; # The RSA header file critcl::csources md5.c; # The RSA MD5 implementation. |
︙ | ︙ |
Changes to modules/md5/md5x.tcl.
︙ | ︙ | |||
12 13 14 15 16 17 18 | # critcl (md5c) or Trf. # # ------------------------------------------------------------------------- # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- # | | | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | # critcl (md5c) or Trf. # # ------------------------------------------------------------------------- # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- # # $Id: md5x.tcl,v 1.3.2.2 2004/05/27 02:47:42 andreas_kupries Exp $ package require Tcl 8.2; # tcl minimum version # Try and load a compiled extension to help. if {[catch {package require tcllibc}]} { if {[catch {package require md5c}]} { catch { package requre Trf package require Memchan } } } namespace eval ::md5 { variable version 2.0.1 variable rcsid {$Id: md5x.tcl,v 1.3.2.2 2004/05/27 02:47:42 andreas_kupries Exp $} namespace export md5 hmac MD5Init MD5Update MD5Final variable uid if {![info exists uid]} { set uid 0 } |
︙ | ︙ | |||
378 379 380 381 382 383 384 | [expr {(0xFF00 & $v) >> 8}] \ [expr {(0xFF0000 & $v) >> 16}] \ [expr {((0xFF000000 & $v) >> 24) & 0xFF}] } # 32bit rotate-left proc ::md5::<<< {v n} { | > > | | | 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 | [expr {(0xFF00 & $v) >> 8}] \ [expr {(0xFF0000 & $v) >> 16}] \ [expr {((0xFF000000 & $v) >> 24) & 0xFF}] } # 32bit rotate-left proc ::md5::<<< {v n} { return [expr {((($v << $n) \ | (($v >> (32 - $n)) \ & (0x7FFFFFFF >> (31 - $n))))) \ & 0xFFFFFFFF}] } # Convert our <<< pseuodo-operator into a procedure call. regsub -all -line \ {\[expr {(\$[ABCD]) \+ \(\((.*)\)\s+<<<\s+(\d+)\)}\]} \ $::md5::MD5Hash_body \ {[expr {\1 + [<<< [expr {\2}] \3]}]} \ |
︙ | ︙ | |||
481 482 483 484 485 486 487 | # Define the MD5 hashing procedure with inline functions. proc ::md5::MD5Hash {token msg} $::md5::MD5Hash_bodyX # ------------------------------------------------------------------------- if {[package provide Trf] != {}} { | | | 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 | # Define the MD5 hashing procedure with inline functions. proc ::md5::MD5Hash {token msg} $::md5::MD5Hash_bodyX # ------------------------------------------------------------------------- if {[package provide Trf] != {}} { interp alias {} ::md5::Hex {} ::hex -mode encode -- } else { proc ::md5::Hex {data} { set result {} binary scan $data c* r foreach c $r { append result [format "%02X" [expr {$c & 0xff}]] } |
︙ | ︙ |
Changes to modules/md5/md5x.test.
1 2 3 4 5 6 7 8 9 10 | # -*- tcl -*- # md5.test: tests for the md5 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. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | # -*- tcl -*- # md5.test: tests for the md5 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: md5x.test,v 1.5.2.1 2004/05/24 03:13:33 andreas_kupries Exp $ # ------------------------------------------------------------------------- # Initialize the test package # if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::* |
︙ | ︙ |
Changes to modules/md5/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 11 | # 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} | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | # 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 md5 2.0.1 [list source [file join $dir md5x.tcl]] package ifneeded md5 1.4.3 [list source [file join $dir md5.tcl]] |
Changes to modules/md5crypt/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-12 Andreas Kupries <[email protected]> | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-12 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/mime/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-12 Andreas Kupries <[email protected]> | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-05-23 Andreas Kupries <[email protected]> * mime.tcl: Downgraded mime to version 1.3.6, and removed the * mime.man: -decode extension from the API. This branch is for * pkgIndex.tcl: bugfixes only. 2004-05-19 Andreas Kupries <[email protected]> * mime.test: * mime.tcl: Fixed [SF Tcllib Bug 954328]. The package mime now adapts at runtime to whatever version of package md5 has been loaded. 2004-05-12 Andreas Kupries <[email protected]> * smtp.tcl (::smtp::wdata): Fixed [SF Tcllib Bug 951568]. Added handlers for the query/* commands from Trf. Also changed the default to sliently pass all unknowns in the future. 2004-05-10 Andreas Kupries <[email protected]> * mime.tcl (copymessageaux): Applied the patch for [SF Tcllib Bug 893516] on behalf of Marshall Rose. The problem was found by Todd Copeland <[email protected]>, he provided the patch as well. 2004-05-04 Andreas Kupries <[email protected]> * mime.man: * mime.test: * mime.tcl: Applied [SF Tcllib Patch 763712]. This extends the functionality of mime::getbody with decoding of the mime part based on the specified charset into the regular utf8 form. Testsuite was updated and extended as well. Thanks to Matthew Walker <[email protected]> for the work. Updated the documentation for mime on my own. Bumped version to 1.4. * mime:test: * mime.tcl: Applied [SF Tcllib Patch 758742], adding many more MIME types for encodings to the knowledge-base of the package. Thanks to Matthew Walker <[email protected]> for the work, and Mikhail Teterin <[email protected]> for prodding. Bumped version to 1.3.5. * mime.test: * mime.tcl (copymessageaux): Fixed [SF Tcllib Bug 620852]. Added '-nonewline' to the puts statements which wrote out the chunks read from the file associated with the mime part, converted or not. As the data was [read] we had no business of adding eol's during writing as well. Thanks to Jasper Taylor <[email protected]> for the report, and his patience. Added a test for this as well, using files of similar size as originally provided. 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-12 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/mime/mime.man.
1 | [comment {-*- tcl -*- doctools manpage}] | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | [comment {-*- tcl -*- doctools manpage}] [manpage_begin mime n 1.3.6] [copyright {1999-2000 Marshall T. Rose}] [moddesc {Mime}] [titledesc {Manipulation of MIME body parts}] [require Tcl] [require mime [opt 1.3.6]] [description] [para] The [package mime] library package provides the commands to create and manipulate MIME body parts. [list_begin definitions] |
︙ | ︙ | |||
173 174 175 176 177 178 179 | size of each fragment passed to the callback.) [nl] When the end of the body is reached, the callback is invoked as: [example { | | | | | 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 | 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 [cmd ::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. |
︙ | ︙ |
Changes to modules/mime/mime.tcl.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # 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 | | | > > > | | | > > > > > > > > | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 | # 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.6 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 set major [lindex [split [package require md5] .] 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] } if {$::major < 2} { # md5 v1, result is hex string ready for use. proc md5 {-- string} { return [md5::md5 $string] } } else { # md5 v2, need option to get hex string proc md5 {-- string} { return [md5::md5 -hex $string] } } proc unstack {channel} { # do nothing return } } unset major } # # state variables: # # canonicalP: input is in its canonical form # content: type/subtype |
︙ | ︙ | |||
108 109 110 111 112 113 114 | LX_LSQUARE LX_RSQUARE \ LX_EQUALS LX_SOLIDUS \ LX_QUOTE] set encList [list \ ascii US-ASCII \ big5 Big5 \ | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > | | | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 | LX_LSQUARE LX_RSQUARE \ LX_EQUALS LX_SOLIDUS \ LX_QUOTE] set encList [list \ ascii US-ASCII \ big5 Big5 \ cp1250 Windows-1250 \ cp1251 Windows-1251 \ cp1252 Windows-1252 \ cp1253 Windows-1253 \ cp1254 Windows-1254 \ cp1255 Windows-1255 \ cp1256 Windows-1256 \ cp1257 Windows-1257 \ cp1258 Windows-1258 \ cp437 IBM437 \ cp737 "" \ cp775 IBM775 \ cp850 IBM850 \ cp852 IBM852 \ cp855 IBM855 \ cp857 IBM857 \ cp860 IBM860 \ cp861 IBM861 \ cp862 IBM862 \ cp863 IBM863 \ cp864 IBM864 \ cp865 IBM865 \ cp866 IBM866 \ cp869 IBM869 \ cp874 "" \ cp932 "" \ cp936 GBK \ cp949 "" \ cp950 "" \ dingbats "" \ ebcdic "" \ 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-10 ISO-8859-10 \ iso8859-13 ISO-8859-13 \ iso8859-14 ISO-8859-14 \ iso8859-15 ISO-8859-15 \ iso8859-16 ISO-8859-16 \ jis0201 JIS_X0201 \ jis0208 JIS_C6226-1983 \ jis0212 JIS_X0212-1990 \ koi8-r KOI8-R \ koi8-u KOI8-U \ ksc5601 KS_C_5601-1987 \ macCentEuro "" \ macCroatian "" \ macCyrillic "" \ macDingbats "" \ macGreek "" \ macIceland "" \ macJapan "" \ macRoman "" \ macRomania "" \ macThai "" \ macTurkish "" \ macUkraine "" \ shiftjis Shift_JIS \ symbol "" \ tis-620 TIS-620 \ unicode "" \ utf-8 UTF-8] variable encodings array set encodings $encList variable reversemap foreach {enc mimeType} $encList { if {$mimeType != ""} { set reversemap([string tolower $mimeType]) $enc } } set encAliasList [list \ ascii ANSI_X3.4-1968 \ ascii iso-ir-6 \ ascii ANSI_X3.4-1986 \ ascii ISO_646.irv:1991 \ ascii ASCII \ ascii ISO646-US \ ascii us \ ascii IBM367 \ ascii cp367 \ cp437 cp437 \ cp437 437 \ cp775 cp775 \ cp850 cp850 \ cp850 850 \ cp852 cp852 \ cp852 852 \ cp855 cp855 \ cp855 855 \ cp857 cp857 \ cp857 857 \ cp860 cp860 \ cp860 860 \ cp861 cp861 \ cp861 861 \ cp861 cp-is \ cp862 cp862 \ cp862 862 \ cp863 cp863 \ cp863 863 \ cp864 cp864 \ cp865 cp865 \ cp865 865 \ cp866 cp866 \ cp866 866 \ cp869 cp869 \ cp869 869 \ cp869 cp-gr \ cp936 CP936 \ cp936 MS936 \ cp936 Windows-936 \ iso8859-1 ISO_8859-1:1987 \ iso8859-1 iso-ir-100 \ iso8859-1 ISO_8859-1 \ iso8859-1 latin1 \ iso8859-1 l1 \ iso8859-1 IBM819 \ iso8859-1 CP819 \ iso8859-2 ISO_8859-2:1987 \ iso8859-2 iso-ir-101 \ iso8859-2 ISO_8859-2 \ iso8859-2 latin2 \ iso8859-2 l2 \ iso8859-3 ISO_8859-3:1988 \ iso8859-3 iso-ir-109 \ iso8859-3 ISO_8859-3 \ iso8859-3 latin3 \ iso8859-3 l3 \ iso8859-4 ISO_8859-4:1988 \ iso8859-4 iso-ir-110 \ iso8859-4 ISO_8859-4 \ iso8859-4 latin4 \ iso8859-4 l4 \ iso8859-5 ISO_8859-5:1988 \ iso8859-5 iso-ir-144 \ iso8859-5 ISO_8859-5 \ iso8859-5 cyrillic \ iso8859-6 ISO_8859-6:1987 \ iso8859-6 iso-ir-127 \ iso8859-6 ISO_8859-6 \ iso8859-6 ECMA-114 \ iso8859-6 ASMO-708 \ iso8859-6 arabic \ iso8859-7 ISO_8859-7:1987 \ iso8859-7 iso-ir-126 \ iso8859-7 ISO_8859-7 \ iso8859-7 ELOT_928 \ iso8859-7 ECMA-118 \ iso8859-7 greek \ iso8859-7 greek8 \ iso8859-8 ISO_8859-8:1988 \ iso8859-8 iso-ir-138 \ iso8859-8 ISO_8859-8 \ iso8859-8 hebrew \ iso8859-9 ISO_8859-9:1989 \ iso8859-9 iso-ir-148 \ iso8859-9 ISO_8859-9 \ iso8859-9 latin5 \ iso8859-9 l5 \ iso8859-10 iso-ir-157 \ iso8859-10 l6 \ iso8859-10 ISO_8859-10:1992 \ iso8859-10 latin6 \ iso8859-14 iso-ir-199 \ iso8859-14 ISO_8859-14:1998 \ iso8859-14 ISO_8859-14 \ iso8859-14 latin8 \ iso8859-14 iso-celtic \ iso8859-14 l8 \ iso8859-15 ISO_8859-15 \ iso8859-15 Latin-9 \ iso8859-16 iso-ir-226 \ iso8859-16 ISO_8859-16:2001 \ iso8859-16 ISO_8859-16 \ iso8859-16 latin10 \ iso8859-16 l10 \ jis0201 X0201 \ jis0208 iso-ir-87 \ jis0208 x0208 \ jis0208 JIS_X0208-1983 \ jis0212 x0212 \ jis0212 iso-ir-159 \ ksc5601 iso-ir-149 \ ksc5601 KS_C_5601-1989 \ ksc5601 KSC5601 \ ksc5601 korean \ shiftjis MS_Kanji \ utf-8 UTF8] foreach {enc mimeType} $encAliasList { set reversemap([string tolower $mimeType]) $enc } namespace export initialize finalize getproperty \ getheader setheader \ getbody \ copymessage \ mapencoding \ reversemapencoding \ |
︙ | ︙ | |||
240 241 242 243 244 245 246 | variable mime set token [namespace current]::[incr mime(uid)] # FRINK: nocheck variable $token upvar 0 $token state | | | 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 | variable mime set token [namespace current]::[incr mime(uid)] # FRINK: nocheck variable $token upvar 0 $token state if {[set code [catch { eval [linsert $args 0 mime::initializeaux $token] } \ result]]} { set ecode $errorCode set einfo $errorInfo catch { mime::finalize $token -subordinates dynamic } return -code $code -errorinfo $einfo -errorcode $ecode $result |
︙ | ︙ | |||
923 924 925 926 927 928 929 | array set options [list -subordinates dynamic] array set options $args switch -- $options(-subordinates) { all { if {![string compare $state(value) parts]} { foreach part $state(parts) { | | | | 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 | 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 [linsert $args 0 mime::finalize $part] } } } dynamic { for {set cid $state(cid)} {$cid > 0} {incr cid -1} { eval [linsert $args 0 mime::finalize $token-$cid] } } none { } default { |
︙ | ︙ | |||
1414 1415 1416 1417 1418 1419 1420 | } else { uplevel #0 $options(-command) [list end] } } result] set ecode $errorCode set einfo $errorInfo | > | > > > | 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 | } else { uplevel #0 $options(-command) [list end] } } result] set ecode $errorCode set einfo $errorInfo if {$code} { return -code $code -errorinfo $einfo -errorcode $ecode $result } return $result } # ::mime::getbodyaux -- # # Builds up the body of the message, fragment by fragment. When # the entire message has been retrieved, it is returned. # |
︙ | ︙ | |||
1630 1631 1632 1633 1634 1635 1636 | } else { set X [read $fd $size] } if {$size > 0} { set size [expr {$size - [string length $X]}] } if {[string compare $converter ""]} { | | | | 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 | } else { set X [read $fd $size] } if {$size > 0} { set size [expr {$size - [string length $X]}] } if {[string compare $converter ""]} { puts -nonewline $channel [$converter -mode encode -- $X] } else { puts -nonewline $channel $X } } if {$closeP} { catch { close $state(fd) } unset state(fd) } |
︙ | ︙ | |||
1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 | 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) } | > > > | 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 | if {[catch { fconfigure $channel -buffersize } blocksize]} { set blocksize 4096 } elseif {$blocksize < 512} { set blocksize 512 } set blocksize [expr {($blocksize/4)*3}] # [893516] fconfigure $channel -buffersize $blocksize puts $channel "" if {[string compare $converter ""]} { puts $channel [$converter -mode encode -- $state(string)] } else { puts $channel $state(string) } |
︙ | ︙ |
Changes to modules/mime/mime.test.
1 2 3 4 5 6 7 8 9 | # 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. # | | > > > > > > > > > > | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | # 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.12.2.1 2004/05/24 02:58:11 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::* } # This code loads md5x, i.e. md5 v2. Proper testing should do one run # using md5 v1, aka md5.tcl as well. package forget md5 catch {namespace delete md5} if {[catch {source [file join [file dirname [file dirname [info script]]] md5 md5x.tcl]} msg]} { puts "skipped [file tail [info script]] (md5x.tcl): $msg" return } package forget mime catch {namespace delete mime} if {[catch {source [file join [file dirname [info script]] mime.tcl]} msg]} { puts "skipped [file tail [info script]] (mime.tcl): $msg" return } namespace import mime::* puts "tcltest [package present tcltest]" puts "mime [package present mime]" puts "- md5 [package present md5]" test mime-1.1 {initialize with no args} { catch {initialize} res subst $res } {specify exactly one of -file, -parts, or -string} |
︙ | ︙ | |||
280 281 282 283 284 285 286 287 288 | foreach {bug n encoded expected} { 764702 1 "(=?utf-8?Q?H=C3=BCrz?=)" "(H�rz)" } { test mime-7.$n "Test field_decode (from SF Tcllib bug $bug)" { mime::field_decode $encoded } $expected ; # {} } ::tcltest::cleanupTests | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 | foreach {bug n encoded expected} { 764702 1 "(=?utf-8?Q?H=C3=BCrz?=)" "(H�rz)" } { test mime-7.$n "Test field_decode (from SF Tcllib bug $bug)" { mime::field_decode $encoded } $expected ; # {} } test mime-7.1 {Test reversemapencoding+mapencoding with preferred name} { set charset [mime::reversemapencoding "US-ASCII"] mime::mapencoding $charset } {US-ASCII} test mime-7.2 {Test reversemapencoding+mapencoding with alias} { set charset [mime::reversemapencoding "UTF8"] mime::mapencoding $charset } {UTF-8} test mime-8.0 {Test chunk handling of copymessage and helpers} { set in [makeFile [set data [string repeat [string repeat "123456789 " 10]\n 350]] input.txt] set mi [makeFile {} mime.txt] set token [mime::initialize -canonical text/plain -file $in] set f [open $mi w] fconfigure $f -translation binary mime::copymessage $token $f close $f set token [mime::initialize -file $mi] set newdata [mime::getbody $token] set res [string compare $data $newdata] removeFile input.txt removeFile mime.txt unset data newdata token f in mi set res } 0 ::tcltest::cleanupTests |
Changes to modules/mime/performance.tcl.
|
| | > > | 1 2 3 4 5 6 7 8 9 10 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} #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."] |
︙ | ︙ |
Changes to modules/mime/pkgIndex.tcl.
1 | if {![package vsatisfies [package provide Tcl] 8.3]} {return} | | | | 1 2 3 | if {![package vsatisfies [package provide Tcl] 8.3]} {return} package ifneeded mime 1.3.6 [list source [file join $dir mime.tcl]] package ifneeded smtp 1.3.6 [list source [file join $dir smtp.tcl]] |
Changes to modules/mime/smtp.man.
1 | [comment {-*- tcl -*- doctools manpage}] | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | [comment {-*- tcl -*- doctools manpage}] [manpage_begin smtp n 1.3.6] [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.6]] [require smtp [opt 1.3.6]] [description] [para] The [package smtp] library package provides the client side of the smtp protocol. [list_begin definitions] |
︙ | ︙ |
Changes to modules/mime/smtp.tcl.
1 2 3 4 5 6 7 8 9 | # 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 | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | # 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.6 package provide smtp 1.3.6 # # state variables: # # sd: socket to server # afterID: afterID associated with ::smtp::timer # options: array of user-supplied options |
︙ | ︙ | |||
1032 1033 1034 1035 1036 1037 1038 | proc ::smtp::wdata {token command buffer} { # FRINK: nocheck variable $token upvar 0 $token state switch -- $command { | < < | < | < | 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 | proc ::smtp::wdata {token command buffer} { # FRINK: nocheck variable $token upvar 0 $token state switch -- $command { create/write - clear/write - delete/write { set state(crP) 0 set state(nlP) 1 set state(size) 0 } write { |
︙ | ︙ | |||
1097 1098 1099 1100 1101 1102 1103 | append result "\n" } incr state(size) [string length $result] return $result } | | > > > > > > > > > > > > > | | 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 | append result "\n" } incr state(size) [string length $result] return $result } create/read - delete/read { # Bugfix for [#539952] } query/ratio { # Indicator for unseekable channel, # for versions of Trf which ask for # this. return {0 0} } query/maxRead { # No limits on reading bytes from the channel below, for # versions of Trf which ask for this information return -1 } default { # Silently pass all unknown commands. #error "Unknown command \"$command\"" } } return "" } # ::smtp::talk -- |
︙ | ︙ |
Changes to modules/multiplexer/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-10 Andreas Kupries <[email protected]> | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-10 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/ncgi/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-09 Andreas Kupries <[email protected]> | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-09 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/nntp/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-05 Andreas Kupries <[email protected]> | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-05 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/nntp/nntp.tcl.
1 2 3 4 5 6 7 | # nntp.tcl -- # # nntp implementation for Tcl. # # Copyright (c) 1998-2000 by Ajuba Solutions. # All rights reserved. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | # nntp.tcl -- # # nntp implementation for Tcl. # # Copyright (c) 1998-2000 by Ajuba Solutions. # All rights reserved. # # RCS: @(#) $Id: nntp.tcl,v 1.12.2.1 2004/05/24 02:58:11 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 |
︙ | ︙ | |||
167 168 169 170 171 172 173 | 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 | | | 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 | 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 [linsert $args 0 ::nntp::_$cmd $name]] } # ::nntp::okprint -- # # Used to test the return code stored in data(code) to # make sure that it is alright to right to the socket. # |
︙ | ︙ | |||
799 800 801 802 803 804 805 | } puts $sock "$cmd" flush $sock return } proc ::nntp::command {name args} { | | | 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 | } puts $sock "$cmd" flush $sock return } proc ::nntp::command {name args} { set res [eval [linsert $args 0 ::nntp::cmd $name]] return [::nntp::response $name] } proc ::nntp::msg {name} { upvar 0 ::nntp::${name}data data |
︙ | ︙ |
Changes to modules/ntp/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-29 Pat Thoyts <[email protected]> | > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-05-23 Andreas Kupries <[email protected]> * time.tcl: Rel. engineering. Updated version number * time.man: of time to reflect its changes, to 1.0.3. * pkgIndex.tcl: 2004-02-28 Pat Thoyts <[email protected]> * time.tcl: Fix the version as 1.0.2 2004-02-26 Pat Thoyts <[email protected]> * time.tcl: Applied patch #905132 to better handle socket errors. 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-29 Pat Thoyts <[email protected]> |
︙ | ︙ |
Changes to modules/ntp/ntp_time.man.
|
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | [manpage_begin ntp_time n 1.0.3] [copyright {2002, Pat Thoyts <[email protected]>}] [moddesc {ntp}] [titledesc {Tcl Time Service Client}] [require Tcl 8.2] [require time [opt 1.0.3]] [description] [para] This package implements a client for the RFC 868 TIME protocol ([uri http://www.rfc-editor.org/rfc/rfc868.txt]). This simple protocol returns the time in seconds since 1 January 1900 |
︙ | ︙ |
Changes to modules/ntp/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 | # 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. | | | 1 2 3 4 5 6 7 8 9 10 11 | # 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.3 [list source [file join $dir time.tcl]] |
Changes to modules/ntp/time.tcl.
1 2 3 4 5 6 7 8 9 | # time.tcl - Copyright (C) 2003 Pat Thoyts <[email protected]> # # Client for the Time protocol. See RFC 868 # # ------------------------------------------------------------------------- # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- # | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # time.tcl - Copyright (C) 2003 Pat Thoyts <[email protected]> # # Client for the Time protocol. See RFC 868 # # ------------------------------------------------------------------------- # 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.9.2.2 2004/05/27 02:47:46 andreas_kupries Exp $ package require Tcl 8.0; # tcl minimum version package require log; # tcllib 1.3 namespace eval ::time { variable version 1.0.3 variable rcsid {$Id: time.tcl,v 1.9.2.2 2004/05/27 02:47:46 andreas_kupries Exp $} namespace export configure gettime server cleanup variable options if {![info exists options]} { array set options { -timeserver {} |
︙ | ︙ | |||
166 167 168 169 170 171 172 | variable $token upvar 0 $token State if {$State(-protocol) == "udp"} { set State(sock) [udp_open] udp_conf $State(sock) $State(-timeserver) $State(-port) } else { | > | > > > > > | 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 | variable $token upvar 0 $token State if {$State(-protocol) == "udp"} { set State(sock) [udp_open] udp_conf $State(sock) $State(-timeserver) $State(-port) } else { if {[catch { set State(sock) [socket $State(-timeserver) $State(-port)] } sockerror]} { set State(status) error set State(error) $sockerror return $token } } # setup the timeout if {$State(-timeout) > 0} { set State(after) [after $State(-timeout) \ [list [namespace origin reset] $token timeout]] } |
︙ | ︙ |
Changes to modules/pop3/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-01-21 Andreas Kupries <[email protected]> | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-01-21 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/pop3/clnt.tcl.
|
| | | 1 2 3 4 5 6 7 8 | #! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # pop3 client, loaded with sequence of operations # to perform. set modules [file dirname $testdir] |
︙ | ︙ |
Changes to modules/pop3/srv.tcl.
|
| | | 1 2 3 4 5 6 7 8 | #! /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 |
︙ | ︙ |
Changes to modules/pop3d/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-10 Andreas Kupries <[email protected]> | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-10 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/profiler/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-12 Andreas Kupries <[email protected]> | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-12 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/report/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-05 Andreas Kupries <[email protected]> | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-05 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/sha1/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-05 Andreas Kupries <[email protected]> | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-05 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/smtpd/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-05 Andreas Kupries <[email protected]> | > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | 2004-06-18 Pat Thoyts <[email protected]> * pkgIndex.tcl: Incremented version to 1.2.2 * smtpd.man: * smtpd.tcl: * smtpd.tcl (::smtpd::gmtoffset): Fixed bug #934134. The TZ calculation was inverted and failed to cope with times spanning midnight. 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-05 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/smtpd/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 11 | # 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} | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # 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.2 [list source [file join $dir smtpd.tcl]] |
Changes to modules/smtpd/smtpd.man.
1 | [comment {-*- tcl -*- doctools manpage}] | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | [comment {-*- tcl -*- doctools manpage}] [manpage_begin smtpd n 1.2.2] [copyright {Pat Thoyts <[email protected]>}] [moddesc {Tcl SMTP Server Package}] [titledesc {Tcl SMTP server implementation}] [require Tcl 8.3] [require smtpd [opt 1.2.2]] [description] [para] The [package smtpd] package provides a simple Tcl-only server library for the Simple Mail Transfer Protocol as described in RFC 821 ([uri http://www.rfc-editor.org/rfc/rfc821.txt]) and |
︙ | ︙ |
Changes to modules/smtpd/smtpd.tcl.
︙ | ︙ | |||
12 13 14 15 16 17 18 | # ------------------------------------------------------------------------- package require Tcl 8.3; # tcl minimum version package require log; # tcllib package require mime; # tcllib namespace eval ::smtpd { | | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | # ------------------------------------------------------------------------- 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.12.2.1 2004/06/18 04:43:09 andreas_kupries Exp $} variable version 1.2.2 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 |
︙ | ︙ | |||
342 343 344 345 346 347 348 | # ------------------------------------------------------------------------- # Description: # Calculate the local offset from GMT in hours for use in the timestamp # proc ::smtpd::gmtoffset {} { set now [clock seconds] | | | | > | < > | < < | < < < | 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 | # ------------------------------------------------------------------------- # Description: # Calculate the local offset from GMT in hours for use in the timestamp # proc ::smtpd::gmtoffset {} { set now [clock seconds] set local [clock format $now -format "%j %H" -gmt false] set zulu [clock format $now -format "%j %H" -gmt true] set lh [expr {([scan [lindex $local 0] %d] * 24) \ + [scan [lindex $local 1] %d]}] set zh [expr {([scan [lindex $zulu 0] %d] * 24) \ + [scan [lindex $zulu 1] %d]}] set off [expr {$lh - $zh}] set off [format "%+03d00" $off] return $off } # ------------------------------------------------------------------------- # Description: # Generate a standard SMTP compliant timestamp. That is a local time but with # the timezone represented as an offset. |
︙ | ︙ | |||
473 474 475 476 477 478 479 | 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 } | | < | 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 | 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" state $channel domain $domain log::log debug "HELO on $channel from $domain" return } # ------------------------------------------------------------------------- # Description: |
︙ | ︙ |
Changes to modules/snit/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-07 Will Duquette <[email protected]> | > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-26 Andreas Kupries <[email protected]> * snit.test: Codified the requirement of Tcl 8.4 into * pkgIndex.tcl: package index and test suite. 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-07 Will Duquette <[email protected]> |
︙ | ︙ |
Changes to modules/snit/pkgIndex.tcl.
1 2 | package ifneeded snit 0.93 \ [list source [file join $dir snit.tcl]] | > | 1 2 3 | if {![package vsatisfies [package provide Tcl] 8.4]} {return} package ifneeded snit 0.93 \ [list source [file join $dir snit.tcl]] |
Changes to modules/snit/snit.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # -*-Tcl-*- #--------------------------------------------------------------------- # TITLE: # snit.test # # AUTHOR: # Will Duquette # # DESCRIPTION: # Test cases for snit.tcl. Uses the ::tcltest:: harness. # Note: # The tests assume tcltest 2.1 | > < > > > > > > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | # -*-Tcl-*- #--------------------------------------------------------------------- # TITLE: # snit.test # # AUTHOR: # Will Duquette # # DESCRIPTION: # Test cases for snit.tcl. Uses the ::tcltest:: harness. # Note: # Snit assumes Tcl 8.4 # The tests assume tcltest 2.1 #--------------------------------------------------------------------- # Load the tcltest package, initialize some constraints. if {![package vsatisfies [package provide Tcl] 8.4]} { puts "Aborting tests for snit." puts "Requiring Tcl 8.4, have [package present Tcl]" return } if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 namespace import ::tcltest::* } else { # Ensure that 2.1 or higher present. if {![package vsatisfies [package present tcltest] 2.1]} { puts "Aborting tests for snit." puts "Requiring tcltest 2.1, have [package present tcltest]" return } } if { [lsearch $auto_path [file dirname [info script]]] == -1 } { set auto_path [linsert $auto_path 0 [file dirname [info script]]] |
︙ | ︙ | |||
48 49 50 51 52 53 54 55 56 57 58 59 60 61 | package forget snit catch {namespace delete snit} if {[catch {source [file join [file dirname [info script]] snit.tcl]} msg]} { puts "skipped [file tail [info script]]: $msg" return } puts "- snit [package present snit]" namespace import ::snit::* # Set up for Tk tests: Repeat background errors proc bgerror {msg} { global errorInfo | > | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | package forget snit catch {namespace delete snit} if {[catch {source [file join [file dirname [info script]] snit.tcl]} msg]} { puts "skipped [file tail [info script]]: $msg" return } puts "- Tcl [package present Tcl]" puts "- snit [package present snit]" namespace import ::snit::* # Set up for Tk tests: Repeat background errors proc bgerror {msg} { global errorInfo |
︙ | ︙ |
Changes to modules/soundex/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-05 Andreas Kupries <[email protected]> | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-05 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/stooop/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-05 Andreas Kupries <[email protected]> | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2003-05-05 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/struct/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-14 Andreas Kupries <[email protected]> | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 | 2004-08-09 Andreas Kupries <[email protected]> * queue.test: * queue.tcl: Changed way of mapping from queue object commands to associoated namespaces. The object namespace now has the same name and location of the object command. Adapted all tests to account for this change. * queue.test: * queue.tcl: Changed dispatcher to auto-generate the list of queue commands when a wrong one is given. Updated tests to account for this. Changed dispatcher to uplevel 1 the method execution, updated walking system to reflect this change. See log entry 2003-07-06 as well. * stack.test: * stack.tcl: Changed way of mapping from stack object commands to associoated namespaces. The object namespace now has the same name and location of the object command. Adapted all tests to account for this change. * stack.test: * stack.tcl: Changed dispatcher to auto-generate the list of stack commands when a wrong one is given. Updated tests to account for this. Changed dispatcher to uplevel 1 the method execution, updated walking system to reflect this change. See log entry 2003-07-06 as well. * stack.man: Fixed [SF Tcllib 1005380]. Documentation for peek and pop now matching the actual behaviour. See also entry 2003-04-25 for the same thing, for queue. * tree.tcl: Spelling police. * graph.tcl: * stack.tcl: * queue.tcl: * matrix.tcl: * ChangeLog: 2004-08-04 Andreas Kupries <[email protected]> * sets.tests: * sets.tcl (::struct::set::Sdifference): Fixed the [Tcllib SF Bug 1002143]. Thanks to Todd Coram <[email protected]> for the report. Set elements containing parentheses screw up the special implementation using the elements as names for local vars, as they are not seen as regular locals, but as array elements. Disabled the special implementation, using the regular one across versions. Extended the testsuite. * graph.test: Fixed [SF Tcllib Bug 1003671]: Ensured that * tree.test: (de)serialization of empty graph/tree is * graph.tcl: working properly. Thanks to Bhushit Joshipura * tree.tcl: <[email protected]> for the report. 2004-08-03 Andreas Kupries <[email protected]> * graph.test: Fixed [SF Tcllib Bug 1000716]: Unset of last * tree.test: attribute followed by delete does not result * graph.tcl: in error anymore. Thanks to Brian Theado * tree.tcl: <[email protected]> for both report and fix. 2004-06-01 Andreas Kupries <[email protected]> * matrix.tcl (_search): Fixed bug reported by Joachim Kock <[email protected]>, using his fix. Search went into an infinite loop if -nocase was used. * matrix.test: Added a testcase. 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-24 Andreas Kupries <[email protected]> * sets.tcl: Typo police. No functional changes. 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-14 Andreas Kupries <[email protected]> |
︙ | ︙ | |||
68 69 70 71 72 73 74 | between the various combination of type and order, and the possible visitor actions. 2004-01-28 Andreas Kupries <[email protected]> * struct_tree.man: Updated documentation. * tree.test: Updated testsuite for modified 'walk' syntax. | | | 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 | between the various combination of type and order, and the possible visitor actions. 2004-01-28 Andreas Kupries <[email protected]> * struct_tree.man: Updated documentation. * tree.test: Updated testsuite for modified 'walk' syntax. * tree.tcl (method walk): Modified to use list of loop variables, containing either one or two. Default: One variable, node information. When two specified the first refers to action data. * list.test: Added test for call with illegal option. * list.tcl (Lflatten): Added proper error message when encountering an unknown/illegal option. |
︙ | ︙ | |||
155 156 157 158 159 160 161 | * graph.man: Completed the implementation of graph serialization. * graph.tcl: Updated testsuite, documentation. * graph.test: 2003-07-15 Andreas Kupries <[email protected]> | | | 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 | * graph.man: Completed the implementation of graph serialization. * graph.tcl: Updated testsuite, documentation. * graph.test: 2003-07-15 Andreas Kupries <[email protected]> * tree.tcl: Created 'ldelete' and 'lset' (emulation pre 8.4) * graph.tcl: and replaced as much 'lreplace's as possible. Using the K operator for speed, encapsulated in the two l commands. * graph.man: Implemented the renaming of nodes and arcs. * graph.tcl: * graph.test: |
︙ | ︙ | |||
181 182 183 184 185 186 187 | * tree.test: * tree.tcl: More rework. The attribute APIs are now backward incompatible, the default attribute 'data' has been dropped. The whole module 'struct' has been bumped to version 2.0 because of this. Reworked the testsuite for the changed APIs. Reworked the (de)serialization stuff a bit and added tests for them. Added an API to rename nodes, and an API to query the name of the | | | | | | | | 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 | * tree.test: * tree.tcl: More rework. The attribute APIs are now backward incompatible, the default attribute 'data' has been dropped. The whole module 'struct' has been bumped to version 2.0 because of this. Reworked the testsuite for the changed APIs. Reworked the (de)serialization stuff a bit and added tests for them. Added an API to rename nodes, and an API to query the name of the root node. The APIs 'getall' and 'keys' now allow usage of glob patterns to restrict their results. Documentation is now uptodate. Added API to compute the 'height' of a node (= distance to its deepest child). 2003-07-06 Andreas Kupries <[email protected]> * tree.test: * tree.tcl: Reworked node attribute storage. Name of array to store the information is now dissociated from the name of the node. This enables the use of arbitrary node names, i.e. ':' in node names. The second benefit is that nodes without attribute data (normal) require less memory than before. Removed the now irrelevant validation of node names and updated the testsuite. * tree.test: * tree.tcl: Changed way of mapping from tree object commands to associated namespaces. The object namespace now has the same name and location of the object command. Adapted all tests to account for this change. * tree.test: * tree.tcl: Changed dispatcher to auto-generate the list of tree commands when a wrong one is given. Updated tests to account for the now correct sort order. Changed dispatcher to uplevel 1 the method execution, updated walking system to reflect this change. 2003-07-04 Andreas Kupries <[email protected]> * list.tcl: The changes in the list dispatcher required corresponding changes in a number of methods: upvar/level 2 => upvar/level 1. Detected by testsuite. Bad me, should have run it immediately. Bugs fixed. * list.test: Extended the testsuite. * list.tcl (lcsInvertMerge2): Fixed problem with extending the result with an chunk of type unchanged, for the case that this happens at the very beginning, i.e. for an empty result. This fixes SF Tcllib bug [765321]. 2003-05-20 Andreas Kupries <[email protected]> * list.tcl (dispatcher): eval => uplevel so that upvar's in the method commands do not need to know about the dispatcher frame in the stack. * list.man: * list.tcl (dbJoin(Keyed)): Extended the commands with an option -keys. Argument is the name of a variable to store the actual list of keys into, independent of the output table. As the latter may not contain all the keys, depending on how and where key columns are present or not. Additionally cleanups in the use of loop variables in the keyed helper commands 'frink' complained about. 2003-05-16 Andreas Kupries <[email protected]> * Extension of the package functionality warrants version bump to 1.4. * list.man: Added descriptions of the db join commands, and section explaining the table joins. * list.test: Added tests for the db join functionality. Adapted existing tests to changed (fixed) error messages. * list.tcl: Rewrote the main dispatcher a bit to make it simpler, and to allow us to hide internal functions from it. Added 'dbJoin(Keyed)' for relational table join (inner, left/right/full outer). Fixed function name in some error messages. 2003-05-14 Andreas Kupries <[email protected]> * tree.tcl: Added some [list]'s to show node names containing spaces properly in error messages. * tree.test: Reworked to test handling of item nodes containing spaces. * tree.bench: Reworked, added helper procedures, test cases are now simpler. * struct_list.man: Fixed typos in the examples. 2003-05-06 Jeff Hobbs <[email protected]> * tree.test: |
︙ | ︙ | |||
335 336 337 338 339 340 341 | 2003-04-15 Andreas Kupries <[email protected]> * 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 | | | 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 | 2003-04-15 Andreas Kupries <[email protected]> * 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. struct.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 <[email protected]> * graph.test: * graph.man: * graph.tcl: Added code to look for the C-implementation, cgraph, |
︙ | ︙ | |||
380 381 382 383 384 385 386 | * list.man: * list.test: * list.tcl: Added and documented commands [iota], [equal], and [repeat]. Extended the testsuite. 2003-04-02 Andreas Kupries <[email protected]> | | | 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 | * list.man: * list.test: * list.tcl: Added and documented commands [iota], [equal], and [repeat]. Extended the testsuite. 2003-04-02 Andreas Kupries <[email protected]> * list.tcl: * list.test: Fixed SF tcllib bug #714209. * ../../../examples/struct: Added example applications for usage of longestCommonSubsequence and lcsInvert. * struct.tcl: Integrated new list commands. |
︙ | ︙ | |||
467 468 469 470 471 472 473 | 2002-07-08 Andreas Kupries <[email protected]> * 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 | | | 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 | 2002-07-08 Andreas Kupries <[email protected]> * 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 <[email protected]> fixing the behaviour of move, SF bug #578460. The command now also validates all nodes before trying to move any of them. 2002-05-27 Andreas Kupries <[email protected]> * matrix.man: Fixed typo (graph -> matrix). |
︙ | ︙ | |||
704 705 706 707 708 709 710 | * 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 <[email protected]> * tree.test: | | | 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 | * 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 <[email protected]> * tree.test: * tree.tcl: Added check for node existence in children function [Bug: 4341] 2000-03-03 Eric Melski <[email protected]> * tree.tcl: Changed usage information for tree::_walk. * tree.n: Enhanced description of walk function, fixed a typo. |
Changes to modules/struct/graph.tcl.
1 2 3 4 5 6 7 8 9 | # 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. # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | # 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.13.2.3 2004/08/10 06:19:44 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/ # # ** NOTE ** ATTENTION ** # # For the 2.0 version of the graph interface 'cgraph 0.6' is _not_ # usable anymore. # # '[package vcompare $version 0.6] > 0' <=> '$version > 0.6' if { ![catch {package require cgraph} version] && [package vcompare $version 0.6] > 0 } { |
︙ | ︙ | |||
364 365 366 367 368 369 370 | } return } # ::struct::graph::__arc_exists -- # | | | 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 | } return } # ::struct::graph::__arc_exists -- # # Test for existence 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. |
︙ | ︙ | |||
463 464 465 466 467 468 469 | upvar ${name}::$arcAttr($arc) data return [array names data $pattern] } # ::struct::graph::__arc_keyexists -- # | | | 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 | upvar ${name}::$arcAttr($arc) data return [array names data $pattern] } # ::struct::graph::__arc_keyexists -- # # Test for existence of a given key for a given arc in a graph. # # Arguments: # name name of the graph. # arc arc to query. # key key to lookup # # Results: |
︙ | ︙ | |||
842 843 844 845 846 847 848 | } upvar ${name}::$arcAttr($arc) data catch {unset data($key)} if {[array size data] == 0} { # No attributes stored for this arc, squash the whole array. | | | 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 | } upvar ${name}::$arcAttr($arc) data catch {unset data($key)} if {[array size data] == 0} { # No attributes stored for this arc, squash the whole array. unset arcAttr($arc) unset data } return } # ::struct::graph::_arcs -- # |
︙ | ︙ | |||
1273 1274 1275 1276 1277 1278 1279 | proc ::struct::graph::_keys {name {pattern *}} { variable ${name}::graphAttr return [array names graphAttr $pattern] } # ::struct::graph::_keyexists -- # | | | 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 | proc ::struct::graph::_keys {name {pattern *}} { variable ${name}::graphAttr return [array names graphAttr $pattern] } # ::struct::graph::_keyexists -- # # Test for existence of a given key in a graph. # # Arguments: # name name of the graph. # key key to lookup # # Results: # 1 if the key exists, 0 else. |
︙ | ︙ | |||
1452 1453 1454 1455 1456 1457 1458 | } return } # ::struct::graph::__node_exists -- # | | | 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 | } return } # ::struct::graph::__node_exists -- # # Test for existence 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. |
︙ | ︙ | |||
1551 1552 1553 1554 1555 1556 1557 | upvar ${name}::$nodeAttr($node) data return [array names data $pattern] } # ::struct::graph::__node_keyexists -- # | | | 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 | upvar ${name}::$nodeAttr($node) data return [array names data $pattern] } # ::struct::graph::__node_keyexists -- # # Test for existence of a given key for a node in a graph. # # Arguments: # name name of the graph. # node node to query. # key key to lookup # # Results: |
︙ | ︙ | |||
1586 1587 1588 1589 1590 1591 1592 | # # 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: | | | 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 | # # 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 name 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 { |
︙ | ︙ | |||
1856 1857 1858 1859 1860 1861 1862 | } upvar ${name}::$nodeAttr($node) data catch {unset data($key)} if {[array size data] == 0} { # No attributes stored for this node, squash the whole array. | | | 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 | } upvar ${name}::$nodeAttr($node) data catch {unset data($key)} if {[array size data] == 0} { # No attributes stored for this node, squash the whole array. unset nodeAttr($node) unset data } return } # ::struct::graph::_nodes -- # |
︙ | ︙ | |||
2660 2661 2662 2663 2664 2665 2666 | return [array names tmp] } } } # ::struct::graph::GenAttributeStorage -- # | | | 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 | return [array names tmp] } } } # ::struct::graph::GenAttributeStorage -- # # Create an array to store the attributes of a node in. # # Arguments: # name Name of the graph containing the node # type Type of object for the attribute # obj Name of the node or arc which got attributes. # # Results: |
︙ | ︙ | |||
2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 | upvar 1 \ $gavar graphAttr \ $navar nodeAttr \ $aavar arcAttr \ $inavar inArcs \ $outavar outArcs \ $arcnvar arcNodes # Overall length ok ? if {[llength $ser] % 3 != 1} { return -code error \ "error in serialization: list length not 1 mod 3." } | > > > > > > | 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 | upvar 1 \ $gavar graphAttr \ $navar nodeAttr \ $aavar arcAttr \ $inavar inArcs \ $outavar outArcs \ $arcnvar arcNodes array set nodeAttr {} array set arcAttr {} array set inArcs {} array set outArcs {} array set arcNodes {} # Overall length ok ? if {[llength $ser] % 3 != 1} { return -code error \ "error in serialization: list length not 1 mod 3." } |
︙ | ︙ |
Changes to modules/struct/graph.test.
1 2 3 4 5 6 7 8 9 10 | # -*- 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. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | # -*- 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.13.2.2 2004/08/05 05:07:29 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::* } source [file join [file dirname [info script]] graph.tcl] |
︙ | ︙ | |||
499 500 501 502 503 504 505 | mygraph arc insert node0 node1 root mygraph arc set root foo "" set result [catch {mygraph arc unset root bogus}] mygraph destroy set result } 0 | | > > > > > > > > > > > > > > > | 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 | mygraph arc insert node0 node1 root mygraph arc set root foo "" set result [catch {mygraph arc unset root bogus}] mygraph destroy set result } 0 test graph-9.5 {arc unset removes attribute from arc} { graph mygraph mygraph node insert node0 mygraph node insert node1 mygraph arc insert node0 node1 root set result [list] lappend result [mygraph arc keyexists root foobar] mygraph arc set root foobar foobar lappend result [mygraph arc keyexists root foobar] mygraph arc unset root foobar lappend result [mygraph arc keyexists root foobar] mygraph destroy set result } {0 1 0} test graph-9.6 {arc unset followed by arc delete} { graph mygraph set result [list] mygraph node insert node0 mygraph node insert node1 set a [mygraph arc insert node0 node1 root] mygraph arc set $a foo bar mygraph arc unset $a foo mygraph arc delete $a set result [mygraph arc exists $a] mygraph destroy unset a set result } 0 # --------------------------------------------------- test graph-10.1 {arcs} { graph mygraph set result [mygraph arcs] mygraph destroy |
︙ | ︙ | |||
1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 | mygraph node set root foobar foobar lappend result [mygraph node keyexists root foobar] mygraph node unset root foobar lappend result [mygraph node keyexists root foobar] mygraph destroy set result } {0 1 0} # --------------------------------------------------- test graph-19.1 {nodes} { graph mygraph set result [mygraph nodes] mygraph destroy | > > > > > > > > > > > > > | 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 | mygraph node set root foobar foobar lappend result [mygraph node keyexists root foobar] mygraph node unset root foobar lappend result [mygraph node keyexists root foobar] mygraph destroy set result } {0 1 0} test graph-18.6 {node unset followed by node delete} { graph mygraph set result [list] set n [mygraph node insert node0] mygraph node set $n foo bar mygraph node unset $n foo mygraph node delete $n set result [mygraph node exists $n] mygraph destroy unset n set result } 0 # --------------------------------------------------- test graph-19.1 {nodes} { graph mygraph set result [mygraph nodes] mygraph destroy |
︙ | ︙ | |||
2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 | test graph-43.1 {serialization, bogus node} { graph mygraph catch {mygraph serialize foo} result mygraph destroy set result } {node "foo" does not exist in graph "::mygraph"} test graph-43.3 {serialization, all} { graph mygraph mygraph node insert %0 mygraph node insert %1 mygraph node insert %2 | > > > > > > > > > > | 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 | test graph-43.1 {serialization, bogus node} { graph mygraph catch {mygraph serialize foo} result mygraph destroy set result } {node "foo" does not exist in graph "::mygraph"} test graph-43.2 {serialization, empty graph} { graph mygraph set serial [mygraph serialize] set result [validate_serial mygraph $serial] mygraph destroy set result # serial = {{}} } ok test graph-43.3 {serialization, all} { graph mygraph mygraph node insert %0 mygraph node insert %1 mygraph node insert %2 |
︙ | ︙ | |||
2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 | mygraph destroy set result } [list \ attr/graph/data-mismatch attr/graph/data-mismatch \ ok nodes/mismatch/#nodes \ arc/b/unknown ok] # --------------------------------------------------- test graph-45.1 {graph assignment} { graph mygraph catch {mygraph = foo bar} result mygraph destroy | > > > > > > > > > | 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 | mygraph destroy set result } [list \ attr/graph/data-mismatch attr/graph/data-mismatch \ ok nodes/mismatch/#nodes \ arc/b/unknown ok] test graph-44.14 {deserialization, empty graph} { graph mygraph set serial {{}} mygraph deserialize $serial set result [validate_serial mygraph $serial] mygraph destroy set result } ok # --------------------------------------------------- test graph-45.1 {graph assignment} { graph mygraph catch {mygraph = foo bar} result mygraph destroy |
︙ | ︙ |
Changes to modules/struct/matrix.tcl.
1 2 3 4 | # matrix.tcl -- # # Implementation of a matrix data structure for Tcl. # | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | # matrix.tcl -- # # Implementation of a matrix data structure for Tcl. # # Copyright (c) 2001-2004 by Andreas Kupries <[email protected]> # # Heapsort code Copyright (c) 2003 by Edwin A. Suominen <[email protected]>, # based on concepts in "Introduction to Algorithms" by Thomas H. Cormen et al. # # 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.14.2.2 2004/08/10 06:19:44 andreas_kupries 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 # row heights and column widths and the information about linked arrays. # # The variables are # - columns #columns in data # - rows #rows in data # - data cell contents # - colw cache of column widths # - rowh cache of row heights # - 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 matrices variable counter 0 |
︙ | ︙ | |||
407 408 409 410 411 412 413 414 415 416 417 418 419 420 | 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 { | > | 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 | 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 set args [lrange $args 1 end] } -* { return -code error \ "invalid option \"[lindex $args 0]\":\ should be -nocase, -exact, -glob, or -regexp" } default { |
︙ | ︙ | |||
1609 1610 1611 1612 1613 1614 1615 | trace variable data w [list ::struct::matrix::MatTraceOut $variable $name] return } # ::struct::matrix::_links -- # # Retrieves the names of all array variable the matrix is | | | 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 | trace variable data w [list ::struct::matrix::MatTraceOut $variable $name] return } # ::struct::matrix::_links -- # # Retrieves the names of all array variable the matrix is # officially linked to. # # Arguments: # name Name of the matrix object. # # Results: # List of variables the matrix is linked to. |
︙ | ︙ | |||
1742 1743 1744 1745 1746 1747 1748 | # 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. | | | 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 | # 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] |
︙ | ︙ | |||
1832 1833 1834 1835 1836 1837 1838 | 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 | | | 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 | 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 outer list 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". |
︙ | ︙ | |||
2198 2199 2200 2201 2202 2203 2204 | # None. proc ::struct::matrix::_unlink {name avar} { variable ${name}::link if {![info exists link($avar)]} { | | | 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 | # None. proc ::struct::matrix::_unlink {name avar} { variable ${name}::link if {![info exists link($avar)]} { # Ignore unlinking of unknown variables. return } # Delete the traces first, then remove the link management # information from the object. upvar #0 $avar array |
︙ | ︙ |
Changes to modules/struct/matrix.test.
1 2 3 4 5 6 7 8 9 10 | # -*- 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 <[email protected]> # All rights reserved. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | # -*- 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 <[email protected]> # All rights reserved. # # RCS: @(#) $Id: matrix.test,v 1.11.2.1 2004/06/02 04:40:42 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::* } source [file join [file dirname [info script]] matrix.tcl] |
︙ | ︙ | |||
1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 | 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} | > | 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 | 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}} 22 -nocase {rect 1 1 3 3} {C} {{2 2}} } { 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} |
︙ | ︙ |
Changes to modules/struct/queue.tcl.
1 2 3 4 5 6 7 8 9 | # 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. # | | < < < < < < < < < < | | | > > | | | > > > | > > > > > > | > > > > > > > > > > > > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 | # 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.5.2.1 2004/08/10 06:19:45 andreas_kupries 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 # 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 {args} { variable queues variable counter switch -exact -- [llength [info level 0]] { 1 { # Missing name, generate one. incr counter set name "queue${counter}" } 2 { # Standard call. New empty queue. set name [lindex $args 0] } default { # Error. return -code error \ "wrong # args: should be \"queue ?name ?=|:=|as|deserialize source??\"" } } # 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" } if {[llength [info commands $name]]} { return -code 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 |
︙ | ︙ | |||
82 83 84 85 86 87 88 | 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 | > | | | > > > > | > | > | | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 | 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 set sub _$cmd if { [llength [info commands ::struct::queue::$sub]] == 0 } { set optlist [lsort [info commands ::struct::queue::_*]] set xlist {} foreach p $optlist { set p [namespace tail $p] lappend xlist [string range $p 1 end] } set optlist [linsert [join $xlist ", "] "end-1" "or"] return -code error \ "bad option \"$cmd\": must be $optlist" } uplevel 1 [linsert $args 0 ::struct::queue::_$cmd $name] } # ::struct::queue::_clear -- # # Clear a queue. # # Arguments: |
︙ | ︙ | |||
121 122 123 124 125 126 127 | # # Results: # None. proc ::struct::queue::_destroy {name} { variable queues unset queues($name) | | | 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 | # # 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. # |
︙ | ︙ | |||
164 165 166 167 168 169 170 | set queues($name) [lreplace $queues($name) 0 $index] return $result } # ::struct::queue::_peek -- # | | | | 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 | set queues($name) [lreplace $queues($name) 0 $index] return $result } # ::struct::queue::_peek -- # # Retrieve 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 fulfill the request, throws an error. proc ::struct::queue::_peek {name {count 1}} { variable queues if { $count < 1 } { error "invalid item count $count" } |
︙ | ︙ |
Changes to modules/struct/queue.test.
1 2 3 4 5 6 7 8 9 10 | # -*- 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. # | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 | # -*- 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.6.2.1 2004/08/10 06:19:45 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 } {} |
︙ | ︙ | |||
88 89 90 91 92 93 94 | } 4 test queue-4.1 {put operation} { queue myqueue catch {myqueue put} msg myqueue destroy set msg | | | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 | } 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 |
︙ | ︙ |
Changes to modules/struct/sets.tcl.
1 2 3 4 | #---------------------------------------------------------------------- # # sets.tcl -- # | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | #---------------------------------------------------------------------- # # sets.tcl -- # # Definitions for the processing of sets. # # Copyright (c) 2004 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: sets.tcl,v 1.2.2.2 2004/08/05 05:43:08 andreas_kupries Exp $ # #---------------------------------------------------------------------- package require Tcl 8.0 namespace eval ::struct { namespace eval set {} } namespace eval ::struct::set { namespace export set } ########################## # Public functions # ::struct::set::set -- # # Command that access all set commands. # # Arguments: # cmd Name of the subcommand to dispatch to. # args Arguments for the subcommand. # # Results: # Whatever the result of the subcommand is. |
︙ | ︙ | |||
197 198 199 200 201 202 203 | # # Results: # A - B # # Side effects: # None. | < < < | | | | | | | | > > > > > > > > > > | | | | | | | | | | | | | > | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 | # # Results: # A - B # # Side effects: # None. proc ::struct::set::Sdifference {A B} { if {[llength $A] == 0} {return {}} if {[llength $B] == 0} {return $A} array set tmp {} foreach x $A {::set tmp($x) .} foreach x $B {catch {unset tmp($x)}} return [array names tmp] } if 0 { # Tcllib SF Bug 1002143. We cannot use the implementation below. # It will treat set elements containing '(' and ')' as array # elements, and this screws up the storage of elements as the name # of local vars something fierce. No way around this. Disabling # this code and always using the other implementation (s.a.) is # the only possible fix. if {[package vcompare [package provide Tcl] 8.4] < 0} { # Tcl 8.[23]. Use explicit array to perform the operation. } else { # Tcl 8.4+, has 'unset -nocomplain' proc ::struct::set::Sdifference {A B} { if {[llength $A] == 0} {return {}} if {[llength $B] == 0} {return $A} # Get the variable B out of the way, avoid collisions # prepare for "pure list optimization" ::set ::struct::set::tmp [lreplace $B -1 -1 unset -nocomplain] unset B # unset A early: no local variables left foreach [lindex [list $A [unset A]] 0] {.} {break} eval $::struct::set::tmp return [info locals] } } } # ::struct::set::Ssymdiff -- # # Compute symmetric difference of two sets. # |
︙ | ︙ |
Changes to modules/struct/sets.test.
1 2 3 4 5 6 7 8 | # Tests for the 'set' 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) 2004 by Andreas Kupries # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | # Tests for the 'set' 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) 2004 by Andreas Kupries # # RCS: @(#) $Id: sets.test,v 1.3.2.1 2004/08/05 05:43:08 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::* } source [file join [file dirname [info script]] sets.tcl] |
︙ | ︙ | |||
223 224 225 226 227 228 229 230 231 232 233 234 235 236 | test set-6.7 {difference} { lsort [setop difference $sa $sd] } $sempty test set-6.8 {difference} { lsort [setop difference $sd $sa] } {e f} test set-7.0 {symdiff} { catch {setop symdiff} msg set msg } [tcltest::wrongNumArgs {::struct::set::Ssymdiff} {A B} 0] | > > > > > > > > > > > > | 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 | test set-6.7 {difference} { lsort [setop difference $sa $sd] } $sempty test set-6.8 {difference} { lsort [setop difference $sd $sa] } {e f} test set-6.9 {difference} { lsort [setop difference \ [list "Washington, DC (District of Columbia)" Maryland Virginia] \ [list "Washington, DC (District of Columbia)" Virginia]] } Maryland test set-6.10 {difference} { lsort [setop difference \ [list DC Maryland Virginia] \ [list DC Virginia]] } Maryland test set-7.0 {symdiff} { catch {setop symdiff} msg set msg } [tcltest::wrongNumArgs {::struct::set::Ssymdiff} {A B} 0] |
︙ | ︙ |
Changes to modules/struct/stack.man.
︙ | ︙ | |||
30 31 32 33 34 35 36 | [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. | < > | < > | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | [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 not enoughs items on the stack to fulfull the request, this command will throw an error. [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 not enoughs items on the stack to fulfull the request, this command will throw an error. [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. |
︙ | ︙ |
Changes to modules/struct/stack.tcl.
1 2 3 4 5 6 7 8 9 | # 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. # | | < < < < < < < < < < < | | > > | | | > > > | > > > > > > | > > > > > > > > > > > > | > | > > > > > > | | > > > > > | > | > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 | # 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.5.2.1 2004/08/10 06:19:45 andreas_kupries 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 # 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 {args} { variable stacks variable counter switch -exact -- [llength [info level 0]] { 1 { # Missing name, generate one. incr counter set name "stack${counter}" } 2 { # Standard call. New empty stack. set name [lindex $args 0] } default { # Error. return -code error \ "wrong # args: should be \"stack ?name ?=|:=|as|deserialize source??\"" } } # 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" } if {[llength [info commands $name]]} { return -code 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} { # 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 set sub _$cmd if { [llength [info commands ::struct::stack::$sub]] == 0 } { set optlist [lsort [info commands ::struct::stack::_*]] set xlist {} foreach p $optlist { set p [namespace tail $p] lappend xlist [string range $p 1 end] } set optlist [linsert [join $xlist ", "] "end-1" "or"] return -code error \ "bad option \"$cmd\": must be $optlist" } uplevel 1 [linsert $args 0 ::struct::stack::$sub $name] } # ::struct::stack::_clear -- # # Clear a stack. # # Arguments: |
︙ | ︙ | |||
112 113 114 115 116 117 118 | # name name of the stack object. # # Results: # None. proc ::struct::stack::_destroy {name} { unset ::struct::stack::stacks($name) | | | | | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 | # 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 -- # # Retrieve 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 fulfill the request, throws an error. proc ::struct::stack::_peek {name {count 1}} { variable stacks if { $count < 1 } { error "invalid item count $count" } |
︙ | ︙ |
Changes to modules/struct/stack.test.
1 2 3 4 5 6 7 8 9 10 | # -*- 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. # | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 | # -*- 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.7.2.1 2004/08/10 06:19:45 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 } {} |
︙ | ︙ | |||
88 89 90 91 92 93 94 | } 4 test stack-4.1 {push operation} { stack mystack catch {mystack push} msg mystack destroy set msg | | | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 | } 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 |
︙ | ︙ |
Changes to modules/struct/tree.tcl.
1 2 3 4 5 6 7 8 9 | # 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. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | # 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.28.2.2 2004/08/10 06:19:45 andreas_kupries Exp $ package require Tcl 8.2 namespace eval ::struct {} namespace eval ::struct::tree { # Data storage in the tree module |
︙ | ︙ | |||
589 590 591 592 593 594 595 | proc ::struct::tree::_destroy {name} { namespace delete $name interp alias {} ::$name {} } # ::struct::tree::_exists -- # | | | 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 | proc ::struct::tree::_destroy {name} { namespace delete $name interp alias {} ::$name {} } # ::struct::tree::_exists -- # # Test for existence 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. |
︙ | ︙ | |||
667 668 669 670 671 672 673 | # Return the height (distance from the given node to its deepest child) # # Arguments: # name Name of the tree. # node Node we wish to know the height for.. # # Results: | | | 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 | # Return the height (distance from the given node to its deepest child) # # Arguments: # name Name of the tree. # node Node we wish to know the height for.. # # Results: # height Distance to deepest child of the node. proc ::struct::tree::_height {name node} { if { ![_exists $name $node] } { return -code error "node \"$node\" does not exist in tree \"$name\"" } variable ${name}::children |
︙ | ︙ | |||
721 722 723 724 725 726 727 | upvar ${name}::$attribute($node) data return [array names data $pattern] } # ::struct::tree::_keyexists -- # | | | 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 | upvar ${name}::$attribute($node) data return [array names data $pattern] } # ::struct::tree::_keyexists -- # # Test for existence of a given key for a node in a tree. # # Arguments: # name Name of the tree. # node Node to query. # key Key to lookup. # # Results: |
︙ | ︙ | |||
821 822 823 824 825 826 827 | foreach node $args { if {[_exists $name $node] } { # Move the node to its new home if { [string equal $node $rootname] } { return -code error "cannot move root node" } | | | 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 | foreach node $args { if {[_exists $name $node] } { # Move the node to its new home if { [string equal $node $rootname] } { return -code error "cannot move root node" } # Cannot make a node its own descendant (I'm my own grandpa...) set ancestor $parentNode while { ![string equal $ancestor $rootname] } { if { [string equal $ancestor $node] } { return -code error "node \"$node\" cannot be its own descendant" } set ancestor $parent($ancestor) } |
︙ | ︙ | |||
1503 1504 1505 1506 1507 1508 1509 | } upvar ${name}::$attribute($node) data catch {unset data($key)} if {[array size data] == 0} { # No attributes stored for this node, squash the whole array. | | | 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 | } upvar ${name}::$attribute($node) data catch {unset data($key)} if {[array size data] == 0} { # No attributes stored for this node, squash the whole array. unset attribute($node) unset data } return } # ::struct::tree::_walk -- # |
︙ | ︙ | |||
1860 1861 1862 1863 1864 1865 1866 | unset attribute($node) } return } # ::struct::tree::GenAttributeStorage -- # | | | 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 | unset attribute($node) } return } # ::struct::tree::GenAttributeStorage -- # # Create an array to store the attributes of a node in. # # Arguments: # name Name of the tree containing the node # node Name of the node which got attributes. # # Results: # none |
︙ | ︙ | |||
1909 1910 1911 1912 1913 1914 1915 | # Store attribute data if {[info exists attribute($node)]} { upvar ${name}::$attribute($node) data lappend tree [array get data] } else { | | | | 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 | # Store attribute data if {[info exists attribute($node)]} { upvar ${name}::$attribute($node) data lappend tree [array get data] } else { # Encode nodes without attributes. lappend tree {} } # Build tree structure, by adding the children to the list, all # referring back to their parent by index. Their own children are # added through recursive calls. foreach c $children($node) { set cidx [llength $tree] lappend tree $c $rootidx Serialize $name $c tree $cidx } |
︙ | ︙ | |||
1980 1981 1982 1983 1984 1985 1986 | } # Remember parent, and reconstruct children set p($node) [lindex $ser $parent] lappend ch($p($node)) $node } | | | 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 | } # Remember parent, and reconstruct children set p($node) [lindex $ser $parent] lappend ch($p($node)) $node } # Root node information ok ? if {[llength $rn] < 1} { return -code error \ "error in serialization: no root specified." } elseif {[llength $rn] > 1} { return -code error \ "error in serialization: multiple root nodes." |
︙ | ︙ |
Changes to modules/struct/tree.test.
1 2 3 4 5 6 7 8 9 | # tree.test: tests for the tree structure. -*- 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) 1998-2000 by Ajuba Solutions. # All rights reserved. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | # tree.test: tests for the tree structure. -*- 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) 1998-2000 by Ajuba Solutions. # All rights reserved. # # RCS: @(#) $Id: tree.test,v 1.29.2.2 2004/08/05 05:07:29 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::* } source [file join [file dirname [info script]] tree.tcl] |
︙ | ︙ | |||
430 431 432 433 434 435 436 437 438 439 440 441 442 443 | mytree set root foobar foobar lappend result [mytree keyexists root foobar] mytree unset root foobar lappend result [mytree keyexists root foobar] mytree destroy set result } {0 1 0} ############################################################ test tree-2.7.1 {keys, wrong # args} { tree mytree catch {mytree keys root flaboozle foobar} msg mytree destroy | > > > > > > > > > > > > | 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 | mytree set root foobar foobar lappend result [mytree keyexists root foobar] mytree unset root foobar lappend result [mytree keyexists root foobar] mytree destroy set result } {0 1 0} test tree-2.6.6 {unset followed by node delete} { tree mytree set result [list] set n [mytree insert root end] mytree set $n foo bar mytree unset $n foo mytree delete $n set result [mytree exists $n] mytree destroy set result } 0 ############################################################ test tree-2.7.1 {keys, wrong # args} { tree mytree catch {mytree keys root flaboozle foobar} msg mytree destroy |
︙ | ︙ | |||
2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 | set serial [mytree serialize %0] set result [validate_serial mytree $serial %0] mytree destroy set result # {%0 {} {} %3 0 {} %4 0 {foo far data {}}} } ok ############################################################ test tree-5.2.1 {deserialization, wrong #args} { tree mytree catch {mytree deserialize foo bar} result mytree destroy | > > > > > > > > > | 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 | set serial [mytree serialize %0] set result [validate_serial mytree $serial %0] mytree destroy set result # {%0 {} {} %3 0 {} %4 0 {foo far data {}}} } ok test tree-5.1.5 {serialization, empty tree} { tree mytree set serial [mytree serialize] set result [validate_serial mytree $serial] mytree destroy set result # serial = {root {} {}} } ok ############################################################ test tree-5.2.1 {deserialization, wrong #args} { tree mytree catch {mytree deserialize foo bar} result mytree destroy |
︙ | ︙ | |||
2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 | lappend result [mytree rootname] mytree destroy set result } [list node/%0/unknown node/%0/unknown root \ ok attr/%4/mismatch root \ node/root/unknown ok %0] ############################################################ test tree-5.3.1 {tree assignment} { tree mytree catch {mytree = foo bar} result mytree destroy | > > > > > > > > > | 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 | lappend result [mytree rootname] mytree destroy set result } [list node/%0/unknown node/%0/unknown root \ ok attr/%4/mismatch root \ node/root/unknown ok %0] test tree-5.2.18 {deserialization, empty tree} { tree mytree set serial {root {} {}} mytree deserialize $serial set result [validate_serial mytree $serial] mytree destroy set result } ok ############################################################ test tree-5.3.1 {tree assignment} { tree mytree catch {mytree = foo bar} result mytree destroy |
︙ | ︙ |
Changes to modules/struct1/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-11 Andreas Kupries <[email protected]> | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-11 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/struct1/queue.tcl.
1 2 3 4 5 6 7 8 9 | # 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. # | | < < < < < < < < < < | | | > > | | | > > > | > > > > > > | > > > > > > > > > > > > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 | # 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.2.2.1 2004/08/10 06:19:45 andreas_kupries 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 # 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 {args} { variable queues variable counter switch -exact -- [llength [info level 0]] { 1 { # Missing name, generate one. incr counter set name "queue${counter}" } 2 { # Standard call. New empty queue. set name [lindex $args 0] } default { # Error. return -code error \ "wrong # args: should be \"queue ?name ?=|:=|as|deserialize source??\"" } } # 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" } if {[llength [info commands $name]]} { return -code 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 |
︙ | ︙ | |||
82 83 84 85 86 87 88 | 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 | > | | | > > > > | > | > | | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 | 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 set sub _$cmd if { [llength [info commands ::struct::queue::$sub]] == 0 } { set optlist [lsort [info commands ::struct::queue::_*]] set xlist {} foreach p $optlist { set p [namespace tail $p] lappend xlist [string range $p 1 end] } set optlist [linsert [join $xlist ", "] "end-1" "or"] return -code error \ "bad option \"$cmd\": must be $optlist" } uplevel 1 [linsert $args 0 ::struct::queue::_$cmd $name] } # ::struct::queue::_clear -- # # Clear a queue. # # Arguments: |
︙ | ︙ | |||
121 122 123 124 125 126 127 | # # Results: # None. proc ::struct::queue::_destroy {name} { variable queues unset queues($name) | | | 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 | # # 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. # |
︙ | ︙ |
Changes to modules/struct1/queue.test.
1 2 3 4 5 6 7 8 9 10 | # -*- 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. # | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 | # -*- 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.2.2.1 2004/08/10 06:19:45 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 } {} |
︙ | ︙ | |||
88 89 90 91 92 93 94 | } 4 test queue-4.1 {put operation} { queue myqueue catch {myqueue put} msg myqueue destroy set msg | | | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 | } 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 |
︙ | ︙ |
Changes to modules/struct1/stack.tcl.
1 2 3 4 5 6 7 8 9 | # 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. # | | < < < < < < < < < < < | | > > | | | > > > | > > > > > > | > > > > > > > > > > > > | > | > > > > > > | | > > > > > | > | > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 | # 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.2.2.1 2004/08/10 06:19:45 andreas_kupries 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 # 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 {args} { variable stacks variable counter switch -exact -- [llength [info level 0]] { 1 { # Missing name, generate one. incr counter set name "stack${counter}" } 2 { # Standard call. New empty stack. set name [lindex $args 0] } default { # Error. return -code error \ "wrong # args: should be \"stack ?name ?=|:=|as|deserialize source??\"" } } # 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" } if {[llength [info commands $name]]} { return -code 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} { # 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 set sub _$cmd if { [llength [info commands ::struct::stack::$sub]] == 0 } { set optlist [lsort [info commands ::struct::stack::_*]] set xlist {} foreach p $optlist { set p [namespace tail $p] lappend xlist [string range $p 1 end] } set optlist [linsert [join $xlist ", "] "end-1" "or"] return -code error \ "bad option \"$cmd\": must be $optlist" } uplevel 1 [linsert $args 0 ::struct::stack::$sub $name] } # ::struct::stack::_clear -- # # Clear a stack. # # Arguments: |
︙ | ︙ | |||
112 113 114 115 116 117 118 | # name name of the stack object. # # Results: # None. proc ::struct::stack::_destroy {name} { unset ::struct::stack::stacks($name) | | | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 | # 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. # |
︙ | ︙ |
Changes to modules/struct1/stack.test.
1 2 3 4 5 6 7 8 9 10 | # -*- 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. # | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 | # -*- 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.2.2.1 2004/08/10 06:19:45 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 } {} |
︙ | ︙ | |||
88 89 90 91 92 93 94 | } 4 test stack-4.1 {push operation} { stack mystack catch {mystack push} msg mystack destroy set msg | | | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 | } 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 |
︙ | ︙ |
Changes to modules/textutil/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-01 Johannes-Heinrich Vogeler <[email protected]> | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | 2004-06-24 Andreas Kupries <[email protected]> * trim.tcl: Fixed typo in 'trimEmptyHeading'. 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-05-23 Andreas Kupries <[email protected]> * textutil.tcl: Rel. engineering. Updated version number * textutil.man: of fileutil to reflect its changes, to 0.6.1. * pkgIndex.tcl: 2004-05-14 Andreas Kupries <[email protected]> * adjust.tcl: The last commit of this file, not recorded in here the ChangeLog :(, not only fixed the bug with the infinite loop invoked by the tests cases 2.6 and 2.7 :), but also introduced an error with trivial a fix (usage of wrong variable) and utterly easy to detect __if the testsuite had been run before the commit__ :(. Obviously it was not. The rewritten Adjust procedure returned not only the reformatted input, but prepended this wanted result with a copy of the original unformatted input. This has been fixed. * adjust.test: Updated the testsuite using the assumption that the currently returned formatted results are correct as is. As the tests 2.6 and 2.7 are not running into infinite loop anymore their tag 'knownBug' has been removed. These two tests are now regular tests again and will be executed as part of any run of the testsuite for textutil. 2004-03-06 Andreas Kupries <[email protected]> * adjust_hyph.test: Added the example of [Tcllib SF Bug 860753] as a testcase to textutil. Using tcllib 1.4 the new test fails. Using the CVS Head (== Tcllib 1.6) the reported problem could not be reproduced. IOW this problem has been fixed already. 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-01 Johannes-Heinrich Vogeler <[email protected]> |
︙ | ︙ |
Changes to modules/textutil/adjust.tcl.
︙ | ︙ | |||
55 56 57 58 59 60 61 62 63 64 65 66 67 68 | -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!" } | > > > > > | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 | -full { if { ![ string is boolean -strict $value ] } then { error "expected boolean but got \"$value\"" } set FullLine [ string is true $value ] } -hyphenate { # the word exceeding the length of line is tried to be # hyphenated; if a word cannot be hyphenated to fit into # the line processing stops! The length of the line should # be set to a reasonable value! 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!" } |
︙ | ︙ | |||
87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 | } 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 "" } # | > > > > > < | > > > > > > > > | | | | < < < < < | | | < < < < < < | < < < < < | | < | < < | < | | > > < < < | > > > | > > | > > | > > > > | | < | < < < < < < < | > | < < < | < < < < < < < | | < | | | < < > > | | > | | < | | < < < < | < > | | < | | < < < | < | < < < < < | | < < < | > | | < | < < | < < | < < | | > | > > < < < | > > > > | | | < | | < < < < > > > | | < > | > > > | > > > > > > > | | | | | < > | > > > | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | > | > | < | | | | < < | | < < | < | | | > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 | } if { $value < 1 } then { error "expected positive integer but got \"$value\"" } set Length $value } -strictlength { # the word exceeding the length of line is moved to the # next line without hyphenation; words longer than given # line length are cut into smaller pieces 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 "" } # ::textutil::adjust::Adjust # # History: # rewritten on 2004-04-13 for bugfix tcllib-bugs-882402 (jhv) proc ::textutil::adjust::Adjust { varOrigName varNewName } { variable Length variable FullLine variable StrictLength variable Hyphenate upvar $varOrigName orig upvar $varNewName text set pos 0; # Cursor after writing set line "" set text "" if {!$FullLine} { regsub -all -- "(\n)|(\t)" $orig " " orig regsub -all -- " +" $orig " " orig regsub -all -- "(^ *)|( *\$)" $orig "" orig } set words [split $orig]; set numWords [llength $words]; set numline 0; for {set cnt 0} {$cnt < $numWords} {incr cnt} { set w [lindex $words $cnt]; set wLen [string length $w]; # the word $w doesn't fit into the present line # case #1: we try to hyphenate if {$Hyphenate && ($pos+$wLen >= $Length)} { # Hyphenation instructions set w2 [textutil::adjust::Hyphenation $w]; set iMax [llength $w2]; if {$iMax == 1 && [string length $w] > $Length} { # word cannot be hyphenated and exceeds linesize error "Word \"$w2\" can\'t be hyphenated\ and exceeds linesize $Length!" } else { # hyphenating of $w was successfull, but we have to look # that every sylable would fit into the line foreach x $w2 { if {[string length $x] >= $Length} { error "Word \"$w\" can\'t be hyphenated\ to fit into linesize $Length!" } } } for {set i 0; set w3 ""} {$i < $iMax} {incr i} { set syl [lindex $w2 $i]; if {($pos+[string length " $w3$syl-"]) > $Length} {break} append w3 $syl; } for {set w4 ""} {$i < $iMax} {incr i} { set syl [lindex $w2 $i]; append w4 $syl; } if {[string length $w3] && [string length $w4]} { # hyphenation was successfull: redefine # list of words w => {"$w3-" "$w4"} set x [lreplace $words $cnt $cnt "$w4"]; set words [linsert $x $cnt "$w3-"]; set w [lindex $words $cnt]; set wLen [string length $w]; incr numWords; } } # the word $w doesn't fit into the present line # case #2: we try to cut the word into pieces if {$StrictLength && ([string length $w] > $Length)} { # cut word into two pieces set w2 $w; set over [expr $pos+2+$wLen-$Length]; set w3 [string range $w2 0 $Length] set w4 [string range $w2 [expr $Length+1] end]; set x [lreplace $words $cnt $cnt $w4]; set words [linsert $x $cnt $w3 ]; set w [lindex $words $cnt]; set wLen [string length $w]; incr numWords; } else { ; } # continuing with the normal procedure if {($pos+$wLen < $Length)} { # append word to current line if {$pos} {append line " "; incr pos} append line $w; incr pos $wLen; } else { # line full => write buffer and begin a new line if [string length $text] {append text "\n"} append text [Justification $line [incr numline]]; set line $w; set pos $wLen; } } # write buffer and return! if [string length $text] {append text "\n"} append text [Justification $line end]; return $text } # ::textutil::adjust::Justification # # justify a given line # # Parameters: # line text for justification # index index for line in text # # Returns: # the justified line # # Remarks: # Only lines with size not exceeding the max. linesize provided # for text formatting are justified!!! proc ::textutil::adjust::Justification { line index } { variable Justify variable Length variable FullLine variable StrRepeat set len [string length $line]; # length of current line if { $Length <= $len } then { # the length of current line ($len) is equal as or greater than # the value provided for text formatting ($Length) => to avoid # inifinite loops we leave $line unchanged and return! 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 justification, it's a little bit complex: # # if some spaces are missing, then # # 1) sort the list of words in the current line by decreasing size # 2) foreach word, add one space before it, except if it's the # first word, until enough spaces are added # 3) rebuild the line if { "$justify" == "plain" } then { set miss [ expr { $Length - [ string length $line ] } ] # Bugfix tcllib-bugs-860753 (jhv) set words [split $line]; set numWords [llength $words]; if {$numWords < 2} { # current line consists of less than two words - we can't # insert blanks to achieve a plain justification => leave # $line unchanged and return! return $line; } for {set i 0; set totalLen 0} {$i < $numWords} {incr i} { set w($i) [lindex $words $i]; if {$i > 0} {set w($i) " $w($i)"}; set wLen($i) [string length $w($i)]; set totalLen [expr $totalLen+$wLen($i)]; } set miss [expr {$Length - $totalLen}]; # len walks through all lengths of words of the line under # consideration for {set len 1} {$miss > 0} {incr len} { for {set i 1} {($i < $numWords) && ($miss > 0)} {incr i} { if {$wLen($i) == $len} { set w($i) " $w($i)"; incr wLen($i); incr miss -1; } } } set line ""; for {set i 0} {$i < $numWords} {incr i} { set line "$line$w($i)"; } # End of bugfix 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" } |
︙ | ︙ | |||
428 429 430 431 432 433 434 435 436 437 438 439 440 441 | # if there are manual set hyphenation marks e.g. "Recht\-schrei\-bung" # use these for hyphenation and return if [regexp {[^\\-]*[\\-][.]*} $str] { regsub -all {(\\)(-)} $str {-} tmp; return [split $tmp -]; } # otherwise follow Knuth's algorithm variable HyphPatterns; # hyphenation patterns (TeX) set w ".[string tolower $str]."; # transform to lower case set wLen [string length $w]; # and add delimiters | > > > > > | 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 | # if there are manual set hyphenation marks e.g. "Recht\-schrei\-bung" # use these for hyphenation and return if [regexp {[^\\-]*[\\-][.]*} $str] { regsub -all {(\\)(-)} $str {-} tmp; return [split $tmp -]; } # Don't hyphenate very short words! Minimum length for hyphenation # is set to 3 characters! if { [string length $str] < 4 } then { return $str } # otherwise follow Knuth's algorithm variable HyphPatterns; # hyphenation patterns (TeX) set w ".[string tolower $str]."; # transform to lower case set wLen [string length $w]; # and add delimiters |
︙ | ︙ |
Changes to modules/textutil/adjust.test.
︙ | ︙ | |||
64 65 66 67 68 69 70 | ::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 } \ | | | | | | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 | ::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 |
︙ | ︙ | |||
104 105 106 107 108 109 110 | 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 } \ | | | | | | | | | | | | 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 | 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, |
︙ | ︙ | |||
151 152 153 154 155 156 157 | 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 } \ | | > | | | | | | | > | | | | | | | | | | | | | | | < | | | | | | | | | | | | | < | | | | | | < | 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 | 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. ThisIsSimilarToTextOnlyThisStrin gHasOneReallyLongWordInIt 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. ThisIsSimilarToTextOnlyThisStrin gHasOneReallyLongWordInIt 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. ThisIsSimilarToTextOnlyThisStrin gHasOneReallyLongWordInIt 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 |
︙ | ︙ |
Changes to modules/textutil/adjust_hyph.test.
︙ | ︙ | |||
96 97 98 99 100 101 102 103 104 | los ucesistas a a- probar los cambios a la carta magna (Pe- riodico La Razon, Bolivia)} ########## ::tcltest::cleanupTests | > > > > > > > > > > > > > > > > > > | 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 | los ucesistas a a- probar los cambios a la carta magna (Pe- riodico La Razon, Bolivia)} ########## test adjust-tex-sf-860753 {German hyphenation with plain justification} { set str { ein test strin ein test string ein test string ein test string ein test string ein test string ein test string ein test string ein test string ein test string ein test string ein test string ein test string ein test string ein test string ein test string ein test string ein test string g ein test string } textutil::adjust::readPatterns [file join $::tcltest::testsDirectory "dehypht.tex"] textutil::adjust $str -length 76 -hyphenate 1 -strictlength 1 -justify plain } {ein test strin ein test string ein test string ein test string ein test string ein test string ein test string ein test string ein test string ein test string ein test string ein test string ein test string ein test string ein test string ein test string ein test string ein test string g ein test string} ::tcltest::cleanupTests |
Changes to modules/textutil/pkgIndex.tcl.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # 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 } | | | 8 9 10 11 12 13 14 15 16 | # 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.1 [list source [file join $dir textutil.tcl]] package ifneeded textutil::expander 1.2.1 [list source [file join $dir expander.tcl]] |
Changes to modules/textutil/textutil.man.
|
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 | [manpage_begin textutil n 0.6.1] [moddesc {Texts and strings utils}] [titledesc {Procedures to manipulate texts and strings.}] [require Tcl 8.2] [require textutil [opt 0.6.1]] [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] |
︙ | ︙ |
Changes to modules/textutil/textutil.tcl.
︙ | ︙ | |||
167 168 169 170 171 172 173 | 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. | | < | 167 168 169 170 171 172 173 174 | 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.1 |
Changes to modules/textutil/trim.tcl.
1 2 3 4 5 6 7 8 9 | namespace eval ::textutil { namespace eval trim { variable StrU "\[ \t\]+" variable StrR "(${StrU})\$" variable StrL "^(${StrU})" namespace export trim trimright trimleft \ | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | namespace eval ::textutil { namespace eval trim { variable StrU "\[ \t\]+" variable StrR "(${StrU})\$" variable StrL "^(${StrU})" namespace export trim trimright trimleft \ trimPrefix trimEmptyHeading # 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::trimEmptyHeading namespace export trim trimleft trimright trimPrefix trimEmptyHeading } proc ::textutil::trim::trimleft {text {trim "[ \t]+"}} { regsub -line -all -- [MakeStr $trim left] $text {} text return $text } |
︙ | ︙ |
Changes to modules/uri/ChangeLog.
1 2 3 4 5 6 7 | 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-11 Andreas Kupries <[email protected]> | > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | 2004-05-23 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6.1 ======================== * 2004-05-23 Andreas Kupries <[email protected]> * uri.tcl: Rel. engineering. Updated version number * uri.man: of uri to reflect its changes, to 1.1.4. * pkgIndex.tcl: 2004-05-03 Andreas Kupries <[email protected]> * uri.test: * uri.tcl (SplitHttp): Fixed [SF Tcllib Bug 936064]. Now extracting user/password information from the Http URI as well. Simple change from 'GetHostPort' to 'GetUPHP'. Updated the test suite as well (One new test, and update of 4 existing tests). 2004-02-15 Andreas Kupries <[email protected]> * * Released and tagged Tcllib 1.6 ======================== * 2004-02-11 Andreas Kupries <[email protected]> |
︙ | ︙ |
Changes to modules/uri/pkgIndex.tcl.
1 2 3 4 | if {![package vsatisfies [package provide Tcl] 8.2]} { # FRINK: nocheck return } | | | 1 2 3 4 5 6 | if {![package vsatisfies [package provide Tcl] 8.2]} { # FRINK: nocheck return } package ifneeded uri 1.1.4 [list source [file join $dir uri.tcl]] package ifneeded uri::urn 1.0.1 [list source [file join $dir urn-scheme.tcl]] |
Changes to modules/uri/uri.man.
|
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 | [manpage_begin uri n 1.1.4] [moddesc {Tcl Uniform Resource Identifier Management}] [titledesc {URI utilities}] [require Tcl 8.2] [require uri [opt 1.1.4]] [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 |
︙ | ︙ |
Changes to modules/uri/uri.tcl.
1 2 3 4 5 6 7 8 9 10 11 | # 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 # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | # 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.25.2.2 2004/05/27 02:47:48 andreas_kupries Exp $ package require Tcl 8.2 namespace eval ::uri { namespace export split join namespace export resolve isrelative |
︙ | ︙ | |||
131 132 133 134 135 136 137 | namespace delete $scheme return -code error \ "Variable \"schemepart\" is missing." } # Now we can extend the variables which keep track of the registered schemes. | | | 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 | namespace delete $scheme return -code error \ "Variable \"schemepart\" is missing." } # Now we can extend the variables which keep track of the registered schemes. eval [linsert $schemeList 0 lappend schemes] set schemePattern "([::join $schemes |]):" foreach s schemeList { # FRINK: nocheck set url2part($s) "${s}:[set ${scheme}::schemepart]" # FRINK: nocheck append url "(${s}:[set ${scheme}::schemepart])|" |
︙ | ︙ | |||
312 313 314 315 316 317 318 | set url [string replace $url [lindex $match 0] end] } if {[string match "//*" $url]} { set url [string range $url 2 end] | | | | | 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 | set url [string replace $url [lindex $match 0] end] } 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::JoinHttp {args} { eval [linsert $args 0 uri::JoinHttpInner http 80] } proc ::uri::JoinHttps {args} { eval [linsert $args 0 uri::JoinHttpInner https 443] } proc ::uri::JoinHttpInner {scheme defport args} { array set components [list \ host {} port $defport path {} query {} \ ] array set components $args |
︙ | ︙ | |||
583 584 585 586 587 588 589 | 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) } | | | 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 | 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 [linsert [array get baseparts] 0 join]] } default { return -code error "unable to resolve relative URL \"$url\"" } } } else { |
︙ | ︙ | |||
631 632 633 634 635 636 637 | # Depends on scheme proc ::uri::geturl {url args} { array set urlparts [split $url] switch -- $urlparts(scheme) { file { | | | | 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 | # Depends on scheme proc ::uri::geturl {url args} { array set urlparts [split $url] switch -- $urlparts(scheme) { file { return [eval [linsert $args 0 file_geturl $url]] } 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 [linsert $args 0 $urlparts(scheme)::geturl $url]] } } } # ::uri::file_geturl -- # # geturl implementation for file: scheme |
︙ | ︙ | |||
692 693 694 695 696 697 698 | # # Results: # A URL proc ::uri::join args { array set components $args | | | 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 | # # Results: # A URL proc ::uri::join args { array set components $args return [eval [linsert $args 0 Join[string totitle $components(scheme)]]] } # ::uri::canonicalize -- # # Canonicalize a URL # # Acknowledgements: |
︙ | ︙ | |||
750 751 752 753 754 755 756 | 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 | | | 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 | 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 [linsert [array get u] 0 uri::join]] return $uri } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # regular expressions covering various url schemes |
︙ | ︙ | |||
925 926 927 928 929 930 931 | variable fieldvalue "${char}*" variable fieldspec ";${fieldname}=${fieldvalue}" variable schemepart "//${hostOrPort}/${path}(${fieldspec})*" variable url "prospero:$schemepart" } | | | 925 926 927 928 929 930 931 932 | variable fieldvalue "${char}*" variable fieldspec ";${fieldname}=${fieldvalue}" variable schemepart "//${hostOrPort}/${path}(${fieldspec})*" variable url "prospero:$schemepart" } package provide uri 1.1.4 |
Changes to modules/uri/uri.test.
1 2 3 4 5 6 7 8 | # 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. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | # 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.17.2.1 2004/05/24 02:58:12 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] |
︙ | ︙ | |||
30 31 32 33 34 35 36 | } # ------------------------------------------------------------------------- # Split tests test uri-1.1 {uri::split - http w/- query} { eval kvsort [uri::split http://test.net/path/path2?query] | | | | | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 | } # ------------------------------------------------------------------------- # 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 {} pwd {} query query scheme http user {}} 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 {} pwd {} query query scheme https user {}} test uri-1.3 {uri::split - http w/- port} { eval kvsort [uri::split http://test.net:8080] } {host test.net path {} port 8080 pwd {} query {} scheme http user {}} test uri-1.4 {uri::split - https w/- port} { eval kvsort [uri::split https://test.net:8888] } {host test.net path {} port 8888 pwd {} query {} scheme https user {}} 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}] |
︙ | ︙ | |||
417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 | # ------------------------------------------------------------------------- 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: | > > > > > > | 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 | # ------------------------------------------------------------------------- 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} # ------------------------------------------------------------------------- test uri-9.0 {uri::split bug #936064, user information} { eval kvsort [uri::split http://foo:[email protected]:80/bla/] } {host baz.com path bla/ port 80 pwd bar query {} scheme http user foo} # ------------------------------------------------------------------------- ::tcltest::cleanupTests return # ------------------------------------------------------------------------- # Local Variables: # mode: tcl # indent-tabs-mode: nil # End: |
Changes to sak.tcl.
︙ | ︙ | |||
467 468 469 470 471 472 473 | return } proc gd-gen-rpmspec {} { global tcllib_version tcllib_name distribution | | | 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 | return } proc gd-gen-rpmspec {} { global tcllib_version tcllib_name distribution set header [string map [list @@@@ $tcllib_version @__@ $tcllib_name] {# $Id: sak.tcl,v 1.25.2.1 2004/05/24 02:58:08 andreas_kupries Exp $ %define version @@@@ %define directory /usr Summary: The standard Tcl library Name: @__@ Version: %{version} |
︙ | ︙ | |||
1161 1162 1163 1164 1165 1166 1167 | } # Build critcl modules. If no args then build the tcllibc module. proc __critcl {} { global argv critcl critclmodules tcl_platform if {$tcl_platform(platform) == "windows"} { set critcl [auto_execok tclkitsh] | | > > > > > > > > > > > > > > | > | | < > | 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 | } # Build critcl modules. If no args then build the tcllibc module. proc __critcl {} { global argv critcl critclmodules tcl_platform if {$tcl_platform(platform) == "windows"} { set critcl [auto_execok tclkitsh] if {$critcl == {}} { return -code error "error: failed to find tclkitsh.exe in path" } else { # If the critcl.kit isn't in the path, set the CRITCL env var. if {[info exists ::env(CRITCL)]} { set critclkit $::env(CRITCL) } else { set critclkit [auto_execok critcl.kit] } if {$critclkit == {}} { return -code error "error: failed to find critcl.kit in \ path.\n\ You may wish to set the CRITCL environment variable to the\ location of your critcl.kit file." } set critcl [concat $critcl $critclkit] } } else { # My, isn't it simpler under unix. set critcl [auto_execok critcl] } if {$critcl != {}} { if {[llength $argv] == 0} { puts stderr "[string repeat - 72]\nBuilding critcl components." puts stderr "Note: you can ignore warnings for tcllibc.tcl,\ base64c.tcl and crcc.tcl.\n[string repeat - 72]" critcl_module tcllibc } else { foreach m $argv { if {[info exists critclmodules($m)]} { critcl_module $m } else { puts "warning: $m is not a critcl module" |
︙ | ︙ |
Changes to tcllib_version.tcl.
|
| | | 1 2 | set tcllib_version 1.6.1 set tcllib_name tcllib |