Tcl Library Source Code

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-05-23  Andreas Kupries  <[email protected]>

	* Bumped version in branch to 1.6.1 in preparation of upcoming
	  bugfix release.

2004-04-16  Pat Thoyts  <[email protected]>

	* sak.tcl: Some mods to the critcl build code for use under
	Windows. If it cannot find critcl.kit, then use env(CRITCL) for
	the location of the kit file.

2004-03-09  Andreas Kupries  <[email protected]>

	* examples/csv/csv2html.orig:		Unified the startup header of all
	* examples/csv/csvcut.orig:		applications, using suggestions
	* examples/csv/csvdiff.orig:		made by Stuart Cassoff <[email protected]>.
	* examples/csv/csvjoin.orig:
	* examples/csv/csvsort.orig:
	* examples/csv/csvuniq.orig:
	* examples/ftp/ftpdemo.tcl.orig:
	* examples/ftp/ftpvalid.orig:
	* examples/ftp/hpupdate.tcl.orig:
	* examples/ftp/mirror.tcl.orig:
	* examples/ftp/newer.tcl.orig:
	* examples/ftpd/ftpd.orig:
	* examples/ftpd/ftpd.test.orig:
	* examples/ftpd/ftpd.unix.orig:
	* examples/irc/irc_example.tcl.orig:
	* examples/mime/mbot/README.html.orig:
	* examples/mime/mbot/README.txt.orig:
	* examples/mime/mbot/README.xml.orig:
	* examples/mime/mbot/impersonal.tcl.orig:
	* examples/mime/mbot/personal.tcl.orig:
	* examples/nntp/postnews.orig:
	* examples/oreilly-oscon2001/oscon.orig:
	* examples/smtpd/tcl_smtpd.orig:
	* examples/smtpd/tk_smtpd.orig:
	* examples/smtpd/tk_smtpdMIME.orig:
	* modules/des/des.tcl.orig:
	* modules/devtools/musub.tcl.orig:
	* modules/doctools/mpexpand.orig:
	* modules/doctools/mpexpand.all.orig:
	* modules/doctools/tocexpand.orig:
	* modules/fileutil/fileutil.test.orig:
	* modules/mime/performance.tcl.orig:
	* modules/pop3/clnt.tcl.orig:
	* modules/pop3/srv.tcl.orig:

2004-03-01  Andreas Kupries  <[email protected]>

	* installer.tcl: Requiring Tcl 8.2 when executing the installer,
	  as anything below that version does not make any sense. This
	  fixes [Tcllib SF Bug 899152].

	* installer.tcl: Fixed [Tcllib SF Bug 899209] by deleting an
	  existing file before trying to overwrite it.

2004-02-18  Andreas Kupries  <[email protected]>

	* tcllib_version.tcl: Moving mainline to 1.6.0.1 to distinguish
	  development from the released version.

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2004-02-14  Andreas Kupries  <[email protected]>

@@ 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
pop3d::dbox         1.0.1
pop3d::udb          1.1
profiler            0.2.2
report              0.3.1
resolv              1.0.3
sha1                1.0.3
smtp                1.3.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

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

#!/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
package require struct

#!/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

# ----------------------------------------------------
# csvcut ?-sep sepchar? LIST file...

#!/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

# ----------------------------------------------------

#!/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

# ----------------------------------------------------
# csvuniq ?-sep sepchar? keycol1 file1.in keycol2 file2.in file.out|-

#!/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

# ----------------------------------------------------
# csvsort ?-sep sepchar? ?-f? ?-n? ?-r? ?-skip cnt? column file.in|- file.out|-

#!/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

# ----------------------------------------------------
# csvuniq ?-sep sepchar? column file.in|- file.out|-

#!/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 
#   Changed:	07/00 
#   Version:    1.1
#
#   Copyright (C) 1997,1998 Steffen Traeger
#	EMAIL:	[email protected]
#	URL:	http://home.t-online.de/home/Steffen.Traeger
#
#   This program is free software; you can redistribute it and/or 
#   modify it. 
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#
########################################################################

package require Tcl 8
package require Tcl 8.3
package require Tk
package require ftp 2.0

# set palette under X
if { [string range [winfo server .] 0 0] == "X" } {
	option add *background			LightGray
	tk_setPalette LightGray

#!/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
package require ftp

#!/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 
#   Changed:    7/2000
#   Version:    2.0

#   You should have received a copy of the GNU General Public License
#   along with this program; if not, write to the Free Software
#   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
########################################################################

# load required FTP package library 
package require Tcl 8.3
package require ftp 2.0
package require Tk
if {![llength [info commands tkButtonInvoke]]} {
    ::tk::unsupported::ExposePrivateCommand tkButtonInvoke
}

# LED Colors

#!/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
set passwd xxxxxx 

#!/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
	}
	ftp::Close $conn

#!/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]
}

proc bgerror {args} {
    global errorInfo

#!/bin/sh 
#! /bin/sh
# FTP daemon for testing the ftp client (modules/ftp).
# -*- 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
    puts stderr "bgerror: [join $args]"
    puts stderr $errorInfo

#!/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]
}

proc bgerror {args} {
    global errorInfo

#!/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 <[email protected]>
# $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"
set auto_path "[file join [file dirname [info script]] .. .. modules log] $auto_path"
package require irc 0.4

#!/bin/sh
# the next line restarts using tclsh \
#! /bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}
PATH=/usr/pkg/bin:/usr/local/bin:/usr/bin:/bin LD_LIBRARY_PATH=/usr/pkg/lib:/usr/local/lib:/usr/lib export PATH LD_LIBRARY_PATH; exec tclsh8.3 "$0" "$@"

# impersonal.tcl - export impersonal mail via the web
#
# (c) 1999 Marshall T. Rose
# Hold harmless the author, and any lawful use is allowed.
#


package require Tcl 8.3
global options


# begin of routines that may be redefined in configFile

proc tclLog {message} {
    global options

#!/bin/sh
# the next line restarts using tclsh \
#! /bin/sh
# -*- tcl -*- \
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" "$@"

exec tclsh "$0" ${1+"$@"}

# personal.tcl - process personal mail
#
# (c) 1999 Marshall T. Rose
# Hold harmless the author, and any lawful use is allowed.
#
# The original version was written in 1994!
#

package require Tcl 8.3

global options


# begin of routines that may be redefined in configFile

proc impersonalMail {originator} {}

#!/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
#    into the NNTP network
# 2) The name of the newsserver to push the articles to.

#!/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
package require htmlparse
package require textutil

#! /bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}
#

# tcl_smtpd - Copyright (C) 2001 Pat Thoyts <[email protected]>
#
# Simple test of the mail server. All incoming messages are displayed to
# stdout.
#
# Usage tk_smtpd 0.0.0.0 8025
#    or tk_smtpd 127.0.0.1 2525
#    or tk_smtpd
# to listen to the default port 25 on all tcp/ip interfaces.
#
# -------------------------------------------------------------------------
# This software is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE.  See the file 'license.terms' for
# more details.
# -------------------------------------------------------------------------
# \
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]}]} {
        error "invalid sender address \"$sender\""
    }

#! /bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}
#

# tk_smtpd - Copyright (C) 2001 Pat Thoyts <[email protected]>
#
# Simple test of the mail server. All incoming messages are displayed in a 
# message dialog.
#
# This example works nicely under Windows or within tkcon.
#
# Usage tk_smtpd 0.0.0.0 8025
#    or tk_smtpd 127.0.0.1 2525
#    or tk_smtpd
# to listen to the default port 25 on all tcp/ip interfaces.
#
# -------------------------------------------------------------------------
# This software is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE.  See the file 'license.terms' for
# more details.
# -------------------------------------------------------------------------
# \
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]}]} {
        error "invalid sender address \"$sender\""
    }

#! /bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}
#

# tk_smtpdMIME -Copyright (C) 2002 Pat Thoyts <[email protected]>
#
# Simple test of the mail server. All incoming messages are displayed in a 
# message dialog.
#
# This uses the new MIME token passing interface to the smtpd module.
#
# This example works nicely under Windows or within tkcon.
#
# Usage tk_smtpd 0.0.0.0 8025
#    or tk_smtpd 127.0.0.1 2525
#    or tk_smtpd
# to listen to the default port 25 on all tcp/ip interfaces.
#
# -------------------------------------------------------------------------
# This software is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE.  See the file 'license.terms' for
# more details.
# -------------------------------------------------------------------------
# \
exec wish "$0" ${1+"$@"}

package require smtpd
package require mime
package require Tk
package require Tcl 8.3
package require Tk
package require smtpd
package require mime
wm withdraw .
set _dlgid 0

# Handle new mail by raising a message dialog for each recipient.
proc deliverMIME {token} {

    set senders [mime::getheader $token From]

	    [file join $libdir $module]
    return
}

