utils.tcl

utils.tcl
This file is part of Unifix BWidget Toolkit
$Id: utils.tcl,v 1.5 2002/01/28 21:56:32 patthoyts Exp $
Index of commands:
- GlobalVar::exists
- GlobalVar::setvarvar
- GlobalVar::getvarvar
- BWidget::assert
- BWidget::clonename
- BWidget::get3dcolor
- BWidget::XLFDfont
- BWidget::place
- BWidget::grab
- BWidget::focus


BWidget
Comments  
Arguments  
Used by  
Uses  
namespace eval BWidget {
    variable _top
    variable _gstack {}
    variable _fstack {}
    proc use {} {}
}


BWidget::XLFDfont
Comments Command BWidget::XLFDfont
Arguments cmd
args
Used by  
Uses  
proc BWidget::XLFDfont { cmd args } {
    switch -- $cmd {
        create {
            set font "-*-*-*-*-*-*-*-*-*-*-*-*-*-*"
        }
        configure {
            set font [lindex $args 0]
            set args [lrange $args 1 end]
        }
        default {
            return -code error "XLFDfont: commande incorrecte: $cmd"
        }
    }
    set lfont [split $font "-"]
    if { [llength $lfont] != 15 } {
        return -code error "XLFDfont: description XLFD incorrecte: $font"
    }

    foreach {option value} $args {
        switch -- $option {
            -foundry { set index 1 }
            -family  { set index 2 }
            -weight  { set index 3 }
            -slant   { set index 4 }
            -size    { set index 7 }
            default  { return -code error "XLFDfont: option incorrecte: $option" }
        }
        set lfont [lreplace $lfont $index $index $value]
    }
    return [join $lfont "-"]
}


BWidget::assert
Comments Command BWidget::assert
Arguments exp
msg
Used by  
Uses  
proc BWidget::assert { exp {msg ""}} {
    set res [uplevel 1 expr $exp]
    if { !$res} {
        if { $msg == "" } {
            return -code error "Assertion failed: {$exp}"
        } else {
            return -code error $msg
        }
    }
}


BWidget::clonename
Comments Command BWidget::clonename
Arguments menu
Used by DynamicHelp::register
Uses  
proc BWidget::clonename { menu } {
    set path     ""
    set menupath ""
    set found    0
    foreach widget [lrange [split $menu "."] 1 end] {
        if { $found || [winfo class "$path.$widget"] == "Menu" } {
            set found 1
            append menupath "#" $widget
            append path "." $menupath
        } else {
            append menupath "#" $widget
            append path "." $widget
        }    
    }
    return $path
}


BWidget::focus
Comments Command BWidget::focus
Arguments option
path
Used by Tree::edit
ComboBox::_mapliste
Dialog::withdraw
Dialog::draw
Dialog::_destroy
ListBox::edit
DragSite::_init_drag
ComboBox::_unmapliste
DragSite::_end_drag
Uses  
proc BWidget::focus { option path } {
    variable _fstack

    if { $option == "release" } {
        while { [llength $_fstack] } {
            set oldf [lindex $_fstack end]
            set _fstack [lreplace $_fstack end end]
            if { [string compare $oldf $path] && [winfo exists $oldf] } {
                catch {::focus -force $oldf}
                return
            }
        }
    } elseif { $option == "set" } {
        lappend _fstack [::focus]
        ::focus -force $path
    }
}


BWidget::get3dcolor
Comments Command BWidget::get3dcolor
Arguments path
bgcolor
Used by NoteBook::configure
ArrowButton::_redraw_relief
NoteBook::create
Uses  
proc BWidget::get3dcolor { path bgcolor } {
    foreach val [winfo rgb $path $bgcolor] {
        lappend dark [expr {60*$val/100}]
        set tmp1 [expr {14*$val/10}]
        if { $tmp1 > 65535 } {
            set tmp1 65535
        }
        set tmp2 [expr {(65535+$val)/2}]
        lappend light [expr {($tmp1 > $tmp2) ? $tmp1:$tmp2}]
    }
    return [list [eval format "#%04x%04x%04x" $dark] [eval format "#%04x%04x%04x" $light]]
}


BWidget::getname
Comments Command BWidget::getname
Arguments name
Used by Button::configure
Button::create
BWLabel::create
SelectFont::create
SelectColor::dialog
BWLabel::configure
Uses  
proc BWidget::getname { name } {
    if { [string length $name] } {
        set text [option get . "${name}Name" ""]
        if { [string length $text] } {
            return [parsetext $text]
        }
    }
    return {}
}


