Index: ChangeLog ================================================================== --- ChangeLog +++ ChangeLog @@ -1,5 +1,73 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-05-23 Andreas Kupries + + * Bumped version in branch to 1.6.1 in preparation of upcoming + bugfix release. + +2004-04-16 Pat Thoyts + + * 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 + + * 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 . + * 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 + + * 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 + + * tcllib_version.tcl: Moving mainline to 1.6.0.1 to distinguish + development from the released version. + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: PACKAGES ================================================================== --- PACKAGES +++ PACKAGES @@ -1,46 +1,46 @@ -@@ RELEASE 1.6 +@@ 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 -csv 0.5 +crc32 1.1.1 +csv 0.5.1 des 0.8.1 dns 1.1 -doctools 1.0.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 +fileutil 1.6.1 ftp 2.4.1 ftp::geturl 0.2 -ftpd 1.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 +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.1 -md5 2.0.0 +md4 1.0.2 +md5 2.0.1 md5crypt 1.0.0 -mime 1.3.4 +mime 1.3.6 multiplexer 0.2 ncgi 1.2.3 nntp 0.2.1 pop3 1.6.1 pop3d 1.0.2 @@ -48,20 +48,20 @@ pop3d::udb 1.1 profiler 0.2.2 report 0.3.1 resolv 1.0.3 sha1 1.0.3 -smtp 1.3.5 +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 +textutil 0.6.1 textutil::expander 1.2.1 -time 1.0.2 -uri 1.1.3 +time 1.0.3 +uri 1.1.4 uri::urn 1.0.1 -uuencode 1.1 +uuencode 1.1.1 yencode 1.1 ADDED README-1.6.1.txt Index: README-1.6.1.txt ================================================================== --- /dev/null +++ README-1.6.1.txt @@ -0,0 +1,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 +------ ------- ----------- ----------- ------------------------------- Index: examples/csv/csv2html ================================================================== --- examples/csv/csv2html +++ examples/csv/csv2html @@ -1,8 +1,9 @@ -#!/bin/sh -# use -*- tcl -*- \ -exec tclsh "$0" "$@" +#! /bin/sh +# -*- tcl -*- \ +exec tclsh "$0" ${1+"$@"} + # Generate HTML table from CSV data package require csv package require cmdline package require report Index: examples/csv/csvcut ================================================================== --- examples/csv/csvcut +++ examples/csv/csvcut @@ -1,8 +1,9 @@ -#!/bin/sh -# use -*- tcl -*- \ -exec tclsh "$0" "$@" +#! /bin/sh +# -*- tcl -*- \ +exec tclsh "$0" ${1+"$@"} + # Cut and reorder fields in a CSV file. package require csv package require cmdline Index: examples/csv/csvdiff ================================================================== --- examples/csv/csvdiff +++ examples/csv/csvdiff @@ -1,8 +1,9 @@ -#!/bin/sh -# use -*- tcl -*- \ -exec tclsh "$0" "$@" +#! /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 Index: examples/csv/csvjoin ================================================================== --- examples/csv/csvjoin +++ examples/csv/csvjoin @@ -1,8 +1,9 @@ -#!/bin/sh -# use -*- tcl -*- \ -exec tclsh "$0" "$@" +#! /bin/sh +# -*- tcl -*- \ +exec tclsh "$0" ${1+"$@"} + # Join two CSV files by key package require csv package require cmdline Index: examples/csv/csvsort ================================================================== --- examples/csv/csvsort +++ examples/csv/csvsort @@ -1,8 +1,9 @@ -#!/bin/sh -# use -*- tcl -*- \ -exec tclsh "$0" "$@" +#! /bin/sh +# -*- tcl -*- \ +exec tclsh "$0" ${1+"$@"} + # Sort CSV data by a column package require csv package require cmdline Index: examples/csv/csvuniq ================================================================== --- examples/csv/csvuniq +++ examples/csv/csvuniq @@ -1,8 +1,9 @@ -#!/bin/sh -# use -*- tcl -*- \ -exec tclsh "$0" "$@" +#! /bin/sh +# -*- tcl -*- \ +exec tclsh "$0" ${1+"$@"} + # Make CSV data the specified column unique. package require csv package require cmdline Index: examples/ftp/ftpdemo.tcl ================================================================== --- examples/ftp/ftpdemo.tcl +++ examples/ftp/ftpdemo.tcl @@ -1,9 +1,9 @@ -#!/bin/sh -# the next line restarts using wish \ -exec wish8.3 "$0" "$@" -# +#! /bin/sh +# -*- tcl -*- \ +exec tclsh "$0" ${1+"$@"} + # - simple tcl/tk test script for FTP library package - # # Required: tcl/tk8.3 # # Created: 07/97 @@ -20,11 +20,11 @@ # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. # ######################################################################## -package require Tcl 8 +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" } { Index: examples/ftp/ftpvalid ================================================================== --- examples/ftp/ftpvalid +++ examples/ftp/ftpvalid @@ -1,8 +1,9 @@ -#!/bin/sh +#! /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 Index: examples/ftp/hpupdate.tcl ================================================================== --- examples/ftp/hpupdate.tcl +++ examples/ftp/hpupdate.tcl @@ -1,9 +1,9 @@ -#!/bin/sh -# the next line restarts using wish \ -exec wish8.3 "$0" -- "$@" -# +#! /bin/sh +# -*- tcl -*- \ +exec tclsh "$0" ${1+"$@"} + # - homepage update program using FTP - # # Required: tcl/tk8.2 # # Created: 12/96 @@ -29,10 +29,11 @@ # 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 } Index: examples/ftp/mirror.tcl ================================================================== --- examples/ftp/mirror.tcl +++ examples/ftp/mirror.tcl @@ -1,9 +1,10 @@ -#!/bin/sh -# the next line restarts using tclsh \ -exec tclsh8.3 "$0" -- "$@" +#! /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 Index: examples/ftp/newer.tcl ================================================================== --- examples/ftp/newer.tcl +++ examples/ftp/newer.tcl @@ -1,9 +1,10 @@ -#!/bin/sh -# the next line restarts using tclsh \ -exec tclsh8.3 "$0" -- "$@" +#! /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 Index: examples/ftpd/ftpd ================================================================== --- examples/ftpd/ftpd +++ examples/ftpd/ftpd @@ -1,10 +1,12 @@ -#!/bin/sh +#! /bin/sh +# -*- tcl -*- \ +exec tclsh "$0" ${1+"$@"} + # FTP daemon -# \ -exec tclsh8.3 "$0" ${1+"$@"} +package require Tcl 8.3 if {[catch {package require ftpd}]} { set here [file dirname [info script]] source [file join .. $here ftpd.tcl] } Index: examples/ftpd/ftpd.test ================================================================== --- examples/ftpd/ftpd.test +++ examples/ftpd/ftpd.test @@ -1,16 +1,18 @@ -#!/bin/sh -# FTP daemon for testing the ftp client (modules/ftp). +#! /bin/sh # -*- tcl -*- \ -exec tclsh8.3 "$0" ${1+"$@"} +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 Index: examples/ftpd/ftpd.unix ================================================================== --- examples/ftpd/ftpd.unix +++ examples/ftpd/ftpd.unix @@ -1,10 +1,12 @@ -#!/bin/sh +#! /bin/sh +# -*- tcl -*- \ +exec tclsh "$0" ${1+"$@"} + # FTP daemon -# \ -exec tclsh8.3 "$0" ${1+"$@"} +package require Tcl 8.3 if {[catch {package require ftpd}]} { set here [file dirname [info script]] source [file join .. $here ftpd.tcl] } Index: examples/irc/irc_example.tcl ================================================================== --- examples/irc/irc_example.tcl +++ examples/irc/irc_example.tcl @@ -1,11 +1,11 @@ -#!/bin/sh -# the next line restarts using tclsh \ - exec tclsh "$0" "$@" +#! /bin/sh +# -*- tcl -*- \ +exec tclsh "$0" ${1+"$@"} # irc example script, by David N. Welton -# $Id: irc_example.tcl,v 1.7 2004/01/15 06:36:12 andreas_kupries Exp $ +# $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" Index: examples/mime/mbot/impersonal.tcl ================================================================== --- examples/mime/mbot/impersonal.tcl +++ examples/mime/mbot/impersonal.tcl @@ -1,16 +1,16 @@ -#!/bin/sh -# the next line restarts using tclsh \ -PATH=/usr/pkg/bin:/usr/local/bin:/usr/bin:/bin LD_LIBRARY_PATH=/usr/pkg/lib:/usr/local/lib:/usr/lib export PATH LD_LIBRARY_PATH; exec tclsh8.3 "$0" "$@" +#! /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 Index: examples/mime/mbot/personal.tcl ================================================================== --- examples/mime/mbot/personal.tcl +++ examples/mime/mbot/personal.tcl @@ -1,18 +1,18 @@ -#!/bin/sh -# the next line restarts using tclsh \ -PATH=/usr/pkg/bin:/usr/local/bin:/usr/bin:/bin LD_LIBRARY_PATH=/usr/pkg/lib:/usr/local/lib:/usr/lib export PATH LD_LIBRARY_PATH; exec tclsh8.3 "$0" "$@" - +#! /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 Index: examples/nntp/postnews ================================================================== --- examples/nntp/postnews +++ examples/nntp/postnews @@ -1,8 +1,9 @@ -#!/usr/local/bin/tclsh -# -*- tcl -*- -# +#! /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 Index: examples/oreilly-oscon2001/oscon ================================================================== --- examples/oreilly-oscon2001/oscon +++ examples/oreilly-oscon2001/oscon @@ -1,8 +1,9 @@ -#!/bin/sh -# use -*- tcl -*- \ -exec tclsh "$0" "$@" +#! /bin/sh +# -*- tcl -*- \ +exec tclsh "$0" ${1+"$@"} + # Extract and report oscon schedule package require struct package require csv package require report Index: examples/smtpd/tcl_smtpd ================================================================== --- examples/smtpd/tcl_smtpd +++ examples/smtpd/tcl_smtpd @@ -1,7 +1,9 @@ #! /bin/sh -# +# -*- tcl -*- \ +exec tclsh "$0" ${1+"$@"} + # tcl_smtpd - Copyright (C) 2001 Pat Thoyts # # Simple test of the mail server. All incoming messages are displayed to # stdout. # @@ -14,13 +16,12 @@ # This software is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the file 'license.terms' for # more details. # ------------------------------------------------------------------------- -# \ -exec tclsh8.3 "$0" ${1+"$@"} +package require 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]}]} { Index: examples/smtpd/tk_smtpd ================================================================== --- examples/smtpd/tk_smtpd +++ examples/smtpd/tk_smtpd @@ -1,7 +1,9 @@ #! /bin/sh -# +# -*- tcl -*- \ +exec tclsh "$0" ${1+"$@"} + # tk_smtpd - Copyright (C) 2001 Pat Thoyts # # Simple test of the mail server. All incoming messages are displayed in a # message dialog. # @@ -16,15 +18,14 @@ # This software is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the file 'license.terms' for # more details. # ------------------------------------------------------------------------- -# \ -exec wish8.3 "$0" ${1+"$@"} -package require smtpd +package require 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]}]} { Index: examples/smtpd/tk_smtpdMIME ================================================================== --- examples/smtpd/tk_smtpdMIME +++ examples/smtpd/tk_smtpdMIME @@ -1,7 +1,9 @@ #! /bin/sh -# +# -*- tcl -*- \ +exec tclsh "$0" ${1+"$@"} + # tk_smtpdMIME -Copyright (C) 2002 Pat Thoyts # # Simple test of the mail server. All incoming messages are displayed in a # message dialog. # @@ -18,16 +20,15 @@ # This software is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the file 'license.terms' for # more details. # ------------------------------------------------------------------------- -# \ -exec wish "$0" ${1+"$@"} +package require Tcl 8.3 +package require Tk package require smtpd package require mime -package require Tk wm withdraw . set _dlgid 0 # Handle new mail by raising a message dialog for each recipient. proc deliverMIME {token} { Index: install_action.tcl ================================================================== --- install_action.tcl +++ install_action.tcl @@ -49,11 +49,20 @@ } proc _man {module format ext docdir} { global distribution argv argc argv0 config - package require doctools + # [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 Index: installer.tcl ================================================================== --- installer.tcl +++ installer.tcl @@ -1,11 +1,15 @@ #!/bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # -------------------------------------------------------------- -# Installer for Tcllib +# 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] @@ -95,10 +99,11 @@ 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 } Index: modules/base64/ChangeLog ================================================================== --- modules/base64/ChangeLog +++ modules/base64/ChangeLog @@ -1,5 +1,21 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-05-23 Andreas Kupries + + * 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 + + * uuencode.tcl (::uuencode::pad): don't use log package + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/base64/pkgIndex.tcl ================================================================== --- modules/base64/pkgIndex.tcl +++ modules/base64/pkgIndex.tcl @@ -7,8 +7,8 @@ # 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 [list source [file join $dir uuencode.tcl]] -package ifneeded yencode 1.1 [list source [file join $dir yencode.tcl]] +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]] Index: modules/base64/uuencode.man ================================================================== --- modules/base64/uuencode.man +++ modules/base64/uuencode.man @@ -1,11 +1,11 @@ -[manpage_begin uuencode n 1.1] +[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]] +[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 Index: modules/base64/uuencode.tcl ================================================================== --- modules/base64/uuencode.tcl +++ modules/base64/uuencode.tcl @@ -4,22 +4,21 @@ # # ------------------------------------------------------------------------- # 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 2004/01/25 07:29:21 andreas_kupries Exp $ +# @(#)$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 -catch {package require log}; # tcllib 1.0 # Try and get some compiled helper package. if {[catch {package require tcllibc}]} { catch {package require Trf} } namespace eval ::uuencode { - variable version 1.1 + variable version 1.1.1 namespace export encode decode uuencode uudecode } proc ::uuencode::Enc {c} { @@ -162,12 +161,10 @@ # Result: # Returns the input string - possibly padded with uuencoded null chars. # proc ::uuencode::pad {s} { if {[set mod [expr {[string length $s] % 4}]] != 0} { - log::log notice "invalid uuencoded string: padding string to a\ - multiple of 4." append s [string repeat "`" [expr {4 - $mod}]] } return $s } Index: modules/calendar/ChangeLog ================================================================== --- modules/calendar/ChangeLog +++ modules/calendar/ChangeLog @@ -1,5 +1,11 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/calendar/gregorian.test ================================================================== --- modules/calendar/gregorian.test +++ modules/calendar/gregorian.test @@ -3,11 +3,11 @@ # calendar.test -- # # Tests for [calendar::CommonCalendar] and # [calendar::GregorianCalendar] # -# RCS: @(#) $Id: gregorian.test,v 1.3 2004/01/15 06:36:12 andreas_kupries Exp $ +# 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 } @@ -27,17 +27,27 @@ # #---------------------------------------------------------------------- # 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 } { Index: modules/cmdline/ChangeLog ================================================================== --- modules/cmdline/ChangeLog +++ modules/cmdline/ChangeLog @@ -1,5 +1,11 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/comm/ChangeLog ================================================================== --- modules/comm/ChangeLog +++ modules/comm/ChangeLog @@ -1,5 +1,11 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/control/ChangeLog ================================================================== --- modules/control/ChangeLog +++ modules/control/ChangeLog @@ -1,5 +1,11 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/counter/ChangeLog ================================================================== --- modules/counter/ChangeLog +++ modules/counter/ChangeLog @@ -1,5 +1,11 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/crc/ChangeLog ================================================================== --- modules/crc/ChangeLog +++ modules/crc/ChangeLog @@ -1,5 +1,22 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-05-23 Andreas Kupries + + * 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 + + * crc32.tcl: Cope with data begining with hyphen when using + Trf (SF bug #914278) + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/crc/crc32.man ================================================================== --- modules/crc/crc32.man +++ modules/crc/crc32.man @@ -1,11 +1,11 @@ -[manpage_begin crc32 n 1.1] +[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]] +[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 Index: modules/crc/crc32.tcl ================================================================== --- modules/crc/crc32.tcl +++ modules/crc/crc32.tcl @@ -8,14 +8,14 @@ # # ------------------------------------------------------------------------- # 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 2004/01/25 07:29:21 andreas_kupries Exp $ +# $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 + variable crc32_version 1.1.1 namespace export crc32 variable crc32_tbl [list 0x00000000 0x77073096 0xEE0E612C 0x990951BA \ 0x076DC419 0x706AF48F 0xE963A535 0x9E6495A3 \ @@ -162,11 +162,11 @@ 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 + binary scan [crc-zlib -- $s] i r return $r } interp alias {} ::crc::Crc32 {} ::crc::Crc32_trf } else { Index: modules/crc/pkgIndex.tcl ================================================================== --- modules/crc/pkgIndex.tcl +++ modules/crc/pkgIndex.tcl @@ -1,5 +1,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 [list source [file join $dir crc32.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]] Index: modules/csv/ChangeLog ================================================================== --- modules/csv/ChangeLog +++ modules/csv/ChangeLog @@ -1,5 +1,22 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-05-23 Andreas Kupries + + * 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 + + * 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 * * Released and tagged Tcllib 1.6 ======================== * Index: modules/csv/csv.man ================================================================== --- modules/csv/csv.man +++ modules/csv/csv.man @@ -1,12 +1,12 @@ [comment {-*- tcl -*-}] -[manpage_begin csv n 0.5] +[manpage_begin csv n 0.5.1] [copyright {2002 Andreas Kupries }] [moddesc {CSV processing}] [titledesc {Procedures to handle CSV data.}] [require Tcl 8.3] -[require csv [opt 0.5]] +[require csv [opt 0.5.1]] [description] [para] The [package csv] package provides commands to manipulate information Index: modules/csv/csv.tcl ================================================================== --- modules/csv/csv.tcl +++ modules/csv/csv.tcl @@ -6,14 +6,14 @@ # Copyright (c) 2001 by Andreas Kupries # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: csv.tcl,v 1.16 2004/01/25 07:29:39 andreas_kupries Exp $ +# 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 +package provide csv 0.5.1 namespace eval ::csv { namespace export join joinlist read2matrix read2queue report namespace export split split2matrix split2queue writematrix writequeue } @@ -127,11 +127,11 @@ set m $b set sepChar $c set expand $d } } - 4 { + 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 Index: modules/csv/pkgIndex.tcl ================================================================== --- modules/csv/pkgIndex.tcl +++ modules/csv/pkgIndex.tcl @@ -7,6 +7,6 @@ # 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 [list source [file join $dir csv.tcl]] +package ifneeded csv 0.5.1 [list source [file join $dir csv.tcl]] Index: modules/des/ChangeLog ================================================================== --- modules/des/ChangeLog +++ modules/des/ChangeLog @@ -1,5 +1,11 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/devtools/microserv.tcl ================================================================== --- modules/devtools/microserv.tcl +++ modules/devtools/microserv.tcl @@ -1,6 +1,6 @@ -#- *- tcl -*- +# -*- tcl -*- # MicroServer (also MicroServant) # aka muserv (mu = greek micron) # # Copyright (c) 2003 by Andreas Kupries Index: modules/devtools/musub.tcl ================================================================== --- modules/devtools/musub.tcl +++ modules/devtools/musub.tcl @@ -1,6 +1,6 @@ -#!/bin/sh +#! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # Generic framework for a microserv.tcl based server/ # Index: modules/dns/ChangeLog ================================================================== --- modules/dns/ChangeLog +++ modules/dns/ChangeLog @@ -1,5 +1,15 @@ +2004-05-26 Pat Thoyts + + * dns.tcl: Fix issue setting the log level properly. + +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/dns/dns.tcl ================================================================== --- modules/dns/dns.tcl +++ modules/dns/dns.tcl @@ -19,20 +19,20 @@ # ------------------------------------------------------------------------- # 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 2004/01/25 07:29:39 andreas_kupries Exp $ +# $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 2004/01/25 07:29:39 andreas_kupries Exp $} + 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 @@ -44,11 +44,11 @@ search {} nameserver {localhost} loglevel warn } variable log [logger::init dns] - ${log}::enable $options(loglevel) + ${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 @@ -140,11 +140,11 @@ -log* { if {$cget} { return $options(loglevel) } else { set options(loglevel) [Pop args 1] - ${log}::enable $options(loglevel) + ${log}::setlevel $options(loglevel) } } -- { Pop args ; break } default { set opts [join [lsort [array names options]] ", -"] Index: modules/doctools/ChangeLog ================================================================== --- modules/doctools/ChangeLog +++ modules/doctools/ChangeLog @@ -1,5 +1,43 @@ +2004-05-30 Andreas Kupries + + * mpexpand.man: Updated reference 'dtformat' to 'doctools_fmt'. + +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-05-23 Andreas Kupries + + * 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 + + * 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 + + * 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 + + * mpformats/fmt.xml: BUGFIX: "puts stderr" ==> "puts_stderr". + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/doctools/doctools.man ================================================================== --- modules/doctools/doctools.man +++ modules/doctools/doctools.man @@ -1,12 +1,12 @@ [comment {-*- tcl -*- doctools manpage}] -[manpage_begin doctools n 1.0.1] +[manpage_begin doctools n 1.0.2] [copyright {2003 Andreas Kupries }] [moddesc {Documentation tools}] [titledesc {Create and manipulate doctools converter object}] [require Tcl 8.2] -[require doctools [opt 1.0.1]] +[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 Index: modules/doctools/doctools.tcl ================================================================== --- modules/doctools/doctools.tcl +++ modules/doctools/doctools.tcl @@ -5,11 +5,11 @@ # Copyright (c) 2003 Andreas Kupries # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: doctools.tcl,v 1.7 2004/01/25 07:29:39 andreas_kupries Exp $ +# 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 { @@ -1154,6 +1154,6 @@ #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.1 +package provide doctools 1.0.2 Index: modules/doctools/mpexpand ================================================================== --- modules/doctools/mpexpand +++ modules/doctools/mpexpand @@ -1,6 +1,6 @@ -#!/bin/sh +#! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} lappend auto_path [file dirname [file dirname [info script]]] package require doctools Index: modules/doctools/mpexpand.all ================================================================== --- modules/doctools/mpexpand.all +++ modules/doctools/mpexpand.all @@ -1,6 +1,6 @@ -#!/bin/sh +#! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} set here [file dirname [file join [pwd] [info script]]] set verbose 0 Index: modules/doctools/mpexpand.man ================================================================== --- modules/doctools/mpexpand.man +++ modules/doctools/mpexpand.man @@ -6,11 +6,11 @@ [titledesc {Markup processor}] [description] [para] This manpage describes a processor / converter for manpages in the -doctools format as specified in [cmd dtformat]. The processor is based +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]|-] Index: modules/doctools/mpformats/_nroff.tcl ================================================================== --- modules/doctools/mpformats/_nroff.tcl +++ modules/doctools/mpformats/_nroff.tcl @@ -13,15 +13,15 @@ # because of this is filtered out in the post-processing step. proc nr_lp {} {return \n.LP} proc nr_ta {{text {}}} {return ".ta$text"} -proc nr_bld {} {return \\fB} -proc nr_ul {} {return \\fI} -proc nr_rst {} {return \\fR} +proc nr_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 "'\\\" [join [split $text \n] "\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"} @@ -36,12 +36,47 @@ 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) @@ -77,7 +112,8 @@ set line [string trimright $line] } lappend lines $line } # Return the modified result buffer - return [join $lines "\n"] + return [string map $finalMap [join $lines "\n"]] } + Index: modules/doctools/mpformats/_text.tcl ================================================================== --- modules/doctools/mpformats/_text.tcl +++ modules/doctools/mpformats/_text.tcl @@ -275,10 +275,13 @@ } 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 Index: modules/doctools/mpformats/_xml.tcl ================================================================== --- modules/doctools/mpformats/_xml.tcl +++ modules/doctools/mpformats/_xml.tcl @@ -1,8 +1,8 @@ # -*- tcl -*- # -# $Id: _xml.tcl,v 1.8 2004/01/15 06:36:12 andreas_kupries Exp $ +# $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 . # Freely redistributable. @@ -154,11 +154,11 @@ } # Not found: set elementStack $origStack if {![string length $default]} { set where "[join $elementStack /] - [info level 1]" - puts stderr "Warning: Cannot start context $gis ($where)" + puts_stderr "Warning: Cannot start context $gis ($where)" set default [lindex $gis 0] } lappend elementStack $default return [startTag $default] } Index: modules/doctools/mpformats/fmt.nroff ================================================================== --- modules/doctools/mpformats/fmt.nroff +++ modules/doctools/mpformats/fmt.nroff @@ -42,11 +42,11 @@ c_hold hdr [nr_include man.macros] c_hold hdr [nr_title "\"[string trimleft $title :]\" $section $version $module \"$shortdesc\""] c_hold hdr [nr_bolds] c_hold hdr [fmt_section NAME] - c_hold hdr "$title \\- $description" + c_hold hdr "$title \1\\- $description" return [c_held hdr] } c_pass 1 fmt_moddesc {desc} {c_set_module $desc} @@ -136,11 +136,11 @@ } return {} } proc fmt_enum {} {return [nr_item " \[[c_cnext]\]\n"]} -proc fmt_bullet {} {return [nr_item " \\(bu"]} +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 ""] @@ -148,11 +148,11 @@ append text " $type" if {$mode != {}} {append text " ($mode)"} return $text } proc fmt_opt_def {name {arg {}}} { - if {[string match -* $name]} {set name \\-$name} + #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} { Index: modules/doctools/pkgIndex.tcl ================================================================== --- modules/doctools/pkgIndex.tcl +++ modules/doctools/pkgIndex.tcl @@ -7,10 +7,10 @@ # 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.1 [list source [file join $dir doctools.tcl]] +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]] Index: modules/doctools/tocexpand ================================================================== --- modules/doctools/tocexpand +++ modules/doctools/tocexpand @@ -1,6 +1,6 @@ -#!/bin/sh +#! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} rename source __source proc source {path} { Index: modules/exif/ChangeLog ================================================================== --- modules/exif/ChangeLog +++ modules/exif/ChangeLog @@ -1,5 +1,11 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/fileutil/ChangeLog ================================================================== --- modules/fileutil/ChangeLog +++ modules/fileutil/ChangeLog @@ -1,5 +1,29 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-05-23 Andreas Kupries + + * 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 + + * 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 + + * fileutil.tcl: updated the jpeg test to recognize exif format + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/fileutil/fileutil.man ================================================================== --- modules/fileutil/fileutil.man +++ modules/fileutil/fileutil.man @@ -1,11 +1,11 @@ [comment {-*- tcl -*- doctools manpage}] -[manpage_begin fileutil n 1.6] +[manpage_begin fileutil n 1.6.1] [moddesc {file utilities}] [titledesc {Procedures implementing some file utilities}] [require Tcl 8] -[require fileutil [opt 1.6]] +[require fileutil [opt 1.6.1]] [description] [para] This package provides implementations of standard unix utilities. Index: modules/fileutil/fileutil.tcl ================================================================== --- modules/fileutil/fileutil.tcl +++ modules/fileutil/fileutil.tcl @@ -6,15 +6,15 @@ # Copyright (c) 2002 by Phil Ehrens (fileType) # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: fileutil.tcl,v 1.37 2004/02/10 06:44:21 andreas_kupries Exp $ +# 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 +package provide fileutil 1.6.1 namespace eval ::fileutil { namespace export grep find findByPattern cat foreachLine } @@ -423,11 +423,11 @@ set pwd [file split $pwd] set npath [file split $path] if {[string match ${pwd}* $npath]} { - set path [eval file join [lrange $npath [llength $pwd] end]] + set path [eval [linsert [lrange $npath [llength $pwd] end] 0 file join ]] } return $path } # ::fileutil::stripN -- @@ -444,11 +444,11 @@ proc ::fileutil::stripN {path n} { set path [file split $path] if {$n >= [llength $path]} { return {} } else { - return [eval file join [lrange $path $n end]] + return [eval [linsert [lrange $path $n end] 0 file join]] } } # ::fileutil::cat -- # @@ -686,12 +686,17 @@ lappend type compressed gzip } elseif { $binary && [string match "GIF*" $test] } { lappend type graphic gif } elseif { $binary && [string match "\x89PNG*" $test] } { lappend type graphic png - } elseif { $binary && [string match "\xFF\xD8\xFF\xE0\x00\x10JFIF*" $test] } { - lappend type graphic jpeg + } elseif { $binary && [string match "\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 "*\*" $test] } { Index: modules/fileutil/fileutil.test ================================================================== --- modules/fileutil/fileutil.test +++ modules/fileutil/fileutil.test @@ -6,11 +6,11 @@ # # Copyright (c) 1998-2000 by Ajuba Solutions. # Copyright (c) 2001 by ActiveState Tool Corp. # All rights reserved. # -# RCS: @(#) $Id: fileutil.test,v 1.22 2004/02/14 05:59:20 andreas_kupries Exp $ +# 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} { @@ -467,11 +467,11 @@ } [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]] +} [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]] Index: modules/fileutil/pkgIndex.tcl ================================================================== --- modules/fileutil/pkgIndex.tcl +++ modules/fileutil/pkgIndex.tcl @@ -7,6 +7,6 @@ # 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 [list source [file join $dir fileutil.tcl]] +package ifneeded fileutil 1.6.1 [list source [file join $dir fileutil.tcl]] Index: modules/ftp/ChangeLog ================================================================== --- modules/ftp/ChangeLog +++ modules/ftp/ChangeLog @@ -1,5 +1,11 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/ftpd/ChangeLog ================================================================== --- modules/ftpd/ChangeLog +++ modules/ftpd/ChangeLog @@ -1,5 +1,22 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-05-23 Andreas Kupries + + * 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 + + * Bugfixes by Gerald Lester. No details available. Gerald is asked + to replace this entry with one describing his changes. + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/ftpd/ftpd.man ================================================================== --- modules/ftpd/ftpd.man +++ modules/ftpd/ftpd.man @@ -1,11 +1,11 @@ [comment {-*- tcl -*- doctools manpage}] -[manpage_begin ftpd n 1.2] +[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]] +[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]). Index: modules/ftpd/ftpd.tcl ================================================================== --- modules/ftpd/ftpd.tcl +++ modules/ftpd/ftpd.tcl @@ -7,11 +7,11 @@ # 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 2004/02/11 07:48:40 andreas_kupries Exp $ +# 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 @@ -1072,11 +1072,11 @@ ::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 "200 OK" + puts $sock "230 OK" set data(access) 1 } return } @@ -1747,31 +1747,31 @@ # # Patched Mark O'Connor # set fhandle [open $path a] if {[lindex $args 0] == "binary"} { - fconfigure $fhandle -translation 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 + 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 + fconfigure $fhandle -translation binary -encoding binary } return $fhandle } dlist { foreach {style outchan} $args break @@ -1994,11 +1994,11 @@ # sourced into the interpreter. # # Patched Mark O'Connor # -package provide ftpd 1.2 +package provide ftpd 1.2.1 ## ## Implementation of passive command ## @@ -2012,11 +2012,11 @@ 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" + puts $sock "227 Entering Passive Mode ($ans)." return } proc ::ftpd::PasvAccept {sock sock2 ip port} { Index: modules/ftpd/pkgIndex.tcl ================================================================== --- modules/ftpd/pkgIndex.tcl +++ modules/ftpd/pkgIndex.tcl @@ -7,6 +7,6 @@ # 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 [list source [file join $dir ftpd.tcl]] +package ifneeded ftpd 1.2.1 [list source [file join $dir ftpd.tcl]] Index: modules/html/ChangeLog ================================================================== --- modules/html/ChangeLog +++ modules/html/ChangeLog @@ -1,5 +1,11 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/html/html.tcl ================================================================== --- modules/html/html.tcl +++ modules/html/html.tcl @@ -308,11 +308,11 @@ # 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 uplevel $args + ::eval [linsert $args 0 uplevel] return "" } # ::html::init # @@ -655,11 +655,11 @@ # Results: # The html fragment proc ::html::textInputRow {label name {value {}} args} { variable defaults - ::set html [row $label [::eval [list html::textInput $name $value] $args]] + ::set html [row $label [::eval [linsert $args 0 html::textInput $name $value]]] return $html } # ::html::passwordInputRow -- # Index: modules/htmlparse/ChangeLog ================================================================== --- modules/htmlparse/ChangeLog +++ modules/htmlparse/ChangeLog @@ -1,5 +1,11 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/inifile/ChangeLog ================================================================== --- modules/inifile/ChangeLog +++ modules/inifile/ChangeLog @@ -1,5 +1,19 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-03-06 Andreas Kupries + + * 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 * * Released and tagged Tcllib 1.6 ======================== * Index: modules/inifile/ini.tcl ================================================================== --- modules/inifile/ini.tcl +++ modules/inifile/ini.tcl @@ -5,11 +5,11 @@ # Copyright (c) 2003 Aaron Faupell # # 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 2004/02/11 07:48:41 andreas_kupries Exp $ +# 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 @@ -262,13 +262,13 @@ } if { ![info exists comments($sec\000$key)] } { return {} } return $comments($sec\000$key) } if { $key == "" } { - eval [list lappend comments($sec)] $args + eval [linsert $args 0 lappend comments($sec)] } else { - eval [list lappend comments($sec\000$key)] $args + eval [linsert $args 0 lappend comments($sec\000$key)] } } # return the physical filename for the handle Index: modules/inifile/inifile.test ================================================================== --- modules/inifile/inifile.test +++ modules/inifile/inifile.test @@ -29,63 +29,104 @@ #--------------------------------------------------------------------- set testini [file join [file dirname [info script]] test.ini] test inifile-1.1 {ini::open} { - ini::open $testini + set res [ini::open $testini r] + ini::close $res + set res } {ini0} test inifile-1.2 {ini::sections} { - ini::sections ini0 + 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} { - ini::keys ini0 section1 + 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} { - ini::keys ini0 \{test + set hdl [ini::open $testini r] + set res [ini::keys $hdl \{test] + ini::close $hdl + set res } {\}key} test inifile-1.5 {ini::get} { - ini::get ini0 section1 + 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} { - ini::get ini0 \{test + 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} { - ini::value ini0 section1 key + 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} { - ini::value ini0 \{test \}key + 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} { - ini::exists ini0 section1 + set hdl [ini::open $testini r] + set res [ini::exists $hdl section1] + ini::close $hdl + set res } {1} test inifile-1.10 {ini::exists} { - ini::exists ini0 section + set hdl [ini::open $testini r] + set res [ini::exists $hdl section] + ini::close $hdl + set res } {0} test inifile-1.11 {ini::exists} { - ini::exists ini0 section1 testkey + 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} { - ini::exists ini0 section1 blah + 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} { - ini::exists ini0 \{test + set hdl [ini::open $testini r] + set res [ini::exists $hdl \{test] + ini::close $hdl + set res } {1} test inifile-1.14 {ini:::exists} { - ini::exists ini0 \{test \}key + set hdl [ini::open $testini r] + set res [ini::exists $hdl \{test \}key] + ini::close $hdl + set res } {1} #--------------------------------------------------------------------- # Clean up Index: modules/irc/ChangeLog ================================================================== --- modules/irc/ChangeLog +++ modules/irc/ChangeLog @@ -1,5 +1,11 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/javascript/ChangeLog ================================================================== --- modules/javascript/ChangeLog +++ modules/javascript/ChangeLog @@ -1,5 +1,11 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/log/ChangeLog ================================================================== --- modules/log/ChangeLog +++ modules/log/ChangeLog @@ -1,5 +1,53 @@ +2004-05-26 Michael Schlenker + + * 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 + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-05-23 Andreas Kupries + + * 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 + + * 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 + + * 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 + + * 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 * * Released and tagged Tcllib 1.6 ======================== * Index: modules/log/log.man ================================================================== --- modules/log/log.man +++ modules/log/log.man @@ -1,12 +1,12 @@ [comment {-*- tcl -*- doctools manpage}] -[manpage_begin log n 1.1] +[manpage_begin log n 1.1.1] [copyright {2001-2002 Andreas Kupries }] [moddesc {Logging facility}] [titledesc {Procedures to log messages of libraries and applications.}] [require Tcl 8] -[require log [opt 1.1]] +[require log [opt 1.1.1]] [description] [para] The [package log] package provides commands that allow libraries and Index: modules/log/log.tcl ================================================================== --- modules/log/log.tcl +++ modules/log/log.tcl @@ -5,11 +5,13 @@ # # Copyright (c) 2001 by ActiveState Tool Corp. # See the file license.terms. package require Tcl 8 -package provide log 1.1 +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 @@ -746,5 +748,12 @@ } puts $chan "$level$fill($level) $text" return } + +# ### ### ### ######### ######### ######### +## Initialization code. Disable logging for the lower levels by +## default. + +## log::lvSuppressLE emergency +log::lvSuppressLE warning Index: modules/log/log.test ================================================================== --- modules/log/log.test +++ modules/log/log.test @@ -5,11 +5,11 @@ # No output means no errors were found. # # Copyright (c) 2001 by ActiveState Tool Corp. # All rights reserved. # -# RCS: @(#) $Id: log.test,v 1.3 2004/01/15 06:36:13 andreas_kupries Exp $ +# 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::* } @@ -128,14 +128,19 @@ 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 debug error emergency info notice warning} { +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" Index: modules/log/logger.man ================================================================== --- modules/log/logger.man +++ modules/log/logger.man @@ -1,12 +1,12 @@ [comment {-*- tcl -*- doctools manpage}] -[comment {$Id: logger.man,v 1.8 2004/02/14 05:59:20 andreas_kupries Exp $}] -[manpage_begin logger n 0.3] +[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] -[require logger [opt 0.3]] +[require Tcl 8.2] +[require logger [opt 0.3.1]] [description] [para] The [package logger] package provides a flexible system for logging messages @@ -39,30 +39,33 @@ [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 initalized, it "inherits" properties from its +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 or "above" the given level. Levels are +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 or "below" the given level. Levels are +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]). @@ -84,17 +87,19 @@ it. [call [cmd \${log}::enable] [arg level]] Enable logging, in the service referenced by [var \${log}], and its -children, at or above the level specified. Note that this does [emph not] disable logging below this level, so you should probably use +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 or below the level specified. Note that this does [emph not] enable logging above this level, so you should probably use [cmd setlevel] instead. +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 @@ -118,19 +123,20 @@ ${log}::logproc notice logtoserver }] [call [cmd \${log}::services]] -Returns a list of all the registered logging 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. +Returns the currently enabled log level for this service. If no logging is enabled returns [const none]. -[call [cmd \${log}::delproc]] +[call [cmd \${log}::delproc] [arg command]] -Set the script to call when the log instance in question is deleted. For example: +Set the script to call when the log instance in question is deleted. +For example: [example { ${log}::delproc [list closesock $logsock] }] Index: modules/log/logger.tcl ================================================================== --- modules/log/logger.tcl +++ modules/log/logger.tcl @@ -1,402 +1,446 @@ # logger.tcl -- # -# Tcl implementation of a general logging facility. +# Tcl implementation of a general logging facility. # # Copyright (c) 2003 by David N. Welton +# Copyright (c) 2004 by Michael Schlenker # 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 +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. - set services {} + variable services {} # The log 'levels'. - set levels [list debug info notice warn error critical] + variable levels [list debug info notice warn error critical] } # ::logger::walk -- # -# Walk namespaces, starting in 'start', and evaluate 'code' in -# them. +# Walk namespaces, starting in 'start', and evaluate 'code' in +# them. # # Arguments: -# start - namespace to start in. -# code - code to execute in namespaces walked. +# start - namespace to start in. +# code - code to execute in namespaces walked. # # Side Effects: -# Side effects of code executed. +# Side effects of code executed. # # Results: -# None. +# None. proc ::logger::walk { start code } { set children [namespace children $start] foreach c $children { - logger::walk $c $code - namespace eval $c $code + 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} {} + namespace eval tree::${service} { + variable service + variable levels + } lappend services $service - set tree::${service}::service $service - set tree::${service}::levels $levels + 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. - set 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 $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" - } - - # this is the lowest level possible. - variable enabled $lv - 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 - - logger::walk [namespace current] delete - catch { uplevel \#0 $delcallback } - namespace delete [namespace current] - } - - # 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 - set parent [namespace parent] - while { $parent != "::logger::tree" } { - # If the 'enabled' variable doesn't exist, create the - # whole thing. - if { ! [::info exists ${parent}::enabled] } { - logger::init [string map {::logger::tree:: ""} $parent] - } - set enabled [set ${parent}::enabled] - enable $enabled - set parent [namespace parent $parent] - } + # 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 { $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 - } - } + 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. +# Returns a list of all active services. # # Arguments: -# None. +# None. # # Side Effects: -# None. +# None. # # Results: -# List of active services. +# List of active services. proc ::logger::services {} { variable services - return 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. +# 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. +# lv - level above which to enable logging. # # Side Effects: -# Enables logging in a given level, and all higher levels. +# Enables logging in a given level, and all higher levels. # # Results: -# None. +# None. proc ::logger::enable {lv} { variable services foreach sv $services { - ::logger::tree::${sv}::enable $lv + ::logger::tree::${sv}::enable $lv } } proc ::logger::disable {lv} { variable services foreach sv $services { - ::logger::tree::${sv}::disable $lv + ::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. +# Introspect the available log levels. Provided so a caller does +# not need to know implementation details or code the list +# himself. # # Arguments: -# None. +# None. # # Side Effects: -# None. +# None. # # Results: -# levels - The list of valid log levels accepted by enable and disable +# levels - The list of valid log levels accepted by enable and disable proc ::logger::levels {} { variable levels return $levels } Index: modules/log/logger.test ================================================================== --- modules/log/logger.test +++ modules/log/logger.test @@ -3,20 +3,21 @@ # # 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 . +# Copyright (c) 2004 by Michael Schlenker . # -# $Id: logger.test,v 1.5 2004/02/13 15:21:02 davidw Exp $ +# $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.2 +package require logger 0.3.1 test logger-1.0 {init basic} { set log [logger::init global] ${log}::delete set log @@ -23,10 +24,12 @@ } {::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] @@ -34,10 +37,21 @@ ${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 @@ -192,77 +206,157 @@ ${log1}::delete set ::INFO } {{Error Message} {Warning Message}} test logger-6.0 {levels command} { - logger::levels + 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 + 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 + 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 + 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 + 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 + 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 + 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 Index: modules/log/pkgIndex.tcl ================================================================== --- modules/log/pkgIndex.tcl +++ modules/log/pkgIndex.tcl @@ -7,8 +7,8 @@ # 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 [list source [file join $dir log.tcl]] +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 [list source [file join $dir logger.tcl]] +package ifneeded logger 0.3.1 [list source [file join $dir logger.tcl]] Index: modules/math/ChangeLog ================================================================== --- modules/math/ChangeLog +++ modules/math/ChangeLog @@ -1,18 +1,30 @@ +2004-06-18 Kevin Kenny + + * combinatorics.test: Kevin added the display of the math version + number to the test. + +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== - * + * + 2004-02-09 Jeff Hobbs * combinatorics.tcl (::math::factorial): correct fac 171 off-by-one and use of -strict in string is int|double. 2003-12-22 Joe English - * calculus.man (rungeKuttaStep): Add missing argument + * calculus.man (rungeKuttaStep): Add missing argument in function synopsis (bug report from Richard Body). 2003-10-29 Arjen Markus * statistics.tcl (BasicStat): Applied fix for [SF Tcllib Bug @@ -23,11 +35,11 @@ 2003-05-05 Andreas Kupries * * Released and tagged Tcllib 1.4 ======================== - * + * 2003-04-24 Andreas Kupries * pkgIndex.tcl: Found math::optimize missing in index. * optimize.man: Version number inconsistent with code, @@ -61,12 +73,12 @@ * optimize.test: Corrected errors in loading the functionality under test, and of accessing tcltest. Now functional. 2003-04-18 Joe English * pkgIndex.tcl: Added math::statistics after yesterday's commit by Arjen Markus. @@ -85,11 +97,11 @@ * pkgIndex.tcl: * fuzzy.tcl: Committed new code (see #535216), this also updates the package to version 0.2 - * fuzzy.man: + * 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 @@ -176,11 +188,11 @@ * combinatorics.tcl: Removed incorrect 'package provide'. 2002-01-11 Kevin Kenny - * math.tcl: + * 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'. @@ -194,12 +206,12 @@ * math.tcl: Fixed dubious code reported by frink. 2000-10-06 Eric Melski - * math.test: - * math.n: + * math.test: + * math.n: * math.tcl: Added ::math::fibonacci function, to compute numbers in the Fibonacci sequence. 2000-09-08 Eric Melski @@ -209,19 +221,19 @@ * pkgIndex.tcl: Bumped version number to 1.1. 2000-06-15 Eric Melski - * math.n: - * math.test: + * math.n: + * math.test: * math.tcl: Incorporated sigma, cov, stats, integrate functions (from Philip Ehrens ). [RFE: 5060] 2000-03-27 Eric Melski - * math.n: - * math.test: + * math.n: + * math.test: * math.tcl: Added sum, mean, and product functions (from Philip Ehrens ). 2000-03-09 Eric Melski Index: modules/math/combinatorics.test ================================================================== --- modules/math/combinatorics.test +++ modules/math/combinatorics.test @@ -5,11 +5,11 @@ # 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 2004/02/14 05:59:20 andreas_kupries Exp $ +# 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::* } @@ -16,13 +16,10 @@ source [file join [file dirname [info script]] math.tcl] source [file join [file dirname [info script]] combinatorics.tcl] package require math - -puts "math [package present 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]] } { Index: modules/md4/ChangeLog ================================================================== --- modules/md4/ChangeLog +++ modules/md4/ChangeLog @@ -1,5 +1,23 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-05-23 Andreas Kupries + + * 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 + + * 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 * * Released and tagged Tcllib 1.6 ======================== * Index: modules/md4/md4.man ================================================================== --- modules/md4/md4.man +++ modules/md4/md4.man @@ -1,11 +1,11 @@ -[manpage_begin md4 n 1.0.1] +[manpage_begin md4 n 1.0.2] [moddesc {md4}] [copyright {2003, Pat Thoyts }] [titledesc {MD4 Message-Digest Algorithm}] [require Tcl 8.2] -[require md4 [opt 1.0.1]] +[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 Index: modules/md4/md4.tcl ================================================================== --- modules/md4/md4.tcl +++ modules/md4/md4.tcl @@ -6,18 +6,18 @@ # ------------------------------------------------------------------------- # 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 2004/01/15 06:36:13 andreas_kupries Exp $ +# $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.1 - variable rcsid {$Id: md4.tcl,v 1.9 2004/01/15 06:36:13 andreas_kupries Exp $} + 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]} { @@ -278,12 +278,14 @@ [expr {((0xFF000000 & $v) >> 24) & 0xFF}] } # 32bit rotate-left proc ::md4::<<< {v n} { - set v [expr {(($v << $n) | (($v >> (32 - $n)) & (0x7FFFFFFF >> (31 - $n))))}] - return [expr {$v & 0xFFFFFFFF}] + return [expr {((($v << $n) \ + | (($v >> (32 - $n)) \ + & (0x7FFFFFFF >> (31 - $n))))) \ + & 0xFFFFFFFF}] } # Convert our <<< pseuodo-operator into a procedure call. regsub -all -line \ {\[expr {(.*) <<< (\d+)}\]} \ @@ -331,11 +333,11 @@ proc ::md4::MD4Hash {token msg} $::md4::MD4Hash_body # ------------------------------------------------------------------------- if {[package provide Trf] != {}} { - interp alias {} ::md4::Hex {} ::hex -mode encode + interp alias {} ::md4::Hex {} ::hex -mode encode -- } else { proc ::md4::Hex {data} { set result {} binary scan $data c* r foreach c $r { Index: modules/md4/md4.test ================================================================== --- modules/md4/md4.test +++ modules/md4/md4.test @@ -1,8 +1,8 @@ # md4.test - Copyright (C) 2003 Pat Thoyts # -# $Id: md4.test,v 1.4 2004/01/15 06:36:13 andreas_kupries Exp $ +# $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::* } @@ -189,16 +189,18 @@ 147 9B98A75EDED6B5AF8C449B75A74C30B3 148 5F9F642231152DD8CD5CAA9B5FC59B5D 149 84D82189C5458F8647D338FD62EF1667 } { test md4-2.$n "md4 block size checks: length $n" { - ::md4::md4 -hex [string repeat a $n] - } $hash + 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: Index: modules/md4/md4_check.c ================================================================== --- modules/md4/md4_check.c +++ modules/md4/md4_check.c @@ -3,20 +3,20 @@ * 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 2004/01/15 06:36:13 andreas_kupries Exp $ + * $Id: md4_check.c,v 1.2.2.1 2004/05/24 03:13:33 andreas_kupries Exp $ */ #include #include #include #include static const char rcsid[] = -"$Id: md4_check.c,v 1.2 2004/01/15 06:36:13 andreas_kupries Exp $"; +"$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; Index: modules/md4/md4c.tcl ================================================================== --- modules/md4/md4c.tcl +++ modules/md4/md4c.tcl @@ -8,11 +8,11 @@ # INSTALLATION # ------------ # This package uses critcl (http://wiki.tcl.tk/critcl). To build do: # critcl -libdir -pkg md4c md4c # -# $Id: md4c.tcl,v 1.4 2004/01/15 06:36:13 andreas_kupries Exp $ +# $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 Index: modules/md4/pkgIndex.tcl ================================================================== --- modules/md4/pkgIndex.tcl +++ modules/md4/pkgIndex.tcl @@ -2,9 +2,9 @@ # # md4 package index file # # This package has been tested with tcl 8.2.3 and above. # -# $Id: pkgIndex.tcl,v 1.3 2004/01/15 06:36:13 andreas_kupries Exp $ +# $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.1 [list source [file join $dir md4.tcl]] +package ifneeded md4 1.0.2 [list source [file join $dir md4.tcl]] Index: modules/md5/ChangeLog ================================================================== --- modules/md5/ChangeLog +++ modules/md5/ChangeLog @@ -1,5 +1,23 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-05-23 Andreas Kupries + + * 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 + + * 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 * * Released and tagged Tcllib 1.6 ======================== * Index: modules/md5/md5.man ================================================================== --- modules/md5/md5.man +++ modules/md5/md5.man @@ -1,11 +1,11 @@ -[manpage_begin md5 n 2.0.0] +[manpage_begin md5 n 2.0.1] [moddesc {Perform md5 hashing}] [copyright {2003, Pat Thoyts }] [titledesc {MD5 Message-Digest Algorithm}] [require Tcl 8.2] -[require md5 2.0] +[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 Index: modules/md5/md5.test ================================================================== --- modules/md5/md5.test +++ modules/md5/md5.test @@ -6,11 +6,11 @@ # 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 2004/02/14 05:59:20 andreas_kupries Exp $ +# 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} { Index: modules/md5/md5c.tcl ================================================================== --- modules/md5/md5c.tcl +++ modules/md5/md5c.tcl @@ -2,11 +2,11 @@ # # Wrapper for RSA's Message Digest in C # # Written by Jean-Claude Wippler # -# $Id: md5c.tcl,v 1.3 2004/01/15 06:36:13 andreas_kupries Exp $ +# $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 Index: modules/md5/md5x.tcl ================================================================== --- modules/md5/md5x.tcl +++ modules/md5/md5x.tcl @@ -14,11 +14,11 @@ # ------------------------------------------------------------------------- # 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 2004/01/15 06:36:13 andreas_kupries Exp $ +# $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}]} { @@ -29,12 +29,12 @@ } } } namespace eval ::md5 { - variable version 2.0.0 - variable rcsid {$Id: md5x.tcl,v 1.3 2004/01/15 06:36:13 andreas_kupries Exp $} + 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]} { @@ -380,12 +380,14 @@ [expr {((0xFF000000 & $v) >> 24) & 0xFF}] } # 32bit rotate-left proc ::md5::<<< {v n} { - set v [expr {(($v << $n) | (($v >> (32 - $n)) & (0x7FFFFFFF >> (31 - $n))))}] - return [expr {$v & 0xFFFFFFFF}] + 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+)\)}\]} \ @@ -483,11 +485,11 @@ proc ::md5::MD5Hash {token msg} $::md5::MD5Hash_bodyX # ------------------------------------------------------------------------- if {[package provide Trf] != {}} { - interp alias {} ::md5::Hex {} ::hex -mode encode + interp alias {} ::md5::Hex {} ::hex -mode encode -- } else { proc ::md5::Hex {data} { set result {} binary scan $data c* r foreach c $r { Index: modules/md5/md5x.test ================================================================== --- modules/md5/md5x.test +++ modules/md5/md5x.test @@ -6,11 +6,11 @@ # 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 2004/02/14 05:59:21 andreas_kupries Exp $ +# 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} { Index: modules/md5/pkgIndex.tcl ================================================================== --- modules/md5/pkgIndex.tcl +++ modules/md5/pkgIndex.tcl @@ -7,7 +7,7 @@ # 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.0 [list source [file join $dir md5x.tcl]] +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]] Index: modules/md5crypt/ChangeLog ================================================================== --- modules/md5crypt/ChangeLog +++ modules/md5crypt/ChangeLog @@ -1,5 +1,11 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/mime/ChangeLog ================================================================== --- modules/mime/ChangeLog +++ modules/mime/ChangeLog @@ -1,5 +1,66 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-05-23 Andreas Kupries + + * 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 + + * 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 + + * 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 + + * mime.tcl (copymessageaux): Applied the patch for [SF Tcllib Bug + 893516] on behalf of Marshall Rose. The problem was found by + Todd Copeland , he provided the + patch as well. + +2004-05-04 Andreas Kupries + + * 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 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 + for the work, and Mikhail Teterin + 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 + 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 * * Released and tagged Tcllib 1.6 ======================== * Index: modules/mime/mime.man ================================================================== --- modules/mime/mime.man +++ modules/mime/mime.man @@ -1,12 +1,12 @@ [comment {-*- tcl -*- doctools manpage}] -[manpage_begin mime n 1.3.4] +[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.4]] +[require mime [opt 1.3.6]] [description] [para] The [package mime] library package provides the commands to create and manipulate MIME body parts. @@ -175,25 +175,25 @@ [nl] When the end of the body is reached, the callback is invoked as: [example { - uplevel #0 $callback "end" + uplevel #0 $callback "end" }] [nl] Alternatively, if an error occurs, the callback is invoked as: [example { - uplevel #0 $callback [list "error" reason] + uplevel #0 $callback [list "error" reason] }] [nl] Regardless, the return value of the final invocation of the callback -is propagated upwards by mime::getbody. +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 Index: modules/mime/mime.tcl ================================================================== --- modules/mime/mime.tcl +++ modules/mime/mime.tcl @@ -10,21 +10,21 @@ # # new string features and inline scan are used, requiring 8.3. package require Tcl 8.3 -package provide mime 1.3.4 +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 - package require md5 1.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 { @@ -32,18 +32,29 @@ return [base64::$what $chunk] } proc quoted-printable {-mode what -- chunk} { return [mime::qp_$what $chunk] } - proc md5 {-- string} { - return [md5::md5 $string] - } + + 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: # @@ -110,40 +121,41 @@ LX_QUOTE] set encList [list \ ascii US-ASCII \ big5 Big5 \ - cp1250 "" \ - cp1251 "" \ - cp1252 "" \ - cp1253 "" \ - cp1254 "" \ - cp1255 "" \ - cp1256 "" \ - cp1257 "" \ - cp1258 "" \ - cp437 "" \ + 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 "" \ - cp850 "" \ - cp852 "" \ - cp855 "" \ - cp857 "" \ - cp860 "" \ - cp861 "" \ - cp862 "" \ - cp863 "" \ - cp864 "" \ - cp865 "" \ - cp866 "" \ - cp869 "" \ + 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 "" \ + cp936 GBK \ cp949 "" \ cp950 "" \ dingbats "" \ + ebcdic "" \ euc-cn EUC-CN \ euc-jp EUC-JP \ euc-kr EUC-KR \ gb12345 GB12345 \ gb1988 GB1988 \ @@ -158,16 +170,21 @@ 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 \ - jis0201 "" \ - jis0208 "" \ - jis0212 "" \ + iso8859-16 ISO-8859-16 \ + jis0201 JIS_X0201 \ + jis0208 JIS_C6226-1983 \ + jis0212 JIS_X0212-1990 \ koi8-r KOI8-R \ - ksc5601 "" \ + koi8-u KOI8-U \ + ksc5601 KS_C_5601-1987 \ macCentEuro "" \ macCroatian "" \ macCyrillic "" \ macDingbats "" \ macGreek "" \ @@ -178,10 +195,11 @@ macThai "" \ macTurkish "" \ macUkraine "" \ shiftjis Shift_JIS \ symbol "" \ + tis-620 TIS-620 \ unicode "" \ utf-8 UTF-8] variable encodings array set encodings $encList @@ -189,10 +207,133 @@ 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 \ @@ -242,11 +383,11 @@ set token [namespace current]::[incr mime(uid)] # FRINK: nocheck variable $token upvar 0 $token state - if {[set code [catch { eval [list mime::initializeaux $token] $args } \ + if {[set code [catch { eval [linsert $args 0 mime::initializeaux $token] } \ result]]} { set ecode $errorCode set einfo $errorInfo catch { mime::finalize $token -subordinates dynamic } @@ -925,18 +1066,18 @@ switch -- $options(-subordinates) { all { if {![string compare $state(value) parts]} { foreach part $state(parts) { - eval [list mime::finalize $part] $args + eval [linsert $args 0 mime::finalize $part] } } } dynamic { for {set cid $state(cid)} {$cid > 0} {incr cid -1} { - eval [list mime::finalize $token-$cid] $args + eval [linsert $args 0 mime::finalize $token-$cid] } } none { } @@ -1416,11 +1557,15 @@ } } result] set ecode $errorCode set einfo $errorInfo - return -code $code -errorinfo $einfo -errorcode $ecode $result + 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 @@ -1632,13 +1777,13 @@ } if {$size > 0} { set size [expr {$size - [string length $X]}] } if {[string compare $converter ""]} { - puts $channel [$converter -mode encode -- $X] + puts -nonewline $channel [$converter -mode encode -- $X] } else { - puts $channel $X + puts -nonewline $channel $X } } if {$closeP} { catch { close $state(fd) } @@ -1683,10 +1828,13 @@ } 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 { Index: modules/mime/mime.test ================================================================== --- modules/mime/mime.test +++ modules/mime/mime.test @@ -5,28 +5,39 @@ # 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 2004/02/13 06:51:37 andreas_kupries Exp $ +# 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]]: $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 @@ -282,7 +293,39 @@ } { 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 Index: modules/mime/performance.tcl ================================================================== --- modules/mime/performance.tcl +++ modules/mime/performance.tcl @@ -1,6 +1,8 @@ -#!/usr/bin/tclsh +#! /bin/sh +# -*- tcl -*- \ +exec tclsh "$0" ${1+"$@"} #package require mime source ./mime.tcl proc construct_item_with_attachment size { Index: modules/mime/pkgIndex.tcl ================================================================== --- modules/mime/pkgIndex.tcl +++ modules/mime/pkgIndex.tcl @@ -1,3 +1,3 @@ if {![package vsatisfies [package provide Tcl] 8.3]} {return} -package ifneeded mime 1.3.4 [list source [file join $dir mime.tcl]] -package ifneeded smtp 1.3.5 [list source [file join $dir smtp.tcl]] +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]] Index: modules/mime/smtp.man ================================================================== --- modules/mime/smtp.man +++ modules/mime/smtp.man @@ -1,13 +1,13 @@ [comment {-*- tcl -*- doctools manpage}] -[manpage_begin smtp n 1.3.5] +[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.5]] -[require smtp [opt 1.3.5]] +[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. Index: modules/mime/smtp.tcl ================================================================== --- modules/mime/smtp.tcl +++ modules/mime/smtp.tcl @@ -5,12 +5,12 @@ # 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.4 -package provide smtp 1.3.5 +package require mime 1.3.6 +package provide smtp 1.3.6 # # state variables: # # sd: socket to server @@ -1034,16 +1034,12 @@ # FRINK: nocheck variable $token upvar 0 $token state switch -- $command { - create/read - - - create/write - - - clear/write - - + create/write - + clear/write - delete/write { set state(crP) 0 set state(nlP) 1 set state(size) 0 } @@ -1099,17 +1095,30 @@ incr state(size) [string length $result] return $result } - create/read - + 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 { - error "Unknown command \"$command\"" + # Silently pass all unknown commands. + #error "Unknown command \"$command\"" } } return "" } Index: modules/multiplexer/ChangeLog ================================================================== --- modules/multiplexer/ChangeLog +++ modules/multiplexer/ChangeLog @@ -1,5 +1,11 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/ncgi/ChangeLog ================================================================== --- modules/ncgi/ChangeLog +++ modules/ncgi/ChangeLog @@ -1,5 +1,11 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/nntp/ChangeLog ================================================================== --- modules/nntp/ChangeLog +++ modules/nntp/ChangeLog @@ -1,5 +1,11 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/nntp/nntp.tcl ================================================================== --- modules/nntp/nntp.tcl +++ modules/nntp/nntp.tcl @@ -3,11 +3,11 @@ # nntp implementation for Tcl. # # Copyright (c) 1998-2000 by Ajuba Solutions. # All rights reserved. # -# RCS: @(#) $Id: nntp.tcl,v 1.12 2004/02/16 04:14:48 andreas_kupries Exp $ +# 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 { @@ -169,11 +169,11 @@ error "bad option \"$cmd\": must be $optlist" } # Call the appropriate command with its arguments - return [eval [list ::nntp::_$cmd $name] $args] + return [eval [linsert $args 0 ::nntp::_$cmd $name]] } # ::nntp::okprint -- # # Used to test the return code stored in data(code) to @@ -801,11 +801,11 @@ flush $sock return } proc ::nntp::command {name args} { - set res [eval [list ::nntp::cmd $name] $args] + set res [eval [linsert $args 0 ::nntp::cmd $name]] return [::nntp::response $name] } proc ::nntp::msg {name} { Index: modules/ntp/ChangeLog ================================================================== --- modules/ntp/ChangeLog +++ modules/ntp/ChangeLog @@ -1,5 +1,25 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-05-23 Andreas Kupries + + * 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 + + * time.tcl: Fix the version as 1.0.2 + +2004-02-26 Pat Thoyts + + * time.tcl: Applied patch #905132 to better handle socket errors. + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/ntp/ntp_time.man ================================================================== --- modules/ntp/ntp_time.man +++ modules/ntp/ntp_time.man @@ -1,11 +1,11 @@ -[manpage_begin ntp_time n 1.0.2] +[manpage_begin ntp_time n 1.0.3] [copyright {2002, Pat Thoyts }] [moddesc {ntp}] [titledesc {Tcl Time Service Client}] [require Tcl 8.2] -[require time [opt 1.0.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]). Index: modules/ntp/pkgIndex.tcl ================================================================== --- modules/ntp/pkgIndex.tcl +++ modules/ntp/pkgIndex.tcl @@ -6,6 +6,6 @@ # 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.2 [list source [file join $dir time.tcl]] +package ifneeded time 1.0.3 [list source [file join $dir time.tcl]] Index: modules/ntp/time.tcl ================================================================== --- modules/ntp/time.tcl +++ modules/ntp/time.tcl @@ -5,18 +5,18 @@ # ------------------------------------------------------------------------- # 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 2004/01/15 06:36:13 andreas_kupries Exp $ +# $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.1 - variable rcsid {$Id: time.tcl,v 1.9 2004/01/15 06:36:13 andreas_kupries Exp $} + 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]} { @@ -168,11 +168,17 @@ if {$State(-protocol) == "udp"} { set State(sock) [udp_open] udp_conf $State(sock) $State(-timeserver) $State(-port) } else { - set State(sock) [socket $State(-timeserver) $State(-port)] + 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) \ Index: modules/pop3/ChangeLog ================================================================== --- modules/pop3/ChangeLog +++ modules/pop3/ChangeLog @@ -1,5 +1,11 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/pop3/clnt.tcl ================================================================== --- modules/pop3/clnt.tcl +++ modules/pop3/clnt.tcl @@ -1,6 +1,6 @@ -#!/bin/sh +#! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # pop3 client, loaded with sequence of operations # to perform. Index: modules/pop3/srv.tcl ================================================================== --- modules/pop3/srv.tcl +++ modules/pop3/srv.tcl @@ -1,6 +1,6 @@ -#!/bin/sh +#! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # pop3 server for testing the client. # Spawn this via pipe. Writes the port Index: modules/pop3d/ChangeLog ================================================================== --- modules/pop3d/ChangeLog +++ modules/pop3d/ChangeLog @@ -1,5 +1,11 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/profiler/ChangeLog ================================================================== --- modules/profiler/ChangeLog +++ modules/profiler/ChangeLog @@ -1,5 +1,11 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/report/ChangeLog ================================================================== --- modules/report/ChangeLog +++ modules/report/ChangeLog @@ -1,5 +1,11 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/sha1/ChangeLog ================================================================== --- modules/sha1/ChangeLog +++ modules/sha1/ChangeLog @@ -1,5 +1,11 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/smtpd/ChangeLog ================================================================== --- modules/smtpd/ChangeLog +++ modules/smtpd/ChangeLog @@ -1,5 +1,21 @@ +2004-06-18 Pat Thoyts + + * 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 + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/smtpd/pkgIndex.tcl ================================================================== --- modules/smtpd/pkgIndex.tcl +++ modules/smtpd/pkgIndex.tcl @@ -7,6 +7,6 @@ # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.3]} {return} -package ifneeded smtpd 1.2.1 [list source [file join $dir smtpd.tcl]] +package ifneeded smtpd 1.2.2 [list source [file join $dir smtpd.tcl]] Index: modules/smtpd/smtpd.man ================================================================== --- modules/smtpd/smtpd.man +++ modules/smtpd/smtpd.man @@ -1,12 +1,12 @@ [comment {-*- tcl -*- doctools manpage}] -[manpage_begin smtpd n 1.2.1] +[manpage_begin smtpd n 1.2.2] [copyright {Pat Thoyts }] [moddesc {Tcl SMTP Server Package}] [titledesc {Tcl SMTP server implementation}] [require Tcl 8.3] -[require smtpd [opt 1.2.1]] +[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 Index: modules/smtpd/smtpd.tcl ================================================================== --- modules/smtpd/smtpd.tcl +++ modules/smtpd/smtpd.tcl @@ -14,12 +14,12 @@ 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 2004/01/15 06:36:14 andreas_kupries Exp $} - variable version 1.2.1 + 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} @@ -344,22 +344,18 @@ # Description: # Calculate the local offset from GMT in hours for use in the timestamp # proc ::smtpd::gmtoffset {} { set now [clock seconds] - set lh [string trimleft [clock format $now -format "%H" -gmt false] 0] - set zh [string trimleft [clock format $now -format "%H" -gmt true] 0] - if {$lh == "" || $zh == ""} { - set off 0 - } else { - set off [expr {$zh - $lh}] - } - if {$off > 0} { - set off [format "+%02d00" $off] - } else { - set off [format "-%02d00" [expr {abs($off)}]] - } + 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: @@ -475,13 +471,12 @@ 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\ + Puts $channel "250 $options(serveraddr) Hello $domain\ \[[state $channel client_addr]\], pleased to meet you" - Puts $channel "250 Ready for mail." state $channel domain $domain log::log debug "HELO on $channel from $domain" return } Index: modules/snit/ChangeLog ================================================================== --- modules/snit/ChangeLog +++ modules/snit/ChangeLog @@ -1,5 +1,16 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-02-26 Andreas Kupries + + * snit.test: Codified the requirement of Tcl 8.4 into + * pkgIndex.tcl: package index and test suite. + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/snit/pkgIndex.tcl ================================================================== --- modules/snit/pkgIndex.tcl +++ modules/snit/pkgIndex.tcl @@ -1,2 +1,3 @@ +if {![package vsatisfies [package provide Tcl] 8.4]} {return} package ifneeded snit 0.93 \ [list source [file join $dir snit.tcl]] Index: modules/snit/snit.test ================================================================== --- modules/snit/snit.test +++ modules/snit/snit.test @@ -8,24 +8,30 @@ # # 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 math::statistics." + puts "Aborting tests for snit." puts "Requiring tcltest 2.1, have [package present tcltest]" return } } @@ -50,10 +56,11 @@ 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 Index: modules/soundex/ChangeLog ================================================================== --- modules/soundex/ChangeLog +++ modules/soundex/ChangeLog @@ -1,5 +1,11 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/stooop/ChangeLog ================================================================== --- modules/stooop/ChangeLog +++ modules/stooop/ChangeLog @@ -1,5 +1,11 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/struct/ChangeLog ================================================================== --- modules/struct/ChangeLog +++ modules/struct/ChangeLog @@ -1,5 +1,86 @@ +2004-08-09 Andreas Kupries + + * 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 + + * sets.tests: + * sets.tcl (::struct::set::Sdifference): Fixed the [Tcllib SF Bug + 1002143]. Thanks to Todd Coram 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: for the report. + +2004-08-03 Andreas Kupries + + * 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: for both report and fix. + +2004-06-01 Andreas Kupries + + * matrix.tcl (_search): Fixed bug reported by Joachim Kock + , using his fix. Search went into an infinite + loop if -nocase was used. + * matrix.test: Added a testcase. + +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-02-24 Andreas Kupries + + * sets.tcl: Typo police. No functional changes. + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * @@ -70,11 +151,11 @@ 2004-01-28 Andreas Kupries * struct_tree.man: Updated documentation. * tree.test: Updated testsuite for modified 'walk' syntax. - * tree.tcl (method walk): Modified to use list of loopvariables, + * 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 @@ -157,11 +238,11 @@ * graph.tcl: Updated testsuite, documentation. * graph.test: 2003-07-15 Andreas Kupries - * tree.tcl: Created ldelete and lset (emulation pre 8.4) + * 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. @@ -183,11 +264,11 @@ 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 - rootnode. The APIs 'getall' and 'keys' now allow usage of glob + 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 @@ -200,11 +281,11 @@ 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 - associoated namespaces. The object namespace now has the same + 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 @@ -221,11 +302,11 @@ * 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]. + fixes SF Tcllib bug [765321]. 2003-05-20 Andreas Kupries * list.tcl (dispatcher): eval => uplevel so that upvar's in the method commands do not need to know about the dispatcher frame @@ -235,11 +316,11 @@ * 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 + of loop variables in the keyed helper commands 'frink' complained about. 2003-05-16 Andreas Kupries * Extension of the package functionality warrants version bump to 1.4. @@ -250,11 +331,11 @@ * 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, lef/right/full + 'dbJoin(Keyed)' for relational table join (inner, left/right/full outer). Fixed function name in some error messages. 2003-05-14 Andreas Kupries * tree.tcl: Added some [list]'s to show node names containing @@ -261,11 +342,11 @@ spaces properly in error messages. * tree.test: Reworked to test handling of item nodes containing spaces. - * tree.bench: Reworked, added helper procedures, testcases are now + * tree.bench: Reworked, added helper procedures, test cases are now simpler. * struct_list.man: Fixed typos in the examples. 2003-05-06 Jeff Hobbs @@ -337,11 +418,11 @@ * tcllib_list.man: Changed name to struct_list.man. Allows for usage of struct outside of tcllib, not as big a coupling. * graph.tcl: Redone the setting up of namespace a bit to prevent problem with the generation of a master package - index. strcut.tcl bailed out with an error because the namespace + 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 * graph.test: @@ -382,11 +463,11 @@ * list.tcl: Added and documented commands [iota], [equal], and [repeat]. Extended the testsuite. 2003-04-02 Andreas Kupries - * list.cl: + * list.tcl: * list.test: Fixed SF tcllib bug #714209. * ../../../examples/struct: Added example applications for usage of longestCommonSubsequence and lcsInvert. @@ -469,11 +550,11 @@ * tree.man: Updated the documentation to clarify the behaviour. * test.tcl: Updated testsuite, part of the patch below. * tree.tcl (_move): Accepted patch by Brian Theado - fixing the behaviour of mov, SF + 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 @@ -706,13 +787,13 @@ name is given [RFE: 4345] 2000-03-08 Eric Melski * tree.test: - * tree.tcl: Added check for node existance in children function + * tree.tcl: Added check for node existence in children function [Bug: 4341] 2000-03-03 Eric Melski * tree.tcl: Changed usage information for tree::_walk. * tree.n: Enhanced description of walk function, fixed a typo. Index: modules/struct/graph.tcl ================================================================== --- modules/struct/graph.tcl +++ modules/struct/graph.tcl @@ -5,11 +5,11 @@ # 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 2004/02/09 09:32:13 andreas_kupries Exp $ +# 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 @@ -20,11 +20,11 @@ # 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_ -# useable anymore. +# usable anymore. # # '[package vcompare $version 0.6] > 0' <=> '$version > 0.6' if { ![catch {package require cgraph} version] && @@ -366,11 +366,11 @@ return } # ::struct::graph::__arc_exists -- # -# Test for existance of a given arc in a graph. +# Test for existence of a given arc in a graph. # # Arguments: # name name of the graph. # arc arc to look for. # @@ -465,11 +465,11 @@ return [array names data $pattern] } # ::struct::graph::__arc_keyexists -- # -# Test for existance of a given key for a given arc in a graph. +# 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 @@ -844,11 +844,11 @@ upvar ${name}::$arcAttr($arc) data catch {unset data($key)} if {[array size data] == 0} { # No attributes stored for this arc, squash the whole array. - set arcAttr($arc) {} + unset arcAttr($arc) unset data } return } @@ -1275,11 +1275,11 @@ return [array names graphAttr $pattern] } # ::struct::graph::_keyexists -- # -# Test for existance of a given key in a graph. +# Test for existence of a given key in a graph. # # Arguments: # name name of the graph. # key key to lookup # @@ -1454,11 +1454,11 @@ return } # ::struct::graph::__node_exists -- # -# Test for existance of a given node in a graph. +# Test for existence of a given node in a graph. # # Arguments: # name name of the graph. # node node to look for. # @@ -1553,11 +1553,11 @@ return [array names data $pattern] } # ::struct::graph::__node_keyexists -- # -# Test for existance of a given key for a node in a graph. +# 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 @@ -1588,11 +1588,11 @@ # name name of the graph. # args node to insert; must be unique. If none is given, # the routine will generate a unique node name. # # Results: -# node The namee of the new node. +# 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 @@ -1858,11 +1858,11 @@ upvar ${name}::$nodeAttr($node) data catch {unset data($key)} if {[array size data] == 0} { # No attributes stored for this node, squash the whole array. - set nodeAttr($node) {} + unset nodeAttr($node) unset data } return } @@ -2662,11 +2662,11 @@ } } # ::struct::graph::GenAttributeStorage -- # -# Create an array to store the attrributes of a node in. +# 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. @@ -2691,10 +2691,16 @@ $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." Index: modules/struct/graph.test ================================================================== --- modules/struct/graph.test +++ modules/struct/graph.test @@ -6,11 +6,11 @@ # 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 2004/02/14 05:59:22 andreas_kupries Exp $ +# 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::* } @@ -501,11 +501,11 @@ set result [catch {mygraph arc unset root bogus}] mygraph destroy set result } 0 -test graph-9.5 {arc unset removes attribute from node} { +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] @@ -515,10 +515,25 @@ 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 @@ -1005,10 +1020,23 @@ 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 @@ -2407,10 +2435,20 @@ 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 @@ -2623,10 +2661,19 @@ 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 Index: modules/struct/matrix.tcl ================================================================== --- modules/struct/matrix.tcl +++ modules/struct/matrix.tcl @@ -1,18 +1,18 @@ # matrix.tcl -- # # Implementation of a matrix data structure for Tcl. # -# Copyright (c) 2001 by Andreas Kupries +# Copyright (c) 2001-2004 by Andreas Kupries # # Heapsort code Copyright (c) 2003 by Edwin A. Suominen , # 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 2004/01/25 06:15:05 andreas_kupries Exp $ +# 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 {} @@ -22,18 +22,18 @@ # # One namespace per object, containing # # - Two scalar variables containing the current number of rows and columns. # - Four array variables containing the array data, the caches for - # rowheights and columnwidths and the information about linked arrays. + # 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 columnwidths - # - rowh cache of rowheights + # - 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 @@ -409,10 +409,11 @@ 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" @@ -1611,11 +1612,11 @@ } # ::struct::matrix::_links -- # # Retrieves the names of all array variable the matrix is -# officialy linked to. +# officially linked to. # # Arguments: # name Name of the matrix object. # # Results: @@ -1744,11 +1745,11 @@ # # 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. +# value The new value of the cell. # # Results: # None. proc ::struct::matrix::__set_cell {name column row value} { @@ -1834,11 +1835,11 @@ # ::struct::matrix::__set_rect -- # # Takes a list of lists of cell values and writes them into the # submatrix whose top-left cell is specified by the two -# indices. If the sublists of the outerlist are not of equal +# 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, @@ -2200,11 +2201,11 @@ proc ::struct::matrix::_unlink {name avar} { variable ${name}::link if {![info exists link($avar)]} { - # Ignore unlinking of unkown variables. + # Ignore unlinking of unknown variables. return } # Delete the traces first, then remove the link management # information from the object. Index: modules/struct/matrix.test ================================================================== --- modules/struct/matrix.test +++ modules/struct/matrix.test @@ -6,11 +6,11 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 2001 by Andreas Kupries # All rights reserved. # -# RCS: @(#) $Id: matrix.test,v 1.11 2004/02/14 05:59:22 andreas_kupries Exp $ +# 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::* } @@ -1907,10 +1907,11 @@ 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} Index: modules/struct/queue.tcl ================================================================== --- modules/struct/queue.tcl +++ modules/struct/queue.tcl @@ -5,11 +5,11 @@ # 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 2004/01/15 06:36:14 andreas_kupries Exp $ +# 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 @@ -16,20 +16,10 @@ variable queues # counter is used to give a unique name for unnamed queues variable counter 0 - # commands is the list of subcommands recognized by the queue - variable commands [list \ - "clear" \ - "destroy" \ - "get" \ - "peek" \ - "put" \ - "size" \ - ] - # Only export one command, the one used to instantiate a new queue namespace export queue } # ::struct::queue::queue -- @@ -41,28 +31,51 @@ # name name of the queue; if null, generate one. # # Results: # name name of the queue created -proc ::struct::queue::queue {{name ""}} { +proc ::struct::queue::queue {args} { variable queues variable counter - - if { [llength [info level 0]] == 1 } { - incr counter - set name "queue${counter}" - } - - if { ![string equal [info commands ::$name] ""] } { - error "command \"$name\" already exists, unable to create queue" + + 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 + interp alias {} $name {} ::struct::queue::QueueProc $name return $name } ########################## @@ -84,17 +97,24 @@ if { [llength [info level 0]] == 2 } { error "wrong # args: should be \"$name option ?arg arg ...?\"" } # Split the args into command and args components - if { [string equal [info commands ::struct::queue::_$cmd] ""] } { - variable commands - set optlist [join $commands ", "] - set optlist [linsert $optlist "end-1" "or"] - error "bad option \"$cmd\": must be $optlist" + 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" } - return [eval [linsert $args 0 ::struct::queue::_$cmd $name]] + + uplevel 1 [linsert $args 0 ::struct::queue::_$cmd $name] } # ::struct::queue::_clear -- # # Clear a queue. @@ -123,11 +143,11 @@ # None. proc ::struct::queue::_destroy {name} { variable queues unset queues($name) - interp alias {} ::$name {} + interp alias {} $name {} return } # ::struct::queue::_get -- # @@ -166,19 +186,19 @@ return $result } # ::struct::queue::_peek -- # -# Retrive the value of an item on the queue without removing it. +# 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 fufill the request, throws an error. +# to fulfill the request, throws an error. proc ::struct::queue::_peek {name {count 1}} { variable queues if { $count < 1 } { error "invalid item count $count" Index: modules/struct/queue.test ================================================================== --- modules/struct/queue.test +++ modules/struct/queue.test @@ -6,11 +6,11 @@ # 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 2004/01/15 06:36:14 andreas_kupries Exp $ +# 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::* } @@ -21,42 +21,42 @@ test queue-0.1 {queue errors} { queue myqueue catch {queue myqueue} msg myqueue destroy set msg -} "command \"myqueue\" already exists, unable to create queue" +} "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 ...?\"" +} "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" +} "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} +} {::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} +} {::queue1 ::queue1 0} test queue-2.1 {queue destroy} { queue myqueue myqueue destroy info commands ::myqueue @@ -90,11 +90,11 @@ test queue-4.1 {put operation} { queue myqueue catch {myqueue put} msg myqueue destroy set msg -} "wrong # args: should be \"myqueue put item ?item ...?\"" +} "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 Index: modules/struct/sets.tcl ================================================================== --- modules/struct/sets.tcl +++ modules/struct/sets.tcl @@ -1,17 +1,17 @@ #---------------------------------------------------------------------- # # sets.tcl -- # -# Definitions for processing of sets. +# 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 2004/02/09 09:32:14 andreas_kupries Exp $ +# RCS: @(#) $Id: sets.tcl,v 1.2.2.2 2004/08/05 05:43:08 andreas_kupries Exp $ # #---------------------------------------------------------------------- package require Tcl 8.0 @@ -24,11 +24,11 @@ ########################## # Public functions # ::struct::set::set -- # -# Command that access all list commands. +# Command that access all set commands. # # Arguments: # cmd Name of the subcommand to dispatch to. # args Arguments for the subcommand. # @@ -199,40 +199,48 @@ # A - B # # Side effects: # None. -if {[package vcompare [package provide Tcl] 8.4] < 0} { - # Tcl 8.[23]. Use explicit array to perform the operation. - - 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] - } - -} 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] +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 -- # Index: modules/struct/sets.test ================================================================== --- modules/struct/sets.test +++ modules/struct/sets.test @@ -4,11 +4,11 @@ # 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 2004/02/14 05:59:22 andreas_kupries Exp $ +# 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::* } @@ -225,10 +225,22 @@ } $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 Index: modules/struct/stack.man ================================================================== --- modules/struct/stack.man +++ modules/struct/stack.man @@ -32,24 +32,24 @@ Return the top [arg count] items of the stack, without removing them from the stack. If [arg count] is not specified, it defaults to 1. If [arg count] is 1, the result is a simple string; otherwise, it is a list. If specified, [arg count] must be greater than or equal to 1. -If there are no items on the stack, this command will return -[arg count] empty strings. +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 no items on the stack, this command will return -[arg count] empty strings. +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 Index: modules/struct/stack.tcl ================================================================== --- modules/struct/stack.tcl +++ modules/struct/stack.tcl @@ -5,11 +5,11 @@ # 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 2004/01/15 06:36:14 andreas_kupries Exp $ +# 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 @@ -16,21 +16,10 @@ variable stacks # counter is used to give a unique name for unnamed stacks variable counter 0 - # commands is the list of subcommands recognized by the stack - variable commands [list \ - "clear" \ - "destroy" \ - "peek" \ - "pop" \ - "push" \ - "rotate" \ - "size" \ - ] - # Only export one command, the one used to instantiate a new stack namespace export stack } # ::struct::stack::stack -- @@ -42,26 +31,50 @@ # name name of the stack; if null, generate one. # # Results: # name name of the stack created -proc ::struct::stack::stack {{name ""}} { +proc ::struct::stack::stack {args} { variable stacks variable counter - if { [llength [info level 0]] == 1 } { - incr counter - set name "stack${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" } - if { ![string equal [info commands ::$name] ""] } { - error "command \"$name\" already exists, unable to create stack" - } set stacks($name) [list ] # Create the command to manipulate the stack - interp alias {} ::$name {} ::struct::stack::StackProc $name + interp alias {} $name {} ::struct::stack::StackProc $name return $name } ########################## @@ -77,17 +90,30 @@ # # 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 - if { [lsearch -exact $::struct::stack::commands $cmd] == -1 } { - set optlist [join $::struct::stack::commands ", "] - set optlist [linsert $optlist "end-1" "or"] - error "bad option \"$cmd\": must be $optlist" + 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" } - eval [linsert $args 0 ::struct::stack::_$cmd $name] + + uplevel 1 [linsert $args 0 ::struct::stack::$sub $name] } # ::struct::stack::_clear -- # # Clear a stack. @@ -114,25 +140,25 @@ # Results: # None. proc ::struct::stack::_destroy {name} { unset ::struct::stack::stacks($name) - interp alias {} ::$name {} + interp alias {} $name {} return } # ::struct::stack::_peek -- # -# Retrive the value of an item on the stack without popping it. +# 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 fufill the request, throws an error. +# to fulfill the request, throws an error. proc ::struct::stack::_peek {name {count 1}} { variable stacks if { $count < 1 } { error "invalid item count $count" Index: modules/struct/stack.test ================================================================== --- modules/struct/stack.test +++ modules/struct/stack.test @@ -6,11 +6,11 @@ # 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 2004/01/15 06:36:14 andreas_kupries Exp $ +# 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::* } @@ -21,42 +21,42 @@ test stack-0.1 {stack errors} { stack mystack catch {stack mystack} msg mystack destroy set msg -} "command \"mystack\" already exists, unable to create stack" +} "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 ...?\"" +} "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" +} "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} +} {::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} +} {::stack1 ::stack1 0} test stack-2.1 {stack destroy} { stack mystack mystack destroy info commands ::mystack @@ -90,11 +90,11 @@ test stack-4.1 {push operation} { stack mystack catch {mystack push} msg mystack destroy set msg -} "wrong # args: should be \"mystack push item ?item ...?\"" +} "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 Index: modules/struct/tree.tcl ================================================================== --- modules/struct/tree.tcl +++ modules/struct/tree.tcl @@ -5,11 +5,11 @@ # 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 2004/02/09 09:32:14 andreas_kupries Exp $ +# 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 {} @@ -591,11 +591,11 @@ interp alias {} ::$name {} } # ::struct::tree::_exists -- # -# Test for existance of a given node in a tree. +# Test for existence of a given node in a tree. # # Arguments: # name Name of the tree to query. # node Node to look for. # @@ -669,11 +669,11 @@ # Arguments: # name Name of the tree. # node Node we wish to know the height for.. # # Results: -# height Distance to depest child of the node. +# 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\"" } @@ -723,11 +723,11 @@ return [array names data $pattern] } # ::struct::tree::_keyexists -- # -# Test for existance of a given key for a node in a tree. +# 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. @@ -823,11 +823,11 @@ # 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 grandpaw...) + # 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" } @@ -1505,11 +1505,11 @@ upvar ${name}::$attribute($node) data catch {unset data($key)} if {[array size data] == 0} { # No attributes stored for this node, squash the whole array. - set attribute($node) {} + unset attribute($node) unset data } return } @@ -1862,11 +1862,11 @@ return } # ::struct::tree::GenAttributeStorage -- # -# Create an array to store the attrributes of a node in. +# 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. # @@ -1911,16 +1911,16 @@ # Store attribute data if {[info exists attribute($node)]} { upvar ${name}::$attribute($node) data lappend tree [array get data] } else { - # Enoce nodes without attributes. + # Encode nodes without attributes. lappend tree {} } # Build tree structure, by adding the children to the list, all - # refering back to their parent by index. Their own children are + # 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 @@ -1982,11 +1982,11 @@ set p($node) [lindex $ser $parent] lappend ch($p($node)) $node } - # Rootnode information ok ? + # Root node information ok ? if {[llength $rn] < 1} { return -code error \ "error in serialization: no root specified." } elseif {[llength $rn] > 1} { Index: modules/struct/tree.test ================================================================== --- modules/struct/tree.test +++ modules/struct/tree.test @@ -5,11 +5,11 @@ # 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 2004/02/14 05:59:22 andreas_kupries Exp $ +# 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::* } @@ -432,10 +432,22 @@ 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 @@ -2142,10 +2154,19 @@ 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 @@ -2319,10 +2340,19 @@ 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 Index: modules/struct1/ChangeLog ================================================================== --- modules/struct1/ChangeLog +++ modules/struct1/ChangeLog @@ -1,5 +1,11 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * Index: modules/struct1/queue.tcl ================================================================== --- modules/struct1/queue.tcl +++ modules/struct1/queue.tcl @@ -5,11 +5,11 @@ # 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 2004/01/15 06:36:14 andreas_kupries Exp $ +# 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 @@ -16,20 +16,10 @@ variable queues # counter is used to give a unique name for unnamed queues variable counter 0 - # commands is the list of subcommands recognized by the queue - variable commands [list \ - "clear" \ - "destroy" \ - "get" \ - "peek" \ - "put" \ - "size" \ - ] - # Only export one command, the one used to instantiate a new queue namespace export queue } # ::struct::queue::queue -- @@ -41,28 +31,51 @@ # name name of the queue; if null, generate one. # # Results: # name name of the queue created -proc ::struct::queue::queue {{name ""}} { +proc ::struct::queue::queue {args} { variable queues variable counter - - if { [llength [info level 0]] == 1 } { - incr counter - set name "queue${counter}" - } - - if { ![string equal [info commands ::$name] ""] } { - error "command \"$name\" already exists, unable to create queue" + + 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 + interp alias {} $name {} ::struct::queue::QueueProc $name return $name } ########################## @@ -84,17 +97,24 @@ if { [llength [info level 0]] == 2 } { error "wrong # args: should be \"$name option ?arg arg ...?\"" } # Split the args into command and args components - if { [string equal [info commands ::struct::queue::_$cmd] ""] } { - variable commands - set optlist [join $commands ", "] - set optlist [linsert $optlist "end-1" "or"] - error "bad option \"$cmd\": must be $optlist" + 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" } - return [eval [linsert $args 0 ::struct::queue::_$cmd $name]] + + uplevel 1 [linsert $args 0 ::struct::queue::_$cmd $name] } # ::struct::queue::_clear -- # # Clear a queue. @@ -123,11 +143,11 @@ # None. proc ::struct::queue::_destroy {name} { variable queues unset queues($name) - interp alias {} ::$name {} + interp alias {} $name {} return } # ::struct::queue::_get -- # Index: modules/struct1/queue.test ================================================================== --- modules/struct1/queue.test +++ modules/struct1/queue.test @@ -6,11 +6,11 @@ # 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 2004/01/15 06:36:14 andreas_kupries Exp $ +# 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::* } @@ -21,42 +21,42 @@ test queue-0.1 {queue errors} { queue myqueue catch {queue myqueue} msg myqueue destroy set msg -} "command \"myqueue\" already exists, unable to create queue" +} "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 ...?\"" +} "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" +} "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} +} {::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} +} {::queue1 ::queue1 0} test queue-2.1 {queue destroy} { queue myqueue myqueue destroy info commands ::myqueue @@ -90,11 +90,11 @@ test queue-4.1 {put operation} { queue myqueue catch {myqueue put} msg myqueue destroy set msg -} "wrong # args: should be \"myqueue put item ?item ...?\"" +} "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 Index: modules/struct1/stack.tcl ================================================================== --- modules/struct1/stack.tcl +++ modules/struct1/stack.tcl @@ -5,11 +5,11 @@ # 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 2004/01/15 06:36:14 andreas_kupries Exp $ +# 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 @@ -16,21 +16,10 @@ variable stacks # counter is used to give a unique name for unnamed stacks variable counter 0 - # commands is the list of subcommands recognized by the stack - variable commands [list \ - "clear" \ - "destroy" \ - "peek" \ - "pop" \ - "push" \ - "rotate" \ - "size" \ - ] - # Only export one command, the one used to instantiate a new stack namespace export stack } # ::struct::stack::stack -- @@ -42,26 +31,50 @@ # name name of the stack; if null, generate one. # # Results: # name name of the stack created -proc ::struct::stack::stack {{name ""}} { +proc ::struct::stack::stack {args} { variable stacks variable counter - if { [llength [info level 0]] == 1 } { - incr counter - set name "stack${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" } - if { ![string equal [info commands ::$name] ""] } { - error "command \"$name\" already exists, unable to create stack" - } set stacks($name) [list ] # Create the command to manipulate the stack - interp alias {} ::$name {} ::struct::stack::StackProc $name + interp alias {} $name {} ::struct::stack::StackProc $name return $name } ########################## @@ -77,17 +90,30 @@ # # 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 - if { [lsearch -exact $::struct::stack::commands $cmd] == -1 } { - set optlist [join $::struct::stack::commands ", "] - set optlist [linsert $optlist "end-1" "or"] - error "bad option \"$cmd\": must be $optlist" + 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" } - eval [linsert $args 0 ::struct::stack::_$cmd $name] + + uplevel 1 [linsert $args 0 ::struct::stack::$sub $name] } # ::struct::stack::_clear -- # # Clear a stack. @@ -114,11 +140,11 @@ # Results: # None. proc ::struct::stack::_destroy {name} { unset ::struct::stack::stacks($name) - interp alias {} ::$name {} + interp alias {} $name {} return } # ::struct::stack::_peek -- # Index: modules/struct1/stack.test ================================================================== --- modules/struct1/stack.test +++ modules/struct1/stack.test @@ -6,11 +6,11 @@ # 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 2004/01/15 06:36:14 andreas_kupries Exp $ +# 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::* } @@ -21,42 +21,42 @@ test stack-0.1 {stack errors} { stack mystack catch {stack mystack} msg mystack destroy set msg -} "command \"mystack\" already exists, unable to create stack" +} "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 ...?\"" +} "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" +} "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} +} {::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} +} {::stack1 ::stack1 0} test stack-2.1 {stack destroy} { stack mystack mystack destroy info commands ::mystack @@ -90,11 +90,11 @@ test stack-4.1 {push operation} { stack mystack catch {mystack push} msg mystack destroy set msg -} "wrong # args: should be \"mystack push item ?item ...?\"" +} "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 Index: modules/textutil/ChangeLog ================================================================== --- modules/textutil/ChangeLog +++ modules/textutil/ChangeLog @@ -1,5 +1,47 @@ +2004-06-24 Andreas Kupries + + * trim.tcl: Fixed typo in 'trimEmptyHeading'. + +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-05-23 Andreas Kupries + + * 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 + + * 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 + + * 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 * * Released and tagged Tcllib 1.6 ======================== * Index: modules/textutil/adjust.tcl ================================================================== --- modules/textutil/adjust.tcl +++ modules/textutil/adjust.tcl @@ -57,10 +57,15 @@ 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_)]} { @@ -89,10 +94,14 @@ 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 ] } @@ -104,301 +113,275 @@ } return "" } +# ::textutil::adjust::Adjust # -# Dies ist die relevante Routine -# +# 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 - regsub -all -- "(\n)|(\t)" $orig " " text - regsub -all -- " +" $text " " text - regsub -all -- "(^ *)|( *\$)" $text "" text - - set ltext [ split $text ] - - if { $StrictLength } then { - - # Limit the length of a line to $Length. If any single - # word is long than $Length, then split the word into multiple - # words. - - set i 0 - foreach tmpWord $ltext { - if { [ string length $tmpWord ] > $Length } then { - - # Since the word is longer than the line length, - # remove the word from the list of words. Then - # we will insert several words that are less than - # or equal to the line length in place of this word. - - set ltext [ lreplace $ltext $i $i ] - incr i -1 - set j 0 - - # Insert a series of shorter words in place of the - # one word that was too long. - - while { $j < [ string length $tmpWord ] } { - - # Calculate the end of the string range for this word. - - if { [ expr { [string length $tmpWord ] - $j } ] > $Length } then { - set end [ expr { $j + $Length - 1} ] - } else { - set end [ string length $tmpWord ] - } - - set ltext [ linsert $ltext [ expr {$i + 1} ] [ string range $tmpWord $j $end ] ] - incr i - incr j [ expr { $end - $j + 1 } ] - } - } - incr i - } - } - - # End if { $StrictLength } ... - - set line [ lindex $ltext 0 ] - set pos [ string length $line ] - set text "" - set numline 0 - set numword 1 - set words(0) 1 - set words(1) [ list $pos $line ] - - foreach word [ lrange $ltext 1 end ] { - set size [ string length $word ] - if { ( $pos + $size ) < $Length } then { - # the word fits into the actual line ... - # - append line " $word" - incr numword - incr words(0) - set words($numword) [ list $size $word ] - incr pos - incr pos $size - } elseif { $Hyphenate } { - # the word does not fit into the line and we must try to hyphenate - - set word2 [Hyphenation $word]; - set word2 [string trim $word2]; - set word3 ""; - set word4 "" - - set i 0; - set iMax [llength $word2]; - - # build up the part of the word to be kept in the current line - - while { $i < $iMax } { - set syl [lindex $word2 $i] - if { $pos + [string length " $word3$syl-"] > $Length } { break } - append word3 $syl; - incr i; - } - - # build up the part of the hyphenated word to be transferred to - # the next line - - while { $i < $iMax } { - set syl [lindex $word2 $i]; - append word4 $syl; - incr i; - } - - # to be done in the future: code that guarantees that the - # parts of the hyphenated word have a minimum length .. - - if {[string length $word3] && [string length $word4]} { - # hyphenation was succesful: keep $word3 and the hyphen in the - # current line and begin next line with $word4 - # - # current line - - append line " $word3-" - incr numword - incr words(0) - set words($numword) [list [string length $word3] $word3]; - incr pos; - incr pos [string length $word3]; - - if [string length $text] { append text "\n" } - append text [ Justification $line [ incr numline ] words ] - - # next line - - set line "$word4" - set pos [string length $word4]; - catch { unset words } - set numword 1 - set words(0) 1 - set words(1) [ list $size $word ] - } else { - # hyphenation failed => close current line and begin - # the next line with the unhyphenated word ($word) - - if [string length $text] { append text "\n" } - append text [Justification $line [incr numline] words] - - set line "$word" - set pos $size - catch { unset words } - set numword 1 - set words(0) 1 - } - } else { - # no hyphenation - if [string length $text] { append text "\n" } - append text [Justification $line [ incr numline ] words ] - - set line "$word" - set pos $size - catch { unset words } - set numword 1 - set words(0) 1 - set words(1) [ list $size $word ] - } - } - if [string length $text] { append text "\n" } - append text [Justification $line end words] - + 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 } -# -# Ende der relevanten Routine -# - -proc ::textutil::adjust::Justification { line index arrayName } { - variable Justify - variable Length - variable FullLine - variable StrRepeat - - upvar $arrayName words - - set len [ string length $line ] - if { $Length == $len } then { - return $line - } - - # Special case: - # for the last line, and if the justification is set to 'plain' - # the real justification is 'left' if the length of the line - # is less than 90% (rounded) of the max length allowed. This is - # to avoid expansion of this line when it is too small: without - # it, the added spaces will 'unbeautify' the result. - # - - set justify $Justify - if { ( "$index" == "end" ) && \ - ( "$Justify" == "plain" ) && \ - ( $len < round($Length * 0.90) ) } then { - set justify left - } - - # For a left justification, nothing to do, but to - # add some spaces at the end of the line if requested - # - - if { "$justify" == "left" } then { - set jus "" - if { $FullLine } then { - set jus [ $StrRepeat " " [ expr { $Length - $len } ] ] - } - return "${line}${jus}" - } - - # For a right justification, just add enough spaces - # at the beginning of the line - # - - if { "$justify" == "right" } then { - set jus [ $StrRepeat " " [ expr { $Length - $len } ] ] - return "${jus}${line}" - } - - # For a center justification, add half of the needed spaces - # at the beginning of the line, and the rest at the end - # only if needed. - - if { "$justify" == "center" } then { - set mr [ expr { ( $Length - $len ) / 2 } ] - set ml [ expr { $Length - $len - $mr } ] - set jusl [ $StrRepeat " " $ml ] - set jusr [ $StrRepeat " " $mr ] - if { $FullLine } then { - return "${jusl}${line}${jusr}" - } else { - return "${jusl}${line}" - } - } - - # For a plain justiciation, it's a little bit complex: - # if some spaces are missing, then - # sort the list of words in the current line by - # decreasing size - # foreach word, add one space before it, except if - # it's the first word, until enough spaces are added - # then rebuild the line - # - # Idea kept but procedure modified by jhv - - if { "$justify" == "plain" } then { - set miss [ expr { $Length - [ string length $line ] } ] - if { $miss == 0 } then { - return "${line}" - } - - # Bugfix tcllib-bugs-860753 (jhv) - - set worte [split $line]; - set imax [llength $worte]; - - for {set i 0; set totalLen 0} {$i < $imax} {incr i} { - set elem($i) [lindex $worte $i]; - if {$i > 0} {set elem($i) " $elem($i)"}; - set elemLen($i) [string length $elem($i)]; - set totalLen [expr $totalLen+$elemLen($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 < $imax) && ($miss > 0)} {incr i} { - if {$elemLen($i) == $len} { - set elem($i) " $elem($i)"; - incr elemLen($i); - incr miss -1; - } - } - } - - set line ""; - for {set i 0} {$i < $imax} {incr i} { - set line "$line$elem($i)"; - } - - # End of bugfix - - return "${line}" - } - - error "Illegal justification key \"$justify\"" +# ::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 { @@ -430,10 +413,15 @@ 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) Index: modules/textutil/adjust.test ================================================================== --- modules/textutil/adjust.test +++ modules/textutil/adjust.test @@ -66,26 +66,26 @@ "hello, world" test adjust-0.5 {adjust string on left with full line} { ::textutil::adjust $string -full yes } \ -"hello, world " +"hello, world " test adjust-0.6 {adjust string on right with full line} { ::textutil::adjust $string -justify right -full yes } \ -" hello, world" +" hello, world " test adjust-0.7 {adjust string on center with full line} { ::textutil::adjust $string -justify center -full 1 } \ -" hello, world " +" hello, world " test adjust-0.8 {adjust string with plain justification and full line} { ::textutil::adjust $string -justify plain -full YES } \ -"hello, world " +"hello, world " ############################## test adjust-1.1 {adjust multi lines on left} { ::textutil::adjust $text -full no @@ -106,24 +106,24 @@ 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. " +"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. " +"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 @@ -153,24 +153,26 @@ 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. " +" 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. " +"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 @@ -177,43 +179,41 @@ 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} {knownBug} { - ::textutil::adjust $text2 -justify plain -length 31 -strictlength 1 -} \ -"Hello, world! This is the end, -my friend. You're just another -brick in the wall. Michele, ma -belle, sont des mots qui vont -trés bien ensembles, trés bien - ensembles. -ThisIsSimilarToTextOnlyThisStri - ngHasOneReallyLongWordInIt -Smoke on the water, and fire in -the sky. Oh Lord, don't let me -be misunderstood. Cause tramp -like us, baby we were born to -run." - -test adjust-2.7 {adjust multi lines with plain justification and strictlength} {knownBug} { - ::textutil::adjust $text2 -justify plain -length 31 -strictlength 1 -} \ -"Hello, world! This is the end, -my friend. You're just another -brick in the wall. Michele, ma -belle, sont des mots qui vont -trés bien ensembles, trés bien - ensembles. -ThisIsSimilarToTextOnlyThisStri - ngHasOneReallyLongWordInIt -Smoke on the water, and fire in -the sky. Oh Lord, don't let me -be misunderstood. Cause tramp -like us, baby we were born to -run." +test adjust-2.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, @@ -220,17 +220,16 @@ my friend. You're just another brick in the wall. Michele, ma belle, sont des mots qui vont trés bien ensembles, trés bien ensembles. -ThisIsSimilarToTextOnlyThisStri -ngHasOneReallyLongWordInIt -Smoke on the water, and fire in -the sky. Oh Lord, don't let me -be misunderstood. Cause tramp -like us, baby we were born to -run." +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 Index: modules/textutil/adjust_hyph.test ================================================================== --- modules/textutil/adjust_hyph.test +++ modules/textutil/adjust_hyph.test @@ -98,7 +98,25 @@ 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 Index: modules/textutil/pkgIndex.tcl ================================================================== --- modules/textutil/pkgIndex.tcl +++ modules/textutil/pkgIndex.tcl @@ -10,7 +10,7 @@ if {![package vsatisfies [package provide Tcl] 8.2]} { # FRINK: nocheck return } -package ifneeded textutil 0.6 [list source [file join $dir textutil.tcl]] +package ifneeded textutil 0.6.1 [list source [file join $dir textutil.tcl]] package ifneeded textutil::expander 1.2.1 [list source [file join $dir expander.tcl]] Index: modules/textutil/textutil.man ================================================================== --- modules/textutil/textutil.man +++ modules/textutil/textutil.man @@ -1,10 +1,10 @@ -[manpage_begin textutil n 0.6] +[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]] +[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). Index: modules/textutil/textutil.tcl ================================================================== --- modules/textutil/textutil.tcl +++ modules/textutil/textutil.tcl @@ -169,7 +169,6 @@ 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 - +package provide textutil 0.6.1 Index: modules/textutil/trim.tcl ================================================================== --- modules/textutil/trim.tcl +++ modules/textutil/trim.tcl @@ -5,11 +5,11 @@ variable StrU "\[ \t\]+" variable StrR "(${StrU})\$" variable StrL "^(${StrU})" namespace export trim trimright trimleft \ - trimPrefix trimEmpyHeading + 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]+" } } { } @@ -18,12 +18,12 @@ proc trimPrefix {text prefix} {} proc trimEmptyHeading {text} {} } - namespace import -force trim::trim trim::trimleft trim::trimright trim::trimPrefix trim::trimEmpyHeading - namespace export trim trimleft trimright trimPrefix trimEmpyHeading + 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 Index: modules/uri/ChangeLog ================================================================== --- modules/uri/ChangeLog +++ modules/uri/ChangeLog @@ -1,5 +1,25 @@ +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-05-23 Andreas Kupries + + * 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 + + * 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 * * Released and tagged Tcllib 1.6 ======================== * Index: modules/uri/pkgIndex.tcl ================================================================== --- modules/uri/pkgIndex.tcl +++ modules/uri/pkgIndex.tcl @@ -1,6 +1,6 @@ if {![package vsatisfies [package provide Tcl] 8.2]} { # FRINK: nocheck return } -package ifneeded uri 1.1.3 [list source [file join $dir uri.tcl]] +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]] Index: modules/uri/uri.man ================================================================== --- modules/uri/uri.man +++ modules/uri/uri.man @@ -1,10 +1,10 @@ -[manpage_begin uri n 1.1.3] +[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.3]] +[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 Index: modules/uri/uri.tcl ================================================================== --- modules/uri/uri.tcl +++ modules/uri/uri.tcl @@ -7,11 +7,11 @@ # Derived from urls.tcl by Andreas Kupries # # TODO: # Handle www-url-encoding details # -# CVS: $Id: uri.tcl,v 1.25 2004/01/25 07:29:51 andreas_kupries Exp $ +# 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 { @@ -133,11 +133,11 @@ "Variable \"schemepart\" is missing." } # Now we can extend the variables which keep track of the registered schemes. - eval lappend schemes $schemeList + eval [linsert $schemeList 0 lappend schemes] set schemePattern "([::join $schemes |]):" foreach s schemeList { # FRINK: nocheck set url2part($s) "${s}:[set ${scheme}::schemepart]" @@ -314,24 +314,24 @@ } if {[string match "//*" $url]} { set url [string range $url 2 end] - array set parts [GetHostPort url] + array set parts [GetUPHP url] } set parts(path) [string trimleft $url /] return [array get parts] } proc ::uri::JoinHttp {args} { - eval uri::JoinHttpInner http 80 $args + eval [linsert $args 0 uri::JoinHttpInner http 80] } proc ::uri::JoinHttps {args} { - eval uri::JoinHttpInner https 443 $args + eval [linsert $args 0 uri::JoinHttpInner https 443] } proc ::uri::JoinHttpInner {scheme defport args} { array set components [list \ host {} port $defport path {} query {} \ @@ -585,11 +585,11 @@ set baseparts(path) "[::join $path /]/$relparts(path)" } } catch { set baseparts(query) $relparts(query) } catch { set baseparts(fragment) $relparts(fragment) } - return [eval join [array get baseparts]] + return [eval [linsert [array get baseparts] 0 join]] } default { return -code error "unable to resolve relative URL \"$url\"" } } @@ -633,20 +633,20 @@ proc ::uri::geturl {url args} { array set urlparts [split $url] switch -- $urlparts(scheme) { file { - return [eval file_geturl [list $url] $args] + 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 [list $urlparts(scheme)::geturl $url] $args] + return [eval [linsert $args 0 $urlparts(scheme)::geturl $url]] } } } # ::uri::file_geturl -- @@ -694,11 +694,11 @@ # A URL proc ::uri::join args { array set components $args - return [eval [list Join[string totitle $components(scheme)]] $args] + return [eval [linsert $args 0 Join[string totitle $components(scheme)]]] } # ::uri::canonicalize -- # # Canonicalize a URL @@ -752,11 +752,11 @@ # Munge trailing /.. while {[regsub -all -- {/[^/]+/\.\.} $uri {/} uri]} {} if { $uri == ".." } { set uri "/" } set u(path) $uri - set uri [eval uri::join [array get u]] + set uri [eval [linsert [array get u] 0 uri::join]] return $uri } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -927,6 +927,6 @@ variable schemepart "//${hostOrPort}/${path}(${fieldspec})*" variable url "prospero:$schemepart" } -package provide uri 1.1.3 +package provide uri 1.1.4 Index: modules/uri/uri.test ================================================================== --- modules/uri/uri.test +++ modules/uri/uri.test @@ -4,11 +4,11 @@ # 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 2004/01/15 06:36:14 andreas_kupries Exp $ +# 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::* } @@ -32,23 +32,23 @@ # ------------------------------------------------------------------------- # Split tests test uri-1.1 {uri::split - http w/- query} { eval kvsort [uri::split http://test.net/path/path2?query] -} {host test.net path path/path2 port {} query query scheme http} +} {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 {} query query scheme https} +} {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 query {} scheme http} +} {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 query {} scheme https} +} {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 {}} @@ -419,10 +419,16 @@ 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:bar@baz.com:80/bla/] +} {host baz.com path bla/ port 80 pwd bar query {} scheme http user foo} # ------------------------------------------------------------------------- ::tcltest::cleanupTests Index: sak.tcl ================================================================== --- sak.tcl +++ sak.tcl @@ -469,11 +469,11 @@ 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 2004/02/14 05:59:20 andreas_kupries Exp $ + 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 @@ -1163,22 +1163,37 @@ # 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 != {}} { - set critcl [concat $critcl [auto_execok critcl.kit]] + 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} { - #foreach p [array names critclmodules] { - # critcl_module $p - #} + 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 Index: tcllib_version.tcl ================================================================== --- tcllib_version.tcl +++ tcllib_version.tcl @@ -1,2 +1,2 @@ -set tcllib_version 1.6 +set tcllib_version 1.6.1 set tcllib_name tcllib