# $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) { ::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 #}