File Coverage

blib/lib/XML/Mini/Document.pm

Criterion	Covered	Total	%
statement	267	382	69.9
branch	79	184	42.9
condition	36	74	48.6
subroutine	31	37	83.7
pod	17	20	85.0
total	430	697	61.6

package XML::Mini::Document;
use strict;
$^W = 1;

use FileHandle;

use XML::Mini;
use XML::Mini::Element;
use XML::Mini::Element::Comment;
use XML::Mini::Element::Header;
use XML::Mini::Element::CData;
use XML::Mini::Element::DocType;
use XML::Mini::Element::Entity;
use XML::Mini::Node;

use vars qw ( 	$VERSION
		$TextBalancedAvailable
	 );

use Text::Balanced;
$TextBalancedAvailable = 1;

$VERSION = '1.38';


if ($XML::Mini::IgnoreDeepRecursionWarnings)
{
	XML::Mini->ignoreDeepRecursionWarning();
}

sub new
{
    my $class = shift;
    my $string = shift;

    my $self = {};
    bless $self, ref $class || $class;

    $self->init();

    if (defined $string)
    {
	$self->fromString($string);
    }

    return $self;
}

sub init {
	my $self = shift;
	delete $self->{'_xmlDoc'};

	$self->{'_xmlDoc'} = XML::Mini::Element->new("PSYCHOGENIC_ROOT_ELEMENT");
}


sub getRoot
{
    my $self = shift;
    return $self->{'_xmlDoc'};
}

sub setRoot
{
    my $self = shift;
    my $root = shift;

    return XML::Mini->Error("XML::Mini::Document::setRoot(): Trying to set non-XML::Mini::Element as root")
	unless ($self->isElement($root));

    $self->{'_xmlDoc'} = $root;
}

sub isElement
{
    my $self = shift;
    my $element = shift || return undef;

    my $type = ref $element;

    return undef unless $type;

    return 0 unless ($type =~ /^XML::Mini::Element/);

    return 1;
}

sub isNode
{
    my $self = shift;
    my $element = shift || return undef;

    my $type = ref $element;

    return undef unless $type;

    return 0 unless ($type =~ /^XML::Mini::Node/);

    return 1;
}

sub createElement
{
    my $self = shift;
    my $name = shift;
    my $value = shift; # optional

    my $newElement = XML::Mini::Element->new($name);

    return XML::Mini->Error("Could not create new element named '$name'")
	unless ($newElement);

    if (defined $value)
    {
	$newElement->text($value);
    }

    return $newElement;
}

sub getElementByPath
{
    my $self = shift;
    my $path = shift;
    my @elementNumbers = @_;

    my $element = $self->{'_xmlDoc'}->getElementByPath($path, @elementNumbers);
    if ($XML::Mini::Debug)
    {
	if ($element)
	{
	    XML::Mini->Log("XML::Mini::Document::getElementByPath(): element at $path found.");
	  } else {
	      XML::Mini->Log("XML::Mini::Document::getElement(): element at $path NOT found.");
	    }
    }

    return $element;
}

sub getElement
{
    my $self = shift;
    my $name = shift;
    my $elementNumber = shift; # optionally get only the ith element

    my $element = $self->{'_xmlDoc'}->getElement($name, $elementNumber);

    if ($XML::Mini::Debug)
    {
	if ($element)
	{
		XML::Mini->Log("XML::Mini::Document::getElement(): element named $name found.");
	} else {
		XML::Mini->Log("XML::Mini::Document::getElement(): element named $name NOT found.");
	}
    }

    return $element;
}

