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