# Description: puts all RoxIRC windows into a single tabbed window

package require roxirc 2.0

startup

if {$tcl_platform(platform) == "unix"} {
    option add *tabs*middle.borderWidth 1 widgetDefault
    option add *tabs*Button.borderWidth 2 widgetDefault
} elseif {$tcl_platform(platform) == "windows"} {
    option add *tabs*left.relief flat widgetDefault
    option add *tabs*right.relief flat widgetDefault
    option add *tabs*close.relief flat widgetDefault
    option add *tabs*Button*padY 2 widgetDefault
    option add *tabs.middle.f*.padY 2 widgetDefault
    #if {$tcl_platform(osVersion) > 5.0} {
    #} else {
    #}
}

foreach x {toplevel wm winfo destroy} {
    rename ::$x ::_$x
}

bind cmdline <Escape> {wm iconify [winfo toplevel %W]; catch {_wm iconify [_winfo toplevel %W]}}

procs toplevel wm winfo destroy command_explode command_combine _destroy _winfo _wm _toplevel circulate

AddToPrefs single bool 1

proc toplevel {name args} {
    global side prefs
    if {![_winfo exists .tabs] || [regexp -- {-class +\w*Dialog} $args] || [string match ".*.*" $name]} {
        eval _toplevel $name $args
        return $name
    }
    eval frame $name -class Toplevel $args
    button .tabs.middle.c.f$name -text $name -highlightthickness 0 -padx 3m -relief groove
    pack .tabs.middle.c.f$name -side left -pady 0 -padx 0 -fill y
    bindtags .tabs.middle.c.f$name tab
    if {[string match ".q*" $name] && $prefs(iconifyqueries) && [string match "UpdateChat *" [info level -2]]} {
        hilightbutton $name
        return $name
    }
    showframe $name
    after idle [namespace current]::setscrollstate
    return $name
}

proc wm {option window args} {
    if {[_winfo exists $window] && [string equal [_winfo toplevel $window] $window]} {
        return [eval _wm $option $window $args]
    }
    switch -exact -- $option {
        title {
            global single
            if {$args == ""} {
                if {[info exists single(title,$window)]} {return $single(title,$window)}
                return {}
            }
            if {[lindex [split [lindex $args 0]] 1] == "Query"} {
                set title [lindex [split [lindex [split [lindex $args 0]] 2] !] 0]
            } elseif {[lindex [split [lindex $args 0]] 2] == "Chat"} {
                set title "DCC [lindex [split [lindex [split [lindex $args 0]] 3] @] 0]"
            } elseif {[lindex [split [lindex $args 0]] 1] == "DCC"} {
                set title "[lindex [split [lindex $args 0]] 2] [lindex [split [lindex [split [lindex $args 0]] 4] @] 0]"
            } elseif {$window == ".0"} {
                set title "Status"
            } elseif {[string length $window] < 3} {
                set title [lindex [split [lindex $args 0]] 1]
            } else {
                set title [string range [lindex $args 0] 7 end]
            }
            .tabs.middle.c.f$window configure -text [string range $title 0 15]
            set single(title,$window) [lindex $args 0]
            if {[.tabs.middle.c.f$window cget -relief] == "raised"} {_wm title . $single(title,$window)}
            if {$window == ".0"} {_wm iconname . "RoxIRC \[$::me on $::server\]"}
        }
        protocol {
            global single
            if {[llength $args] == 0} {
                return [string map "protocol, {} ,$window {}" [array names single protocol,*,$window]]
            }
            if {[llength $args] == 1} {
                if [info exists single(protocol,[lindex $args 0],$window)] {
                    return $single(protocol,[lindex $args 0],$window)
                }
                return {}
            }
            if {[llength $args] == 2 && [lindex $args 1] == ""} {
                catch {unset single(protocol,[lindex $args 0],$window)}
                return {}
            }
            set single(protocol,[lindex $args 0],$window) [lindex $args 1]
        }
        state {return normal}
        deiconify {showframe $window}
        iconname  {set ::single(iconname,$window) [lindex $args 0]}
        geometry  {}
        iconify   {}
        transient {}
        withdraw  {}
        resizable {}
        default {return [eval _wm $option $window $args]}
    }
}