sub fromString
{
    my $self = shift;
    my $string = shift;


    if ($XML::Mini::CheckXMLBeforeParsing)
    {
    	my $copy = $string;

    	$copy =~ s/<\s*\?\s*xml.*?\?>//smg;
    	$copy =~ s///smg;

	$copy =~s/]*>//smg;
	$copy =~ s/]*>//smg;
	$copy =~ s/]*>//smg;
    	$copy =~ s/<\s*[^\s>]+[^>]*\/\s*>//smg; # get rid of  tags

    	# get rid of all pairs of tags...
   	 my %counts;
   	 while ($copy =~ m/<\s*([^\/\s>]+)[^>]*>/smg)
    	{
    		$counts{$1}->{'open'} = 0 unless (exists $counts{$1}->{'open'});
		$counts{$1}->{'open'}++;
    	}

    	while ($copy =~ m/<\s*\/\s*([^\s>]+)(\s[^>]*)?>/smg)
    	{
    		$counts{$1}->{'close'} = 0 unless (exists $counts{$1}->{'close'});
		$counts{$1}->{'close'}++;
    	}

    	# anything left
    	my @unmatched;
   	while (my ($tag, $res) = each %counts)
    	{
    		unless ($res->{'open'} && $res->{'close'}
			&& $res->{'open'} == $res->{'close'} )
		{
			push @unmatched, $tag;
		}
    	}

    	if (scalar @unmatched)
    	{
		if ($XML::Mini::DieOnBadXML)
		{
    			XML::Mini->Error("Found unmatched tags in your XML... " . join(',', @unmatched));
		} else {

    			XML::Mini->Log("Found unmatched tags in your XML... " . join(',', @unmatched));
		}

		return 0;
    	}

	# passed our basic check...
   }


    $self->fromSubString($self->{'_xmlDoc'}, $string);

    return $self->{'_xmlDoc'}->numChildren();
}

sub fromFile
{
    my $self = shift;
    my $filename = shift;

    my $fRef = \$filename;
    my $contents;
    if (ref($filename) && UNIVERSAL::isa($filename, 'IO::Handle'))
    {
	$contents = join("", $filename->getlines());
	$filename->close();

    } elsif (ref $fRef eq 'GLOB') {

    	$contents = join('', $fRef->getlines());
	$fRef->close();

    } elsif (ref $fRef eq 'SCALAR') {

	return XML::Mini->Error("XML::Mini::Document::fromFile() Can't find file $filename")
		unless (-e $filename);


	return XML::Mini->Error("XML::Mini::Document::fromFile() Can't read file $filename")
		unless (-r $filename);

	my $infile = FileHandle->new();
	$infile->open( "<$filename")
		|| return  XML::Mini->Error("XML::Mini::Document::fromFile()  Could not open $filename for read: $!");
	$contents = join("", $infile->getlines());
	$infile->close();
    }

    return $self->fromString($contents);
}

sub parse
{
	my $self = shift;
	my $input = shift;

	my $inRef = \$input;
	my $type = ref($inRef);

	if ($type eq 'SCALAR' && $input =~ m|<[^>]+>|sm)
	{
		# we have some XML
		return $self->fromString($input);

	} else {
		# hope it's a file name or handle
		return $self->fromFile($input);
	}

}


sub fromHash {
	my $self = shift;
	my $href = shift ||  return XML::Mini->Error("XML::Mini::Document::fromHash - must pass a hash reference");
	my $params = shift || {};

	$self->init();

	if ($params->{'attributes'})
	{
		my %attribs;
		while (my ($attribName, $value) = each %{$params->{'attributes'}})
		{
			my $vType = ref $value || "";
			if ($vType)
			{
				if ($vType eq 'ARRAY')
				{
					foreach my $v (@{$value})
					{
						$attribs{$attribName}->{$v}++;
					}

				}
			} else {
				$attribs{$attribName}->{$value}++;
			}
		}

		$params->{'attributes'} = \%attribs;
	}



	while (my ($keyname, $value) = each %{$href})
	{

		my $sub = $self->_fromHash_getExtractSub(ref $value);

		$self->$sub($keyname, $value, $self->{'_xmlDoc'}, $params);

	}

	return $self->{'_xmlDoc'}->numChildren();

}

