view release on metacpan or  search on metacpan

lib/Config/XPath.pm  view on Meta::CPAN

#  You may distribute under the terms of either the GNU General Public License
#  or the Artistic License (the same terms as Perl itself)
#
#  (C) Paul Evans, 2005-2010 -- leonerd@leonerd.org.uk

package Config::XPath;

use strict;
use warnings;

use Exporter 'import';
our @EXPORT = qw(
   get_service_config

   get_config_string
   get_config_attrs
   get_config_list
   get_config_map

   get_sub_config
   get_sub_config_list

   read_default_config
);

our $VERSION = '0.16';

use XML::XPath;

use Carp;

use Scalar::Util qw( weaken );

=head1 NAME

C<Config::XPath> - retrieve configuration data from XML files by using XPath

=head1 SYNOPSIS

 use Config::XPath;

 my $conf = Config::XPath->new( filename => 'addressbook.xml' );

 ## Basic data retrieval

 my $bob_phone = $conf->get_string( '//user[@name="bob"]/@phone' );

 my %jim_details = $conf->get_attrs( '//user[@name="jim"]' );

 my @everyone_with_fax = $conf->get_list( '//user[@fax]' );
 print " $_ has a fax\n" for @everyone_with_fax;

 my $phone_map = $conf->get_map( '//user', '@name', '@phone' );
 print " $_ has a phone: $phone_map->{$_}\n" for sort keys %$phone_map;

 ## Subconfigurations

 my $james_config = $conf->get_sub( '//user[@name="james"]' );
 my $james_phone = $james_config->get_string( '@phone' );

 foreach my $user_config ( $conf->get_sub_list( '//user[@email]' ) ) {
    my $town = $user_config->get_string( 'address/town' );
    print "Someone in $town has an email account\n";
 }

=head1 DESCRIPTION

This module provides easy access to configuration data stored in an XML file.
Configuration is retrieved using XPath keys; various methods exist to
convert the result to a variety of convenient forms.

If the methods are called as static functions (as opposed to as object
methods) then they access data stored in the default configuration file
(details given below).

=cut

=head2 Subconfigurations

By default, the XPath context is at the root node of the XML document. If some
other context is required, then a subconfiguration object can be used. This is
a child C<Config::XPath> object, built from an XPath query on the parent.
Whatever node the query matches becomes the context for the new object. The
methods C<get_sub()> and C<get_sub_list()> perform this task; the former
returning a single child, and the latter returning a list of all matches.

=cut

=head1 CONSTRUCTOR

=head2 $conf = Config::XPath->new( %args )

lib/Config/XPath.pm  view on Meta::CPAN

=cut

sub new
{
   my $class = shift;

   my %args;

   # Cope with now-deprecated constructor form
   if( @_ == 1 ) {
      carp 'Use of '.__PACKAGE__.'->new( $file ) is deprecated; use ->new( filename => $file ) instead';
      %args = ( filename => $_[0] );
   }
   else {
      %args = @_;
   }

   my $self = bless { 
   }, $class;

   my $parser = $self->{parser} = delete $args{parser};
   
   if( defined $args{filename} ) {
      $self->{filename} = $args{filename};
      $self->_reload_file;
   }
   elsif( defined $args{xml} ) {
      my $xp = XML::XPath->new(
         xml => $args{xml},
         defined $parser ? ( parser => $parser ) : (),
      );
      croak "Cannot parse string" unless $xp;
      $self->{xp} = $xp;
   }
   elsif( defined $args{ioref} ) {
      my $xp = XML::XPath->new( 
         ioref => $args{ioref},
         defined $parser ? ( parser => $parser ) : (),
      );
      croak "Cannot parse XML from ioref" unless $xp;
      $self->{xp} = $xp;
   }
   else {
      croak "Expected 'filename', 'xml', 'parser' or 'ioref' argument";
   }

   return $self;
}

# Internal-only constructor
sub newContext
{
   my $class = shift;
   my ( $parent, $context ) = @_;

   my $self = {
      parent   => $parent,
      context  => $context
   };

   weaken( $self->{parent} );

   return bless $self, $class;
}

sub find
{
   my $self = shift;
   my ( $path, %args ) = @_;

   my $toplevel = $self;
   $toplevel = $toplevel->{parent} while !exists $toplevel->{xp};

   my $xp = $toplevel->{xp};

   my $context = $args{context} || $self->{context};

   if ( defined $context ) {
      return $xp->find( $path, $context );
   }
   else {
      return $xp->find( $path );
   }
}

sub get_config_nodes
{
   my $self = shift;
   my ( $path ) = @_;

   my $nodeset = $self->find( $path );

   unless( $nodeset->isa( "XML::XPath::NodeSet" ) ) {
      croak "Expected result to be a nodeset at '$path'";
   }

   return $nodeset->get_nodelist;
}

sub get_config_node
{
   my $self = shift;
   my ( $path ) = @_;

   my @nodes = $self->get_config_nodes( $path );

   if ( scalar @nodes == 0 ) {
      croak "No config found at '$path'";
   }

   if ( scalar @nodes > 1 ) {
      croak "Found more than one node at '$path'";
   }

   return shift @nodes;
}

sub get_node_attrs($)
# Get a hash of the attributes, putting the node name in "+"
{
   my ( $node ) = @_;