File Coverage

blib/lib/XML/XPath/Simple.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package XML::XPath::Simple;
#############################################################
#  XML::XPath::Simple
#  Whyte.Wolf Simple XPath Module
#  Version 0.05
#
#  Copyright (c) 2002 by S.D. Campbell
#
#  Created 26 March 2002; Revised 30 March 2002 by SDC
#
#  Description:
#	A perl module which can be used for simple parsing of
#   XPath expressions.
#
#############################################################
#
#  This program is free software; you can redistribute it and/or
#  modify it under the terms of the GNU General Public License
#  as published by the Free Software Foundation; either version 2
#  of the License, or (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#############################################################

use Exporter;
use Carp;
use XML::Simple;

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

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

$VERSION = '0.05';
$errmsg = "";


#############################################################
# new
#
#  The constructor for the class.  Requires a string containing
#  XML.  Returns a reference to the new object or undef
#  on error.  Error can be retrieved from $XML::XPath::Simple::errmsg

sub new {
    my $class = shift;
    my %params = @_;
	my %xmlopts = ( keeproot => '1',
			 keyattr => [],
			 forcecontent => '1',
			 forcearray => '1',
			 contentkey => 'text',
			 );

    my $self = {};

	if($params{xml}){
		$$self{xml} = $params{xml};
		if($params{context}){
			$$self{context} = $params{context};
		} else {
			$$self{context} = '/';
		}
		$$self{ref} = XMLin($$self{xml}, %xmlopts);

        bless $self, $class;
    	return $self;
	}else{
		$errmsg = "XML::XPath::Simple -- No XML to parse: This module requires an XML string.";
		return undef;
	}
}

#############################################################
# context
#
#    Allows the user to get/set the context.  Returns
#    current default context, or undef if passed a new
#    context to set.

sub context {
	my $self = shift;
	if(scalar(@_) == 0) {
		return $$self{context};
	} else {
		my $path = shift;
		$$self{context} = $path;
	}
	return undef;
}

#############################################################
# find
#
#    Returns true if the node specified by the path exists
#    false otherwise.

sub find {
	my $self = shift;
	my $path = shift;
	my $ref = $$self{ref};
	$path = $self->_convert($path);

	if (eval($path)) {
		return 'true';
	} else {
		return 'false';
	}
}

#############################################################
# valueof
#
#    Returns the value of the node at the path specified

sub valueof {
	my $self = shift;
	my $path = shift;
	my $ref = $$self{ref};
	$path = $self->_convert($path);
	if (ref(eval($path))){
		$path .= '->{text}';
	}

	return eval($path);
}

#############################################################
# _convert
#
#    An internal subroutine that converts XPaths into
#    XML::Simple hash references.

sub _convert {

	my $self = shift;
	my $path = shift;
	if(substr($path, 0, 1) ne '/'){
		if(substr($path, 0, 2) eq '..'){
			my $context = $$self{context};
			$context =~ s/\/(\w*|@\w*|\w*\[\w*\])$//igs;
			$path =~ s/^..//is;
			$path = $context . $path;
		} elsif($path eq '.'){
			$path = $$self{context};
		} elsif(substr($path, 0, 1) eq '@'){
			$path = $$self{context} . $path;
		} else {
			$path = $$self{context} . '/' . $path;
		}
	}

	$path =~ s/\/(\w*)\[(\d*)\]/->{$1}[($2 - 1)]/igs;
	$path =~ s/\/(\w*)/->{$1}[0]/igs;
	$path =~ s/@(\w*)/->{$1}/igs;
	$path = '$ref' . $path;

	return $path;

}

1;
__END__