proc winfo {option args} {
    if {[_winfo exists [lindex $args 0]] && ![string equal [_winfo toplevel [lindex $args 0]] .]} {
        return [eval _winfo $option $args]
    }
    switch -exact -- $option {
        toplevel {
            return .[lindex [split $args .] 1]
        }
        default {
            return [eval _winfo $option $args]
        }
    }
}

proc destroy {window} {
    if {[_winfo exists .tabs.middle.c.f$window]} {
        set i [lsearch [_winfo children .tabs.middle.c.f] .tabs.middle.c.f$window]
        _destroy .tabs.middle.c.f$window
        set show end
        if {$i > 0} {set show [expr $i - 1]}
        showframe [string map {.tabs.middle.c.f ""} [lindex [winfo children .tabs.middle.c.f] $show]]
        after idle [namespace current]::setscrollstate
    }
    _destroy $window
}

proc command_combine {window line} {
    global info
    set line [rele [split $line]]
    if {$line == ""} {
        set windows [winfo children .]
    } else {
        set windows {}
        foreach x $line {
            if {[set w [windowname $x]] != ""} {
                lappend windows $w
            } elseif {[_winfo exists $x] && [winfo toplevel $x] == $x} {
                lappend windows $x
            }
        }
    }
    set focus [focus]
    if {![winfo exists .tabs]} {
        set first 1
        if {$focus == ""} {
            set geom [_wm geometry .0]
        } else {
            set geom [_wm geometry [_winfo toplevel $focus]]
        }
        pack [createbuttonbar] -side top -fill x
        bind all <<channelcreate>> {+bind %W.middle.right.label <ButtonRelease-1> {}; %W.middle.right.label configure -cursor ""}
    }
    foreach x $windows {
        if {$x != [_winfo toplevel $x]} continue
        if {[winfo exists $x.n]} {reattachnick $x}
        reparentin $x
        wm title $x [wm title $x]
        if {[info exists info(text,$x)]} {ConfigureTags $x}
        if {[$x cget -class] == "Channel"} {
            nicklistitemconfigure $x
            $x.middle.right.label configure -cursor {}
            bind $x.middle.right.label <ButtonRelease-1> {}
        } elseif {$x == ".0"} {
            pack configure .tabs.middle.c.f.0 -before [lindex [_winfo children .tabs.middle.c.f] 0]
            lower .tabs.middle.c.f.0
        }
        catch {focus $x.bottom.cmdline}
    }
    if {[info exists first]} {
        if {![string match "*+0+0" $geom]} {
            set geom [split $geom "x+"]
            _wm geometry . [lindex $geom 0]x[expr [lindex $geom 1] + 30]+[lindex $geom 2]+[expr [lindex $geom 3] - 30]
        }
        bind all <<echo>> "+[namespace current]::hilightbutton %W"
        bind . <Map> {if {![string equal . %W]} {break}; _wm geometry . [_wm geometry %W]; bind . <Map> {}}
        bind .tabs.middle.c <Configure> [namespace current]::setscrollstate
        _wm deiconify .
    }
    if {$focus != ""} {
        if {[lsearch $windows [winfo toplevel $focus]] > -1} {
            showframe [winfo toplevel $focus]
        } else {
            update
            raise [winfo toplevel $focus] .
            focus -force $focus
        }
    }
}

proc command_explode {window line} {
    global info
    if {![winfo exists .tabs]} return
    set line [rele [split $line]]
    if {$line == ""} {
        set windows [string map {.tabs.middle.c.f ""} [_winfo children .tabs.middle.c.f]]
        wm withdraw .
        update idletasks
    } else {
        set windows {}
        foreach x $line {
            if {[set w [windowname $x]] != ""} {
                lappend windows $w
            } elseif {[_winfo exists $x] && [winfo toplevel $x] == $x} {
                lappend windows $x
            }
        }
    }
    foreach x $windows {
        reparentout $x
        catch {focus $x.bottom.cmdline}
        if {[info exists info(text,$x)]} {ConfigureTags $x}
        command_position $x r
        if {[$x cget -class] == "Channel"} {
            nicklistitemconfigure $x
            bind $x.middle.right.label <ButtonRelease-1> "NicksMove %W %X %Y"
            $x.middle.right.label configure -cursor fleur
        }
    }
    if {[winfo children .tabs.middle.c.f] == ""} {
        destroy .tabs
        wm withdraw .
        unbind all <<echo>> "[namespace current]::hilightbutton %W"
        unbind all <<channelcreate>> {bind %W.middle.right.label <ButtonRelease-1> {}; %W.middle.right.label configure -cursor ""}
        update
        raise $window
        focus $window
        catch {focus $window.bottom.cmdline}
    }
}

