element.pm

CCSM Research Tools: Community Atmosphere Model (CAM)

# ----------------------------------------------------------
# 06Sep2001 Added to support tree-like iteration          JW
# 04Nov2001 Changed to get_children (with alias)          JW
# 05Nov2001 Fixed so that it actually works               JW
# 06Nov2001 Added comments, optimizations and bug fixes   JW
# ----------------------------------------------------------
sub children;
*children = \&get_children;
sub get_children {
	my $self = shift;
	my @children = ();

	# If we don't have any content, then we should return an emtpty 
	# list right away -- we have no children.
	return @children unless defined $self->{node}[2];

	# We need to traverse the document tree and find our own node
	# This will also load {children} and {parent} as well
	$self->_find_self() unless defined $self->{self};

	# Now that we know who we are (if this didn't fail) we can 
	# iterate through the sub nodes (our child list) and make 
	# XML::Lite::Elements objects for each child
	if( defined $self->{children} ) {
		my $i = 0;
		my $node = $self->{children}[$i];
		while( defined $node ) {
			push @children, XML::Lite::Element->new( $self->{doc}, $node );
			$i++ if (@$node == 4) && (defined $node->[2]); # Skip element's child list if it exists
			$node = $self->{children}[++$i];
		} # end while
	} # end if
	
	return @children;
} # end get_children


=item my $text = $element->get_text()

Returns a scalar of the text within an element sans children elements.
This effectively takes the content of the element and strips all XML
elements. All text is concatenated into a single string. White space
is preserved. CDATA elements are included without the <![CDATA[ tags.
Other entities are preserved.

=cut

# ----------------------------------------------------------
# Date      Modification                              Author
# ----------------------------------------------------------
# 04Nov2001 Added function to get text                   JW
# 06Nov2001 Added <.../> optimization                    JW
# 06Nov2001 Included CDATA text recovery                 JW
# ----------------------------------------------------------
sub text;
*text = \&get_text;
sub get_text {
	my $self = shift;
	my $content = '';

	# If we don't have any content, then we should return  
	# $content right away -- we have no text
	return $content unless defined $self->{node}[2];

	# Otherwise get out content and children
	my @children = $self->get_children;
	my $orig_content = $self->get_content;
	
	# Then remove the child elements from our content
	my $start = 0;
	foreach( @children ) {
		my $end = $_->{node}[0] - $self->{node}[1] - 1;
		$content .= substr( $orig_content, $start, $end - $start);
		$start = ($_->{node}[3] || $_->{node}[1]) - $self->{node}[1];
	} # end foreach
	$content .= substr( $orig_content, $start ) if $start < length($orig_content);
	
	# Remove the CDATA wrapper, preserving the content
	$content =~ s/<!\[CDATA\[(.+?)]\]>/$1/g;
	
	# Return the left-over text
	return $content;
} # end get_text

##########################
##                      ##
##   Private Methods    ##
##                      ##
##########################
# ----------------------------------------------------------
# Sub: _parse_attrs
#
# Args: (None)
#
# Returns: True value on success, false on failure
#
# Description: Pares the attributes in the element into a hash
# ----------------------------------------------------------
# Date      Modification                              Author
# ----------------------------------------------------------
# 08Apr2002 Allow null strings as valid values           BEE
# 13Mar2002 Don't do anything if not defined             EBK
# ----------------------------------------------------------
sub _parse_attrs {
	my $self = shift;
	
	my $attrs = $self->{_attrs};
       if ( defined($attrs) ) {
		$attrs =~ s/^\s+//;
		$attrs =~ s/\s+$//;
		$self->{attrs} = {};
		while( $attrs =~ s/^(\S+)\s*="([^"]*)"// )		#" For syntax highlighter
		{
			$self->{attrs}{$1} = $2;
			$attrs =~ s/^\s+//;
		} # end while
       }
	
	return 1;
} # end _parse_atttrs

# ----------------------------------------------------------
# Sub: _find_self
#
# Args: (None)
#
# Returns: A reference to our node or undef on error
#
# Description: Traverses the owner document's tree to find
# the node that references the current element. Sets 
# $self-{self} as a side-effect. Even if this is already set,
# _find_self will traverse again, so don't call unless needed.
# ----------------------------------------------------------
# Date      Modification                              Author
# ----------------------------------------------------------
# 06Nov2001 Added to support children() method            JW
# ----------------------------------------------------------
sub _find_self {
	my $self = shift;
	
	# We actually just call this recusively, so the first 
	# argument can be a starting point to descend from
	# but we don't doc that above
	my $node = shift || $self->{doc}{tree};
	return undef unless defined $node;

	# Our owner XML::Lite document has a tree (list of lists) that
	# tracks all elements in the document. Starting at the root
	# of the tree, walk through each node until we find one with
	# the same offsets as our $self->{node} has.

	# Walk through the nodes in this node and compare to our selves
	for( my $i = 0; $i < scalar(@$node) && defined $node->[$i]; $i++ ) {

		# If this is our self, then we're done!
		# NOTE: Since the list references are the same in the by-name hash
		# and tree objects, we can just do a reference compare here
		# if objects are create with non-factory methods then we need to 
		# use a _compare_lists call.
# 		if( _compare_lists( $node->[$i], $self->{node} ) ) { 
 		if( $node->[$i] eq $self->{node} ) { 
			$self->{parent} = $node;
			$self->{self} = $node->[$i];
			# If this list has children, then add a pointer to that list
			$self->{children} = $node->[$i + 1] if (scalar(@{$node->[$i]}) == 4) && (defined $node->[$i][2]);
 			last;
 		} # end if

		# If this is a node with content (start and end tag) then check children
		if( (scalar(@{$node->[$i]}) == 4) && (defined $node->[$i][2]) ) {
			# This is a node with content (start and end tag)
			# So look at the child node list that follows and see what it's got
 			$i++;
			last if defined $self->_find_self( $node->[$i] );
		} # end for

		# For efficiency, we only need look at nodes that start before
		# our node does
              if ( defined($node->[$i][0]) && defined($self->{node}->[3]) ) {
			last if $node->[$i][0] > $self->{node}->[3];
              }
	} # end for

	# And return it
	return $self->{self};
} # end _find_self

# ----------------------------------------------------------
# Sub: _compare_lists
#
# Args: $list_ref_1, $list_ref_2
#
# Returns: True if the same elements, false otherwise
#
# Description: Compare the contents of two lists and returns
# whether they are the same
# NOTE: This is a CLASS METHOD (or sub)
# ----------------------------------------------------------
# Date      Modification                              Author
# ----------------------------------------------------------
# 06Nov2001 Added to support node lookups                 JW
# ----------------------------------------------------------
sub _compare_lists {
	my( $rA, $rB ) = @_;
	
	# Lists are not equal unless same size
	return 0 unless scalar(@$rA) == scalar(@$rB);
	
	# Now compare item by item.
	my $i;
	for( $i = 0; $i < scalar(@$rA); $i++ ) {
		return 0 unless $rA->[$i] eq $rB->[$i];
	} # end for
	
	return 1;
} # end _compare_lists

# module clean-up code here (global destructor)
END { }

1;  # so the require or use succeeds

=back

=head1 BUGS

(None known)

=head1 VERSION

0.11

=head1 AUTHOR

Jeremy Wadsack for Wadsack-Allen Digital Group ([e-mail])

=head1 COPYRIGHT

Copyright 2001 Wadsack-Allen. All rights reserved.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut