This is a library written out of frustration. One of our production service keep running out of file descriptors at our hosting provider. This is probably because the processes are running under OpenVZ (which needs to mitigate all the resources between all containers). I got tired of trying to circumvent what I believe is a bug in the
ftpd implementation, I have good hopes that the library below might solve it. What does it do? The library is able to place a number of present and future channels matching a given pattern under observation: when no activity has been discovered on a matching channel for a given period of time, the channel is automatically closed, unless a last-minute callback tells the library the opposite. The library also has a list of protected channels, channels that will not be placed under its supervision.
EF## Module Name -- autoclose.tcl
## Description:
##
## Automatically close channels which names match a pattern after some
## period of inactivity. A command callback can be provided to decide
## whether a specific channel should be automatically closed or not. In
## addition, the module supports a list of protected channels, i.e.
## channels that will not be considered for autoclosing at all. This is
## usefull for server socket channels for example, or for long-lived
## channels (socket clients?).
##
## This module is able to automatically detect client sockets whenever
## server sockets have been registered and incoming clients are detected.
##
package require Tcl 8.5
namespace eval ::autoclose {
namespace eval vars {
variable version 0.1; # Package version number
variable generator 0; # Generator for identifiers
variable captured 0; # Global I/O commands captured?
variable debug ""; # Name of channel to output debug, empty for none
variable protected {}; # List of channels not under supervision
variable -silence 5000; # Default silence period for new supervisors.
variable -command {}; # Default autoclose callback for new supervisors.
}
# Sub-namespace to hold details for channels under supervision
namespace eval channels {}
}
# ::autoclose::overlook -- Create a supervision group
#
# Create a supervision group, i.e. start watching for file operations for
# all channels which name match the pattern passed as a parameter and
# arrange to autoclose the channel whenever no activity has been seen on
# the channel for a given period of time. This procedure takes the
# following set of dash-led options:
#
# -silence The inactivity period, in milliseconds (defaults to 5 s.)
# -command Command to call before autoclosing, should return a boolean.
#
# Arguments:
# ptn Pattern matching the names of the channels to supervise
# args List of dash-led options and their arguments.
#
# Results:
# An identifier that might be used in future versions of this package.
#
# Side Effects:
# Will watch all I/O operations on the matching channels to detect
# activity.
proc ::autoclose::overlook { ptn args } {
# Create a supervision group of channels (even though, theoretically, the
# pattern could match a single channel). Initialise the group to good
# defaults.
set ac [namespace current]::vars::group[incr vars::generator]
upvar \#0 $ac GRP
set GRP(id) $ac
set GRP(pattern) $ptn
set GRP(-silence) ${vars::-silence}
set GRP(-command) ${vars::-command}
# Parse the options from the arguments. This is basic, but will do.
foreach opt [dict keys $args] {
switch -- $opt {
-silence -
-command {
set GRP($opt) [dict get $args $opt]
}
default {
return -code error \
"$ptn is an unknown argument, should be one of [join [array names GRP -*] ,\ ]"
}
}
}
# If all I/O commands haven't been captured to be routed through this
# module, arrange to do so. The current implementation routes I/O commands
# to internal commands to this module, with the first letter capitalised to
# make sure we follow Tcl-calling conventions. The original command is
# placed in this module under its original name, with the suffix Orig
# appended. The loop below is also able to route an original command to a
# generic dispatcher if necessary.
if { !$vars::captured } {
foreach cmd [list open close [list gets Capture] [list eof Capture] \
[list fblocked Capture] [list fconfigure Capture] \
fcopy [list fileevent Capture] puts read socket \
[list flush Capture] [list seek Capture] \
[list tell Capture]] {
# Capture the original command to capture and the internal
# dispatcher that it should be routed to, if applicable.
lassign $cmd orig internal
# Rename original command into this namespace to avoid conflicts.
# Add the suffix Orig.
rename ::$orig [namespace current]::${orig}Orig
# Now either renamed with first capitalized letter, or rename so as
# to go through the dispatcher.
if { $internal eq "" } {
set internal [string toupper [string index $orig 0]][string range $orig 1 end]
interp alias {} $orig {} [namespace current]::$internal
} else {
interp alias {} $orig {} [namespace current]::$internal $orig
}
}
# Remember that we have captured, we don't want/need to do this twice.
set vars::captured 1
}
}
# ::autoclose::protect -- Protect a channel from autoclose
#
# Arrange for an existing channel to be protected from autoclose
# mechanisms. The channel will automatically be removed from the
# protection list when it is closed.
#
# Arguments:
# channel Channel to protect (empty allowed)
#
# Results:
# Return the list of currently protected channels.
#
# Side Effects:
# None.
proc ::autoclose::protect { { channel "" } } {
if { $channel ne "" && [lsearch $vars::protected $channel] < 0 } {
Cancel $channel
lappend vars::protected $channel
}
return $vars::protected
}
# ::autoclose::unprotect -- Unprotect a channel from autoclose
#
# Remove a channel from the list of channels being excempted to autoclose
# after inactivity.
#
# Arguments:
# channel Channel to unprotect
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::autoclose::unprotect { channel } {
set idx [lsearch $vars::protected $channel]
if { $idx >= 0 } {
set vars::protected [lreplace $vars::protected $idx $idx]
}
}
# ::autoclose::discovery -- Channel discovery information
#
# This procedure will return how the channel passed as an argument was
# discovered by this module. The discovery list consists of the stack that
# led to discovery for this channel, each item in the list containing the
# procedure and argument call at that time. The typical usage of this
# procedure is either to automatically protect channels that would
# otherwise be hidden from the caller, or to help debugging when looking
# for a missing close call (which is the leading reason for writing this
# module).
#
# Arguments:
# channel Channel (probably supervised by this module)
#
# Results:
# List of procedure and arguments calls at the time this module picked up
# the channel for supervision, an empty list for channels outside our
# supervision.
#
# Side Effects:
# None.
proc ::autoclose::discovery {channel} {
set c [namespace current]::channels::$channel
if { [info exists $c] } {
return [dict get [set $c] discovery]
}
return [list]
}
## Below are internal procedures
# ::autoclose::Debug -- Conditional debug
#
# Output a messages whenever the global debug variable is set to the name
# of a channel.
#
# Arguments:
# msg Debug text to output
#
# Results:
# None.
#
# Side Effects:
# Output message on channel.
proc ::autoclose::Debug { msg } {
if { $vars::debug ne "" } {
putsOrig $vars::debug $msg
}
}
# ::autoclose::Supervised -- Should a channel be supervised
#
# Should a channel be supervised and autoclose after a period of
# inactivity? This respects the list of channels that are protected from
# the mechanisms in this module and looks for a matching channel group.
#
# Arguments:
# channel Channel to enquire
#
# Results:
# Return the identifier of the first autoclose supervision group which
# pattern matches the name of the channel, if the channel wasn't
# protected.
#
# Side Effects:
# None.
proc ::autoclose::Supervised { channel } {
if { [lsearch $vars::protected $channel] < 0 } {
foreach ac [info vars [namespace current]::vars::group*] {
upvar \#0 $ac GRP
if { [string match $GRP(pattern) $channel] } {
Debug "$channel will be auto-closed after $GRP(-silence) of inactivity"
return $ac
}
}
}
return ""
}
# ::autoclose::ForceClose -- Force channel close operation
#
# Force a close operation on the channel, possibly in synchrony with the
# callback that was provided for the group to which the channel belongs.
# This procedure is registered as the inactivity callback.
#
# Arguments:
# ac Identifier of the supervision group.
# channel Channel to close
#
# Results:
# None.
#
# Side Effects:
# Close the channel.
proc ::autoclose::ForceClose { ac channel } {
# Access supervision group to which the channel belongs, fail early.
if { ![info exists $ac] } {
return
}
upvar \#0 $ac GRP
# If we still know something about the channel, close it in concert with the
# callback that has been registered as part of the supervision group. The
# default is to close whenever there isn't any callback. When there is a
# callback, it should return a boolean telling to close (on) or not (off).
set c [namespace current]::channels::$channel
if { [info exists $c] } {
Debug "Inactivity period for $channel reached, forcing close"
# Callback to mediate imminent autoclosing of channel. Arrange to store
# the successfull result of the callback in the closeIt variable.
set closeIt 1
if { [llength $GRP(-command)] > 0 \
&& [catch {eval [linsert $GRP(-command) end $channel]} res] == 0 } {
set closeIt $res
}
# Don't autoclose if callback decided the other way.
if { [string is true $closeIt] } {
# Go through our own implementation on purpose, this will allow us
# to remove internal state.
Close $channel
}
}
}
# ::autoclose::Account -- Register activity
#
# Account for activity on the channel passed as argument. We arrange for
# the procedure AutoClose to be called after the inactivity period
#
# Arguments:
# ac Identifier of the supervision group.
# channel Channel to close
# cmd I/O command where activity was detected
#
# Results:
# None.
#
# Side Effects:
# Will automatically close the channel after -silence millseconds.
proc ::autoclose::Account { ac channel { cmd ""} } {
upvar \#0 $ac GRP
set c [namespace current]::channels::$channel
if { [info exists $c] } {
after cancel [dict get [set $c] timeout]
}
dict set $c channel $channel
dict set $c latest [clock milliseconds]
dict set $c timeout \
[after $GRP(-silence) [list [namespace current]::ForceClose $ac $channel]]
if { ![dict exists [set $c] discovery]} {
set disco [list]
set lvl [info level]
for {set l [expr {$lvl-1}]} {$l>=0} {incr l -1} {
lappend disco [info level $l]
}
dict set $c discovery $disco
}
Debug "Registered activity for $channel from $cmd"
}
# ::autoclose::Cancel -- Forget a channel autoclose
#
# Cancel an autoclose operation for a channel, if there was such an
# operation.
#
# Arguments:
# channel Channel (probably under supervision)
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::autoclose::Cancel { channel } {
set c [namespace current]::channels::$channel
if { [info exists $c] } {
set tmout [dict get [set $c] timeout]
if { $tmout ne "" } {
after cancel $tmout
}
dict set $c timeout ""
}
}
# ::autoclose::Open -- Shim around open
#
# This is our implementation of open. THe procedure arranges to start
# supervising the channel that was created by open if relevant.
#
# Arguments:
# fname Name of file (or pipe)
# args Additional arguments, as for open
#
# Results:
# Return the channel returned by the real open call.
#
# Side Effects:
# None.
proc ::autoclose::Open { fname args } {
set channel [uplevel 1 [linsert $args 0 [namespace current]::openOrig $fname]]
set ac [Supervised $channel]
if { $ac ne "" } {
Account $ac $channel open
}
return $channel
}
# ::autoclose::Close -- Shim around close
#
# Remove the channel from the supervision mechanisms, if there were such.
# Close it using the real close command.
#
# Arguments:
# channel Channel to be closed.
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::autoclose::Close { channel } {
set c [namespace current]::channels::$channel
if { [info exists $c] } {
# We catch cancelling to cope with empty timeouts (cancelled timeouts)
catch {after cancel [dict get [set $c] timeout]}
unset $c
}
unprotect $channel
return [[namespace current]::closeOrig $channel]
}
# ::autoclose::Capture -- Shim around many I/O commands
#
# This will call one of the many original I/O commands that start with a
# channel identifier in their arguments. The procedure accounts for
# activity on the channel.
#
# Arguments:
# orig Original command to call
# channel Channel to call command on
# args Additional arguments to command
#
# Results:
# Whatever was returned by the original command.
#
# Side Effects:
# None.
proc ::autoclose::Capture { orig channel args } {
set ac [Supervised $channel]
if { $ac ne "" } {
Account $ac $channel $orig
}
return [uplevel 1 [linsert $args 0 [namespace current]::${orig}Orig $channel]]
}
# ::autoclose::Fcopy -- Shim around fcopy
#
# This is a shim around the original fcopy. That is necessary since the
# command takes two channel identifiers as arguments. Note that since
# fcopy might be a long operation, channels that are concerned by an fcopy
# might be closed by this module too early.
#
# Arguments:
# inchan Input channel
# outchan Output channel
# args Additional arguments to fcopy
#
# Results:
# Whatever was returned by fcopy
#
# Side Effects:
# None.
proc ::autoclose::Fcopy { inchan outchan args } {
set ac [Supervised $inchan]
if { $ac ne "" } {
Account $ac $inchan fcopy
}
set ac [Supervised $outchan]
if { $ac ne "" } {
Account $ac $outchan fcopy
}
return [uplevel 1 [linsert $args 0 [namespace current]::fcopyOrig $inchan $outchan]]
}
# ::autoclose::Puts -- Shim around puts
#
# Shim around the origianl puts. puts is picky for its arguments, so we
# reconstruct carefully all the possible cases..
#
# Arguments:
# args Arguments to puts, reanalysed within the shim
#
# Results:
# Whatever is returned by the real puts.
#
# Side Effects:
# None.
proc ::autoclose::Puts {args} {
# puts is picky for its arguments, so we reconstruct carefully all the
# possible cases..
# Should we have a new line at the end?
set nonewline 0
if { [lindex $args 0] eq "-nonewline" } {
set nonewline 1
set args [lrange $args 1 end]
}
# Where to output (puts defaults to stdout)
set channel stdout
if { [llength $args] >= 2 } {
set channel [lindex $args 0]
set args [lrange $args 1 end]
}
# Now we can capture the channel and activity, if necessary and call the
# original puts
set ac [Supervised $channel]
if { $ac ne "" } {
Account $ac $channel puts
}
if { $nonewline } {
return [uplevel 1 [linsert $args 0 [namespace current]::putsOrig -nonewline $channel]]
} else {
return [uplevel 1 [linsert $args 0 [namespace current]::putsOrig $channel]]
}
}
# ::autoclose::Read -- Shim around read
#
# Shim around the real read call, this is necessary since it sometimes
# take the -nonewline as its first argument.
#
# Arguments:
# args Arguments to the real read
#
# Results:
# Whatever is returned by the real read.
#
# Side Effects:
# None.
proc ::autoclose::Read { args } {
set channel ""
if { [lindex $args 0] eq "-nonewline" } {
set channel [lindex $args 1]
} else {
set channel [lindex $args 0]
}
if { $channel ne "" } {
set ac [Supervised $channel]
if { $ac ne "" } {
Account $ac $channel read
}
}
return [uplevel 1 [linsert $args 0 [namespace current]::readOrig]]
}
# ::autoclose::SocketClient -- Intercepts socket clients
#
# This procedure is registered as the command of server sockets so we can
# get to know about incoming clients as soon as possible. If relevant, it
# will place the socket under supervision of this module before calling
# the command that should have been called on client connection.
#
# Arguments:
# cmd Command to callback with new client socket information
# channel Socket to client
# addr Address of remote client.
# port Port to remote client.
#
# Results:
# Returns whatever is returned by the client callback command.
#
# Side Effects:
# None.
proc ::autoclose::SocketClient { cmd channel addr port } {
# Place the socket under supervision, if relevant.
set ac [Supervised $channel]
if { $ac ne "" } {
Account $ac $channel socket
}
return [uplevel 1 [linsert $cmd end $channel $addr $port]]
}
# ::autoclose::Socket -- Shim around socket
#
# This is the shim around the real socket command. Whenever a server
# socket is declared, we arrange for one of our procedure to be called
# before the client command callback so we can, if relevant, start
# supervising the client socket as part of this module.
#
# Arguments:
# args Arguments to the socket command
#
# Results:
# Whatever was returned by the socket command.
#
# Side Effects:
# None.
proc ::autoclose::Socket { args } {
# Arrange to be able to capture clients.
set idx [lsearch $args "-server"]
if { $idx >= 0 } {
set cmd [lindex $args [expr {$idx+1}]]
set args [lreplace $args $idx [expr {$idx+1}]]
set channel [uplevel 1 [linsert $args 0 [namespace current]::socketOrig \
-server [list [namespace current]::SocketClient $cmd]]]
} else {
set channel [uplevel 1 [linsert $args 0 [namespace current]::socketOrig]]
}
# Place the socket under supervision, if relevant.
set ac [Supervised $channel]
if { $ac ne "" } {
Account $ac $channel socket
}
# Return the socket.
return $channel
}
package provide autoclose $::autoclose::vars::version
# Some pretty simplistic internal testing. We exercise the library by reading
# this file using a few different commands, and mostly at regular intervals and
# for a while. The number of "gets" below is computed so that we are sure that
# the library will trigger its autoclose mechanism before we attempt closing
# ourselves.
if { [info exists argv0] && [file normalize [info script]] eq [file normalize $argv0] } {
proc tryclose {fd {accept 1} {doexit 1}} {
puts "Closing $fd"
if { [catch {close $fd} err] } {
if { $accept } {
puts "Already closed as expected: $err"
} else {
puts "Error when closing $fd: $err"
}
}
if { $doexit } {
exit
}
}
proc tryread {fd header count} {
if { $count == 2 } {
set somechars [read $fd 34]
puts -nonewline ${header}${somechars}
} elseif { $count < 10 } {
set line [gets $fd]
puts ${header}${line}
}
if { $count < 10 } {
after 500 [list tryread $fd $header [incr count]]
}
}
::autoclose::overlook file*
set fd [open [info script] "RDONLY"]
puts "regular: Discovery for $fd: [::autoclose::discovery $fd]"
fconfigure $fd -buffering line
puts [read $fd]
seek $fd 0 start
tryread $fd "regular: " 0
after 20000 [list tryclose $fd]
set protected [open [info script] "RDONLY"]
puts "protected: Discovery for $protected: [::autoclose::discovery $protected]"
::autoclose::protect $protected
puts "Protected channels are [::autoclose::protect]"
after 10000 [list tryread $protected "protected:" 5]
after 17500 [list tryclose $protected 0 0]
vwait forever
}Future directions:
- Support for all the chan vocabulary