proc nicklistitemconfigure {w} {
    global info
    for {set index 0} {$index < [$w.middle.right.nicks index end]} {incr index} {
        if {[isop $info(channel,$w) [string trimleft [$w.middle.right.nicks get $index] @]]} {
            itemconfigure $w @nicklist $index
        } elseif {[isvoice $info(channel,$w) [string trimleft [$w.middle.right.nicks get $index] +]]} {
            itemconfigure $w +nicklist $index
        } else {
            break
        }
    }
}

proc addtags {w tags} {
    foreach {d tag pos} $tags {
        if {$d == "tagon"} {
            set t($tag) $pos
        } elseif {$d == "tagoff" && [info exists t($tag)] && $t($tag) != ""} {
            $w tag add $tag $t($tag) $pos
            unset t($tag)
        }
    }
}

proc createbuttonbar {} {
    set ns [namespace current]
    frame .tabs
    frame .tabs.f1 -relief sunken -bd 2 -width 2
    frame .tabs.f2 -relief sunken -bd 2 -width 2
    frame .tabs.middle -relief raised
    button .tabs.left  -text < -bd 1 -command "${ns}::scrollleft"   -highlightthickness 0 -width 2 -padx 0 -state disabled
    button .tabs.right -text > -bd 1 -command "${ns}::scrollright"  -highlightthickness 0 -width 2 -padx 0 -state disabled
    button .tabs.close -text X -bd 1 -command "${ns}::closecurrent" -highlightthickness 0 -width 3 -padx 0
    canvas .tabs.middle.c -height [winfo reqheight .tabs.right] -xscrollincrement 1 -highlightthickness 0
    frame .tabs.middle.c.f
    grid .tabs.left .tabs.right .tabs.f1 .tabs.middle .tabs.f2 .tabs.close -sticky nesw -padx 0 -pady 0
    if {$::tcl_platform(platform) == "unix"} {grid forget .tabs.f1 .tabs.f2}
    grid columnconfigure .tabs {0 1 5} -minsize 15 -weight 0
    grid columnconfigure .tabs 3 -weight 2
    pack .tabs.middle.c -fill both
    .tabs.middle.c create window 0 0 -anchor nw -window .tabs.middle.c.f
    bind .tabs.middle.c.f <Configure> {.tabs.middle.c configure -scrollregion [.tabs.middle.c bbox all]}
    if {$::tcl_platform(platform) == "windows"} {
        foreach x {left right close} {
            bind .tabs.$x <Enter> {if {[%W cget -state] != "disabled"} {%W configure -relief raised}}
            bind .tabs.$x <Leave> {%W configure -relief flat}
        }
    }
    return .tabs
}

proc scrollright {} {
    scrollsetleft [winfo containing [expr [_winfo rootx .tabs.middle.c] + [_winfo width .tabs.middle.c] - 1] [_winfo rooty .tabs.middle.c]]
    .tabs.right configure -foreground black -activeforeground black
}

proc scrollleft {} {
    scrollsetright [winfo containing [_winfo rootx .tabs.middle.c] [_winfo rooty .tabs.middle.c]]
    .tabs.left configure -foreground black -activeforeground black
}

proc scrollsetleft {tab} {
    set tab [string map {.tabs.middle.c.f ""} $tab]
    if {![_winfo exists .tabs.middle.c.f$tab]} return
    .tabs.middle.c xview scroll [expr [_winfo rootx .tabs.middle.c.f$tab] - [_winfo rootx .tabs.middle.c]] units
}

