File Coverage

blib/lib/HTML/ListToTree.pm

Criterion	Covered	Total	%
statement	183	202	90.5
branch	57	94	60.6
condition	39	62	62.9
subroutine	29	30	96.6
pod	19	20	95.0
total	327	408	80.1

=pod

=begin classdoc

Converts an HTML nested list document to a Javascripted
tree widget.

Copyright© 2007, Dean Arnold, Presicient Corp., USA. All rights reserved.

Excluding the dtree widget software and components included in the
L package, permission is granted to use this software
under the same terms as Perl itself. Refer to the L for details.

@author Dean Arnold
@since 2007-Jun-10
@self $self

=end classdoc

=cut

package HTML::ListToTree;

use HTML::TreeBuilder;
use HTML::ListToTree::DTree;

use strict;
use warnings;

our $VERSION = '0.10';

our %tags_accepted = qw(a 1 li 1 ul 1 ol 1 /a 1 /li 1 /ul 1 /ol 1);
#
#	have to use class variable for unlink action, due to
#	recursive structure
#
our %unlinks = ( 'include' => 1, 'warn' => 1, 'ignore' => 1 );
our $onUnlink;

=pod

=begin classdoc

Create an HTML::ListToTree object with specified text label and link url,
optionally setting an initial set of child nodes and/or extracting
children from a source document.

@constructor
@param Text		a text label for the node
@param Link		a link URL for the node.
@optional Children	an arrayref of HTML::ListToTree objects
@optional Source	a document from which to collect child nodes
@optional Widget	either a Perl object, or the name of a Perl package, providing browser widget construction methods;
	default 'HTML::ListToTree::DTree'
@optional UnlinkedLeaves	string specifying disposition of unlinked leaf nodes; valid values are

					include (the default) - include in three
					warn - emit warning, but include in tree
					ignore - don't include, and don't warn


@return	an HTML::ListToTree object

=end classdoc

=cut

sub new {
	my $class = shift;
	my %args = @_;

	$args{Children} ||= [];
	my $widget;
	if ($args{Widget}) {
		if (ref $args{Widget}) {
			$widget = $args{Widget};
		}
		else {
			eval "
				require $args{Widget};
				\$widget = $args{Widget}->new();
			";
			return undef if $@;
		}
	}
	else {
		$widget = HTML::ListToTree::DTree->new();
	}
#
#	if an unlink action is specified, update it
#
	$onUnlink = $unlinks{lc $args{UnlinkedLeaves}} ? lc $args{UnlinkedLeaves} : 'include'
		if exists $args{UnlinkedLeaves};

	$onUnlink ||= 'include';
	my $self = bless {
		_text => $args{Text},
		_link => $args{Link},
		_children => $args{Children},
		_widget => $widget,
	}, $class;

	push @{$self->{_children}}, $self->extractTree($args{Source})
		if exists $args{Source};

	return $self;
}

=pod

=begin classdoc

Add a set of sibling nodes to the tree as a child of this node.
The nodes are appended to any existing list of immediate children
of this node.

@param @nodes 		a list of nodes. Nodes are specified as either 2-tuples of
					Text => Link, or as an HTML::ListToTree object

@returnlist HTML::ListToTree objects added as children of this object

=end classdoc

=cut

sub addChildren {
	my $self = shift;
	my ($text, $link);
	my @nodes = ();
	my @args = (ref $_[0] eq 'ARRAY') ? @{$_[0]} : @_;
	push(@{$self->{_children}},
		ref $args[0] ? shift @args : HTML::ListToTree->new(Text => shift @args, Link => shift @args)),
	push(@nodes, $self->{_children}[-1])
		while (@args);
	return @nodes;
}

=pod

=begin classdoc

Extract a tree from a nested lists of the input document, and
add it as a child of this node.

@param $html 		the source HTML document

@returnlist HTML::ListToTree objects extracted from the document

=end classdoc

=cut

