statusbar.tcl

# ----------------------------------------------------------------------------
#  statusbar.tcl ---
#  This file is part of Unifix BWidget Toolkit
#  $Id: statusbar.tcl,v 1.91 2009/09/06 21:42:14 oberdorfer Exp $
# ----------------------------------------------------------------------------
#	Create a status bar Tk widget
#
#  Provides a status bar to be placed at the bottom of a toplevel.
#  Currently does not support being placed in a toplevel that has
#  gridding applied (via widget -setgrid or wm grid).
#
#  Ensure that the widget is placed at the very bottom of the toplevel,
#  otherwise the resize behavior may behave oddly.
# ------------------------------------------------------------------------
# 

package require Tk 8.3

if {0} {
    proc sample {} {
    # sample usage
    eval destroy [winfo children .]
    pack [text .t -width 0 -height 0] -fill both -expand 1

    set sbar .s
    StatusBar $sbar
    pack $sbar -side bottom -fill x
    set f [$sbar getframe]

    # Specify -width 1 for the label widget so it truncates nicely
    # instead of requesting large sizes for long messages
    set w [label $f.status -width 1 -anchor w -textvariable ::STATUS]
    set ::STATUS "This is a status message"
    # give the entry weight, as we want it to be the one that expands
    $sbar add $w -weight 1

    # BWidget's progressbar
    set w [ProgressBar $f.bpbar -orient horizontal \
	       -variable ::PROGRESS -bd 1 -relief sunken]
    set ::PROGRESS 50
    $sbar add $w
    }
}

namespace eval StatusBar {
    Widget::define StatusBar statusbar

    Widget::declare StatusBar {
	{-background  Color      "SystemWindow"	0}
	{-borderwidth TkResource 0	0 frame}
	{-relief      TkResource flat	0 frame}
	{-showseparator Boolean	 1	0}
	{-showresizesep Boolean	 0	0}
	{-showresize  Boolean	 1	0}
	{-width	      TkResource 100	0 frame}
	{-height      TkResource 18	0 frame}
	{-ipad	      String	 1	0}
	{-pad	      String	 0	0}
	{-bg	      Synonym	 -background}
	{-bd	      Synonym	 -borderwidth}
    }

    # -background, -borderwidth and -relief apply to outer frame, but relief
    # should be left flat for proper look
    Widget::addmap StatusBar "" :cmd {
	-background {} -width {} -height {} -borderwidth {} -relief {}
    }
    Widget::addmap StatusBar "" .sbar {
	-background {}
    }
    Widget::addmap StatusBar "" .resize {
	-background {}
    }
    Widget::addmap StatusBar "" .hsep {
	-background {}
    }

    # -pad provides general padding around the status bar
    # -ipad provides padding around each status bar item
    # Padding can be a list of {padx pady}

    variable HaveMarlett \
	[expr {[lsearch -exact [font families] "Marlett"] != -1}]

    bind StatusResize <1> \
	[namespace code [list begin_resize %W %X %Y]]
    bind StatusResize <B1-Motion> \
	[namespace code [list continue_resize %W %X %Y]]
    bind StatusResize <ButtonRelease-1> \
	[namespace code [list end_resize %W %X %Y]]

    bind StatusBar <Destroy> [list StatusBar::_destroy %W]

    # PNG version has partial alpha transparency for better look
    variable pngdata {
	iVBORw0KGgoAAAANSUhEUgAAAA8AAAAPCAYAAAFM0aXcAAAABGdBTUEAAYagM
	eiWXwAAAGJJREFUGJW9kVEOgCAMQzs8GEezN69fkKlbUAz2r3l5NGTA+pCU+Q
	IA5sv39wGgZKClZGBhJMVTklRr3VNwMz04mVfQzQiEm79EkrYZycxIkq8kkv2
	v6RFGku9TUrj8RGr9AGy6mhv2ymLwAAAAAElFTkSuQmCC
    }
    variable gifdata {
	R0lGODlhDwAPAJEAANnZ2f///4CAgD8/PyH5BAEAAAAALAAAAAAPAA8AAAJEh
	I+py+1IQvh4IZlG0Qg+QshkAokGQfAvZCBIhG8hA0Ea4UPIQJBG+BAyEKQhCH
	bIQAgNEQCAIA0hAyE0AEIGgjSEDBQAOw==
    }
    if {[package provide img::png] != ""} {
	image create photo ::StatusBar::resizer -format PNG -data $pngdata
    } else {
	image create photo ::StatusBar::resizer -format GIF -data $gifdata
    }
}


