package Tickit::Widget::Tree;
# ABSTRACT: Simple tree widget for Tickit
use strict;
use warnings;
use parent qw(Tickit::ContainerWidget);
use List::Util qw(sum);
use Scalar::Util qw(blessed);
use Tickit::Utils qw(substrwidth textwidth);
use Tickit::Widget::Static;
use utf8;
our $VERSION = '0.003';
=head1 NAME
Tickit::Widget::Tree - support for an expandable tree widget
=head1 VERSION
version 0.003
=head1 SYNOPSIS
my $tree = Tickit::Widget::Tree->new(
is_open => 1,
label => 'Root',
line_style => 'single',
);
$tree->add(Tickit::Widget::Tree->new(
is_open => 1,
label => 'First',
));
=head1 DESCRIPTION
Simple tree widget. See examples in main source for more info.
=cut
use constant CLEAR_BEFORE_RENDER => 0;
=head1 METHODS
=cut
=head2 new
Instantiate new tree.
Takes the following named parameters:
=over 4
=item * root - the root widget for this tree (optional)
=item * parent - the parent widget (optional)
=item * line_style - type of line used, see L</LINE STYLES> (optional, defaults to single)
=item * label - the text label to use for this tree entry
=back
=cut
sub new {
my $class = shift;
my %args = @_;
my $root = delete $args{root};
my $parent = delete $args{parent};
my $self = $class->SUPER::new(%args);
$self->{children} ||= [];
$self->{$_} = delete $args{$_} for grep exists $args{$_}, qw(label is_open prev next line_style label_widget);
$self->update_root_and_parent(
root => $root,
parent => $parent
);
$self->{pen_active} = delete $args{pen_active} || Tickit::Pen->new( fg => 2, bg => 4, b => 1 );
$self->{pen_label} = delete $args{pen_label} || Tickit::Pen->new( bg => 16, fg => 7 );
unless($self->{label_widget}) {
$self->{label_widget} = Tickit::Widget::Static->new(
text => defined($self->{label}) ? $self->{label} : ''
);
$self->{label_widget}->set_pen($self->pen_label);
}
if(my $children = delete $args{children}) {
$self->add(my $child = $class->new(%args, %$_) or die "failed to add child to $self") for @$children;
}
return $self;
}
=head2 label
Set or retrieve the label for this widget.
By default all nodes use a L<Tickit::Widget::Static> widget as a label,
see the L</label_widget> method for more control over this.
=cut
sub label {
my $self = shift;
if(@_) {
my $txt = shift;
$self->{label} = $txt;
$self->label_widget->set_text($txt) if exists $self->{label_widget};
$self->resized;
return $self;
}
return $self->{label};
}
=head2 label_widget
Set or retrieve the label widget for this node. Typically a L<Tickit::Widget::Static>,
this must accept a pen which will be used for displaying the currently-highlighted node.
=cut
sub label_widget {
my $self = shift;
if(@_) {
$self->{label_widget} = shift;
$self->{label_widget}->set_pen($self->pen_label);
$self->resized;
return $self;
}
return $self->{label_widget};
}
# Is this still accurate?
=head2 prev
The 'previous element' is determined as follows:
=over 4
=item * If we have a previous sibling:
=over 4
=item * If the previous sibling is open and has children, returns the last of those
=item * If the previous sibling is closed or empty, returns it (the previous sibling)
=back
=item * If we have a parent and no previous sibling(s):
=over 4
=item * Return the parent
=back
=item * Return ourselves
=back
=cut
sub prev {
my $self = shift;
if(my $prev = $self->prev_sibling) {
return $prev if $prev->is_closed;
my $c = $prev;
$c = $c->last_child while $c->has_children;
return $c;
}
return $self->tree_parent if $self->tree_parent;
return $self;
}
=head2 prev_sibling
Returns the previous sibling for this node. RO accessor.
=cut
sub prev_sibling { shift->{prev_sibling} }
=head2 next_sibling
Returns the next sibling for this node. RO accessor.
=cut
sub next_sibling { shift->{next_sibling} }
=head2 next
The 'next element' is determined as follows:
=over 4
=item * If we're open and have children, next is the first child element.
=item * If we're closed or empty, next is the next sibling at our current level.
=item * If there's no next sibling, call the parent's L</next> method.
=item * If there's no parent, return $self.
=back
=cut
sub next {
my $self = shift;
return $self->first_child if $self->is_open && $self->has_children;
return $self->_next_ignore_children(@_);
}
=head2 _next_ignore_children
Returns the next node, ignoring any children in the current node for the
purposes of the search.
=cut
sub _next_ignore_children {
my $self = shift;
my $ns = $self->next_sibling;
return $ns if $ns;
my $parent = $self->tree_parent or return $self;
my $suggested = $parent->_next_ignore_children(@_);
return $self if $suggested == $self->tree_parent;
return $suggested;
}
=head2 lines
Returns the number of lines used by this node. Will be the label height
unless the widget is open.
=cut
sub lines {
my $self = shift;
my $lines = $self->label_widget->lines;
return $lines unless $self->is_open;
$lines += sum 0, map +$_->lines, $self->children;
return $lines;
}
=head2 cols
Number of cols for autocalculation. We're flexible, so we just use the default 1.
=cut
sub cols { my $self = shift; textwidth($self->prefix_text) + $self->label_widget->cols; }
=head2 is_open
Returns true if this node is open, false if not.
If open state is undefined, then we inherit from the parent if we have one,
or return 0 as a fallback.
=cut
sub is_open {
my $self = shift;
return $self->{is_open} if defined $self->{is_open};
return $self->tree_parent->is_open if $self->tree_parent;
return 1;
}
=head2 is_closed
Returns true if we're closed, false if not.
=cut
sub is_closed { !(shift->is_open) }
=head2 window_lost
Callback to clear children and label when we lose our window.
=cut
sub window_lost {
my $self = shift;
$_->set_window(undef) for $self->label_widget, $self->children;
return $self;
}
=head2 window_gained
Callback to adjust our widgets when we get a window.
=cut
sub window_gained {
my $self = shift;
# Let parent set up focus
$self->SUPER::window_gained(@_);
my $win = $self->window;
$win->clear;
$self->_reshape_label($win);
$self->reapply_windows;
}
=head2 reshape
Callback to adjust the label window when our window is resized.
=cut
sub reshape {
my $self = shift;
$self->SUPER::reshape(@_);
my $win = $self->window;
$self->_reshape_label($win);
}
=head2 _reshape_label
Adjust our label window to fit the current window.
=cut
sub _reshape_label {
my $self = shift;
my $win = shift;
die $self->label_widget->lines unless $self->label_widget->lines > 0;
my $prefix = $self->style_map->{solo};
my $prefix_len = textwidth $prefix;
# TODO try change_geometry again
$self->label_widget->set_window($win->make_sub(0, $prefix_len + 1, $self->label_widget->lines, $win->cols - ($prefix_len + 1)));
return $self;
}
=head2 reapply_windows
Calculate windows for all widgets.
=cut
sub reapply_windows {
my $self = shift;
unless($self->is_open) {
$_->set_window(undef) for $self->children;
return $self->resized;
}
my $win = $self->window or return;
my $prefix_len = textwidth $self->prefix_text;
my $y = $self->label_widget->lines;
my @tasks;
CHILD:
for my $child ($self->children) {
my $height = $child->lines;
push @tasks, [ $child, ($child->window ? 'change' : 'create'),
$y,
$prefix_len,
$height,
$win->cols - $prefix_len
];
$y += $height;
}
foreach (@tasks) {
my ($child, $type, @args) = @$_;
# TODO make this work again
# if($type eq 'create') {
my $sub = $win->make_sub(@args);
$child->set_window($sub);
# } else {
# $child->window->change_geometry(@args);
# }
}
return $self->resized;
}
=head2 C<insert_after>
Adds $v after $self.
Takes over $self->next, including backlink from $self->next->prev.
=cut
sub insert_after {
my $self = shift;
my $v = shift;
$self->{next_sibling} = $v;
$v->{prev_sibling} = $self;
# Take a copy of the next in the chain
my $next = $self->{next};
# Insert our new entry after us
Scalar::Util::weaken($self->{next} = $v);
# Link them back to us
Scalar::Util::weaken($v->{prev} = $self);
# Set their next entry to our next entry
Scalar::Util::weaken($v->{next} = $next);
# Update backlink from next in chain back to the new value
Scalar::Util::weaken($next->{prev} = $v);
return $self;
}
=head2 add
Adds a child node after all other children.
=cut
sub add {
my $self = shift;
my $child = shift;
die "bad child" unless $child->isa(__PACKAGE__);
my $prev = $self->{children}[-1];
$prev->insert_after($child) if $prev;
# Add to queue
push @{$self->{children}}, $child;
# Try to send the on_add signal
$_->($child, $self) for grep defined, map $child->can($_), qw(on_add);
$self->resized;
$self;
}
=head2 children
Returns a list of all children.
=cut
sub children { @{ shift->{children} || [] } }
sub has_children { @{ shift->{children} || [] } ? 1 : 0 }
sub first_child { shift->{children}[0] }
sub last_child { shift->{children}[-1] }
sub pen_label { shift->{pen_label} }
sub pen_active { shift->{pen_active} }
=head2 is_highlighted
Returns true if this node is highlighted.
Note that the highlighted widget itself is tracked through
the root node, see L</highlighted> for more information.
=cut
sub is_highlighted { shift->{is_highlighted} }
=head2 prefix_text
Returns the appropriate line prefix text for the current style.
=cut
sub prefix_text {
my $self = shift;
return $self->style_map->{prefix};
}
=head2 style_map
Returns hashref which maps a component to the character string used to represent it.
=cut
sub style_map {
my $self = shift;
return {
ascii => {
prefix => '| ',
is_open => '[-]',
is_closed => '[+]',
solo => '- ',
open_parent => '-+ ',
item_prefix => '+',
item_last => '\\',
},
single => {
prefix => '│ ',
is_open => '[-]',
is_closed => '[+]',
solo => '─ ',
open_parent => '─┬ ',
item_prefix => '├',
item_last => '└',
},
double => {
prefix => '║ ',
is_open => '[-]',
is_closed => '[+]',
solo => '═ ',
open_parent => '═╦ ',
item_prefix => '╠',
item_last => '╚',
},
thick => {
prefix => '┃ ',
is_open => '[-]',
is_closed => '[+]',
solo => '━ ',
open_parent => '━┳ ',
item_prefix => '┣',
item_last => '┗',
},
}->{$self->line_style};
}
=head2 render
Tickit::Window
=cut
sub render {
my $self = shift;
return unless my $win = $self->window;
my %args = @_;
my $rect = $args{rect} || $win->rect;
my $style_map = $self->style_map;
my $y = $rect->top;
if($y < 1) {
my $txt = $style_map->{$self->next_sibling ? 'item_prefix' : 'item_last'};
if($self->children && $self->is_open) {
$txt .= $style_map->{open_parent};
} elsif($self->children) {
$txt .= $style_map->{'is_closed'};
} else {
$txt .= $style_map->{solo};
}
if($rect->left <= textwidth $txt) {
$win->goto($y, $rect->left);
$win->print($txt);
}
++$y;
}
LINE:
for ($y..$y+$rect->lines) {
last LINE unless $_ < $win->lines;
$win->goto($_, $rect->left);
my $x = 0;
$win->print($self->next_sibling ? $self->prefix_text : (' ' x textwidth($self->prefix_text))) if $rect->left <= textwidth($self->prefix_text);
$x += textwidth($self->prefix_text);
$win->erasech($rect->cols - $x, 1);
# if($self->is_open && $self->children) {
# $win->erasech($rect->cols - $x) unless $self->next_sibling;
# } else {
# $win->erasech($rect->cols - $x);
# }
}
}
=head2 highlighted
=cut
sub highlighted {
my $self = shift;
return $self->root->{highlighted} ||= $self->root;
}
=head2 highlight
=cut
sub highlight {
my $self = shift;
if(my $h = $self->highlighted) {
$h->_unhighlight;
$h->{is_highlighted} = 0;
}
$self->{is_highlighted} = 1;
$self->_highlight;
$self->root->{highlighted} = $self;
return $self;
}
sub _highlight {
my $self = shift;
return $self unless my $w = $self->label_widget;
$self->_set_pen_for_widget($w => 'active');
return $self;
}
sub _unhighlight {
my $self = shift;
return $self unless my $w = $self->label_widget;
$self->_set_pen_for_widget($w => 'label');
return $self;
}
sub _set_pen_for_widget {
my $self = shift;
my $w = shift or die "no widget supplied";
my $type = shift or die "no type supplied";
my $method = 'pen_' . $type;
$w->set_pen($self->$method);
# TODO This seems wrong, but somehow I couldn't convince Tickit::Widget to pick up the new pen
$w->window->set_pen($self->$method) if $w->window;
$w->resized;
return $self;
}
=head2 highlight_next
=cut
sub highlight_next {
my $self = shift;
my $next = $self->highlighted->next;
$next->highlight;
die "root variance? " . $next->root->label . ', ' . $self->root->label if $next->root != $self->root;
die "Highlight failed? " . join ', ', $next->label, $self->highlighted->label, $next->highlighted->label, $next->is_highlighted unless $next->label eq $self->highlighted->label;
die "Next does not match highlight: " . $next->tree_parent->label . ", " . $self->highlighted->tree_parent->label . ", $self" unless $next == $self->highlighted && $next eq $self->highlighted;
die "Next item (" . $next->label . ") is not highlighted" unless $next->is_highlighted;
die "Highlighted (" . $self->highlighted->label . ") is not highlighted, I am " . $self->label unless $self->highlighted->is_highlighted;
return $self;
}
=head2 highlight_prev
=cut
sub highlight_prev {
my $self = shift;
$self->highlighted->prev->highlight;
die "Highlighted (" . $self->highlighted->label . ") is not highlighted, I am " . $self->label unless $self->highlighted->{is_highlighted};
return $self;
}
=head2 rerender
=cut
sub rerender {
my $self = shift;
return unless $self->window;
$self->redraw;
}
=head2 root
=cut
sub root {
my $self = shift;
if(@_) {
$self->update_root_and_parent(
root => shift
);
return $self;
}
return $_ for grep $_, $self->{root}, $self->tree_parent && $self->tree_parent->root, $self;
}
=head2 tree_parent
=cut
sub tree_parent {
my $self = shift;
if(@_) {
$self->update_root_and_parent(
parent => shift
);
return $self;
}
return $self->{tree_parent};
}
=head2 update_root_and_parent
=cut
sub update_root_and_parent {
my $self = shift;
my %args = @_;
my $old_root = $self->root;
my $parent = delete $args{parent};
my $root = delete $args{root};
die "Parent does not match root" if $parent && $root && $parent->root != $root;
die "Wrong root" if $old_root && $root && $root != $old_root;
$root ||= $parent->root if $parent;
$parent ||= $root;
unless($root) {
$root = $self;
$self->{highlighted} = $self;
$args{prev} = $self;
$args{next} = $self;
}
$self->{tree_parent} = $parent;
return $self;
}
=head2 on_key
=cut
sub on_key {
my $self = shift;
my ($type, $str, $key) = @_;
if($type eq 'key' && $str eq 'Down') {
$self->highlight_next;
return 1;
} elsif($type eq 'key' && $str eq 'Up') {
$self->highlight_prev;
return 1;
} elsif($type eq 'text' && $str eq '+') {
$self->highlighted->open;
return 1;
} elsif($type eq 'text' && $str eq '-') {
$self->highlighted->close;
return 1;
} elsif($type eq 'text' && $str eq 'r') {
$self->root->rerender;
return 1;
}
return $self->_updated_on_key(@_);
return 0;
}
=head2 open
Open this node. Triggers a redraw.
=cut
sub open {
my $self = shift;
$self->{is_open} = 1;
$self->tree_parent->reapply_windows if $self->tree_parent;
$self->next_sibling->reapply_windows if $self->next_sibling;
$self->resized;
return $self;
}
=head2 close
Close this node. Triggers a redraw.
=cut
sub close {
my $self = shift;
$self->{is_open} = 0;
$self->next_sibling->reapply_windows if $self->next_sibling;
$self->tree_parent->reapply_windows if $self->tree_parent;
$self->resized;
return $self;
}
sub child_resized { }
sub bind_keys {
my $self = shift;
while(@_) {
my $str = shift;
my $value = shift;
if(defined $value) {
$self->{keybindings}{$str} = $value;
} else {
delete $self->{keybindings}{$str};
}
}
}
sub _updated_on_key {
my $self = shift;
my ($type, $str, $key) = @_;
# If we have something bound for this key, delegate to the defined handler
return $self->$_( $str, $key ) for map {
$_ eq 'CODE'
? $_->($str, $key)
: $_ eq 'ARRAY'
? @$_
: $_ eq 'HASH'
? values %$_
: $_
} grep defined, (
($type eq "key")
? ($self->{keybindings}{$str})
: ()
);
if($type eq "text") {
$_->($self, $str) for grep $_, $self->can('on_text');
return 1;
}
return 0;
}
=head2 on_add
Make sure everything has a consistent view of root and parent nodes
when adding a widget to a parent.
=cut
sub on_add {
my $self = shift;
my $parent = shift;
$self->update_root_and_parent(parent => $parent);
return $self;
}
=head2 line_style
Returns current line style. Inherits from parent, root or defaults to 'single'.
=cut
sub line_style {
my $self = shift;
if(@_) {
$self->{line_style} = shift;
return $self;
}
return $self->{line_style} if defined $self->{line_style};
return $self->tree_parent->line_style if $self->tree_parent;
return $self->root->line_style if $self->root && $self->root != $self;
# Fallback default
return 'single';
}
1;
__END__
=head1 SEE ALSO
=head1 AUTHOR
Tom Molesworth <cpan@entitymodel.com>
=head1 LICENSE
Copyright Tom Molesworth 2011. Licensed under the same terms as Perl itself.