source: code/archive/environment2/data/tcl/irk/lib/irkcommand.tcl @ 10670

# irkcommand.tcl:
#
# Various commands that can be invoked by the user of the IRK library:

namespace eval irk {

    # Say something to a user or to a channel

    proc say {token chan saying} {
        variable state

        if {[catch {set sock $state($token,socket)}]} {
            error "$token: not a valid irc connection"
        }
        if {![string compare "" $saying]} {
            return
        }
        sendit $sock "PRIVMSG $chan :[string trim $saying]"
    }

    # Send a NOTICE to a user or a channel

    proc notice {token chan args} {
        variable state

        if {[catch {set sock $state($token,socket)}]} {
            error "$token: not a valid irc connection"
        }
        sendit $sock "NOTICE $chan :$args"
    }

    # Send a raw command to the server:

    proc send {token args} {
        variable state

        if {[catch {set sock $state($token,socket)}]} {
            error "$token: not a valid irc connection"
        }
        puts $sock $args
    }

    # Change your NICK

    proc nick {token {newnick ""}} {
        variable state

        if {![string compare "" $newnick]} {
            return $state($token,nick)
        }
        if {[catch {set sock $state($token,socket)}]} {
            error "$token: not a valid irc connection"
        }
        puts $sock "NICK $newnick"
    }

    # Join a channel

    proc join {token chans {keys ""}} {
        variable state

        if {[catch {set sock $state($token,socket)}]} {
            error "$token: not a valid irc connection"
        }
        puts $sock "JOIN $chans $keys"
    }

    # Leave a channel

    proc leave {token chans {partmsg ""}} {
        variable state

        if {![string compare $partmsg ""]} {
            if {[info exists state(partmsg)]} {
                set partmsg $state(partmsg)
            }
        }
        if {[catch {set sock $state($token,socket)}]} {
            error "$token: not a valid irc connection"
        }
        puts $sock "PART $chans $partmsg"
    }

    # Return a list of all connections that are open:

    proc connections {} {
        variable state

        if {![info exists state(connections)]} {
            return {}
        }
        return $state(connections)
    }

    # Return a list of channels we're on in a give connection:

    proc onchannels {token} {
        variable state

        if {![info exists state($token,channels)]} {
            return {}
        }
        return $state($token,channels)
    }

    # Returns 1 if we are on the given channel.

    proc onchannel {token channel} {
        variable state

        if {![info exists state($token,channels)]} {
            return 0
        }

        set idx [lsearch $state($token,channels) $channel]
        if {$idx == -1} {
            return 0
        }
        return 1
    }

    # Return a list of users on a given channel (we must be on that channel).

    proc whoison {token chan} {
        variable state

        if {![info exists state($token,$chan,NAMES)]} {
            return {}
        }
        return $state($token,$chan,NAMES)
    }

    # Ping a server

    proc ping {token} {
        variable state

        if {[catch {set sock $state($token,socket)}]} {
            error "$token: not a valid irc connection"
        }
        set state($token,PINGSTART) [clock clicks -millis]
        puts $sock "PING $state($token,host)"
    }

    # Quit this connection

    proc quit {token} {
        disconnect $token
    }

    # Query information about someone

    proc whois {token nick} {
        variable state

        if {[catch {set sock $state($token,socket)}]} {
            error "$token: not a valid irc connection"
        }
        puts $sock "WHOIS $nick"
    }

    # Set an away message

    proc away {token args} {
        variable state

        if {[catch {set sock $state($token,socket)}]} {
            error "$token: not a valid irc connection"
        }
        puts $sock "AWAY :$args"
    }

    # This procedure lets the client do CTCP actions:

    proc ctcp {token target action args} {
        variable state

        if {[catch {set sock $state($token,socket)}]} {
            error "$token: not a valid irc connection"
        }
        sendit $sock "PRIVMSG $target :\001$action $args\001"
    }

    # This command implements the TCL CTCP protocol:

    proc tcl {token target args} {
        variable state

        # Send it to the channel:

        if {[catch {set sock $state($token,socket)}]} {
            error "$token: not a valid irc connection"
        }
        sendit $sock "PRIVMSG $target :\001TCL $args\001"

        # Apply it locally:

        if {[info exists state($token,channel,ctcp,TCL,LOCAL)]} {
            $state($token,channel,ctcp,TCL,LOCAL) \
                    $token $state($token,nick) $state($token,user) \
                    PRIVMSG $target TCL $args
        }
    }

    # These procedures add and remove action handlers:

    # These procedures add actions that will be called when the user
    # with the given nick causes the supplied comm(and) to be executed
    # on the given dest(ination). This is the most specific form of action.

    proc addaction3 {token nick comm dest cmd} {
        variable state

        if {![info exists state($token,$nick,$comm,$dest)]} {
            set state($token,$nick,$comm,$dest) [list $cmd]
        } else {
            lappend state($token,$nick,$comm,$dest) $cmd
        }
    }