# ------------------------------------------------------------------------
#  Command StatusBar::create
# ------------------------------------------------------------------------
proc StatusBar::create { path args } {
    variable _widget
    variable HaveMarlett

    # Allow for img::png loaded after initial source
    if {[package provide img::png] != ""} {
	variable pngdata
	::StatusBar::resizer configure -format PNG -data $pngdata
    }

    Widget::init StatusBar $path $args

    eval [list frame $path -class StatusBar] [Widget::subcget $path :cmd]

    foreach {padx pady} [_padval [Widget::cget $path -pad]] \
	{ipadx ipady} [_padval [Widget::cget $path -ipad]] { break }

    if {[BWidget::using ttk]} {
	set sbar   [ttk::frame $path.sbar -padding [list $padx $pady]]
    } else {
	set sbar   [eval [list frame $path.sbar -padx $padx -pady $pady] \
			[Widget::subcget $path .sbar]]
    }
    if {[string equal $::tcl_platform(platform) "windows"]} {
	set cursor size_nw_se
    } else {
	set cursor sizing; # bottom_right_corner ??
    }
    set resize [eval [list label $path.resize] \
		    [Widget::subcget $path .resize] \
		    [list -borderwidth 0 -relief flat -anchor se \
			 -cursor $cursor -anchor se -padx 0 -pady 0]]
    if {$HaveMarlett} {
	$resize configure -font "Marlett -16" -text \u006f
    } else {
	$resize configure -image ::StatusBar::resizer
    }
    bindtags $resize [list all [winfo toplevel $path] StatusResize $resize]

    if {[BWidget::using ttk]} {
	set fsep [ttk::separator $path.hsep -orient horizontal]
    } else {
	set fsep [eval [list frame $path.hsep -bd 1 -height 2 -relief sunken] \
		      [Widget::subcget $path .hsep]]
    }
    set sep  [_sep $path sepresize {}]

    grid $fsep   -row 0 -column 0 -columnspan 3 -sticky ew
    grid $sbar   -row 1 -column 0 -sticky news
    grid $sep    -row 1 -column 1 -sticky ns -padx $ipadx -pady $ipady
    grid $resize -row 1 -column 2 -sticky news
    grid columnconfigure $path 0 -weight 1
    if {![Widget::cget $path -showseparator]} {
	grid remove $fsep
    }
    if {![Widget::cget $path -showresize]} {
	grid remove $sep $resize
    } elseif {![Widget::cget $path -showresizesep]} {
	grid remove $sep
    }
    set _widget($path,items) {}

    return [Widget::create StatusBar $path]
}


# ------------------------------------------------------------------------
#  Command StatusBar::configure
# ------------------------------------------------------------------------
proc StatusBar::configure { path args } {
    variable _widget

    set res [Widget::configure $path $args]

    foreach {chshow chshowrsep chshowsep chipad chpad} \
	[Widget::hasChangedX $path -showresize -showresizesep -showseparator \
	     -ipad -pad] { break }

    if {$chshow} {
	set show [Widget::cget $path -showresize]
	set showrsep [Widget::cget $path -showresizesep]
        if {$show} {
	    if {$showrsep} {
		grid $path.sepresize
	    }
	    grid $path.resize
        } else {
	    grid remove $path.sepresize $path.resize
	}
    }
    if {$chshowsep} {
        if {$show} {
	    grid $path.hsep
        } else {
	    grid remove $path.hsep
	}
    }
    if {$chipad} {
	foreach {ipadx ipady} [_padval [Widget::cget $path -ipad]] { break }
	foreach w [grid slaves $path.sbar] {
	    grid configure $w -padx $ipadx -pady $ipady
	}
    }
    if {$chpad} {
	foreach {padx pady} [_padval [Widget::cget $path -pad]] { break }
	if {[string equal [winfo class $path.sbar] "TFrame"]} {
	    $path.sbar configure -padding [list $padx $pady]
	} else {
	    $path.sbar configure -padx $padx -pady $pady
	}
    }
    return $res
}


# ------------------------------------------------------------------------
#  Command StatusBar::cget
# ------------------------------------------------------------------------
proc StatusBar::cget { path option } {
    return [Widget::cget $path $option]
}

# ------------------------------------------------------------------------
#  Command StatusBar::getframe
# ------------------------------------------------------------------------
proc StatusBar::getframe {path} {
    # This is the frame that users should place their statusbar widgets in
    return $path.sbar
}

# ------------------------------------------------------------------------
#  Command StatusBar::add
# ------------------------------------------------------------------------
proc StatusBar::add {path w args} {
    variable _widget

    array set opts [list \
			-weight    0 \
			-separator 1 \
			-sticky    news \
			-pad       [Widget::cget $path -ipad] \
			]
    foreach {key val} $args {
	if {[info exists opts($key)]} {
	    set opts($key) $val
	} else {
	    set msg "unknown option \"$key\", must be one of: "
	    append msg [join [lsort [array names opts]] {, }]
	    return -code error $msg
	}
    }
    foreach {ipadx ipady} [_padval $opts(-pad)] { break }

    set sbar $path.sbar
    foreach {cols rows} [grid size $sbar] break
    # Add separator if requested, and we aren't the first element
    if {$opts(-separator) && $cols != 0} {
	set sep [_sep $path sep[winfo name $w]]
	# only append name, to distinguish us from them
	lappend _widget($path,items) [winfo name $sep]
	grid $sep -in $sbar -row 0 -column $cols \
	    -sticky ns -padx $ipadx -pady $ipady
	incr cols
    }

    lappend _widget($path,items) $w
    grid $w -in $sbar -row 0 -column $cols -sticky $opts(-sticky) \
	-padx $ipadx -pady $ipady
    grid columnconfigure $sbar $cols -weight $opts(-weight)

    return $w
}

