File Coverage

blib/lib/Text/Tree.pm

Criterion	Covered	Total	%
statement	100	111	90.0
branch	25	32	78.1
condition	4	4	100.0
subroutine	12	13	92.3
pod	2	9	22.2
total	143	169	84.6

# Text::Tree - format a simple tree of strings into a textual tree graph

#----------------------------------------------------------------------------
#
# Copyright (C) 2003-2004 Ron Isaacson
# Portions Copyright (C) 2003 Mark Jason Dominus
# Portions Copyright (C) 2004 Ed Halley
#
#----------------------------------------------------------------------------

package Text::Tree;
use vars qw($VERSION);
$VERSION = 1.0;

=head1 NAME

Text::Tree - format a simple tree of strings into a textual tree graph

=head1 SYNOPSIS

    use Text::Tree;

    my $tree = new Text::Tree( "root",
                               [ "left\nnode" ],
			       [ "right", [ "1" ], [ "2" ] ] );
    print $tree->layout("boxed");

    __OUTPUT__

        +----+
        |root|
        +----+
      .---^---.
    +----+ +-----+
    |left| |right|
    |node| +-----+
    +----+  .-^-.
           +-+ +-+
           |1| |2|
           +-+ +-+

=cut

#----------------------------------------------------------------------------

use strict;
use warnings;

sub NBSP() { "\x01" }

=head1 METHODS

