X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FHTML%2FZoom%2FSelectorParser.pm;h=48545ffd16c4b19c49d3d471bf9e5a41abd83696;hb=f7dc3b611fcb491ad708b7f71347d36bad71fb1c;hp=9b3d5dcd7685eff32979da9824c0a03aed38099f;hpb=7084f73fe418998647664323a2d1b77c8e6c7e71;p=catagits%2FHTML-Zoom.git

diff --git a/lib/HTML/Zoom/SelectorParser.pm b/lib/HTML/Zoom/SelectorParser.pm
index 9b3d5dc..48545ff 100644
--- a/lib/HTML/Zoom/SelectorParser.pm
+++ b/lib/HTML/Zoom/SelectorParser.pm
@@ -7,6 +7,8 @@ use Carp qw(confess);
 
 my $sel_char = '-\w_';
 my $sel_re = qr/([$sel_char]+)/;
+my $match_value_re = qr/"?$sel_re"?/;
+
 
 sub new { bless({}, shift) }
 
@@ -18,141 +20,124 @@ sub _raw_parse_simple_selector {
     /\G\*/gc and
       return sub { 1 };
 
-     # 'el[attr~="foo"]
+    # 'element' - match on tag name
 
-    /\G$sel_re\[$sel_re~="$sel_re"\]/gc and
+    /\G$sel_re/gc and
       return do {
         my $name = $1;
-        my $attr = $2;
-        my $val = $3;
-        sub {
-          if (
-            $_[0]->{name} && $_[0]->{name} eq $name and
-            $_[0]->{attrs}{$attr}
-          ) {
-            my %vals = map { $_ => 1 } split /\s+/, $_[0]->{attrs}{$attr};
-            return $vals{$val}
-          }
-          return undef
-        }
+        sub { $_[0]->{name} && $_[0]->{name} eq $name }
       };
 
-     # 'el[attr^="foo"]
+    # '#id' - match on id attribute
 
-    /\G$sel_re\[$sel_re\^="$sel_re"\]/gc and
+    /\G#$sel_re/gc and
       return do {
-        my $name = $1;
-        my $attr = $2;
-        my $val = $3;
-        sub {
-           $_[0]->{name} && $_[0]->{name} eq $name and
-           $_[0]->{attrs}{$attr} && $_[0]->{attrs}{$attr} =~ /^\Q$val\E/
-        }
+        my $id = $1;
+        sub { $_[0]->{attrs}{id} && $_[0]->{attrs}{id} eq $id }
       };
 
-     # 'el[attr$="foo"]
+    # '.class1.class2' - match on intersection of classes
 
-    /\G$sel_re\[$sel_re\$="$sel_re"\]/gc and
+    /\G((?:\.$sel_re)+)/gc and
       return do {
-        my $name = $1;
-        my $attr = $2;
-        my $val = $3;
+        my $cls = $1; $cls =~ s/^\.//;
+        my @cl = split(/\./, $cls);
         sub {
-           $_[0]->{name} && $_[0]->{name} eq $name and
-           $_[0]->{attrs}{$attr} && $_[0]->{attrs}{$attr} =~ /\Q$val\E$/
+          $_[0]->{attrs}{class}
+          && !grep $_[0]->{attrs}{class} !~ /(^|\s+)$_($|\s+)/, @cl
         }
       };
 
-     # 'el[attr*="foo"]
-
-    /\G$sel_re\[$sel_re\*="$sel_re"\]/gc and
+    # '[attr^=foo]' - match attribute with ^ anchored regex
+    /\G\[$sel_re\^=$match_value_re\]/gc and
       return do {
-        my $name = $1;
-        my $attr = $2;
-        my $val = $3;
+        my $attribute = $1;
+        my $value = $2;
         sub {
-           $_[0]->{name} && $_[0]->{name} eq $name and
-           $_[0]->{attrs}{$attr} && $_[0]->{attrs}{$attr} =~ /\Q$val\E/
+          $_[0]->{attrs}{$attribute}
+          && $_[0]->{attrs}{$attribute} =~ qr/^\Q$value\E/;
         }
       };
 
-     # 'el[attr="foo"]
-
-    /\G$sel_re\[$sel_re="$sel_re"\]/gc and
+    # '[attr$=foo]' - match attribute with $ anchored regex
+    /\G\[$sel_re\$=$match_value_re\]/gc and
       return do {
-        my $name = $1;
-        my $attr = $2;
-        my $val = $3;
+        my $attribute = $1;
+        my $value = $2;
         sub {
-           $_[0]->{name} && $_[0]->{name} eq $name and
-           $_[0]->{attrs}{$attr} && $_[0]->{attrs}{$attr} eq $val
+          $_[0]->{attrs}{$attribute}
+          && $_[0]->{attrs}{$attribute} =~ qr/\Q$value\E$/;
         }
       };
 
-     # 'el[attr]
-
-    /\G$sel_re\[$sel_re\]/gc and
+    # '[attr*=foo] - match attribute with regex:
+    /\G\[$sel_re\*=$match_value_re\]/gc and
       return do {
-        my $name = $1;
-        my $attr = $2;
+        my $attribute = $1;
+        my $value = $2;
         sub {
-           $_[0]->{name} && $_[0]->{name} eq $name && $_[0]->{attrs}{$attr}
+          $_[0]->{attrs}{$attribute}
+          && $_[0]->{attrs}{$attribute} =~ qr/\Q$value\E/;
         }
       };
 
-    # 'element' - match on tag name
-
-    /\G$sel_re/gc and
+    # '[attr~=bar]' - match attribute contains word
+    /\G\[$sel_re~=$match_value_re\]/gc and
       return do {
-        my $name = $1;
-        sub { $_[0]->{name} && $_[0]->{name} eq $name }
+        my $attribute = $1;
+        my $value = $2;
+        sub {
+          $_[0]->{attrs}{$attribute}
+          && $_[0]->{attrs}{$attribute} =~ qr/\b\Q$value\E\b/;
+        }
       };
 
-    # '#id' - match on id attribute
-
-    /\G#$sel_re/gc and
+    # '[attr!=bar]' - match attribute contains prefix (for language matches)
+    /\G\[$sel_re\|=$match_value_re\]/gc and
       return do {
-        my $id = $1;
-        sub { $_[0]->{attrs}{id} && $_[0]->{attrs}{id} eq $id }
+        my $attribute = $1;
+        my $value = $2;
+        sub {
+          $_[0]->{attrs}{$attribute}
+          && $_[0]->{attrs}{$attribute} =~ qr/^\Q$value\E(?:-|$)/;
+        }
       };
 
-    # '.class1.class2' - match on intersection of classes
-
-    /\G((?:\.$sel_re)+)/gc and
+    # '[attr=bar]' - match attributes
+    /\G\[$sel_re=$match_value_re\]/gc and
       return do {
-        my $cls = $1; $cls =~ s/^\.//;
-        my @cl = split(/\./, $cls);
+        my $attribute = $1;
+        my $value = $2;
         sub {
-          $_[0]->{attrs}{class}
-          && !grep $_[0]->{attrs}{class} !~ /(^|\s+)$_($|\s+)/, @cl
+          $_[0]->{attrs}{$attribute}
+          && $_[0]->{attrs}{$attribute} eq $value;
         }
       };
 
-    # 'el.class1' - element + class
-
-    /\G$sel_re\.$sel_re/gc and
+    # '[attr!=bar]' - attributes doesn't match
+    /\G\[$sel_re!=$match_value_re\]/gc and
       return do {
-        my $cls = $1;
-        my $name = $2;
+        my $attribute = $1;
+        my $value = $2;
         sub {
-           $_[0]->{name} && $_[0]->{name} eq $name and
-           $_[0]->{attrs}{class} && $_[0]->{attrs}{class} eq $cls
+          ! ($_[0]->{attrs}{$attribute}
+          && $_[0]->{attrs}{$attribute} eq $value);
         }
       };
 
-    # 'el#id' - element + id
-
-    /\G$sel_re#$sel_re/gc and
+    # '[attr]' - match attribute being present:
+    /\G\[$sel_re\]/gc and
       return do {
-        my $id = $1;
-        my $name = $2;
+        my $attribute = $1;
         sub {
-           $_[0]->{name} && $_[0]->{name} eq $name and
-           $_[0]->{attrs}{id} && $_[0]->{attrs}{id} eq $id
+          exists $_[0]->{attrs}{$attribute};
         }
-      };
+    };
+    
+    # none of the above matched, try catching some obvious errors:
 