# ------------------------------------------------------------------------
#  Command StatusBar::delete
# ------------------------------------------------------------------------
proc StatusBar::remove {path args} {
    variable _widget

    set destroy [string equal [lindex $args 0] "-destroy"]
    if {$destroy} {
	set args [lrange $args 1 end]
    }
    foreach w $args {
	set idx [lsearch -exact $_widget($path,items) $w]
	if {$idx == -1 || ![winfo exists $w]} {
	    # ignore unknown or non-widget items (like our separators)
	    continue
	}
	# separator is always previous item
	set sidx [expr {$idx - 1}]
	set sep  [lindex $_widget($path,items) $sidx]
	if {[string match .* $sep]} {
	    # not one of our separators
	    incr sidx
	} elseif {$sep != ""} {
	    # destroy separator too
	    set sep $path.sbar.$sep
	    destroy $sep
	}
	if {$destroy} {
	    destroy $w
	} else {
	    grid forget $w
	}
	if {$idx == 0} {
	    # separator of next item is no longer necessary
	    set sep [lindex $_widget($path,items) [expr {$idx + 1}]]
	    if {$sep != "" && ![string match .* $sep]} {
		incr idx
		set sep $path.sbar.$sep
		destroy $sep
	    }
	}
	set _widget($path,items) [lreplace $_widget($path,items) $sidx $idx]
    }
}

# ------------------------------------------------------------------------
#  Command StatusBar::delete
# ------------------------------------------------------------------------
proc StatusBar::delete {path args} {
    return [StatusBar::remove $path -destroy $args]
}

# ------------------------------------------------------------------------
#  Command StatusBar::items
# ------------------------------------------------------------------------
proc StatusBar::items {path} {
    variable _widget
    return $_widget($path,items)
}

proc StatusBar::_sep {path name {sub .sbar}} {
    if {[BWidget::using ttk]} {
	return [ttk::separator $path$sub.$name -orient vertical]
    } else {
	return [frame $path$sub.$name -bd 1 -width 2 -relief sunken]
    }
}

proc StatusBar::_padval {padval} {
    set len [llength $padval]
    foreach {a b} $padval { break }
    if {$len == 0 || $len > 2} {
	return -code error \
	    "invalid pad value \"$padval\", must be 1 or 2 pixel values"
    } elseif {$len == 1} {
	return [list $a $a]
    } elseif {$len == 2} {
	return $padval
    }
}

# ------------------------------------------------------------------------
#  Command StatusBar::_destroy
# ------------------------------------------------------------------------
proc StatusBar::_destroy { path } {
    variable _widget
    variable resize
    array unset widget $path,*
    array unset resize $path.resize,*
    Widget::destroy $path
}

# The following proc handles the mouse click on the resize control. It stores
# the original size of the window and the initial coords of the mouse relative
# to the root.

proc StatusBar::begin_resize {w rootx rooty} {
    variable resize
    set t    [winfo toplevel $w]
    set relx [expr {$rootx - [winfo rootx $t]}]
    set rely [expr {$rooty - [winfo rooty $t]}]
    set resize($w,x) $relx
    set resize($w,y) $rely
    set resize($w,w) [winfo width $t]
    set resize($w,h) [winfo height $t]
    set resize($w,winc) 1
    set resize($w,hinc) 1
    set resize($w,grid) [wm grid $t]
}

# The following proc handles mouse motion on the resize control by asking the
# wm to adjust the size of the window.

proc StatusBar::continue_resize {w rootx rooty} {
    variable resize
    if {[llength $resize($w,grid)]} {
	# at this time, we don't know how to handle gridded resizing
	return
    }
    set t      [winfo toplevel $w]
    set relx   [expr {$rootx - [winfo rootx $t]}]
    set rely   [expr {$rooty - [winfo rooty $t]}]
    set width  [expr {$relx - $resize($w,x) + $resize($w,w)}]
    set height [expr {$rely - $resize($w,y) + $resize($w,h)}]
    if {$width  < 0} { set width 0 }
    if {$height < 0} { set height 0 }
    wm geometry $t ${width}x${height}

    if {[string equal $::tcl_platform(platform) "windows"]} {
      update idletasks
    }
}

# The following proc cleans up when the user releases the mouse button.

proc StatusBar::end_resize {w rootx rooty} {
    variable resize
    #continue_resize $w $rootx $rooty
    #wm grid $t $resize($w,grid)
    array unset resize $w,*
}