    proc setaction3 {token nick comm dest cmd} {
        variable state

        set state($token,$nick,$comm,$dest) [list $cmd]
    }

    # This procedure removes an action set by either of the above two
    # procedures.

    proc remaction3 {token nick comm dest cmd} {
        variable state

        if {![info exists state($token,$nick,$comm,$dest)]} {
            return
        }
        set cmds $state($token,$nick,$comm,$dest)
        set idx [lsearch $cmds $cmd]
        if {$idx == -1} {
            return
        }
        set state($token,$nick,$comm,$dest) [lreplace $cmds $idx $idx]
        if {![string compare "" $state($token,$nick,$comm,$dest)]} {
            unset state($token,$nick,$comm,$dest)
        }
    }

    # These procedures add actions that will be called when the
    # specific comm(and) is caused for the given dest(ination).

    proc addaction2 {token comm dest cmd} {
        variable state

        if {![info exists state($token,$comm,$dest)]} {
            set state($token,$comm,$dest) [list $cmd]
        } else {
            lappend state($token,$comm,$dest) $cmd
        }
    }

    proc setaction2 {token comm dest cmd} {
        variable state

        set state($token,$comm,$dest) [list $cmd]
    }

    # This procedure removes an action set by either of the above two
    # procedures.

    proc remaction2 {token comm dest cmd} {
        variable state

        if {![info exists state($token,$comm,$dest)]} {
            return
        }
        set cmds $state($token,$comm,$dest)
        set idx [lsearch $cmds $cmd]
        if {$idx == -1} {
            return
        }
        set state($token,$comm,$dest) [lreplace $cmds $idx $idx]
        if {![string compare "" $state($token,$comm,$dest)]} {
            unset state($token,$comm,$dest)
        }
    }

    # These procedures add actions that will be called when the
    # specific comm(and) is caused any dest(ination).

    proc addaction1 {token comm cmd} {
        variable state

        if {![info exists state($token,$comm)]} {
            set state($token,$comm) [list $cmd]
        } else {
            lappend state($token,$comm) $cmd
        }
    }

    proc setaction1 {token comm cmd} {
        variable state

        set state($token,$comm) [list $cmd]
    }

    # This procedure removes an action set by either of the above two
    # procedures.

    proc remaction1 {token comm cmd} {
        variable state

        if {![info exists state($token,$comm)]} {
            return
        }
        set cmds $state($token,$comm)
        set idx [lsearch $cmds $cmd]
        if {$idx == -1} {
            return
        }
        set state($token,$comm) [lreplace $cmds $idx $idx]
        if {![string compare "" $state($token,$comm)]} {
            unset state($token,$comm)
        }
    }

    # These procedures add global actions that will be called
    # when the specific comm(and) is caused on any dest(ination) and
    # any irc connection. These are the lowest priority commands.

    proc addactionglobal {comm cmd} {
        variable state

        if {![info exists state(cmd,$comm)]} {
            set state(cmd,$comm) [list $cmd]
        } else {
            lappend state(cmd,$comm) $cmd
        }
    }

    proc setactionglobal {comm cmd} {
        variable state

        set state(cmd,$comm) [list $cmd]
    }

    # This procedure removes an action set by either of the above two
    # procedures.

    proc remactionglobal {comm cmd} {
        variable state

        if {![info exists state(cmd,$comm)]} {
            return
        }
        set cmds $state(cmd,$comm)
        set idx [lsearch $cmds $cmd]
        if {$idx == -1} {
            return
        }
        set state(cmd,$comm) [lreplace $cmds $idx $idx]
        if {![string compare "" $state(cmd,$comm)]} {
            unset state(cmd,$comm)
        }
    }

    # This procedure manages configuration information for IRC:

    proc config {args} {
        if {$args == {}} {
            return [collectConfig]
        }

        if {[llength $args] == 1} {
            return [queryConfig [lindex $args 0]]
        }

        if {[expr [llength $args] % 2] != 0} {
            error "incorrect number of argument, must be multiple of 2"
        }

        setConfig $args
    }

    # Helper procedure to return a list with all important user settable
    # configuration information.

    proc collectConfig {} {
        variable state

        set config {}

        foreach name [array names state "-*"] {
            lappend config [list $name $state($name)]
        }
        return $config
    }

    # Helper procedure to return the value of one option.

    proc queryConfig {option} {
        variable state

        if {![info exists state($option)]} {
            return {}
        }
        return $state($option)
    }

    # Helper procedure to modify the configuration of a set of options.

    proc setConfig {theargs} {
        variable state

        foreach {opt val} $theargs {
            if {![string match "-*" $opt]} {
                continue
            }
            set state($opt) $val
        }
    }
}