sub _fromHash_getExtractSub {
	my $self = shift;
	my $valType = shift || 'STRING';

	my $sub = "_fromHash_extract$valType";

	return XML::Mini->Error("XML::Mini::Document::fromHash Don't know how to interpret '$valType' values")
		unless ($self->can($sub));

	return $sub;

}


sub _fromHash_extractHASH {
	my $self = shift;
	my $name = shift;
	my $value = shift || return XML::Mini->Error("XML::Mini::Document::extractHASHref No value passed!");
	my $parent = shift || return XML::Mini->Error("XML::Mini::Document::extractHASHref No parent element passed!");
	my $params = shift || {};

	return XML::Mini->Error("XML::Mini::Document::extractHASHref No element name passed!")
		unless (defined $name);


	my $thisElement = $parent->createChild($name);

	while (my ($key, $val) = each %{$value})
	{


		my $sub = $self->_fromHash_getExtractSub(ref $val);

		$self->$sub($key, $val, $thisElement, $params);

	}

	return ;
}

sub _fromHash_extractARRAY {
	my $self = shift;
	my $name = shift;
	my $values = shift || return XML::Mini->Error("XML::Mini::Document::extractARRAYref No value passed!");
	my $parent = shift || return XML::Mini->Error("XML::Mini::Document::extractARRAYref No parent element passed!");
	my $params = shift || {};

	return XML::Mini->Error("XML::Mini::Document::extractARRAYref No element name passed!")
		unless (defined $name);

	# every element in an array ref is a child element of the parent
	foreach my $val (@{$values})
	{
		my $valRef = ref $val;

		if ($valRef)
		{
			# this is a complex element
			#my $childElement = $parent->createChild($name);

			# process sub elements
			my $sub = $self->_fromHash_getExtractSub($valRef);

			$self->$sub($name, $val, $parent, $params);

		} else {
			# simple string
			$self->_fromHash_extractSTRING($name, $val, $parent, $params);


		}

	}

	return;

}

sub _fromHash_extractSTRING {
	my $self = shift;
	my $name = shift;
	my $val = shift ;
	my $parent = shift || return XML::Mini->Error("XML::Mini::Document::extractSTRING No parent element passed!");
	my $params = shift || {};

	return XML::Mini->Error("XML::Mini::Document::extractSTRING No element name passed!")
		unless (defined $name);


	return XML::Mini->Error("XML::Mini::Document::extractSTRING No value passed!")
		unless (defined $val);

	my $pname = $parent->name();

	if ($params->{'attributes'}->{$pname}->{$name} || $params->{'attributes'}->{'-all'}->{$name})
	{
		$parent->attribute($name, $val);
	} elsif ($name eq '-content') {

		$parent->text($val);

	} else {
		$parent->createChild($name, $val);
	}

	return ;


}



sub toHash {
	my $self = shift;

	my $retVal = $self->{'_xmlDoc'}->toStructure();

	my $type = ref $retVal;

	if ($type && $type eq 'HASH')
	{
		return $retVal;
	}

	my $retHash = {
			'-content'	=> $retVal,
		};

	return $retHash;

}



sub toString
{
    my $self = shift;
    my $depth = shift || 0;

    my $retString = $self->{'_xmlDoc'}->toString($depth);

    $retString =~ s/<\/PSYCHOGENIC_ROOT_ELEMENT>//smi;
    $retString =~ s/]*)?>\s*//smi;


    return $retString;
}

