File Coverage

blib/lib/XML/miniXQL.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package XML::miniXQL;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

use XML::miniXQL::Parser;
use XML::Parser;

require Exporter;

@ISA = qw(Exporter);
@EXPORT = qw(
);

$VERSION = '0.04';


sub queryXML {
	my $param = shift;
	my $xml;
	if (ref $param eq 'HASH') {
		$xml = shift;

	}
	else {
		$xml = $param;
		$param = {Style => 'List'};
	}

	my @queries = @_;

#	print "Queries:\n", join "\n", @queries;
#	print "\n\n";

	my @Requests;

	my $req = new XML::miniXQL::Parser();
	do {
		$req = new XML::miniXQL::Parser(shift @queries, $req);
		push @Requests, $req;
	} while @queries;

	my $currenttree = new XML::miniXQL::Parser();

	my $p = new XML::Parser(Style => 'Stream',
		_parseresults => {},
		_currenttree => $currenttree,
		_requests => \@Requests,
		_style => $param->{Style},
		);

	my $results;

	# Using exceptions for a more fine-grained control. Not completely necessary ATM though.
	eval {
		$results = $p->parse($xml);
#		warn "Parse returned ", @{$results}, "\n";
	};
	if ($@) {
		die $@;
	}
	else {
		return $results;
	}
}

sub StartTag {
	my $expat = shift;
	return $expat->finish() if $expat->{_done};
	my $element = shift;
#	my %attribs = %_;

#warn "Start: $element\n";
	$expat->{_currenttree}->Append($element, %_);
	my $current = $expat->{_currenttree};

#warn "Path now: ", $expat->{_currenttree}->Path, "\n";

	my $removed = 0;

	foreach (0..$#{$expat->{_requests}}) {
		next unless defined $expat->{_requests}->[$_]->Attrib;
# warn "Looking for attrib: ", $expat->{_requests}->[$_]->Attrib, "\n";
		if (defined $_{$expat->{_requests}->[$_]->Attrib}) {
			# Looking for attrib
			if ($expat->{_requests}->[$_]->isEqual($current)) {
				# We have equality!
#				print "Found\n";
				found($expat, $expat->{_requests}->[$_], $_{$expat->{_requests}->[$_]->Attrib});
				splice(@{$expat->{_requests}}, $_ - $removed, 1) unless $expat->{_requests}->[$_]->isRepeat;
				$expat->{_done} = 1 if (@{$expat->{_requests}} == 0);
				$removed++;
				# return;
			}
		}
	}
}

sub EndTag {
	my $expat = shift;
	return $expat->finish() if $expat->{_done};
# warn "End: $_\n";

	$expat->{_currenttree}->Pop();
}

sub Text {
	my $expat = shift;
	my $text = $_;

	return $expat->finish() if $expat->{_done};

	my @Requests = @{$expat->{_requests}};
	my $current = $expat->{_currenttree};
	my $removed = 0;

	foreach (0..$#Requests) {
#		print "(",$expat->current_element, ")Searching for: ",
#		$Requests[$_]->Path, ($Requests[$_]->isRepeat ? "*" : ''), "\n";
		if (!$Requests[$_]->Attrib) {
			# Not looking for an attrib
#			warn "Comparing : ", $Requests[$_]->Path, " : ", $expat->{_currenttree}->Path, "\n";
			if ($Requests[$_]->isEqual($current)) {
#				print "Found\n";
				found($expat, $Requests[$_], $text);
				splice(@{$expat->{_requests}}, $_ - $removed, 1) unless $Requests[$_]->isRepeat;
				$expat->{_done} = 1 if (@Requests == 0);
				$removed++;
				# return;
			}
		}
	}
}

sub found {
	my $expat = shift;
	my ($request, $found) = @_;

# warn "Found: ", $request->Path, " : $found\n";

	if ($request->Path =~ /\.\*/) {
		# Request path contains a regexp
		my $match = $request->Path;
		$match =~ s/\[(.*?)\]/\\\[$1\\\]/g;

#		warn "Regexp: ", $expat->{_currenttree}->Path, " =~ |$match|\n";
		$expat->{_currenttree}->Path =~ /$match/;
		if ($expat->{_style} eq 'List') {
			push @{$expat->{_parseresults}}, $&, $found;
		}
		elsif ($expat->{_style} eq 'Hash') {
			push @{$expat->{_parseresults}->{$&}}, $found;
		}
	}
	else {
		if ($expat->{_style} eq 'List') {
			push @{$expat->{_parseresults}}, $request->Path, $found;
		}
		elsif ($expat->{_style} eq 'Hash') {
			push @{$expat->{_parseresults}->{$request->Path}}, $found;
		}
	}

}

sub EndDocument {
	my $expat = shift;
	delete $expat->{_done};
	delete $expat->{_currenttree};
	delete $expat->{_requests};
	return $expat->{_parseresults};
}

1;
__END__