File Coverage

blib/lib/Tickit/Widget/ScrollBox.pm
Criterion Covered Total %
statement 9 9 100.0
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 12 12 100.0


line stmt bran cond sub pod time code
1             # You may distribute under the terms of either the GNU General Public License
2             # or the Artistic License (the same terms as Perl itself)
3             #
4             # (C) Paul Evans, 2013-2014 -- leonerd@leonerd.org.uk
5              
6             package Tickit::Widget::ScrollBox;
7              
8 1     1   579 use strict;
  1         2  
  1         33  
9 1     1   5 use warnings;
  1         1  
  1         31  
10 1     1   10 use base qw( Tickit::SingleChildWidget );
  1         2  
  1         458  
11             Tickit::Window->VERSION( '0.39' ); # ->scroll_with_children
12             use Tickit::Style;
13              
14             our $VERSION = '0.05';
15              
16             use Carp;
17              
18             use List::Util qw( max );
19              
20             use Tickit::Widget::ScrollBox::Extent;
21             use Tickit::RenderBuffer qw( LINE_DOUBLE CAP_BOTH );
22              
23             =head1 NAME
24              
25             C - allow a single child widget to be scrolled
26              
27             =head1 SYNOPSIS
28              
29             use Tickit;
30             use Tickit::Widget::ScrollBox;
31             use Tickit::Widget::Static;
32              
33             my $scrollbox = Tickit::Widget::ScrollBox->new(
34             child => Tickit::Widget::Static->new(
35             text => join( "\n", map { "The content for line $_" } 1 .. 100 ),
36             ),
37             );
38              
39             Tickit->new( root => $scrollbox )->run;
40              
41             =head1 DESCRIPTION
42              
43             This container widget draws a scrollbar beside a single child widget and
44             allows a portion of it to be displayed by scrolling.
45              
46             =head1 STYLE
47              
48             Th following style pen prefixes are used:
49              
50             =over 4
51              
52             =item scrollbar => PEN
53              
54             The pen used to render the background of the scroll bar
55              
56             =item scrollmark => PEN
57              
58             The pen used to render the active scroll position in the scroll bar
59              
60             =item arrow => PEN
61              
62             The pen used to render the scrolling arrow buttons
63              
64             =back
65              
66             The following style keys are used:
67              
68             =over 4
69              
70             =item arrow_up => STRING
71              
72             =item arrow_down => STRING
73              
74             =item arrow_left => STRING
75              
76             =item arrow_right => STRING
77              
78             Each should be a single character to use for the scroll arrow buttons.
79              
80             =back
81              
82             The following style actions are used:
83              
84             =over 4
85              
86             =item up_1 ()
87              
88             =item down_1 ()
89              
90             =item left_1 ()
91              
92             =item right_1 ()
93              
94             Scroll by 1 line
95              
96             =item up_half ()
97              
98             =item down_half ()
99              
100             =item left_half ()
101              
102             =item right_half ()
103              
104             Scroll by half of the viewport
105              
106             =item to_top ()
107              
108             =item to_bottom ()
109              
110             =item to_leftmost ()
111              
112             =item to_rightmost ()
113              
114             Scroll to the edge of the area
115              
116             =back
117              
118             =cut
119              
120             style_definition base =>
121             scrollbar_fg => "blue",
122             scrollmark_bg => "blue",
123             arrow_rv => 1,
124             arrow_up => chr 0x25B4, # U+25B4 == Black up-pointing small triangle
125             arrow_down => chr 0x25BE, # U+25BE == Black down-pointing small triangle
126             arrow_left => chr 0x25C2, # U+25C2 == Black left-pointing small triangle
127             arrow_right => chr 0x25B8, # U+25B8 == Black right-pointing small triangle
128             '' => "up_1",
129             '' => "down_1",
130             '' => "left_1",
131             '' => "right_1",
132             '' => "up_half",
133             '' => "down_half",
134             '' => "left_half",
135             '' => "right_half",
136             '' => "to_top",
137             '' => "to_bottom",
138             '' => "to_leftmost",
139             '' => "to_rightmost",
140             ;
141              
142             use constant WIDGET_PEN_FROM_STYLE => 1;
143             use constant KEYPRESSES_FROM_STYLE => 1;
144              
145             =head1 CONSTRUCTOR
146              
147             =cut
148              
149             =head2 $scrollbox = Tickit::Widget::ScrollBox->new( %args )
150              
151             Constructs a new C object.
152              
153             Takes the following named arguments in addition to those taken by the base
154             L constructor:
155              
156             =over 8
157              
158             =item vertical => BOOL or "on_demand"
159              
160             =item horizontal => BOOL or "on_demand"
161              
162             Whether to apply a scrollbar in the vertical or horizontal directions. If not
163             given, these default to vertical only.
164              
165             If given as the string C then the scrollbar will be optionally be
166             displayed only if needed; if the space given to the widget is smaller than the
167             child content necessary to display.
168              
169             =back
170              
171             =cut
172              
173             sub new
174             {
175             my $class = shift;
176             my %args = @_;
177              
178             my $vertical = delete $args{vertical} // 1;
179             my $horizontal = delete $args{horizontal};
180              
181             my $child = delete $args{child};
182              
183             my $self = $class->SUPER::new( %args );
184              
185             $self->{vextent} = Tickit::Widget::ScrollBox::Extent->new( $self, "v" ) if $vertical;
186             $self->{hextent} = Tickit::Widget::ScrollBox::Extent->new( $self, "h" ) if $horizontal;
187              
188             $self->{v_on_demand} = $vertical ||'' eq "on_demand";
189             $self->{h_on_demand} = $horizontal||'' eq "on_demand";
190              
191             $self->add( $child ) if $child;
192              
193             return $self;
194             }
195              
196             =head1 ACCESSORS
197              
198             =cut
199              
200             sub lines
201             {
202             my $self = shift;
203             return $self->child->lines + ( $self->hextent ? 1 : 0 );
204             }
205              
206             sub cols
207             {
208             my $self = shift;
209             return $self->child->cols + ( $self->vextent ? 1 : 0 );
210             }
211              
212             =head2 $vextent = $scrollbox->vextent
213              
214             Returns the L object representing the box's
215             vertical scrolling extent.
216              
217             =cut
218              
219             sub vextent
220             {
221             my $self = shift;
222             return $self->{vextent};
223             }
224              
225             sub _v_visible
226             {
227             my $self = shift;
228             return 0 unless my $vextent = $self->{vextent};
229             return 1 unless $self->{v_on_demand};
230             return $vextent->limit > 0;
231             }
232              
233             =head2 $hextent = $scrollbox->hextent
234              
235             Returns the L object representing the box's
236             horizontal scrolling extent.
237              
238             =cut
239              
240             sub hextent
241             {
242             my $self = shift;
243             return $self->{hextent};
244             }
245              
246             sub _h_visible
247             {
248             my $self = shift;
249             return 0 unless my $hextent = $self->{hextent};
250             return 1 unless $self->{h_on_demand};
251             return $hextent->limit > 0;
252             }
253              
254             =head1 METHODS
255              
256             =cut
257              
258             sub children_changed
259             {
260             my $self = shift;
261             if( my $child = $self->child ) {
262             my $scrollable = $self->{child_is_scrollable} = $child->can( "CAN_SCROLL" ) && $child->CAN_SCROLL;
263              
264             if( $scrollable ) {
265             foreach my $method (qw( set_scrolling_extents scrolled )) {
266             $child->can( $method ) or croak "ScrollBox child cannot ->$method - do you implement it?";
267             }
268              
269             my $vextent = $self->vextent;
270             my $hextent = $self->hextent;
271              
272             $child->set_scrolling_extents( $vextent, $hextent );
273             defined $vextent->real_total or croak "ScrollBox child did not set vextent->total" if $vextent;
274             defined $hextent->real_total or croak "ScrollBox child did not set hextent->total" if $hextent;
275             }
276             }
277             $self->SUPER::children_changed;
278             }
279              
280             sub reshape
281             {
282             my $self = shift;
283              
284             my $window = $self->window or return;
285             my $child = $self->child or return;
286              
287             my $vextent = $self->vextent;
288             my $hextent = $self->hextent;
289              
290             if( !$self->{child_is_scrollable} ) {
291             $vextent->set_total( $child->lines ) if $vextent;
292             $hextent->set_total( $child->cols ) if $hextent;
293             }
294              
295             my $v_spare = ( $vextent ? $vextent->real_total : $window->lines-1 ) - $window->lines;
296             my $h_spare = ( $hextent ? $hextent->real_total : $window->cols-1 ) - $window->cols;
297              
298             # visibility of each bar might depend on the visibility of the other, if it
299             # it was exactly at limit
300             $v_spare++ if $v_spare == 0 and $h_spare > 0;
301             $h_spare++ if $h_spare == 0 and $v_spare > 0;
302              
303             my $v_visible = $vextent && ( !$self->{v_on_demand} || $v_spare > 0 );
304             my $h_visible = $hextent && ( !$self->{h_on_demand} || $h_spare > 0 );
305              
306             my @viewportgeom = ( 0, 0,
307             $window->lines - ( $h_visible ? 1 : 0 ),
308             $window->cols - ( $v_visible ? 1 : 0 ) );
309              
310             my $viewport;
311             if( $viewport = $self->{viewport} ) {
312             $viewport->change_geometry( @viewportgeom );
313             }
314             else {
315             $viewport = $window->make_sub( @viewportgeom );
316             $self->{viewport} = $viewport;
317             }
318              
319             $vextent->set_viewport( $viewport->lines ) if $vextent;
320             $hextent->set_viewport( $viewport->cols ) if $hextent;
321              
322             if( $self->{child_is_scrollable} ) {
323             $child->set_window( $viewport ) unless $child->window;
324             }
325             else {
326             my ( $childtop, $childlines ) =
327             $vextent ? ( -$vextent->start, $vextent->total )
328             : ( 0, max( $child->lines, $viewport->lines ) );
329              
330             my ( $childleft, $childcols ) =
331             $hextent ? ( -$hextent->start, $hextent->total )
332             : ( 0, max( $child->cols, $viewport->cols ) );
333              
334             my @childgeom = ( $childtop, $childleft, $childlines, $childcols );
335              
336             if( my $childwin = $child->window ) {
337             $childwin->change_geometry( @childgeom );
338             }
339             else {
340             $childwin = $viewport->make_sub( @childgeom );
341             $childwin->set_expose_after_scroll( 1 );
342             $child->set_window( $childwin );
343             }
344             }
345             }
346              
347             sub window_lost
348             {
349             my $self = shift;
350             $self->SUPER::window_lost( @_ );
351              
352             $self->{viewport}->close if $self->{viewport};
353              
354             undef $self->{viewport};
355             }
356              
357             =head2 $scrollbox->scroll( $downward, $rightward )
358              
359             Requests the content be scrolled downward a number of lines and rightward a
360             number of columns (either of which which may be negative).
361              
362             =cut
363              
364             sub scroll
365             {
366             my $self = shift;
367             my ( $downward, $rightward ) = @_;
368             $self->vextent->scroll( $downward ) if $self->vextent and defined $downward;
369             $self->hextent->scroll( $rightward ) if $self->hextent and defined $rightward;
370             }
371              
372             =head2 $scrollbox->scroll_to( $top, $left )
373              
374             Requests the content be scrolled such that the given line and column number of
375             the child's content is the topmost visible in the container.
376              
377             =cut
378              
379             sub scroll_to
380             {
381             my $self = shift;
382             my ( $top, $left ) = @_;
383             $self->vextent->scroll_to( $top ) if $self->vextent and defined $top;
384             $self->hextent->scroll_to( $left ) if $self->hextent and defined $left;
385             }
386              
387             sub _extent_scrolled
388             {
389             my $self = shift;
390             my ( $id, $delta, $value ) = @_;
391              
392             my $vextent = $self->vextent;
393             my $hextent = $self->hextent;
394              
395             if( my $win = $self->window ) {
396             if( $id eq "v" ) {
397             $win->expose( Tickit::Rect->new(
398             top => 0, lines => $win->lines,
399             left => $win->cols - 1, cols => 1,
400             ) );
401             }
402             elsif( $id eq "h" ) {
403             $win->expose( Tickit::Rect->new(
404             top => $win->lines - 1, lines => 1,
405             left => 0, cols => $win->cols,
406             ) );
407             }
408             }
409              
410             # Extents use $delta = 0 to just request a redraw e.g. on change of total
411             return if $delta == 0;
412              
413             my $child = $self->child or return;
414              
415             my ( $downward, $rightward ) = ( 0, 0 );
416             if( $id eq "v" ) {
417             $downward = $delta;
418             }
419             elsif( $id eq "h" ) {
420             $rightward = $delta;
421             }
422              
423             if( $self->{child_is_scrollable} ) {
424             $child->scrolled( $downward, $rightward, $id );
425             }
426             else {
427             my $childwin = $child->window or return;
428              
429             $childwin->reposition( $vextent ? -$vextent->start : 0,
430             $hextent ? -$hextent->start : 0 );
431              
432             my $viewport = $self->{viewport};
433             $viewport->scroll_with_children( $downward, $rightward );
434             }
435             }
436              
437             sub render_to_rb
438             {
439             my $self = shift;
440             my ( $rb, $rect ) = @_;
441             my $win = $self->window or return;
442              
443             my $lines = $win->lines;
444             my $cols = $win->cols;
445              
446             my $scrollbar_pen = $self->get_style_pen( "scrollbar" );
447             my $scrollmark_pen = $self->get_style_pen( "scrollmark" );
448             my $arrow_pen = $self->get_style_pen( "arrow" );
449              
450             my $v_visible = $self->_v_visible;
451             my $h_visible = $self->_h_visible;
452              
453             if( $v_visible and $rect->right == $cols ) {
454             my $vextent = $self->vextent;
455             my ( $bar_top, $mark_top, $mark_bottom, $bar_bottom ) =
456             $vextent->scrollbar_geom( 1, $lines - 2 - ( $h_visible ? 1 : 0 ) );
457             my $start = $vextent->start;
458              
459             $rb->text_at ( 0, $cols-1,
460             $start > 0 ? $self->get_style_values( "arrow_up" ) : " ", $arrow_pen );
461             $rb->vline_at( $bar_top, $mark_top-1, $cols-1, LINE_DOUBLE, $scrollbar_pen, CAP_BOTH ) if $mark_top > $bar_top;
462             $rb->erase_at( $_, $cols-1, 1, $scrollmark_pen ) for $mark_top .. $mark_bottom-1;
463             $rb->vline_at( $mark_bottom, $bar_bottom-1, $cols-1, LINE_DOUBLE, $scrollbar_pen, CAP_BOTH ) if $bar_bottom > $mark_bottom;
464             $rb->text_at ( $bar_bottom, $cols-1,
465             $start < $vextent->limit ? $self->get_style_values( "arrow_down" ) : " ", $arrow_pen );
466             }
467              
468             if( $h_visible and $rect->bottom == $lines ) {
469             my $hextent = $self->hextent;
470              
471             my ( $bar_left, $mark_left, $mark_right, $bar_right ) =
472             $hextent->scrollbar_geom( 1, $cols - 2 - ( $v_visible ? 1 : 0 ) );
473             my $start = $hextent->start;
474              
475             $rb->goto( $lines-1, 0 );
476              
477             $rb->text_at( $lines-1, 0,
478             $start > 0 ? $self->get_style_values( "arrow_left" ) : " ", $arrow_pen );
479             $rb->hline_at( $lines-1, $bar_left, $mark_left-1, LINE_DOUBLE, $scrollbar_pen, CAP_BOTH ) if $mark_left > $bar_left;
480             $rb->erase_at( $lines-1, $mark_left, $mark_right - $mark_left, $scrollmark_pen );
481             $rb->hline_at( $lines-1, $mark_right, $bar_right-1, LINE_DOUBLE, $scrollbar_pen, CAP_BOTH ) if $bar_right > $mark_right;
482             $rb->text_at( $lines-1, $bar_right,
483             $start < $hextent->limit ? $self->get_style_values( "arrow_right" ) : " ", $arrow_pen );
484              
485             $rb->erase_at( $lines-1, $cols-1, 1 ) if $v_visible;
486             }
487             }
488              
489             sub key_up_1 { my $vextent = shift->vextent or return; $vextent->scroll( -1 ); 1 }
490             sub key_down_1 { my $vextent = shift->vextent or return; $vextent->scroll( +1 ); 1 }
491             sub key_left_1 { my $hextent = shift->hextent or return; $hextent->scroll( -1 ); 1 }
492             sub key_right_1 { my $hextent = shift->hextent or return; $hextent->scroll( +1 ); 1 }
493              
494             sub key_up_half { my $vextent = shift->vextent or return; $vextent->scroll( -int( $vextent->viewport / 2 ) ); 1 }
495             sub key_down_half { my $vextent = shift->vextent or return; $vextent->scroll( +int( $vextent->viewport / 2 ) ); 1 }
496             sub key_left_half { my $hextent = shift->hextent or return; $hextent->scroll( -int( $hextent->viewport / 2 ) ); 1 }
497             sub key_right_half { my $hextent = shift->hextent or return; $hextent->scroll( +int( $hextent->viewport / 2 ) ); 1 }
498              
499             sub key_to_top { my $vextent = shift->vextent or return; $vextent->scroll_to( 0 ); 1 }
500             sub key_to_bottom { my $vextent = shift->vextent or return; $vextent->scroll_to( $vextent->limit ); 1 }
501             sub key_to_leftmost { my $hextent = shift->hextent or return; $hextent->scroll_to( 0 ); 1 }
502             sub key_to_rightmost { my $hextent = shift->hextent or return; $hextent->scroll_to( $hextent->limit ); 1 }
503              
504             sub on_mouse
505             {
506             my $self = shift;
507             my ( $args ) = @_;
508              
509             my $type = $args->type;
510             my $button = $args->button;
511              
512             my $lines = $self->window->lines;
513             my $cols = $self->window->cols;
514              
515             my $vextent = $self->vextent;
516             my $hextent = $self->hextent;
517              
518             my $vlen = $lines - 2 - ( $self->_h_visible ? 1 : 0 );
519             my $hlen = $cols - 2 - ( $self->_v_visible ? 1 : 0 );
520              
521             if( $type eq "press" and $button == 1 ) {
522             if( $vextent and $args->col == $cols-1 ) {
523             # Click in vertical scrollbar
524             my ( undef, $mark_top, $mark_bottom, $bar_bottom ) = $vextent->scrollbar_geom( 1, $vlen );
525             my $line = $args->line;
526              
527             if( $line == 0 ) { # up arrow
528             $vextent->scroll( -1 );
529             }
530             elsif( $line < $mark_top ) { # above area
531             $vextent->scroll( -int( $vextent->viewport / 2 ) );
532             }
533             elsif( $line < $mark_bottom ) {
534             # press in mark - ignore for now - TODO: prelight?
535             }
536             elsif( $line < $bar_bottom ) { # below area
537             $vextent->scroll( +int( $vextent->viewport / 2 ) );
538             }
539             elsif( $line == $bar_bottom ) { # down arrow
540             $vextent->scroll( +1 );
541             }
542             return 1;
543             }
544             if( $hextent and $args->line == $lines-1 ) {
545             # Click in horizontal scrollbar
546             my ( undef, $mark_left, $mark_right, $bar_right ) = $hextent->scrollbar_geom( 1, $hlen );
547             my $col = $args->col;
548              
549             if( $col == 0 ) { # left arrow
550             $hextent->scroll( -1 );
551             }
552             elsif( $col < $mark_left ) { # above area
553             $hextent->scroll( -int( $hextent->viewport / 2 ) );
554             }
555             elsif( $col < $mark_right ) {
556             # press in mark - ignore for now - TODO: prelight
557             }
558             elsif( $col < $bar_right ) { # below area
559             $hextent->scroll( +int( $hextent->viewport / 2 ) );
560             }
561             elsif( $col == $bar_right ) { # right arrow
562             $hextent->scroll( +1 );
563             }
564             return 1;
565             }
566             }
567             elsif( $type eq "drag_start" and $button == 1 ) {
568             if( $vextent and $args->col == $cols-1 ) {
569             # Drag in vertical scrollbar
570             my ( undef, $mark_top, $mark_bottom ) = $vextent->scrollbar_geom( 1, $vlen );
571             my $line = $args->line;
572              
573             if( $line >= $mark_top and $line < $mark_bottom ) {
574             $self->{drag_offset} = $line - $mark_top;
575             $self->{drag_bar} = "v";
576             return 1;
577             }
578             }
579             if( $hextent and $args->line == $lines-1 ) {
580             # Drag in horizontal scrollbar
581             my ( undef, $mark_left, $mark_right ) = $hextent->scrollbar_geom( 1, $hlen );
582             my $col = $args->col;
583              
584             if( $col >= $mark_left and $col < $mark_right ) {
585             $self->{drag_offset} = $col - $mark_left;
586             $self->{drag_bar} = "h";
587             return 1;
588             }
589             }
590             }
591             elsif( $type eq "drag" and $button == 1 and defined( $self->{drag_offset} ) ) {
592             if( $self->{drag_bar} eq "v" ) {
593             my $want_bar_top = $args->line - $self->{drag_offset} - 1;
594             my $want_top = int( $want_bar_top * $vextent->total / $vlen + 0.5 );
595             $vextent->scroll_to( $want_top );
596             }
597             if( $self->{drag_bar} eq "h" ) {
598             my $want_bar_left = $args->col - $self->{drag_offset} - 1;
599             my $want_left = int( $want_bar_left * $hextent->total / $hlen + 0.5 );
600             $hextent->scroll_to( $want_left );
601             }
602             }
603             elsif( $type eq "drag_stop" ) {
604             undef $self->{drag_offset};
605             }
606             elsif( $type eq "wheel" ) {
607             # Alt-wheel for horizontal
608             my $extent = $args->mod & 2 ? $self->hextent : $self->vextent;
609             $extent->scroll( -5 ) if $extent and $button eq "up";
610             $extent->scroll( +5 ) if $extent and $button eq "down";
611             return 1;
612             }
613             }
614              
615             =head1 SMART SCROLLING
616              
617             If the child widget declares it supports smart scrolling, then the ScrollBox
618             will not implement content scrolling on its behalf. Extra methods are used to
619             co-ordinate the scroll position between the scrolling-aware child widget and
620             the containing ScrollBox. This is handled by the following methods on the
621             child widget.
622              
623             If smart scrolling is enabled for the child, then its window will be set to
624             the viewport directly, and the child widget must offset its content within the
625             window as appropriate. The child must indicate the range of its scrolling
626             ability by using the C method on the extent object it is given.
627              
628             =head2 $smart = $child->CAN_SCROLL
629              
630             If this method exists and returns a true value, the ScrollBox will use smart
631             scrolling. This method must return a true value for this to work, allowing the
632             method to itself be a proxy, for example, to proxy scrolling information
633             through a single child widget container.
634              
635             =head2 $child->set_scrolling_extents( $vextent, $hextent )
636              
637             Gives the child widget the vertical and horizontal scrolling extents. The
638             child widget should save thes values, and inspect the C value of them
639             any time it needs these to implement content offset position when
640             rendering.
641              
642             =head2 $child->scrolled( $downward, $rightward, $h_or_v )
643              
644             Informs the child widget that one of the scroll positions has changed. It
645             passes the delta (which may be negative) of each position, and a string which
646             will be either C<"h"> or C<"v"> to indicate whether it was an adjustment of
647             the horizontal or vertical scrollbar. The extent objects will already have
648             been updated by this point, so the child may also inspect the C value
649             of them to obtain the new absolute offsets.
650              
651             =cut
652              
653             =head1 TODO
654              
655             =over 4
656              
657             =item *
658              
659             Choice of left/right and top/bottom bar positions.
660              
661             =item *
662              
663             Click-and-hold on arrow buttons for auto-repeat
664              
665             =item *
666              
667             Allow smarter cooperation with a scrolling-aware child widget; likely by
668             setting extent objects on the child if it declares to be supported, and use
669             that instead of an offset child window.
670              
671             =back
672              
673             =cut
674              
675             =head1 AUTHOR
676              
677             Paul Evans
678              
679             =cut
680              
681             0x55AA;