sub addFromDocument {
	my ($self, $html) = @_;
	my @nodes = $self->extractTree($html);
	push @{$self->{_children}}, @nodes;
	return @nodes;
}

=pod

=begin classdoc

Return the child nodes of this node as a list.
The list is in the order in which the nodes were added
to this node.

@returnlist the child nodes aHTML::ListToTree objects

=end classdoc

=cut

sub getChildren {
	my $self = shift;

	return @{$self->{_children}};
}

=pod

=begin classdoc

Scans this node's children to locate a node with the specified text label.
The scan is breadth first (i.e., siblings are scanned before children).

@return	if a match is found, an HTML::ListToTree object; otherwise, undef.

=end classdoc

=cut

sub getNodeByText {
	my ($self, $text) = @_;

	foreach (@{$self->{_children}}) {
		return $_
			if ($_->{_text} eq $text);
	}
	foreach (@{$self->{_children}}) {
		my $node = $_->getNodeByText($text);
		return $node if $node;
	}
	return undef;
}

=pod

=begin classdoc

Scans this node's children to locate a node with the specified URL link.
The scan is breadth first (i.e., siblings are scanned before children).

@return	if a match is found, an HTML::ListToTree object; otherwise, undef.

=end classdoc

=cut

sub getNodeByLink {
	my ($self, $link) = @_;

	my $offset = -1 * length($link);
	foreach (@{$self->{_children}}) {
		return $_
			if (substr($_->{_link}, $offset) eq $link);
	}
	foreach (@{$self->{_children}}) {
		my $node = $_->getNodeByLink($link);
		return $node if $node;
	}
	return undef;
}

=pod

=begin classdoc

Return the text label of this node.

@return	the text label of this node

=end classdoc

=cut

sub getText {
	return $_[0]->{_text};
}

=pod

=begin classdoc

Set the text label of this node.

@param $text	the text label to set

@return	this node

=end classdoc

=cut

sub setText {
	$_[0]->{_text} = $_[1];
	return $_[0];
}

=pod

=begin classdoc

Return the link URL of this node.

@return	the link URL of this node

=end classdoc

=cut

sub getLink {
	return $_[0]->{_link};
}

=pod

=begin classdoc

Set the link URL of this node.

@param $link	the link URL to set

@return	this node

=end classdoc

=cut

sub setLink {
	$_[0]->{_link} = $_[1];
	return $_[0];
}

=pod

=begin classdoc

Render this HTML::ListToTree object into an HTML document containing Javascript
required for dtree, and suitable for use as a frame
within a frameset. Subclasses may override this method to provide
alternate renderings of the tree.

@constructor
@optional Additions HTML text to be appended to the generated tree
@optional BasePath  the base directory path for all local hyperlinks
@optional CloseIcon name of icon used for closed tree nodes; default 'closedbook.gif'
@optional CSSPath path to the stylesheet file dtree.css used by dtree; default './css'
@optional IconPath path to the location of icons used by dtree; default './img'
@optional JSPath path to the Javascript file dtree.js; default '.js'
@optional UseIcons when set to a true value, tree nodes are decorated with icons; default true
@optional OpenIcon name of icon used for open tree nodes; default 'openbook.gif'
@optional RootIcon name of icon used for the root tree node; default is same as OpenIcon
@optional Target the name of an HTML frame to contain the document being navigated; default 'mainframe'

@return	an HTML document

=end classdoc

=cut