proc _man {module format ext docdir} {
    global distribution argv argc argv0 config

    # [SF Tcllib Bug 784519]
    # Directly access the bundled doctools package to ensure that
    # we have the truly latest code for that, and not the doctools
    # the executing tclsh would find on its own. The present query is
    # used to ensure that we load the package only once.

    package require doctools
    #package require doctools
    if {[catch {package present doctools}]} {
	uplevel #0 [list source [file join $distribution modules doctools doctools.tcl]]
    }
    ::doctools::new dt -format $format -module $module

    foreach f [glob -nocomplain [file join $distribution modules $module *.man]] {

	set out [file join $docdir [file rootname [file tail $f]]].$ext

	log "Generating $out"

#!/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]


# --------------------------------------------------------------
# Version information for tcllib.

    }
}

proc get_input {f} {return [read [set if [open $f r]]][close $if]}
proc write_out {f text} {
    global config
    if {$config(dry)} {log "Generate $f" ; return}
    catch {file delete -force $f}
    puts -nonewline [set of [open $f w]] $text
    close $of
}


# --------------------------------------------------------------
# Use configuration to perform installation

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-05-23  Andreas Kupries  <[email protected]>

	* uuencode.tcl: Rel. engineering. Updated version number 
	* uuencode.man: of uuencode to reflect its changes, to 1.1.1.
	* pkgIndex.tcl:

2004-03-09  Jeff Hobbs  <[email protected]>

	* uuencode.tcl (::uuencode::pad): don't use log package

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2003-10-24  Andreas Kupries  <[email protected]>

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded base64   2.3 [list source [file join $dir base64.tcl]]
package ifneeded uuencode 1.1 [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]]

[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
ASCII characters.

# uuencode - Copyright (C) 2002 Pat Thoyts <[email protected]>
#
# Provide a Tcl only implementation of uuencode and uudecode.
#
# -------------------------------------------------------------------------
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------
# @(#)$Id: uuencode.tcl,v 1.13 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} {
    return [format %c [expr {($c != 0) ? (($c & 0x3f) + 0x20) : 0x60}]]
}

#  Permit more tolerant decoding of invalid input strings by padding to
#  a multiple of 4 bytes with nulls.
# Result:
#  Returns the input string - possibly padded with uuencoded null chars.
#
proc ::uuencode::pad {s} {
    if {[set mod [expr {[string length $s] % 4}]] != 0} {
        log::log notice "invalid uuencoded string: padding string to a\
              multiple of 4."
        append s [string repeat "`" [expr {4 - $mod}]]
    }
    return $s
}

# -------------------------------------------------------------------------

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2003-05-05  Andreas Kupries  <[email protected]>

#----------------------------------------------------------------------
#
# 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 }

# Direct loading of provide script -- support testing even

#
# TEST CASES
#
#----------------------------------------------------------------------

# Unix epoch

array set gregChange {
    ERA CE
    YEAR 1752
    MONTH 9
    DAY_OF_MONTH 14
}
set gregChangeJ [calendar::GregorianCalendar::EYMDToJulianDay gregChange]
puts "Gregorian calendar was adopted in England on Julian Day $gregChangeJ"

array set gregUnixEpoch {
	ERA CE 
	YEAR 1970 
	MONTH 1 
	DAY_OF_MONTH 1
}
set unixEpoch [calendar::GregorianCalendar::EYMDToJulianDay gregUnixEpoch]
puts "Posix epoch is Julian day $unixEpoch"

# Procedure that tests EYMDToJulianDay, EYDToJulianDay, JulianDayToEYD,
# and JulianDayToEYMD

proc testCal { month day year } {

    global unixEpoch

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2004-02-09  Andreas Kupries  <[email protected]>

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2003-10-23  Andreas Kupries  <[email protected]>

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2003-05-05  Andreas Kupries  <[email protected]>

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2003-11-20  Andreas Kupries  <[email protected]>

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-05-23  Andreas Kupries  <[email protected]>

	* crc32.tcl: Rel. engineering. Updated version number 
	* crc32.man: of crc32 to reflect its changes, to 1.1.1.
	* pkgIndex.tcl:

2004-04-01  Pat Thoyts  <[email protected]>

	* crc32.tcl: Cope with data begining with hyphen when using
	  Trf (SF bug #914278)

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2003-05-27  Pat Thoyts  <[email protected]>

[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
http://www.naaccr.org/standard/crc32/document.html

# crc32.tcl -- Copyright (C) 2002 Pat Thoyts <[email protected]>
#
# CRC32 Cyclic Redundancy Check. 
# (for algorithm see http://www.rad.com/networks/1994/err_con/crc.htm)
#
# From http://mini.net/tcl/2259.tcl
# Written by Wayland Augur and Pat Thoyts.
#
# -------------------------------------------------------------------------
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------
# $Id: crc32.tcl,v 1.13 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 \
                           0x0EDB8832 0x79DCB8A4 0xE0D5E91E 0x97D2D988 \
                           0x09B64C2B 0x7EB17CBD 0xE7B82D07 0x90BF1D91 \

    #  and return the correct value according to our byte order.
    #
    proc ::crc::Crc32_trf {s {seed 0xFFFFFFFF}} {
        if {$seed != 0xFFFFFFFF} {
            return -code error "invalid option: the Trf crc32 command cannot\
                                 accept a seed value"
        }
        binary scan [crc-zlib $s] i r
        binary scan [crc-zlib -- $s] i r
        return $r
    }

    interp alias {} ::crc::Crc32 {} ::crc::Crc32_trf
} else {
    interp alias {} ::crc::Crc32 {} ::crc::Crc32_tcl
}

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]]

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-05-23  Andreas Kupries  <[email protected]>

	* csv.tcl: Rel. engineering. Updated version number 
	* csv.man: of csv to reflect its changes, to 0.5.1.
	* pkgIndex.tcl:

2004-05-03  Andreas Kupries  <[email protected]>

	* csv.tcl (read2matrix): Fixed bogus switch case. Had case "4"
	  twice, second should have been "5". [SF Tcllib Bug 940651].

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2003-11-22  Andreas Kupries  <[email protected]>

[comment {-*- tcl -*-}]
[manpage_begin csv n 0.5]
[manpage_begin csv n 0.5.1]
[copyright {2002 Andreas Kupries <[email protected]>}]
[moddesc   {CSV processing}]
[titledesc {Procedures to handle CSV data.}]
[require Tcl 8.3]
[require csv [opt 0.5]]
[require csv [opt 0.5.1]]
[description]

[para]

The [package csv] package provides commands to manipulate information
in CSV [sectref FORMAT] (CSV = Comma Separated Values).

# csv.tcl --
#
#	Tcl implementations of CSV reader and writer
#
# Copyright (c) 2001 by Jeffrey Hobbs
# Copyright (c) 2001 by Andreas Kupries <[email protected]>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: csv.tcl,v 1.16 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
}

# ::csv::join --

	    } else {
		set chan    $a
		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

	    set chan    $b

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.3]} {return}
package ifneeded csv 0.5 [list source [file join $dir csv.tcl]]
package ifneeded csv 0.5.1 [list source [file join $dir csv.tcl]]

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2003-05-07  Pat Thoyts  <[email protected]>

#- *- tcl -*-
# -*- tcl -*-
# MicroServer (also MicroServant)
# aka muserv (mu = greek micron)
#
# Copyright (c) 2003 by Andreas Kupries <[email protected]>

# ####################################################################

#!/bin/sh
#! /bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}

# Generic framework for a microserv.tcl based server/
#
# Copyright (c) 2003 by Andreas Kupries <[email protected]>

2004-05-26  Pat Thoyts  <[email protected]>

	* dns.tcl: Fix issue setting the log level properly.

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2004-01-22  Pat Thoyts  <[email protected]>

#    send multiple queries along the same connection.
#
# -------------------------------------------------------------------------
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------
#
# $Id: dns.tcl,v 1.19 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
    if {![info exists options]} {
        array set options {
            port       53
            timeout    30000
            protocol   tcp
            search     {}
            nameserver {localhost}
            loglevel   warn
        }
        variable log [logger::init dns]
        ${log}::enable $options(loglevel)
        ${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
    }

                }
            }
            -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]] ", -"]
                return -code error "bad option [lindex $args 0]:\
                        must be one of -$opts"

2004-05-30  Andreas Kupries  <[email protected]>

	* mpexpand.man: Updated reference 'dtformat' to 'doctools_fmt'.

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-05-23  Andreas Kupries  <[email protected]>

	* doctools.tcl: Rel. engineering. Updated version number 
	* doctools.man: of doctools to reflect its changes, to 1.0.2.
	* pkgIndex.tcl:

2004-05-14  Andreas Kupries  <[email protected]>

	* mpformats/_text.tcl (SECT): Fixed a small problem in the text
	  generator which was present for ages. Titles of more than one
	  word would have braces around them. Not fatal but also not so
	  nice looking. It was an argument versus argument list
	  thing. Adding a lindex in the proper place gets rid of the
	  additional level of quoting.

2004-05-04  Andreas Kupries  <[email protected]>

	* mpformats/_nroff.tcl: Fixed [SF Tcllib Bug 943146]. Added markup
	* mpformats/fmt.nroff: protection code like already in use for
	                       HTML and XML to handle nroff's special
	                       characters, i.e. the backslash properly.
	                       Also fixed handling of leading dashes in
	                       'opt_def'.