-    confess "Couldn't parse $_ as starting with simple selector";
+    # indicate unmatched square bracket:
+    /\G\[[^\]]*/gc and $_[0]->_blam('Unmatched [');
   }
 }
 
@@ -164,10 +149,40 @@ sub parse_selector {
   for ($sel) {
     my @sub;
     PARSE: { do {
-      push(@sub, $self->_raw_parse_simple_selector($_));
-      last PARSE if (pos == length);
-      /\G\s*,\s*/gc or confess "Selectors not comma separated";
-    } until (pos == length) };
+
+      my @this_chain;
+
+      # slurp selectors until we find something else:
+      while( my $sel = $self->_raw_parse_simple_selector($_) ){
+        push @this_chain, $sel;
+      }
+
+      if( @this_chain == 1 )
+      {
+        push @sub, @this_chain;
+      }
+      else{
+        # make a compound match closure of everything
+        # in this chain of selectors:
+        push @sub, sub{
+          my $r;
+          for my $inner ( @this_chain ){
+            if( ! ($r = $inner->( @_ )) ){
+              return $r;
+            }
+          }
+          return $r;
+        }
+      }
+
+      # now we're at the end or a delimiter:
+      last PARSE if( pos == length );
+      /\G\s*,\s*/gc or do {
+        /\G(.*)/;
+        $self->_blam( "Selectors not comma separated." );
+      }
+
+     } until (pos == length) };
     return $sub[0] if (@sub == 1);
     return sub {
       foreach my $inner (@sub) {
@@ -178,4 +193,12 @@ sub parse_selector {
 }
 
 
+sub _blam {
+  my ($self, $error) = @_;
+  my $hat = (' ' x (pos||0)).'^';
+  die "Error parsing dispatch specification: ${error}\n
+${_}
+${hat} here\n";
+}
+
 1;