proc scrollsetright {tab} {
    set tab [string map {.tabs.middle.c.f ""} $tab]
    if {![_winfo exists .tabs.middle.c.f$tab]} return
    .tabs.middle.c xview scroll [expr -1 * (([_winfo rootx .tabs.middle.c] + [_winfo width .tabs.middle.c]) - ([_winfo rootx .tabs.middle.c.f$tab] + [_winfo width .tabs.middle.c.f$tab]))] units
}

proc closecurrent {} {
    foreach x [_winfo children .] {
        if {$x != ".tabs" && $x != ".0" && [_winfo exists .tabs.middle.c.f$x] && [_winfo ismapped $x]} {
            if {[wm protocol $x WM_DELETE_WINDOW] != ""} {
                eval [wm protocol $x WM_DELETE_WINDOW]
            } else {
                destroy $x
            }
            _destroy .tabs.middle.c.f$x
            if {[_winfo children .tabs.middle.c.f] == ""} {command_explode .0 {}}
            return
        }
    }
}

proc hilightbutton {name} {
    global info
    set name [winfo toplevel $name]
    if {[_winfo ismapped $name]} return
    set view [tabvisibility $name]
    set color red
    if {[info exists info(text,$name)] && [string match *hilight* [$info(text,$name) tag names end-1l+8c]]} {
        set color yellow
    }
    if {[.tabs.middle.c.f$name cget -foreground] != "yellow"} {
        .tabs.middle.c.f$name configure -foreground $color -activeforeground $color
    }
    if {$view < 0 && [.tabs.left cget -foreground] != "yellow"} {
        .tabs.left configure -foreground $color -activeforeground $color
    }
    if {$view > 0 && [.tabs.right cget -foreground] != "yellow"} {
        .tabs.right configure -foreground $color -activeforeground $color
    }
}

proc tabvisibility {name} {
    set s [winfo rootx .tabs.middle.c]
    set ts [winfo rootx .tabs.middle.c.f$name]
    if {$ts < $s} {return -1}
    if {$ts + [winfo width .tabs.middle.c.f$name] > $s + [winfo width .tabs.middle.c]} {return 1}
    return 0
}

proc showframe {name} {
    global single
    set name .[lindex [split $name .] end]
    if {![_winfo exists $name] || $name == "."} return
    if {[.tabs.middle.c.f$name cget -relief] == "raised"} return
    foreach x [_winfo children .] {
        if {$x != ".tabs"} {pack forget $x}
    }
    foreach x [_winfo children .tabs.middle.c.f] {$x configure -relief groove}
    pack $name -fill both -expand 1
    if {[_winfo exists $name.bottom.cmdline]} {focus $name.bottom.cmdline}
    if {[info exists single(title,$name)]} {_wm title . $single(title,$name)}
    .tabs.close configure -state normal
    if {$name == ".0"} { .tabs.close configure -state disabled }
    .tabs.middle.c.f$name configure -foreground black -activeforeground black -relief raised
}

proc setscrollstate {} {
    if {![winfo exists .tabs]} return
    set w [winfo width .tabs.middle.c]
    if {$w > 1 && [winfo width .tabs.middle.c.f] > $w} {
        .tabs.left configure -state normal
        .tabs.right configure -state normal
    } else {
        .tabs.left configure -foreground black -activeforeground black -state disabled
        .tabs.right configure -foreground black -activeforeground black -state disabled
    }
}

proc tearoff {tab x y} {
    set rx1 [_winfo rootx .tabs]
    set ry1 [_winfo rooty .tabs]
    set rx2 [expr $rx1 + [_winfo width .tabs]]
    set ry2 [expr $ry1 + [_winfo height .tabs]]
    if {$x < ($rx1 - 20) || $x > ($rx2 + 20) || $y < ($ry1 - 20) || $y > ($ry2 + 20)} {
        set win [string map {.tabs.middle.c.f ""} $tab]
        command_explode $win $win
        #_wm geometry $win +$x+$y
    }
}

