Private methods and state information?
Hi,
I am trying to translate this table widget from [incr Tcl] to
STk :)
Well,
I have a couple of questions:
How can one create private methods in Stk?
For instance, _show_scrollbars ...
Also, how can I specified private information about the class.
For instance, in the constructor for "table", it creates a scrollbar:
scrollbar $this.vsbframe.vscroll \
-orient vert \
-command "$this display_row"
So what is the semantic equivalent for Stk?
Tnks,
Amancio
------ Here is the [incr Tcl] table Widget------
#
# [incr Tcl] Table
# ----------------------------------------------------------------------
# Implements a table widget using [incr Tcl].
#
# PUBLIC ATTRIBUTES:
#
# -heading ....... reserve room for column headings (1/0)
# -rows .......... number of rows to display on screen
# -cols .......... number of columns to display on screen
# -cell_width .... cell width in characters [TODO: or "expand"?]
# -cell_format.... standard format specifier (eg., %s|%d|%e|%f)
# -show_scroll ... always show scrollbars? (1/0)
# -show_col_scroll always show column scrollbars? (1/0)
# -never_show_col_scroll NEVER show column scrollbars? (1/0) [TODO]
# -spacer ........ spacer to align scrollbar to table (see below)
# -verbose ....... turn on verbose mode. (1/0)
#
# METHODS:
#
# constructor .... create table instance and initialize options/state
# destructor .... destroys the widget and deletes the Tcl command
# configure ...... used to change public attributes
#
# add_row ........ add a new row with the optional supplied data
# add_col ........ add a new col with the optional supplied data
# replicate_row .. replicate this row and add it to the bottom
# replicate_col .. replicate this col and add it to the end
# insert_row ..... insert a row and push everything down
# insert_col ..... insert a col and push everything to the right
# delete_row ..... delete the given row
# delete_col ..... delete the given column
# display_row .... display a row
# display_col .... display a col
#
# select_cell .... selects a row,col to start editing
# clear .......... empty out all cells
# fill ........... fill a table with empty rows and columns upto capacity
# displayed ...... check if a row or a column is visible or not.
#
# set_heading .... set the column heading
# set_cell........ set the cell value
# set_table ...... sets ALL the cells in the entire table
# set_row ........ sets the cells in the entire row
# set_col ........ sets the cells in the entire column
#
# get_size ....... query table size (returns {nrows ncols})
# get_cur_cell ... query which cell has focus (returns {row col})
# get_cell ....... query selected [row,column] item
# get_row ........ query whole row
# get_col ........ query whole column
# get_named_col .. query the column under a particular heading
# get_headings ... query all the headings
# get_value ...... query public variables by name
#
# next_cell ...... goto next cell in $_next_dir direction
# left_cell ...... goto cell on the left
# right_cell...... goto cell on the right
# up_cell ........ goto cell on the up above
# down_cell ...... goto cell on the down below
# paste_cell ..... paste the X11 selection into cell
# edit_cell ...... hack to get around bind {+new_command} problem.
#
# PRIVATE METHODS:
#
# _vputs ............... prints msg if $verbose = 1
# _min ................. returns lesser of $x and $y
# _max ................. returns greater of $x and $y
# _bind_cell ........... specify the bindings for cell widgets
# _bind_heading ........ specify the bindings for heading widgets
# select_cell .......... set the current focus
# select_cell_special .. edit the cell in a real window
# _set_cell_special .... set the cell from user input
# _show_scrollbars ..... pack scrollbars if needed/specified
# _show_cscrollbars .... pack column scrollbars if needed
# _scroll_column ....... scroll a whole column
#
# _copy_cell ........... copy a cell
# _copy_row ............ copy an entire row
# _copy_col ............ copy an entire col
#
# PRIVATE ATTRIBUTES:
#
# See list at the end of class definition
#
# X11 OPTION DATABASE ATTRIBUTES
#
# cellBackground ....... background color for cells
# cellForeground ....... foreground color for cells
#
# headingBackground .... background color for headings
# headingForeground .... foreground color for headings
#
# focusBackground ...... background color for current focus cell
# focusForeground ...... foreground color for current focus cell
#
# ...and the rest of the usual widget attributes
#
# BINDINGS:
# HACK: I wanted to augment the Entry <1> binding to also highlight
# the cell with the current focus, but the {+new_binding} doesn't
# seem to work for me, so I simply copied the binding from tk.tcl.
# see method edit_cell.
#
# ----------------------------------------------------------------------
# AUTHOR: Mumit Khan Phone: (608)877 2400
# CXrL, U of WI-Madison E-mail: khan_at_xraylith.wisc.edu
#
# RCS: table.tcl,v 1.1 1994/05/15 13:39:21 khan Exp
# ----------------------------------------------------------------------
# Copyright (c) 1994 Mumit Khan
# ======================================================================
#
itcl_class Table {
#------------------------------------------------------------
# Table construction/destruction routines
#------------------------------------------------------------
# ------------------------------------------------------------------
# CONSTRUCTOR - create new table
# ------------------------------------------------------------------
constructor {config} {
_vputs "creating Table instance $this ..."
#
# Create a window with the same name as this object
#
set class [$this info class]
::rename $this $this-tmp-
::frame $this -class $class
::rename $this $this-win-
::rename $this-tmp- $this
#
# set resource options
#
set _cell_bg [option get $this cellBackground Table]
if {$_cell_bg == ""} {set _cell_bg lightgrey}
set _cell_fg [option get $this cellForeground Table]
if {$_cell_fg == ""} {set _cell_fg black}
set _heading_bg [option get $this headingBackground Table]
if {$_heading_bg == ""} {set _heading_bg LightSteelBlue}
set _heading_fg [option get $this headingForeground Table]
if {$_heading_fg == ""} {set _heading_fg black}
set _focus_bg [option get $this focusBackground Table]
if {$_focus_bg == ""} {set _focus_bg pink}
set _focus_fg [option get $this focusForeground Table]
if {$_focus_fg == ""} {set _focus_fg $_cell_fg}
#
# title
#
# frame $this.title
#
# FIXME/TODO
#
# Set the protected state variables that're not part of config set.
set _constructed 1
set _row_total 0
set _row_first 0
set _row_last 0
set _col_total 0
set _col_first 0
set _col_last [expr $cols-1]
set _vscroll_shown $show_scroll
set _hscroll_shown $show_scroll
#
# make scrollbars. if the variable show_scroll is 0, then the
# scrollbars are visible only when the table size is larger than
# screen allocation.
#
# the tricky part is adding little spacers on top/bottom of the
# vertical scrollbar and to the right of the horizontal scrollbar
# so that the scrollbars are aligned with the table itself.
#
_vputs "creating frames/scrollbars ..."
frame $this.vsbframe
scrollbar $this.vsbframe.vscroll \
-orient vert \
-command "$this display_row"
if {$heading} {
set spacer_geom $spacer
} else {
set spacer_geom 0x0
}
frame $this.vsbframe.tspacer -geom $spacer_geom -bg $_cell_bg
frame $this.vsbframe.bspacer -geom $spacer -bg $_cell_bg
$this.vsbframe.vscroll set 0 0 0 0
scrollbar $this.hscroll \
-orient horizontal \
-command "$this display_col"
$this.hscroll set 0 0 0 0
}
# ------------------------------------------------------------------
# DESTRUCTOR - destroy window containing widget
# ------------------------------------------------------------------
destructor {
::rename $this-win- {}
destroy $this
}
# ------------------------------------------------------------------
# METHOD: configure - used to change public attributes
# ------------------------------------------------------------------
method configure {config} {
_vputs "Configuring ..."
}
# ------------------------------------------------------------------
# METHOD: display_row -
# ------------------------------------------------------------------
method display_row {first {force 0}} {
_vputs "viewing row $first ..."
set first [_max 0 [_min $first [expr $_row_total-$rows]]]
set last [expr [_min $_row_total [expr $first+$rows]]-1]
_vputs "... adjusted to row $first ..."
# might have pack/unpack the whole bit. Yuk!
if {$force || $first > $_row_last | $last < $_row_first} {
# Force unpack everything...
for {set row 0} {$row < $_row_total} {incr row} {
for {set col 0} {$col < $_col_total} {incr col} {
catch "pack unpack $this.$col.$row"
}
}
# pack stuff back in...
for {set row $first} {$row <= $last} {incr row} {
for {set col 0} {$col < $_col_total} {incr col} {
catch "pack $this.$col.$row -side top -fill x"
}
}
} else {
#
# assume overlapped scrolling
#
if {$first >= $_row_first} {
# remove from the top
for {set row $_row_first} {$row < $first} {incr row} {
for {set col 0} {$col < $_col_total} {incr col} {
catch "pack unpack $this.$col.$row"
}
}
# add to the bottom
for {set row $_row_last} {$row <= $last} {incr row} {
for {set col 0} {$col < $_col_total} {incr col} {
pack $this.$col.$row -side top -fill x
}
}
}
if {$first < $_row_first} {
# scroll up
for {set row $_row_last} {$row > $last} {incr row -1} {
for {set col 0} {$col < $_col_total} {incr col} {
catch "pack unpack $this.$col.$row"
}
}
# Add to the top
for {set row [expr $_row_first-1]} {$row >= $first} \
{incr row -1} {
for {set col 0} {$col < $_col_total} {incr col} {
pack $this.$col.$row -before $this.$col.[expr $row+1] \
-side top -fill x
}
}
}
}
set _row_first $first
set _row_last $last
$this.vsbframe.vscroll set $_row_total $rows $first $last
}
# ------------------------------------------------------------------
# METHOD: display_col -
# ------------------------------------------------------------------
method display_col {first {force 0}} {
_vputs "viewing col $first ..."
set first [_max 0 [_min $first [expr $_col_total-$cols]]]
set last [expr [_min $_col_total [expr $first+$cols]]-1]
_vputs "... adjusted to col $first ..."
# might have pack/unpack the whole bit. Yuk!
if {$force || $first > $_col_last | $last < $_col_first} {
# unpack everything...
for {set col 0} {$col < $_col_total} {incr col} {
catch "pack unpack $this.$col"
}
# pack stuff back in...
for {set col $first} {$col <= $last} {incr col} {
catch "pack $this.$col -side left -fill y"
}
} else {
#
if {$first >= $_col_first} {
# Remove from the top (scroll down)
for {set col $_col_first} {$col < $first} {incr col} {
catch "pack unpack $this.$col"
}
# Add to the bottom
for {set col $_col_last} {$col <= $last} {incr col} {
pack $this.$col -side left -fill y
}
}
if {$first < $_col_first} {
# Remove from the bottom (scroll up)
for {set col $_col_last} {$col > $last} {incr col -1} {
catch "pack unpack $this.$col"
}
# Add to the top
for {set col [expr $_col_first-1]} {$col >= $first} \
{incr col -1} {
pack $this.$col -before $this.[expr $col+1] \
-side left -fill y
}
}
}
set _col_first $first
set _col_last $last
$this.hscroll set $_col_total $cols $first $last
}
# ------------------------------------------------------------------
# METHOD: _show_scrollbars
# ------------------------------------------------------------------
method _show_scrollbars {} {
_vputs "showing scrollbars ..."
if {$_vscroll_shown} {
pack $this.vsbframe.tspacer -side top -anchor n
pack $this.vsbframe.vscroll -side top -expand 1 -fill y -anchor n
if {$_hscroll_shown} {
pack $this.vsbframe.bspacer -side bottom -anchor s
}
pack $this.vsbframe -before $this.$_col_first \
-side right -fill y -expand 1
} else {
pack unpack $this.vsbframe
}
if {$_hscroll_shown} {
if $_vscroll_shown {
pack $this.hscroll -after $this.vsbframe -side bottom -fill x
} else {
pack $this.hscroll -before $this.$_col_first \
-side bottom -fill x
}
} else {
pack unpack $this.hscroll
}
}
# ------------------------------------------------------------------
# METHOD: _scroll_column
# ------------------------------------------------------------------
method _scroll_column {col i1 i2 i3 i4} {
#_vputs "scrolling column $col ($i1 $i2 $i3 $i4) ..."
#for {set row 0} {$row < $_row_total} {incr row} {
# $this.$col.$row view $i3
#}
#$this.$col.cscroll set $_max_cell_width $cell_width $i3 $i4
}
method _scroll_column2 {col i1} {
_vputs "2: scrolling column $col ($i1) ..."
for {set row 0} {$row < $_row_total} {incr row} {
$this.$col.$row view $i1
}
$this.$col.cscroll set $_col_widths($col) $cell_width \
$i1 [expr $i1 + $cell_width - 1]
}
method _update_col_scroll {col width} {
_vputs "updating col $col scrollbar with width = $width"
$this.$col.cscroll set $width $cell_width \
0 [expr $cell_width-1]
}
method _show_cscrollbars {} {
_vputs "showing column scrollbars"
if {$_col_scroll_shown} {
for {set col 0} {$col < $_col_total} {incr col} {
if {![winfo exists $this.$col.cscroll]} {
scrollbar $this.$col.cscroll \
-orient horizontal \
-command "$this _scroll_column2 $col"
}
if [winfo exists $this.$col.header] {
pack $this.$col.cscroll -side top -fill x \
-after $this.$col.header
} else {
pack $this.$col.cscroll -side top -fill x \
-after $this.$col.header
}
_update_col_scroll $col $_col_widths($col)
}
}
}
# ------------------------------------------------------------------
# METHOD: clear - clear out all cells
# ------------------------------------------------------------------
method clear {{heading 0}} {
if {$heading} {set_heading {}}
for {set row 0} {$row < $_row_total} {incr row} {
set_row $row {} 1
}
}
# ------------------------------------------------------------------
# METHOD: fill - fill empty cells
# ------------------------------------------------------------------
method fill {} {
set need_cols [expr $cols-$_col_total]
set need_rows [expr $rows-$_row_total]
for {set col 0} {$col < $need_cols} {incr col} {
add_col {}
}
for {set row 0} {$row < $need_rows} {incr row} {
add_row {}
}
}
#------------------------------------------------------------
# Table Header Management
#------------------------------------------------------------
# ------------------------------------------------------------------
# METHOD: set_heading -
# ------------------------------------------------------------------
method set_heading {headings} {
# might have to add empty columns
if {$_col_total == 0} {
set _col_total [llength $headings]
for {set col 0} {$col < $_col_total} {incr col} {
frame $this.$col
}
# force unpacking/packing off all cells
display_col 0 1
$this.hscroll set $_col_total $cols 0 \
[expr [_min $_col_total $cols]-1]
# show scrollbars if needed.
if {$_col_total > $cols || $show_scroll} {
set _hscroll_shown 1
_show_scrollbars
}
}
#
# these columns may not have had any headings until now, so create
# new entries if necessary.
#
set no_heading [catch {$this.0.header get}]
if {!$_have_heading || $no_heading} {
for {set col 0} {$col < $_col_total} {incr col} {
entry $this.$col.header -relief sunken -bg $_heading_bg \
-width $cell_width
_bind_heading $this.$col.header $col
$this.$col.header insert 0 [lindex $headings $col]
pack $this.$col.header -side top -fill x
if {$_col_scroll_shown} {
scrollbar $this.$col.cscroll \
-orient horizontal \
-command "$this _scroll_column2 $col"
pack $this.$col.cscroll -side top -fill x
}
}
} else {
# headings are already there, so simply set the new values
for {set col 0} {$col < $_col_total} {incr col} {
set_cell header $col [lindex $headings $col]
}
}
set _have_heading 1
}
#------------------------------------------------------------
# Table access functions
#------------------------------------------------------------
# ------------------------------------------------------------------
# METHOD: set_cell -
# ------------------------------------------------------------------
method set_cell {row col value} {
_vputs "setting cell ($row,$col) to $value ..."
set err [catch {format $cell_format $value} val]
if $err {set val $value}
$this.$col.$row delete 0 end
$this.$col.$row insert 0 $val
if {$_col_scroll_shown} {
if {![info exists _col_widths($col)]} {
set _col_widths($col) $cell_width
}
set len [string length $value]
set _col_widths($col) [_max $_col_widths($col) $len]
_update_col_scroll $col $_col_widths($col)
_vputs "maximum cell width now is $_col_widths($col)"
}
}
# ------------------------------------------------------------------
# METHOD: set_row - sets the the cells in the entire row
# ------------------------------------------------------------------
method set_row {row {data {}} {clear 1}} {
_vputs "setting row $row to $data"
# add extra columns if necessary. Careful about using $_col_total
# in loop checks, since add_col changes that.
set ncols [llength $data]
set col_total $_col_total
for {set col $col_total} {$col < $ncols} {incr col} {
_vputs "... adding col $col"
add_col {}
}
# add extra rows if necessary. Careful about using $_row_total
# in loop checks, since add_row changes that.
set need_rows [_max 0 [expr $row-$_row_total+1]]
for {set ri 0} {$ri < $need_rows} {incr ri} {
add_row {}
}
set ncols [expr {($clear) ? $_col_total : $ncols}]
for {set col 0} {$col < $ncols} {incr col} {
_vputs "... setting cell $row $col"
set_cell $row $col [string trim [lindex $data $col]]
}
}
# ------------------------------------------------------------------
# METHOD: set_col - sets the the cells in the entire col
# ------------------------------------------------------------------
method set_col {col {heading {}} {data {}} {clear 1}} {
_vputs "setting col $col to heading $heading and data $data"
# add extra rows if necessary. Careful about using $_row_total
# in loop checks, since add_row changes that.
set nrows [llength $data]
set row_total $_row_total
for {set row $row_total} {$row < $nrows} {incr row} {
_vputs "... adding row $row"
add_row {}
}
# add extra cols if necessary. Careful about using $_col_total
# in loop checks, since add_col changes that.
set need_cols [_max 0 [expr $col-$_col_total+1]]
for {set ci 0} {$ci < $need_cols} {incr ci} {
add_col {} {}
}
set nrows [expr {($clear) ? $_row_total : $nrows}]
for {set row 0} {$row < $nrows} {incr row} {
_vputs "... setting cell $row $col"
set_cell $row $col [string trim [lindex $data $row]]
}
# set the heading as well.
if {$_have_heading} {
$this.$col.header delete 0 end
$this.$col.header insert 0 $heading
}
}
# ------------------------------------------------------------------
# METHOD: set_table - sets ALL the cells in the entire table
# data is a list of lists, one for each row. caller's responsibility
# to put it into list format.
# ------------------------------------------------------------------
method set_table {{heading{}} {data {}} {clear 1}} {
_vputs "setting table data"
set_heading $heading
set nrows [length $data]
for {set row 0} {$row < nrows} {incr row} {
set_row $row [lindex $data $row] $clear
}
}
#------------------------------------------------------------
# Table query functions
#------------------------------------------------------------
# ------------------------------------------------------------------
# METHOD: get_size - query current size of the table.
# returns "nrows ncols"
# ------------------------------------------------------------------
method get_size {} {
return "$_row_total $_col_total"
}
# ------------------------------------------------------------------
# METHOD: get_cur_cell - query current focus cell {row col}
# If this is called from a MENU for example, the table has already
# lost focus and the internal state is no good.
#
# returns "-1 -1" if no current focus in table.
# ------------------------------------------------------------------
method get_cur_cell {} {
set focus [focus]
set row -1
set col -1
if {[string first $this $focus] == 0} { ;# table does have focus
set rest [split $focus .]
set namelen [llength $rest]
set col [lindex $rest [expr $namelen-2]]
set row [lindex $rest [expr $namelen-1]]
}
_vputs "current window/cell is: $focus, ($row, $col)"
return "$row $col"
}
# ------------------------------------------------------------------
# METHOD: get_cell - query a cell
# ------------------------------------------------------------------
method get_cell {row col} {
if {$row < 0 || $row >= $_row_total || \
$col < 0 || $col >= $_col_total} {
error "Table::get_cell: cell ($row,$col) out of range."
}
return [string trim [$this.$col.$row get]]
}
# ------------------------------------------------------------------
# METHOD: get_row - query a whole row
# ------------------------------------------------------------------
method get_row {row} {
if {$row < 0 || $row >= $_row_total} {
error "Table::get_row: row \"$row\" out of range."
}
set row_data {}
for {set col 0} {$col < $_col_total} {incr col} {
lappend row_data [string trim [$this.$col.$row get]]
}
return $row_data
}
# ------------------------------------------------------------------
# METHOD: get_col - query a whole column
# ------------------------------------------------------------------
method get_col {col} {
if {$col < 0 || $col >= $_col_total} {
error "Table::get_col: col \"$col\" out of range."
}
set col_data {}
for {set row 0} {$row < $_row_total} {incr row} {
lappend col_data [string trim [$this.$col.$row get]]
}
return $col_data
}
# ------------------------------------------------------------------
# METHOD: get_named_col - query the column under a particular heading
# DOES NOT check for multiple identical headings.
# ------------------------------------------------------------------
method get_named_col {heading} {
set tmpheading [string tolower [string trim $heading]]
set headings [get_headings]
set numheadings [llength $headings]
for {set col 0} {$col < $numheadings} {incr col} {
if {[string compare $tmpheading \
[string tolower [string trim [lindex $headings $col]]]] == 0} {
break
}
}
if {$col == $numheadings} {
error "Table::get_named_heading: No such heading \"$heading\""
return {}
}
return [get_col $col]
}
# ------------------------------------------------------------------
# METHOD: get_value - query public variables
# ------------------------------------------------------------------
method get_value {varName} {
catch "set $varName" value
return $value
}
# ------------------------------------------------------------------
# METHOD: get_headings -
# ------------------------------------------------------------------
method get_headings {} {
if {!$_have_heading} {return {}}
for {set col 0} {$col < $_col_total} {incr col} {
lappend table_heading [string trim [$this.$col.header get]]
}
return $table_heading
}
# ------------------------------------------------------------------
# METHOD: displayed - returns if a row or column is displayed
# ------------------------------------------------------------------
method displayed {what index} {
switch -glob -- $what {
row* {
set first $_row_first
set last $_row_last
}
col* {
set first $_col_first
set last $_col_last
}
default {
error "Table::displayed: bad argument \"$what\"."
}
}
return [expr ($index >= $first && $index <= $last)]
}
#------------------------------------------------------------
# Table Manipulation
#
# -- Add data function
# -- Add row/col functions
# -- Delete row/col functions
# -- Replicate row/col functions [TODO/FIXME]
# -- Insert row/col functions
#
#------------------------------------------------------------
# ------------------------------------------------------------------
# METHOD: add_row - adds a new row to the table. Returns the current
# number of rows in the table.
# ------------------------------------------------------------------
method add_row {data} {
_vputs "adding row [expr $_row_total-1]"
# add empty columns if needed
if {$_col_total == 0} {
set _col_total [llength $data]
for {set col 0} {$col < $_col_total} {incr col} {
frame $this.$col
}
display_col 0 1
$this.hscroll set $_col_total $cols 0 \
[expr [_min $_col_total $cols]-1]
if {$_col_total > $cols || $show_scroll} {
set _hscroll_shown 1
_show_scrollbars
}
}
# now create the needed cells in a row
set row $_row_total
for {set col 0} {$col < $_col_total} {incr col} {
if {$_col_scroll_shown} {
entry $this.$col.$row -relief sunken -bg $_cell_bg \
-width $cell_width \
-scrollcommand "$this _scroll_column $col"
} else {
entry $this.$col.$row -relief sunken -bg $_cell_bg \
-width $cell_width
}
set_cell $row $col [lindex $data $col]
_bind_cell $this.$col.$row $row $col
}
incr _row_total
# need vscrollbar?
if {$_row_total == $rows || $show_scroll} {
set _vscroll_shown 1
_show_scrollbars
}
# call display_row to pack the cells, but don't force re-packing all
display_row $_row_first 0
$this.vsbframe.vscroll set $_row_total $rows $_row_first \
[expr [_min [expr $rows+$_row_first] $_row_total]-1]
return $_row_total
}
# ------------------------------------------------------------------
# METHOD: add_col - add a new column and return the current total of
# columns in the table.
# ------------------------------------------------------------------
method add_col {heading {data {}}} {
frame $this.$_col_total
incr _col_total
_vputs "adding column [expr $_col_total-1]"
# call display_col to pack the cells (force it). This is necessary
# if the number of columns is still less than maximum size, and
# the table needs to grow.
display_col $_col_first 1
$this.hscroll set $_col_total $cols $_col_first \
[expr [_min [expr $cols+$_col_first] $_col_total]-1]
# need hscrollbar?
if {$_col_total > $cols || $show_scroll} {
set _hscroll_shown 1
_show_scrollbars
}
set col [expr $_col_total-1]
# add the heading first, if any.
if {$_have_heading} {
entry $this.$col.header -relief sunken \
-bg $_heading_bg -width $cell_width
_bind_heading $this.$col.header $col
$this.$col.header insert 0 $heading
pack $this.$col.header -side top -fill x
}
# add the column scrollbar next, if any.
if {$_col_scroll_shown} {
puts "creating column scrollbar ..."
scrollbar $this.$col.cscroll \
-orient horizontal \
-command "$this scroll_column2 $col"
pack $this.$col.cscroll -side top -fill x
}
# Now add needed rows in the new column and call call display_row
# to pack the cells (force it). This is necessary if the number
# of rows is still less than maximum size, and the table needs to
# grow.
for {set row 0} {$row < $_row_total} {incr row} {
if {$_col_scroll_shown} {
entry $this.$col.$row -relief sunken \
-bg $_cell_bg -width $cell_width \
-scrollcommand "$this _scroll_column $col"
} else {
entry $this.$col.$row -relief sunken \
-bg $_cell_bg -width $cell_width
}
_bind_cell $this.$col.$row $row $col
}
display_row $_row_first 1
# now add the data in the new columns
if {[llength $data] != 0} {
# and how many rows do we need?
set need_rows [llength $data]
for {set row $_row_total} {$row < $need_rows} {incr row} {
add_row {}
}
# and now we can set the data
set row 0
foreach datum $data {
set_cell $row $col $datum
incr row
}
}
return $_col_total
}
# ------------------------------------------------------------------
# METHOD: _copy_row - copy this row into a new one. Must exist.
# ------------------------------------------------------------------
method _copy_row {from_row to_row} {
for {set col 0} {$col < $_col_total} {incr col} {
_copy_cell $from_row $col $to_row $col
}
return 0
}
# ------------------------------------------------------------------
# METHOD: _copy_col - copy this col into a new one. Must exist.
# ------------------------------------------------------------------
method _copy_col {from_col to_col} {
for {set row 0} {$row < $_row_total} {incr row} {
_copy_cell $row $from_col $row $to_col
}
if {$_have_heading} {
$this.$to_col.header delete 0 end
$this.$to_col.header insert 0 [$this.$from_col.header get]
}
return 0
}
# ------------------------------------------------------------------
# METHOD: _copy_cell - copy this cell into a new one. Must exist.
# ------------------------------------------------------------------
method _copy_cell {from_row from_col to_row to_col} {
set_cell $to_row $to_col [get_cell $from_row $from_col]
return 0
}
# ------------------------------------------------------------------
# METHOD: replicate_row - replicate this row at the end.
# ------------------------------------------------------------------
method replicate_row {row} {
return [add_row [get_row $row]]
}
# ------------------------------------------------------------------
# METHOD: replicate_col - replicate this col at the end
# ------------------------------------------------------------------
method replicate_col {col} {
#
# don't simply add a new col with the data from the old one, since
# the header doesn't get copied correctly.
#
add_col {}
_copy_col $col [expr $_col_total-1]
}
# ------------------------------------------------------------------
# METHOD: insert_row - insert a new row (empty) and push everything down
# ------------------------------------------------------------------
method insert_row {i_row} {
if {$i_row >= $_row_total} {
# TODO/FIXME: report error
return -1
}
_vputs "inserting row $i_row. row_total = $_row_total"
# add a new row. This changes _row_total
add_row [get_row [expr $_row_total-1]]
for {set row [expr $_row_total-2]} {$row >= $i_row} {incr row -1} {
_copy_row [expr $row-1] $row
}
incr row
set_row $row {} 1
display_row $_row_first
if {$_row_total > $rows} {
set _vscroll_shown 1
_show_scrollbars
}
}
# ------------------------------------------------------------------
# METHOD: insert_col - insert a new col (empty) and push everything right
# ------------------------------------------------------------------
method insert_col {i_col} {
if {$i_col >= $_col_total} {
# TODO/FIXME: report error
return -1
}
_vputs "inserting col $i_col. col_total = $_col_total"
# add a new col. This changes _col_total
add_col {} {}
for {set col [expr $_col_total-1]} {$col > $i_col} {incr col -1} {
_copy_col [expr $col-1] $col
}
set_col $col {} {} 1
display_col $_col_first
if {$_col_total > $cols} {
set _hscroll_shown 1
_show_scrollbars
}
}
# ------------------------------------------------------------------
# METHOD: delete_row - delete this row and reconfigure if necessary.
# ------------------------------------------------------------------
method delete_row {d_row} {
if {$_row_total == 0} {return 0}
if {$d_row >= $_row_total} {
# TODO/FIXME: report error
return -1
}
for {set row [expr $d_row+1]} {$row < $_row_total} {incr row} {
_copy_row $row [expr $row-1]
}
incr row -1
for {set col 0} {$col < $_col_total} {incr col} {
destroy $this.$col.$row
}
incr _row_total -1
display_row $_row_first
if {$_row_total <= $rows} {
set _vscroll_shown 0
_show_scrollbars
}
}
# ------------------------------------------------------------------
# METHOD: delete_col - delete this column.
# BUG: has trouble when deleting ALL the columns in the table.
# ------------------------------------------------------------------
method delete_col {d_col} {
if {$_col_total == 0} {return 0}
if {$d_col >= $_col_total} {
# TODO/FIXME: report error
return -1
}
for {set col [expr $d_col+1]} {$col < $_col_total} {incr col} {
_copy_col $col [expr $col-1]
}
incr col -1
if {$_have_heading} {
destroy $this.$col.header
}
if {$_col_scroll_shown} {
destroy $this.$col.cscroll
}
for {set row 0} {$row < $_row_total} {incr row} {
destroy $this.$col.$row
}
# now delete the frame that contains the last column
destroy $this.$col
incr _col_total -1
display_col $_col_first
if {$_col_total <= $cols} {
set _hscroll_shown 0
_show_scrollbars
}
}
#------------------------------------------------------------
# Bindings for cells
#------------------------------------------------------------
method _bind_cell {w row col} {
bind $w <Return> "$this next_cell $row $col"
bind $w <Control-n> "$this down_cell $row $col"
bind $w <Key-Down> "$this down_cell $row $col"
bind $w <Control-p> "$this up_cell $row $col"
bind $w <Key-Up> "$this up_cell $row $col"
bind $w <Control-b> "$this left_cell $row $col"
bind $w <Key-Left> "$this left_cell $row $col"
bind $w <Control-f> "$this right_cell $row $col"
bind $w <Key-Right> "$this right_cell $row $col"
bind $w <Control-r> "$this add_row {}"
bind $w <Control-c> "$this add_col {}"
bind $w <Control-e> "$this edit_cell_special $row $col"
bind $w <Double-1> "$this edit_cell_special $row $col"
bind $w <Button-1> "$this edit_cell %W %x $row $col"
bind $w <Button-2> "$this paste_cell $row $col"
#################################################################
#
# THE FOCUS HANDLERS ARE NOT USED CURRENTLY.
#
#bind $w <FocusIn> "$this _set_focus_in %W $row $col"
#bind $w <FocusOut> "$this _set_focus_out %W $row $col"
#
# THE FOCUS HANDLERS ARE NOT USED CURRENTLY.
#
#################################################################
}
#
# FIX/TODO: consolidate cell and header bindings.
#
method _bind_heading {w j} {
bind $w <Return> "$this next_cell -1 $j"
}
#------------------------------------------------------------
# TableEntry actions
#------------------------------------------------------------
# ------------------------------------------------------------------
# METHOD: select_cell -
# ------------------------------------------------------------------
method select_cell {row col {cursor_at_end 0}} {
set w $this.$col.$row
if {$w == $_cur_focus_win} return
if [winfo exists $_cur_focus_win] {
$_cur_focus_win configure -bg $_cell_bg -fg $_cell_fg
}
set _cur_focus_win $w
set _cur_focus_row $row
set _cur_focus_col $col
$w configure -bg $_focus_bg -fg $_focus_fg
if $cursor_at_end {catch "$w icursor end"}
if {$command != {}} "$command $row $col {[$w get]}"
focus $w
}
####################################################################
#
# THE FOCUS HANDLERS ARE NOT USED CURRENTLY.
#
# ------------------------------------------------------------------
# METHOD: _set_cur_focus_in - sets the current focus window and row/col
# ------------------------------------------------------------------
method _set_focus_in {w row col} {
_vputs "focusin: $w"
if {$_cur_focus_win == $w} return
_vputs "current focus: ($row, $col)"
_vputs "... last: ($_last_focus_row, $_last_focus_col)"
set _cur_focus_win $w
set _cur_focus_row $row
set _cur_focus_col $col
$_cur_focus_win configure -bg $_focus_bg -fg $_focus_fg
}
# ------------------------------------------------------------------
# METHOD: _set_cur_focus_out - sets the prev focus window and row/col
# ------------------------------------------------------------------
method _set_focus_out {w row col} {
_vputs "focusout: $w"
_vputs "last focus: ($row, $col)"
set _cur_focus_win ""
set _cur_focus_row -1
set _cur_focus_col -1
set _last_focus_win $w
set _last_focus_row $row
set _last_focus_col $col
$_last_focus_win configure -bg $_cell_bg -fg $_cell_fg
}
#
# THE FOCUS HANDLERS ARE NOT USED CURRENTLY.
#
####################################################################
# ------------------------------------------------------------------
# METHOD: edit_cell -
# ------------------------------------------------------------------
method edit_cell {w cursor_x row col} {
if [winfo exists $_cur_focus_win] {
$_cur_focus_win configure -bg $_cell_bg -fg $_cell_fg
}
set _cur_focus_win $this.$col.$row
$_cur_focus_win configure -bg $_focus_bg -fg $_focus_fg
$w icursor _at_$cursor_x
$w select from _at_$cursor_x
if {[lindex [$w config -state] 4] == "normal"} {focus $w}
if {$command != {}} "$command $row $col {[$w get]}"
}
# ------------------------------------------------------------------
# METHOD: next_cell - next is determined by <next_dir> variable.
# ------------------------------------------------------------------
method next_cell {row col} {
if [string match "down" $_next_dir] {
down_cell $row $col
} else {
right_cell $row $col
}
}
# ------------------------------------------------------------------
# METHOD: down_cell - try to keep the cursor in the same position
# ------------------------------------------------------------------
method down_cell {row col} {
catch {$this.$col.$row index insert} pos
if {$row < $_row_last} {
#focus $this.$col.[expr $row+1]
#catch {$this.$col.[expr $row+1] icursor $pos}
set newrow [expr $row+1]
select_cell $newrow $col
return
}
if {$row < [expr $_row_total-1]} {
display_row [expr $_row_first+1]
down_cell $row $col
return
}
}
# ------------------------------------------------------------------
# METHOD: up_cell - try to keep the cursor in the same position
# ------------------------------------------------------------------
method up_cell {row col} {
catch {$this.$col.$row index insert} pos
if {$row > $_row_first} {
set newrow [expr $row-1]
select_cell $newrow $col
} else {
if {$row > 0} {
display_row [expr $_row_first-1]
up_cell $row $col
}
}
}
# ------------------------------------------------------------------
# METHOD: left_cell -
# ------------------------------------------------------------------
method left_cell {row col {cursor_at_end 0}} {
if {$col > $_col_first} {
set newcol [expr $col-1]
select_cell $row $newcol $cursor_at_end
} else {
if {$col > 0} {
display_col [expr $_col_first-1]
left_cell $row $col $cursor_at_end
}
}
}
# ------------------------------------------------------------------
# METHOD: right_cell -
# ------------------------------------------------------------------
method right_cell {row col {cursor_at_start 0}} {
if {$col < $_col_last} {
set newcol [expr $col+1]
select_cell $row $newcol
} else {
if {$col < [expr $_col_total-1]} {
display_col [expr $_col_first+1]
right_cell $row $col $cursor_at_start
}
}
}
# ------------------------------------------------------------------
# METHOD: paste_cell - paste the selection item.
# ------------------------------------------------------------------
method paste_cell {row col} {
set err [catch {selection get} sel]
if {!$err} {
set_cell $row $col $sel
}
}
# ------------------------------------------------------------------
# METHOD: edit_cell_special - edit a cell in a real window.
# ------------------------------------------------------------------
method edit_cell_special {row col} {
catch {destroy .edit}
toplevel .edit
frame .edit.label -relief raised
label .edit.label.cell -text "Edit Cell $row,$col"
pack .edit.label.cell -anchor center -padx 5 -pady 5
label .edit.msg \
-text "Enter new value or expression (strings must be quoted):"
scrollbar .edit.sb -orient horizontal -command ".edit.entry view"
entry .edit.entry -width 50 -relief sunken \
-scrollcommand ".edit.sb set"
bind .edit.entry <Return> "$this _set_cell_special $row $col"
.edit.entry insert 0 [$this.$col.$row get]
frame .edit.confirm
button .edit.confirm.accept -text "Accept" \
-command "$this _set_cell_special $row $col"
button .edit.confirm.cancel -text "Cancel" -command {destroy .edit}
pack .edit.confirm.accept -side left -padx 25 -pady 5
pack .edit.confirm.cancel -side right -padx 25 -pady 5
pack .edit.label -side top -padx 5 -pady 5
pack .edit.msg -side top -padx 5 -pady 5 -anchor w
pack .edit.entry -side top -padx 5 -pady 5 -fill both
pack .edit.sb -side top -padx 5 -pady 5 -fill both
pack .edit.confirm -side top -padx 5 -pady 5
}
method _set_cell_special {row col} {
set_cell $row $col [expr [.edit.entry get]]
focus $this.$col.$row
destroy .edit
}
#------------------------------------------------------------
# TODO: Add/Copy functions for rows/columns
#------------------------------------------------------------
# ------------------------------------------------------------------
# METHOD: _vputs - used to print debugging message is verbose set.
# ------------------------------------------------------------------
method _vputs {msg} {
if $verbose {puts "$this: $msg"}
}
# ------------------------------------------------------------------
# METHOD: _min - Returns the lesser of $x and $y
# ------------------------------------------------------------------
proc _min {x y} {expr "($x < $y) ? $x : $y"}
# ------------------------------------------------------------------
# METHOD: _max - Returns the greater of $x and $y
# ------------------------------------------------------------------
proc _max {x y} {expr {($x > $y) ? $x : $y}}
# PUBLIC DATA
#
# rows ............ number of rows to start with
# cols ............ number of rows to start with
# heading ......... want column heading?
#
# cell_width ...... width of table entry
# cell_format ..... %s|%d|%f|%e format strings for regular cells
#
# show_scroll ..... always display scroll bars?
# spacer .......... spacer geometry for aligning vscroll with table.
#
# verbose ......... set verbose on (1) or off (0)
#
public rows 5 {
_vputs "setting number of rows to $rows"
if {$_constructed} {
puts stderr "Table: cannot change rows specify after creation."
} else {
set rows $rows
}
}
public cols 5 {
_vputs "setting number of columns to $cols"
if {$_constructed} {
puts stderr "Table: cannot change cols specify after creation."
} else {
set cols $cols
}
}
public cell_width 15 { ;# how wide to make each entry
_vputs "setting width of entries to $cell_width"
set cell_width $cell_width
}
public cell_format %s { ;# for entry validation.
_vputs "setting cell_format to $cell_format"
set cell_format $cell_format
}
public heading 0 {
_vputs "setting table header to $heading"
set heading $heading
}
public show_scroll 0 { ;# force scrollbars
_vputs "always showing scrollbars"
set show_scroll $show_scroll
if {$show_scroll == 1} {
set _hscroll_shown 1
set _vscroll_shown 1
if {$_constructed} _show_scrollbars
}
}
public show_col_scroll 0 { ;# force column scrollbars
if {$_constructed} {
puts stderr "Table: cannot specify column scrollbar creation."
} else {
_vputs "always showing scrollbars"
set show_col_scroll $show_col_scroll
if {$show_col_scroll == 1} {
set _col_scroll_shown 1
_show_cscrollbars
}
}
}
public spacer 18x18 { ;# for aligning vscrollbar
if {$_constructed} {
puts stderr "Table: cannot change spacer specify after creation."
} else {
_vputs "setting spacer to $spacer"
if {[scan $spacer "%dx%d" x y] != 2} {
error "Wrong -spacer value \"$spacer\": must be of XxY format."
}
set spacer $spacer
}
}
public command {} { ;# callback for current cell info
if {$command != {}} {
_vputs "setting command callback to $command"
set command $command
}
}
public verbose 0 {
_vputs "setting verbose mode to on."
set verbose $verbose
}
#
# PROTECTED DATA
#
protected _first_shown 0 ;# for view management
protected _last_shown 0 ;# for view management
protected _row_total 0 ;# total rows in table
protected _row_first 0 ;# index of first shown
protected _row_last 0 ;# index of last shown
protected _col_total 0 ;# total cols in table
protected _col_first 0 ;# index of first shown
protected _col_last 0 ;# index of last shown
protected _cur_focus_win "" ;# which cell has the focus
protected _cur_focus_row -1 ;# which row has the focus
protected _cur_focus_col -1 ;# which col has the focus
####################################################################
#
# THESE FOCUS VARIABLES ARE NOT USED CURRENTLY.
#
protected _last_focus_win "" ;# which cell had the last focus
protected _last_focus_row -1 ;# which row had the last focus
protected _last_focus_col -1 ;# which col had the last focus
#
# THESE FOCUS VARIABLES ARE NOT USED CURRENTLY.
#
####################################################################
protected _next_dir "down" ;# direction to move with <return>
protected _heading_space 0 ;# space to leave for header
protected _have_heading 0 ;# have header defined
protected _vscroll_shown 0 ;# is vscrollbar visible now?
protected _hscroll_shown 0 ;# is vscrollbar visible now?
protected _col_scroll_shown 0 ;# is column scrollbar visible now?
protected _col_widths ;# for scrolling columns
protected _cell_bg ;# background color for cells
protected _cell_fg ;# foreground color for cells
protected _heading_bg ;# background color for heading
protected _heading_fg ;# foreground color for heading
protected _focus_bg ;# background color for cur focus
protected _focus_fg ;# foreground color for cur focus
protected _constructed 0 ;# post-constructor check
}
Received on Wed Nov 30 1994 - 04:07:01 CET
This archive was generated by hypermail 2.3.0
: Mon Jul 21 2014 - 19:38:59 CEST