view release on metacpan or  search on metacpan

lib/Tcl/pTk/Table.pm  view on Meta::CPAN

#
# This is a reimplementation of the perl/tk Tk::Table widget using the Tablematrix widget
#   The original perl/tk approach can't be used for Tcl::pTk, because it uses the ManageGeometry methods,
#    which aren't supported in Tcl::pTk
#

package Tcl::pTk::Table;

our ($VERSION) = ('1.11');

use strict;

use Tcl::pTk::TableMatrix;

use base qw(Tcl::pTk::Derived Tcl::pTk::Frame);

Construct Tcl::pTk::Widget 'Table';


sub Populate
{
 my ($t,$args) = @_;
 $t->SUPER::Populate($args);
 
 my $scrollbars = delete $args->{-scrollbars};
 my $tableMatrix;
 
 # create tableMatrix with scrollbars, if -scrollbars option present
 if( $scrollbars ){
         $tableMatrix = $t->Scrolled('TableMatrix', -scrollbars => $scrollbars, -rows => 1, -cols => 1, 
                 -titlerows => 0, -titlecols => 0, -roworigin => 1, -colorigin => 1);
 }
 else{
         $tableMatrix = $t->TableMatrix(-rows => 1, -cols => 1, -titlerows => 0, -titlecols => 0, -roworigin => 1, -colorigin => 1);
 }

 # Initialize widget storage
 $t->{widgets} = {}; # Mapping of row/col index to widget
 $t->{Width}   = []; # Mapping of col number to col width
 $t->{Height}  = []; # Mapping of row number to row height
 
 $tableMatrix->pack(-expand => 1, -fill => 'both');
 
 $t->Advertise('TableMatrix', $tableMatrix);
         
 $t->ConfigSpecs('-scrollbars'         => [PASSIVE   => 'scrollbars','Scrollbars','nw'],
                 
                 # TakeFocus doesn't do anything, just present for Tk::Table Compatibility
                 '-takefocus'          => [PASSIVE => 'takeFocus','TakeFocus',1],  
                 '-rows'               => [PASSIVE => 'rows','Rows',10],
                 '-columns'            => [PASSIVE => 'columns','Columns',10],
                 '-fixedcolumns'       => [{-titlecols => $tableMatrix}  => 'fixedcolumns', 'fixedcolumns', 0], # fixedcolumns mapped to tablematrix -titlecols
                 '-fixedrows'          => [{-titlerows => $tableMatrix}  => 'fixedrows',    'fixedrows',    0], # fixedrows mapped to tablematrix -titlerows
                 DEFAULT               => [$tableMatrix]
                 );


}



sub get
{
 my ($t,$row,$col) = @_;
 return $t->{widgets}{"$row,$col"};

}


sub clear {
    my $self = shift;
    
    my $tm = $self->Subwidget('TableMatrix'); # Work with the tablematrix
    
    # Get our widget store