2004-04-22  Joe English  <[email protected]>

	* mpformats/fmt.xml: BUGFIX: "puts stderr" ==> "puts_stderr".
	
2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2004-02-09  Andreas Kupries  <[email protected]>

[comment {-*- tcl -*- doctools manpage}]
[manpage_begin doctools n 1.0.1]
[manpage_begin doctools n 1.0.2]
[copyright {2003 Andreas Kupries <[email protected]>}]
[moddesc   {Documentation tools}]
[titledesc {Create and manipulate doctools converter object}]
[require Tcl 8.2]
[require doctools [opt 1.0.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
available and provides the interface specified in
[cmd dtformatter(n)].

# doctools.tcl --
#
#	Implementation of doctools objects for Tcl.
#
# Copyright (c) 2003 Andreas Kupries <[email protected]>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: doctools.tcl,v 1.7 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 {
    # Data storage in the doctools module
    # -------------------------------

    # => FOO/mpformats

    #catch {search [file join $here                lib doctools mpformats]}
    #catch {search [file join [file dirname $here] lib doctools mpformats]}
    catch {search [file join $here                             mpformats]}
}

package provide doctools 1.0.1
package provide doctools 1.0.2

#!/bin/sh
#! /bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}

lappend auto_path [file dirname [file dirname [info script]]]
package require doctools

# ---------------------------------------------------------------------

#!/bin/sh
#! /bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}

set here    [file dirname [file join [pwd] [info script]]]
set verbose 0

set o [lindex $argv 0]

[comment {-*- tcl -*- doctools manpage}]
[manpage_begin mpexpand n 1.0]
[copyright {2002 Andreas Kupries <[email protected]>}]
[copyright {2003 Andreas Kupries <[email protected]>}]
[moddesc   {Documentation toolbox}]
[titledesc {Markup processor}]
[description]
[para]

This manpage describes a processor / converter for manpages in the
doctools format as specified in [cmd 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]|-]

The processor takes three arguments, namely the code describing which
formatting to generate as the output, the file to read the markup

# All dot-commands (f.e. .PP) are returned with a leading \n,
# enforcing that they are on a new line. Any empty line created
# because of this is filtered out in the post-processing step.


proc nr_lp      {}          {return \n.LP}
proc nr_ta      {{text {}}} {return ".ta$text"}
proc nr_bld     {}          {return \\fB}
proc nr_ul      {}          {return \\fI}
proc nr_rst     {}          {return \\fR}
proc nr_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"}
proc nr_in      {}          {return \n.RS}
proc nr_out     {}          {return \n.RE}
proc nr_nofill  {}          {return \n.nf}
proc nr_fill    {}          {return .fi}
proc nr_title   {text}      {return "\n.TH $text"}
proc nr_include {file}      {return "\n.so $file"}
proc nr_bolds   {}          {return \n.BS}
proc nr_bolde   {}          {return \n.BE}

proc nr_section {name}      {return "\n.SH \"$name\""}


################################################################

# Handling of nroff special characters in content:
#
# Plain text is initially passed through unescaped;
# internally-generated markup is protected by preceding it with \1.
# The final PostProcess step strips the escape character from
# real markup and replaces unadorned special characters in content
# with proper escapes.
#

global   markupMap
set      markupMap [list "\\" "\1\\"]
global   finalMap
set      finalMap [list \
	"\1\\" "\\" \
	"\\"   "\\\\"]
global   textMap
set      textMap [list "\\" "\\\\"]


proc nroffEscape {text} {
    global textMap
    return [string map $textMap $text]
}

# markup text --
#	Protect markup characters in $text.
#	These will be stripped out in PostProcess.
#
proc nroffMarkup {text} {
    global markupMap
    return [string map $markupMap $text]
}

proc nroff_postprocess {nroff} {
    global finalMap

    # Postprocessing final nroff text.
    # - Strip empty lines out of the text
    # - Remove leading and trailing whitespace from lines.
    # - Exceptions to the above: Keep empty lines and leading
    #   whitespace when in verbatim sections (no-fill-mode)

    set nfMode   [list .nf .CS]	; # commands which start no-fill mode

		set verbatim 0
	    }
	    set line [string trimright $line]
	}
	lappend lines $line
    }
    # Return the modified result buffer
    return [join $lines "\n"]
    return [string map $finalMap [join $lines "\n"]]
}

    return [join $linebuffer \n]
}


proc SECT {text} {
    upvar linebuffer linebuffer

    # text is actually the list of arguments, having one element, the text.
    set text [lindex $text 0]
    #puts_stderr "SECT $text"
    #puts_stderr ""

    # Write section title, underline it

    lappend linebuffer ""
    lappend linebuffer $text

# -*- 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 <[email protected]>.
# Freely redistributable.
#
######################################################################

	lappend endTags [endTag $current]
	set elementStack [lreplace $elementStack end end]
    }
    # Not found:
    set elementStack $origStack
    if {![string length $default]} {
    	set where "[join $elementStack /] - [info level 1]"
	puts stderr "Warning: Cannot start context $gis ($where)"
	puts_stderr "Warning: Cannot start context $gis ($where)"
    	set default [lindex $gis 0] 
    }
    lappend elementStack $default
    return [startTag $default]
}

# end ? gi ? --

	c_hold hdr $text
    }

    c_hold hdr [nr_include man.macros]
    c_hold hdr [nr_title "\"[string trimleft $title :]\" $section $version $module \"$shortdesc\""]
    c_hold hdr [nr_bolds]
    c_hold hdr [fmt_section NAME]
    c_hold hdr "$title \\- $description"
    c_hold hdr "$title \1\\- $description"

    return [c_held hdr]
}

c_pass 1 fmt_moddesc   {desc} {c_set_module $desc}
c_pass 2 fmt_moddesc   {desc} NOP

    if {[dt_lnesting] > 0} {
	return [nr_out]
    }
    return {}
}

proc fmt_enum     {}        {return [nr_item " \[[c_cnext]\]\n"]}
proc fmt_bullet   {}        {return [nr_item " \\(bu"]}
proc fmt_bullet   {}        {return [nr_item " \1\\(bu"]}
proc fmt_lst_item {text}    {return [nr_blt $text]}
proc fmt_cmd_def  {command} {return [nr_blt [fmt_cmd $command]]}

proc fmt_arg_def {type name {mode {}}} {
    set    text [nr_blt ""]
    append text [fmt_arg $name]
    append text " $type"
    if {$mode != {}} {append text " ($mode)"}
    return $text
}
proc fmt_opt_def {name {arg {}}} {
    if {[string match -* $name]} {set name \\-$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} {
    set    text ""
    append text "[nr_lp]\n"

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded doctools            1.0.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]]

#!/bin/sh
#! /bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}

rename source __source 
proc source {path} {
    set f [file join [pwd] $path]
    uplevel 1 __source $path

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2003-05-09  Andreas Kupries  <[email protected]>

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-05-23  Andreas Kupries  <[email protected]>

	* fileutil.tcl: Rel. engineering. Updated version number 
	* fileutil.man: of fileutil to reflect its changes, to 1.6.1.
	* pkgIndex.tcl:

2004-05-23  Andreas Kupries  <[email protected]>

	* fileutil.test: Cleaning up after Aaron. Updated the test
	  filetype-1.12 to look for the extended return value of fileType
	  when applied to jpeg images. The last checkin changed this, but
	  the test was not updated as well, most likely not even
	  run. Found and corrected during release preparation and testing.

2004-05-11  Aaron Faupell <[email protected]>

	* fileutil.tcl: updated the jpeg test to recognize exif format

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2004-02-09  Andreas Kupries  <[email protected]>

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

[list_begin definitions]

# fileutil.tcl --
#
#	Tcl implementations of standard UNIX utilities.
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
# Copyright (c) 2002      by Phil Ehrens <[email protected]> (fileType)
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: fileutil.tcl,v 1.37 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
}

# ::fileutil::grep --
#

	return "."
    }

    set pwd   [file split $pwd]
    set npath [file split $path]

    if {[string match ${pwd}* $npath]} {
	set path [eval file join [lrange $npath [llength $pwd] end]]
	set path [eval [linsert [lrange $npath [llength $pwd] end] 0 file join ]]
    }
    return $path
}

# ::fileutil::stripN --
#
#	Removes N elements from the beginning of the path.
#
# Arguments:
#	path		path to modify
#	n		number of elements to strip
#
# Results:
#	path		The modified path

proc ::fileutil::stripN {path n} {
    set path [file split $path]
    if {$n >= [llength $path]} {
	return {}
    } else {
	return [eval file join [lrange $path $n end]]
	return [eval [linsert [lrange $path $n end] 0 file join]]
    }
}

