From a954976e93f01de895194894bd094892d9abd334 Mon Sep 17 00:00:00 2001 From: Pat Thoyts Date: Wed, 3 Feb 2010 10:08:54 +0000 Subject: [PATCH] Updated library packages from upstream sources. Signed-off-by: Pat Thoyts --- lib/base64/base64.tcl | 136 ++++++++++++++++++++++++---------- lib/base64/pkgIndex.tcl | 16 +--- lib/chatwidget/ChangeLog | 6 ++ lib/dns/dns.tcl | 8 +- lib/dns/ip.tcl | 11 ++- lib/dns/pkgIndex.tcl | 6 +- lib/irc/irc.tcl | 10 ++- lib/irc/pkgIndex.tcl | 4 +- lib/jabberlib/jlibtls.tcl | 21 +++++- lib/jabberlib/pep.tcl | 130 +++++--------------------------- lib/log/log.tcl | 10 ++- lib/log/logger.tcl | 152 ++++++++++++++++++++++++++++---------- lib/log/pkgIndex.tcl | 4 +- lib/sha1/sha1.tcl | 4 +- lib/tooltip/pkgIndex.tcl | 4 +- lib/tooltip/tipstack.tcl | 4 +- lib/tooltip/tooltip.tcl | 139 ++++++++++++++++++++++++++-------- 17 files changed, 398 insertions(+), 267 deletions(-) diff --git a/lib/base64/base64.tcl b/lib/base64/base64.tcl index 3edfd48..bd43971 100644 --- a/lib/base64/base64.tcl +++ b/lib/base64/base64.tcl @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: base64.tcl,v 1.23 2004/10/03 23:06:55 andreas_kupries Exp $ +# RCS: @(#) $Id: base64.tcl,v 1.31 2009/01/29 04:30:47 andreas_kupries Exp $ # Version 1.0 implemented Base64_Encode, Base64_Decode # Version 2.0 uses the base64 namespace @@ -18,6 +18,8 @@ # Version 2.2.2 bugfixes # Version 2.3 bugfixes and extended to support Trf +# @mdgen EXCLUDE: base64c.tcl + package require Tcl 8.2 namespace eval ::base64 { namespace export encode decode @@ -41,12 +43,13 @@ if {![catch {package require Trf 2.0}]} { # by $wrapchar. proc ::base64::encode {args} { - # Set the default wrapchar and maximum line length to match the output - # of GNU uuencode 4.2. Various RFCs allow for different wrapping - # characters and wraplengths, so these may be overridden by command line - # options. + # Set the default wrapchar and maximum line length to match + # the settings for MIME encoding (RFC 3548, RFC 2045). These + # are the settings used by Trf as well. Various RFCs allow for + # different wrapping characters and wraplengths, so these may + # be overridden by command line options. set wrapchar "\n" - set maxlen 60 + set maxlen 76 if { [llength $args] == 0 } { error "wrong # args: should be \"[lindex [info level 0] 0]\ @@ -78,23 +81,56 @@ if {![catch {package require Trf 2.0}]} { # [string is] requires Tcl8.2; this works with 8.0 too if {[catch {expr {$maxlen % 2}}]} { - error "expected integer but got \"$maxlen\"" + return -code error "expected integer but got \"$maxlen\"" + } elseif {$maxlen < 0} { + return -code error "expected positive integer but got \"$maxlen\"" } set string [lindex $args end] set result [::base64 -mode encode -- $string] - set result [string map [list \n ""] $result] - - if {$maxlen > 0} { - set res "" - set edge [expr {$maxlen - 1}] - while {[string length $result] > $maxlen} { - append res [string range $result 0 $edge]$wrapchar - set result [string range $result $maxlen end] - } - if {[string length $result] > 0} { - append res $result + + # Trf's encoder implicitly uses the settings -maxlen 76, + # -wrapchar \n for its output. We may have to reflow this for + # the settings chosen by the user. A second difference is that + # Trf closes the output with the wrap char sequence, + # always. The code here doesn't. Therefore 'trimright' is + # needed in the fast cases. + + if {($maxlen == 76) && [string equal $wrapchar \n]} { + # Both maxlen and wrapchar are identical to Trf's + # settings. This is the super-fast case, because nearly + # nothing has to be done. Only thing to do is strip a + # terminating wrapchar. + set result [string trimright $result] + } elseif {$maxlen == 76} { + # wrapchar has to be different here, length is the + # same. We can use 'string map' to transform the wrap + # information. + set result [string map [list \n $wrapchar] \ + [string trimright $result]] + } elseif {$maxlen == 0} { + # Have to reflow the output to no wrapping. Another fast + # case using only 'string map'. 'trimright' is not needed + # here. + + set result [string map [list \n ""] $result] + } else { + # Have to reflow the output from 76 to the chosen maxlen, + # and possibly change the wrap sequence as well. + + # Note: After getting rid of the old wrap sequence we + # extract the relevant segments from the string without + # modifying the string. Modification, i.e. removal of the + # processed part, means 'shifting down characters in + # memory', making the algorithm O(n^2). By avoiding the + # modification we stay in O(n). + + set result [string map [list \n ""] $result] + set l [expr {[string length $result]-$maxlen}] + for {set off 0} {$off < $l} {incr off $maxlen} { + append res [string range $result $off [expr {$off+$maxlen-1}]] $wrapchar } + append res [string range $result $off end] set result $res } @@ -125,6 +161,8 @@ if {![catch {package require Trf 2.0}]} { variable base64_en {} # We create the auxiliary array base64_tmp, it will be unset later. + variable base64_tmp + variable i set i 0 foreach char {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z \ @@ -143,6 +181,10 @@ if {![catch {package require Trf 2.0}]} { # # the last ascii char is 'z' + variable char + variable len + variable val + scan z %c len for {set i 0} {$i <= $len} {incr i} { set char [format %c $i] @@ -181,12 +223,13 @@ if {![catch {package require Trf 2.0}]} { proc ::base64::encode {args} { set base64_en $::base64::base64_en - # Set the default wrapchar and maximum line length to match the output - # of GNU uuencode 4.2. Various RFCs allow for different wrapping - # characters and wraplengths, so these may be overridden by command line - # options. + # Set the default wrapchar and maximum line length to match + # the settings for MIME encoding (RFC 3548, RFC 2045). These + # are the settings used by Trf as well. Various RFCs allow for + # different wrapping characters and wraplengths, so these may + # be overridden by command line options. set wrapchar "\n" - set maxlen 60 + set maxlen 76 if { [llength $args] == 0 } { error "wrong # args: should be \"[lindex [info level 0] 0]\ @@ -218,7 +261,9 @@ if {![catch {package require Trf 2.0}]} { # [string is] requires Tcl8.2; this works with 8.0 too if {[catch {expr {$maxlen % 2}}]} { - error "expected integer but got \"$maxlen\"" + return -code error "expected integer but got \"$maxlen\"" + } elseif {$maxlen < 0} { + return -code error "expected positive integer but got \"$maxlen\"" } set string [lindex $args end] @@ -231,21 +276,14 @@ if {![catch {package require Trf 2.0}]} { # Process the input bytes 3-by-3 binary scan $string c* X + foreach {x y z} $X { - # Do the line length check before appending so that we don't get an - # extra newline if the output is a multiple of $maxlen chars long. - if {$maxlen && $length >= $maxlen} { - append result $wrapchar - set length 0 - } - - append result [lindex $base64_en [expr {($x >>2) & 0x3F}]] + ADD [lindex $base64_en [expr {($x >>2) & 0x3F}]] if {$y != {}} { - append result [lindex $base64_en [expr {(($x << 4) & 0x30) | (($y >> 4) & 0xF)}]] + ADD [lindex $base64_en [expr {(($x << 4) & 0x30) | (($y >> 4) & 0xF)}]] if {$z != {}} { - append result \ - [lindex $base64_en [expr {(($y << 2) & 0x3C) | (($z >> 6) & 0x3)}]] - append result [lindex $base64_en [expr {($z & 0x3F)}]] + ADD [lindex $base64_en [expr {(($y << 2) & 0x3C) | (($z >> 6) & 0x3)}]] + ADD [lindex $base64_en [expr {($z & 0x3F)}]] } else { set state 2 break @@ -254,16 +292,33 @@ if {![catch {package require Trf 2.0}]} { set state 1 break } - incr length 4 } if {$state == 1} { - append result [lindex $base64_en [expr {(($x << 4) & 0x30)}]]== + ADD [lindex $base64_en [expr {(($x << 4) & 0x30)}]] + ADD = + ADD = } elseif {$state == 2} { - append result [lindex $base64_en [expr {(($y << 2) & 0x3C)}]]= + ADD [lindex $base64_en [expr {(($y << 2) & 0x3C)}]] + ADD = } return $result } + proc ::base64::ADD {x} { + # The line length check is always done before appending so + # that we don't get an extra newline if the output is a + # multiple of $maxlen chars long. + + upvar 1 maxlen maxlen length length result result wrapchar wrapchar + if {$maxlen && $length >= $maxlen} { + append result $wrapchar + set length 0 + } + append result $x + incr length + return + } + # ::base64::decode -- # # Base64 decode a given string. @@ -302,7 +357,6 @@ if {![catch {package require Trf 2.0}]} { foreach {v w z} $nums break set a [expr {($v << 2) | (($w & 0x30) >> 4)}] - if {$z == {}} { append output [binary format c $a ] } else { @@ -322,4 +376,4 @@ if {![catch {package require Trf 2.0}]} { } } -package provide base64 2.3.1 +package provide base64 2.4.1 diff --git a/lib/base64/pkgIndex.tcl b/lib/base64/pkgIndex.tcl index 0c6384c..ee3804c 100644 --- a/lib/base64/pkgIndex.tcl +++ b/lib/base64/pkgIndex.tcl @@ -1,14 +1,4 @@ -# 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.1 [list source [file join $dir base64.tcl]] -#package ifneeded uuencode 1.1.2 [list source [file join $dir uuencode.tcl]] -#package ifneeded yencode 1.1.1 [list source [file join $dir yencode.tcl]] +package ifneeded base64 2.4.1 [list source [file join $dir base64.tcl]] +#package ifneeded uuencode 1.1.5 [list source [file join $dir uuencode.tcl]] +#package ifneeded yencode 1.1.3 [list source [file join $dir yencode.tcl]] diff --git a/lib/chatwidget/ChangeLog b/lib/chatwidget/ChangeLog index 0131403..bd7c15e 100644 --- a/lib/chatwidget/ChangeLog +++ b/lib/chatwidget/ChangeLog @@ -1,3 +1,9 @@ +2009-01-21 Andreas Kupries + + * + * Released and tagged Tklib 0.5 ======================== + * + 2008-06-20 Pat Thoyts * chatwidget.tcl: Fixed a number of minor bugs. diff --git a/lib/dns/dns.tcl b/lib/dns/dns.tcl index 2d742e6..c0a0244 100644 --- a/lib/dns/dns.tcl +++ b/lib/dns/dns.tcl @@ -29,7 +29,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- # -# $Id: dns.tcl,v 1.35 2007/08/26 00:44:34 patthoyts Exp $ +# $Id: dns.tcl,v 1.36 2008/11/22 12:28:54 mic42 Exp $ package require Tcl 8.2; # tcl minimum version package require logger; # tcllib 1.3 @@ -38,8 +38,8 @@ package require uri::urn; # tcllib 1.2 package require ip; # tcllib 1.7 namespace eval ::dns { - variable version 1.3.2 - variable rcsid {$Id: dns.tcl,v 1.35 2007/08/26 00:44:34 patthoyts Exp $} + variable version 1.3.3 + variable rcsid {$Id: dns.tcl,v 1.36 2008/11/22 12:28:54 mic42 Exp $} namespace export configure resolve name address cname \ status reset wait cleanup errorcode @@ -913,7 +913,7 @@ proc ::dns::Flags {token {varname {}}} { set flags(authoritative) [expr {($hdr & 0x0400) >> 10}] set flags(truncated) [expr {($hdr & 0x0200) >> 9}] set flags(recursion_desired) [expr {($hdr & 0x0100) >> 8}] - set flafs(recursion_allowed) [expr {($hdr & 0x0080) >> 7}] + set flags(recursion_allowed) [expr {($hdr & 0x0080) >> 7}] set flags(errorcode) [expr {($hdr & 0x000F)}] return [array get flags] diff --git a/lib/dns/ip.tcl b/lib/dns/ip.tcl index 1efb4d2..6d67ab8 100644 --- a/lib/dns/ip.tcl +++ b/lib/dns/ip.tcl @@ -9,15 +9,15 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- # -# $Id: ip.tcl,v 1.12 2007/08/20 20:03:04 andreas_kupries Exp $ +# $Id: ip.tcl,v 1.13 2009/04/13 20:33:17 andreas_kupries Exp $ # @mdgen EXCLUDE: ipMoreC.tcl package require Tcl 8.2; # tcl minimum version namespace eval ip { - variable version 1.1.2 - variable rcsid {$Id: ip.tcl,v 1.12 2007/08/20 20:03:04 andreas_kupries Exp $} + variable version 1.1.3 + variable rcsid {$Id: ip.tcl,v 1.13 2009/04/13 20:33:17 andreas_kupries Exp $} namespace export is version normalize equal type contract mask #catch {namespace ensemble create} @@ -68,7 +68,7 @@ proc ::ip::is {class ip} { proc ::ip::version {ip} { set version -1 foreach {addr mask} [split $ip /] break - if {[string first $addr :] < 0 && [IPv4? $addr]} { + if {[IPv4? $addr]} { set version 4 } elseif {[IPv6? $addr]} { set version 6 @@ -165,6 +165,9 @@ proc ::ip::mask {ip} { # Returns true is the argument can be converted into an IPv4 address. # proc ::ip::IPv4? {ip} { + if {[string first : $ip] >= 0} { + return 0 + } if {[catch {Normalize4 $ip}]} { return 0 } diff --git a/lib/dns/pkgIndex.tcl b/lib/dns/pkgIndex.tcl index fad685b..c856342 100644 --- a/lib/dns/pkgIndex.tcl +++ b/lib/dns/pkgIndex.tcl @@ -1,9 +1,9 @@ # pkgIndex.tcl - # -# $Id: pkgIndex.tcl,v 1.18 2008/03/14 21:21:12 andreas_kupries Exp $ +# $Id: pkgIndex.tcl,v 1.20 2009/04/13 20:33:17 andreas_kupries Exp $ if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded dns 1.3.2 [list source [file join $dir dns.tcl]] +package ifneeded dns 1.3.3 [list source [file join $dir dns.tcl]] package ifneeded resolv 1.0.3 [list source [file join $dir resolv.tcl]] -package ifneeded ip 1.1.2 [list source [file join $dir ip.tcl]] +package ifneeded ip 1.1.3 [list source [file join $dir ip.tcl]] package ifneeded spf 1.1.1 [list source [file join $dir spf.tcl]] diff --git a/lib/irc/irc.tcl b/lib/irc/irc.tcl index f3ee41d..e9ba5e6 100644 --- a/lib/irc/irc.tcl +++ b/lib/irc/irc.tcl @@ -5,12 +5,12 @@ # Copyright (c) 2001-2003 by David N. Welton . # This code may be distributed under the same terms as Tcl. # -# $Id: irc.tcl,v 1.26 2006/04/23 22:35:57 patthoyts Exp $ +# $Id: irc.tcl,v 1.27 2008/08/05 20:40:04 andreas_kupries Exp $ package require Tcl 8.3 namespace eval ::irc { - variable version 0.6 + variable version 0.6.1 # counter used to differentiate connections variable conn 0 @@ -107,12 +107,18 @@ proc ::irc::connection { args } { set name [format "%s::irc%s" [namespace current] $conn] namespace eval $name { + variable sock + variable dispatch + variable linedata + variable config + set sock {} array set dispatch {} array set linedata {} array set config [array get ::irc::config] if { $config(logger) || $config(debug)} { package require logger + variable logger set logger [logger::init [namespace tail [namespace current]]] if { !$config(debug) } { ${logger}::disable debug } } diff --git a/lib/irc/pkgIndex.tcl b/lib/irc/pkgIndex.tcl index 3c4586b..df54b66 100644 --- a/lib/irc/pkgIndex.tcl +++ b/lib/irc/pkgIndex.tcl @@ -1,8 +1,8 @@ # pkgIndex.tcl -*- tcl -*- -# $Id: pkgIndex.tcl,v 1.9 2008/06/24 22:06:56 patthoyts Exp $ +# $Id: pkgIndex.tcl,v 1.10 2008/08/05 20:40:04 andreas_kupries Exp $ if { ![package vsatisfies [package provide Tcl] 8.3] } { # PRAGMA: returnok return } -package ifneeded irc 0.6 [list source [file join $dir irc.tcl]] package ifneeded picoirc 0.5.1 [list source [file join $dir picoirc.tcl]] +package ifneeded irc 0.6.1 [list source [file join $dir irc.tcl]] diff --git a/lib/jabberlib/jlibtls.tcl b/lib/jabberlib/jlibtls.tcl index b5ddb00..5aad409 100644 --- a/lib/jabberlib/jlibtls.tcl +++ b/lib/jabberlib/jlibtls.tcl @@ -3,17 +3,34 @@ # This file is part of the jabberlib. It provides support for the # tls network socket security layer. # -# Copyright (c) 2004 Mats Bengtsson +# Copyright (c) 2004-2008 Mats Bengtsson # # This file is distributed under BSD style license. # -# $Id: jlibtls.tcl,v 1.19 2007/07/23 15:11:43 matben Exp $ +# $Id: jlibtls.tcl,v 1.20 2008/08/21 07:27:27 matben Exp $ package require tls package require jlib package provide jlibtls 1.0 +proc jlib::tls_configure {jlibname args} { + + upvar ${jlibname}::locals locals + + foreach {key val} $args { + switch -- $key { + -certfile - + -keyfile - + -command { + set locals($key) $val + } + default { + return -code error "Illegal option \"$key\"" + } + } + } +} proc jlib::starttls {jlibname cmd args} { diff --git a/lib/jabberlib/pep.tcl b/lib/jabberlib/pep.tcl index eece5d6..712ea6f 100644 --- a/lib/jabberlib/pep.tcl +++ b/lib/jabberlib/pep.tcl @@ -9,7 +9,7 @@ # # This file is distributed under BSD style license. # -# $Id: pep.tcl,v 1.10 2007/09/06 13:20:47 matben Exp $ +# $Id: pep.tcl,v 1.11 2008/08/16 06:33:07 matben Exp $ # ############################# USAGE ############################################ # @@ -37,6 +37,16 @@ # NB: It is currently unclear there should be an id attribute in the item # element since PEP doesn't use it but pubsub do, and the experimental # OpenFire PEP implementation. +# +# NB: This seems not to work with ejabberd: +# +# 4.3.4 Sending the Last Published Item +# As mentioned, a PEP service MUST send the last published item to all +# new subscribers and to all newly-available resources for each subscriber, +# including the account owner itself. (That is, the default value +# of the "pubsub#send_last_published_item" node configuration field must +# be "on_sub_and_presence"; this behavior essentially mimics the +# functionality of presence as defined in XMPP IM.) package require jlib::disco package require jlib::pubsub @@ -169,6 +179,12 @@ proc jlib::pep::create {jlibname node args} { # Results: # none +# BUG: http://www.xmpp.org/extensions/xep-0163.html +# "Because PEP services must send notifications to the account owner, +# you too receive the notification at each of your resources..." +# +# This seems not to be working! + proc jlib::pep::publish {jlibname node itemE args} { eval {$jlibname pubsub publish $node -items [list $itemE]} $args } @@ -217,118 +233,6 @@ proc jlib::pep::subscribe {jlibname jid node args} { eval {$jlibname pubsub subscribe $jid $myjid2 -node $node} $args } -# @@@ OUTDATED; BACKUP !!!!!!!!!!!!!!! - -# jlib::pep::set_auto_subscribe -- -# -# Subscribe all available users automatically. - -proc jlib::pep::set_auto_subscribe {jlibname node args} { - upvar ${jlibname}::pep::autosub autosub - - array set argsA { - -command {} - } - array set argsA $args - set autosub($node,node) $node - set autosub($node,-command) $argsA(-command) - - # For those where we've already got presence. - set jidL [$jlibname roster getusers -type available] - foreach jid $jidL { - - # We may not yet have disco info for this. - if {[$jlibname disco iscategorytype gateway/* $jid]} { - continue - } - - # If Juliet's server supports PEP (thereby making juliet@capulet.com - # a virtual pubsub service), it MUST return an identity of "pubsub/pep" - $jlibname disco get_async items $jid \ - [list [namespace current]::OnDiscoItems $node] - } - - # And register an event handler for any presence. - if {!$autosub(presreg)} { - set autosub(presreg) 1 - $jlibname presence_register_int available \ - [namespace code [list PresenceEvent $node]] - } -} - -proc jlib::pep::list_auto_subscribe {jlibname} { - upvar ${jlibname}::pep::autosub autosub - - set nodes {} - foreach {key node} [array get autosub *,node] { - lappend nodes $node - } - return $nodes -} - -proc jlib::pep::have_auto_subscribe {jlibname node} { - upvar ${jlibname}::pep::autosub autosub - - return [info exists autosub($node,node)] -} - -proc jlib::pep::unset_auto_subscribe {jlibname node} { - upvar ${jlibname}::pep::autosub autosub - - array unset autosub $node,* - if {![llength [array names autosub *,node]]} { - set autosub(presreg) 0 - $jlibname presence_deregister_int available \ - [namespace code [list PresenceEvent $node]] - } -} - -proc jlib::pep::PresenceEvent {jlibname xmldata node} { - upvar ${jlibname}::pep::autosub autosub - variable state - - set type [wrapper::getattribute $xmldata type] - set from [wrapper::getattribute $xmldata from] - if {$type eq ""} { - set type "available" - } - set jid2 [jlib::barejid $from] - if {![$jlibname roster isitem $jid2]} { - return - } - if {[$jlibname disco iscategorytype gateway/* $from]} { - return - } - - # We should be careful not to disco/publish for each presence change. - # @@@ There is a small glitch here if user changes presence before we - # received its disco result. - if {![$jlibname disco isdiscoed info $from]} { - foreach {key node} [array get autosub $node,*] { - $jlibname disco get_async items $jid2 \ - [list [namespace current]::OnDiscoItems $node] - } - } -} - -proc jlib::pep::OnDiscoItems {node jlibname type from subiq args} { - - # Get contact PEP nodes. - if {$type eq "result"} { - set nodes [$jlibname disco nodes $from] - if {[lsearch -exact $nodes $node] >= 0} { - - # NEW PEP: - # If an entity is not subscribed to the account owner's presence, - # it MUST subscribe to a node using.... - set subscribe [$jlibname roster getsubscription $from] - set myjid2 [$jlibname myjid2] - $jlibname pubsub subscribe $from $myjid2 -node $node \ - -command $autosub($node,-command) - } - } -} - # We have to do it here since need the initProc before doing this. namespace eval jlib::pep { diff --git a/lib/log/log.tcl b/lib/log/log.tcl index a9f42ae..3904cfb 100644 --- a/lib/log/log.tcl +++ b/lib/log/log.tcl @@ -7,7 +7,7 @@ # See the file license.terms. package require Tcl 8 -package provide log 1.2 +package provide log 1.3 # ### ### ### ######### ######### ######### @@ -159,6 +159,9 @@ namespace eval ::log { # 0 - messages with with level are written out. # 1 - messages with this level are suppressed. + # Note: This initialization is partially overridden via + # 'log::lvSuppressLE' at the bottom of this file. + variable suppressed array set suppressed { emergency 0 @@ -225,7 +228,7 @@ proc ::log::lv2longform {level} { return $levelMap($level) } - return -code error "\"$level\" is no unique abbreviation of a level name" + return -code error "bad level \"$level\": must be [join [lreplace [levels] end end "or [lindex [levels] end]"] ", "]." } # log::lv2color -- @@ -839,7 +842,8 @@ proc ::log::Puts {level text} { return } - puts $chan "$level$fill($level) $text" + puts $chan "$level$fill($level) $text" + flush $chan return } diff --git a/lib/log/logger.tcl b/lib/log/logger.tcl index 7e69481..ce93fef 100644 --- a/lib/log/logger.tcl +++ b/lib/log/logger.tcl @@ -3,7 +3,7 @@ # Tcl implementation of a general logging facility. # # Copyright (c) 2003 by David N. Welton -# Copyright (c) 2004-2007 by Michael Schlenker +# Copyright (c) 2004-2008 by Michael Schlenker # Copyright (c) 2006 by Andreas Kupries # # See the file license.terms. @@ -14,7 +14,7 @@ package require Tcl 8.2 -package provide logger 0.8 +package provide logger 0.9 namespace eval ::logger { namespace eval tree {} @@ -33,6 +33,15 @@ namespace eval ::logger { variable RETURN_CODES [list "ok" "error" "return" "break" "continue"] } +# Try to load msgcat and fall back to format if it fails +if {[catch {package require msgcat}]} { + interp alias {} ::logger::mc {} ::format +} else { + namespace eval ::logger { + namespace import ::msgcat::mc + } +} + # ::logger::_nsExists -- # # Workaround for missing namespace exists in Tcl 8.2 and 8.3. @@ -213,7 +222,9 @@ proc ::logger::init {service} { variable levels set lvnum [lsearch -exact $levels $lv] if { $lvnum == -1 } { - return -code error "Invalid level '$lv' - levels are $levels" + return -code error \ + -errorcode [list LOGGER INVALID_LEVEL] \ + [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels] } variable enabled @@ -258,7 +269,9 @@ proc ::logger::init {service} { variable levels set lvnum [lsearch -exact $levels $lv] if { $lvnum == -1 } { - return -code error "Invalid level '$lv' - levels are $levels" + return -code error \ + -errorcode [list LOGGER INVALID_LEVEL] \ + [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels] } variable enabled @@ -328,11 +341,15 @@ proc ::logger::init {service} { if {[::logger::_cmdPrefixExists [lindex $args 0]]} { set levelchangecallback [lindex $args 0] } else { - return -code error "Invalid cmd '[lindex $args 0]' - does not exist" + return -code error \ + -errorcode [list LOGGER INVALID_CMD] \ + [::logger::mc "Invalid cmd '%s' - does not exist" [lindex $args 0]] } } default { - return -code error "Wrong # of arguments. Usage: \${log}::lvlchangeproc ?cmd?" + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc "Wrong # of arguments. Usage: \${log}::lvlchangeproc ?cmd?"] } } } @@ -386,7 +403,9 @@ proc ::logger::init {service} { set lvnum [lsearch -exact $levels $lv] if { ($lvnum == -1) && ($lv != "trace") } { - return -code error "Invalid level '$lv' - levels are $levels" + return -code error \ + -errorcode [list LOGGER INVALID_LEVEL] \ + [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels] } switch -exact -- [llength $args] { 0 { @@ -396,22 +415,31 @@ proc ::logger::init {service} { set cmd [lindex $args 0] if {[string equal "[namespace current]::${lv}cmd" $cmd]} {return} if {[llength [::info commands $cmd]]} { - proc ${lv}cmd {args} "uplevel 1 \[list $cmd \[lindex \$args end\]\]" + proc ${lv}cmd args [format {\ + uplevel 1 [list %s [expr {[llength $args]==1 ? [lindex $args end] : $args}]] + } $cmd] } else { - return -code error "Invalid cmd '$cmd' - does not exist" + return -code error \ + -errorcode [list LOGGER INVALID_CMD] \ + [::logger::mc "Invalid cmd '%s' - does not exist" $cmd] } set lvlcmds($lv) $cmd } 2 { foreach {arg body} $args {break} - proc ${lv}cmd {args} "_setservicename \$args; - set val \[${lv}customcmd \[lindex \$args end\]\] ; - _restoreservice; set val" + proc ${lv}cmd args [format {\ + _setservicename args + set val [%s [expr {[llength $args]==1 ? [lindex $args end] : $args}]] + _restoreservice + set val} ${lv}customcmd] proc ${lv}customcmd $arg $body set lvlcmds($lv) [namespace current]::${lv}customcmd } default { - return -code error "Usage: \${log}::logproc level ?cmd?\nor \${log}::logproc level argname body" + return -code error \ + -errorcode [list LOGGER WRONG_USAGE] \ + [::logger::mc \ + "Usage: \${log}::logproc level ?cmd?\nor \${log}::logproc level argname body" ] } } } @@ -440,11 +468,15 @@ proc ::logger::init {service} { 2 { if {[::logger::_cmdPrefixExists [lindex $args 0]]} { set delcallback [lindex $args 0] } else { - return -code error "Invalid cmd '[lindex $args 0]' - does not exist" + return -code error \ + -errorcode [list LOGGER INVALID_CMD] \ + [::logger::mc "Invalid cmd '%s' - does not exist" [lindex $args 0]] } } default { - return -code error "Wrong # of arguments. Usage: \${log}::delproc ?cmd?" + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc "Wrong # of arguments. Usage: \${log}::delproc ?cmd?"] } } } @@ -497,15 +529,27 @@ proc ::logger::init {service} { return $service } - proc _setservicename {arg} { + proc _setservicename {argname} { variable service variable oldname + upvar 1 $argname arg if {[llength $arg] <= 1} { return - } else { - set oldname $service - set service [lindex $arg end-1] } + + set count -1 + set newname "" + while {[string equal [lindex $arg [expr {$count+1}]] "-_logger::service"]} { + incr count 2 + set newname [lindex $arg $count] + } + if {[string equal $newname ""]} { + return + } + set oldname $service + set service $newname + # Pop off "-_logger::service " from argument list + set arg [lreplace $arg 0 $count] } proc _restoreservice {} { @@ -536,35 +580,42 @@ proc ::logger::init {service} { } "on" { if {[llength $args]} { - return -code error "wrong # args: should be \"trace on\"" + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc "wrong # args: should be \"trace on\""] } return [logger::_trace_on $service] } "off" { if {[llength $args]} { - return -code error "wrong # args: should be \"trace off\"" + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc "wrong # args: should be \"trace off\""] } return [logger::_trace_off $service] } "add" { if {![llength $args]} { return -code error \ - "wrong # args: should be \"trace add ?-ns? ...\"" + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc "wrong # args: should be \"trace add ?-ns? ...\""] } return [uplevel 1 [list ::logger::_trace_add $service $args]] } "remove" { if {![llength $args]} { return -code error \ - "wrong # args: should be \"trace remove ?-ns? ...\"" + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc "wrong # args: should be \"trace remove ?-ns? ...\""] } return [uplevel 1 [list ::logger::_trace_remove $service $args]] } default { return -code error \ - "Invalid action \"$action\": must be status, add, remove,\ - on, or off" + -errorcode [list LOGGER INVALID_ARG] \ + [::logger::mc "Invalid action \"%s\": must be status, add, remove,\ + on, or off" $action] } } } @@ -603,16 +654,20 @@ proc ::logger::init {service} { # OPTIMIZE: do not allow multiple aliases in the hierarchy # they can always be replaced by more efficient # direct aliases to the target procs. - interp alias {} [namespace current]::${lvl}cmd {} ${parent}::${lvl}cmd $service + interp alias {} [namespace current]::${lvl}cmd \ + {} ${parent}::${lvl}cmd -_logger::service $service } # inherit the starting loglevel of the parent service setlevel [${parent}::currentloglevel] } else { foreach lvl [concat [::logger::levels] "trace"] { - proc ${lvl}cmd {args} "_setservicename \$args ; - set val \[stdoutcmd $lvl \[lindex \$args end\]\] ; - _restoreservice; set val" + proc ${lvl}cmd args [format {\ + _setservicename args + set val [stdoutcmd %s [expr {[llength $args]==1 ? [lindex $args end] : $args}]] + _restoreservice + set val } $lvl] + set lvlcmds($lvl) [namespace current]::${lvl}cmd } } @@ -683,7 +738,9 @@ proc ::logger::setlevel {lv} { variable enabled variable levels if {[lsearch -exact $levels $lv] == -1} { - return -code error "Invalid level '$lv' - levels are $levels" + return -code error \ + -errorcode [list LOGGER INVALID_LEVEL] \ + [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels] } set enabled $lv if {[catch { @@ -731,7 +788,9 @@ proc ::logger::levels {} { proc ::logger::servicecmd {service} { variable services if {[lsearch -exact $services $service] == -1} { - return -code error "Service \"$service\" does not exist." + return -code error \ + -errorcode [list LOGGER NO_SUCH_SERVICE] \ + [::logger::mc "Service \"%s\" does not exist." $service] } return "::logger::tree::${service}" } @@ -753,9 +812,12 @@ proc ::logger::import {args} { variable services if {[llength $args] == 0 || [llength $args] > 7} { - return -code error "Wrong # of arguments: \"logger::import ?-all?\ + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc \ + "Wrong # of arguments: \"logger::import ?-all?\ ?-force?\ - ?-prefix prefix? ?-namespace namespace? service\"" + ?-prefix prefix? ?-namespace namespace? service\""] } # process options @@ -780,9 +842,12 @@ proc ::logger::import {args} { set force 1 } default { - return -code error "Unknown argument: \"$opt\" :\nUsage:\ - \"logger::import ?-all? ?-force?\ - ?-prefix prefix? ?-namespace namespace? service\"" + return -code error \ + -errorcode [list LOGGER UNKNOWN_ARG] \ + [::logger::mc \ + "Unknown argument: \"%s\" :\nUsage:\ + \"logger::import ?-all? ?-force?\ + ?-prefix prefix? ?-namespace namespace? service\"" $opt] } } } @@ -804,7 +869,9 @@ proc ::logger::import {args} { set service [lindex $args 0] if {[lsearch -exact $services $service] == -1} { - return -code error "Service \"$service\" does not exist." + return -code error \ + -errorcode [list LOGGER NO_SUCH_SERVICE] \ + [::logger::mc "Service \"%s\" does not exist." $service] } # @@ -835,7 +902,9 @@ proc ::logger::import {args} { set cmdname ${importns}::${prefix}$cmd set collision [llength [info commands $cmdname]] if {$collision && !$force} { - return -code error "can't import command \"$cmdname\": already exists" + return -code error \ + -errorcode [list LOGGER IMPORT_NAME_EXISTS] \ + [::logger::mc "can't import command \"%s\": already exists" $cmdname] } lappend imports ${importns}::${prefix}$cmd ${sourcens}::${cmd} } @@ -921,7 +990,8 @@ proc ::logger::_trace_on { service } { if {[package vcompare $tcl_version "8.4"] < 0} { return -code error \ - "execution tracing is not available in Tcl $tcl_version" + -errorcode [list LOGGER TRACE_NOT_AVAILABLE] \ + [::logger::mc "execution tracing is not available in Tcl %s" $tcl_version] } namespace eval ::logger::tree::${service} { @@ -968,7 +1038,9 @@ proc ::logger::_trace_get_proclist { inputList } { set inputList [lrange $inputList 1 end] if {![llength $inputList]} { - return -code error "Must specify at least one namespace target" + return -code error \ + -errorcode [list LOGGER TARGET_MISSING] \ + [::logger::mc "Must specify at least one namespace target"] } # Rebuild the argument list to contain namespace procedures diff --git a/lib/log/pkgIndex.tcl b/lib/log/pkgIndex.tcl index 9158b68..2e4958c 100644 --- a/lib/log/pkgIndex.tcl +++ b/lib/log/pkgIndex.tcl @@ -1,8 +1,8 @@ if {![package vsatisfies [package provide Tcl] 8]} {return} -package ifneeded log 1.2 [list source [file join $dir log.tcl]] +package ifneeded log 1.3 [list source [file join $dir log.tcl]] if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded logger 0.8 [list source [file join $dir logger.tcl]] +package ifneeded logger 0.9 [list source [file join $dir logger.tcl]] package ifneeded logger::appender 1.3 [list source [file join $dir loggerAppender.tcl]] if {![package vsatisfies [package provide Tcl] 8.4]} {return} diff --git a/lib/sha1/sha1.tcl b/lib/sha1/sha1.tcl index 125c8f6..261218a 100644 --- a/lib/sha1/sha1.tcl +++ b/lib/sha1/sha1.tcl @@ -21,7 +21,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- # -# $Id: sha1.tcl,v 1.21 2007/05/03 21:41:10 andreas_kupries Exp $ +# $Id: sha1.tcl,v 1.22 2009/05/07 00:35:10 patthoyts Exp $ # @mdgen EXCLUDE: sha1c.tcl @@ -29,7 +29,7 @@ package require Tcl 8.2; # tcl minimum version namespace eval ::sha1 { variable version 2.0.3 - variable rcsid {$Id: sha1.tcl,v 1.21 2007/05/03 21:41:10 andreas_kupries Exp $} + variable rcsid {$Id: sha1.tcl,v 1.22 2009/05/07 00:35:10 patthoyts Exp $} variable accel array set accel {tcl 0 critcl 0 cryptkit 0 trf 0} diff --git a/lib/tooltip/pkgIndex.tcl b/lib/tooltip/pkgIndex.tcl index d007900..0efe09a 100644 --- a/lib/tooltip/pkgIndex.tcl +++ b/lib/tooltip/pkgIndex.tcl @@ -1,4 +1,4 @@ # -*- tcl -*- -package ifneeded tooltip 1.4.2 [list source [file join $dir tooltip.tcl]] -package ifneeded tipstack 1.0 [list source [file join $dir tipstack.tcl]] +package ifneeded tooltip 1.4.4 [list source [file join $dir tooltip.tcl]] +package ifneeded tipstack 1.0.1 [list source [file join $dir tipstack.tcl]] diff --git a/lib/tooltip/tipstack.tcl b/lib/tooltip/tipstack.tcl index de6069a..b55df75 100644 --- a/lib/tooltip/tipstack.tcl +++ b/lib/tooltip/tipstack.tcl @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tipstack.tcl,v 1.3 2006/04/04 23:56:36 andreas_kupries Exp $ +# RCS: @(#) $Id: tipstack.tcl,v 1.4 2009/01/09 05:46:12 andreas_kupries Exp $ # # ### ######### ########################### @@ -166,4 +166,4 @@ namespace eval ::tipstack { # ### ######### ########################### # Ready -package provide tipstack 1.0 +package provide tipstack 1.0.1 diff --git a/lib/tooltip/tooltip.tcl b/lib/tooltip/tooltip.tcl index 4f5b88c..f6c3dea 100644 --- a/lib/tooltip/tooltip.tcl +++ b/lib/tooltip/tooltip.tcl @@ -7,13 +7,12 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tooltip.tcl,v 1.13 2008/07/14 22:53:02 hobbs Exp $ +# RCS: @(#) $Id: tooltip.tcl,v 1.16 2008/12/01 23:37:16 hobbs Exp $ # # Initiated: 28 October 1996 package require Tk 8.4 -package provide tooltip 1.4.2 package require msgcat #------------------------------------------------------------------------ @@ -39,11 +38,15 @@ package require msgcat # enable OR on # Enables tooltips for defined widgets. # -# ?-index index? ?-item id? ?message? +# ?-index index? ?-items id? ?-tag tag? ?message? # If -index is specified, then is assumed to be a menu # and the index represents what index into the menu (either the # numerical index or the label) to associate the tooltip message with. # Tooltips do not appear for disabled menu items. +# If -item is specified, then is assumed to be a listbox +# or canvas and the itemId specifies one or more items. +# If -tag is specified, then is assumed to be a text +# and the tagId specifies a tag. # If message is {}, then the tooltip for that widget is removed. # The widget must exist prior to calling tooltip. The current # tooltip message for is returned, if any. @@ -62,22 +65,33 @@ package require msgcat namespace eval ::tooltip { namespace export -clear tooltip + variable labelOpts variable tooltip variable G - array set G { - enabled 1 - fade 1 - FADESTEP 0.2 - FADEID {} - DELAY 500 - AFTERID {} - LAST -1 - TOPLEVEL .__tooltip__ + if {![info exists G]} { + array set G { + enabled 1 + fade 1 + FADESTEP 0.2 + FADEID {} + DELAY 500 + AFTERID {} + LAST -1 + TOPLEVEL .__tooltip__ + } + if {[tk windowingsystem] eq "x11"} { + set G(fade) 0 ; # don't fade by default on X11 + } } - if {[tk windowingsystem] eq "x11"} { - set G(fade) 0 ; # don't fade by default on X11 + if {![info exists labelOpts]} { + # Undocumented variable that allows users to extend / override + # label creation options. Must be set prior to first registry + # of a tooltip, or destroy $::tooltip::G(TOPLEVEL) first. + set labelOpts [list -highlightthickness 0 -relief solid -bd 1 \ + -background lightyellow -fg black] } + # The extra ::hide call in is necessary to catch moving to # child widgets where the event won't be generated bind Tooltip [namespace code { @@ -136,6 +150,8 @@ proc ::tooltip::tooltip {w args} { } set b $G(TOPLEVEL) if {![winfo exists $b]} { + variable labelOpts + toplevel $b -class Tooltip if {[tk windowingsystem] eq "aqua"} { ::tk::unsupported::MacWindowStyle style $b help none @@ -147,8 +163,7 @@ proc ::tooltip::tooltip {w args} { catch {wm attributes $b -alpha 0.99} wm positionfrom $b program wm withdraw $b - label $b.label -highlightthickness 0 -relief solid -bd 1 \ - -background lightyellow -fg black + eval [linsert $labelOpts 0 label $b.label] pack $b.label -ipadx 1 } if {[info exists tooltip($i)]} { return $tooltip($i) } @@ -159,6 +174,7 @@ proc ::tooltip::tooltip {w args} { proc ::tooltip::register {w args} { variable tooltip set key [lindex $args 0] + set class [winfo class $w] while {[string match -* $key]} { switch -- $key { -index { @@ -169,16 +185,16 @@ proc ::tooltip::register {w args} { set index [lindex $args 1] set args [lreplace $args 0 1] } - -item { - set namedItem [lindex $args 1] - if {[catch {$w find withtag $namedItem} item]} { - return -code error "widget \"$w\" is not a canvas, or item\ - \"$namedItem\" does not exist in the canvas" - } - if {[llength $item] > 1} { - return -code error "item \"$namedItem\" specifies more\ - than one item on the canvas" - } + -item - -items { + if {$class eq "Listbox" || $class eq "Treeview"} { + set items [lindex $args 1] + } else { + set namedItem [lindex $args 1] + if {[catch {$w find withtag $namedItem} items]} { + return -code error "widget \"$w\" is not a canvas, or\ + item \"$namedItem\" does not exist in the canvas" + } + } set args [lreplace $args 0 1] } -tag { @@ -192,14 +208,14 @@ proc ::tooltip::register {w args} { } default { return -code error "unknown option \"$key\":\ - should be -index or -item" + should be -index, -items or -tag" } } set key [lindex $args 0] } if {[llength $args] != 1} { return -code error "wrong # args: should be \"tooltip widget\ - ?-index index? ?-item item? ?-tag tag? message\"" + ?-index index? ?-items item? ?-tag tag? message\"" } if {$key eq ""} { clear $w @@ -210,10 +226,20 @@ proc ::tooltip::register {w args} { if {[info exists index]} { set tooltip($w,$index) $key return $w,$index - } elseif {[info exists item]} { - set tooltip($w,$item) $key - enableCanvas $w $item - return $w,$item + } elseif {[info exists items]} { + foreach item $items { + set tooltip($w,$item) $key + if {$class eq "Listbox"} { + enableListbox $w $item + } elseif {$class eq "Treeview"} { + enableTreeview $w $item + } else { + enableCanvas $w $item + } + } + # Only need to return the first item for the purposes of + # how this is called + return $w,[lindex $items 0] } elseif {[info exists tag]} { set tooltip($w,t_$tag) $key enableTag $w $tag @@ -377,6 +403,52 @@ proc ::tooltip::wname {{w {}}} { return $G(TOPLEVEL) } +proc ::tooltip::listitemTip {w x y} { + variable tooltip + variable G + + set G(LAST) -1 + set item [$w index @$x,$y] + if {$G(enabled) && [info exists tooltip($w,$item)]} { + set G(AFTERID) [after $G(DELAY) \ + [namespace code [list show $w $tooltip($w,$item) cursor]]] + } +} + +# Handle the lack of / between listbox items using +proc ::tooltip::listitemMotion {w x y} { + variable tooltip + variable G + if {$G(enabled)} { + set item [$w index @$x,$y] + if {$item ne $G(LAST)} { + set G(LAST) $item + after cancel $G(AFTERID) + catch {wm withdraw $G(TOPLEVEL)} + if {[info exists tooltip($w,$item)]} { + set G(AFTERID) [after $G(DELAY) \ + [namespace code [list show $w $tooltip($w,$item) cursor]]] + } + } + } +} + +# Initialize tooltip events for Treeview widgets +proc ::tooltip::enableTreeview {w args} { + if {[string match *treeviewitemTip* [bind $w ]]} { return } + +} + +# Initialize tooltip events for Listbox widgets +proc ::tooltip::enableListbox {w args} { + if {[string match *listitemTip* [bind $w ]]} { return } + bind $w +[namespace code [list listitemTip %W %x %y]] + bind $w +[namespace code [list listitemMotion %W %x %y]] + bind $w +[namespace code [list hide 1]] ; # fade ok + bind $w +[namespace code hide] + bind $w +[namespace code hide] +} + proc ::tooltip::itemTip {w args} { variable tooltip variable G @@ -402,6 +474,7 @@ proc ::tooltip::tagTip {w tag} { variable G set G(LAST) -1 if {$G(enabled) && [info exists tooltip($w,t_$tag)]} { + if {[info exists G(AFTERID)]} { after cancel $G(AFTERID) } set G(AFTERID) [after $G(DELAY) \ [namespace code [list show $w $tooltip($w,t_$tag) cursor]]] } @@ -414,3 +487,5 @@ proc ::tooltip::enableTag {w tag} { $w tag bind $tag +[namespace code hide] $w tag bind $tag +[namespace code hide] } + +package provide tooltip 1.4.4 -- 2.23.0