BWidget::grab
Comments Command BWidget::grab
Arguments option
path
Used by Dialog::_destroy
ComboBox::_unmapliste
DragSite::_end_drag
Dialog::draw
SelectColor::menu
ComboBox::_mapliste
ProgressDlg::create
Dialog::withdraw
DragSite::_init_drag
Uses  
proc BWidget::grab { option path } {
    variable _gstack

    if { $option == "release" } {
        catch {::grab release $path}
        while { [llength $_gstack] } {
            set grinfo  [lindex $_gstack end]
            set _gstack [lreplace $_gstack end end]
            foreach {oldg mode} $grinfo {
                if { [string compare $oldg $path] && [winfo exists $oldg] } {
                    if { $mode == "global" } {
                        catch {::grab -global $oldg}
                    } else {
                        catch {::grab $oldg}
                    }
                    return
                }
            }
        }
    } else {
        set oldg [::grab current]
        if { $oldg != "" } {
            lappend _gstack [list $oldg [::grab status $oldg]]
        }
        if { $option == "global" } {
            ::grab -global $path
        } else {
            ::grab $path
        }
    }
}


BWidget::lreorder
Comments Command BWidget::lreorder
Arguments list
neworder
Used by Tree::reorder
ListBox::reorder
Uses  
proc BWidget::lreorder { list neworder } {
    set pos     0
    set newlist {}
    foreach e $neworder {
        if { [lsearch -exact $list $e] != -1 } {
            lappend newlist $e
            set tabelt($e)  1
        }
    }
    set len [llength $newlist]
    if { !$len } {
        return $list
    }
    if { $len == [llength $list] } {
        return $newlist
    }
    set pos 0
    foreach e $list {
        if { ![info exists tabelt($e)] } {
            set newlist [linsert $newlist $pos $e]
        }
        incr pos
    }
    return $newlist
}


BWidget::parsetext
Comments Command BWidget::parsetext
Arguments text
Used by  
Uses  
proc BWidget::parsetext { text } {
    set result ""
    set index  -1
    set start  0
    while { [string length $text] } {
        set idx [string first "&" $text]
        if { $idx == -1 } {
            append result $text
            set text ""
        } else {
            set char [string index $text [expr {$idx+1}]]
            if { $char == "&" } {
                append result [string range $text 0 $idx]
                set    text   [string range $text [expr {$idx+2}] end]
                set    start  [expr {$start+$idx+1}]
            } else {
                append result [string range $text 0 [expr {$idx-1}]]
                set    text   [string range $text [expr {$idx+1}] end]
                incr   start  $idx
                set    index  $start
            }
        }
    }
    return [list $result $index]
}


BWidget::place
Comments Command BWidget::place

