1# Created by Dmitry Karasik <dk@plab.ku.dk> 2# Modifications by Anton Berezin <tobez@tobez.org> 3package Prima::Header; 4 5use strict; 6use warnings; 7use Prima::Classes; 8 9use vars qw(@ISA); 10@ISA = qw(Prima::Widget); 11 12use constant CaptureBrimWidth => 2; 13 14{ 15my %RNT = ( 16 %{Prima::Widget-> notification_types()}, 17 DrawItem => nt::Action, 18 MeasureItem => nt::Action, 19 MoveItem => nt::Action, 20 SizeItem => nt::Action, 21 SizeItems => nt::Action, 22); 23 24sub notification_types { return \%RNT; } 25} 26 27 28sub profile_default 29{ 30 my $def = $_[ 0]-> SUPER::profile_default; 31 my %prf = ( 32 offset => 0, 33 items => [], 34 widths => [], 35 pressed => -1, 36 clickable => 1, 37 scalable => 1, 38 dragable => 1, 39 minTabWidth => 2, 40 vertical => 0, 41 selectable => 0, 42 ); 43 @$def{keys %prf} = values %prf; 44 return $def; 45} 46 47sub init 48{ 49 my $self = shift; 50 $self-> {$_} = 0 for qw(offset count maxWidth clickable scalable minTabWidth vertical dragable); 51 $self-> {$_} = -1 for qw(pressed); 52 $self-> {widths} = []; 53 $self-> {items} = []; 54 my %profile = $self-> SUPER::init(@_); 55 $self-> {fontHeight} = $self-> font-> height; 56 $self-> {resetDisabled} = 1; 57 $self-> $_( $profile{$_}) 58 for ( qw( vertical minTabWidth items widths offset pressed clickable scalable dragable)); 59 if ( scalar @{$profile{widths}} == 0) { 60 $self-> autowidths; 61 $self-> repaint; 62 } 63 return %profile; 64} 65 66sub on_paint 67{ 68 my ( $self, $canvas) = @_; 69 my @size = $canvas-> size; 70 my @c = $self-> enabled ? 71 ( $self-> color, $self-> backColor) : 72 ( $self-> disabledColor, $self-> disabledBackColor); 73 my @c3d = ( $self-> light3DColor, $self-> dark3DColor); 74 75 my ($prelightPart, $prelightColor) = (-1); 76 if ( defined $self->{prelight} ) { 77 $prelightColor = $self-> prelight_color($c[1]); 78 $prelightPart = $self->{prelight}; 79 } 80 81 $self-> rect3d( 0, 0, $size[0]-1, $size[1]-1, 1, @c3d, $c[1]); 82 my $v = $self-> {vertical}; 83 my ( $x, $y) = ( - $self-> {offset}, ( $size[1] - $self-> {fontHeight}) / 2); 84 my $i; 85 86 my $pressed = $self-> {pressed}; 87 @c3d = reverse @c3d if $v; 88 my ( $wx, $cx) = ( $self-> {widths}, $self-> {count}); 89 my ( $notifier, @notifyParms) = $self-> get_notify_sub(q(DrawItem)); 90 $self-> push_event; 91 my ( $d, $lim) = $v ? ( $x, $size[1]) : ( $x, $size[0]); 92 for ( $i = 0; $i < $cx; $i++) { 93 next unless $$wx[$i]; 94 if ( $d + $$wx[$i] + 2 < 1) { 95 $d += $$wx[$i] + 2; 96 next; 97 } 98 my $mx = ( $d + $$wx[$i] + 1 > $lim - 2) ? ($lim - 2) : ($d + $$wx[$i] + 1); 99 $v ? 100 $self-> clipRect( 1, $d < 1 ? 1 : $d, $size[0] - 2, $mx) : 101 $self-> clipRect( $d < 1 ? 1 : $d, 1, $mx, $size[1] - 2); 102 if ( $i == $prelightPart) { 103 $self-> color($prelightColor); 104 $self-> bar(0,0,@size); 105 } 106 $self-> color( $c[0]); 107 $v ? 108 $notifier-> ( @notifyParms, $canvas, $i, 1, $d + 1, $size[0] - 2, $mx - 1, $d + 4) : 109 $notifier-> ( @notifyParms, $canvas, $i, $d + 1, 1, $mx - 1, $size[1] - 2, $y); 110 if ( $i == $pressed) { 111 $self-> color( $c3d[1]); 112 $v ? 113 $self-> line( $size[0] - 2, $d, $size[0] - 2, $d + $$wx[$i]) : 114 $self-> line( $d, $size[1] - 2, $d + $$wx[$i], $size[1] - 2); 115 } else { 116 $self-> color( $c3d[0]); 117 } 118 $v ? 119 $self-> line( 1, $d, $size[0] - 2, $d) : 120 $self-> line( $d, 1, $d, $size[1] - 2); 121 if ( $i == $pressed) { 122 $self-> color( $c3d[0]); 123 $v ? 124 $self-> line( 1, $d, 1, $d + $$wx[$i]) : 125 $self-> line( $d, 1, $d + $$wx[$i], 1); 126 } else { 127 $self-> color( $c3d[1]); 128 } 129 $d += $$wx[$i] + 1; 130 $v ? 131 $self-> line( 1, $d, $size[0] - 2, $d) : 132 $self-> line( $d, 1, $d, $size[1] - 2); 133 last if $d > $lim - 3; 134 $d++; 135 } 136 $self-> pop_event; 137} 138 139sub on_fontchanged 140{ 141 my $self = $_[0]; 142 $self-> {fontHeight} = $self-> font-> height; 143} 144 145sub on_drawitem 146{ 147 my ( $self, $canvas, $index, $left, $bottom, $right, $top, $y) = @_; 148 $canvas-> text_shape_out( $self-> {items}-> [$index], $left, $y); 149} 150 151sub on_measureitem 152{ 153 my ( $self, $index, $result) = @_; 154 $$result = $self-> {vertical} ? 155 $self-> {fontHeight} : 156 $self-> get_text_width( $self-> {items}-> [$index]); 157} 158 159sub point2area 160{ 161 my ( $self, $x, $y, $useBorders) = @_; 162 my $i; 163 my $pressable = $self-> {clickable} || $self-> {dragable}; 164 return if !$self-> {scalable} && !$pressable; 165 my $lim; 166 if ( $self-> {vertical}) { 167 return undef if ( $x < 1 || $x > $self-> width - 1) && !$useBorders; 168 $lim = $y; 169 } else { 170 return undef if ( $y < 1 || $y > $self-> height - 1) && !$useBorders; 171 $lim = $x; 172 } 173 174 my $cbw = $self-> {scalable} ? CaptureBrimWidth : 0; 175 my $sx = - $self-> {offset} + 1 + $cbw; 176 my $c = $self-> {count}; 177 my $wx = $self-> {widths}; 178 for ( $i = 0; $i < $c; $i++) { 179 next unless $$wx[$i]; 180 $sx += $$wx[$i] - $cbw * 2; 181 if ( $lim < $sx) { 182 return $pressable ? $i : undef; 183 } 184 $sx += $cbw * 2 + 2; 185 if ( $lim < $sx) { 186 return $self-> {scalable} ? -($i+1) : $i; 187 } 188 } 189 return undef; 190} 191 192sub tab2offset 193{ 194 my ( $self, $item) = @_; 195 my $i; 196 my $c = $self-> {count}; 197 my $x = 1; 198 for ( $i = 0; $i < $item; $i++) { 199 next unless $self-> {widths}-> [$i]; 200 $x += $self-> {widths}-> [$i] + 2; 201 } 202 return $x; 203} 204 205sub tab2rect 206{ 207 my ( $self, $id) = @_; 208 my $offset = $self-> tab2offset( $id) - $self-> {offset} - 1; 209 return $self-> {vertical} ? 210 ( 1, $offset, $self-> width - 1, $offset + $self-> {widths}-> [$id] + 2) : 211 ( $offset, 1, $offset + $self-> {widths}-> [$id] + 2, $self-> height - 1); 212} 213 214sub reset_transaction 215{ 216 my $self = $_[0]; 217 my $lim = $self-> {vertical} ? $self-> height : $self-> width; 218 $self-> {swidth} = $self-> tab2offset( $self-> {tabId}) - $self-> {offset}; 219 $self-> {maxwidth} = $lim - $self-> {swidth} - 2; 220 $self-> {maxwidth} -= $self-> {minTabWidth} if $self-> {tabId} < $self-> {count} - 1; 221 if ( $self-> {swidth} < 0) { 222 $self-> {minwidth} = -$self-> {swidth} - 1; 223 $self-> {minwidth} = $self-> {minTabWidth} 224 if $self-> {minwidth} > $self-> {minTabWidth}; 225 } else { 226 $self-> {minwidth} = $self-> {minTabWidth}; 227 } 228} 229 230sub on_mousedown 231{ 232 my ( $self, $btn, $mod, $x, $y) = @_; 233 return unless $btn == mb::Left; 234 return if $self-> {transaction}; 235 my $id = $self-> point2area( $x, $y); 236 return unless defined $id; 237 $self-> capture(1); 238 if ( $id < 0) { 239 $self-> {transaction} = 2; 240 $self-> {anchor} = $self-> {vertical} ? $y : $x; 241 $self-> {tabId} = - $id - 1; 242 $self-> {owidth} = $self-> {widths}-> [$self-> {tabId}]; 243 $self-> reset_transaction; 244 } else { 245 $self-> {transaction} = 1; 246 $self-> {tabId} = $id; 247 $self-> pressed( $id); 248 $self-> {clickAllowed} = $self-> {clickable}; 249 $self-> {anchor} = $self-> {vertical} ? $y : $x; 250 $self-> {anchor} -= $self-> tab2offset( $id) - $self-> {offset}; 251 } 252 $self-> {pointerPos} = [$self-> pointerPos]; 253 delete $self-> {pointerSet}; 254} 255 256sub on_mouseup 257{ 258 my ( $self, $btn, $mod, $x, $y) = @_; 259 return unless $self-> {transaction}; 260 return unless $btn == mb::Left; 261 my $id = $self-> point2area( $x, $y); 262 263 $self-> capture(0); 264 if ( $self-> {transaction} == 1) { 265 my @a = $self-> tab2rect( $self-> {tabId}); 266 if ( $x >= $a[0] && $x < $a[2] && $y >= $a[1] && $y < $a[3]) { 267 $self-> notify(q(Click), $self-> {tabId}) if $self-> {clickAllowed}; 268 } 269 $self-> pressed(-1); 270 } else { 271 $self-> recalc_maxwidth; 272 } 273 $self-> {transaction} = undef; 274} 275 276 277sub on_mousemove 278{ 279 my ( $self, $mod, $x, $y) = @_; 280 return if $self->{no_mouse_move}; 281 unless ( $self-> {transaction}) { 282 if ( $self-> enabled ) { 283 my $p = $self-> point2area( $x, $y); 284 my $ptr; 285 if ( defined $p && $p < 0) { 286 $ptr = $self-> {vertical} ? cr::SizeNS : cr::SizeWE; 287 } elsif ( $self-> {dragable} && !$self-> {clickable} && defined $p) { 288 $ptr = cr::Move; 289 } else { 290 $ptr = cr::Default; 291 } 292 $self-> pointer( $ptr); 293 294 my $prelight = (defined($p) && $p >= 0) ? $p : undef; 295 if (( $prelight // -1 ) != ( $self->{prelight} // -1)) { 296 $self->{prelight} = $prelight; 297 $self->repaint; 298 } 299 300 } 301 return; 302 } 303 304 if ( $self-> {transaction} == 1) { 305 my @a = $self-> tab2rect( $self-> {tabId}); 306 $self-> pressed( 307 ( $x >= $a[0] && $x < $a[2] && $y >= $a[1] && $y < $a[3]) ? 308 $self-> {tabId} : -1 309 ); 310 return unless $self-> {dragable}; 311 my @ppos = $self-> pointerPos; 312 if ( $self-> {clickable} && !$self-> {pointerSet}) { 313 my @p = @{$self-> {pointerPos}}; 314 if ( abs( $p[0] - $ppos[0]) > 2 || abs( $p[1] - $ppos[1]) > 2) { 315 $self-> pointer( cr::Move); 316 delete $self-> {pointerPos}; 317 $self-> {pointerSet} = 1; 318 } 319 } 320 my @lx = $self-> {vertical} ? @a[1,3] : @a[0,2]; 321 my $d = $self-> {vertical} ? $y : $x; 322 return if $d >= $lx[0] && $d < $lx[1]; 323 my $osc = $self-> {scalable}; $self-> {scalable} = 0; 324 my $p = $self-> point2area( $x, $y, 1); # exclude borders 325 $self-> {scalable} = $osc; 326 my $o = $self-> {tabId}; 327 return unless defined $p; 328 return if $p == $o; 329 $self-> {clickAllowed} = 0; 330 my $newpos; 331 if ( $self-> {widths}-> [$p] > $self-> {widths}-> [$o]) { 332 $ppos[$self-> {vertical} ? 1 : 0] += 333 ( $self-> {widths}-> [$p] - $self-> {widths}-> [$o]) * (( $p > $o) ? 1 : -1); 334 $newpos = 1; 335 } 336 337 splice( @{$self-> {items}}, $p, 0, splice( @{$self-> {items}}, $o, 1)); 338 splice( @{$self-> {widths}}, $p, 0, splice( @{$self-> {widths}}, $o, 1)); 339 $self-> {tabId} = $p; 340 $self-> repaint; 341 $self-> notify(q(MoveItem), $o, $p); 342 local $self->{no_mouse_move} = 1; 343 $self-> pointerPos( @ppos) if $newpos; 344 } else { 345 my @sz = $self-> size; 346 my $d = $self-> {vertical} ? $y : $x; 347 my $nw = $self-> {owidth} + $d - $self-> {anchor}; 348 $nw = $self-> {maxwidth} if $nw > $self-> {maxwidth}; 349 $nw = $self-> {minwidth} if $nw < $self-> {minwidth}; 350 $nw = $self-> {minTabWidth} if $nw < $self-> {minTabWidth}; 351 my $ow = $self-> {widths}-> [$self-> {tabId}]; 352 return if $nw == $ow; 353 $self-> {widths}-> [$self-> {tabId}] = $nw; 354 my $o = $self-> {swidth} + $ow; 355 $self-> {maxWidth} += $nw - $ow; 356 $self-> {vertical} ? 357 $self-> scroll( 358 0, $nw - $ow, 359 confineRect => [ 1, $o, $sz[0] - 1, $sz[1] - 1 + abs($nw - $ow)], 360 clipRect => [ 1, 1, $sz[0]-1, $sz[1]-1], 361 ) : $self-> scroll( 362 $nw - $ow, 0, 363 confineRect => [ $o, 1, $sz[0] - 1 + abs($nw - $ow), $sz[1] - 1], 364 clipRect => [ 1, 1, $sz[0]-1, $sz[1]-1], 365 ); 366 $self-> notify(q(SizeItem), $self-> {tabId}, $ow, $nw); 367 } 368} 369 370sub on_mouseleave 371{ 372 my $self = shift; 373 $self-> repaint if defined( delete $self->{prelight} ); 374} 375 376sub on_mouseclick 377{ 378 $_[0]-> clear_event; 379 return unless $_[5]; 380 shift-> notify(q(MouseDown), @_); 381} 382 383 384sub on_click 385{ 386# my ( $self, $index) = @_; 387} 388 389sub protect 390{ 391 die "Prima::Header: Cannot change parameters during transaction\n" if $_[0]-> {transaction}; 392} 393 394sub autowidths 395{ 396 my ($self) = @_; 397 my @r = $self-> calc_autowidths; 398 $self-> {widths} = \@r; 399 $self-> recalc_maxwidth; 400 $self-> notify(q(SizeItems)); 401} 402 403sub calc_autowidths 404{ 405 my $self = $_[0]; 406 $self-> protect; 407 my $cx = $self-> {count}; 408 my $i; 409 $self-> begin_paint_info; 410 my ( $notifier, @notifyParms) = $self-> get_notify_sub(q(MeasureItem)); 411 my @r; 412 for ( $i = 0; $i < $cx; $i++) { 413 my $result = 0; 414 $notifier-> ( @notifyParms, $i, \$result); 415 $result = $self-> {minTabWidth} if $result < $self-> {minTabWidth}; 416 push @r, $result; 417 next unless $result; 418 } 419 $self-> end_paint_info; 420 return @r; 421} 422 423sub recalc_maxwidth 424{ 425 my $self = $_[0]; 426 my $mxw = 2; 427 for ( @{$self-> {widths}}) { 428 $mxw += $_ + 2 if $_; 429 } 430 $self-> {maxWidth} = $mxw; 431} 432 433sub offset 434{ 435 return $_[0]-> {offset} unless $#_; 436 my ( $self, $offset) = @_; 437 $offset = 0 if $offset < 0; 438 $offset = $self-> {maxWidth} - 5 if $offset >= $self-> {maxWidth} - 4; 439 return if $offset == $self-> {offset}; 440 $self-> {offset} = $offset; 441 $self-> reset_transaction if $self-> {transaction}; 442 $self-> repaint; 443} 444 445sub clickable 446{ 447 return $_[0]-> {clickable} unless $#_; 448 $_[0]-> {clickable} = $_[1]; 449} 450 451sub vertical 452{ 453 return $_[0]-> {vertical} unless $#_; 454 return if $_[0]-> {vertical} == $_[1]; 455 $_[0]-> protect; 456 $_[0]-> {vertical} = $_[1]; 457 $_[0]-> repaint; 458} 459 460sub scalable 461{ 462 return $_[0]-> {scalable} unless $#_; 463 $_[0]-> {scalable} = $_[1]; 464} 465 466sub dragable 467{ 468 return $_[0]-> {dragable} unless $#_; 469 $_[0]-> {dragable} = $_[1]; 470} 471 472sub minTabWidth 473{ 474 return $_[0]-> {minTabWidth} unless $#_; 475 my $changed = 0; 476 my $m = $_[1]; 477 $m = 0 if $m < 0; 478 $_[0]-> {minTabWidth} = $m; 479 for (@{$_[0]-> {widths}}) { 480 $_ = $m, $changed = 1 if $_ < $m; 481 } 482 $_[0]-> recalc_maxwidth; 483 $_[0]-> notify(q(SizeItems)) if $changed; 484} 485 486sub items 487{ 488 unless ( $#_) { 489 return wantarray ? @{$_[0]-> {items}} : [@{$_[0]-> {items}}]; 490 } 491 my ( $self, @items) = @_; 492 $self-> protect; 493 @items = @{$items[0]} if scalar(@items) == 1 && ref($items[0]) eq 'ARRAY'; 494 $self-> {items} = [@items]; 495 my $oc = $self-> {count}; 496 $self-> {count} = scalar @items; 497 if ( $oc > $self-> {count}) { 498 splice( @{$self-> {widths}}, $self-> {count}); 499 $self-> notify(q(SizeItems)); 500 } elsif ( $oc < $self-> {count}) { 501 push( @{$self-> {widths}}, (( $self-> {minTabWidth}) x ( $self-> {count} - $oc))); 502 $self-> notify(q(SizeItems)); 503 } 504 $self-> recalc_maxwidth; 505 $self-> offset( $self-> offset); 506 $self-> repaint; 507} 508 509sub widths 510{ 511 unless ( $#_) { 512 return wantarray ? @{$_[0]-> {widths}} : [@{$_[0]-> {widths}}]; 513 } 514 my ( $self, @widths) = @_; 515 $self-> protect; 516 @widths = @{$widths[0]} if scalar(@widths) == 1 && ref($widths[0]) eq 'ARRAY'; 517 $self-> {widths} = [@widths]; 518 if ( scalar @widths > $self-> {count}) { 519 splice( @{$self-> {widths}}, $self-> {count}); 520 } elsif ( scalar @widths < $self-> {count}) { 521 push( @{$self-> {widths}}, 522 (( $self-> {minTabWidth}) x ( $self-> {count} - scalar @widths))); 523 } 524 for ( @{$self-> {widths}}) { 525 $_ = $self-> {minTabWidth} if $_ < $self-> {minTabWidth}; 526 } 527 $self-> recalc_maxwidth; 528 $self-> offset( $self-> offset); 529 $self-> repaint; 530 $self-> notify(q(SizeItems)); 531} 532 533sub pressed 534{ 535 return $_[0]-> {pressed} unless $#_; 536 my ( $self, $pid) = @_; 537 $pid = -1 if $pid < 0 || $pid >= $self-> {count}; 538 return if $pid == $self-> {pressed}; 539 my $opid = $self-> {pressed}; 540 $self-> {pressed} = $pid; 541 if (( $opid < 0) || ( $pid < 0)) { 542 $self-> invalidate_rect( $self-> tab2rect( ( $pid < 0) ? $opid : $pid)); 543 } else { 544 $self-> repaint; 545 } 546} 547 5481; 549 550=head1 NAME 551 552Prima::Header - a multi-tabbed header widget. 553 554=head1 DESCRIPTION 555 556The widget class provides functionality of several button-like 557caption tabs, that can be moved and resized by the user. 558The class was implemented with a view to serve as a table header 559for list and grid widgets. 560 561=head1 API 562 563=head2 Events 564 565=over 566 567=item Click INDEX 568 569Called when the user clicks on the tab, positioned at INDEX. 570 571=item DrawItem CANVAS, INDEX, X1, Y1, X2, Y2, TEXT_BASELINE 572 573A callback used to draw the tabs. CANVAS is the output object; 574INDEX is the index of a tab. 575X1,Y2,X2,Y2 are the coordinates of the boundaries of the tab rectangle; 576TEXT_BASELINE is a pre-calculated vertical position for eventual 577centered text output. 578 579=item MeasureItem INDEX, RESULT 580 581Stores in scalar, referenced by RESULT, the width or height ( depending 582on L<vertical> property value ) of the tab in pixels. 583 584=item MoveItem OLD_INDEX, NEW_INDEX 585 586Called when the user moves a tab from its old location, specified by OLD_INDEX, 587to the NEW_INDEX position. By the time of call, all internal structures are 588updated. 589 590=item SizeItem INDEX, OLD_EXTENT, NEW_EXTENT 591 592Called when the user resizes a tab in INDEX position. OLD_EXTENT and NEW_EXTENT 593are either width or height of the tab, depending on L<vertical> property value. 594 595=item SizeItems 596 597Called when more than one tab has changed its extent. This might happen as a result 598of user action, as well as an effect of set-calling to some properties. 599 600=back 601 602=head2 Properties 603 604=over 605 606=item clickable BOOLEAN 607 608Selects if the user is allowed to click the tabs. 609 610Default value: 1 611 612=item dragable BOOLEAN 613 614Selects if the user is allowed to move of the tabs. 615 616Default value: 1 617 618=item items ARRAY 619 620Array of scalars, representing the internal data of the tabs. 621By default the scalars are treated as text strings. 622 623=item minTabWidth INTEGER 624 625A minimal extent in pixels a tab must occupy. 626 627Default value: 2 628 629=item offset INTEGER 630 631An offset on the major axis ( depends on L<vertical> property value ) 632that the widget is drawn with. Used for the conjunction with list widgets 633( see L<Prima::DetailedList> ), when the list is horizontally or 634vertically scrolled. 635 636Default value: 0 637 638=item pressed INTEGER 639 640Contains the index of the currently pressed tab. A -1 value is selected 641when no tabs are pressed. 642 643Default value: -1 644 645=item scalable BOOLEAN 646 647Selects if the user is allowed to resize the tabs. 648 649Default value: 1 650 651=item vertical BOOLEAN 652 653If 1, the tabs are aligned vertically; 654the L<offset>, L<widths> property and extent parameters of the callback 655notification assume heights of the tabs. 656 657If 0, the tabs are aligned horizontally, and the extent properties 658and parameters assume tab widths. 659 660=item widths ARRAY 661 662Array of integer values, corresponding to the extents of the tabs. 663The extents are widths ( C<vertical> is 0 ) or heights ( C<vertical> is 1 ). 664 665=back 666 667=head2 Methods 668 669=over 670 671=item tab2offset INDEX 672 673Returns offset of the INDEXth tab ( without regard to L<offset> property value ). 674 675=item tab2rect INDEX 676 677Returns four integers, representing the rectangle area, occupied by 678the INDEXth tab ( without regard to L<offset> property value ). 679 680=back 681 682=head1 AUTHOR 683 684Dmitry Karasik, E<lt>dmitry@karasik.eu.orgE<gt>. 685 686=head1 SEE ALSO 687 688L<Prima>, L<Prima::Widget>, L<Prima::DetailedList>, F<examples/sheet.pl>. 689 690=cut 691