Merge commit '7c621da28f07e449ad90c387344f07a453927569' as 'tcllib'

5 files changed, 787 insertions, 0 deletions

diff --git a/tcllib/modules/multiplexer/ChangeLog b/tcllib/modules/multiplexer/ChangeLog
new file mode 100644
index 0000000..f83a537
--- /dev/null
+++ b/tcllib/modules/multiplexer/ChangeLog
@@ -0,0 +1,136 @@
+2013-02-01  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.15 ========================
+	* 
+
+2011-12-13  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.14 ========================
+	* 
+
+2011-11-10  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	* multiplexer.test: Re-merged the split test, and modified to
+	  accept both possible results. 8.6 can return an ipv4 address
+	  as well, depending on the OS configuration.
+
+2011-11-07  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	* multiplexer.test: Split a test with core version dependent
+	  results into two, one per possible result.
+
+2011-01-24  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.13 ========================
+	* 
+
+2009-12-07  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.12 ========================
+	* 
+
+2008-12-12  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.11.1 ========================
+	* 
+
+2008-10-16  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.11 ========================
+	* 
+
+2007-09-12  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.10 ========================
+	* 
+
+2007-03-21  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	* multiplexer.man: Fixed all warnings due to use of now deprecated
+	  commands. Added a section about how to give feedback.
+
+2006-10-29  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	* multiplexer.test: Accept anything matching 127.*.*.* as
+	  ip-address for localhost.
+
+2006-10-03  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.9 ========================
+	* 
+
+2006-01-23  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	* multiplexer.test: More boilerplate simplified via use of test support.
+
+2006-01-19  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	* multiplexer.test: Hooked into the new common test support code.
+
+2005-10-06  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.8 ========================
+	* 
+
+2004-10-05  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.7 ========================
+	* 
+
+2004-05-23  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.6.1 ========================
+	* 
+
+2004-02-15  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.6 ========================
+	* 
+
+2004-02-10  Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+	* multiplexer.man: This package is can be used with Tcl
+	* pkgIndex.tcl:    8.2. Documented as such.
+
+	* multiplexer.test: One test uses the 8.3'ism 'file
+	  channels'. Added constraint and skipping it when under Tcl
+	  8.2. Changed initialization code to ensure that the local
+	  multiplexer package is loaded, and not an installed one.
+
+2003-05-20  Andreas Kupries  <andreask@activestate.com>
+
+	* multiplexer.man: Cleaned up the documentation of the three hooks
+	  which can be set per multiplexer instance (access, data, exit).
+
+	* multiplexer.tcl: Made sendtoorigin a true boolean flag, instead
+	  of just 0/1.
+
+2003-05-19  David N. Welton  <davidw@dedasys.com>
+
+	* multiplexer.tcl (NewClient): Added access denied debug message
+	for accessfilter.
+
+	* multiplexer.man: Minor cleanups.
+
+	* multiplexer.test: Added several tests.
+
+	* multiplexer.tcl: Adding updated multiplexer to tcllib.  It is
+	now possible to run multiple multiplexer instances, and it uses
+	the logger package for logging.
+
+	* multiplexer.man: New file, still needs cleaning up.  Content
+	taken from old multiplexer.n.
+
+	* multiplexer.test: Added a few initial tests.  Working on more.
diff --git a/tcllib/modules/multiplexer/multiplexer.man b/tcllib/modules/multiplexer/multiplexer.man
new file mode 100644
index 0000000..d47e822
--- /dev/null
+++ b/tcllib/modules/multiplexer/multiplexer.man
@@ -0,0 +1,130 @@
+[comment {-*- tcl -*- doctools manpage}]
+[comment { $Id: multiplexer.man,v 1.11 2009/01/29 06:16:20 andreas_kupries Exp $ }]
+[manpage_begin multiplexer n 0.2]
+[keywords chat]
+[keywords multiplexer]
+[moddesc   {One-to-many communication with sockets.}]
+[titledesc {One-to-many communication with sockets.}]
+[category  {Programming tools}]
+[require Tcl 8.2]
+[require logger]
+[require multiplexer [opt 0.2]]
+[description]
+
+The [package multiplexer] package provides a generic system for one-to-many
+communication utilizing sockets.  For example, think of a chat system
+where one user sends a message which is then broadcast to all the
+other connected users.
+
+[para]
+
+It is possible to have different multiplexers running concurrently.
+
+[list_begin definitions]
+
+[call [cmd ::multiplexer::create]]
+
+The [cmd create] command creates a new multiplexer 'instance'.  For
+example:
+
+[example {set mp [::multiplexer::create]}]
+
+This instance can then be manipulated like so: [example {${mp}::Init 35100}]
+
+[call [cmd \${multiplexer_instance}::Init] [arg port]]
+
+This starts the multiplexer listening on the specified port.
+
+[call [cmd \${multiplexer_instance}::Config] [arg key] [arg value]]
+
+Use [cmd Config] to configure the multiplexer instance.  Configuration
+options currently include:
+
+[list_begin options]
+
+[opt_def sendtoorigin]
+
+A boolean flag. If [const true], the sender will receive a copy of the
+sent message.  Defaults to [const false].
+
+[opt_def debuglevel]
+
+Sets the debug level to use for the multiplexer instance, according to
+those specified by the [package logger] package (debug, info, notice,
+warn, error, critical).
+
+[list_end]
+
+[call [cmd \${multiplexer_instance}::AddFilter] [arg cmdprefix]]
+
+Command to add a filter for data that passes through the multiplexer
+instance.
+
+The registered [arg cmdprefix] is called when data arrives at a
+multiplexer instance. If there is more than one filter command
+registered at the instance they will be called in the order of
+registristation, and each filter will get the result of the preceding
+filter as its argument. The first filter gets the incoming data as its
+argument. The result returned by the last filter is the data which
+will be broadcast to all clients of the multiplexer instance.
+
+The command prefix is called as
+
+[list_begin definitions]
+[call [cmd cmdprefix] [arg data] [arg chan] [arg clientaddress] [arg clientport]]
+
+Takes the incoming [arg data], modifies it, and returns that as its
+result. The last three arguments contain information about the client
+which sent the data to filter: The channel connecting us to the
+client, its ip-address, and its ip-port.
+
+[list_end]
+
+[call [cmd \${multiplexer_instance}::AddAccessFilter] [arg cmdprefix]]
+
+Command to add an access filter.
+
+The registered [arg cmdprefix] is called when a new client socket
+tries to connect to the multixer instance. If there is more than one
+access filter command registered at the instance they will be called
+in the order of registristation. If any of the called commands returns
+[const -1] the access to the multiplexer instance is denied and the
+client channel is closed immediately. Any other result grants the
+client access to the multiplexer instance.
+
+The command prefix is called as
+
+[list_begin definitions]
+[call [cmd cmdprefix] [arg chan] [arg clientaddress] [arg clientport]]
+
+The arguments contain information about the client which tries to
+connected to the instance: The channel connecting us to the client,
+its ip-address, and its ip-port.
+
+[list_end]
+
+[call [cmd \${multiplexer_instance}::AddExitFilter] [arg cmdprefix]]
+
+Adds filter to be run when client socket generates an EOF condition.
+
+The registered [arg cmdprefix] is called when a client socket of the
+multixer signals EOF. If there is more than one exit filter command
+registered at the instance they will be called in the order of
+registristation. Errors thrown by an exit filter are ignored, but
+logged. Any result returned by an exit filter is ignored.
+
+The command prefix is called as
+
+[list_begin definitions]
+[call [cmd cmdprefix] [arg chan] [arg clientaddress] [arg clientport]]
+
+The arguments contain information about the client which signaled the
+EOF: The channel connecting us to the client, its ip-address, and its
+ip-port.
+
+[list_end]
+[list_end]
+
+[vset CATEGORY multiplexer]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/multiplexer/multiplexer.tcl b/tcllib/modules/multiplexer/multiplexer.tcl
new file mode 100644
index 0000000..e5dfe4b
--- /dev/null
+++ b/tcllib/modules/multiplexer/multiplexer.tcl
@@ -0,0 +1,291 @@
+# multiplexer.tcl -- one-to-many comunication with sockets
+#
+#	Implementation of a one-to-many multiplexer in Tcl utilizing
+#	sockets.
+
+# Copyright (c) 2001-2003 by David N. Welton <davidw@dedasys.com>
+
+# This file may be distributed under the same terms as Tcl.
+
+# $Id: multiplexer.tcl,v 1.4 2004/01/15 06:36:13 andreas_kupries Exp $
+
+package provide multiplexer 0.2
+package require logger
+
+namespace eval ::multiplexer {
+    variable Unique 0
+}
+
+proc ::multiplexer::create {} {
+    variable Unique
+    set ns ::multiplexer::mp$Unique
+
+    namespace eval $ns {
+	# Use the namespace as the logger name.
+	set log [logger::init [string trimleft [namespace current] ::]]
+	# list of connected clients
+	array set clients {}
+
+	# filters to run at access (socket accept) time
+	set accessfilters {}
+
+	# filters to run on data
+	set filters {}
+
+	# hook to run at exit time
+	set exitfilters {}
+
+	# config options
+	array set config {}
+	set config(sendtoorigin) 0
+	set config(debuglevel) warn
+	${log}::disable $config(debuglevel)
+	${log}::enable $config(debuglevel)
+
+	# AddAccessFilter --
+	#
+	# Command to add an access filter that will be called like so:
+	#
+	# AccessFilter chan clientaddress clientport
+	#
+	# Arguments:
+	#
+	# function: proc to filter access to the multiplexer.  Takes chan,
+	# clientaddress and clientport arguments.  Returns 0 on success, -1 on
+	# failure.
+
+	proc AddAccessFilter { function } {
+	    variable accessfilters
+	    lappend accessfilters $function
+	}
+
+	# AddFilter --
+
+	# Command to add a filter for data that passes through the
+	# multiplexer.  The filter proc is called like this:
+
+	# Filter data chan clientaddress clientport
+
+	# Arguments:
+
+	# function: proc to filter data that arrives to the
+	# multiplexer.
+	# Takes data, chan, clientaddress, and clientport arguments.  Returns
+	# filtered version of data.
+
+	proc AddFilter { function } {
+	    variable filters
+	    lappend filters $function
+	}
+
+	# AddExitFilter --
+
+	# Adds filter to be run when client socket generates an EOF condition.
+	# ExitFilter functions look like the following:
+
+	# ExitFilter chan clientaddress clientport
+
+	# Arguments:
+
+	# function: hook to be run when clients exit by generating an EOF.
+	# Takes chan, clientaddress and clientport arguments, and returns
+	# nothing.
+
+	proc AddExitFilter { function } {
+	    variable exitfilters
+	    lappend exitfilters $function
+	}
+
+	# DelClient --
+
+	# Deletes a client from the client list, and runs exit filters.
+
+	# Arguments:
+
+	# chan: channel that is closed.
+
+	# client: address of client
+
+	# clientport: port number of client.
+
+	proc DelClient { chan client clientport } {
+	    variable clients
+	    variable exitfilters
+	    variable config
+	    variable log
+	    foreach ef $exitfilters {
+		catch {
+		    $ef $chan $client $clientport
+		} err
+		${log}::debug "Error in DelClient: $err"
+	    }
+	    unset clients($chan)
+	    close $chan
+	}
+
+
+	# MultiPlex --
+
+	# Multiplex data
+
+	# Arguments:
+
+	# data - data to multiplex
+
+	proc MultiPlex { data {chan ""} } {
+	    variable clients
+	    variable config
+	    variable log
+
+	    foreach c [array names clients] {
+		if { $config(sendtoorigin) } {
+		    puts -nonewline $c "$data"
+		} else {
+		    if { $chan != $c } {
+			${log}::debug "Sending '$data' to $c"
+			puts -nonewline $c "$data"
+		    }
+		}
+	    }
+	}
+
+
+	# GetData --
+
+	# Get data from clients, filter it, redistribute it.
+
+	# Arguments:
+
+	# chan: open channel
+
+	# client: client address
+
+	# clientport: port number of client
+
+	proc GetData { chan client clientport } {
+	    variable filters
+	    variable clients
+	    variable config
+	    variable log
+	    if { ! [eof $chan] } {
+		set data [read $chan]
+	#	gets $chan data
+		${log}::debug "Tcl chan $chan from host $client and port $clientport sends: $data"
+		# do data filters
+		foreach f $filters {
+		    catch {
+			set data [$f $data $chan $client $clientport]
+		    } err
+		    ${log}::debug "GetData filter: $err"
+		}
+		set chans [array names clients]
+		MultiPlex $data $chan
+	    } else {
+		${log}::debug "Deleting client $chan from host $client and port $clientport."
+		DelClient $chan $client $clientport
+	    }
+	}
+
+	# NewClient --
+
+	# Sets up newly created connection after running access filters
+
+	# Arguments:
+
+	# chan: open channel
+
+	# client: client address
+
+	# clientport: port number of client
+
+	proc NewClient { chan client clientport } {
+	    variable clients
+	    variable config
+	    variable accessfilters
+	    variable log
+	    # run through access filters
+	    foreach af $accessfilters {
+		if { [$af $chan $client $clientport] == -1 } {
+		    ${log}::debug "Access denied to $chan $client $clientport"
+		    close $chan
+		    return
+		}
+	    }
+	    set clients($chan) $client
+
+	    # We want to read data and immediately send it out again.
+	    fconfigure $chan -blocking 0
+	    fconfigure $chan -buffering none
+	    fconfigure $chan -translation binary
+	    fileevent $chan readable [list [namespace current]::GetData $chan $client $clientport]
+	    ${log}::debug "Tcl channel $chan is host $client and port $clientport."
+	}
+
+	# Config --
+	#
+	# Configure global options, which currently include the
+	# following:
+	#
+	# sendtoorigin: if 1, resend the data to all clients, including the
+	# sender.  Defaults to 0
+	#
+	# debuglevel: a debug level understood by logger.
+	#
+	# Arguments:
+	#
+	# key: name of option to configure
+	#
+	# value: value for option.
+
+	proc Config { key value } {
+	    variable config
+	    variable log
+	    if { $key == "debuglevel" } {
+		${log}::disable $config(debuglevel)
+		${log}::enable $value
+	    }
+	    set config($key) $value
+	}
+
+	# Init --
+	#
+	# Start the server
+	#
+	# Arguments:
+	#
+	# port: port to listen on.
+
+	proc Init { port } {
+	    variable serversock
+	    set serversock [socket -server [namespace current]::NewClient $port]
+	}
+
+	# destroy --
+	#
+	#	Destroy multiplexer instance.  It is important to do
+	#	this, to free the resources used.
+	#
+	# Side Effects:
+	#	Deletes namespace associated with multiplexer
+	#	instance.
+
+
+	proc destroy { } {
+	    variable serversock
+	    foreach c [array names clients] {
+	        catch { close $c }
+	    }
+	    catch {
+		close $serversock
+	    }
+	    namespace delete [namespace current]
+	}
+
+    }
+    incr Unique
+    return $ns
+}
+
+namespace eval multiplexer {
+    namespace export create destroy
+}
diff --git a/tcllib/modules/multiplexer/multiplexer.test b/tcllib/modules/multiplexer/multiplexer.test
new file mode 100644
index 0000000..775aa97
--- /dev/null
+++ b/tcllib/modules/multiplexer/multiplexer.test
@@ -0,0 +1,218 @@
+# -*- tcl -*-
+# Tests for the multiplexer facility.
+#
+# Sourcing this file into Tcl runs the tests and generates output for
+# errors.
+# No output means no errors were found.
+#
+# Copyright (c) 2003 by David N. Welton <davidw@dedasys.com>.
+#
+# $Id: multiplexer.test,v 1.11 2011/11/14 18:49:27 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+	[file dirname [file dirname [file join [pwd] [info script]]]] \
+	devtools testutilities.tcl]
+
+testsNeedTcl     8.2
+testsNeedTcltest 1.0
+
+testing {
+    useLocal multiplexer.tcl multiplexer
+}
+
+# -------------------------------------------------------------------------
+
+test multiplexer-1.0 {create multiplexer} {
+    set mp [multiplexer::create]
+    set ns [namespace children ::multiplexer]
+    ${mp}::destroy
+    set ns
+} {::multiplexer::mp0}
+
+test multiplexer-1.1 {destroy multiplexer} {
+    set mp [multiplexer::create]
+    ${mp}::destroy
+    namespace children multiplexer
+} {}
+
+test multiplexer-2.1 {start multiplexer} {
+    set mp [multiplexer::create]
+    ${mp}::Init 37465
+    set res ""
+    if { [catch {
+	set sk [socket localhost 37465]
+    } err] } { set res $err }
+    ${mp}::destroy
+    set res
+} {}
+
+test multiplexer-2.2 {start & destroy multiplexer} {tcl8.3plus} {
+    set mp [multiplexer::create]
+    set startchans [lsort [file channels]]
+    ${mp}::Init 37465
+
+    set sk [socket localhost 37465]
+    catch { close $sk }
+
+    ${mp}::destroy
+    set chans [lsort [file channels]]
+    string compare $chans $startchans
+} {0}
+
+
+
+proc Get {chan} {
+    gets $chan line
+    if { [info exists ::forever] } {
+	incr ::forever
+    } else {
+	set ::forever 1
+    }
+}
+
+test multiplexer-3.1 {send multiplexer - line buffered} {
+    set ::forever 0
+    set mp [multiplexer::create]
+    ${mp}::Init 37465
+    set sk1 [socket localhost 37465]
+    set sk2 [socket localhost 37465]
+    set sk3 [socket localhost 37465]
+    fileevent $sk2 readable [list Get $sk2]
+    fileevent $sk3 readable [list Get $sk3]
+
+    fconfigure $sk1 -buffering line
+    fconfigure $sk2 -buffering line
+    fconfigure $sk3 -buffering line
+
+    update
+    puts $sk1 "Multiplexer test message 3.1"
+    # Each socket should receive a copy of the above message, so we
+    # have to vwait's.
+    vwait ::forever
+    vwait ::forever
+    ${mp}::destroy
+    set ::forever
+} {2}
+
+proc Get2 {chan} {
+    set line [read -nonewline $chan]
+    if { [info exists ::forever] } {
+	incr ::forever
+    } else {
+	set ::forever 1
+    }
+}
+
+test multiplexer-3.2 {send multiplexer - not buffered} {
+    set ::forever 0
+    set mp [multiplexer::create]
+    ${mp}::Init 37465
+    set sk1 [socket localhost 37465]
+    set sk2 [socket localhost 37465]
+    set sk3 [socket localhost 37465]
+    fileevent $sk2 readable [list Get2 $sk2]
+    fileevent $sk3 readable [list Get2 $sk3]
+
+    fconfigure $sk1 -buffering none
+    fconfigure $sk2 -buffering none -blocking 0
+    fconfigure $sk3 -buffering none -blocking 0
+
+    update
+    puts -nonewline $sk1 "Multiplexer test message 3.2"
+    # Each socket should receive a copy of the above message, so we
+    # have to vwait's.
+    vwait ::forever
+    vwait ::forever
+    ${mp}::destroy
+    set ::forever
+} {2}
+
+
+proc TestFilter {data chan clientaddress clientport} {
+    #puts "$data $chan $clientaddress $clientport"
+    return "Filtered data: $data"
+}
+
+proc Get3 {chan} {
+    gets $chan line
+    set ::forever $line
+}
+
+test multiplexer-4.1 {add filter} {
+    set ::forever 0
+    set mp [multiplexer::create]
+    ${mp}::Init 37465
+    ${mp}::AddFilter TestFilter
+    set sk1 [socket localhost 37465]
+    set sk2 [socket localhost 37465]
+    fileevent $sk2 readable [list Get3 $sk2]
+
+    fconfigure $sk1 -buffering line
+    fconfigure $sk2 -buffering line
+
+    update
+    puts $sk1 "Multiplexer test message 4.1"
+    # Each socket should receive a copy of the above message, so we
+    # have to vwait's.
+    vwait ::forever
+    ${mp}::destroy
+    set ::forever
+} {Filtered data: Multiplexer test message 4.1}
+
+proc TestAccessFilter {chan clientaddress clientport} {
+    lappend ::forever $clientaddress
+    return 0
+}
+
+test multiplexer-5.1 {add access filter} {
+    set ::forever {}
+    set mp [multiplexer::create]
+    ${mp}::Init 37465
+    ${mp}::AddAccessFilter TestAccessFilter
+    update
+    set sk1 [socket localhost 37465]
+    set sk2 [socket localhost 37465]
+
+    vwait ::forever
+    vwait ::forever
+    ${mp}::destroy
+
+    expr {
+	  [string match {127.*.*.* 127.*.*.*} $::forever] ||
+	  [string equal {::1 ::1}             $::forever]
+      }
+} 1
+
+proc DenyAccessFilter {chan clientaddress clientport} {
+    return -1
+}
+
+test multiplexer-5.2 {add access filter which denies access} {
+    set ::forever {}
+    set mp [multiplexer::create]
+    ${mp}::Init 37465
+    ${mp}::AddAccessFilter DenyAccessFilter
+    set sk1 [socket localhost 37465]
+    after idle {
+	update
+	fconfigure $sk1 -buffering none
+	if { [catch {
+	    puts $sk1 "boom"
+	    after 200	;# delay to overcome nagle - see ticket [ced089d5fe]
+	    puts $sk1 "tish"
+	} err] } {
+	    set ::forever "socket blocked"
+	} else {
+	    set ::forever "socket not blocked"
+	}
+    }
+    vwait ::forever
+    ${mp}::destroy
+    set forever
+} {socket blocked}
+
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/multiplexer/pkgIndex.tcl b/tcllib/modules/multiplexer/pkgIndex.tcl
new file mode 100644
index 0000000..51f2ad4
--- /dev/null
+++ b/tcllib/modules/multiplexer/pkgIndex.tcl
@@ -0,0 +1,12 @@
+# Tcl package index file, version 1.1
+# This file is generated by the "pkg_mkIndex" command
+# and sourced either when an application starts up or
+# by a "package unknown" script.  It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands.  When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+
+if { ![package vsatisfies [package provide Tcl] 8.2] } { return }
+package ifneeded multiplexer 0.2 [list source [file join $dir multiplexer.tcl]]