## command.tcl ## ## This demo shows the use of the table widget's -command options ## ## jeff.hobbs@acm.org ## Converted to perl/tk by John Cerney use Tk; use Tk::TableMatrix; my ($rows,$cols) = (10,10); # number of rows/cols my $top = MainWindow->new; # Sub to fill the array variable sub fill{ my ($array,$x,$y) = @_; my ($i,$j); for( $i = -$x; $i<$x; $i++){ for( $j = -$y; $j<$y; $j++){ $array->{"$i,$j"} = "$i x $j"; } } } ## Test out the use of a callback to define tags on rows and columns sub rowSub{ my $row = shift; return "OddRow" if( $row > 0 && $row % 2) } sub colSub{ my $col = shift; return "OddCol" if( $col > 0 && $col%2) ; } sub tblCmd{ my ($array, $set, $row,$col,$val) = @_; # my @args = @_; # print "In Table Command, Args = '".join("', '",@args)."'\n"; my $index = "$row,$col"; if( $set ){ $array->{$index} = $val; } else{ if( defined( $array->{$index})){ return $array->{$index}; } else{ return ''; } } } my $label = $top->Label(-text => "TableMatrix -command Example"); # Label the changes with the value of currentTest my $currentText = ''; my $currentLabel = $top->Label(-textvariable => \$currentText); # Entry that changes with the value of activeText my $activeText = ''; my $activeEntry = $top->Entry(-textvariable => \$activeText); my $arrayVar = {}; fill($arrayVar, $rows,$cols); # fill up the array variable my $t = $top->Scrolled('TableMatrix', -rows => $rows, -cols => $cols, -width => 6, -height => 6, -titlerows => 1, -titlecols => 2, -command => [\&tblCmd, $arrayVar], -roworigin => -1, -colorigin => -2, -rowtagcommand => \&rowSub, -coltagcommand => \&colSub, -selectmode => 'extended', -flashmode => 'on', -variable => $arrayVar, ); $t->configure( -browsecommand => sub{ my ($index) = @_; $currentText = $index; $activeText = $t->get($index); }); $t->configure( -validate => 1, -validatecommand => sub{ my ($row,$col,$old,$new,$index) = @_; $activeText = $new; return 1; } ); $t->configure( -selectioncommand => sub{ my ($NumRows,$Numcols,$selection,$noCells) = @_; my @args = @_; print "In Selection Command, Args = '".join("', '",@args)."'\n"; return $selection; } ); # hideous Color definitions here: $t->tagConfigure('OddRow', -bg => 'orange', -fg => 'purple'); $t->tagConfigure('OddCol', -bg => 'brown', -fg => 'pink'); $t->colWidth( -2 => 7, -1 => 7, 1=> 5, 2 => 8, 4=> 14); $label->pack( -expand => 1, -fill => 'both'); $currentLabel->pack( -expand => 1, -fill => 'both'); $activeEntry->pack( -expand => 1, -fill => 'both'); $t->pack(-expand => 1, -fill => 'both'); Tk::MainLoop;