File Coverage

blib/lib/Tk/Tree/XML.pm

Criterion	Covered	Total	%
statement	13	17	76.4
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	22	81.8

package Tk::Tree::XML;

# Tk::Tree::XML - XML tree widget

# Copyright (c) 2008 José Santos. All rights reserved.
# This program is free software. It can be redistributed and/or modified under
# the same terms as Perl itself.

use strict;
use warnings;
use Carp;

BEGIN {
	use vars qw($VERSION @ISA);
	require Tk::Tree;
	require XML::Parser;
	require Tk::Derived;
	$VERSION	= '0.01';
	@ISA		= qw(Tk::Derived Tk::Tree);
}

Construct Tk::Widget 'XML';

sub Tk::Widget::ScrolledXML { shift->Scrolled('XML' => @_) }

# ConfigSpecs default values
my $PCDATA_MAX_LENGTH = 80;

sub Populate {
	my ($myself, $args) = @_;
	$myself->SUPER::Populate($args);
	$myself->ConfigSpecs(
		-pcdatamaxlength		=> ["METHOD", "pcdataMaxLength",
									"PCDATAMaxLength", $PCDATA_MAX_LENGTH],
		-pcdatalongsymbol		=> ["PASSIVE", "pcdataLongSymbol",
									"PCDATALongSymbol", '...'],
		-pcdatapreservespace	=> ["PASSIVE", "pcdataPreserveSpace",
									"PCDATAPreserveSpace", 0],
		-itemtype				=> ["SELF", "itemType", "ItemType", 'text']
	);
}

# ConfigSpecs methods

# get/set maximum number of characters for visualization of pcdata contents
sub pcdatamaxlength {
	my ($myself, $args) = @_;
	if (@_ > 1) {
		$myself->_configure(-pcdatamaxlength => &_pcdata_max_length($args));
	}
	return $myself->_cget('-pcdatamaxlength');
}

# validate given max number of characters for visualization of pcdata contents
# return given number if it is valid, $PCDATA_MAX_LENGTH otherwise
sub _pcdata_max_length {
	$_ = shift;
	/^\+?\d+$/ ? $& : &{ sub {
		carp "Attempt to assign an invalid value to -pcdatamaxlength: '$_' is" .
			" not a positive integer. Default value ($PCDATA_MAX_LENGTH)" .
			" will be used instead.\n";
		$PCDATA_MAX_LENGTH
	}};
}

# application programming interface

sub load_xml_file {	# load_xml_file($xml_filename)
	my ($myself, $xmlfile) = @_;
	my @array = (1, 2, 3);
	if (!$myself->info('exists', '0')) {
		$myself->_load_xml('', &_xml_parser->parsefile($xmlfile));
		$myself->autosetmode;# set up automatic handling of open/close events
	} else {
		carp "An XML document has already been loaded into the tree." .
			" XML file $xmlfile will not be loaded.";
	}
}

sub load_xml_string {	# load_xml_string($xml_string)
	my ($myself, $xmlstring) = @_;
	if (!$myself->info('exists', '0')) {
		$myself->_load_xml('', &_xml_parser->parse($xmlstring));
		$myself->autosetmode;# set up automatic handling of open/close events
	} else {
		carp "An XML document has already been loaded into the tree." .
			" XML string will not be loaded.";
	}
}

sub get_name {	# get_name()
	my $myself = shift;
	my $entry_path = $myself->selectionGet();
	my $is_mixed = ref($myself->entrycget($entry_path, '-data'));
	$is_mixed ? $myself->entrycget($entry_path, '-text') : undef;
}

sub get_attrs {	# get_attrs()
	my $myself = shift;
	my $attrs = $myself->entrycget($myself->selectionGet(), '-data');
	ref($attrs) ? %{$attrs} : undef;
}

sub get_text {	# get_text()
	my $myself = shift;
	my $text = $myself->entrycget($myself->selectionGet(), '-data');
	ref($text) ? undef : $text;
}

sub is_mixed {	# is_mixed()
	my $myself = shift;
	'HASH' eq ref($myself->entrycget($myself->selectionGet(), '-data'));
}

sub is_pcdata {	# is_pcdata()
	my $myself = shift;
	!$myself->is_mixed();
}

# helper methods

sub _xml_parser {	# _xml_parser(): get an XML::Parser instance.
	new XML::Parser(Style => 'Tree', ErrorContext => 2)
}

# _load_xml($parent_path, @children): load XML elems under entry at $parent_path
# @children is a list of tag/content pairs where each pair is such as:
# - ($element_tag, [%element_attrs, @element_children])	<= element is mixed
# - 0, 'pcdata contents'								<= element is PCDATA
# for each entry, XML -data and -text are set, respectively, to:
# attributes and element tag							<= element is mixed
# pcdata content and formatted pcdata content			<= element is PCDATA
sub _load_xml {
	my ($myself, $parent_path, @children) = ($_[0], $_[1], @{$_[2]});
	my $entry_path;
	while (@children) {
		my ($elem_tag, $elem_content) = (shift @children, shift @children);
		if (!ref $elem_content) {	# element is #PCDATA
			$elem_content =~ s/[\n\t ]*(.*)[\n\t ]*/$1/	# trim spacing
				unless $myself->cget('-pcdatapreservespace') eq 1;
			if ('' ne $elem_content) {
				$entry_path = $myself->addchild(
					$parent_path, -data => $elem_content,
					-text => $myself->_format_pcdata($elem_content),
				);
			}
		} else {	# element is not pcdata
			$entry_path = $myself->addchild($parent_path,
				-data => $elem_content->[0], -text => $elem_tag
			);
			shift(@$elem_content);	# shift element attributes off
			$myself->_load_xml($entry_path, $elem_content)
				unless !scalar @$elem_content; # recursively process children
		}
	}
}

sub _format_pcdata { # _format_pcdata($pcdata): format/return pcdata accordingly
	my ($myself, $pcdata) = @_;
	my $pcdata_max_length = $myself->cget('-pcdatamaxlength');
	length($pcdata) > $pcdata_max_length
		? substr($pcdata, 0, $pcdata_max_length) .
			$myself->cget('-pcdatalongsymbol')
		: $pcdata;
}

1;

__END__