Notes:
For Windows systems with more than one monitor the available screen area may
have negative positions. Geometry settings with negative numbers are used
under X to place wrt the right or bottom of the screen. On windows, Tk
continues to do this. However, a geometry such as 100x100+-200-100 can be
used to place a window onto a secondary monitor. Passing the + gets Tk
to pass the remainder unchanged so the Windows manager then handles -200
which is a position on the left hand monitor.
I've tested this for left, right, above and below the primary monitor.
Currently there is no way to ask Tk the extent of the Windows desktop in
a multi monitor system. Nor what the legal co-ordinate range might be.
Arguments path
w
h
args
Used by SelectColor::menu
ComboBox::_mapliste
Dialog::draw
Uses  
proc BWidget::place { path w h args } {
    variable _top

    update idletasks
    set reqw [winfo reqwidth  $path]
    set reqh [winfo reqheight $path]
    if { $w == 0 } {set w $reqw}
    if { $h == 0 } {set h $reqh}

    set arglen [llength $args]
    if { $arglen > 3 } {
        return -code error "BWidget::place: bad number of argument"
    }

    if { $arglen > 0 } {
        set where [lindex $args 0]
        set idx   [lsearch {"at" "center" "left" "right" "above" "below"} $where]
        if { $idx == -1 } {
            return -code error "BWidget::place: incorrect position \"$where\""
        }
        if { $idx == 0 } {
            set err [catch {
                # purposely removed the {} around these expressions - [PT]
                set x [expr int([lindex $args 1])]
                set y [expr int([lindex $args 2])]
            }]
            if { $err } {
                return -code error "BWidget::place: incorrect position"
            }
            if {$::tcl_platform(platform) == "windows"} {
                # handle windows multi-screen. -100 != +-100
                if {[string index [lindex $args 1] 0] != "-"} {
                    set x "+$x"
                }
                if {[string index [lindex $args 2] 0] != "-"} {
                    set y "+$y"
                }                    
            } else {
                if { $x >= 0 } {
                    set x "+$x"
                }
                if { $y >= 0 } {
                    set y "+$y"
                }
            }
        } else {
            if { $arglen == 2 } {
                set widget [lindex $args 1]
                if { ![winfo exists $widget] } {
                    return -code error "BWidget::place: \"$widget\" does not exist"
                }
        } else {
        set widget .
        }
            set sw [winfo screenwidth  $path]
            set sh [winfo screenheight $path]
            if { $idx == 1 } {
                if { $arglen == 2 } {
                    # center to widget
                    set x0 [expr {[winfo rootx $widget] + ([winfo width  $widget] - $w)/2}]
                    set y0 [expr {[winfo rooty $widget] + ([winfo height $widget] - $h)/2}]
                } else {
                    # center to screen
                    set x0 [expr {([winfo screenwidth  $path] - $w)/2 - [winfo vrootx $path]}]
                    set y0 [expr {([winfo screenheight $path] - $h)/2 - [winfo vrooty $path]}]
                }
                set x "+$x0"
                set y "+$y0"
                if {$::tcl_platform(platform) != "windows"} {
                    if { $x0+$w > $sw } {set x "-0"; set x0 [expr {$sw-$w}]}
                    if { $x0 < 0 }      {set x "+0"}
                    if { $y0+$h > $sh } {set y "-0"; set y0 [expr {$sh-$h}]}
                    if { $y0 < 0 }      {set y "+0"}
                }
            } else {
                set x0 [winfo rootx $widget]
                set y0 [winfo rooty $widget]
                set x1 [expr {$x0 + [winfo width  $widget]}]
                set y1 [expr {$y0 + [winfo height $widget]}]
                if { $idx == 2 || $idx == 3 } {
                    set y "+$y0"
                    if {$::tcl_platform(platform) != "windows"} {
                        if { $y0+$h > $sh } {set y "-0"; set y0 [expr {$sh-$h}]}
                        if { $y0 < 0 }      {set y "+0"}
                    }
                    if { $idx == 2 } {
                        # try left, then right if out, then 0 if out
                        if { $x0 >= $w } {
                            set x [expr {$x0-$sw}]
                        } elseif { $x1+$w <= $sw } {
                            set x "+$x1"
                        } else {
                            set x "+0"
                        }
                    } else {
                        # try right, then left if out, then 0 if out
                        if { $x1+$w <= $sw } {
                            set x "+$x1"
                        } elseif { $x0 >= $w } {
                            set x [expr {$x0-$sw}]
                        } else {
                            set x "-0"
                        }
                    }
                } else {
                    set x "+$x0"
                    if {$::tcl_platform(platform) != "windows"} {
                        if { $x0+$w > $sw } {set x "-0"; set x0 [expr {$sw-$w}]}
                        if { $x0 < 0 }      {set x "+0"}
                    }
                    if { $idx == 4 } {
                        # try top, then bottom, then 0
                        if { $h <= $y0 } {
                            set y [expr {$y0-$sh}]
                        } elseif { $y1+$h <= $sh } {
                            set y "+$y1"
                        } else {
                            set y "+0"
                        }
                    } else {
                        # try bottom, then top, then 0
                        if { $y1+$h <= $sh } {
                            set y "+$y1"
                        } elseif { $h <= $y0 } {
                            set y [expr {$y0-$sh}]
                        } else {
                            set y "-0"
                        }
                    }
                }
            }
        }
        wm geometry $path "${w}x${h}${x}${y}"
    } else {
        wm geometry $path "${w}x${h}"
    }
    update idletasks
}


BWidget::refocus
Comments BWidget::refocus --

Helper function used to redirect focus from a container frame in
a megawidget to a component widget. Only redirects focus if
focus is already on the container.

Arguments:
container container widget to redirect from.
component component widget to redirect to.

Results:
None.
Arguments container
component
Used by Tree::create
Uses  
proc BWidget::refocus {container component} {
    if { [string equal $container [::focus]] } {
    ::focus $component
    }
    return
}


GlobalVar
Comments  
Arguments  
Used by  
Uses  
namespace eval GlobalVar {
    proc use {} {}
}


GlobalVar::exists
Comments Command GlobalVar::exists
Arguments varName
Used by ProgressBar::_modify
Uses  
proc GlobalVar::exists { varName } {
    return [uplevel \#0 [list info exists $varName]]
}


GlobalVar::getvar
Comments Command GlobalVar::getvar
Arguments varName
Used by ProgressBar::_modify
DynamicHelp::_motion_info
Uses  
proc GlobalVar::getvar { varName } {
    return [uplevel \#0 [list set $varName]]
}


GlobalVar::setvar
Comments Command GlobalVar::setvar
Arguments varName
value
Used by DynamicHelp::_menu_info
DynamicHelp::_leave_info
DynamicHelp::_motion_info
BWLabel::_drop_cmd
Uses  
proc GlobalVar::setvar { varName value } {
    return [uplevel \#0 [list set $varName $value]]
}


GlobalVar::tracevar
Comments Command GlobalVar::tracevar
Arguments cmd
varName
args
Used by ProgressBar::configure
ProgressBar::_destroy
ProgressBar::create
Uses  
proc GlobalVar::tracevar { cmd varName args } {
    return [uplevel \#0 trace $cmd [list $varName] $args]
}
generated by zdoc.tcl on 2003-03-06 00:21:55