PurpleCommander: commander.tcl

# ChangeLog:
#
# 9/13/2007:
#  Patch from venks on irc.freenode.net to restore puts functionality
#  in the slave which was lost in a slightly-to-naive alias.

if {[info exists purple::tk_available] && !$purple::tk_available} {
        purple::notify -error {Purple Commander} {Purple Commander cannot be loaded} \
                {Purple Commander requires Tk support to load properly.}
        error {Tk not available}
}

load {} Tk

proc slave_init { slave pshell } {
        interp alias $slave purple_puts {} slave_puts $pshell
        $slave eval {
                rename ::puts ::purple_orig_puts
                proc ::puts { args } {
                        set len [llength $args]
                        if {$len == 1} {
                                return [::purple_puts [lindex $args 0]]
                        } elseif {$len == 2} {
                                if {[lindex $args 0] == "-nonewline"} {
                                        return [::purple_puts -nonewline \
                                                [lindex $args 1]]
                                } else {
                                        return [::purple_orig_puts \
                                                [lindex $args 0] \
                                                [lindex $args 1]]
                                }
                        } else {
                                return [eval ::purple_orig_puts $args]
                        }
                }
                catch { load {} purple }
                catch { source "${purple::user_dir}/commanderrc" }
        }
}

proc slave_puts { pshell args } {
        upvar $pshell shell
        set nonewline 0

        if {[llength $args] < 1} {
                error "wrong # args: puts ?-nonewline? string"
        }

        if {[string match [lindex $args 0] "-nonewline"]} {
                set nonewline 1
        }

        if {[llength $args] > [expr {1 + $nonewline}]} {
                error "wrong # args: puts ?-nonewline string"
        } else {
                $shell(text) insert end [lindex $args $nonewline] puts
                if {!$nonewline} {
                        $shell(text) insert end "\n" puts
                }
        }
}

proc shell_reset { pshell } {
        upvar $pshell shell

        interp delete $shell(interp)
        set shell(interp) [interp create]
        set shell(current) ""
        set shell(histindex) 1
        set shell(tmphist) ""
        $shell(text) delete 0.0 end
        slave_init $shell(interp) $pshell
        shell_prompt $pshell
}

proc shell_create { pshell root } {
        upvar $pshell shell

        set shell(prompt) "purple] "
        set shell(continue) "+     "
        set shell(current) ""
        set shell(histindex) 1
        set shell(tmphist) ""
        set shell(interp) [interp create]
        frame ${root}.frame
        set shell(text) [text ${root}.frame.shell -wrap word -background white \
                -yscrollcommand "${root}.frame.scroll set"]
        scrollbar ${root}.frame.scroll -command "$shell(text) yview"

        bindtags $shell(text) "$shell(text) Shell Text ShellAfter . all"
        bind $shell(text) <Return> "shell_return $pshell; break"
        bind $shell(text) <Control-p> "shell_prevcmd $pshell; break"
        bind $shell(text) <Control-n> "shell_nextcmd $pshell; break"
        $shell(text) tag configure error -foreground red
        $shell(text) tag configure prompt -foreground blue
        $shell(text) tag configure puts -foreground purple
        $shell(text) tag configure return -foreground grey

        slave_init $shell(interp) $pshell

        shell_prompt $pshell
        $shell(text) mark gravity endprompt left
        $shell(text) mark gravity startcmd left

        pack $shell(text) -fill x -fill y -side left
        pack ${root}.frame.scroll -fill y -side right
        pack ${root}.frame
        focus $shell(text)
}

proc shell_new { } {
        global shells

        incr shells
        set w ".shell$shells"
        toplevel $w
        wm title $w "Purple Commander $shells"
        shell_create "::shell$shells" $w
}

proc shell_prompt { pshell } {
        upvar $pshell shell

        $shell(text) insert end $shell(prompt) prompt
        $shell(text) mark set endprompt insert
        $shell(text) mark set startcmd endprompt
}

proc shell_return { pshell } {
        upvar $pshell shell

        $shell(text) mark set insert end
        $shell(text) insert end "\n"
        set shell(current) "$shell(current)[$shell(text) get endprompt end]"
        if {[info complete $shell(current)]} {
                exec_command $pshell
                $shell(text) insert end $shell(prompt) prompt
                $shell(text) mark set endprompt insert
                $shell(text) mark set startcmd endprompt
                set shell(current) ""
                set shell(histindex) 1
                set shell(tmphist) ""
        } else {
                $shell(text) insert end $shell(continue) prompt
                $shell(text) mark set endprompt insert
        }
        $shell(text) see end
}

proc shell_prevcmd { pshell } {
        upvar $pshell shell

        if {$shell(histindex) == 1} {
                set curcmd [concat $shell(current) [$shell(text) get endprompt end]]
                set shell(tmphist) $curcmd
        }

        incr shell(histindex) -1
        set newcmd [$shell(interp) eval [list history event $shell(histindex)]]
        if {[string length $newcmd]} {
                set shell(current) ""
                $shell(text) delete startcmd end
                $shell(text) mark set prompt startcmd
                $shell(text) insert end $newcmd
        }
}

