=head1 NAME Tk::TableMatrix::SpreadsheetHideRows - Table Display with selectable hide/un-hide of rows =head1 SYNOPSIS use Tk; use Tk::TableMatrix::SpreadsheetHideRows my $t = $top->Scrolled('SpreadsheetHideRows', -selectorCol => 3, -expandData => $hashRef, -rows => 21, -cols => 11, -width => 6, -height => 6, -titlerows => 1, -titlecols => 1, -variable => $arrayVar, -selectmode => 'extended', -resizeborders => 'both', -titlerows => 1, -titlecols => 1, -bg => 'white', ); =head1 DESCRIPTION L is a L-derived widget that implements a Spreadsheet-like display of tabular information, where some of the rows in the table can be expanded/hidden by clicking a '+/-' selector in the row. This can be used to display top-level information in a table, while allowing the user to expand certain table rows to view detail-level information. See demos/SpreadsheetHideRows in the source distribution for a simple example of this widget =head1 Widget-specific Options In addition the standard L widget options. The following options are implemented: =over 1 =item -selectorCol Column number where the +/- selector will appear. Clicking on the +/- selector will expand/hide the detail information in the table for a particular row. =item -selectorColWidth Width of the column used to display the +/- selector. Defaults to 2 =item -expandData Hash ref defining the detail-level data displayed when a row is expanded (by clicking the +/- selector). This hash ref should have the following structure: $expandData = { row1 => { tag => 'detailDataTag', data => $detailData, spans=> $spanData, expandData => $subLevelData }, row2 => { . . } Where: row1, row2, ... Row numbers that will be expandable. tag => 'detailDataTag' Tag name that will be applied to the detail data. (optional) $detailData 2D Array of detail-data to be displayed when the row is expanded. e.g. [ [ r1c1, r1c2, r1c3 ], [ r2c1, r2c2, r2,c3] ] $spans 1D array of span information (optional) to be used for display of the detail information. e.g. [ col2 => "rows,cols", col4 => "rows,cols", ... ] $subLevelData Optional Recursive expandData used to hold detail-data of detail-data. =back =head1 MEMBER DATA The following items are stored as member data =over 1 =item defaultCursor Name of the mouse cursor pointer that is used for normal (i.e. non-title, non-indicator) cells in the widget. This is set to the value of the $widget->cget(-cursor) option when the widget is created. =item indRowCols Hash ref of Row/Cols indexes where there are indicators stores. This is a quick lookup hash built from I<_expandData>. =item _expandData Internal version of the I hash. Any sub-detail data (i.e. expand data that is at lower levels of I) that is visible is placed at the top level of this hash, for keeping track of the visible I. =back =head1 Widget Methods In addition the standard L widget method. The following methods are implemented: =cut package Tk::TableMatrix::SpreadsheetHideRows; use Carp; use Tk; use Tk::TableMatrix::Spreadsheet; use Tk::Derived; use base qw/ Tk::Derived Tk::TableMatrix::Spreadsheet/; $VERSION = '1.24'; Tk::Widget->Construct("SpreadsheetHideRows"); sub ClassInit{ my ($class,$mw) = @_; $class->SUPER::ClassInit($mw); }; sub Populate { my ($self, $args) = @_; $self->ConfigSpecs( -selectorCol => [qw/METHOD selectorCol SelectorCol/, undef], -selectorColWidth=> [qw/PASSIVE selectorColWidth SelectorColWidth/, 2], -expandData => [qw/METHOD expandData ExpandData/, {}], -selectorRow => [qw/METHOD selectorRow SelectorRow/, undef], -selectorRowWidth=> [qw/PASSIVE selectorRowWidth SelectorRowWidth/, 2], -expandDataCol => [qw/METHOD expandDataCol ExpandDataCol/, {}], ); $self->SUPER::Populate($args); $self->tagConfigure('plus', -image => $self->Getimage("plus"), -showtext => 0, -anchor => 'center'); $self->tagConfigure('minus', -image => $self->Getimage("minus"), -showtext => 0, -anchor => 'center'); $self->{normalCursor} = $self->cget('-cursor'); # get the default cursor } =head2 showDetail Shows (i.e. expands the table) the detail data for a given row. This method is called when a user clicks on an indicator that is not already expanded. B $widget->showDetail($row); # Shows the detail data for row number $row =cut sub showDetail{ my $self = shift; my $row = shift; my $selectorCol = $self->cget(-selectorCol); my $index = "$row,$selectorCol"; # make index for the cell to be expanded my $indRowCols = $self->{indRowCols}; $self->tagCell('minus', $index); $indRowCols->{$index} = '-'; # Get the detail data and insert: my $expandData = $self->{'_expandData'}; my $detailData = $expandData->{$row}; my $detailArray = $detailData->{data}; my $noRows = scalar( @$detailArray); # InsertRows: # change state to normal if not already so we can insert my $currentState = $self->cget(-state); $self->configure(-state => 'normal') unless( $currentState eq 'normal'); $self->insertRows($row,$noRows); # Adjust Spans: $self->adjustSpans($row+1,$noRows); #insert data my $colorigin = $self->cget(-colorigin); my $rowNum = $row+1; foreach my $rowData( @$detailArray ){ #my @rowArray = @$rowData; #grep s/([\{\}])/\\$1/g, @rowArray; # backslash any existing '{' chars, so they don't get interpreted as field chars my $insertData = "{".join("}{", @$rowData)."}"; # make insert data look like tcl array, so it # gets put in different cells $self->set('row', "$rowNum,$colorigin", $insertData); $rowNum++; } # Apply Tags, if any: my $tag; if( defined( $detailData->{tag})){ $tag = $detailData->{tag}; my $startRow = $row+1; my $noRows = @$detailArray; my $stopRow = scalar(@$detailArray) + $startRow - 1; my @tagRows = ($startRow..$stopRow); $self->tagRow($tag,@tagRows); } # Apply Spans, if any: my $spans; if( defined( $detailData->{spans})){ $spans = $detailData->{spans}; my $spanSize = scalar(@$spans); #Error Checking, spans array should be a multiple of 2 if( ($spanSize % 2) < 1){ my $startRow = $row+1; my $noRows = @$detailArray; my $stopRow = scalar(@$detailArray) + $startRow - 1; foreach my $spanRow($startRow..$stopRow){ # build an array to feed to spans, change column number for row.col index # (every 2rd item in the array). my @spanArray = map $_ % 2 ? $spans->[$_] : "$spanRow,".$spans->[$_], (0..($spanSize-1)); $self->spans(@spanArray); } }else{ warn("Spans array for row $row, is not a multiple of 2\n"); } } # Now Update the internal arrays for the inserted rows ### my %expandDataNew; foreach my $rowIndex(keys %$expandData){ if($rowIndex > $row){ # adjust rows greater than the current row $expandDataNew{$rowIndex+$noRows} = $expandData->{$rowIndex}; } else{ $expandDataNew{$rowIndex} = $expandData->{$rowIndex}; } } # Copy new to existing: %$expandData = %expandDataNew; my %indRowColsNew; foreach my $rcindex(keys %$indRowCols){ my ($rowIndex,$colIndex) = split(',',$rcindex); if($rowIndex > $row){ # adjust rows greater than the current row my $newRow = $rowIndex+$noRows; $indRowColsNew{"$newRow,$colIndex"} = $indRowCols->{$rcindex}; } else{ $indRowColsNew{$rcindex} = $indRowCols->{$rcindex}; } } # Copy new to existing: %$indRowCols = %indRowColsNew; # Take care of any lower-level detail data: my $subDetail; if( defined( $detailData->{expandData})){ $subDetail = $detailData->{expandData}; foreach my $subRow( keys %$subDetail){ my $realRow = $row+$subRow; my $index = "$realRow,$selectorCol"; $self->tagCell('plus', $index); $indRowCols->{$index} = '+'; # update internal array # put subdetail data to top level, adjusting the relative row # numbers to real row numbers: #my %adjustedSubDetail; #foreach my $subKey(keys %$subDetail){ # $adjustedSubDetail{$subKey+$row} = $subDetail->{$subKey}; #} $expandData->{$realRow} = $subDetail->{$subRow}; } } # Put the state back $self->configure(-state => $currentState) unless( $currentState eq 'normal'); } sub showDetailCol { my $self = shift; my $col = shift; my $selectorRow = $self->cget(-selectorRow); my $index = "$selectorRow,$col"; # make index for the cell to be expanded my $indRowCols = $self->{indRowCols}; $self->tagCell('minus', $index); $indRowCols->{$index} = '-'; # Get the detail data and insert: my $expandData = $self->{'_expandDataCol'}; my $detailData = $expandData->{$col}; my $detailArray = $detailData->{data}; my $noCols = scalar( @$detailArray); # InsertCols: # change state to normal if not already so we can insert my $currentState = $self->cget(-state); $self->configure(-state => 'normal') unless( $currentState eq 'normal'); $self->insertCols($col,$noCols); # Adjust Spans: $self->adjustSpansCol($col+1,$noCols); #insert data my $colorigin = $self->cget(-colorigin); my $colNum = $col+1; foreach my $colData( @$detailArray ){ #my @ColArray = @$ColData; #grep s/([\{\}])/\\$1/g, @ColArray; # backslash any existing '{' chars, so they don't get interpreted as field chars my $insertData = "{".join("}{", @$colData)."}"; # make insert data look like tcl array, so it # gets put in different cells $self->set('col', "$colorigin,$colNum", $insertData); $colNum++; } # Apply Tags, if any: my $tag; if( defined( $detailData->{tag})){ $tag = $detailData->{tag}; my $startCol = $col+1; my $noCols = @$detailArray; my $stopCol = scalar(@$detailArray) + $startCol - 1; my @tagCols = ($startCol..$stopCol); $self->tagCol($tag,@tagCols); } # Apply Spans, if any: my $spans; if( defined( $detailData->{spans})){ $spans = $detailData->{spans}; my $spanSize = scalar(@$spans); #Error Checking, spans array should be a multiple of 2 if( ($spanSize % 2) < 1){ my $startCol = $col+1; my $noCols = @$detailArray; my $stopCol = scalar(@$detailArray) + $startCol - 1; foreach my $spanCol($startCol..$stopCol){ # build an array to feed to spans, change column number for row.col index # (every 2rd item in the array). my @spanArray = map $_ % 2 ? $spans->[$_] : "$spanCol,".$spans->[$_], (0..($spanSize-1)); $self->spans(@spanArray); } }else{ warn("Spans array for Col $col, is not a multiple of 2\n"); } } # Now Update the internal arrays for the inserted cols ### my %expandDataNew; foreach my $colIndex(keys %$expandData){ if($colIndex > $col){ # adjust cols greater than the current col $expandDataNew{$colIndex+$noCols} = $expandData->{$colIndex}; } else{ $expandDataNew{$colIndex} = $expandData->{$colIndex}; } } # Copy new to existing: %$expandData = %expandDataNew; my %indRowColsNew; foreach my $rcindex(keys %$indRowCols){ my ($rowIndex,$colIndex) = split(',',$rcindex); if($colIndex > $col){ # adjust cols greater than the current col my $newCol = $colIndex+$noCols; $indRowColsNew{"$rowIndex,$newCol"} = $indRowCols->{$rcindex}; } else{ $indRowColsNew{$rcindex} = $indRowCols->{$rcindex}; } } # Copy new to existing: %$indRowCols = %indRowColsNew; # Take care of any lower-level detail data: my $subDetail; if( defined( $detailData->{expandDataCol})){ $subDetail = $detailData->{expandDataCol}; foreach my $subCol( keys %$subDetail){ my $realCol = $col+$subCol; my $index = "$selectorRow,$realCol"; $self->tagCell('plus', $index); $indRowCols->{$index} = '+'; # update internal array # put subdetail data to top level, adjusting the relative row # numbers to real row numbers: #my %adjustedSubDetail; #foreach my $subKey(keys %$subDetail){ # $adjustedSubDetail{$subKey+$row} = $subDetail->{$subKey}; #} $expandData->{$realCol} = $subDetail->{$subCol}; } } # Put the state back $self->configure(-state => $currentState) unless( $currentState eq 'normal'); } =head2 hideDetail Hides the detail data for a given row. This method is called when a user clicks on an indicator that is already expanded. B $widget->hideDetail($row); # Hides the detail data for row number $row =cut sub hideDetail{ my $self = shift; my $row = shift; my $expandData = shift; my $detailData = $expandData->{$row}; my $selectorCol = $self->cget(-selectorCol); my $index = "$row,$selectorCol"; # make index for the cell to be hidden my $indRowCols = $self->{indRowCols}; # hide any sublevel data first: my $lowerLevelHideRows = 0; if( defined( $detailData->{expandData})){ # sublevel data exists my $subLevelData = $detailData->{expandData}; # convert sublevel data to absolute rows my $convertedSubData = {}; foreach my $rowNum(keys %$subLevelData){ $convertedSubData->{$rowNum+$row} = $subLevelData->{$rowNum}; } #Hide lower level data, if showing my $subLevelIndex; foreach my $rowNum (sort {$a<=>$b} keys %$convertedSubData){ $subLevelIndex = "$rowNum,$selectorCol"; if( $indRowCols->{$subLevelIndex} eq '-'){ # For lower-level hide-detail calls, we don't use any updates to the # expandData Arg, so we create an anonymous hash ref in this call $lowerLevelHideRows += $self->hideDetail($rowNum,{ %$convertedSubData} ); } } } $self->tagCell('plus', $index); $indRowCols->{$index} = '+'; # Get the detail data and hide: my $detailArray = $detailData->{data}; my $noRows = scalar( @$detailArray); # unapply any spans (This is not auto-handled by the row delete command, so we # have to do it here manually) my $spans; if( defined( $detailData->{spans})){ $spans = $detailData->{spans}; my $spanSize = scalar(@$spans); #Error Checking, spans array should be a multiple of 2 if( ($spanSize % 2) < 1){ my $startRow = $row+1; my $noRows = @$detailArray; my $stopRow = scalar(@$detailArray) + $startRow - 1; foreach my $spanRow($startRow..$stopRow){ # build an array to feed to spans, change column number for row.col index # (every 2rd item in the array). my @spanArray = map $_ % 2 ? '0,0' : "$spanRow,".$spans->[$_], (0..($spanSize-1)); $self->spans(@spanArray); } }else{ warn("Spans array for row $row, is not a multiple of 2\n"); } } # change state to normal if not already so we can modify the table my $currentState = $self->cget(-state); $self->configure(-state => 'normal') unless( $currentState eq 'normal'); # Move Any existing spans that are at rows > $row+$noRows to where the should be, now that rows # have been deleted $self->adjustSpans($row+$noRows,-$noRows); # deleteRows: $self->deleteRows($row+1,$noRows); my %indRowColsNew; foreach my $rcindex(keys %$indRowCols){ my ($rowIndex,$colIndex) = split(',',$rcindex); if($rowIndex > $row){ # adjust rows greater than the current row my $newRow = $rowIndex-$noRows; $indRowColsNew{"$newRow,$colIndex"} = $indRowCols->{$rcindex}; } else{ $indRowColsNew{$rcindex} = $indRowCols->{$rcindex}; } } # Copy new to existing: %$indRowCols = %indRowColsNew; $noRows += $lowerLevelHideRows; # Include the lower level detail rows hidden in the internall array update # Now Update the internal arrays for the deleted rows ### my %expandDataNew; foreach my $rowIndex(keys %$expandData){ if($rowIndex > ($row+$noRows)){ # adjust rows greater than the current row + detail data $expandDataNew{$rowIndex-$noRows} = $expandData->{$rowIndex}; } elsif($rowIndex<= $row){ # rows less than or equal just get copied $expandDataNew{$rowIndex} = $expandData->{$rowIndex}; } #else nothing, expand data that is in the detail data that is being hidden doesn't get copied } # Copy new to existing: %$expandData = %expandDataNew; # Put the state back $self->configure(-state => $currentState) unless( $currentState eq 'normal'); return $noRows; } sub hideDetailCol { my $self = shift; my $col = shift; my $expandData = shift; my $detailData = $expandData->{$col}; my $selectorRow = $self->cget(-selectorRow); my $index = "$selectorRow,$col"; # make index for the cell to be hidden my $indRowCols = $self->{indRowCols}; # hide any sublevel data first: my $lowerLevelHideCols = 0; if( defined( $detailData->{expandDataCol})){ # sublevel data exists my $subLevelData = $detailData->{expandDataCol}; # convert sublevel data to absolute rows my $convertedSubData = {}; foreach my $colNum(keys %$subLevelData){ $convertedSubData->{$colNum+$col} = $subLevelData->{$colNum}; } #Hide lower level data, if showing my $subLevelIndex; foreach my $colNum (sort {$a<=>$b} keys %$convertedSubData){ $subLevelIndex = "$selectorRow,$colNum"; if( $indRowCols->{$subLevelIndex} eq '-'){ # For lower-level hide-detail calls, we don't use any updates to the # expandData Arg, so we create an anonymous hash ref in this call $lowerLevelHideCols += $self->hideDetailCol($colNum,{ %$convertedSubData} ); } } } $self->tagCell('plus', $index); $indRowCols->{$index} = '+'; # Get the detail data and hide: my $detailArray = $detailData->{data}; my $noCols = scalar( @$detailArray); # unapply any spans (This is not auto-handled by the row delete command, so we # have to do it here manually) my $spans; if( defined( $detailData->{spans})){ $spans = $detailData->{spans}; my $spanSize = scalar(@$spans); #Error Checking, spans array should be a multiple of 2 if( ($spanSize % 2) < 1){ my $startCol = $Col+1; my $noCols = @$detailArray; my $stopCol = scalar(@$detailArray) + $startCol - 1; foreach my $spanCol($startCol..$stopCol){ # build an array to feed to spans, change column number for row.col index # (every 2rd item in the array). my @spanArray = map $_ % 2 ? '0,0' : "$spanCol,".$spans->[$_], (0..($spanSize-1)); $self->spans(@spanArray); } }else{ warn("Spans array for row $col, is not a multiple of 2\n"); } } # change state to normal if not already so we can modify the table my $currentState = $self->cget(-state); $self->configure(-state => 'normal') unless( $currentState eq 'normal'); # Move Any existing spans that are at rows > $row+$noRows to where the should be, now that rows # have been deleted $self->adjustSpansCol($col+$noCols,-$noCols); # deleteRows: $self->deleteCols($col+1,$noCols); my %indRowColsNew; foreach my $rcindex(keys %$indRowCols){ my ($rowIndex,$colIndex) = split(',',$rcindex); if($colIndex > $col){ # adjust rows greater than the current row my $newCol = $colIndex-$noCols; $indRowColsNew{"$rowIndex,$newCol"} = $indRowCols->{$rcindex}; } else{ $indRowColsNew{$rcindex} = $indRowCols->{$rcindex}; } } # Copy new to existing: %$indRowCols = %indRowColsNew; $noCols += $lowerLevelHideCols; # Include the lower level detail rows hidden in the internall array update # Now Update the internal arrays for the deleted rows ### my %expandDataNew; foreach my $colIndex(keys %$expandData){ if($colIndex > ($col+$noCols)){ # adjust rows greater than the current row + detail data $expandDataNew{$colIndex-$noCols} = $expandData->{$colIndex}; } elsif($colIndex<= $col){ # rows less than or equal just get copied $expandDataNew{$colIndex} = $expandData->{$colIndex}; } #else nothing, expand data that is in the detail data that is being hidden doesn't get copied } # Copy new to existing: %$expandData = %expandDataNew; # Put the state back $self->configure(-state => $currentState) unless( $currentState eq 'normal'); return $noCols; } #---------------------------------------------- # Sub called when -expandData option changes # sub expandData{ my ($self, $expandData) = @_; if(! defined($expandData)){ # Handle case where $widget->cget(-expandData) is called return $self->{Configure}{-expandData} } $self->clearSelectors(0); my $selectorCol = $self->cget(-selectorCol); # Create internal copy of expand Data for us to mess with my $expandData_int = {}; %$expandData_int = %$expandData; $self->{'_expandData'} = $expandData_int; # update the indRowCols quick lookup hash: $self->updateIndRowCols(0,$expandData, $selectorCol); $self->setSelectors(0); } sub expandDataCol { my ($self, $expandData) = @_; if(! defined($expandData)){ # Handle case where $widget->cget(-expandData) is called return $self->{Configure}{-expandDataCol} } $self->clearSelectors(1); my $selectorRow = $self->cget(-selectorRow); # Create internal copy of expand Data for us to mess with my $expandData_int = {}; %$expandData_int = %$expandData; $self->{'_expandDataCol'} = $expandData_int; # update the indRowCols quick lookup hash: $self->updateIndRowCols(1,$expandData, $selectorRow); $self->setSelectors(1); } #---------------------------------------------- # Sub called when -selectorCol option changes # sub selectorCol{ my ($self, $selectorCol) = @_; if(! defined($selectorCol)){ # Handle case where $widget->cget(-selectorCol) is called # # Set default if not defined yet my $selCol; unless( defined($self->{Configure}{-selectorCol})){ $selCol = $self->{Configure}{-selectorCol} = 0; } else{ $selCol = $self->{Configure}{-selectorCol}; } return $selCol; } ###### Get Old Selector Col and undo Here ?????### $self->clearSelectors(0); my $expandData = $self->cget('-expandData'); # update the indRowCols quick lookup hash: $self->updateIndRowCols(0,$expandData, $selectorCol); $self->setSelectors(0); } sub selectorRow { my ($self, $selectorRow) = @_; if(! defined($selectorRow)){ # Handle case where $widget->cget(-selectorCol) is called # # Set default if not defined yet my $selRow; unless( defined($self->{Configure}{-selectorRow})){ $selRow = $self->{Configure}{-selectorRow} = 0; } else{ $selRow = $self->{Configure}{-selectorRow}; } return $selRow; } ###### Get Old Selector Col and undo Here ?????### $self->clearSelectors(1); my $expandData = $self->cget('-expandDataCol'); # update the indRowCols quick lookup hash: $self->updateIndRowCols(1,$expandData, $selectorRow); $self->setSelectors(1); } # Method used to clear the selectors defined in the current indRowCols hash sub setSelectors{ my $self = shift; my $type = shift ; #1 for rows else for cols my $indRowCols = $self->{indRowCols}; my @pluses = grep $indRowCols->{$_} eq '+', keys %$indRowCols; my @minuses = grep $indRowCols->{$_} eq '-', keys %$indRowCols; $self->tagCell('plus', @pluses); $self->tagCell('minus', @minuses); if((defined $type) and ($type == 1)) { my $selectorRow = $self->cget('-selectorRow'); my $selectorRowHeight = $self->cget(-selectorRowWidth) || 1; # set to '2' (the default), incase this called before the defaults have been set $self->rowHeight($selectorRow, $selectorRowHeight); } else { my $selectorCol = $self->cget('-selectorCol'); my $selectorColWidth = $self->cget(-selectorColWidth) || 2; # set to '2' (the default), incase this called before the defaults have been set $self->colWidth($selectorCol, $selectorColWidth); } } # Method used to clear the selectors defined in the current indRowCols hash sub clearSelectors{ my $self = shift; my $type = shift ; #1 for rows else for cols my @indRowCols = keys %{$self->{indRowCols}}; if( @indRowCols){ $self->tagCell('', keys %{$self->{indRowCols}}); # Get selectorCol from first entry my ($row,$col) = split(',',$indRowCols[0]); if((defined $type) and ($type == 1)) { $self->rowHeight($row,'default'); } else { $self->colWidth($col, 'default'); } } } ### Method to update indRowCols, based on the expandData and selectorCol sub updateIndRowCols{ my $self = shift; my $type = shift ; #1 for rows else for cols my($expandData, $selectorColRow) = @_; my $indRowCols = {}; if((defined $type) and ($type == 1)) { foreach (keys %$expandData){ $indRowCols->{"$selectorColRow,$_"} = '+'; } my $expandDataRow = $self->cget('-expandData'); my $selectorCol = $self->cget('-selectorCol'); foreach (keys %$expandDataRow){ $indRowCols->{"$_,$selectorCol"} = '+'; } } else { foreach (keys %$expandData){ $indRowCols->{"$_,$selectorColRow"} = '+'; } my $expandDataCol = $self->cget('-expandDataCol'); my $selectorRow = $self->cget('-selectorRow'); foreach (keys %$expandDataCol){ $indRowCols->{"$selectorRow,$_"} = '+'; } } $self->{indRowCols} = $indRowCols; return $indRowCols; } # General Motion routine. Calls cellEnter if the pointer has entered another # cell. sub GeneralMotion{ my $self = shift; my $Ev = $self->XEvent; my $rc = $self->index('@' . $Ev->x.",".$Ev->y); $self->SUPER::GeneralMotion; my ($row,$col) = split(',',$rc); my @border = $self->border('mark',$Ev->x,$Ev->y); if( scalar(@border) == 0 && (!($self->{lastrc}) || $rc ne $self->{lastrc})){ # call cellEnter if cell number has changed and we aren't on a border $self->{lastrc} = $rc; $self->cellEnter($row,$col); } } # Method called with the pointer goes over a different cell # Sets the cursor to a top-right arrow if over # the selectorCol sub cellEnter{ my $self = shift; my ($row,$col) = @_; #print "Entered '$row,$col'\n"; my $rowColResizeDrag = $self->{rowColResizeDrag}; # Flag = 1 if cursor has been changed for a row/col resize unless($rowColResizeDrag){ my $indRowCols = $self->{indRowCols}; if( defined( $indRowCols->{"$row,$col"})){ #print "Setting ind cursor\n"; $self->configure(-cursor => 'top_left_arrow'); } else{ #print "Setting old cursor back '".$self->{normalCursor}."'\n"; $self->configure(-cursor => $self->{normalCursor}); } } } ############################################################# ## Over-ridden beginselect. Epands cell if +/- cell selected sub BeginSelect{ my $self = shift; my $rc = shift; my $indRowCols = $self->{indRowCols}; # get quick lookup hash my $state; if( defined($indRowCols->{$rc})) { $state = $indRowCols->{$rc}; my ($row,$col) = split(',',$rc); if(($col eq $self->cget('-selectorCol')) or ($col eq 0)) { if( $state eq '-'){ $self->hideDetail($row, $self->{'_expandData'}); } else{ $self->showDetail($row); } } else { if( $state eq '-'){ $self->hideDetailCol($col, $self->{'_expandDataCol'}); } else{ $self->showDetailCol($col); } } return; } # print "Calling inherited BeginSelect\n"; $self->SUPER::BeginSelect($rc); } #------------------- # Method Called to adjust spans starting at $row by $noRows # # If noRows is greater than 0 then the spans are adjusted up by $noRows # If noRows is negative, then spans are adjusted down by $noRows # # This method is needed becase the rowinsert/delete methods of TableMatrix don't # automatically adjust the spans sub adjustSpans{ my $self = shift; my ($row,$noRows) = @_; my %spans = $self->spans; # Get All Spans my %spansFilterd; # filtered for row > $row my $minRowFiltered = $row; my @filteredIndexes = grep { my ($r,$c) = split(',',$_); $r >= $minRowFiltered} keys %spans; my %unapplySpans; # temp hash used to unapply spans: @unapplySpans{@filteredIndexes} = map '0,0', @filteredIndexes; $self->spans(%unapplySpans); # unapply the spans the filtered spans: my %adjustedSpans; foreach (@filteredIndexes){ my ($r,$c) = split(',',$_); $adjustedSpans{($r+$noRows).",$c"} = $spans{$_}; } # Apply adjusted Spans: $self->spans(%adjustedSpans); } sub adjustSpansCol{ my $self = shift; my ($col,$noCols) = @_; my %spans = $self->spans; # Get All Spans my %spansFilterd; # filtered for row > $row my $minColFiltered = $col; my @filteredIndexes = grep { my ($r,$c) = split(',',$_); $c >= $minColFiltered} keys %spans; my %unapplySpans; # temp hash used to unapply spans: @unapplySpans{@filteredIndexes} = map '0,0', @filteredIndexes; $self->spans(%unapplySpans); # unapply the spans the filtered spans: my %adjustedSpans; foreach (@filteredIndexes){ my ($r,$c) = split(',',$_); $adjustedSpans{"$r,".($c+$noCols)} = $spans{$_}; } # Apply adjusted Spans: $self->spans(%adjustedSpans); } 1;