File Coverage

blib/lib/HTML/Selector/XPath.pm

Criterion	Covered	Total	%
statement	131	144	90.9
branch	113	130	86.9
condition	12	12	100.0
subroutine	13	14	92.8
pod	4	10	40.0
total	273	310	88.0

package HTML::Selector::XPath;

use strict;
use 5.008_001;
our $VERSION = '0.28';

require Exporter;
our @EXPORT_OK = qw(selector_to_xpath);
*import = \&Exporter::import;

use Carp;

sub selector_to_xpath {
    __PACKAGE__->new(shift)->to_xpath(@_);
}

# XXX: Identifiers should also allow any characters U+00A0 and higher, and any
# escaped characters.
my $ident = qr/(?![0-9]|-[-0-9])[-_a-zA-Z0-9]+/;

my $reg = {
    # tag name/id/class
    element => qr/^([#.]?)([^\s'"#.\/:@,=~>()\[\]|]*)((\|)([a-z0-9\\*_-]*))?/i,
    # attribute presence
    attr1   => qr/^\[ \s* ($ident) \s* \]/x,
    # attribute value match
    attr2   => qr/^\[ \s* ($ident) \s*
        ( [~|*^\$!]? = ) \s*
        (?: ($ident) | "([^"]*)" | '([^']*)') \s* \] /x,
    badattr => qr/^\[/,
    attrN   => qr/^:not\(/i, # we chop off the closing parenthesis below in the code
    pseudo  => qr/^:([-\w]+\(?)/i,
    # adjacency/direct descendance
    combinator => qr/^(\s*[>+~\s](?!,))/i,
    # rule separator
    comma => qr/^\s*,\s*/i,
};

sub new {
    my($class, $exp) = @_;
    bless { expression => $exp }, $class;
}

sub selector {
    my $self = shift;
    $self->{expression} = shift if @_;
    $self->{expression};
}

sub convert_attribute_match {
    my ($left,$op,$right) = @_;
    # negation (e.g. [input!="text"]) isn't implemented in CSS, but include it anyway:
    if ($op eq '!=') {
        "\@$left!='$right'";
    } elsif ($op eq '~=') { # substring attribute match
        "contains(concat(' ', \@$left, ' '), ' $right ')";
    } elsif ($op eq '*=') { # real substring attribute match
        "contains(\@$left, '$right')";
    } elsif ($op eq '|=') {
        "\@$left='$right' or starts-with(\@$left, '$right-')";
    } elsif ($op eq '^=') {
        "starts-with(\@$left,'$^N')";
    } elsif ($op eq '$=') {
        my $n = length($^N) - 1;
        "substring(\@$left,string-length(\@$left)-$n)='$^N'";
    } else { # exact match
        "\@$left='$^N'";
    }
}

sub _generate_child {
    my ($direction,$name,$a,$b) = @_;
    if ($a == 0) { # 0n+b
        $b--;
        "[count($direction-sibling::$name) = $b and parent::*]"
    } elsif ($a > 0) { # an + b
        return "[not((count($direction-sibling::$name)+1)<$b) and ((count($direction-sibling::$name) + 1) - $b) mod $a = 0 and parent::*]"
    } else { # -an + $b
        $a = -$a;
        return "[not((count($direction-sibling::$name)+1)>$b) and (($b - (count($direction-sibling::$name) + 1)) mod $a) = 0 and parent::*]"
    }
}

sub nth_child {
    my ($a,$b) = @_;
    if (@_ == 1) {
        ($a,$b) = (0,$a);
    }
    _generate_child('preceding', '*', $a, $b);
}

sub nth_last_child {
    my ($a,$b) = @_;
    if (@_ == 1) {
        ($a,$b) = (0,$a);
    }
    _generate_child('following', '*', $a, $b);
}

# A hacky recursive descent
# Only descends for :not(...)
sub consume_An_plus_B {
    my( $rrule ) = @_;

    my( $A, $B );

    if( $$rrule =~ s/^odd\s*\)// ) {
        ($A,$B) = (2, 1)
    } elsif( $$rrule =~ s/^even\s*\)// ) {
        ($A,$B) = (2, 0)
    } elsif( $$rrule =~ s/^\s*(-?\d+)\s*\)// ) {
        ($A,$B) = (0, $1)
    } elsif( $$rrule =~ s/^\s*(-?\d*)\s*n\s*(?:\+\s*(\d+))?\s*\)// ) {
        ($A,$B) = ($1, $2 || 0);
        if( ! defined $A ) {
            $A = '0';
        } elsif( $A eq '-') {
            $A = '-1';
        } elsif( $A eq '' ) {
            $A = '1';
        }
    } else {
        croak "Can't parse formula from '$$rrule'";
    }

    return ($A, $B);
}

sub consume {
    my ($self, $rule, %parms) = @_;
    my $root = $parms{root} || '/';

    return [$rule,''] if $rule =~ m!^/!; # If we start with a slash, we're already an XPath?!

    my @parts = ("$root/");
    my $last_rule = '';
    my @next_parts;

    my $wrote_tag;
    my $root_index = 0; # points to the current root
    # Loop through each "unit" of the rule
    while (length $rule && $rule ne $last_rule) {
        $last_rule = $rule;

        $rule =~ s/^\s*|\s*$//g;
        last unless length $rule;

        # Prepend explicit first selector if we have an implicit selector
        # (that is, if we start with a combinator)
        if ($rule =~ /$reg->{combinator}/) {
            $rule = "* $rule";
        }

        # Match elements
        if ($rule =~ s/$reg->{element}//) {
            my ($id_class,$name,$lang) = ($1,$2,$3);

            # to add *[1]/self:: for follow-sibling
            if (@next_parts) {
                push @parts, @next_parts; #, (pop @parts);
                @next_parts = ();
            }

            my $tag = $id_class eq '' ? $name || '*' : '*';

            if (defined $parms{prefix} and not $tag =~ /[*:|]/) {
                $tag = join ':', $parms{prefix}, $tag;
            }

            if (! $wrote_tag++) {
                push @parts, $tag;
            }

            # XXX Shouldn't the RE allow both, ID and class?
            if ($id_class eq '#') { # ID
                push @parts, "[\@id='$name']";
            } elsif ($id_class eq '.') { # class
                push @parts, "[contains(concat(' ', normalize-space(\@class), ' '), ' $name ')]";
            };
        };

        # Match attribute selectors
        if ($rule =~ s/$reg->{attr2}//) {
            push @parts, "[", convert_attribute_match( $1, $2, $^N ), "]";
        } elsif ($rule =~ s/$reg->{attr1}//) {
            # If we have no tag output yet, write the tag:
            if (! $wrote_tag++) {
                push @parts, '*';
            }
            push @parts, "[\@$1]";
        } elsif ($rule =~ $reg->{badattr}) {
            Carp::croak "Invalid attribute-value selector '$rule'";
        }

        # Match negation
        if ($rule =~ s/$reg->{attrN}//) {
            # Now we parse the rest, and after parsing the subexpression
            # has stopped, we must find a matching closing parenthesis:
            if ($rule =~ s/$reg->{attr2}//) {
                push @parts, "[not(", convert_attribute_match( $1, $2, $^N ), ")]";
            } elsif ($rule =~ s/$reg->{attr1}//) {
                push @parts, "[not(\@$1)]";
            } elsif ($rule =~ /$reg->{badattr}/) {
                Carp::croak "Invalid negated attribute-value selector ':not($rule)'";
            } else {
                my( $new_parts, $leftover ) = $self->consume( $rule, %parms );
                shift @$new_parts; # remove '//'
                my $xpath = join '', @$new_parts;

                push @parts, "[not(self::$xpath)]";
                $rule = $leftover;
            }
            $rule =~ s!^\s*\)!!
                or die "Unbalanced parentheses at '$rule'";
        }

        # Ignore pseudoclasses/pseudoelements
        while ($rule =~ s/$reg->{pseudo}//) {
            if ( my @expr = $self->parse_pseudo($1, \$rule) ) {
                push @parts, @expr;
            } elsif ( $1 eq 'disabled') {
                push @parts, '[@disabled]';
            } elsif ( $1 eq 'checked') {
                push @parts, '[@checked]';
            } elsif ( $1 eq 'selected') {
                push @parts, '[@selected]';
            } elsif ( $1 eq 'text') {
                push @parts, '*[@type="text"]';
            } elsif ( $1 eq 'first-child') {
                # Translates to :nth-child(1)
                push @parts, nth_child(1);
            } elsif ( $1 eq 'last-child') {
                push @parts, nth_last_child(1);
            } elsif ( $1 eq 'only-child') {
                push @parts, nth_child(1), nth_last_child(1);
            } elsif ($1 =~ /^lang\($/) {
                $rule =~ s/\s*([\w\-]+)\s*\)//
                    or Carp::croak "Can't parse language part from $rule";
                push @parts, "[\@xml:lang='$1' or starts-with(\@xml:lang, '$1-')]";
            } elsif ($1 =~ /^nth-child\(\s*$/) {
                my( $A, $B ) = consume_An_plus_B(\$rule);
                push @parts, nth_child($A, $B);
            } elsif ($1 =~ /^nth-last-child\(\s*$/) {
                my( $A, $B ) = consume_An_plus_B(\$rule);
                push @parts, nth_last_child($A, $B);
            } elsif ($1 =~ /^first-of-type\s*$/) {
                my $type = $parts[-1];
                push @parts, _generate_child('preceding', $type, 0, 1);

            } elsif ($1 =~ /^nth-of-type\(\s*$/) {
                my( $A, $B ) = consume_An_plus_B(\$rule);
                my $type = $parts[-1];
                push @parts, _generate_child('preceding', $type, $A, $B);

            } elsif ($1 =~ /^last-of-type$/) {
                push @parts, "[last()]";

            # Err?! This one does not really exist in the CSS spec...
            # Why did I add this?
            } elsif ($1 =~ /^contains\($/) {
                if( $rule =~ s/^\s*"([^"]*)"\s*\)// ) {
                    push @parts, qq{[text()[contains(string(.),"$1")]]};
                } elsif( $rule =~ s/^\s*'([^']*)'\s*\)// ) {
                    push @parts, qq{[text()[contains(string(.),"$1")]]};
                } else {
                    return( \@parts, $rule );
                    #die "Malformed string in :contains(): '$rule'";
                };
            } elsif ( $1 eq 'root') {
                # This will give surprising results if you do E > F:root
                $parts[$root_index] = $root;
            } elsif ( $1 eq 'empty') {
                push @parts, "[not(* or text())]";
            } else {
                Carp::croak "Can't translate '$1' pseudo-class";
            }
        }

        # Match combinators (whitespace, >, + and ~)
        if ($rule =~ s/$reg->{combinator}//) {
            my $match = $1;
            if ($match =~ />/) {
                push @parts, "/";
            } elsif ($match =~ /\+/) {
                push @parts, "/following-sibling::*[1]/self::";
            } elsif ($match =~ /\~/) {
                push @parts, "/following-sibling::";
            } elsif ($match =~ /^\s*$/) {
                push @parts, "//"
            } else {
                die "Weird combinator '$match'"
            }

            # new context
            undef $wrote_tag;
        }

        # Match commas
        if ($rule =~ s/$reg->{comma}//) {
            push @parts, " | ", "$root/"; # ending one rule and beginning another
            $root_index = $#parts;
            undef $wrote_tag;
        }
    }
    return \@parts, $rule
}

sub to_xpath {
    my $self = shift;
    my $rule = $self->{expression} or return;
    my %parms = @_;

    my($result,$leftover) = $self->consume( $rule, %parms );
    $leftover
        and die "Invalid rule, couldn't parse '$leftover'";
    return join '', @$result;

}

sub parse_pseudo {
    # nop
}

1;
__END__