sub fromSubStringBT {
	my $self = shift;
	my $parentElement = shift;
   	my $XMLString = shift;
	my $useIgnore = shift;

	if ($XML::Mini::Debug)
	{
		XML::Mini->Log("Called fromSubStringBT() with parent '" . $parentElement->name() . "'\n");
	}

	my @res;
	if ($useIgnore)
	{
		my $ignore = [ '<\s*[^\s>]+[^>]*\/\s*>',	#
			'<\?\s*[^\s>]+\s*[^>]*\?>', #
			'',			#
			'\s*', 	# CDATA
			']*)(\[.*?\])?\s*>',	# DOCTYPE
			']+>'
		];

		@res = Text::Balanced::extract_tagged($XMLString, undef, undef, undef, { 'ignore' => $ignore });
	} else {
		@res = Text::Balanced::extract_tagged($XMLString);
	}

	if ($#res == 5)
	{
		# We've extracted a balanced ..

		my $extracted = $res[0]; # the entire ..
		my $remainder = $res[1]; # stuff after the ..HERE  - 3
		my $prefix = $res[3]; # the  itself - 1
		my $contents = $res[4]; # the '..' between .. - 2
		my $suffix = $res[5]; # the

		#XML::Mini->Log("Grabbed prefix '$prefix'...");
		my $newElement;

		if ($prefix =~ m|<\s*([^\s>]+)\s*([^>]*)>|)
		{
			my $name = $1;
			my $attribs = $2;
			$newElement = $parentElement->createChild($name);
	    		$self->_extractAttributesFromString($newElement, $attribs) if ($attribs);

			$self->fromSubStringBT($newElement, $contents) if ($contents =~ m|\S|);

			$self->fromSubStringBT($parentElement, $remainder) if ($remainder =~ m|\S|);
		} else {

			XML::Mini->Log("XML::Mini::Document::fromSubStringBT extracted balanced text from invalid tag '$prefix' - ignoring");
    		}
	} else {

		$XMLString =~ s/>\s*\n/>/gsm;
		if ($XMLString =~ m/^\s*<\s*([^\s>]+)([^>]*>).*<\s*\/\1\s*>/osm)
		{
			# starts with a normal  ...  but has some ?? in it

			my $startTag = $2;
			return $self->fromSubStringBT($parentElement, $XMLString, 'USEIGNORE')
				unless ($startTag =~ m|/\s*>$|);
		}

		# not a ...
		#it's either a
		if ($XMLString =~ m/^\s*(<\s*([^\s>]+)([^>]+)\/\s*>|	#
					 <\?\s*([^\s>]+)\s*([^>]*)\?>|	#
					 |			#
					 \s*| 	# CDATA
					 ]*)(\[.*?\])?\s*>\s*|	# DOCTYPE
					 ]+)\s*(["'])([^\11]+)\11\s*>\s*| # ENTITY
					 ([^<]+))(.*)/xogsmi) # plain text
		{
			my $firstPart	 = $1;
			my $unaryName 	 = $2;
			my $unaryAttribs = $3;
			my $headerName 	 = $4;
			my $headerAttribs= $5;
			my $comment 	 = $6;
			my $cdata	 = $7;
			my $doctype	 = $8;
			my $doctypeCont  = $9;
			my $entityName	 = $10;
			my $entityCont	 = $12;
			my $plainText	 = $13;
			my $remainder 	 = $14;



			# There is some duplication here that should be merged with that in fromSubString()
			if ($unaryName)
			{
				my $newElement = $parentElement->createChild($unaryName);
				$self->_extractAttributesFromString($newElement, $unaryAttribs) if ($unaryAttribs);
			} elsif ($headerName)
			{
				my $newElement = XML::Mini::Element::Header->new($headerName);
				$self->_extractAttributesFromString($newElement, $headerAttribs) if ($headerAttribs);
				$parentElement->appendChild($newElement);
			} elsif (defined $comment) {
				$parentElement->comment($comment);
			} elsif (defined $cdata) {
				my $newElement = XML::Mini::Element::CData->new($cdata);
				$parentElement->appendChild($newElement);
			} elsif ($doctype || defined $doctypeCont) {
				my $newElement = XML::Mini::Element::DocType->new($doctype);
				$parentElement->appendChild($newElement);
				if ($doctypeCont)
				{
					$doctypeCont =~ s/^\s*\[//smg;
					$doctypeCont =~ s/\]\s*$//smg;

					$self->fromSubStringBT($newElement, $doctypeCont);
				}
			} elsif (defined $entityName) {
				my $newElement = XML::Mini::Element::Entity->new($entityName, $entityCont);
				$parentElement->appendChild($newElement);
			} elsif (defined $plainText && $plainText =~ m|\S|sm)
			{
				$parentElement->createNode($plainText);
			} else {
				XML::Mini->Log("NO MATCH???") if ($XML::Mini::Debug);
			}


			if (defined $remainder && $remainder =~ m|\S|sm)
			{
				$self->fromSubStringBT($parentElement, $remainder);
			}

		} else {
			# No match here either...
			XML::Mini->Log("No match in fromSubStringBT() for '$XMLString'") if ($XML::Mini::Debug);

		} # end if it matches one of our other tags or plain text

	} # end if Text::Balanced returned a match


} # end fromSubStringBT()




