package Tk::XMLTree;

# Tk::XMLTree - An 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 'XMLTree';

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

# 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]
	);
	$myself->configure(-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, XMLTree -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__

=head1 NAME

Tk::XMLTree - An XML tree widget

=head1 SYNOPSIS

 use Tk::XMLTree;

 $top = MainWindow->new;

 $xml_tree = $top->XMLTree(?options?);
 $xml_tree = $top->ScrolledXMLTree(?options?);

 $xml_tree->load_xml_file("file.xml");
 $xml_tree->load_xml_string('<root><child /></root>');

=head1 DESCRIPTION

B<XMLTree> graphically displays the tree structure of XML documents loaded 
from either an XML file or an XML string. 

B<XMLTree> enables Perl/Tk applications with a widget that allows visual 
representation and interaction with XML document trees. 

Target applications may include XML viewers, editors and the like. 

=head1 STANDARD OPTIONS

B<XMLTree> is a subclass of L<Tk::Tree> and therefore inherits all of its 
standard options. 

Details on standard widget options can be found at L<Tk::options>.

=head1 WIDGET-SPECIFIC OPTIONS

=over 4

=item Name:		B<pcdataMaxLength>

=item Class:		B<PCDATAMaxLength>

=item Switch:		B<-pcdatamaxlength>

Set the maximum number of characters to be displayed for PCDATA elements. 
Content of such elements is trimmed to a length of B<pcdataMaxLength> characters.

Default value: C<80>. 

=item Name:		B<pcdataLongSymbol>

=item Class:		B<PCDATALongSymbol>

=item Switch:		B<-pcdatalongsymbol>

Set the symbol to append to PCDATA content with length greater than 
B<pcdataMaxLength> characters.

Default value: C<...>. 

=item Name:		B<pcdataPreserveSpace>

=item Class:		B<PCDATAPreserveSpace>

=item Switch:		B<-pcdatapreservespace>

Specify whether space characters surrounding PCDATA elements should be 
preserved or not. Such characters are preserved if this option is set to 1 and 
not preserved if set to 0. 

Default value: 0.

=back

=head1 WIDGET METHODS

The B<XMLTree> method creates a widget object. This object supports the 
B<configure> and B<cget> methods described in L<Tk::options> which can be used 
to enquire and modify the options described above. The widget also inherits 
all the methods provided by the generic L<Tk::Widget> class.

An B<XMLTree> is not scrolled by default. The B<ScrolledXMLTree> method creates a scrolled B<XMLTree>.

The following additional methods are available for B<XMLTree> widgets:

=over 4

=item $xml_tree->B<load_xml_file>(F<$xml_filename>)

Load an XML document from a file into the tree. If the tree is already loaded 
with an XML document, no reloading occurs and a warning message is issued.

Return value: none.

Example(s):

 # load XML document from file document.xml into the tree
 $xml_tree->load_xml_file('document.xml');

=back

=over 4

=item $xml_tree->B<load_xml_string>(F<$xml_string>)

Load an XML document represented by a string into the tree. If the tree is 
already loaded with an XML document, no reloading occurs and a warning message 
is issued.

Return value: none.

Example(s):

 # load XML document from xml string into the tree
 $xml_tree->load_xml_string('<root><child /></root>');

=back

=over 4

=item $xml_tree->B<get_name>()

Retrieve the name of the currently selected XML element.

Return value: name of selected element if it is mixed, undef if it is PCDATA.

Example(s):

 # retrieve name of currently selected element
 $element_name = $xml_tree->get_name();

=back

=over 4

=item $xml_tree->B<get_attrs>()

Retrieve the attribute list of the currently selected XML element.

Return value: attributes of selected element if it is mixed, undef if it is 
PCDATA. Attributes are returned as an associative array, where each key/value 
pair represent an attribute name/value, respectively.

Example(s):

 # retrieve attribute list of currently selected element
 %attributes = $xml_tree->get_attrs();

=back

=over 4

=item $xml_tree->B<get_text>()

Retrieve the content of the currently selected XML element. 

Return value: Text content if selected element is PCDATA, undef if it is mixed.

Example(s):

 # retrieve content text of currently selected element
 $text = $xml_tree->get_text();

=back

=over 4

=item $xml_tree->B<is_mixed>()

Indicate whether the currently selected element is mixed or not. If the element
is not mixed then it is PCDATA. 

Return value: TRUE if the currently selected element is mixed, FALSE if it is 
PCDATA.

Example(s):

 # determine if selected element is mixed or not
 print "element is " . ($xml_tree->is_mixed() ? 'mixed' : 'PCDATA');

=back

=over 4

=item $xml_tree->B<is_pcdata>()

Indicate whether the currently selected element is PCDATA or not. If the 
element is not PCDATA then it is mixed. 

Return value: TRUE if the currently selected element is PCDATA, FALSE if it is 
mixed.

Example(s):

 # determine if selected element is PCDATA or not
 print "element is " . ($xml_tree->is_pcdata() ? 'PCDATA' : 'mixed');

=back

=head1 EXAMPLES

An XML viewer using B<Tk::XMLTree> can be found in the F<examples> directory 
included with this module. 

=head1 VERSION

B<Tk::XMLTree> version 0.01.

=head1 AUTHOR

Santos, José.

=head1 BUGS

Please report any bugs or feature requests to C<bug-tk-xmltree at rt.cpan.org>,
or through the web interface at 
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Tk-XMLTree>. I will be 
notified, and then you'll automatically be notified of progress on your bug as 
I make changes.

=head1 SUPPORT

Documentation for this module can be found with the following perldoc command:

    perldoc Tk::XMLTree

Additional information at:

=over 4

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Tk-XMLTree>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Tk-XMLTree>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Tk-XMLTree>

=item * Search CPAN

L<http://search.cpan.org/dist/Tk-XMLTree>

=back

=head1 COPYRIGHT AND LICENSE

Copyright (c) 2008 José Santos. All rights reserved.

This program is free software. It can redistributed and/or modified under the 
same terms as Perl itself.

=head1 ACKNOWLEDGEMENTS

Thanks to Cotonete, Droit, Pistacho and Barriguita.

=head1 DEDICATION

I dedicate B<Tk::XMLTree> to my GrandMother.

=cut
