view release on metacpan or  search on metacpan

XPath.pm  view on Meta::CPAN

package Class::XPath;

use 5.006;
use strict;
use warnings;

our $VERSION = '1.4';
use Carp qw(croak);
use constant DEBUG => 0;

# regex fragment for names in XPath expressions
our $NAME = qr/[\w:]+/;

# declare prototypes
sub foreach_node (&@);

# handle request to build methods from 'use Class::XPath'.
sub import {
    my $pkg = shift;
    return unless @_;
    my $target = (caller())[0];
    # hand off to add_methods
    $pkg->add_methods(@_, target => $target, from_import => 1);
}

{
    # setup lists of required params
    my %required = map { ($_,1) } 
      qw(get_name get_parent get_children 
         get_attr_names get_attr_value get_content
         get_root call_match call_xpath);
    
# add the xpath and match methods to 
sub add_methods {
    my $pkg  = shift;
    my %args = (call_match => 'match',
                call_xpath => 'xpath',
                @_);
    my $from_import = delete $args{from_import};
    my $target      = delete $args{target};
    croak("Missing 'target' parameter to ${pkg}->add_methods()")
      unless defined $target;

    # check args
    local $_;
    for (keys %args) {
        croak("Unrecognized parameter '$_' " . 
              ($from_import ? " on 'use $pkg' line. " :
                              "passed to ${pkg}->add_methods()"))
          unless $required{$_};
    }
    for (keys %required) {
        croak("Missing required parameter '$_' " . 
              ($from_import ? " on 'use $pkg' line. " :
                              "in call to ${pkg}->add_methods()"))
          unless exists $args{$_};
    }

    # translate get_* method names to sub-refs
    for (grep { /^get_/ } keys %args) {
        next if ref $args{$_} and ref $args{$_} eq 'CODE';
        $args{$_} = eval "sub { shift->$args{$_}(\@_) };";
        croak("Unable to compile sub for '$_' : $@") if $@;
    }

    # install code into requested names to call real match/xpath with
    # supplied %args
    {
        no strict 'refs';
        *{"${target}::$args{call_match}"} = 
          sub { $pkg->match($_[0], \%args, $_[1]) };