## dynarows.tcl ## ## This demos shows the use of the validation mechanism of the table ## and uses the table's cache (no -command or -variable) with a cute ## dynamic row routine. ## ## jeff.hobbs@acm.org ## Converted to perl/tk by John Cerney use Tk; use Tk::TableMatrix; use Date::Parse; use Date::Format; my $top = MainWindow->new; my $t = $top->Scrolled('TableMatrix', -rows => 2, -cols => 3, -cache => 1, -selecttype => 'row', -titlerows => 1, -titlecols => 1, -height => 5, -autoclear => 1, ); $t->configure( -browsecommand => sub{ my ($index) = @_; my $val = $t->get($index); return unless $val; my ($row,$col) = split(",",$index); ## Entries in the last row are allowed to be empty my $nrows = $t->cget(-rows); if( ($row == ($nrows-1)) && $val eq ''){ return; }; return if( $row == 0 || $col == 0); #don't check the title row/cols my $timenumber; # try to parse date from value in cell $timenumber = str2time($val); if( !$timenumber || !$val){ # not a valid date: print "'$val' is not a valid date\n"; $t->bell; $t->activate($index); $t->selectionClear('all'); $t->selectionSet('active'); $t->see('active'); } else{ # Convert to a common date format my $date; $date = time2str("%m/%d/%Y",$timenumber); $t->set($index,$date); if( $row == ($nrows-1) ){ ## if this is the last row and both cols 1 && 2 are not empty ## then add a row and redo configs if( $t->get("$row,1") ne '' && $t->get("$row,2") ne ''){ $t->tagRow('', $row); $t->set("$row,0", $row); $t->configure( -rows => ++$nrows); $t->tagRow('unset', ++$row); $t->set("$row,0","*"); $t->see("$row,1"); $t->activate("$row,1"); } } } }); $t->set("0,1" => "Begin", "0,2" => 'End', "1,0"=>"*"); # hideous Color definitions here: $t->tagConfigure('unset', -fg => '#008811'); $t->tagConfigure('title', -fg => 'red'); $t->tagRow('unset', 1); $t->colWidth( 0 => 3); my $label = $top->Label(-text => "Dynamic Date Validated Rows"); $label->pack( -expand => 1, -fill => 'both'); $t->pack(-expand => 1, -fill => 'both'); # Bindings: # Make the active area move after we press return: # We Have to use class binding here so that we override # the default return binding $t->bind('Tk::TableMatrix','<Return>', sub{ my $r = $t->index('active', 'row'); my $c = $t->index('active', 'col'); if( $c == 2){ $t->activate(++$r.",1"); } else{ $t->activate("$r,".++$c); } $t->see('active'); Tk->break; }); # Make enter do the same thing as return: $t->bind('<KP_Enter>', $t->bind('<Return>')); Tk::MainLoop;