view release on metacpan or  search on metacpan

lib/HTML/TreeStructured.pm  view on Meta::CPAN

package HTML::TreeStructured;
use 5.006;
use strict;
use warnings;

use Carp qw(croak);
use HTML::Template 2.6;

=head1 NAME

HTML::TreeStructured - Perl extension for generating tree structured HTML

=head1 SYNOPSIS

	use HTML::TreeStructured;

	### Describe tree via collection of Node and its properties

	### Method 1: Via ArrayRef
	###
	### Node can be a string or '/' concatenated strings to show ancestry
	### Properties are name/value pairs

	my $tree1 = [
		['/aaa', 	color => 'green'],
		['/aaa/bbb'	mouseover => 'This is addl info'],
		['/aaa/ccc',	color => 'red', active => 0]
	];

	### Method 2: Via Hashref

	my $tree2 = {
		aaa => {
			color => 'green',
			bbb   => {
				mouseover => 'This is addl info',
			},
			ccc   => {
				color	=> 'red',
				active	=> 0,
			},
	};

	Interpreted Node Properties:

	color		= Color of the node name
	mouseover	= Mouse Over text for the node (Info image is displayed next to node)
	active		= 0 would cause strike thru on node
	highlight	= color code used for marker highlight of node
	url		= URL to hyperlink the node
	tooltip		= popup when mouse is over the link (together with url) (See HTML::Tooltip::Javascript)
	closed		= 1 if node be closed on default display (default, all nodes are open)
	comment		= Text to display next to node in bold
	weight		= A numeric value on node which will be used for sorting node position in at sibling level
			  (Default, nodes are sorted in ascending order per dictionary order)


	### Now get HTML equivalent for the tree
	### The associated JavaScript for nodes close/open and ExpandAll/CollapseAll is generated alongside

	$tree_html = HTML::TreeStructured->new(
		name         => 'tree_name',
		image_path   => '/images/',
		data         => $tree1,
		title        => "My Tree",
		title_width  => 300,
		level        => {},     ### If scalar, close BEYOND this depth. Depth start at 0.
					### If Hash, close for depths specified in keys
	)->output;

	### The same module can be used to generate FAQ - see "examples/faq.cgi"

=cut

our $VERSION = "1.01";

sub new 
{
    my $pkg = shift;
    
    # setup defaults and get parameters
    my $self = bless({ 

			title_width	=> 300,
			child_indent	=> 20,
			image_path	=> ".",
			level	     => {},	### Default open up the full tree - This would contain 
		       				### Scalar => depth BEYOND which nodes are closed for tree display
		       				### Hash   => depths matching keys are closed for tree display
						### NB: Depth starts at ZERO
						### E.g. Value of
						### level=2 means Tree nodes are closed at depth 3 and more (all others are open)
						### level={2=>1} means Tree node at depth 2 are closed (all others are open)
                       @_,
                     }, $pkg);
    
    # fix up image_path to always end in a /
    $self->{image_path} .= "/" unless $self->{image_path} =~ m!/$!;

    # check required params
    foreach my $req (qw(name data title)) {
        croak("Missing required parameter '$req'") unless exists $self->{$req};
    }

    if (ref($self->{data}) eq 'ARRAY') {
    	$self->{data} = process_arrayref($self->{data});
    } else {
	my $res;
    	my $data = $self->{data};
	my @kkk = grep { ref($data->{$_}) eq 'HASH' } keys %$data;
	if (1 == @kkk) {
		$res = process_hashref($kkk[0], $data->{$kkk[0]});
	} else {
		$res = process_hashref('ROOT', $data);
	}
	$self->{data} = $res;
    }

    #use Data::Dumper;
    #print '<pre>', Dumper($self->{data}), '</pre>';

    return $self;
}

sub output 
{
    my $self = shift;
    our $TEMPLATE_SRC;
    my $template = HTML::Template->new(scalarref          => \$TEMPLATE_SRC,
                                       die_on_bad_params => 0,
                                       global_vars       => 1,
                                      );

    # build node loop
    my @loop;
    $self->_output_node(node   => $self->{data},
                        loop   => \@loop,
			depth  => 1,
			level  => $self->{level},
                       );
    my @parents;			### Collect all nodes with children - for use in ExpandAll/CollapseAll
    map { push(@parents, {id => $_->{id}}) if ($_->{has_children}) } @loop;
    # setup template parameters
    $template->param(loop => \@loop);
    $template->param(parents => \@parents);
    $template->param(map { ($_, $self->{$_}) } qw(name title title_width child_indent image_path));
    # get output for the widget
    my $output = $template->output;

    return $output;
}

# recursively add nodes to the output loop
sub _output_node 
{
    my ($self, %arg) = @_;
    my $node = $arg{node};
    my $depth = $arg{depth};
    my $level = $arg{level};

    #use Data::Dumper;
    #print "<pre>", Dumper($node), "</pre>";

    my $id = next_id();
    push @{$arg{loop}}, { label       => $node->{label},		### Label to appear in tree
                          value       => $node->{value},		### Hidden Value (whats the use?, but good to have)
                          id          => $id,				### Unique Id (no immediate use, but good to have)
                          open        => display_closed_node($depth, $level, $node->{closed}) ? 0 : 1,	
			  						### During Display, whether to close/open
			  url	      => $node->{url},			### Url to link 
			  mouseover   => $node->{mouseover},		### mouseover message
			  tooltip     => $node->{tooltip},		### Tooltip popup box (See HTML::Tooltip::Javascript)
			  active      => ((defined($node->{active}) and $node->{active} == 0) ? 0 : 1),	
			  						### Is this node active? If not, strike thru during display
			  color       => $node->{color} || 'black',	### Color of the label
			  highlight   => $node->{highlight},		### Color to use for marker highlight
			  comment     => $node->{comment},		### Comment in bold within parentheses next to label
                        };
    
    if ($node->{children} and @{$node->{children}}) {
        $arg{loop}[-1]{has_children} = 1;
        for my $child (@{$node->{children}}) {
            $self->_output_node(node   => $child,
                                loop   => $arg{loop},
				depth  => $depth + 1,
				level  => $level,
                               );
        }
        push @{$arg{loop}}, { end_block => 1 };
    }
    
}

sub display_closed_node
{
	my $ddd = shift; # Depth Info
	my $lll = shift; # Level Info 
			 # scalar ==> Close all nodes BEYOND this depth
			 # hash   ==> Close all nodes for specified keys
	my $closed = shift;

	if (defined($closed)) {
		return $closed;
	}

	if (ref($lll) eq 'HASH') {
		return ($lll->{$ddd} ? 1 : 0);
	} else {
		return ($ddd > $lll ? 1 : 0);
	}
}

{ 
    my $id = 1;
    sub next_id { $id++ }
}

our $TEMPLATE_SRC = <<END;
<style type="text/css">
<!--

  /* title bar style.  The width here will define a minimum width for
     the widget. */
  .hpts-title {
     padding:          2px;
     margin-bottom:    4px;     
     font-size:        large;
     color:            #ffffff;
     background-color: #666666;
     width:            <tmpl_var title_width>px;
  }