# ::fileutil::cat --
#
#	Tcl implementation of the UNIX "cat" command.  Returns the contents
#	of the specified file.

        lappend type compressed bzip
    } elseif { $binary && [string match "\x1f\x8b*" $test] } {
        lappend type compressed gzip
    } elseif { $binary && [string match "GIF*" $test] } {
        lappend type graphic gif
    } elseif { $binary && [string match "\x89PNG*" $test] } {
        lappend type graphic png
    } elseif { $binary && [string match "\xFF\xD8\xFF\xE0\x00\x10JFIF*" $test] } {
        lappend type graphic jpeg
    } elseif { $binary && [string match "\xFF\xD8\xFF*" $test] } {
        binary scan $test c3H2Sa5 id marker len txt 
        if {$marker == "e0" && $txt == "JFIF\x00"} {
            lappend type graphic jpeg jfif
        } elseif { $marker == "e1" && $txt == "Exif\x00" } {
            lappend type graphic jpeg exif
        }
    } elseif { $binary && [string match "MM\x00\**" $test] } {
        lappend type graphic tiff
    } elseif { $binary && [string match "\%PDF\-*" $test] } {
        lappend type pdf
    } elseif { ! $binary && [string match -nocase "*\<html\>*" $test] } {
        lappend type html
    } elseif { [string match "\%\!PS\-*" $test] } {

# -*- tcl -*-
# Tests for the find function.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
# Copyright (c) 2001 by ActiveState Tool Corp.
# All rights reserved.
#
# RCS: @(#) $Id: fileutil.test,v 1.22 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} {
    set auto_path [linsert $auto_path 0 .]
    package require tcltest

    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list text message pgp]]
test fileType-1.12 {test binary graphic jpeg} {
    set f [file join $dir fileTypeTest jpegFile]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list binary graphic jpeg]]
} [list 0 [list binary graphic jpeg jfif]]
test fileType-1.13 {test binary graphic gif} {
    set f [file join $dir fileTypeTest gifFile]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list binary graphic gif]]
test fileType-1.14 {test binary graphic png} {
    set f [file join $dir fileTypeTest pngFile]

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded fileutil 1.6 [list source [file join $dir fileutil.tcl]]
package ifneeded fileutil 1.6.1 [list source [file join $dir fileutil.tcl]]

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2003-12-01  Andreas Kupries  <[email protected]>

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-05-23  Andreas Kupries  <[email protected]>

	* ftpd.tcl: Rel. engineering. Updated version number 
	* ftpd.man: of ftpd to reflect its changes, to 1.2.1.
	* pkgIndex.tcl:

2004-05-23  Andreas Kupries  <[email protected]>

	* Bugfixes by Gerald Lester. No details available. Gerald is asked
	  to replace this entry with one describing his changes.

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2004-02-10  Andreas Kupries  <[email protected]>

[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]).
It works by listening on the standard FTP socket.  Most server errors
are returned as error messages with the appropriate code attached to

# ftpd.tcl --
#
#       This file contains Tcl/Tk package to create a ftp daemon.
#       I believe it was originally written by Matt Newman ([email protected]).  
#       Modified by Dan Kuchler ([email protected]) to handle
#       more ftp commands and to fix some bugs in the original implementation
#       that was found in the stdtcl module.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: ftpd.tcl,v 1.21 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
namespace eval ::ftpd {

    }
    if {$fail || ($res == 0)} {
	::ftpd::Log note "AuthUsr: Access denied to <$data(user)> <$data(pass)>."
	unset data(user)
        unset data(pass)
        puts $sock "551 Access Denied"
    } else {
	puts $sock "200 OK"
	puts $sock "230 OK"
	set data(access) 1
    }
    return
}

