1# multiplexer.tcl -- one-to-many comunication with sockets
2#
3#	Implementation of a one-to-many multiplexer in Tcl utilizing
4#	sockets.
5
6# Copyright (c) 2001-2003 by David N. Welton <davidw@dedasys.com>
7
8# This file may be distributed under the same terms as Tcl.
9
10# $Id: multiplexer.tcl,v 1.4 2004/01/15 06:36:13 andreas_kupries Exp $
11
12package provide multiplexer 0.2
13package require logger
14
15namespace eval ::multiplexer {
16    variable Unique 0
17}
18
19proc ::multiplexer::create {} {
20    variable Unique
21    set ns ::multiplexer::mp$Unique
22
23    namespace eval $ns {
24	# Use the namespace as the logger name.
25	set log [logger::init [string trimleft [namespace current] ::]]
26	# list of connected clients
27	array set clients {}
28
29	# filters to run at access (socket accept) time
30	set accessfilters {}
31
32	# filters to run on data
33	set filters {}
34
35	# hook to run at exit time
36	set exitfilters {}
37
38	# config options
39	array set config {}
40	set config(sendtoorigin) 0
41	set config(debuglevel) warn
42	${log}::disable $config(debuglevel)
43	${log}::enable $config(debuglevel)
44
45	# AddAccessFilter --
46	#
47	# Command to add an access filter that will be called like so:
48	#
49	# AccessFilter chan clientaddress clientport
50	#
51	# Arguments:
52	#
53	# function: proc to filter access to the multiplexer.  Takes chan,
54	# clientaddress and clientport arguments.  Returns 0 on success, -1 on
55	# failure.
56
57	proc AddAccessFilter { function } {
58	    variable accessfilters
59	    lappend accessfilters $function
60	}
61
62	# AddFilter --
63
64	# Command to add a filter for data that passes through the
65	# multiplexer.  The filter proc is called like this:
66
67	# Filter data chan clientaddress clientport
68
69	# Arguments:
70
71	# function: proc to filter data that arrives to the
72	# multiplexer.
73	# Takes data, chan, clientaddress, and clientport arguments.  Returns
74	# filtered version of data.
75
76	proc AddFilter { function } {
77	    variable filters
78	    lappend filters $function
79	}
80
81	# AddExitFilter --
82
83	# Adds filter to be run when client socket generates an EOF condition.
84	# ExitFilter functions look like the following:
85
86	# ExitFilter chan clientaddress clientport
87
88	# Arguments:
89
90	# function: hook to be run when clients exit by generating an EOF.
91	# Takes chan, clientaddress and clientport arguments, and returns
92	# nothing.
93
94	proc AddExitFilter { function } {
95	    variable exitfilters
96	    lappend exitfilters $function
97	}
98
99	# DelClient --
100
101	# Deletes a client from the client list, and runs exit filters.
102
103	# Arguments:
104
105	# chan: channel that is closed.
106
107	# client: address of client
108
109	# clientport: port number of client.
110
111	proc DelClient { chan client clientport } {
112	    variable clients
113	    variable exitfilters
114	    variable config
115	    variable log
116	    foreach ef $exitfilters {
117		catch {
118		    $ef $chan $client $clientport
119		} err
120		${log}::debug "Error in DelClient: $err"
121	    }
122	    unset clients($chan)
123	    close $chan
124	}
125
126
127	# MultiPlex --
128
129	# Multiplex data
130
131	# Arguments:
132
133	# data - data to multiplex
134
135	proc MultiPlex { data {chan ""} } {
136	    variable clients
137	    variable config
138	    variable log
139
140	    foreach c [array names clients] {
141		if { $config(sendtoorigin) } {
142		    puts -nonewline $c "$data"
143		} else {
144		    if { $chan != $c } {
145			${log}::debug "Sending '$data' to $c"
146			puts -nonewline $c "$data"
147		    }
148		}
149	    }
150	}
151
152
153	# GetData --
154
155	# Get data from clients, filter it, redistribute it.
156
157	# Arguments:
158
159	# chan: open channel
160
161	# client: client address
162
163	# clientport: port number of client
164
165	proc GetData { chan client clientport } {
166	    variable filters
167	    variable clients
168	    variable config
169	    variable log
170	    if { ! [eof $chan] } {
171		set data [read $chan]
172	#	gets $chan data
173		${log}::debug "Tcl chan $chan from host $client and port $clientport sends: $data"
174		# do data filters
175		foreach f $filters {
176		    catch {
177			set data [$f $data $chan $client $clientport]
178		    } err
179		    ${log}::debug "GetData filter: $err"
180		}
181		set chans [array names clients]
182		MultiPlex $data $chan
183	    } else {
184		${log}::debug "Deleting client $chan from host $client and port $clientport."
185		DelClient $chan $client $clientport
186	    }
187	}
188
189	# NewClient --
190
191	# Sets up newly created connection after running access filters
192
193	# Arguments:
194
195	# chan: open channel
196
197	# client: client address
198
199	# clientport: port number of client
200
201	proc NewClient { chan client clientport } {
202	    variable clients
203	    variable config
204	    variable accessfilters
205	    variable log
206	    # run through access filters
207	    foreach af $accessfilters {
208		if { [$af $chan $client $clientport] == -1 } {
209		    ${log}::debug "Access denied to $chan $client $clientport"
210		    close $chan
211		    return
212		}
213	    }
214	    set clients($chan) $client
215
216	    # We want to read data and immediately send it out again.
217	    fconfigure $chan -blocking 0
218	    fconfigure $chan -buffering none
219	    fconfigure $chan -translation binary
220	    fileevent $chan readable [list [namespace current]::GetData $chan $client $clientport]
221	    ${log}::debug "Tcl channel $chan is host $client and port $clientport."
222	}
223
224	# Config --
225	#
226	# Configure global options, which currently include the
227	# following:
228	#
229	# sendtoorigin: if 1, resend the data to all clients, including the
230	# sender.  Defaults to 0
231	#
232	# debuglevel: a debug level understood by logger.
233	#
234	# Arguments:
235	#
236	# key: name of option to configure
237	#
238	# value: value for option.
239
240	proc Config { key value } {
241	    variable config
242	    variable log
243	    if { $key == "debuglevel" } {
244		${log}::disable $config(debuglevel)
245		${log}::enable $value
246	    }
247	    set config($key) $value
248	}
249
250	# Init --
251	#
252	# Start the server
253	#
254	# Arguments:
255	#
256	# port: port to listen on.
257
258	proc Init { port } {
259	    variable serversock
260	    set serversock [socket -server [namespace current]::NewClient $port]
261	}
262
263	# destroy --
264	#
265	#	Destroy multiplexer instance.  It is important to do
266	#	this, to free the resources used.
267	#
268	# Side Effects:
269	#	Deletes namespace associated with multiplexer
270	#	instance.
271
272
273	proc destroy { } {
274	    variable serversock
275	    foreach c [array names clients] {
276	        catch { close $c }
277	    }
278	    catch {
279		close $serversock
280	    }
281	    namespace delete [namespace current]
282	}
283
284    }
285    incr Unique
286    return $ns
287}
288
289namespace eval multiplexer {
290    namespace export create destroy
291}
292