mirror of https://gitlab.com/QEF/q-e.git
562 lines
17 KiB
Plaintext
562 lines
17 KiB
Plaintext
# $RCSfile: table.itcl,v $ --
|
|
#
|
|
# This file contains the implementation of the "table" widget.
|
|
#
|
|
# Copyright (c) 2003--2004 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: table.itcl,v 1.6 2008-05-08 18:44:36 kokalj Exp $
|
|
#
|
|
|
|
#
|
|
# NOTE: the documentation of this file yet to be build
|
|
#
|
|
|
|
#table pathName \
|
|
# -caption {caption-text} \
|
|
# -head {head list} \
|
|
# -cols \# \
|
|
# -rows \# \
|
|
# -validate {validate list} \
|
|
# -variname arrayVariableName \
|
|
# -varident arrayVariableIdent \
|
|
|
|
option add *Table*Message.foreground \#000000 widgetDefault
|
|
option add *Table*Message.background \#ffffff widgetDefault
|
|
option add *Table*Message.relief solid widgetDefault
|
|
option add *Table*Message.borderWidth 1 widgetDefault
|
|
option add *Table*Message.anchor c widgetDefault
|
|
option add *Table*Entry.width 10 widgetDefault
|
|
|
|
# ------------------------------------------------------------------------
|
|
#****f* keywidgets/table
|
|
# NAME
|
|
# ::guib::keywidgets::table -- the "table" keywidget
|
|
# USAGE
|
|
# table pathName ?-option value? ?-option value? ?...?
|
|
# RETURN VALUE
|
|
# The pathName of the table widget.
|
|
# SOURCE
|
|
|
|
proc ::guib::keywidgets::table {pathName args} {
|
|
uplevel ::guib::keywidgets::Table $pathName $args
|
|
}
|
|
#********
|
|
# ------------------------------------------------------------------------
|
|
|
|
|
|
# ------------------------------------------------------------------------
|
|
#****c* keywidgets/Table
|
|
# NAME
|
|
# ::guib::keywidgets::Table -- a class for managing keywidget associated with "table" GUIB keyword
|
|
# METHODS
|
|
# ...insert...
|
|
#****
|
|
# ------------------------------------------------------------------------
|
|
|
|
itcl::class ::guib::keywidgets::Table {
|
|
inherit ::itk::Widget
|
|
|
|
private variable col
|
|
private variable row
|
|
private variable nRows 0
|
|
private variable nCols 0
|
|
private variable head
|
|
private variable validate
|
|
#private variable _loadDataVar {}
|
|
private variable _loadDataCmd {}
|
|
private variable _loadDataText {}
|
|
private variable _moduleObj
|
|
|
|
itk_option define -widgets widgets Widgets entry
|
|
itk_option define -onvalues onvalues Value 1
|
|
itk_option define -offvalues offvalues Value 0
|
|
itk_option define -caption caption Caption {}
|
|
itk_option define -head head Head {}
|
|
itk_option define -rows rows Rows 0
|
|
itk_option define -cols cols Cols 0
|
|
itk_option define -varname varname Varname _dummyName {}
|
|
itk_option define -varident varident Varident _dummyVar {}
|
|
itk_option define -validate validate Command whatever
|
|
itk_option define -state state State {}
|
|
|
|
constructor {moduleObj args} {
|
|
set _moduleObj $moduleObj
|
|
#itk_component add -- topframe {
|
|
# frame $itk_interior.topframe -bd 0 -highlightthickness 0
|
|
#}
|
|
itk_component add -- caption {
|
|
# this will be for table caption !!!
|
|
message $itk_interior.caption
|
|
} {
|
|
#usual
|
|
#eval $::guib::keywidgets::def(tableCaptionOptions)
|
|
rename -background -captionbackground captionBackground Background
|
|
}
|
|
itk_component add -- help {
|
|
button $itk_interior.help
|
|
} {
|
|
keep -width
|
|
eval $::guib::widgets::def(helpOptions)
|
|
}
|
|
itk_component add -- body {
|
|
frame $itk_interior.body
|
|
} {
|
|
keep -background
|
|
#usual
|
|
#eval $::guib::keywidgets::def(tableBodyOptions)
|
|
}
|
|
|
|
eval itk_initialize $args
|
|
#pack $itk_component(topframe) -side top -fill x -expand 1
|
|
#pack $itk_component(caption) -in $itk_component(topframe) -side left -fill x -padx 15 -pady 15
|
|
#pack $itk_component(help) -in $itk_component(topframe) -side left -padx $itk_option(-helppadx) -pady $itk_option(-helppady)
|
|
#pack $itk_component(body) -side top -fill x -padx 3 -pady 2
|
|
grid $itk_component(caption) -row 0 -column 0 -columnspan 2 -sticky ew -padx 5 -pady 5
|
|
grid $itk_component(help) -row 1 -column 1 -sticky e -padx $itk_option(-helppadx) -pady $itk_option(-helppady)
|
|
grid $itk_component(body) -row 2 -column 0 -columnspan 2 -sticky ew -padx 3 -pady 2
|
|
grid propagate $itk_interior 1
|
|
|
|
set LoaddataInfo [$_moduleObj loaddataGetInfo $itk_option(-varident)]
|
|
if { $LoaddataInfo != "" } {
|
|
#set _loadDataVar [lindex $LoaddataInfo 0]
|
|
set _loadDataCmd [lindex $LoaddataInfo 1]
|
|
set _loadDataText [lindex $LoaddataInfo 2]
|
|
|
|
set cmd [lindex $_loadDataCmd 0]
|
|
if { [info commands $cmd] == "" } {
|
|
tclu::ERROR "loaddata command $cmd not found"
|
|
}
|
|
|
|
itk_component add loaddata {
|
|
button $itk_interior.loaddata -text $_loadDataText \
|
|
-command [concat $_loadDataCmd $_moduleObj]
|
|
} {
|
|
rename -background -buttonbackground buttonBackground Background
|
|
}
|
|
|
|
set bg [option get $itk_component(loaddata) background *Table*Button.background]
|
|
catch {$itk_component(loaddata) config -bg $bg}
|
|
#pack $itk_component(loaddata) -before $itk_component(body) \
|
|
# -side top -padx 15 -pady 2 -ipadx 15
|
|
grid $itk_component(loaddata) -row 1 -column 0 -columnspan 1 -sticky ew -padx 15 -pady 2 -ipadx 15
|
|
}
|
|
}
|
|
eval $::guib::widgets::def(helpCommand)
|
|
|
|
private method _addCol {index}
|
|
private method _addRow {index}
|
|
private method _deleteCol {index}
|
|
private method _deleteRow {index}
|
|
private method _widget {ir ic}
|
|
#private method _checkbuttonText {cb var}
|
|
}
|
|
|
|
|
|
# ------------------------------------------------------------------------
|
|
# OPTIONS
|
|
# ------------------------------------------------------------------------
|
|
|
|
# ------------------------------------------------------------------------
|
|
# OPTION: -caption
|
|
#
|
|
# This option is displays the table caption
|
|
# ------------------------------------------------------------------------
|
|
itcl::configbody ::guib::keywidgets::Table::caption {
|
|
if { $itk_option(-caption) != {} } {
|
|
$itk_component(caption) configure \
|
|
-text "$itk_option(-caption)" \
|
|
-aspect [expr int(2 * [string length $itk_option(-caption)])]
|
|
bind $itk_component(caption) <Configure> {
|
|
::guib::widgets::messageAspect %W
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
# ------------------------------------------------------------------------
|
|
# OPTION: -head
|
|
#
|
|
# This option is used for the creation of table head
|
|
# ------------------------------------------------------------------------
|
|
itcl::configbody ::guib::keywidgets::Table::head {
|
|
if { $itk_option(-head) != {} } {
|
|
set ind 1
|
|
foreach label $itk_option(-head) {
|
|
if { ! [info exists head($ind)] } {
|
|
# ind-th head's label does not yet exists
|
|
set l [label $itk_component(body).0_$ind -text $label -background \#ffffff \
|
|
-width [expr [string length $label] + 4]]
|
|
grid $l -row 0 -column $ind -sticky ewns \
|
|
-padx 1 -pady 1 -ipadx 0 -ipady 0
|
|
set head($ind) 1 ; # ind-th head's label exists
|
|
} else {
|
|
set l [grid slaves $itk_component(body) -row 0 -column $ind]
|
|
$l configure -text $label
|
|
}
|
|
incr ind
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
# ------------------------------------------------------------------------
|
|
# OPTION: -cols
|
|
#
|
|
# This option is used for specifying the number of tables's columns
|
|
# ------------------------------------------------------------------------
|
|
|
|
itcl::configbody ::guib::keywidgets::Table::cols {
|
|
if { $itk_option(-cols) == "" } { return }
|
|
if { ! [string is integer $itk_option(-cols)] } {
|
|
return
|
|
}
|
|
if { $itk_option(-cols) < 1 } {
|
|
::tclu::ERROR "number of columns lower than 1"
|
|
}
|
|
|
|
if { $itk_option(-cols) > $nCols } {
|
|
#
|
|
# create new cols
|
|
#
|
|
set nc [expr $nCols + 1]
|
|
for {set ic $nc} {$ic <= $itk_option(-cols)} {incr ic} {
|
|
_addCol $ic
|
|
}
|
|
} elseif { $itk_option(-cols) < $nCols } {
|
|
#
|
|
# delete existing cols
|
|
#
|
|
for {set ir $nCols} {$ir > $itk_option(-cols)} {incr ir -1} {
|
|
_deleteCol $ir
|
|
}
|
|
}
|
|
set nCols $itk_option(-cols)
|
|
}
|
|
|
|
|
|
# ------------------------------------------------------------------------
|
|
# OPTION: -rows
|
|
#
|
|
# This option is used for specifying the number of tables's rows
|
|
# ------------------------------------------------------------------------
|
|
|
|
itcl::configbody ::guib::keywidgets::Table::rows {
|
|
if { $itk_option(-rows) == {} } {
|
|
# this happens when user deleted the number from the entry
|
|
return
|
|
}
|
|
if { ! [string is integer $itk_option(-rows)] } {
|
|
return
|
|
}
|
|
if { $itk_option(-rows) < 0 } {
|
|
::tclu::ERROR "number of rows lower than 0"
|
|
}
|
|
if { $itk_option(-rows) > $nRows } {
|
|
#
|
|
# create new rows
|
|
#
|
|
set nr [expr $nRows + 1]
|
|
for {set ir $nr} {$ir <= $itk_option(-rows)} {incr ir} {
|
|
_addRow $ir
|
|
}
|
|
} elseif { $itk_option(-rows) < $nRows } {
|
|
#
|
|
# delete existing rows
|
|
#
|
|
for {set ir $nRows} {$ir > $itk_option(-rows)} {incr ir -1} {
|
|
_deleteRow $ir
|
|
}
|
|
}
|
|
set nRows $itk_option(-rows)
|
|
}
|
|
|
|
# ------------------------------------------------------------------------
|
|
# OPTION: -validate
|
|
#
|
|
# This option is used for specifying the validation of the table's columns
|
|
# TODO: implement the option
|
|
# ------------------------------------------------------------------------
|
|
|
|
itcl::configbody ::guib::keywidgets::Table::validate {
|
|
if { $itk_option(-validate) == {} } {
|
|
set validate whatever
|
|
#set ind 1
|
|
#foreach item $itk_option(-validate) {
|
|
# set validate($ind) $item
|
|
# incr i
|
|
# #TODO: make something like:
|
|
# #set validate($ind) "::tclu::validate::numeric %c|%P"
|
|
#}
|
|
}
|
|
}
|
|
|
|
# ------------------------------------------------------------------------
|
|
# OPTION: -state
|
|
#
|
|
# This option is used for setting the state of the table
|
|
# ------------------------------------------------------------------------
|
|
|
|
itcl::configbody ::guib::keywidgets::Table::state {
|
|
if { $itk_option(-state) == "normal" } {
|
|
::tku::enableAll $itk_interior
|
|
} elseif { $itk_option(-state) == "disabled" } {
|
|
::tku::disableAll $itk_interior
|
|
}
|
|
}
|
|
|
|
|
|
# ------------------------------------------------------------------------
|
|
# OPTION: -widgets
|
|
#
|
|
# This option is used for setting the widgets/per-columns of the table
|
|
# ------------------------------------------------------------------------
|
|
|
|
itcl::configbody ::guib::keywidgets::Table::widgets {
|
|
#puts stderr "::guib::keywidgets::Table::widgets called from [info level -1], -widgets = $itk_option(-widgets)"
|
|
}
|
|
|
|
# ------------------------------------------------------------------------
|
|
# OPTION: -onvalues
|
|
#
|
|
# This option is used for setting the on-values for the table cell widgets
|
|
# like checkbutton
|
|
# ------------------------------------------------------------------------
|
|
|
|
itcl::configbody ::guib::keywidgets::Table::onvalues {
|
|
}
|
|
|
|
# ------------------------------------------------------------------------
|
|
# OPTION: -offvalues
|
|
#
|
|
# This option is used for setting the off-value for the table cell widgets
|
|
# like checkbutton
|
|
# ------------------------------------------------------------------------
|
|
|
|
itcl::configbody ::guib::keywidgets::Table::offvalues {
|
|
}
|
|
|
|
|
|
|
|
# ------------------------------------------------------------------------
|
|
# METHODS
|
|
# ------------------------------------------------------------------------
|
|
|
|
|
|
# ------------------------------------------------------------------------
|
|
# METHOD: _addRow (private)
|
|
#
|
|
# This private method handles the additon of a row
|
|
# ------------------------------------------------------------------------
|
|
|
|
itcl::body ::guib::keywidgets::Table::_addRow {ir} {
|
|
#
|
|
# add row's label
|
|
#
|
|
if { ! [winfo exists $itk_component(body).${ir}_0] } {
|
|
set l [label $itk_component(body).${ir}_0 -text $ir -background \#ffffff]
|
|
grid $l -row $ir -column 0 -sticky ewns -padx 1 -pady 1 -ipadx 0 -ipady 0
|
|
}
|
|
|
|
#
|
|
# add row's columns
|
|
#
|
|
for {set ic 1} {$ic <= $nCols} {incr ic} {
|
|
set e [_widget $ir $ic]
|
|
grid $e -row $ir -column $ic -sticky ewns \
|
|
-padx 0 -pady 0 -ipadx 0 -ipady 0
|
|
set col($ic) 1 ; # column $ic exists now
|
|
}
|
|
|
|
set row($ir) 1 ; # row $ir exists now
|
|
}
|
|
|
|
|
|
# ------------------------------------------------------------------------
|
|
# METHOD: _addCol (private)
|
|
#
|
|
# This private method handles the additon of a column
|
|
# ------------------------------------------------------------------------
|
|
|
|
itcl::body ::guib::keywidgets::Table::_addCol {ic} {
|
|
#
|
|
# add column $ic to all rows !!!
|
|
#
|
|
|
|
#set validate [::tclu::lget $itk_option(-validate) [expr $ic - 1]]
|
|
#if { $validate == "string" || $validate == "" } {
|
|
# set validate whatever
|
|
#}
|
|
|
|
for {set ir 1} {$ir <= $nRows} {incr ir} {
|
|
set e [_widget $ir $ic]
|
|
#set e [entry $itk_component(body).${ir}_${ic} \
|
|
# -textvariable $itk_option(-varident)($ir,$ic) \
|
|
# -validate key \
|
|
# -validatecommand "::guib::widgets::$validate %P"]
|
|
grid $e -row $ir -column $ic -sticky ewns \
|
|
-padx 0 -pady 0 -ipadx 0 -ipady 0
|
|
}
|
|
set col($ic) 1 ; # column $ic exists now
|
|
}
|
|
|
|
|
|
# ------------------------------------------------------------------------
|
|
# METHOD: _deleteRow (private)
|
|
#
|
|
# This private method handles the deletion of a row
|
|
# ------------------------------------------------------------------------
|
|
|
|
itcl::body ::guib::keywidgets::Table::_deleteRow {ir} {
|
|
#
|
|
# delete row's label
|
|
#
|
|
set l [grid slaves $itk_component(body) -row $ir -column 0]
|
|
#grid remove $l
|
|
destroy $l
|
|
|
|
#
|
|
# delete row's columns
|
|
#
|
|
for {set ic 1} {$ic <= $nCols} {incr ic} {
|
|
set e [grid slaves $itk_component(body) -row $ir -column $ic]
|
|
#grid remove $e
|
|
destroy $e
|
|
}
|
|
|
|
unset row($ir) ; # row $ir does not exist
|
|
}
|
|
|
|
# ------------------------------------------------------------------------
|
|
# METHOD: _deleteRow (private)
|
|
#
|
|
# This private method handles the deletion of column
|
|
# ------------------------------------------------------------------------
|
|
|
|
itcl::body ::guib::keywidgets::Table::_deleteCol {ic} {
|
|
#
|
|
# delete column $ic for all rows !!!
|
|
#
|
|
for {set ir 0} {$ir <= $nRows} {incr ir} {
|
|
set e [grid slaves $itk_component(body) -row $ir -column $ic]
|
|
if { $ir == 0 } {
|
|
#
|
|
# This is table's HEAD.
|
|
#
|
|
unset head($ic)
|
|
}
|
|
|
|
#
|
|
# The HEAD labels might be missing!!! In this case the
|
|
# $e == {} and grid remove {} would cause an error.
|
|
#
|
|
if { $e != {} } {
|
|
#grid remove $e
|
|
destroy $e
|
|
}
|
|
}
|
|
unset col($ic) ; # column $ic does not exist
|
|
}
|
|
|
|
# ------------------------------------------------------------------------
|
|
# METHOD: _widget (private)
|
|
#
|
|
# This private method handles the table widgets creation
|
|
# ------------------------------------------------------------------------
|
|
|
|
itcl::body ::guib::keywidgets::Table::_widget {ir ic} {
|
|
|
|
set ic1 [expr $ic - 1]
|
|
set widtxtcmd [::tclu::lget $itk_option(-widgets) $ic1]
|
|
set on [::tclu::lget $itk_option(-onvalues) $ic1]
|
|
set off [::tclu::lget $itk_option(-offvalues) $ic1]
|
|
|
|
# syntax: widget.buttontext.buttoncommand
|
|
set wid [lindex $widtxtcmd 0]
|
|
set txt [lindex $widtxtcmd 1]
|
|
set cmd [lindex $widtxtcmd 2]
|
|
|
|
set textVar [$_moduleObj tableref $itk_option(-varident) $ir $ic]
|
|
if { ! [info exists $textVar] } {
|
|
set $textVar {}
|
|
}
|
|
|
|
switch -exact -- $wid {
|
|
entry -
|
|
entryfileselect {
|
|
if { $wid == "entryfileselect" } {
|
|
set wid ::guib::widgets::entryfileselect
|
|
}
|
|
set result [$wid $itk_component(body).${ir}_${ic} \
|
|
-background seashell \
|
|
-textvariable $textVar]
|
|
|
|
# temp ...
|
|
if { $wid == "entry" } {
|
|
set validate [::tclu::lget $itk_option(-validate) [expr $ic - 1]]
|
|
if { $validate == "string" || $validate == "" } {
|
|
set validate whatever
|
|
}
|
|
$itk_component(body).${ir}_${ic} configure -validate key \
|
|
-validatecommand "::guib::widgets::$validate %P"
|
|
}
|
|
# ... end
|
|
}
|
|
|
|
entrybutton {
|
|
if { [llength $widtxtcmd] != 3 } {
|
|
::tclu::ERROR "expected \"widget buttontext buttoncommand\" elements, but got: $widtxtcmd\""
|
|
}
|
|
set result [::guib::widgets::entrybutton $itk_component(body).${ir}_${ic} \
|
|
-background seashell \
|
|
-textvariable $textVar \
|
|
-buttontext $txt \
|
|
-buttoncommand [list eval $cmd $ir $ic]]
|
|
}
|
|
|
|
checkbutton {
|
|
upvar $textVar value
|
|
|
|
set textVar [$_moduleObj tableref $itk_option(-varident) $ir $ic]
|
|
set cb $itk_component(body).${ir}_${ic}
|
|
set result [checkbutton $cb \
|
|
-variable $textVar \
|
|
-textvariable $textVar \
|
|
-onvalue $on \
|
|
-offvalue $off]
|
|
# not used anymore: -command [code $this _checkbuttonText $cb $textVar]
|
|
}
|
|
|
|
optionmenu {
|
|
if { [llength $widtxtcmd] != 2 } {
|
|
::tclu::ERROR "expected \"optionmenuhelp {item1 ...}\" elements, but got: $widtxtcmd\""
|
|
}
|
|
set result [::guib::widgets::optionmenuhelp $itk_component(body).${ir}_${ic} -textvariable $textVar -textvalues $txt -nohelp 1]
|
|
}
|
|
|
|
default {
|
|
::tclu::ERROR "widget type \"$wid\" not supported"
|
|
}
|
|
}
|
|
return $result
|
|
}
|
|
|
|
|
|
|
|
#body ::guib::keywidgets::Table::_checkbuttonText {cb var} {
|
|
# upvar $var varValue
|
|
# $cb configure -text $varValue
|
|
#} |