# ::ftpd::command::PORT --
#

    switch -exact -- $command {
        append {
	    #
	    # 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
	    ::ftpd::Log debug "at dlist {$style} {$outchan} {$path}"
	    #set path [glob -nocomplain $path]

# Only provide the package if it has been successfully
# sourced into the interpreter.

#
# Patched Mark O'Connor
#
package provide ftpd 1.2
package provide ftpd 1.2.1


##
## Implementation of passive command
##
proc ::ftpd::command::PASV {sock args} {
    upvar #0 ::ftpd::$sock data

    set data(sock2a) [socket -server [list ::ftpd::PasvAccept $sock] 0]
    set list1 [fconfigure $sock -sockname]
    set ip [lindex $list1 0]
    set list2 [fconfigure $data(sock2a) -sockname]
    set port [lindex $list2 2]
    ::ftpd::Log debug "PASV on {$list1} {$list2} $ip $port"
    set ans [split $ip {.}]
    lappend ans [expr {($port >> 8) & 0xff}] [expr {$port & 0xff}]
    set ans [join $ans {,}]
    puts $sock "227 Entering Passive Mode. $ans"
    puts $sock "227 Entering Passive Mode ($ans)."
    return
}


proc ::ftpd::PasvAccept {sock sock2 ip port} {
    upvar #0 ::ftpd::$sock data

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.3]} {return}
package ifneeded ftpd 1.2 [list source [file join $dir ftpd.tcl]]
package ifneeded ftpd 1.2.1 [list source [file join $dir ftpd.tcl]]

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2003-05-05  Andreas Kupries  <[email protected]>

#
# Side Effects:
#	Throws an error if no arguments are given.

proc ::html::eval {args} {

    # The args must be evaluated in the stack frame above this one.
    ::eval uplevel $args
    ::eval [linsert $args 0 uplevel]
    return ""
}

# ::html::init
#
#	Reset state that gets accumulated for the current page.
#

#	args	Additional attributes for the INPUT tag
#
# Results:
#	The html fragment

proc ::html::textInputRow {label name {value {}} args} {
    variable defaults
    ::set html [row $label [::eval [list html::textInput $name $value] $args]]
    ::set html [row $label [::eval [linsert $args 0 html::textInput $name $value]]]
    return $html
}

# ::html::passwordInputRow --
#
#	Format a table row containing a password input element and a label.
#

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2004-02-09  Andreas Kupries  <[email protected]>

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-03-06  Andreas Kupries  <[email protected]>

	* inifile.test: Fixed [Tcllib SF Bug 899204] by (a) rewriting all
	  tests to be completely independent of each other and (b)
	  changing the mode when opening the test file to 'r'. It should
	  be noted that the write facilities of the module are not covered
	  by the testsuite. That is unfortunate.

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2004-02-10  Andreas Kupries <[email protected]>

# ini.tcl --
#
#       Querying and modifying old-style windows configuration files (.ini)
#
# Copyright (c) 2003    Aaron Faupell <[email protected]>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: ini.tcl,v 1.5 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
    set commentchar \;
}

            if { ![info exists comments($sec)] } { return {} }
            return $comments($sec)
        }
        if { ![info exists comments($sec\000$key)] } { return {} }
        return $comments($sec\000$key)
    }
    if { $key == "" } {
        eval [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

proc ::ini::filename {fh} {
    _valid_ns $fh

puts "- inifile [package present inifile]"

#---------------------------------------------------------------------

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} {
    set hdl [ini::open $testini r]
    ini::sections ini0
    set res [ini::sections $hdl]
    ini::close $hdl
    set res
} {emptysection section1 \{test section2}

test inifile-1.3 {ini::keys} {
    set hdl [ini::open $testini r]
    ini::keys ini0 section1
    set res [ini::keys $hdl section1]
    ini::close $hdl
    set res
} {testkey key}

test inifile-1.4 {ini::keys} {
    set hdl [ini::open $testini r]
    ini::keys ini0 \{test
    set res [ini::keys $hdl \{test]
    ini::close $hdl
    set res
} {\}key}

test inifile-1.5 {ini::get} {
    set hdl [ini::open $testini r]
    ini::get ini0 section1
    set res [ini::get $hdl section1]
    ini::close $hdl
    set res
} {testkey hi key value}

test inifile-1.6 {ini::get} {
    set hdl [ini::open $testini r]
    ini::get ini0 \{test
    set res [ini::get $hdl \{test]
    ini::close $hdl
    set res
} {\}key {$blah}}

test inifile-1.7 {ini::value} {
    set hdl [ini::open $testini r]
    ini::value ini0 section1 key
    set res [ini::value $hdl section1 key]
    ini::close $hdl
    set res
} {value}

test inifile-1.8 {ini::value} {
    set hdl [ini::open $testini r]
    ini::value ini0 \{test \}key
    set res [ini::value $hdl \{test \}key]
    ini::close $hdl
    set res
} {$blah}

test inifile-1.9 {ini::exists} {
    set hdl [ini::open $testini r]
    ini::exists ini0 section1
    set res [ini::exists $hdl section1]
    ini::close $hdl
    set res
} {1}

test inifile-1.10 {ini::exists} {
    set hdl [ini::open $testini r]
    ini::exists ini0 section
    set res [ini::exists $hdl section]
    ini::close $hdl
    set res
} {0}

test inifile-1.11 {ini::exists} {
    set hdl [ini::open $testini r]
    ini::exists ini0 section1 testkey
    set res [ini::exists $hdl section1 testkey]
    ini::close $hdl
    set res
} {1}

test inifile-1.12 {ini:::exists} {
    set hdl [ini::open $testini r]
    ini::exists ini0 section1 blah
    set res [ini::exists $hdl section1 blah]
    ini::close $hdl
    set res
} {0}

test inifile-1.13 {ini:::exists} {
    set hdl [ini::open $testini r]
    ini::exists ini0 \{test
    set res [ini::exists $hdl \{test]
    ini::close $hdl
    set res
} {1}

test inifile-1.14 {ini:::exists} {
    set hdl [ini::open $testini r]
    ini::exists ini0 \{test \}key
    set res [ini::exists $hdl \{test \}key]
    ini::close $hdl
    set res
} {1}


#---------------------------------------------------------------------
# Clean up

::tcltest::cleanupTests

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2004-01-24  Andreas Kupries  <[email protected]>

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2003-05-05  Andreas Kupries  <[email protected]>

2004-05-26  Michael Schlenker <[email protected]>

	* logger.tcl: Replaced use of != for string comparision with
	  equivalent but correcter 'string compare'.
	  Fixed a bug with special logger names demonstrated by test 1.3.
	* logger.test: Added test for special logger name.
	  
2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-05-23  Andreas Kupries  <[email protected]>

	* log.tcl: Rel. engineering. Updated version number 
	* log.man: of log to reflect its changes, to 1.1.1.
	* pkgIndex.tcl:

2004-05-26  Michael Schlenker <[email protected]>

	* logger.tcl: Fixed bug with enable/disable
	  wrong enabled value was reported if disable critical was used.
	  Added "none" as result for currentloglevel for this situation.
	* logger.test: Added tests 7.1-7.4 to check for the above bug.
	* logger.man: Fixed docs and replaced the nonsensical "or" with 
	  the correct "and" in enable/disable docs. Added a comment how
	  to completely disable logging for a service and its children. 

2004-05-25  Michael Schlenker <[email protected]>

	* logger.tcl: Fixed bug [948273] in ::logger::services
	  Fixed cleanup of services list in delproc
	  Implemented doc'ed but missing ${log}::services subcommand
	  Fixed misuse of set inside namespace eval to prevent 
	  overwriting of global variables
	  Version number changed to 0.3.1
	* pkgIndex.tcl: updated version number of logger package
	* logger.man: updated docs for ${log}::services.
	* logger.test: Added tests for fixed bugs

2004-03-09  Andreas Kupries  <[email protected]>

	* log.tcl: Added initialization code to suppress the lower levels
	  (warning notice info debug) from generating output. In other
	  words, by default only statements with messages of level error
	  or higher will generate output when the package is loaded.

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2004-02-13  Andreas Kupries  <[email protected]>

[comment {-*- tcl -*- doctools manpage}]
[manpage_begin log n 1.1]
[manpage_begin log n 1.1.1]
[copyright {2001-2002 Andreas Kupries <[email protected]>}]
[moddesc   {Logging facility}]
[titledesc {Procedures to log messages of libraries and applications.}]
[require Tcl 8]
[require log [opt 1.1]]
[require log [opt 1.1.1]]
[description]

[para]

The [package log] package provides commands that allow libraries and
applications to selectively log information about their internal
operation and state.

# log.tcl --
#
#	Tcl implementation of a general logging facility
#	(Reaped from Pool_Base and modified to fit into tcllib)
#
# Copyright (c) 2001 by ActiveState Tool Corp.
# See the file license.terms.

package require Tcl 8
package provide log 1.1
package provide log 1.1.1

# ### ### ### ######### ######### #########

namespace eval ::log {
    namespace export levels lv2longform lv2color lv2priority 
    namespace export lv2cmd lv2channel lvCompare
    namespace export lvSuppress lvSuppressLE lvIsSuppressed
    namespace export lvCmd lvCmdForall
    namespace export lvChannel lvChannelForall lvColor lvColorForall

	# Ignore levels without channel.
	return
    }

    puts $chan "$level$fill($level) $text"
    return
}

# ### ### ### ######### ######### #########
## Initialization code. Disable logging for the lower levels by
## default.

## log::lvSuppressLE emergency
log::lvSuppressLE warning

# -*- tcl -*-
# Tests for the log facility
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2001 by ActiveState Tool Corp.
# All rights reserved.
#
# RCS: @(#) $Id: log.test,v 1.3 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::*
}

if { [lsearch $auto_path [file dirname [info script]]] == -1 } {

test log-6.1 {channel error} {
    if {![catch {::log::lv2channel foo} msg]} {
	error "foo is an unique abbreviation of a level name"
    }
    set msg
} {"foo" is no unique abbreviation of a level name}

foreach level {alert critical 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"
    }
    set msg

[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
from different services, at priority levels, with different commands.

[list_begin definitions]

[call [cmd logger::init] [arg service]]

Initializes the service [arg service] for logging.  The service names
are actually Tcl namespace names, so they are seperated with '::'.

When a logger service is 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]).

[call [cmd \${log}::debug] [arg message]]

Enable logging, in the service referenced by [var \${log}], and its
children, at or above the level specified, and disable logging below
it.

[call [cmd \${log}::enable] [arg level]]

Enable logging, in the service referenced by [var \${log}], and its
children, at 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
and may be removed from future versions of the logger package.  The
current version takes one argument, a command to be executed when the

    }

    ${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]
}]

[call [cmd \${log}::delete]]

# logger.tcl --
#
#	Tcl implementation of a general logging facility.
#   Tcl implementation of a general logging facility.
#
# Copyright (c) 2003 by David N. Welton <[email protected]>
# Copyright (c) 2004 by Michael Schlenker <[email protected]>
# See the file license.terms.

# The logger package provides an 'object oriented' log facility that
# lets you have trees of services, that inherit from one another.
# This is accomplished through the use of Tcl namespaces.

package provide logger 0.3
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"
    # 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 {}
    # 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!
    # 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 no-op args {}


	proc stdoutcmd {level text} {
	    variable service
	    puts "\[[clock format [clock seconds]]\] \[$service\] \[$level\] \'$text\'"
	}
    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\'"
	}
    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.
    # 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
	}
    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.
    # 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"
	    }
    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]
	}
        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.
    # 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"
	    }
    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]
	}
        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
	#
    # 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
	}
    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.
    # 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"
		}
	    }
	}
    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.
    # 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
	}
    proc delproc {cmd} {
        variable delcallback
	set delcallback $cmd
    }


	# delete --
	#
	#	Delete the namespace and its children.
    # delete --
    #
    #   Delete the namespace and its children.

	proc delete {} {
	    variable delcallback
    proc delete {} {
        variable delcallback
        variable service

	    logger::walk [namespace current] delete
	    catch { uplevel \#0 $delcallback }
	    namespace delete [namespace current]
	}
        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.
    # 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]
	}
    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]
    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
	    }
	}
    # 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
}

# -*- tcl -*-
# Tests for the logger facility.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2002 by David N. Welton <[email protected]>.
# Copyright (c) 2004 by Michael Schlenker <[email protected]>.
#
# $Id: logger.test,v 1.5 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
} {::logger::tree::global}

test logger-1.1 {init sub-system} {
    set log [logger::init global::subsystem]
    ${log}::delete
    # cleanup the leftover global log
    ::logger::tree::global::delete
    set log
} {::logger::tree::global::subsystem}

test logger-1.2 {instantiate main logger and child} {
    set log1 [logger::init global]
    set log2 [logger::init global::subsystem]
    ${log2}::delete
    ${log1}::delete
    list $log1 $log2
} {::logger::tree::global ::logger::tree::global::subsystem}

test logger-1.3 {instantiate logger with problematic name} {
    set log [logger::init foo::logger::tree::bar]    
    set services [logger::services]
    # direct cleanup of logger namespace
    foreach srv $services {
        ::logger::tree::${srv}::delete
    }
    set services_post [logger::services]
    list $log [lsort $services] $services_post
} {::logger::tree::foo::logger::tree::bar {foo foo::logger foo::logger::tree foo::logger::tree::bar} {}}

test logger-2.0 {delete} {
    set log [logger::init global]
    ${log}::delete
    catch {set ${log}::enabled} err
    set err
} {can't read "::logger::tree::global::enabled": no such variable}

    ${log1}::warn "warn"
    ${log1}::notice "notice"
    ${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

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8]} {return}
package ifneeded log 1.1 [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]]

2004-06-18  Kevin Kenny  <[email protected]>

	* combinatorics.test: Kevin added the display of the math version
	  number to the test.

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 
	*


2004-02-09  Jeff Hobbs  <[email protected]>

	* combinatorics.tcl (::math::factorial): correct fac 171
	off-by-one and use of -strict in string is int|double.

2003-12-22  Joe English  <[email protected]>
	* calculus.man (rungeKuttaStep): Add missing argument 
	* calculus.man (rungeKuttaStep): Add missing argument
	in function synopsis (bug report from Richard Body).

2003-10-29  Arjen Markus <[email protected]>

	* statistics.tcl (BasicStat): Applied fix for [SF Tcllib Bug
	  820807]. Uniform data may cause a small negative value when
	  computing the base value for a standard deviation, instead of
	  the correct 0.0. The fix now enforces 0.0 when encountering this
	  situation. This entry in the ChangeLog by Andreas Kupries.