sub render {
	my $self = shift;
	my %args = @_;

	$args{CloseIcon} ||= 'closedbook.gif';
	$args{OpenIcon} ||= 'openbook.gif';
	$args{IconPath} ||= './img';
	$args{CSSPath} ||= './css/dtree.css';
	$args{JSPath} ||= './js/dtree.js';
	$args{RootIcon} ||= $args{OpenIcon};
	$args{Target} ||= 'mainframe';
	$args{Additions} ||= '';

	$args{UseIcons} = 1 unless exists $args{UseIcons};

	my ($openimg, $closeimg, $rootimg) = $args{UseIcons} ?
		("$args{IconPath}/$args{OpenIcon}",
			"$args{IconPath}/$args{CloseIcon}",
			"$args{IconPath}/$args{RootIcon}") :
		('', '', '');
#
#	adjust paths for css/javascript/images
#
	if ($args{BasePath}) {
		$args{$_} = _pathAdjust($args{BasePath}, $args{$_})
			foreach (qw(JSPath CSSPath IconPath));
		$self->{_link} = _pathAdjust($args{BasePath}, $self->{_link})
			if $self->{_link};
	}
#
#	save path info if needed later
#
	$self->{_jspath} = $args{JSPath};
	$self->{_iconpath} = $args{IconPath};
	$self->{_csspath} = $args{CSSPath};
	$self->{_widget}->start(
		IconPath => $args{IconPath},
		CSSPath => $args{CSSPath},
		JSPath => $args{JSPath},
		UseIcons => $args{UseIcons} || 0,
		RootIcon => $rootimg,
		RootText => $self->{_text},
		RootLink => $self->{_link},
		Target => $args{Target},
		OpenIcon => $openimg,
		CloseIcon => $closeimg,
		);
#
#	sort current tree into levels
#
	my @levels =  ( [ $self ] );
	_sort_tree([ $self ], \@levels);
#
#	draw root level first
#
	my ($close, $open);
	shift @levels;
	foreach (@{$self->{_children}}) {
		$_->{_text}=~s/'/\\'/g;
		$_->{_link} = _pathAdjust($args{BasePath}, $_->{_link})
			if $args{BasePath};
		(($#{$_->{_children}} >= 0) && $args{UseIcons}) ?
			$self->{_widget}->add($_->{_node}, 0, $_->{_text}, $_->{_link}) :
			$self->{_widget}->addLeaf($_->{_node}, 0, $_->{_text}, $_->{_link});
	}
#
#	then draw succeding levels
#
	my $offset = scalar @{$levels[0]};
	foreach my $i (1..$#levels) {
		foreach (@{$levels[$i]}) {
			$_->{_node} += $offset;
			$_->{_text}=~s/'/\\'/g;
			$_->{_link} = _pathAdjust($args{BasePath}, $_->{_link})
				if $args{BasePath};
			(($#{$_->{_children}} >= 0) && $args{UseIcons}) ?
				$self->{_widget}->add($_->{_node}, $levels[$i-1][$_->{_parent}]->{_node}, $_->{_text}, $_->{_link}) :
				$self->{_widget}->addLeaf($_->{_node}, $levels[$i-1][$_->{_parent}]->{_node}, $_->{_text}, $_->{_link});
		}
		$offset += scalar @{$levels[$i]};
	}

	return $self->{_widget}->getWidget($args{Additions});
}

sub _pathAdjust {
	my ($path, $jspath) = @_;
	return $jspath
		unless (substr($jspath, 0, 2) eq './') && (substr($path, 0, 2) eq './');
#
#	relative path, adjust as needed from current base
#
	my @parts = split /\//, $path;
	my @jsparts = split /\//, $jspath;
	shift @parts;
	shift @jsparts;	# and the relative lead
	my $prefix = '';
	shift @parts,
	shift @jsparts
		while @parts && @jsparts && ($parts[0] eq $jsparts[0]);
	return ('../' x scalar @parts) . join('/', @jsparts)
}

=pod

=begin classdoc

Extract the nested list from the supplied HTML document and convert it
to an HTML::ListToTree object. Subclasses may override this method
to provide alternate list extraction logic.

@param $html	the source document

@return	an HTML::ListToTree object

=end classdoc

=cut

sub extractTree {
	my ($self, $src) = @_;
#
#	enforce some canonical form: only start with a list,
#	remove all comments, and insert list items between
#	consecutive list elements
#
	$src=~s/