File Coverage

lib/YAX/Query.pm

Criterion	Covered	Total	%
statement	113	130	86.9
branch	56	86	65.1
condition	7	12	58.3
subroutine	13	14	92.8
pod	9	12	75.0
total	198	254	77.9

package YAX::Query;

use strict;

use YAX::Constants qw/:all/;

our $rx_iden = "[a-zA-Z0-9-\\:_]+|\\*";
our $rx_item = "\\[(?:(?:-?\\d+)|(?:\\d+\\s*\\.\\.\\s*-?\\d+))\\]";
our $rx_func = "\\b(?:parent|document|id)\\b\\(\\)";
our $rx_type = "#(?:text|processing-instruction|comment|cdata|node)";
our $rx_filt = "\\(.+?\\)(?:$rx_item)?(?=(?:\\.|\$))";
our $rx_attr = "@(?:$rx_iden)(?:$rx_item)?";
our $rx_elmt = "(?:$rx_iden)(?:$rx_item)?";
our $rx_term = "(?:$rx_type)(?:$rx_item)?|(?:$rx_func)(?:$rx_item)?";
our $rx_frag = "(?:$rx_attr)|(?:$rx_term)|(?:$rx_elmt)|(?:$rx_filt)";
our $rx_chld = "\\.(?:$rx_frag)";
our $rx_desc = "\\.\\.(?:$rx_frag)";
our $rx_expr = "$rx_desc|$rx_chld";

our $RX_TEST = "^(?:$rx_expr)+\$";
our $RX_EXEC = $rx_expr;
our $RX_ITEM = '\[(-?\d+)\]$';
our $RX_SLCE = '\[(-?\d+)\s*\.\.\s*(-?\d+)\]$';

our %CACHE;

sub new {
    my ( $class, $node ) = @_;
    my $self = bless [ $node ], $class;
    $self;
}

sub tokenize {
    my ( $self, $expr ) = @_;
    $expr =~ /$RX_EXEC/g;
}

sub compile {
    my ( $self, $expr ) = @_;
    $expr = ".$expr" unless substr( $expr, 0, 1 ) eq '.';
    die "failed to parse `$expr'" unless $expr =~ /$RX_TEST/g;

    return @{ $CACHE{ $expr } } if exists $CACHE{ $expr };

    my @exec;
    my @tokens = $self->tokenize( $expr );

    my ( $index, $start, $end, $seen_flat );
    foreach my $token ( @tokens ) {
        $token = substr( $token, 1 );

        undef( $index );
        undef( $start );
        undef( $end   );

        if ( $token =~ /$RX_ITEM/ ) {
            $token =~ s/$RX_ITEM//;
            $index = $1;
        } elsif ( $token =~ /$RX_SLCE/ ) {
            $token =~ s/$RX_SLCE//;
            $start = $1;
            $end   = $2;
        }

        if ( substr( $token, 0, 1 ) eq '.' ) {
            $seen_flat && die "cannot select `$token' following `$seen_flat'";
            push @exec, [ 'descendants', substr( $token, 1 ) ];
        }
        elsif ( $token eq '#node' ) {
            $seen_flat && die "cannot select `$token' following `$seen_flat'";
            push @exec, [ 'children' ];
        }
        elsif ( $token eq '*' ) {
            $seen_flat && die "cannot select `$token' following `$seen_flat'";
            push @exec, [ 'children', ELEMENT_NODE ];
        }
        elsif ( $token eq '#text' ) {
            $seen_flat && die "cannot select `$token' following `$seen_flat'";
            push @exec, [ 'children', TEXT_NODE ];
            $seen_flat = $token;
        }
        elsif ( $token eq '#cdata' ) {
            $seen_flat = $token;
            push @exec, [ 'children', CDATA_SECTION_NODE ];
        }
        elsif ( $token eq '#processing-instruction' ) {
            $seen_flat && die "cannot select `$token' following `$seen_flat'";
            push @exec, [ 'children', PROCESSING_INSTRUCTION_NODE ];
        }
        elsif ( $token eq '#comment' ) {
            $seen_flat && die "cannot select `$token' following `$seen_flat'";
            push @exec, [ 'children', COMMENT_NODE ];
        }
        elsif ( $token eq '@*' ) {
            $seen_flat && die "cannot select `$token' following `$seen_flat'";
            push @exec, [ 'attributes' ];
            $seen_flat = $token;
        }
        elsif ( substr( $token, 0, 1 ) eq '@' ) {
            $seen_flat && die "cannot select `$token' following `$seen_flat'";
            push @exec, [ 'attribute', substr( $token, 1 ) ];
            $seen_flat = $token;
        }
        elsif ( substr( $token, 0, 1 ) eq '(' ) {
            push @exec, [ 'filter', substr( $token, 1, -1 ) ];
        }
        elsif ( $token eq 'parent()' ) {
            $seen_flat && die "cannot select `$token' following `$seen_flat'";
            push @exec, [ 'parent' ];
        }
        else {
            $seen_flat && die "cannot select `$token' following `$seen_flat'";
            push @exec, [ 'child', $token ]
        }

        if ( defined $index ) {
            push @exec, [ 'item', 0+$index ];
        }
        elsif ( defined $start and defined $end ) {
            push @exec, [ 'slice', 0+$start, 0+$end ];
        }
    }

    $CACHE{ $expr } = [ @exec ];
    return @exec;
}

