File Coverage

blib/lib/Data/SPath.pm

Criterion	Covered	Total	%
statement	107	125	85.6
branch	29	36	80.5
condition	1	7	14.2
subroutine	20	25	80.0
pod			n/a
total	157	193	81.3

use strict;
use warnings;
package Data::SPath;
BEGIN {
  $Data::SPath::VERSION = '0.0004';
}
#ABSTRACT: lookup on nested data with simple path notation

use 5.010_000;
use feature qw(switch);
use Carp qw/croak/;
use Scalar::Util qw/reftype blessed/;
use Text::Balanced qw/
    extract_delimited
    extract_bracketed
    extract_multiple
/;

use Sub::Exporter -setup => {
    exports => [ spath => \&_build_spath ]
};

my @Error_Handlers = qw(
    method_miss
    key_miss
    index_miss
    key_on_non_hash
    args_on_non_method
);


sub _build_spath {
    my ( $class, $name, $args ) = @_;

    return sub {
        my ( $data, $path, $opts ) = @_;
        for ( @Error_Handlers ) {
            unless ( exists $opts->{ $_ } ) {
                if ( exists $args->{ $_ } ) {
                    $opts->{ $_ } = $args->{ $_ };
                }
                else {
                    $opts->{ $_ } = \&{ "_$_" };
                }
            }
            no warnings 'uninitialized';
            unless ( ref( $opts->{ $_ } ) eq 'CODE' ) {
                croak "$_ must be set to a code reference";
            }
        }
        return _spath( $data, $path, $opts );
    };
}

# taken from Data::DPath
sub _unescape {
    my ( $str ) = @_;
    return unless defined $str;
    $str =~ s/(?
    $str =~ s/\\{2}/\\/g;
    return $str;
}

# Modified from Data::DPath. Added /s modifier to allow new lines in keys (why
# not?)
# this originally only supported double quote
sub _unquote {
    my ($str) = @_;
    $str =~ s/^(['"])(.*)\1$/$2/sg;
    return $str;
}

sub _quoted { shift =~ m,^/["'], }

sub _method_miss {
    my ( $method_name, $current, $depth ) = @_;
    my $reftype = reftype( $current );
    croak "tried to call nonexistent method '"
        . $method_name
        . "' on object with type $reftype at spath path element "
        . $depth;
}

sub _key_miss {
    my ( $key, $current, $depth ) = @_;
    croak "tried to access nonexistent key '"
        . $key
        . "' in hash at spath path element "
        . $depth;
}

sub _index_miss {
    my ( $index, $current, $depth ) = @_;
    croak "tried to access nonexistent index '"
        . $index
        . "' in array at spath path element "
        . $depth;
}

sub _key_on_non_hash {
    my ( $key, $current, $depth ) = @_;
    my $reftype = reftype( $current ) || '(non reference)';
    croak "tried to access key '"
        . $key
        . "' on a non-hash type "
        . $reftype
        . " at spath path element "
        . $depth;
}

sub _args_on_non_method {
    my ( $key, $current, $args, $depth ) = @_;
    my $reftype = reftype( $current ) || '(non reference)';
    croak "tried to pass arguments '"
        . $args
        . "' to a non-method '"
        . $key
        . "' of type "
        . $reftype
        . "at spath path element "
        . $depth;
}



sub _tokenize {
    my ( $path ) = @_;

    my $remaining_path = $path;
    my $extracted;
    my @tokens;

    while ( $remaining_path ) {
        my ( $prefix, $args );
        my $key;

        if ( _quoted( $remaining_path ) ) {
            ( $key,  $remaining_path ) = extract_delimited( $remaining_path, q|'"|, '/' );
            ( $args, $remaining_path ) = extract_bracketed( $remaining_path, q|('")| );
            $key = _unescape _unquote $key;

        }
        else {
            # must extract arguments first to keep extract_delimited from getting
            # quoted structures with / in them
            if ( $remaining_path =~ m,^/[^/]+\(, ) {
                ( $extracted, $remaining_path, $prefix ) = extract_bracketed( $remaining_path, q|('")|, '[^(]*' );
                if ( defined $prefix or defined $remaining_path ) {
                    no warnings 'uninitialized';
                    $remaining_path = $prefix . $remaining_path;
                    $args = $extracted;
                }
                else {
                    $remaining_path = $extracted;
                }
            }
            ( $extracted, $remaining_path ) = extract_delimited( $remaining_path, '/' );
            if ( not $extracted ) {
                ( $extracted, $remaining_path ) = ( $remaining_path, undef );
            }
            else {
                $remaining_path = ( chop $extracted ) . $remaining_path;
            }
            ( $key ) = $extracted =~ m,^/(.*),gs;
            $key = _unescape $key;
        }

        push @tokens, [ $key, $args ];
    }
    return \@tokens;
}

sub _tokenize_args {
    my $args = shift;
    ( $args ) = $args =~ /^\((.*)\)$/;
    return map { _unescape( $_ =~ /^['"]/ ? _unquote( $_ ) : $_ ) }
            extract_multiple( $args, [
                # quoted structures
                sub { extract_delimited( $_[0], q|'"| ) },
                # handle unquoted bare words
                qr/\s*(\w+)/s,
                qr/\s*([^,]+)(.*)/s
            ], undef, 1 );
}

sub _spath {
    my ( $data, $path, $opts ) = @_;

    my $current = $data;
    my $depth = 0;
    my $wantlist = wantarray;

    my $tokens = _tokenize( $path );

    for my $token ( @{ $tokens } ) {
        $depth++;
        my ( $key, $args ) = @{ $token };

        if ( blessed $current ) {

            my @args;
            @args = _tokenize_args( $args )
                if defined $args;

            return $opts->{method_miss}->( $key, $current, $depth )
                unless my $method = $current->can( $key );

            if ( $wantlist ) {
                my @current = $current->$method( @args );
                $current = @current > 1 ? \@current : $current[0];
            }
            else {
                $current = $current->$method( @args );
            }
        }
        else {

            return $opts->{args_on_non_method}->( $key, $current, $args, $depth )
                if defined $args;

            given ( ref $current ) {
                when( 'HASH' ) {

                    return $opts->{key_miss}->( $key, $current, $depth )
                        unless exists $current->{ $key };

                    $current = $current->{ $key };
                }
                when ( 'ARRAY' ) {

                    return $opts->{key_on_non_hash}->( $key, $current, $depth )
                        unless $key =~ /^\d+$/;
                    return $opts->{index_miss}->( $key, $current, $depth )
                        if $#{ $current } < $key;

                    $current = $current->[ $key ];
                }
                default {
                    return $opts->{key_on_non_hash}->( $key, $current, $depth );
                }
            }
        }
    }
    return $current;
}


1;


__END__