1=head1 NAME 2 3Tk::TableMatrix::SpreadsheetHideRows - Table Display with selectable hide/un-hide of rows 4 5=head1 SYNOPSIS 6 7 use Tk; 8 use Tk::TableMatrix::SpreadsheetHideRows 9 10 my $t = $top->Scrolled('SpreadsheetHideRows', 11 -selectorCol => 3, 12 -expandData => $hashRef, 13 -rows => 21, -cols => 11, 14 -width => 6, -height => 6, 15 -titlerows => 1, -titlecols => 1, 16 -variable => $arrayVar, 17 -selectmode => 'extended', 18 -resizeborders => 'both', 19 -bg => 'white', 20 ); 21 22=head1 DESCRIPTION 23 24L<Tk::TableMatrix::SpreadsheetHideRows> is a L<Tk::TableMatrix::Spreadsheet>-derived widget that implements 25a Spreadsheet-like display of tabular information, where some of the rows in the table 26can be expanded/hidden by clicking a '+/-' selector in the row. This can be used to display 27top-level information in a table, while allowing the user to expand certain table rows to 28view detail-level information. 29 30See demos/SpreadsheetHideRows in the source distribution for a simple example of this widget 31 32=head1 Widget-specific Options 33 34In addition the standard L<Tk::TableMatrix> widget options. The following options are implemented: 35 36=over 1 37 38=item -selectorCol 39 40Column number where the +/- selector will appear. Clicking on the +/- selector 41will expand/hide the detail information in the table for a particular row. 42 43=item -selectorColWidth 44 45Width of the column used to display the +/- selector. Defaults to 2 46 47=item -expandData 48 49Hash ref defining the detail-level data displayed when a row is expanded (by clicking 50the +/- selector). This hash ref should have the following structure: 51 52 $expandData = { 53 row1 => { tag => 'detailDataTag', 54 data => $detailData, 55 spans=> $spanData, 56 expandData => $subLevelData 57 }, 58 row2 => { 59 . 60 . 61 } 62 63 Where: 64 row1, row2, ... Row numbers that will be expandable. 65 tag => 'detailDataTag' Tag name that will be applied to the detail data. 66 (optional) 67 $detailData 2D Array of detail-data to be displayed when 68 the row is expanded. 69 e.g. [ [ r1c1, r1c2, r1c3 ], 70 [ r2c1, r2c2, r2,c3] ] 71 $spans 1D array of span information (optional) to be 72 used for display of the detail information. 73 e.g. [ col2 => "rows,cols", col4 => "rows,cols", ... ] 74 75 $subLevelData Optional Recursive expandData used to hold detail-data of detail-data. 76 77 78 79=back 80 81=head1 MEMBER DATA 82 83The following items are stored as member data 84 85=over 1 86 87=item defaultCursor 88 89Name of the mouse cursor pointer that is used for normal (i.e. non-title, non-indicator) cells in the widget. 90This is set to the value of the $widget->cget(-cursor) option when the widget is created. 91 92=item indRowCols 93 94Hash ref of Row/Cols indexes where there are indicators stores. This is a quick 95lookup hash built from I<_expandData>. 96 97=item _expandData 98 99Internal version of the I<expandData> hash. Any sub-detail data (i.e. expand data 100that is at lower levels of I<expandData>) that is visible is placed at the top level of this hash, for 101keeping track of the visible I<expandData>. 102 103=back 104 105=head1 Widget Methods 106 107In addition the standard L<Tk::TableMatrix> widget method. The following methods are implemented: 108 109 110=cut 111 112package Tk::TableMatrix::SpreadsheetHideRows; 113 114use Carp; 115 116 117use Tk; 118use Tk::TableMatrix::Spreadsheet; 119use Tk::Derived; 120 121use base qw/ Tk::Derived Tk::TableMatrix::Spreadsheet/; 122 123$VERSION = '1.26'; 124 125 126Tk::Widget->Construct("SpreadsheetHideRows"); 127 128 129sub ClassInit{ 130 my ($class,$mw) = @_; 131 132 $class->SUPER::ClassInit($mw); 133 134 135 136}; 137 138 139sub Populate { 140 my ($self, $args) = @_; 141 142 $self->ConfigSpecs( 143 -selectorCol => [qw/METHOD selectorCol SelectorCol/, undef], 144 -selectorColWidth=> [qw/PASSIVE selectorColWidth SelectorColWidth/, 2], 145 -expandData => [qw/METHOD expandData ExpandData/, {}], 146 ); 147 148 149 $self->SUPER::Populate($args); 150 151 $self->tagConfigure('plus', -image => $self->Getimage("plus"), -showtext => 0, -anchor => 'center'); 152 $self->tagConfigure('minus', -image => $self->Getimage("minus"), -showtext => 0, -anchor => 'center'); 153 154 $self->{normalCursor} = $self->cget('-cursor'); # get the default cursor 155 156 157} 158 159=head2 showDetail 160 161Shows (i.e. expands the table) the detail data for a given row. This method is called 162when a user clicks on an indicator that is not already expanded. 163 164B<Usage:> 165 166 $widget->showDetail($row); 167 168 # Shows the detail data for row number $row 169 170=cut 171 172sub showDetail{ 173 174 my $self = shift; 175 176 my $row = shift; 177 178 my $selectorCol = $self->cget(-selectorCol); 179 180 my $index = "$row,$selectorCol"; # make index for the cell to be expanded 181 182 my $indRowCols = $self->{indRowCols}; 183 184 $self->tagCell('minus', $index); 185 $indRowCols->{$index} = '-'; 186 187 # Get the detail data and insert: 188 my $expandData = $self->{'_expandData'}; 189 my $detailData = $expandData->{$row}; 190 my $detailArray = $detailData->{data}; 191 192 my $noRows = scalar( @$detailArray); 193 194 # InsertRows: 195 # change state to normal if not already so we can insert 196 my $currentState = $self->cget(-state); 197 $self->configure(-state => 'normal') unless( $currentState eq 'normal'); 198 $self->insertRows($row,$noRows); 199 200 # Adjust Spans: 201 $self->adjustSpans($row+1,$noRows); 202 203 #insert data 204 my $colorigin = $self->cget(-colorigin); 205 my $rowNum = $row+1; 206 foreach my $rowData( @$detailArray ){ 207 #my @rowArray = @$rowData; 208 #grep s/([\{\}])/\\$1/g, @rowArray; # backslash any existing '{' chars, so they don't get interpreted as field chars 209 my $insertData = "{".join("}{", @$rowData)."}"; # make insert data look like tcl array, so it 210 # gets put in different cells 211 $self->set('row', "$rowNum,$colorigin", $insertData); 212 $rowNum++; 213 } 214 215 # Apply Tags, if any: 216 my $tag; 217 if( defined( $detailData->{tag})){ 218 $tag = $detailData->{tag}; 219 my $startRow = $row+1; 220 my $noRows = @$detailArray; 221 my $stopRow = scalar(@$detailArray) + $startRow - 1; 222 my @tagRows = ($startRow..$stopRow); 223 $self->tagRow($tag,@tagRows); 224 } 225 226 # Apply Spans, if any: 227 my $spans; 228 if( defined( $detailData->{spans})){ 229 $spans = $detailData->{spans}; 230 231 my $spanSize = scalar(@$spans); 232 #Error Checking, spans array should be a multiple of 2 233 if( ($spanSize % 2) < 1){ 234 235 my $startRow = $row+1; 236 my $noRows = @$detailArray; 237 my $stopRow = scalar(@$detailArray) + $startRow - 1; 238 foreach my $spanRow($startRow..$stopRow){ 239 # build an array to feed to spans, change column number for row.col index 240 # (every 2rd item in the array). 241 my @spanArray = map $_ % 2 ? $spans->[$_] : "$spanRow,".$spans->[$_], (0..($spanSize-1)); 242 $self->spans(@spanArray); 243 } 244 245 }else{ 246 warn("Spans array for row $row, is not a multiple of 2\n"); 247 } 248 249 } 250 251 252 253 254 # Now Update the internal arrays for the inserted rows ### 255 my %expandDataNew; 256 foreach my $rowIndex(keys %$expandData){ 257 if($rowIndex > $row){ # adjust rows greater than the current row 258 $expandDataNew{$rowIndex+$noRows} = $expandData->{$rowIndex}; 259 } 260 else{ 261 $expandDataNew{$rowIndex} = $expandData->{$rowIndex}; 262 } 263 } 264 # Copy new to existing: 265 %$expandData = %expandDataNew; 266 267 268 my %indRowColsNew; 269 foreach my $rcindex(keys %$indRowCols){ 270 271 my ($rowIndex,$colIndex) = split(',',$rcindex); 272 if($rowIndex > $row){ # adjust rows greater than the current row 273 my $newRow = $rowIndex+$noRows; 274 $indRowColsNew{"$newRow,$colIndex"} = $indRowCols->{$rcindex}; 275 } 276 else{ 277 $indRowColsNew{$rcindex} = $indRowCols->{$rcindex}; 278 } 279 } 280 # Copy new to existing: 281 %$indRowCols = %indRowColsNew; 282 283 # Take care of any lower-level detail data: 284 my $subDetail; 285 if( defined( $detailData->{expandData})){ 286 $subDetail = $detailData->{expandData}; 287 288 foreach my $subRow( keys %$subDetail){ 289 290 my $realRow = $row+$subRow; 291 my $index = "$realRow,$selectorCol"; 292 $self->tagCell('plus', $index); 293 $indRowCols->{$index} = '+'; # update internal array 294 295 # put subdetail data to top level, adjusting the relative row 296 # numbers to real row numbers: 297 #my %adjustedSubDetail; 298 #foreach my $subKey(keys %$subDetail){ 299 # $adjustedSubDetail{$subKey+$row} = $subDetail->{$subKey}; 300 #} 301 $expandData->{$realRow} = $subDetail->{$subRow}; 302 } 303 304 } 305 306 # Put the state back 307 $self->configure(-state => $currentState) unless( $currentState eq 'normal'); 308 309 310} 311 312=head2 hideDetail 313 314Hides the detail data for a given row. This method is called 315when a user clicks on an indicator that is already expanded. 316 317B<Usage:> 318 319 $widget->hideDetail($row); 320 321 # Hides the detail data for row number $row 322 323=cut 324 325sub hideDetail{ 326 327 my $self = shift; 328 329 my $row = shift; 330 my $expandData = shift; 331 my $detailData = $expandData->{$row}; 332 333 my $selectorCol = $self->cget(-selectorCol); 334 335 my $index = "$row,$selectorCol"; # make index for the cell to be hidden 336 337 my $indRowCols = $self->{indRowCols}; 338 339 # hide any sublevel data first: 340 my $lowerLevelHideRows = 0; 341 if( defined( $detailData->{expandData})){ # sublevel data exists 342 my $subLevelData = $detailData->{expandData}; 343 # convert sublevel data to absolute rows 344 my $convertedSubData = {}; 345 foreach my $rowNum(keys %$subLevelData){ 346 $convertedSubData->{$rowNum+$row} = $subLevelData->{$rowNum}; 347 } 348 #Hide lower level data, if showing 349 my $subLevelIndex; 350 foreach my $rowNum (sort {$a<=>$b} keys %$convertedSubData){ 351 $subLevelIndex = "$rowNum,$selectorCol"; 352 if( $indRowCols->{$subLevelIndex} eq '-'){ 353 # For lower-level hide-detail calls, we don't use any updates to the 354 # expandData Arg, so we create an anonymous hash ref in this call 355 $lowerLevelHideRows += $self->hideDetail($rowNum,{ %$convertedSubData} ); 356 } 357 } 358 } 359 360 361 $self->tagCell('plus', $index); 362 $indRowCols->{$index} = '+'; 363 364 365 # Get the detail data and hide: 366 my $detailArray = $detailData->{data}; 367 368 my $noRows = scalar( @$detailArray); 369 370 # unapply any spans (This is not auto-handled by the row delete command, so we 371 # have to do it here manually) 372 my $spans; 373 if( defined( $detailData->{spans})){ 374 $spans = $detailData->{spans}; 375 376 my $spanSize = scalar(@$spans); 377 #Error Checking, spans array should be a multiple of 2 378 if( ($spanSize % 2) < 1){ 379 380 my $startRow = $row+1; 381 my $noRows = @$detailArray; 382 my $stopRow = scalar(@$detailArray) + $startRow - 1; 383 foreach my $spanRow($startRow..$stopRow){ 384 # build an array to feed to spans, change column number for row.col index 385 # (every 2rd item in the array). 386 my @spanArray = map $_ % 2 ? '0,0' : "$spanRow,".$spans->[$_], (0..($spanSize-1)); 387 $self->spans(@spanArray); 388 } 389 390 }else{ 391 warn("Spans array for row $row, is not a multiple of 2\n"); 392 } 393 394 } 395 396 397 # change state to normal if not already so we can modify the table 398 my $currentState = $self->cget(-state); 399 $self->configure(-state => 'normal') unless( $currentState eq 'normal'); 400 401 # Move Any existing spans that are at rows > $row+$noRows to where the should be, now that rows 402 # have been deleted 403 $self->adjustSpans($row+$noRows,-$noRows); 404 405 # deleteRows: 406 $self->deleteRows($row+1,$noRows); 407 408 my %indRowColsNew; 409 foreach my $rcindex(keys %$indRowCols){ 410 411 my ($rowIndex,$colIndex) = split(',',$rcindex); 412 if($rowIndex > $row){ # adjust rows greater than the current row 413 my $newRow = $rowIndex-$noRows; 414 $indRowColsNew{"$newRow,$colIndex"} = $indRowCols->{$rcindex}; 415 } 416 else{ 417 $indRowColsNew{$rcindex} = $indRowCols->{$rcindex}; 418 } 419 } 420 # Copy new to existing: 421 %$indRowCols = %indRowColsNew; 422 423 424 $noRows += $lowerLevelHideRows; # Include the lower level detail rows hidden in the internall array update 425 426 427 # Now Update the internal arrays for the deleted rows ### 428 my %expandDataNew; 429 foreach my $rowIndex(keys %$expandData){ 430 if($rowIndex > ($row+$noRows)){ # adjust rows greater than the current row + detail data 431 $expandDataNew{$rowIndex-$noRows} = $expandData->{$rowIndex}; 432 } 433 elsif($rowIndex<= $row){ # rows less than or equal just get copied 434 $expandDataNew{$rowIndex} = $expandData->{$rowIndex}; 435 } 436 #else nothing, expand data that is in the detail data that is being hidden doesn't get copied 437 } 438 # Copy new to existing: 439 %$expandData = %expandDataNew; 440 441 442 # Put the state back 443 $self->configure(-state => $currentState) unless( $currentState eq 'normal'); 444 445 446 return $noRows; 447 448 449} 450 451#---------------------------------------------- 452# Sub called when -expandData option changes 453# 454sub expandData{ 455 my ($self, $expandData) = @_; 456 457 458 459 if(! defined($expandData)){ # Handle case where $widget->cget(-expandData) is called 460 461 return $self->{Configure}{-expandData} 462 463 } 464 465 $self->clearSelectors; 466 467 my $selectorCol = $self->cget(-selectorCol); 468 469 # Create internal copy of expand Data for us to mess with 470 my $expandData_int = {}; 471 %$expandData_int = %$expandData; 472 $self->{'_expandData'} = $expandData_int; 473 474 # update the indRowCols quick lookup hash: 475 $self->updateIndRowCols($expandData, $selectorCol); 476 477 $self->setSelectors; 478 479 480} 481 482 483 484 485#---------------------------------------------- 486# Sub called when -selectorCol option changes 487# 488sub selectorCol{ 489 my ($self, $selectorCol) = @_; 490 491 492 493 if(! defined($selectorCol)){ # Handle case where $widget->cget(-selectorCol) is called 494 # 495 # Set default if not defined yet 496 my $selCol; 497 unless( defined($self->{Configure}{-selectorCol})){ 498 $selCol = $self->{Configure}{-selectorCol} = 0; 499 } 500 else{ 501 $selCol = $self->{Configure}{-selectorCol}; 502 } 503 504 return $selCol; 505 506 } 507 508 ###### Get Old Selector Col and undo Here ?????### 509 $self->clearSelectors; 510 511 my $expandData = $self->cget('-expandData'); 512 513 # update the indRowCols quick lookup hash: 514 $self->updateIndRowCols($expandData, $selectorCol); 515 516 $self->setSelectors; 517 518} 519 520# Method used to clear the selectors defined in the current indRowCols hash 521sub setSelectors{ 522 my $self = shift; 523 524 my $indRowCols = $self->{indRowCols}; 525 526 my @pluses = grep $indRowCols->{$_} eq '+', keys %$indRowCols; 527 my @minuses = grep $indRowCols->{$_} eq '-', keys %$indRowCols; 528 529 $self->tagCell('plus', @pluses); 530 $self->tagCell('minus', @minuses); 531 532 my $selectorCol = $self->cget('-selectorCol'); 533 my $selectorColWidth = $self->cget(-selectorColWidth) || 2; # set to '2' (the default), incase this called before the defaults have been set 534 $self->colWidth($selectorCol, $selectorColWidth); 535 536} 537 538 539 540 541# Method used to clear the selectors defined in the current indRowCols hash 542sub clearSelectors{ 543 my $self = shift; 544 545 my @indRowCols = keys %{$self->{indRowCols}}; 546 if( @indRowCols){ 547 $self->tagCell('', keys %{$self->{indRowCols}}); 548 549 # Get selectorCol from first entry 550 my ($row,$col) = split(',',$indRowCols[0]); 551 $self->colWidth($col, 'default'); 552 } 553 554} 555 556 557### Method to update indRowCols, based on the expandData and selectorCol 558sub updateIndRowCols{ 559 560 my $self = shift; 561 562 my($expandData, $selectorCol) = @_; 563 564 my $indRowCols = {}; 565 566 foreach (keys %$expandData){ 567 $indRowCols->{"$_,$selectorCol"} = '+'; 568 } 569 570 $self->{indRowCols} = $indRowCols; 571 return $indRowCols; 572 573} 574 575# General Motion routine. Calls cellEnter if the pointer has entered another 576# cell. 577 578sub GeneralMotion{ 579 580 my $self = shift; 581 my $Ev = $self->XEvent; 582 583 my $rc = $self->index('@' . $Ev->x.",".$Ev->y); 584 585 $self->SUPER::GeneralMotion; 586 587 my ($row,$col) = split(',',$rc); 588 589 my @border = $self->border('mark',$Ev->x,$Ev->y); 590 if( scalar(@border) == 0 && (!($self->{lastrc}) || $rc ne $self->{lastrc})){ # call cellEnter if cell number has changed and we aren't on a border 591 $self->{lastrc} = $rc; 592 $self->cellEnter($row,$col); 593 } 594 595 596 597} 598 599# Method called with the pointer goes over a different cell 600# Sets the cursor to a top-right arrow if over 601# the selectorCol 602 603sub cellEnter{ 604 605 my $self = shift; 606 my ($row,$col) = @_; 607 608 #print "Entered '$row,$col'\n"; 609 610 611 my $rowColResizeDrag = $self->{rowColResizeDrag}; # Flag = 1 if cursor has been changed for a row/col resize 612 613 unless($rowColResizeDrag){ 614 615 my $indRowCols = $self->{indRowCols}; 616 617 if( defined( $indRowCols->{"$row,$col"})){ 618 #print "Setting ind cursor\n"; 619 $self->configure(-cursor => 'top_left_arrow'); 620 } 621 else{ 622 #print "Setting old cursor back '".$self->{normalCursor}."'\n"; 623 $self->configure(-cursor => $self->{normalCursor}); 624 } 625 } 626 627 628} 629 630 631############################################################# 632## Over-ridden beginselect. Epands cell if +/- cell selected 633sub BeginSelect{ 634 my $self = shift; 635 my $rc = shift; 636 637 my $indRowCols = $self->{indRowCols}; # get quick lookup hash 638 my $state; 639 if( defined($indRowCols->{$rc})) { 640 $state = $indRowCols->{$rc}; 641 my ($row,$col) = split(',',$rc); 642 if( $state eq '-'){ 643 $self->hideDetail($row, $self->{'_expandData'}); 644 } 645 else{ 646 $self->showDetail($row); 647 } 648 649 return; 650 } 651 652 # print "Calling inherited BeginSelect\n"; 653 $self->SUPER::BeginSelect($rc); 654 655} 656 657 658#------------------- 659# Method Called to adjust spans starting at $row by $noRows 660# 661# If noRows is greater than 0 then the spans are adjusted up by $noRows 662# If noRows is negative, then spans are adjusted down by $noRows 663# 664# This method is needed becase the rowinsert/delete methods of TableMatrix don't 665# automatically adjust the spans 666sub adjustSpans{ 667 668 my $self = shift; 669 my ($row,$noRows) = @_; 670 671 my %spans = $self->spans; # Get All Spans 672 my %spansFilterd; # filtered for row > $row 673 my $minRowFiltered = $row; 674 my @filteredIndexes = grep { my ($r,$c) = split(',',$_); $r >= $minRowFiltered} keys %spans; 675 my %unapplySpans; # temp hash used to unapply spans: 676 @unapplySpans{@filteredIndexes} = map '0,0', @filteredIndexes; 677 $self->spans(%unapplySpans); # unapply the spans the filtered spans: 678 my %adjustedSpans; 679 foreach (@filteredIndexes){ 680 my ($r,$c) = split(',',$_); 681 $adjustedSpans{($r+$noRows).",$c"} = $spans{$_}; 682 } 683 684 # Apply adjusted Spans: 685 $self->spans(%adjustedSpans); 686 687} 688 6891; 690 691