sub fromSubString
{
    my $self = shift;
    my $parentElement = shift;
    my $XMLString = shift;

    if ($XML::Mini::Debug)
    {
		XML::Mini->Log("Called fromSubString() with parent '" . $parentElement->name() . "'\n");
    }


    # The heart of the parsing is here, in our mega regex
    # The sections are for:
    # ...
    #
    #
    #
    #
    #
    # plain text
    #=~/<\s*([^\s>]+)([^>]+)?>(.*?)<\s*\/\\1\s*>\s*([^<]+)?(.*)


    if ($TextBalancedAvailable)
    {
    	return $self->fromSubStringBT($parentElement, $XMLString);
    }

    while ($XMLString =~/\s*<\s*([^\s>]+)([^>]+)?>(.*?)<\s*\/\1\s*>\s*([^<]+)?(.*)|
    \s*\s*|
    \s*<\s*([^\s>]+)\s*([^>]*)\/\s*>\s*([^<>]+)?|
    \s*\s*|
    \s*]*)(\[.*?\])?\s*>\s*|
    \s*]+)\s*(["'])([^\14]+)\14\s*>\s*|
    \s*<\?\s*([^\s>]+)\s*([^>]*)\?>|
    ^([^<]+)(.*)/xogsmi)


    {
	# Check which string matched.'
	my $uname = $7;
	my $comment = $6;
	my $cdata = $10;
	my $doctypedef = $11;
	if ($12)
	{
		if ($doctypedef)
		{
			$doctypedef .= ' ' . $12;
		} else {
			$doctypedef = $12;
		}
	}

	my $entityname = $13;
	my $headername = $16;
	my $headerAttribs  = $17;
	my $plaintext = $18;

	if (defined $uname)
	{
	    my $ufinaltxt = $9;
	    my $newElement = $parentElement->createChild($uname);
	    $self->_extractAttributesFromString($newElement, $8);
	    if (defined $ufinaltxt && $ufinaltxt =~ m|\S+|)
	    {
		$parentElement->createNode($ufinaltxt);
	    }
	} elsif (defined $headername)
	{
		my $newElement = XML::Mini::Element::Header->new($headername);
		$self->_extractAttributesFromString($newElement, $headerAttribs) if ($headerAttribs);
		$parentElement->appendChild($newElement);

	} elsif (defined $comment) {
	    #my $newElement = XML::Mini::Element::Comment->new('!--');
	    #$newElement->createNode($comment);
	    $parentElement->comment($comment);
	} elsif (defined $cdata) {
	    my $newElement = XML::Mini::Element::CData->new($cdata);
	    $parentElement->appendChild($newElement);
	} elsif (defined $doctypedef) {

	    my $newElement = XML::Mini::Element::DocType->new($11);
	    $parentElement->appendChild($newElement);
	    $self->fromSubString($newElement, $doctypedef);

	} elsif (defined $entityname) {

	    my $newElement = XML::Mini::Element::Entity->new($entityname, $15);
	    $parentElement->appendChild($newElement);

	} elsif (defined $plaintext) {

	    my $afterTxt = $19;
	    if ($plaintext !~ /^\s+$/)
	    {
		$parentElement->createNode($plaintext);
	    }

	    if (defined $afterTxt)
	    {
		$self->fromSubString($parentElement, $afterTxt);
	    }
	} elsif ($1) {

	    my $nencl = $3;
	    my $finaltxt = $4;
	    my $otherTags = $5;
	    my $newElement = $parentElement->createChild($1);
	    $self->_extractAttributesFromString($newElement, $2);


	    if ($nencl =~ /^\s*([^\s<][^<]*)/)
	    {
		my $txt = $1;
		$newElement->createNode($txt);
		$nencl =~ s/^\s*[^<]+//;
	    }

	    $self->fromSubString($newElement, $nencl);

	    if (defined $finaltxt)
	    {
		$parentElement->createNode($finaltxt);
	    }

	    if (defined $otherTags)
	    {
		$self->fromSubString($parentElement, $otherTags);
	    }
	}
    } # end while matches
} #* end method fromSubString */