2003-05-05  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.4 ========================
	* 
	*

2003-04-24  Andreas Kupries  <[email protected]>

	* pkgIndex.tcl: Found math::optimize missing in index.
	* optimize.man: Version number inconsistent with code,
	  corrected.

2003-04-21  Andreas Kupries  <[email protected]>

	* optimize.test: Corrected errors in loading the functionality
	  under test, and of accessing tcltest. Now functional.

2003-04-18  Joe English  <[email protected]

	* optimize.man: fix minor markup errors that doctools and tmml 
	  were complaining about. 
	* optimize.man: fix minor markup errors that doctools and tmml
	  were complaining about.

2003-04-16  Andreas Kupries  <[email protected]>

	* pkgIndex.tcl: Added math::statistics after yesterday's commit by
	  Arjen Markus.

	* statistics.test: Changed to conform to standard of importing

2003-04-13  Andreas Kupries  <[email protected]>

	* pkgIndex.tcl:
	* fuzzy.tcl: Committed new code (see #535216), this also updates
	  the package to version 0.2

	* fuzzy.man: 
	* fuzzy.man:
	* fuzzy.test: New files for fuzzy comparisons, documentation and
	  testsuite. Fixed some bugs in them. NOTE: There are failures in
	  the testsuite.

2003-04-11  Andreas Kupries  <[email protected]>

	* combinatorics.man:

2002-01-11  Kevin Kenny  <[email protected]>

	* combinatorics.tcl: Removed incorrect 'package provide'.
	
2002-01-11  Kevin Kenny  <[email protected]>

	* 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'.
	* combinatorics.n:
	* combinatorics.tcl:
	* combinatorics.test: Added a 'combinatorics' module containing
	the Gamma function and several related functions (factorial,
	binomial coefficient, and Beta). (Feature request #484850).
	
2001-06-21  Andreas Kupries <[email protected]>

	* math.tcl: Fixed dubious code reported by frink.

2000-10-06  Eric Melski  <[email protected]>

	* math.test: 
	* math.n: 
	* math.test:
	* math.n:
	* math.tcl: Added ::math::fibonacci function, to compute numbers
	in the Fibonacci sequence.

2000-09-08  Eric Melski  <[email protected]>

	* math.test:
	* math.n:
	* math.tcl: Added ::math::random function.

	* pkgIndex.tcl: Bumped version number to 1.1.

2000-06-15  Eric Melski  <[email protected]>

	* math.n: 
	* math.test: 
	* math.n:
	* math.test:
	* math.tcl: Incorporated sigma, cov, stats, integrate functions
	(from Philip Ehrens <[email protected]>). [RFE: 5060]

2000-03-27  Eric Melski  <[email protected]>

	* math.n: 
	* math.test: 
	* math.n:
	* math.test:
	* math.tcl: Added sum, mean, and product functions (from Philip
	Ehrens <[email protected]>).

2000-03-09  Eric Melski  <[email protected]>

	* math.test: Adapted tests for use in/out of tcllib test framework.

2000-03-07  Eric Melski  <[email protected]>

	* pkgIndex.tcl:
	* math.tcl:
	* math.test:
	* math.n: Initial versions of files for math library.

# Tests for combinatorics functions in math library  -*- tcl -*-
#
# This file contains a collection of tests for one or more of the Tcllib
# procedures.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 2001 by Kevin B. Kenny
# All rights reserved.
#
# RCS: @(#) $Id: combinatorics.test,v 1.6 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::*
}

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]] } {
    proc K { x y } { set x }
    proc lset { listVar index var } {

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-05-23  Andreas Kupries  <[email protected]>

	* md4.tcl: Rel. engineering. Updated version number 
	* md4.man: of md4 to reflect its changes, to 1.0.2.
	* pkgIndex.tcl:

2004-02-18  Pat Thoyts  <[email protected]>

	* md4.tcl: Streamlined the rotate-left function and fixed a rare
	  bug that occurs if the hash result produces a hypen as the first
	  character and we are using Trf's hex function.

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2003-05-08  Pat Thoyts  <[email protected]>

[manpage_begin md4 n 1.0.1]
[manpage_begin md4 n 1.0.2]
[moddesc   {md4}]
[copyright {2003, Pat Thoyts <[email protected]>}]
[titledesc {MD4 Message-Digest Algorithm}]
[require Tcl 8.2]
[require md4 [opt 1.0.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
an arbitrary quantity of data and generates a 128-bit message digest
from the input. The MD4 algorithm is faster but potentially weaker than

# md4.tcl - Copyright (C) 2003 Pat Thoyts <[email protected]>
#
# This is a Tcl-only implementation of the MD4 hash algorithm as described in 
# RFC 1320 ( http://www.ietf.org/rfc/rfc1320.txt )
#
# -------------------------------------------------------------------------
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------
#
# $Id: md4.tcl,v 1.9 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]} {
        set uid 0
    }

        [expr {(0xFF00 & $v) >> 8}] \
        [expr {(0xFF0000 & $v) >> 16}] \
        [expr {((0xFF000000 & $v) >> 24) & 0xFF}]
}

# 32bit rotate-left
proc ::md4::<<< {v n} {
    return [expr {((($v << $n) \
                        | (($v >> (32 - $n)) \
    set v [expr {(($v << $n) | (($v >> (32 - $n)) & (0x7FFFFFFF >> (31 - $n))))}]
    return [expr {$v & 0xFFFFFFFF}]
                               & (0x7FFFFFFF >> (31 - $n))))) \
                      & 0xFFFFFFFF}]
}

# Convert our <<< pseuodo-operator into a procedure call.
regsub -all -line \
    {\[expr {(.*) <<< (\d+)}\]} \
    $::md4::MD4Hash_body \
    {[<<< [expr {\1}] \2]} \

# Define the MD4 hashing procedure with inline functions.
proc ::md4::MD4Hash {token msg} $::md4::MD4Hash_body

# -------------------------------------------------------------------------

if {[package provide Trf] != {}} {
    interp alias {} ::md4::Hex {} ::hex -mode encode
    interp alias {} ::md4::Hex {} ::hex -mode encode --
} else {
    proc ::md4::Hex {data} {
        set result {}
        binary scan $data c* r
        foreach c $r {
            append result [format "%02X" [expr {$c & 0xff}]]
        }

# md4.test - Copyright (C) 2003 Pat Thoyts <[email protected]>
#
# $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::*
}

package require md4

    145 B9FF2575260E2AD08557EEBA52B27CDD
    146 BCCCBCFEAB174BDDB81CC74DD97984F6
    147 9B98A75EDED6B5AF8C449B75A74C30B3
    148 5F9F642231152DD8CD5CAA9B5FC59B5D
    149 84D82189C5458F8647D338FD62EF1667
} {
    test md4-2.$n "md4 block size checks: length $n" {
        list [catch {
        ::md4::md4 -hex [string repeat a $n]
    } $hash
            ::md4::md4 -hex [string repeat a $n]
        } msg] $msg
    } [list 0 $hash]
}

::tcltest::cleanupTests

# -------------------------------------------------------------------------
# Local Variables:
#   mode: tcl
#   indent-tabs-mode: nil
# End:

/* md4_check.c Copyright (C) 2003 Pat Thoyts <[email protected]>
 *
 * Generate test data to permit comparison of the tcl implementation of MD4
 * against the OpenSSL library implementation.
 *
 * usage: md4_check
 *
 * $Id: md4_check.c,v 1.2 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 <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <openssl/md4.h>

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;
    MD4_Init(&ctx);
    MD4_Update(&ctx, buf, len);

# md4c.tcl - Copyright (C) 2003 Pat Thoyts <[email protected]>
#
# This provides a C implementation of MD4 using the sample code from RFC1320
# and wrapping this up in a Tcl package.
#
# The tcl interface code is based upon the md5c code from critcl by JCW.
#
# INSTALLATION
# ------------
# This package uses critcl (http://wiki.tcl.tk/critcl). To build do:
#  critcl -libdir <your-tcl-lib-dir> -pkg md4c md4c
#
# $Id: md4c.tcl,v 1.4 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
critcl::csources md4.c

# pkgIndex.tcl - 
#
# 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]]

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-05-23  Andreas Kupries  <[email protected]>

	* md5x.tcl: Rel. engineering. Updated version number 
	* md5.man:  of md5 v2 to reflect its changes, to 2.0.1.
	* pkgIndex.tcl:

2004-02-18  Pat Thoyts  <[email protected]>

	* md5x.tcl: Added -- to end options if using Trf's hex in case the
	  hash begins with a - character (possible).  Streamlined the <<<
	  proc.

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2004-02-12  Andreas Kupries  <[email protected]>

[manpage_begin md5 n 2.0.0]
[manpage_begin md5 n 2.0.1]
[moddesc {Perform md5 hashing}]
[copyright {2003, Pat Thoyts <[email protected]>}]
[titledesc {MD5 Message-Digest Algorithm}]
[require Tcl 8.2]
[require md5 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
an arbitrary quantity of data and generates a 128-bit message digest
from the input. The MD5 algorithm is related to the MD4 algorithm (2)

# -*- tcl -*-
# md5.test:  tests for the md5 commands
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 2001 by ActiveState Tool Corp.
# All rights reserved.
#
# RCS: @(#) $Id: md5.test,v 1.8 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} {
    package require tcltest
    namespace import ::tcltest::*

# md5c.tcl - 
#
# Wrapper for RSA's Message Digest in C
#
# Written by Jean-Claude Wippler <[email protected]>
#
# $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
critcl::csources md5.c;                 # The RSA MD5 implementation.

# critcl (md5c) or Trf.
#
# -------------------------------------------------------------------------
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------
#
# $Id: md5x.tcl,v 1.3 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}]} {
    if {[catch {package require md5c}]} {
        catch {
            package requre Trf
            package require Memchan
        }
    }
}

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]} {
        set uid 0
    }

        [expr {(0xFF00 & $v) >> 8}] \
        [expr {(0xFF0000 & $v) >> 16}] \
        [expr {((0xFF000000 & $v) >> 24) & 0xFF}]
}

# 32bit rotate-left
proc ::md5::<<< {v n} {
    return [expr {((($v << $n) \
                        | (($v >> (32 - $n)) \
    set v [expr {(($v << $n) | (($v >> (32 - $n)) & (0x7FFFFFFF >> (31 - $n))))}]
    return [expr {$v & 0xFFFFFFFF}]
                               & (0x7FFFFFFF >> (31 - $n))))) \
                      & 0xFFFFFFFF}]
}

# Convert our <<< pseuodo-operator into a procedure call.
regsub -all -line \
    {\[expr {(\$[ABCD]) \+ \(\((.*)\)\s+<<<\s+(\d+)\)}\]} \
    $::md5::MD5Hash_body \
    {[expr {\1 + [<<< [expr {\2}] \3]}]} \

# Define the MD5 hashing procedure with inline functions.
proc ::md5::MD5Hash {token msg} $::md5::MD5Hash_bodyX

# -------------------------------------------------------------------------

if {[package provide Trf] != {}} {
    interp alias {} ::md5::Hex {} ::hex -mode encode
    interp alias {} ::md5::Hex {} ::hex -mode encode --
} else {
    proc ::md5::Hex {data} {
        set result {}
        binary scan $data c* r
        foreach c $r {
            append result [format "%02X" [expr {$c & 0xff}]]
        }

# -*- tcl -*-
# md5.test:  tests for the md5 commands
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 2001 by ActiveState Tool Corp.
# All rights reserved.
#
# RCS: @(#) $Id: md5x.test,v 1.5 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} {
    package require tcltest
    namespace import ::tcltest::*

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded md5 2.0.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]]

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2004-02-12  Andreas Kupries  <[email protected]>

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-05-23  Andreas Kupries  <[email protected]>

	* mime.tcl:     Downgraded mime to version 1.3.6, and removed the
	* mime.man:     -decode extension from the API. This branch is for
	* pkgIndex.tcl: bugfixes only.

2004-05-19  Andreas Kupries  <[email protected]>

	* mime.test:
	* mime.tcl: Fixed [SF Tcllib Bug 954328]. The package mime now
	  adapts at runtime to whatever version of package md5 has been
	  loaded.

2004-05-12  Andreas Kupries  <[email protected]>

	* smtp.tcl (::smtp::wdata): Fixed [SF Tcllib Bug 951568]. Added
	  handlers for the query/* commands from Trf. Also changed the
	  default to sliently pass all unknowns in the future.

2004-05-10  Andreas Kupries  <[email protected]>

	* mime.tcl (copymessageaux): Applied the patch for [SF Tcllib Bug
	  893516] on behalf of Marshall Rose. The problem was found by
	  Todd Copeland <[email protected]>, he provided the
	  patch as well.

2004-05-04  Andreas Kupries  <[email protected]>

	* mime.man:
	* mime.test:
	* mime.tcl: Applied [SF Tcllib Patch 763712]. This extends the
	  functionality of mime::getbody with decoding of the mime part
	  based on the specified charset into the regular utf8
	  form. Testsuite was updated and extended as well. Thanks to
	  Matthew Walker <[email protected]> for the
	  work. Updated the documentation for mime on my own. Bumped
	  version to 1.4.

	* mime:test:
	* mime.tcl: Applied [SF Tcllib Patch 758742], adding many more
	  MIME types for encodings to the knowledge-base of the
	  package. Thanks to Matthew Walker <[email protected]>
	  for the work, and Mikhail Teterin <[email protected]>
	  for prodding. Bumped version to 1.3.5.

	* mime.test:
	* mime.tcl (copymessageaux): Fixed [SF Tcllib Bug 620852]. Added
	  '-nonewline' to the puts statements which wrote out the chunks
	  read from the file associated with the mime part, converted or
	  not. As the data was [read] we had no business of adding eol's
	  during writing as well. Thanks to Jasper Taylor
	  <[email protected]> for the report, and his
	  patience. Added a test for this as well, using files of similar
	  size as originally provided.

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2004-02-12  Andreas Kupries  <[email protected]>

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

[list_begin definitions]

size of each fragment passed to the callback.)

[nl]

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

[example {
  uplevel #0 $callback "end"
    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
body.

# Influenced by Borenstein's/Rose's safe-tcl (circa 1993) and Darren New's
# unpublished package of 1999.
#

# new string features and inline scan are used, requiring 8.3.
package require Tcl 8.3

package provide mime 1.3.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 {
        proc base64 {-mode what -- chunk} {
   	    return [base64::$what $chunk]
        }
        proc quoted-printable {-mode what -- chunk} {
  	    return [mime::qp_$what $chunk]
        }

	if {$::major < 2} {
	    # md5 v1, result is hex string ready for use.
        proc md5 {-- string} {
	    return [md5::md5 $string]
        }
	    proc md5 {-- string} {
		return [md5::md5 $string]
	    }
	} else {
	    # md5 v2, need option to get hex string
	    proc md5 {-- string} {
		return [md5::md5 -hex $string]
	    }
	}
        proc unstack {channel} {
	    # do nothing
	    return
        }
    }

    unset major
}        

#
# state variables:
#
#     canonicalP: input is in its canonical form
#     content: type/subtype

                               LX_LSQUARE   LX_RSQUARE  \
                               LX_EQUALS    LX_SOLIDUS  \
                               LX_QUOTE]

    set encList [list \
            ascii US-ASCII \
            big5 Big5 \
            cp1250 "" \
            cp1251 "" \
            cp1252 "" \
            cp1253 "" \
            cp1254 "" \
            cp1255 "" \
            cp1256 "" \
            cp1257 "" \
            cp1258 "" \
            cp437 "" \
            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 \
            gb2312 GB2312 \
            iso2022 ISO-2022 \
            iso2022-jp ISO-2022-JP \
            iso2022-kr ISO-2022-KR \
            iso8859-1 ISO-8859-1 \
            iso8859-2 ISO-8859-2 \
            iso8859-3 ISO-8859-3 \
            iso8859-4 ISO-8859-4 \
            iso8859-5 ISO-8859-5 \
            iso8859-6 ISO-8859-6 \
            iso8859-7 ISO-8859-7 \
            iso8859-8 ISO-8859-8 \
            iso8859-9 ISO-8859-9 \
            iso8859-10 ISO-8859-10 \
            iso8859-13 ISO-8859-13 \
            iso8859-14 ISO-8859-14 \
            iso8859-15 ISO-8859-15 \
            iso8859-16 ISO-8859-16 \
            jis0201  "" \
            jis0208 "" \
            jis0212 "" \
            jis0201 JIS_X0201 \
            jis0208 JIS_C6226-1983 \
            jis0212 JIS_X0212-1990 \
            koi8-r KOI8-R \
            koi8-u KOI8-U \
            ksc5601 "" \
            ksc5601 KS_C_5601-1987 \
            macCentEuro "" \
            macCroatian "" \
            macCyrillic "" \
            macDingbats "" \
            macGreek "" \
            macIceland "" \
            macJapan "" \
            macRoman "" \
            macRomania "" \
            macThai "" \
            macTurkish "" \
            macUkraine "" \
            shiftjis Shift_JIS \
            symbol "" \
            tis-620 TIS-620 \
            unicode "" \
            utf-8 UTF-8]

    variable encodings
    array set encodings $encList
    variable reversemap
    foreach {enc mimeType} $encList {
        if {$mimeType != ""} {
            set reversemap([string tolower $mimeType]) $enc
        }
    } 

    set encAliasList [list \
            ascii ANSI_X3.4-1968 \
            ascii iso-ir-6 \
            ascii ANSI_X3.4-1986 \
            ascii ISO_646.irv:1991 \
            ascii ASCII \
            ascii ISO646-US \
            ascii us \
            ascii IBM367 \
            ascii cp367 \
            cp437 cp437 \
            cp437 437 \
            cp775 cp775 \
            cp850 cp850 \
            cp850 850 \
            cp852 cp852 \
            cp852 852 \
            cp855 cp855 \
            cp855 855 \
            cp857 cp857 \
            cp857 857 \
            cp860 cp860 \
            cp860 860 \
            cp861 cp861 \
            cp861 861 \
            cp861 cp-is \
            cp862 cp862 \
            cp862 862 \
            cp863 cp863 \
            cp863 863 \
            cp864 cp864 \
            cp865 cp865 \
            cp865 865 \
            cp866 cp866 \
            cp866 866 \
            cp869 cp869 \
            cp869 869 \
            cp869 cp-gr \
            cp936 CP936 \
            cp936 MS936 \
            cp936 Windows-936 \
            iso8859-1 ISO_8859-1:1987 \
            iso8859-1 iso-ir-100 \
            iso8859-1 ISO_8859-1 \
            iso8859-1 latin1 \
            iso8859-1 l1 \
            iso8859-1 IBM819 \
            iso8859-1 CP819 \
            iso8859-2 ISO_8859-2:1987 \
            iso8859-2 iso-ir-101 \
            iso8859-2 ISO_8859-2 \
            iso8859-2 latin2 \
            iso8859-2 l2 \
            iso8859-3 ISO_8859-3:1988 \
            iso8859-3 iso-ir-109 \
            iso8859-3 ISO_8859-3 \
            iso8859-3 latin3 \
            iso8859-3 l3 \
            iso8859-4 ISO_8859-4:1988 \
            iso8859-4 iso-ir-110 \
            iso8859-4 ISO_8859-4 \
            iso8859-4 latin4 \
            iso8859-4 l4 \
            iso8859-5 ISO_8859-5:1988 \
            iso8859-5 iso-ir-144 \
            iso8859-5 ISO_8859-5 \
            iso8859-5 cyrillic \
            iso8859-6 ISO_8859-6:1987 \
            iso8859-6 iso-ir-127 \
            iso8859-6 ISO_8859-6 \
            iso8859-6 ECMA-114 \
            iso8859-6 ASMO-708 \
            iso8859-6 arabic \
            iso8859-7 ISO_8859-7:1987 \
            iso8859-7 iso-ir-126 \
            iso8859-7 ISO_8859-7 \
            iso8859-7 ELOT_928 \
            iso8859-7 ECMA-118 \
            iso8859-7 greek \
            iso8859-7 greek8 \
            iso8859-8 ISO_8859-8:1988 \
            iso8859-8 iso-ir-138 \
            iso8859-8 ISO_8859-8 \
            iso8859-8 hebrew \
            iso8859-9 ISO_8859-9:1989 \
            iso8859-9 iso-ir-148 \
            iso8859-9 ISO_8859-9 \
            iso8859-9 latin5 \
            iso8859-9 l5 \
            iso8859-10 iso-ir-157 \
            iso8859-10 l6 \
            iso8859-10 ISO_8859-10:1992 \
            iso8859-10 latin6 \
            iso8859-14 iso-ir-199 \
            iso8859-14 ISO_8859-14:1998 \
            iso8859-14 ISO_8859-14 \
            iso8859-14 latin8 \
            iso8859-14 iso-celtic \
            iso8859-14 l8 \
            iso8859-15 ISO_8859-15 \
            iso8859-15 Latin-9 \
            iso8859-16 iso-ir-226 \
            iso8859-16 ISO_8859-16:2001 \
            iso8859-16 ISO_8859-16 \
            iso8859-16 latin10 \
            iso8859-16 l10 \
            jis0201 X0201 \
            jis0208 iso-ir-87 \
            jis0208 x0208 \
            jis0208 JIS_X0208-1983 \
            jis0212 x0212 \
            jis0212 iso-ir-159 \
            ksc5601 iso-ir-149 \
            ksc5601 KS_C_5601-1989 \
            ksc5601 KSC5601 \
            ksc5601 korean \
            shiftjis MS_Kanji \
            utf-8 UTF8]

    foreach {enc mimeType} $encAliasList {
        set reversemap([string tolower $mimeType]) $enc
    }

    namespace export initialize finalize getproperty \
                     getheader setheader \
                     getbody \
                     copymessage \
                     mapencoding \
                     reversemapencoding \

    variable mime

    set token [namespace current]::[incr mime(uid)]
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    if {[set code [catch { eval [list mime::initializeaux $token] $args } \
    if {[set code [catch { eval [linsert $args 0 mime::initializeaux $token] } \
                         result]]} {
        set ecode $errorCode
        set einfo $errorInfo

        catch { mime::finalize $token -subordinates dynamic }

        return -code $code -errorinfo $einfo -errorcode $ecode $result

    array set options [list -subordinates dynamic]
    array set options $args

    switch -- $options(-subordinates) {
        all {
            if {![string compare $state(value) parts]} {
                foreach part $state(parts) {
                    eval [list mime::finalize $part] $args
                    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 {
        }

        default {

        } else {
            uplevel #0 $options(-command) [list end]
        }
    } result]
    set ecode $errorCode
    set einfo $errorInfo    

    if {$code} {
    return -code $code -errorinfo $einfo -errorcode $ecode $result
        return -code $code -errorinfo $einfo -errorcode $ecode $result
    }

    return $result
}

# ::mime::getbodyaux --
#
#    Builds up the body of the message, fragment by fragment.  When
#    the entire message has been retrieved, it is returned.
#

		} else {
		    set X [read $fd $size]
		}
		if {$size > 0} {
		    set size [expr {$size - [string length $X]}]
		}
		if {[string compare $converter ""]} {
		    puts $channel [$converter -mode encode -- $X]
		    puts -nonewline $channel [$converter -mode encode -- $X]
		} else {
		    puts $channel $X
		    puts -nonewline $channel $X
		}
	    }

            if {$closeP} {
                catch { close $state(fd) }
                unset state(fd)
            }

            if {[catch { fconfigure $channel -buffersize } blocksize]} {
                set blocksize 4096
            } elseif {$blocksize < 512} {
                set blocksize 512
            }
            set blocksize [expr {($blocksize/4)*3}]

	    # [893516]
	    fconfigure $channel -buffersize $blocksize

            puts $channel ""

            if {[string compare $converter ""]} {
                puts $channel [$converter -mode encode -- $state(string)]
            } else {
		puts $channel $state(string)
	    }

# mime.test - Test suite for TclMIME                     -*- tcl -*-
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 2000 by Ajuba Solutions
# All rights reserved.
#
# RCS: @(#) $Id: mime.test,v 1.12 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
    subst $res
} {specify exactly one of -file, -parts, or -string}

foreach {bug n encoded expected} {
    764702 1 "(=?utf-8?Q?H=C3=BCrz?=)" "(H�rz)"
} {
    test mime-7.$n "Test field_decode (from SF Tcllib bug $bug)" {
	mime::field_decode $encoded
    } $expected ; # {}
}

test mime-7.1 {Test reversemapencoding+mapencoding with preferred name} {
    set charset [mime::reversemapencoding "US-ASCII"]
    mime::mapencoding $charset
} {US-ASCII}

test mime-7.2 {Test reversemapencoding+mapencoding with alias} {
    set charset [mime::reversemapencoding "UTF8"]
    mime::mapencoding $charset
} {UTF-8}


test mime-8.0 {Test chunk handling of copymessage and helpers} {
    set in [makeFile [set data [string repeat [string repeat "123456789 " 10]\n 350]] input.txt]
    set mi [makeFile {} mime.txt]

    set token [mime::initialize -canonical text/plain -file $in]

    set f [open $mi w]
    fconfigure $f -translation binary
    mime::copymessage $token $f
    close $f

    set token [mime::initialize -file $mi]
    set newdata [mime::getbody $token]
    set res [string compare $data $newdata]

    removeFile input.txt
    removeFile mime.txt
    unset data newdata token f in mi
    set res
} 0

::tcltest::cleanupTests

#!/usr/bin/tclsh
#! /bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}

#package require mime
source ./mime.tcl 

proc construct_item_with_attachment size {
    set message_token [mime::initialize -canonical text/plain \
            -string "This is a first part."]

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]]

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

[list_begin definitions]

# smtp.tcl - SMTP client
#
# (c) 1999-2000 Marshall T. Rose
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

package require Tcl 8.3
package require mime 1.3.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
#    afterID: afterID associated with ::smtp::timer
#    options: array of user-supplied options

proc ::smtp::wdata {token command buffer} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    switch -- $command {
	create/read
	    -
        create/write
        create/write -
            -
        clear/write
        clear/write  -
            -
        delete/write {
            set state(crP) 0
            set state(nlP) 1
            set state(size) 0
        }

        write {

                append result "\n"
            }

            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 {
	    # Silently pass all unknown commands.
	    error "Unknown command \"$command\""
	    #error "Unknown command \"$command\""
	}
    }

    return ""
}

# ::smtp::talk --

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2004-02-10  Andreas Kupries <[email protected]>

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2004-02-09  Andreas Kupries  <[email protected]>