view release on metacpan or  search on metacpan

lib/Data/Selector.pm  view on Meta::CPAN

=item last 2 links

 $selector_string = "items.*.links.+-2..-1"

 $data_tree = {
     items => [
         {
             links => [ 'l2', 'l3', ],
         },
         {
             links => [ 'l4', 'l5', ],
         },
     ],
 }

=back

=head1 METHODS

=cut

=over

=item parse_string

Creates a selector tree from a selector string.  A map of named selectors can
also be provided which will be interpolated into the selector string before it
is parsed.

Required Args:  selector_string
Optional Args:  named_selectors

=cut

my $selector_string_pattern = qr/
    (
        [^\[\]\,]*+
        (?:
            \[
                (?:
                    [^\[\]]++
                    |
                    (?1)
                )*
            \]
        )?+
    )
    ,?+
/x;

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

    die "selector_string required\n"
      unless defined $args->{selector_string}
      && length $args->{selector_string};

    if ( index( $args->{selector_string}, '$', ) != -1 ) {
        $args->{selector_string} =~
          s/(?:(?<=^)|(?<=,))(\$[a-z_]*)(?:(,)(?!$)|$)/
            defined $args->{named_selectors}->{$1}
              && length $args->{named_selectors}->{$1}
              ? $args->{named_selectors}->{$1} . ( $2 ? $2 : '' )
              : die "contains invalid named selector\n";
        /ego;
    }

    my $selector_tree = {};
    my @queue = ( [ $args->{selector_string}, $selector_tree, [], ], );

    die "must be a string that matches /[^.\[\],]/\n"
      if length $args->{selector_string}
      && $args->{selector_string} !~ /[^.\[\],]/o;
    die "must not contain ']['\n" if index( $queue[0]->[0], '][' ) != -1;
    die "must not contain '[]'\n" if index( $queue[0]->[0], '[]' ) != -1;
    die "must not contain '[,'\n" if index( $queue[0]->[0], '[,' ) != -1;
    die "must not contain ',]'\n" if index( $queue[0]->[0], ',]' ) != -1;
    die "must not contain '[.'\n" if index( $queue[0]->[0], '[.' ) != -1;
    die "must not contain '.]'\n" if index( $queue[0]->[0], '.]' ) != -1;
    die "must not begin with','\n" if substr( $queue[0]->[0], 0, 1 ) eq ',';
    die "must not end with','\n"   if substr( $queue[0]->[0], -1, ) eq ',';
    die "must not begin with'.'\n" if substr( $queue[0]->[0], 0, 1 ) eq '.';
    die "must not end with'.'\n"   if substr( $queue[0]->[0], -1, ) eq '.';
    die "must have balanced [] chars\n"
      unless $queue[0]->[0] =~ tr/[/[/ == $queue[0]->[0] =~ tr/]/]/;
    die "must not match /[^.,]\[/\n"
      if $args->{selector_string} =~ /[^.,]\[/o;
    die "must not match /\][^.,\]]/\n"
      if $args->{selector_string} =~ /\][^.,\]]/o;

    my $order;
    while (@queue) {
        my $token  = shift @queue;
        my @groups = $token->[0] =~ /$selector_string_pattern/go;
        pop @groups;

        my ( $shift_a_suffix, $prev_is_suffix, );
        for my $string (@groups) {
            my $sub_tree = $token->[1];

            my $is_suffix = substr( $string, 0, 1, ) eq '.';
            if ($is_suffix) {
                push( @{ $queue[-1]->[2] }, substr( $string, 1, ), );
                $string = '';
            }
            else {
                my $opening_bracket_pos = index( $string, '[' );

                my $dot_in_prefix_pos = index( $string, '.' );
                $dot_in_prefix_pos = -1
                  if $opening_bracket_pos > -1
                  && $dot_in_prefix_pos > $opening_bracket_pos;

                if ( $dot_in_prefix_pos > -1 ) {
                    my $is_range =
                      substr( $string, $dot_in_prefix_pos + 1, 1 ) eq '.';
                    if ($is_range) {
                        $dot_in_prefix_pos =
                          index( $string, '.', $dot_in_prefix_pos + 2, );
                        $dot_in_prefix_pos = -1