sub toFile
{
    my $self = shift;
    my $filename = shift || return XML::Mini->Error("XML::Mini::Document::toFile - must pass a filename to save to");
    my $safe = shift;

    my $dir = $filename;

    $dir =~ s|(.+/)?[^/]+$|$1|;

    if ($dir)
    {
	return XML::Mini->Error("XML::Mini::Document::toFile - called with file '$filename' but cannot find director $dir")
	    unless (-e $dir && -d $dir);
	return XML::Mini->Error("XML::Mini::Document::toFile - called with file '$filename' but no permission to write to dir $dir")
	    unless (-w $dir);
    }

    my $contents = $self->toString();

    return XML::Mini->Error("XML::Mini::Document::toFile - got nothing back from call to toString()")
	unless ($contents);

    my $outfile = FileHandle->new();

    if ($safe)
    {
	if ($filename =~ m|/\.\./| || $filename =~ m|#;`\*|)
	{
	    return XML::Mini->Error("XML::Mini::Document::toFile() Filename '$filename' invalid with SAFE flag on");
	}

	if (-e $filename)
	{
	    if ($safe =~ /NOOVERWRITE/i)
	    {
		return XML::Mini->Error("XML::Mini::Document::toFile() file '$filename' exists and SAFE flag is '$safe'");
	    }

	    if (-l $filename)
	    {
		return XML::Mini->Error("XML::Mini::Document::toFile() file '$filename' is a "
					. "symbolic link and SAFE flag is on");
	    }
	}
    }

    $outfile->open( ">$filename")
	|| return  XML::Mini->Error("XML::Mini::Document::toFile()  Could not open $filename for write: $!");
    $outfile->print($contents);
    $outfile->close();
    return length($contents);
}

sub getValue
{
    my $self = shift;
    return $self->{'_xmlDoc'}->getValue();
}

sub dump
{
    my $self = shift;
    return Dumper($self);
}

#// _extractAttributesFromString
#// private method for extracting and setting the attributs from a
#// ' a="b" c = "d"' string
sub _extractAttributesFromString
{
    my $self = shift;
    my $element = shift;
    my $attrString = shift;

    return undef unless (defined $attrString);
    my $count = 0;
    while ($attrString =~ /([^\s]+)\s*=\s*(['"])([^\2]*?)\2/g)
    {
	my $attrname = $1;
	my $attrval = $3;

	if (defined $attrname)
	{
	    $attrval = '' unless (defined $attrval && length($attrval));
	    $element->attribute($attrname, $attrval, '');
	    $count++;
	}
    }

    return $count;
}

1;

__END__