proc tabdrag {tab} {
    if {[string match "*.0" $tab]} return
    set pointery [_winfo pointery $tab]
    set pointerx [_winfo pointerx $tab]
    set hi [_winfo rooty .tabs.middle]
    if {$pointery < $hi || $pointery > ($hi + [_winfo height .tabs.middle])} return
    set children [_winfo children .tabs.middle.c.f]
    set c [lsearch -exact $children $tab]
    if {$pointerx < [_winfo rootx .tabs.middle.c]} {
        bind tab <Motion> {}
        after 500 "[namespace current]::tabdrag $tab"
        if {$c <= 1 && [string match "*.0" [lindex $children 0]]} {
            scrollsetleft .0
            return
        }
        if {[set to [lindex $children [expr $c - 1]]] == ""} return
        pack configure $tab -before $to
        lower $tab $to
        update idletasks
        if {[tabvisibility [string map {.tabs.middle.c.f ""} $tab]] < 0} {scrollsetleft $tab}
        return
    } elseif {$pointerx > ([_winfo rootx .tabs.middle.c] + [_winfo width .tabs.middle.c])} {
        bind tab <Motion> {}
        after 500 "[namespace current]::tabdrag $tab"
        if {[set to [lindex $children [expr $c + 1]]] == ""} return
        pack configure $tab -after $to
        raise $tab $to
        update idletasks
        if {[tabvisibility [string map {.tabs.middle.c.f ""} $tab]] > 0} {scrollsetright $tab}
        return
    }
    bind tab <Motion> "[namespace current]::tabdrag $tab"
    set in [_winfo containing $pointerx $pointery]
    if {$tab == $in} return
    set i [lsearch -exact $children $in]
    if {$i < 0} {
        set to [lindex $children end]
        pack configure $tab -after $to
        raise $tab $to
    } elseif {$i < ($c - 1)} {
        set to [lindex $children [expr $c - 1]]
        pack configure $tab -before $to
        lower $tab $to
    } elseif {$i > ($c + 1)} {
        set to [lindex $children [expr $c + 1]]
        pack configure $tab -after $to
        raise $tab $to
    }
}

proc circulate {dir} {
    set wins [winfo children .]
    if {[winfo exists .tabs.middle.c.f]} {
        set wins [string map {.tabs.middle.c.f ""} [winfo children .tabs.middle.c.f]]
    }
    set p [lsearch $wins [winfo toplevel [focus]]]
    set wins [concat [lrange $wins [expr $p + 1] end] [lrange $wins 0 [expr $p - 1]]]
    if {[string match "back*" $dir]} {
        set tmp $wins
        set wins {}
        foreach x $tmp {set wins [linsert $wins 0 $x]}
    }
    foreach i $wins {
        if {[wm state $i] == "normal" && [winfo exists $i.bottom.cmdline]} {
            set next $i
            break
        }
    }
    if {[info exists next] && $next != ""} {
        wm deiconify $next
        raise $next
        focus $next.bottom.cmdline
    }
}

proc reparentin {new} {
    global single
    set state [iterate $new]
    foreach x [_wm protocol $new] {set single(protocol,$x,$new) [_wm protocol $new $x]}
    set single(title,$new) [_wm title $new]
    set single(iconname,$new) [_wm iconname $new]
    if {[set bindings [bind $new]] != ""} {
        foreach x $bindings {lappend state "bind $new $x [list [bind $new $x]]"}
    }
    foreach x [$new configure] {
        if {[set opt [lindex $x 4]] != ""} {lappend top [list [lindex $x 0] $opt]}
    }
    _destroy $new
    eval toplevel $new [join $top]
    eval [join $state "\;"]
}

proc reparentout {new} {
    global single
    set state [iterate $new]
    foreach x [array names single protocol,*,$new] {
        lappend state "wm protocol $new [lindex [split $x ,] 1] [list $single($x)]"
    }
    if {[info exists single(title,$new)]} {lappend state "wm title $new [list $single(title,$new)]"}
    if {[info exists single(iconname,$new)]} {lappend state "wm iconname $new [list $single(iconname,$new)]"}
    if {[set bindings [bind $new]] != ""} {
        foreach x $bindings {lappend state "bind $new $x [list [bind $new $x]]"}
    }
    foreach x [$new configure] {
        if {[set opt [lindex $x 4]] != ""} {lappend top [list [lindex $x 0] $opt]}
    }
    destroy $new
    eval _toplevel $new [join $top]
    eval [join $state "\;"]
}