=head2 new()

    my $tree = new Text::Tree( "label",
                               [ "left child label", [ ... ] ],
			       [ "right child label", [ ... ] );

Create a new tree object from a nested set of array references.  The
first element of each array must be a string used as a node label.  The
remaining elements must each be an array reference for a child of the
node.  Labels may contain newlines to support multiple lines of text.

=cut

sub new
{
    my ($pack, $label, @subnodes) = @_;
    my @subobjects = map { $pack->new(@$_) } @subnodes;
    bless [ $label, @subobjects ] => $pack;
}

=head2 layout()

    my @lines = $tree->layout( "centered in boxes" );
    print @lines;

Lays out the tree into an array of newline-terminated strings, ready for
printing or displaying.  The optional style argument may contain various
keywords such as 'center', 'box', 'line', 'oval' and/or 'space'.  These
style keywords affect how the tree nodes are formatted.

=cut

sub layout
{
    my $tree = shift;
    my $style = shift || undef;
    my @lines = layout_tree($tree, $style);
    return map { s/\Q@{[NBSP]}/ /g; s/\s+$//; "$_\n" } @lines;
}

#----------------------------------------------------------------------------

# Support routines.

# Return the length of longest line in all arguments.  Assumes arguments
# are chomped and contain a single line of text.

sub longest
{
    return (sort { $b <=> $a } map { length } @_)[0];
}

# Ensure all lines match given width (or longest line if 0).
sub pad
{
    my $want = shift;
    $want = longest(@_) if not $want;
    my @lines = @_;
    for (@lines)
    {
	$_ .= ' ' x ($want-length($_))
	    if $want > length($_);
    }
    return @lines if wantarray;
    return $lines[0];
}

# Center and pad to the given width (or longest line if 0).
sub center
{
    my $want = shift;
    $want = longest(@_) if not $want;
    my @lines = @_;
    for (@lines)
    {
	$_ = ' ' x (($want-length($_))/2) . $_
	    if $want > length($_);
	$_ = pad($want, $_);
    }
    return @lines if wantarray;
    return $lines[0];
}

# Add box-border characters according to an 8-char style string.
# The characters are the four corners and four edges of the border.
sub border
{
    my $style = shift;
    my @style = split //, $style;
    my @lines = pad(0, @_);

    my $want = longest(@lines);
    for (@lines)
    {
	$_ = $style[5] . $_ . $style[7];
    }
    unshift(@lines, $style[0] . $style[4]x$want . $style[1]);
    push(@lines, $style[2] . $style[6]x$want . $style[3]);
    return @lines;
}

# Turn the single string label (which may have newlines) into a properly
# centered and/or padded array. The style argument may contain keywords
# to specify different aspects of the formatting.  All spaces in the
# label are turned into special NBSP characters during layout processing.

sub text
{
    my $self = shift;
    my $label = $self->[0];
    my $style = shift || '';

    # pad with spaces to width 5
    my @lines = split /\n/, $label;

    if ($style =~ /center/)
        { @lines = center(0, @lines); }
    else
        { @lines = pad(0, @lines); }

    @lines = border("        ", @lines) if $style =~ /space/;
    @lines = border('++++-|-|', @lines) if $style =~ /line|box/;
    @lines = border("..`'-|-|", @lines) if $style =~ /oval|round/;

    s/ /@{[NBSP]}/g for @lines;
    return \@lines;
}

# Return list of children trees.
sub children
{
    my $self = shift;
    my @children = @$self;

    # throw away the label
    shift @children;
    return @children;
}

# Lay out one subtree into a space-padded rectangle.
sub layout_tree
{
    my $tree = shift;
    my $style = shift;
    my @text = @{text($tree, $style)};
    my @children = children($tree);

    # recurse depth-first, left-right through $tree, returning a
    # downward view of the tree at each stop

    # if we're at a leaf node, then just return it; this is where the
    # recursion stops
    return @text unless @children;

    # build a picture of this node's children
    my @out = ();
    my $shift_len = 0;
    foreach my $child (@children)
    {
	if (@out)
	{
	    # find the length of the longest line seen so far (in the
	    # picture of this node's children), and pad all the lines seen
	    # so far to that length
	    my $pad_len = longest(@out);
	    @out = map { pad($pad_len, $_) } @out;

	    # get the downward picture from this child, and tack each line
	    # of that picture on to the right of the current picture
	    my @child = layout_tree($child, $style);
	    for (0 .. $#child)
	    {
		$out[$_] = ' ' x $shift_len if not $out[$_];
		$out[$_] .= ' ' . $child[$_];
	    }
	}
	else
	{
	    # this is the first child seen
	    @out = layout_tree($child, $style);
	}

	$shift_len += longest(@out);
    }

    # now we have the picture of all of this node's children, so we need
    # to add the text of the node itself to the top

    # we're going to want to center this node above the picture of its
    # children, but there may be additional padding on the left side if
    # any of those children have children of their own; so for the
    # purposes of centering, find the space occupied only by this node's
    # immediate children, and center the text over that

    my $blank = ($out[0] =~ /^( *)/)[0];
    my $len0 = length $out[0];
    my $center = $len0 - length($blank);

    if (@children == 1)
    {
	# if this node has only one child, then just center a "|" above it
	unshift (@out, pad($len0, $blank . center($center, "|")));
    }
    else
    {
	# if this node has multiple children, then we're not so lucky...
	# we're going to take the first line of the existing output,
	# duplicate it, and transform all of the cell borders into
	# connection points

	# start by stripping off any whitespace to the left, and holding
	# it for later
	my ($pad, $lines) = ($out[0] =~ /^( *)(.*)$/);

	# replace each block of non-whitespace (ie, a cell border) with a
	# ".", centered in the space where the border was
	$lines =~ s/(\S+)/center(length($1), ".")/ge;

	# this is going to make some additional whitespace on the left, so
	# strip that off too (and add it to what we've saved). any
	# remaining spaces are part of the connection lines, so turn them
	# into "-"'s.
	$pad .= $1 if ($lines =~ s/^( *)//);
	$lines =~ s/ *$//;
	$lines =~ s/ /-/g;

	# now we have a line that connects all of the children; figure out
	# where to attach it to its parent
	my $text0 = $blank . center($center, $text[-1]);
	$text0 =~ s/(\S+)/center(length($1), "x")/e;
	my $pos = index($text0, "x") - length($pad);

	# attach it with a reasonable character ("+" if directly over a
	# child's connection point, "^" otherwise)
	substr($lines, $pos, 1) =
	    (substr($lines, $pos, 1) eq '.' ? '+' : '^');

	# add this mess to the output
	unshift @out, pad($len0, $pad . $lines);
    }

    # now add this cell itself, properly positioned, to the output, and
    # we're done

    unshift(@out, $blank . center($center, $_)) for reverse @text;
    return @out;
}

#----------------------------------------------------------------------------

sub _test
{
    my $s = new Text::Tree( "5",
			    [ "4 1",
			      [ "3 1\n1",
				[ "2 1\n1 1 1", [ "1 1 1 1 1" ], ], ],
			      ] );
    my $t = Text::Tree->new( "5",
			     [ "4 1",
			       [ "3 1\n1",
				 [ "2 1\n1 1 1", [ "1 1 1 1 1" ], ], ],
			       [ "2 2 1", [ "1" ], $s ],
			       ],
			     [ "3 2\n1" ] );

    my $u = Text::Tree->new( "5",
			     [ "4 1",
			       [ "2 2 1", [ "1" ] ],
			       [ "3 1\n1",
				 [ "2 1\n1 1 1", [ "1 1 1 1 1" ], ], ],
			       ],
			     [ "3 2\n1" ] );
    my $v = Text::Tree->new( "0", $t, $u );
    print $v->layout();
    print $/;

    my $tree = new Text::Tree( "root node",
			       [ "left node\nfunny node\nnode" ],
			       [ "right node", [ "r 1" ], [ "r 2" ] ] );
    print $tree->layout("spaced and centered in ovals");
}

1;
__END__