proc shell_nextcmd { pshell } {
        upvar $pshell shell

        if {$shell(histindex) == 1} { return }

        incr shell(histindex)
        if {$shell(histindex) == 1} {
                set newcmd $shell(tmphist)
                set shell(tmphist) ""
        } else {
                set newcmd [$shell(interp) eval [list history event $shell(histindex)]]
        }

        set shell(current) ""
        $shell(text) delete startcmd end
        $shell(text) mark set prompt startcmd
        $shell(text) insert end $newcmd
}


proc exec_command { pshell } {
        upvar $pshell shell

        if {[string length $shell(current)]} {
                $shell(interp) eval [list history add $shell(current)]
                if {[catch { $shell(interp) eval $shell(current) } result]} {
                        $shell(text) insert end "$result\n" error
                } elseif {[string length $result]} {
                        $shell(text) insert end "$result\n" return
                }
        }
}

proc acct_insert { pshell pacct } {
        upvar $pshell shell
        upvar $pacct acct

        $shell(text) insert insert [lindex $acct(accounts) [$acct(listbox) index active]]
}

proc account_dialog { toplevel pshell } {
        global acct_dialog

        if {[expr {$acct_dialog(posted) != 0}]} {
                destroy $acct_dialog(toplevel)
                set acct_dialog(posted) 0
                set acct_dialog(checkbox) 0
                return
        }

        set acct_dialog(toplevel) $toplevel
        set acct_dialog(accounts) [purple::account list]
        set acct_dialog(list) {}

        set d [toplevel $toplevel]
        wm title $d "Accounts"
        bind $d <Destroy> {
                global acct_dialog
                set acct_dialog(posted) 0
                set acct_dialog(checkbox) 0
                set acct_dialog(list) {}
        }

        frame ${d}.top
        set l [listbox ${d}.top.listbox -foreground grey -background white \
                -yscrollcommand "${d}.top.listscroll set" -listvar ::acct_dialog(list)]
        scrollbar ${d}.top.listscroll -command "$l yview"

        set i 0
        foreach account $acct_dialog(accounts) {
                set acct_dialog(list) [linsert $acct_dialog(list) $i [purple::account username $account]]
                if {[purple::account isconnected $account]} {
                        $l itemconfigure $i -foreground black
                }
                incr i
        }

        bind $l <Double-1> "acct_insert $pshell ::acct_dialog"

        pack $l -side left -expand yes -fill both
        pack ${d}.top.listscroll -side right -fill y
        pack ${d}.top

        set acct_dialog(posted) 1
        set acct_dialog(checkbox) 1
        set acct_dialog(listbox) $l
}

bind Shell <BackSpace> {
        if [%W compare insert <= endprompt] {
                break
        }
}
bind Shell <Key> {
        if [%W compare insert < endprompt] {
                %W mark set insert end
        }
}
bind Shell <Control-u> { %W delete endprompt end; break }
bind ShellAfter <Key> {
        if [%W compare insert < endprompt] {
                %W mark set insert endprompt
        }
}

set acct_dialog(posted) 0
set shells 1

menu .menu -type menubar -tearoff no -borderwidth 0
menu .menu.commander -tearoff no
.menu.commander add command -label New -command { shell_new }
.menu.commander add command -label Reset -command { shell_reset ::shell }
.menu.commander add separator
.menu.commander add command -label Unload -command { purple::unload }
.menu add cascade -menu .menu.commander -label Commander
menu .menu.dialogs -tearoff no
.menu.dialogs add check -label Accounts -command { account_dialog .acctdialog ::shell } -variable acct_dialog(checkbox)
.menu add cascade -menu .menu.dialogs -label Dialogs
. configure -menu .menu

shell_create ::shell {}

if {[info exists purple::version]} {
        purple::signal connect [purple::connection handle] signed-on { gc } {
                global acct_dialog

                if {!$acct_dialog(posted)} { return }

                set account [lsearch -exact $acct_dialog(accounts) [purple::connection account $gc]]
                $acct_dialog(listbox) itemconfigure $account -foreground black
        }
        purple::signal connect [purple::connection handle] signing-off { gc } {
                global acct_dialog
                
                if {!$acct_dialog(posted)} { return }

                set account [lsearch -exact $acct_dialog(accounts) [purple::connection account $gc]]
                $acct_dialog(listbox) itemconfigure $account -foreground grey
        }
}

wm title . "Purple Commander"
wm deiconify .

proc plugin_init { } {
        list "Purple Commander" \
             "$purple::version" \
             "An interactive Tcl interpreter" \
             "Purple Commander provides an interactive command interpreter for the Purple Tcl programming interface.  Among other things, it can be used to load and debug Purple Tcl scripts on the fly." \
             "Ethan Blanton <elb@pidgin.im>" \
             "http://www.pidgin.im/"
}