# 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
# 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
# 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]\
# [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
}
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 \
#
# 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]
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]\
# [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]
# 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
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.
foreach {v w z} $nums break
set a [expr {($v << 2) | (($w & 0x30) >> 4)}]
-
if {$z == {}} {
append output [binary format c $a ]
} else {
}
}
-package provide base64 2.3.1
+package provide base64 2.4.1
-# 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]]
+2009-01-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tklib 0.5 ========================
+ *
+
2008-06-20 Pat Thoyts <patthoyts@users.sourceforge.net>
* chatwidget.tcl: Fixed a number of minor bugs.
# 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
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
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]
# 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}
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
# 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
}
# 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]]
# Copyright (c) 2001-2003 by David N. Welton <davidw@dedasys.com>.
# 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
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 }
}
# 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]]
# 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} {
#
# 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 ############################################
#
# 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
# 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
}
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 {
# See the file license.terms.
package require Tcl 8
-package provide log 1.2
+package provide log 1.3
# ### ### ### ######### ######### #########
# 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
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 --
return
}
- puts $chan "$level$fill($level) $text"
+ puts $chan "$level$fill($level) $text"
+ flush $chan
return
}
# Tcl implementation of a general logging facility.
#
# Copyright (c) 2003 by David N. Welton <davidw@dedasys.com>
-# Copyright (c) 2004-2007 by Michael Schlenker <mic42@users.sourceforge.net>
+# Copyright (c) 2004-2008 by Michael Schlenker <mic42@users.sourceforge.net>
# Copyright (c) 2006 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
#
# See the file license.terms.
package require Tcl 8.2
-package provide logger 0.8
+package provide logger 0.9
namespace eval ::logger {
namespace eval tree {}
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.
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
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
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?"]
}
}
}
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 {
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" ]
}
}
}
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?"]
}
}
}
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 <service>" from argument list
+ set arg [lreplace $arg 0 $count]
}
proc _restoreservice {} {
}
"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? <proc> ...\""
+ -errorcode [list LOGGER WRONG_NUM_ARGS] \
+ [::logger::mc "wrong # args: should be \"trace add ?-ns? <proc> ...\""]
}
return [uplevel 1 [list ::logger::_trace_add $service $args]]
}
"remove" {
if {![llength $args]} {
return -code error \
- "wrong # args: should be \"trace remove ?-ns? <proc> ...\""
+ -errorcode [list LOGGER WRONG_NUM_ARGS] \
+ [::logger::mc "wrong # args: should be \"trace remove ?-ns? <proc> ...\""]
}
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]
}
}
}
# 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
}
}
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 {
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}"
}
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
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]
}
}
}
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]
}
#
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}
}
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} {
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
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}
# 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
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}
# -*- 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]]
# 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 $
#
# ### ######### ###########################
# ### ######### ###########################
# Ready
-package provide tipstack 1.0
+package provide tipstack 1.0.1
# 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
#------------------------------------------------------------------------
# enable OR on
# Enables tooltips for defined widgets.
#
-# <widget> ?-index index? ?-item id? ?message?
+# <widget> ?-index index? ?-items id? ?-tag tag? ?message?
# If -index is specified, then <widget> 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 <widget> is assumed to be a listbox
+# or canvas and the itemId specifies one or more items.
+# If -tag is specified, then <widget> 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 <widget> is returned, if any.
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 <Enter> is necessary to catch moving to
# child widgets where the <Leave> event won't be generated
bind Tooltip <Enter> [namespace code {
}
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
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) }
proc ::tooltip::register {w args} {
variable tooltip
set key [lindex $args 0]
+ set class [winfo class $w]
while {[string match -* $key]} {
switch -- $key {
-index {
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 {
}
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
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
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 <Enter>/<Leave> between listbox items using <Motion>
+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 <Enter>]]} { return }
+
+}
+
+# Initialize tooltip events for Listbox widgets
+proc ::tooltip::enableListbox {w args} {
+ if {[string match *listitemTip* [bind $w <Enter>]]} { return }
+ bind $w <Enter> +[namespace code [list listitemTip %W %x %y]]
+ bind $w <Motion> +[namespace code [list listitemMotion %W %x %y]]
+ bind $w <Leave> +[namespace code [list hide 1]] ; # fade ok
+ bind $w <Any-KeyPress> +[namespace code hide]
+ bind $w <Any-Button> +[namespace code hide]
+}
+
proc ::tooltip::itemTip {w args} {
variable tooltip
variable G
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]]]
}
$w tag bind $tag <Any-KeyPress> +[namespace code hide]
$w tag bind $tag <Any-Button> +[namespace code hide]
}
+
+package provide tooltip 1.4.4
projects / Bullfrog / commitdiff