scnc
/
quantum-espresso
mirror of https://gitlab.com/QEF/q-e.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity
quantum-espresso/GUI/Guib/lib/tkUtils.tcl

593 lines
15 KiB
Tcl
Raw Permalink Blame History

#
# $RCSfile: tkUtils.tcl,v $ --
#
# This file contains the Tone Kokalj's Tk utilities functions.
#
# Copyright (c) 2003 Anton Kokalj Email: tone.kokalj@ijs.si
#
#
# This file is distributed under the terms of the GNU General Public
# License. See the file `COPYING' in the root directory of the present
# distribution, or http://www.gnu.org/copyleft/gpl.txt .
#
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
# OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
# ANTON KOKALJ BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN
# AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
# CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
#
#
# $Id: tkUtils.tcl,v 1.10 2009-08-03 14:22:43 kokalj Exp $
#
#------------------------------------------------------------------------
#****h* TclTkLib/::tku
# NAME
# TKU == Tone Kokalj's Tk Utilities
#
# COPYRIGHT
# 2002--2004 (c) by Tone Kokalj
#
# AUTHOR
# Tone Kokalj
#
# CREATION DATE
# Starting on Fri Dec 14 08:32:59 CET 2001
#
# NOTES
# Here are the basic Tk utility functions
#******
#------------------------------------------------------------------------
package provide tku 0.9
package require Tk
namespace eval ::tku {
variable cursor
variable widgetCounter 0
variable toplevelCounter 0
variable getAllDescendants_list
set cursor(default) [. cget -cursor]
set cursor(watch) watch
namespace export widgetName
namespace export toplevelName
namespace export toplevelExists
namespace export disableAll
namespace export enableAll
namespace export getAllDescendants
namespace export centerWindow
namespace export createFont
namespace export setCursor
namespace export resetCursor
namespace export watchExec
namespace export getOpenFile
namespace export getSaveFile
namespace export exitApp
}
#------------------------------------------------------------------------
#****f* ::tku/::tku::widgetName
# NAME
# ::tku::widgetName -- generates new widget name
# USAGE
# ::tku::widgetName ?parent? ?lastName?
#
# DESCRIPTION
# This proc is used for generating a unique widget name.
#
# ARGUMENTS
# * parent -- widget name of the parent widget
# * lastName -- a prefix for the lastname of the widget (i.e. .a.a.lastname)
#
# RETURN VALUE
# A unique widget name.
#
# EXAMPLE
# ::tku::widgetName $parent
#********
#------------------------------------------------------------------------
proc ::tku::widgetName {{wid {}} {lastName {}}} {
variable widgetCounter
while {1} {
if { [winfo exists ${wid}.${lastName}$widgetCounter] } {
incr widgetCounter
} else {
return ${wid}.${lastName}$widgetCounter
}
}
}
#------------------------------------------------------------------------
#****f* ::tku/::tku::toplevelName
# NAME
# ::tku::toplevelName -- generates new toplevel-widget name
# USAGE
# ::tku::toplevelName ?prefix?
#
# DESCRIPTION
# This proc is used for generating a unique toplevel-widget name.
#
# ARGUMENTS
# * prefix -- prefix for the widget name (for example ".tplw")
#
# RETURN VALUE
# A unique toplevel-widget name.
#
# EXAMPLE
# ::tku::toplevelName $parent
#********
#------------------------------------------------------------------------
proc ::tku::toplevelName {{prefix .tplw}} {
variable toplevelCounter
set prefix .[string trim $prefix "."]
while {1} {
if { [winfo exists ${prefix}$toplevelCounter] } {
incr toplevelCounter
} else {
return ${prefix}$toplevelCounter
}
}
}
#------------------------------------------------------------------------
#****f* ::tku/::tku::toplevelExists
# NAME
# ::tku::toplevelExists -- checks if toplevel already exists
# USAGE
# ::tku::toplevelExists pathName
#
# DESCRIPTION
# This proc is used for checking if widget pathName already exists.
# If it does not exists it just returns the pathName, otherwise the
# "return -code return" is issued, to return from the caller proc.
#
# ARGUMENTS
# * pathName -- widget path-name
#
# RETURN VALUE
# If pathName widget does not exists it returns pathName, otherwise
# returns the "-code return".
#
# EXAMPLE
# ::tku::toplevelExists $widget
#********
#------------------------------------------------------------------------
proc ::tku::toplevelExists {pathName} {
if { [winfo exists $pathName] } {
return -code return
} else {
return $pathName
}
}
#****f* ::tku/::tku::disableAll
# SYNOPSIS
proc ::tku::disableAll {wlist} {
# PURPOSE
# Disables all wlist widgets and its children recursively.
# ARGUMENTS
# * wlist -- list of widgets to disable
# SOURCE
foreach w $wlist {
if { ! [winfo exists $w] } {
continue
}
set children [winfo children $w]
if { $children != "" } {
foreach w $children {
disableAll $w
catch {$w configure -state disabled}
}
}
}
}
#******
#****f* ::tku/::tku::enableAll
# SYNOPSIS
proc ::tku::enableAll {wlist} {
# PURPOSE
# Enable all widgets and its children recursively.
# ARGUMENTS
# * wlist -- list of widgets to enable
# SOURCE
foreach w $wlist {
if { ! [winfo exists $w] } {
continue
}
set children [winfo children $w]
if { $children != "" } {
foreach w $children {
enableAll $w
catch {$w configure -state normal}
}
}
}
}
#******
#****f* ::tku/::tku::getAllDescendants
# SYNOPSIS
proc ::tku::getAllDescendants {w} {
# PURPOSE
# Return a list of all descendants of a given window.
# ARGUMENTS
# * w -- window for which to return all its descendants
# SOURCE
variable getAllDescendants_list
if { [info exists getAllDescendants_list] } {
set getAllDescendants_list ""
}
return [getAllDescendants_ $w]
}
proc getAllDescendants_ {wlist} {
global getAllDescendants_list
foreach w $wlist {
if { ![winfo exists $w] } continue
lappend getAllDescendants_list $w
set children [winfo children $w]
if { $children != "" } {
foreach child $children {
getAllDescendants_ $child
}
}
}
return $getAllDescendants_list
}
#******
#****f* ::tku/::tku::mouseWheelScrollCanvas
# SYNOPSIS
proc ::tku::mouseWheelScrollCanvas {can} {
# PURPOSE
# Arrange all necessary that a given canvas will be scrolled by
# mouse-wheel, even when the canvas possesses many descendant
# widgets (i.e. binds all descendants of a given canvas widget
# to scroll the canvas by mouse-wheel.
# ARGUMENTS
# * can -- path of the canvas widget
# SOURCE
set scrollCmd_B4 [list $can yview scroll -2 units]
set scrollCmd_B5 [list $can yview scroll +2 units]
# TODO: please tune the %D on windows
set scrollCmd_Wheel [list $can yview scroll %D units]
set scrWin [getAllDescendants $can]
global tcl_platform
foreach wid $scrWin {
if { [winfo exists $wid] } {
if { $tcl_platform(platform) == "unix" } {
bind $wid <Button-4> $scrollCmd_B4
bind $wid <Button-5> $scrollCmd_B5
} else {
# TODO: please tune the %D on windows
bind $wid <MouseWheel> $scrollCmd_Wheel
}
}
}
}
#******
#****f* ::tku/::tku::mouseWheelScrollDeleteBindings
# SYNOPSIS
proc ::tku::mouseWheelScrollDeleteBindings {can} {
# PURPOSE
# The opposite of the ::tku::mouseWheelScrollCanvas command: it
# destroys all the mouse-wheel binding assciated with the
# scrolling of the given canvas, so that mouse-wheel does not
# have any effect more.
# ARGUMENTS
# * can -- path of the canvas widget
# SOURCE
set scrWin [::tku::getAllDescendants $can]
global tcl_platform
foreach wid $scrWin {
if { [winfo exists $wid] } {
if { $tcl_platform(platform) == "unix" } {
bind $wid <Button-4> ""
bind $wid <Button-5> ""
} else {
# TODO: please tune the %D on windows
bind $wid <MouseWheel> ""
}
}
}
}
#****f* ::tku/::tku::centerWindow
# SYNOPSIS
proc ::tku::centerWindow {thisWin {otherWid {}}} {
# PURPOSE
# Centers the toplevel with respect to another widget or the
# screen as a whole.
# ARGUMENTS
# * thisWin -- name of widget to center
# * otherWid -- name of widhet the thisWin will be centered onto
# SOURCE
update idletasks
# if otherWid is {}, then center width respect to the root window
set w [winfo reqwidth $thisWin]
set h [winfo reqheight $thisWin]
# root window height/width
set rh [winfo screenheight $thisWin]
set rw [winfo screenwidth $thisWin]
if { $otherWid == "" } {
set reqX [expr {($rw-$w)/2}]
set reqY [expr {($rh-$h)/2}]
} else {
set wfudge 5 ;# wm width fudge factor
set hfudge 20 ;# wm height fudge factor
set otherWidW [winfo width $otherWid]
set otherWidH [winfo height $otherWid]
set reqX [expr {[winfo rootx $otherWid]+($otherWidW-($otherWidW/2))-($w/2)}]
set reqY [expr {[winfo rooty $otherWid]+($otherWidH-($otherWidH/2))-($h/2)}]
# Adjust for errors - if too long or too tall
if { $reqX+$w+$wfudge > $rw } { set reqX [expr {$rw-$w-$wfudge}] }
if { $reqX < $wfudge } { set reqX $wfudge }
if { $reqY+$h+$hfudge > $rh } { set reqY [expr {$rh-$h-$hfudge}] }
if { $reqY < $hfudge } { set reqY $hfudge }
}
wm geometry $thisWin +$reqX+$reqY
}
#******
#****f* ::tku/::tku::createFont
# SYNOPSIS
proc ::tku::createFont {args} {
# PURPOSE
# Create new Tk Font with requested attributes (args=="option value"
# pairs), and return its name
# ARGUMENTS
# * args -- arguments passed to font configure (i.e. option value
# pairs specifying font attributres, see font Tk-command)
#
# SOURCE
set fontName [font create]
eval font configure $fontName $args
return $fontName
}
#******
#****f* ::tku/::tku::setCursor
# SYNOPSIS
proc ::tku::setCursor {cursorName {window .}} {
# PURPOSE
# Set a new cursor, one among those defined by cursor variables.
# So far supported names are:
# * watch
# * default
# ARGUMENTS
# * cursorName -- name for the new cursor
# * window -- (optional) name of window for which to change cursor
# (propagates to its children too)
# SOURCE
variable cursor
switch -exact -- $cursorName {
watch { set _cursor $cursor(watch) }
default { set _cursor $cursor(default) }
}
foreach t [winfo children $window] {
if { [info commands $t] != "" } {
$t config -cursor $_cursor
}
}
$window config -cursor $_cursor
update
}
#******
#****f* ::tku/::tku::resetCursor
# SYNOPSIS
proc ::tku::resetCursor {{window .}} {
# PURPOSE
# Sets a default cursor for specified window.
# ARGUMENTS
# * window -- (optional) name of window for which to set the cursor to default
# (propagates to its children too)
# SOURCE
variable cursor
foreach t [winfo children $window] {
if { [info commands $t] != "" } {
$t config -cursor $cursor(default)
}
}
$window config -cursor $cursor(default)
update
}
#******
#------------------------------------------------------------------------
#****f* ::tku/::tku::watchExec
# NAME
# ::tku::watchExec -- execute a script and display a watch cursor
# USAGE
# ::tku::watchExec script
#
# DESCRIPTION
# This proc executes a script and displays a watch cursor during exec. The
# content of the script is evaluated at the caller level (i.e. uplevel 1
#
# ARGUMENTS
# * parent -- widget name of the parent widget
# * lastName -- a prefix of the last-name of the widget (i.e. .a.a.lastname)
#
# RETURN VALUE
# Returns the last return-value of the last command in the script.
#
# EXAMPLE
# ::tku::watchExec {
# do_whatever $a $b
# do_this_and_that $c $d
# }
#********
#------------------------------------------------------------------------
proc ::tku::watchExec {script} {
::tku::setCursor watch
set result [uplevel 1 $script]
::tku::resetCursor
return $result
}
#****f* ::tku/::tku::getOpenFile
# SYNOPSIS
proc ::tku::getOpenFile {file args} {
# PURPOSE
# Get (return) the name of file for opening, in particular:
# if $file == "" --> query file
# else --> check if file exists
# ARGUMENTS
# * file -- name of file to open (if empty-string, query the file to open)
# * args -- arguments passed to tk_getOpenFile if file == {}
# SOURCE
if { $file == {} } {
# query file ...
set file [eval tk_getOpenFile $args]
if { $file == "" } {
return -code return
}
} else {
# check if file exists
if { ![file exists $file] } {
# note: tku's errorDialog should not use return
::tclu::warningDialog "file \"$file\" does not exists !!!"
return -code return
}
}
return $file
}
#******
#****f* ::tku/::tku::getSaveFile
# SYNOPSIS
proc ::tku::getSaveFile {file args} {
# PURPOSE
# Get (return) the name of file for saving, in particular:
# if $file == "" --> query file
# else --> check if dirname of file exists and is writeable
# ARGUMENTS
# * file -- name of file to open (if empty-string, query the file to open)
# * args -- arguments passed to tk_getSaveFile if file == {}
# SOURCE
if { $file == {} } {
# query file ...
set file [eval tk_getSaveFile $args]
if { $file == "" } {
return -code return
}
} else {
# check if dirname of file exists
set dirname [file dirname $file]
if { ! [file writable $dirname] } {
::tclu::errorDialog "can't create file \"$file\". Permission denied !!!"
return -code return ""
}
if { ! [file isdirectory $dirname] } {
# note: tku's errorDialog should not use return
tclu::errorDialog "can't create \"$file\". Directory $dirname does not exists. !!!"
return -code return ""
}
}
return $file
}
#******
#****f* ::tku/::tku::exitApp
# SYNOPSIS
proc ::tku::exitApp {{cmdAtExit {}}} {
# PURPOSE
# Exit from application if user clicks "Yes" button.
# ARGUMENTS
# * cmdAtExit -- command to execute before exiting
# SOURCE
set button [tk_messageBox -message "Really quit?" \
-type yesno -icon question]
if { $button == "yes" } {
# do everything requested before exiting ...
if { $cmdAtExit != "" } {
eval $cmdAtExit
}
# delete all temporary files ...
::tclu::tempFile delete all
exit
}
}
#******
Reference in New Issue View Git Blame Copy Permalink