source: code/archive/sound5/data/tcl/irk/lib/irkflow.tcl @ 9358

# irkflow.tcl
#
# Simple flow control management so as to avoid flooding.

namespace eval ::irk {

    # For each combination of destination+connection, we keep three items:
    # 
    # flowctl($dest,$conn,after)        The "after" token for the next time
    #                                   we send anything to this destination.
    # flowctl($dest,$conn,queue)        A list of items to send to this
    #                                   destination on this connection.
    # flowctl($dest,$conn,lastsend)     The time we last sent to this
    #                                   destination on this connection.
    #
    # NOTE: We do not limit the length of each item to send. This
    # would lead to extremely hard to diagnose bugs due to commands
    # (e.g. ctcp's) getting cut up into chunks.

    variable flowctl

    # The following setting controls how often (in msecs) we can send
    # to a given connection. It should not be modified by user code or
    # flooding may occur.

    set flowctl(floodlimit) 1500

    # This procedure sends an item to a specific destination+connection.
    # If possible, the item is sent right away. Otherwise it is enqueued
    # for later sending.

    proc sendit {conn item} {
        variable flowctl

        # If this connection has a backlog, append the new
        # items. Otherwise, check if the previous send was
        # less than flowctl(floodlimit) msecs ago. If so, enqueue
        # it for later sending. Otherwise send it now and record
        # the time we sent this item.

        if {[info exists flowctl($conn,after)]} {
            lappend flowctl($conn,queue) $item
        } else {
            if {[catch {set lastsend $flowctl($conn,lastsend)}]} {
                set lastsend 0
            }
            set now [clock clicks -milliseconds]
            set lim $flowctl(floodlimit)
            if {[expr $now - $lastsend] < $lim} {
                lappend flowctl($conn,queue) $item
                set wait [expr ($lim - ($now - $lastsend))]
                set flowctl($conn,after) \
                        [after $wait [list ::irk::sendlater $conn]]
            } else {
                set flowctl($conn,lastsend) $now
                puts $conn $item
            }
        }

        return ""
    }

    # This procedure does the sending when flow control for a connection
    # is activated.

    proc sendlater {conn} {
        variable flowctl

        # First of all clear the after entry.

        unset flowctl($conn,after)

        # Grab the first item on the queue:

        if {[info exists flowctl($conn,queue)]} {
            set items $flowctl($conn,queue)
            if {[string compare $items ""]} {
                set item [lindex $items 0]
                set rest [lrange $items 1 end]
                if {[string compare $rest ""]} {
                    set flowctl($conn,queue) $rest
                    set flowctl($conn,after) \
                            [after $flowctl(floodlimit) \
                                [list ::irk::sendlater $conn]]
                } else {
                    unset flowctl($conn,queue)
                }

                # Record time we last sent to this destination.

                set flowctl($conn,lastsend) [clock clicks -milliseconds]

                # Send this item:

                puts $conn $item
            } else {
                unset flowctl($conn,queue)
            }
        }
    }
}