##################
## 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    
}