proc iterate {w} {
    upvar state state
    foreach c [winfo children $w] {
        set new $c
        if {[catch {$c configure -class} widget]} {set widget "{} {} {} [winfo class $c]"}
        set widget [string tolower [lindex $widget 3]]
        lappend state "$widget $new [getconfig $c]"
        if {$widget == "listbox"} {
            lappend state "$new insert 0 [$c get 0 end]"
        } elseif {$widget == "entry"} {
            lappend state "$new configure -state normal"
            lappend state "$new insert 0 [list [$c get]]"
            lappend state "$new configure -state [$c cget -state]"
        } elseif {$widget == "text"} {
            lappend state "$new configure -state normal"
            lappend state "$new insert 1.0 [list [$c get 0.0 end-1c]]"
            lappend state "$new delete end end-1l"
            lappend state "addtags $new [list [$c dump -tag 0.0 end]]"
            lappend state "$new configure -state [$c cget -state]"
        } elseif {$widget == "menu"} {
            set end [$c index end]
            for {set x 0} {$x <= $end} {incr x} {
                lappend state "$new add [$c type $x] [getconfig $c "entryconfigure $x"]"
            }
        }
        lappend state "bindtags $new [list [bindtags $c]]"
        if {[set bindings [bind $c]] != ""} {
            foreach x $bindings {lappend state "bind $new $x [list [bind $c $x]]"}
        }
        if {[winfo children $c] != ""} {iterate $c}
    }
    set manager {}
    foreach x [winfo children $w] {
        if {[set manager [winfo manager $x]] != ""} {break}
    }
    if {$manager == "grid" || $manager == "pack" || $manager == "place"} {
        foreach x [$manager slaves $w] {lappend state "$manager $x [lrange [$manager info $x] 2 end]"}
    } elseif {$manager == "panedwindow"} {
        foreach x [$w panes] {lappend state "$w add $x [getconfig $w "paneconfigure $x"]"}
    }
    set grid [grid size $w]
    if {[set cols [lindex $grid 0]] > 0} {
        set cols [lindex $cols 0]
        for {incr cols -1} {$cols > -1} {incr cols -1} {
            lappend state "grid columnconfigure $w $cols [grid columnconfigure $w $cols]"
        }
    }
    if {[set rows [lindex $grid 1]] > 0} {
        for {incr rows -1} {$rows > -1} {incr rows -1} {
            lappend state "grid rowconfigure $w $rows [grid rowconfigure $w $rows]"
        }
    }
    return $state
}

proc getconfig {w {cmd configure}} {
    set args {}
    foreach x [eval $w $cmd] {
        if {[set opt [lindex $x 4]] != [lindex $x 3]} {lappend args [list [lindex $x 0] $opt]}
    }
    return [join $args]
}

proc unload {} {
    if {[_winfo exists .tabs]} {command_explode .0 {}}
    RemoveFromPrefs single
    set ns [namespace tail [namespace current]]
    foreach x {toplevel wm winfo destroy} {rename ::_$x ::backup::${ns}::$x}
    after cancel [namespace current]::setscrollstate
}

proc help {window line} {
    Echo $window {[ help ] Variables added by this script: SINGLE} {help default}
    Echo $window {[ help ] Sets whether to startup in single window mode} {help default}
    Echo $window {[ help ] Commands added by this script: /combine /explode} {help default}
    Echo $window {[ help ] Combines all RoxIRC windows into a single tabbed window or explodes the tabbed windows into individual toplevel windows} {help default}
}

bind tab <Button-1> "[namespace current]::showframe %W; bind tab <Motion> \"[namespace current]::tabdrag %W\""
bind tab <ButtonRelease-1> "[namespace current]::tearoff %W %X %Y; bind tab <Motion> {}; after cancel \"[namespace current]::tabdrag %W\""

if {$prefs(single)} {after idle [list command_combine .0 {}]}