sub select {
    my ( $self, $expr ) = @_;
    my @exec = $self->compile( $expr );
    my ( $meth, @list );
    foreach my $exec ( @exec ) {
        $meth = shift @$exec;
        if ( $meth eq 'item' ) {
            @$self = ( $self->[ $exec->[0] ] );
        }
        elsif ( $meth eq 'slice' ) {
            @$self = @$self[ $exec->[0] .. $exec->[1] ];
        }
        elsif ( $meth eq 'filter' ) {
            $self->filter( $exec->[0] );
        }
        else {
            @list = @$self;
            @$self = ( );
            foreach my $node ( @list ) {
                $self->$meth( $node, @$exec );
            }
        }
    }
    $self;
}

sub parent {
    my ( $self, $node ) = @_;
    push @$self, $node->parent;
    $self;
}

sub children {
    my ( $self, $node, $type ) = @_;
    if ( UNIVERSAL::can( $node, 'children' ) ) {
        foreach my $child ( @{ $node->children } ) {
            next if defined $type and ( $child->type != $type );
            push @$self, $child;
        }
    }
    $self;
}

sub child {
    my ( $self, $node, $name ) = @_;
    if ( UNIVERSAL::can( $node, 'children' ) ) {
        foreach my $child ( @{ $node->children } ) {
            next unless $child->name eq $name;
            push @$self, $child;
        }
    }
    $self;
}

sub attributes {
    my ( $self, $node ) = @_;
    push @$self, $node->attributes;
    $self;
}

sub attribute {
    my ( $self, $node, $name ) = @_;
    push @$self, $node->attributes->{ $name };
    $self;
}

sub descendants {
    my ( $self, $node, $name ) = @_;
    $name = '*' unless $name;
    if ( UNIVERSAL::can( $node, 'children' ) ) {
        my @stack;
        my $count = 0;
        foreach my $child ( reverse @{ $node->children } ) {
            $stack[ $count++ ] = $child;
        }
        while ( --$count >= 0 ) {
            my $n = $stack[ $count ];
            if ( $name eq '*' and $n->type == ELEMENT_NODE ) {
                push @$self, $n;
            }
            elsif ( $name eq '#processing-instruction' and
                ( $n->type == PROCESSING_INSTRUCTION_NODE ) ) {
                push @$self, $n;
            }
            elsif ( $n->name eq $name ) {
                push @$self, $n;
            }
            if ( UNIVERSAL::can( $n, 'children' ) ) {
                foreach my $child ( reverse @{ $n->children } ) {
                    $stack[ $count++ ] = $child;
                }
            }
        }
        undef( @stack );
    }
    $self;
}

sub filter {
    my ( $self, $test ) = @_;
    unless ( ref $test eq 'CODE' ) {
        my $orig = $test;
        $test =~ s/@([a-zA-Z\-:._]+)\b/\$_->{$1}/g;
        $orig = $test;
        $test = mk_code( $test );
        die "$@ while compiling filter: `$orig'" if $@;
    }
    @$self = grep { &$test } @$self;
    $self;
}

sub mk_code { eval 'sub { '.$_[-1].' }' }

1;
__END__