File Coverage

blib/lib/Data/CSel.pm
Criterion Covered Total %
statement 206 248 83.0
branch 187 248 75.4
condition 17 44 38.6
subroutine 13 14 92.8
pod 3 3 100.0
total 426 557 76.4


line stmt bran cond sub pod time code
1             package Data::CSel;
2              
3             our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
4             our $DATE = '2021-07-03'; # DATE
5             our $DIST = 'Data-CSel'; # DIST
6             our $VERSION = '0.126'; # VERSION
7              
8 3     3   83650 use 5.020000;
  3         37  
9 3     3   16 use strict;
  3         5  
  3         63  
10 3     3   15 use warnings;
  3         4  
  3         132  
11              
12 3     3   1758 use Code::Includable::Tree::NodeMethods;
  3         7619  
  3         136  
13             #use List::Util qw(first);
14 3     3   26 use Scalar::Util qw(blessed refaddr looks_like_number);
  3         6  
  3         405  
15              
16 3     3   21 use Exporter qw(import);
  3         6  
  3         7175  
17             our @EXPORT_OK = qw(
18             csel
19             csel_each
20             parse_csel
21             );
22              
23             our @CLASS_PREFIXES;
24              
25             our $_i1;
26              
27 0     0   0 sub _fail { die __PACKAGE__.": $_[0] at offset ".pos()."\n" }
28              
29             our $RE =
30             qr{
31             (?&SELECTORS) (?{ $_ = $^R->[1] })
32              
33             (?(DEFINE)
34             (?
35             (?{ [$^R, []] })
36             (?&SELECTOR) # [[$^R, []], $selector]
37             (?{ [$^R->[0][0], [$^R->[1]]] })
38             (?:
39             \s*,\s*
40             (?&SELECTOR)
41             (?{
42             push @{$^R->[0][1]}, $^R->[1];
43             $^R->[0];
44             })
45             )*
46             \s*
47             ) # SELECTORS
48              
49             (?
50             (?{ [$^R, []] })
51             (?&SIMPLE_SELECTOR) # [[$^R, []], $simple_selector]
52             (?{ [$^R->[0][0], [$^R->[1]]] })
53             (?:
54             (\s*>\s*|\s*\+\s*|\s*~\s*|\s+)
55             (?{
56             my $comb = $^N;
57             $comb =~ s/^\s+//; $comb =~ s/\s+$//;
58             $comb = " " if $comb eq '';
59             push @{$^R->[1]}, {combinator=>$comb};
60             $^R;
61             })
62              
63             (?&SIMPLE_SELECTOR)
64             (?{
65             push @{$^R->[0][1]}, $^R->[1];
66             $^R->[0];
67             })
68             )*
69             ) # SELECTOR
70              
71             (?
72             (?:
73             (?:
74             # type selector + optional filters
75             ((?&TYPE_NAME))
76             (?{ [$^R, {type=>$^N}] })
77             (?:
78             (?&FILTER) # [[$^R, $simple_selector], $filter]
79             (?{
80             push @{ $^R->[0][1]{filters} }, $^R->[1];
81             $^R->[0];
82             })
83             (?:
84             \s*
85             (?&FILTER)
86             (?{
87             push @{ $^R->[0][1]{filters} }, $^R->[1];
88             $^R->[0];
89             })
90             )*
91             )?
92             )
93             |
94             (?:
95             # optional type selector + one or more filters
96             ((?&TYPE_NAME))?
97             (?{
98             # XXX sometimes $^N is ' '?
99             my $t = $^N // '*';
100             $t = '*' if $t eq ' ';
101             [$^R, {type=>$t}] })
102             (?&FILTER) # [[$^R, $simple_selector], $filter]
103             (?{
104             push @{ $^R->[0][1]{filters} }, $^R->[1];
105             $^R->[0];
106             })
107             (?:
108             \s*
109             (?&FILTER)
110             (?{
111             push @{ $^R->[0][1]{filters} }, $^R->[1];
112             $^R->[0];
113             })
114             )*
115             )
116             )
117             ) # SIMPLE_SELECTOR
118              
119             (?
120             [A-Za-z_][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*|\*
121             )
122              
123             (?
124             (?{ [$^R, {}] })
125             (
126             (?&ATTR_SELECTOR) # [[$^R0, {}], [$attr, $op, $val]]
127             (?{
128             $^R->[0][1]{type} = 'attr_selector';
129             $^R->[0][1]{attr} = $^R->[1][0];
130             $^R->[0][1]{op} = $^R->[1][1] if defined $^R->[1][1];
131             $^R->[0][1]{value} = $^R->[1][2] if @{ $^R->[1] } > 2;
132             $^R->[0];
133             })
134             |
135             \.((?&TYPE_NAME))
136             (?{
137             $^R->[1]{type} = 'class_selector';
138             $^R->[1]{class} = $^N;
139             $^R;
140             })
141             |
142             \#(\w+)
143             (?{
144             $^R->[1]{type} = 'id_selector';
145             $^R->[1]{id} = $^N;
146             $^R;
147             })
148             |
149             (?&PSEUDOCLASS) # [[$^R, {}], [$pseudoclass, \@args]]
150             (?{
151             $^R->[0][1]{type} = 'pseudoclass';
152             $^R->[0][1]{pseudoclass} = $^R->[1][0];
153             $^R->[0][1]{args} = $^R->[1][1] if @{ $^R->[1] } > 1;
154             $^R->[0];
155             })
156             )
157             ) # FILTER
158              
159             (?
160             \[\s*
161             (?{ [$^R, []] }) # [$^R, [$subjects, $op, $literal]]
162             (?&ATTR_SUBJECTS) # [[$^R, [{name=>$name, args=>$args}, ...]]
163             (?{
164             #use Data::Dmp; say "D:setting subjects: ", dmp $^R->[1];
165             push @{ $^R->[0][1] }, $^R->[1];
166             $^R->[0];
167             })
168              
169             (?:
170             (
171             \s*(?:=~|!~)\s* |
172             \s*(?:!=|<>|>=?|<=?|==?)\s* |
173             \s++(?:eq|ne|lt|gt|le|ge)\s++ |
174             \s+(?:isnt|is|has|hasnt|in|notin)\s+
175             )
176             (?{
177             my $op = $^N;
178             $op =~ s/^\s+//; $op =~ s/\s+$//;
179             $^R->[1][1] = $op;
180             $^R;
181             })
182              
183             (?:
184             (?&LITERAL) # [[$^R0, [$attr, $op]], $literal]
185             (?{
186             push @{ $^R->[0][1] }, $^R->[1];
187             $^R->[0];
188             })
189             |
190             (\w[^\s\]]*) # allow unquoted string
191             (?{
192             $^R->[1][2] = $^N;
193             $^R;
194             })
195             )
196             )?
197             \s*\]
198             ) # ATTR_SELECTOR
199              
200             (?
201             [A-Za-z_][A-Za-z0-9_]*
202             )
203              
204             (?
205             (?{ [$^R, []] }) # [$^R, [name, \@args]]
206             ((?&ATTR_NAME))
207             (?{
208             #say "D:pushing attribute subject: $^N";
209             push @{ $^R->[1] }, $^N;
210             $^R;
211             })
212             (?:
213             # attribute arguments
214             \s*\(\s* (*PRUNE)
215             (?{
216             $^R->[1][1] = [];
217             $^R;
218             })
219             (?:
220             (?&LITERAL)
221             (?{
222             #use Data::Dmp; say "D:pushing argument: ", dmp $^R->[1];
223             push @{ $^R->[0][1][1] }, $^R->[1];
224             $^R->[0];
225             })
226             (?:
227             \s*,\s*
228             (?&LITERAL)
229             (?{
230             #use Data::Dmp; say "D:pushing argument: ", dmp $^R->[1];
231             push @{ $^R->[0][1][1] }, $^R->[1];
232             $^R->[0];
233             })
234             )*
235             )?
236             \s*\)\s*
237             )?
238             ) # ATTR_SUBJECT
239              
240             (?
241             (?{ $_i1 = 0; [$^R, []] })
242             (?&ATTR_SUBJECT) # [[$^R, [$name, \@args]]
243             (?{
244             $_i1++;
245             unless ($_i1 > 1) { # to prevent backtracking from executing tihs code block twice
246             #say "D:pushing subject(1)";
247             push @{ $^R->[0][1] }, {
248             name => $^R->[1][0],
249             (args => $^R->[1][1]) x !!defined($^R->[1][1]),
250             };
251             }
252             $^R->[0];
253             })
254             (?:
255             \s*\.\s*
256             (?{ $_i1 = 0; $^R })
257             (?&ATTR_SUBJECT) # [[$^R, $name, \@args]]
258             (?{
259             $_i1++;
260             unless ($_i1 > 1) { # to prevent backtracking from executing this code block twice
261             #say "D:pushing subject(2)";
262             push @{ $^R->[0][1] }, {
263             name => $^R->[1][0],
264             (args => $^R->[1][1]) x !!defined($^R->[1][1]),
265             };
266             }
267             $^R->[0];
268             })
269             )*
270             ) # ATTR_SUBJECTS
271              
272             (?
273             (?&LITERAL_ARRAY)
274             |
275             (?&LITERAL_NUMBER)
276             |
277             (?&LITERAL_STRING_DQUOTE)
278             |
279             (?&LITERAL_STRING_SQUOTE)
280             |
281             (?&LITERAL_REGEX)
282             |
283             true (?{ [$^R, 1] })
284             |
285             false (?{ [$^R, 0] })
286             |
287             null (?{ [$^R, undef] })
288             ) # LITERAL
289              
290             (?
291             \[\s*
292             (?{ [$^R, []] })
293             (?:
294             (?&LITERAL) # [[$^R, []], $val]
295             (?{ [$^R->[0][0], [$^R->[1]]] })
296             \s*
297             (?:
298             (?:
299             ,\s* (?&LITERAL)
300             (?{ push @{$^R->[0][1]}, $^R->[1]; $^R->[0] })
301             )*
302             |
303             (?: [^,\]]|\z ) (?{ _fail "Expected ',' or '\x5d'" })
304             )
305             )?
306             \s*
307             (?:
308             \]
309             |
310             (?:.|\z) (?{ _fail "Expected closing of array" })
311             )
312             ) # LITERAL_ARRAY
313              
314             (?
315             (
316             -?
317             (?: 0 | [1-9]\d* )
318             (?: \. \d+ )?
319             (?: [eE] [-+]? \d+ )?
320             )
321             (?{ [$^R, 0+$^N] })
322             )
323              
324             (?
325             (
326             "
327             (?:
328             [^\\"]+
329             |
330             \\ [0-7]{1,3}
331             |
332             \\ x [0-9A-Fa-f]{1,2}
333             |
334             \\ ["\\'tnrfbae]
335             )*
336             "
337             )
338             (?{ [$^R, eval $^N] })
339             )
340              
341             (?
342             (
343             '
344             (?:
345             [^\\']+
346             |
347             \\ .
348             )*
349             '
350             )
351             (?{ [$^R, eval $^N] })
352             )
353              
354             (?
355             (
356             /
357             (?:
358             [^/\\]+
359             |
360             \\ .
361             )*
362             /
363             [ims]*
364             )
365             (?{ my $re = eval "qr$^N"; die if $@; [$^R, $re] })
366             )
367              
368             (?
369             [A-Za-z_][A-Za-z0-9_]*(?:-[A-Za-z0-9_]+)*
370             )
371              
372             (?
373             :
374             (?:
375             (?:
376             (has|not)
377             (?{ [$^R, [$^N]] })
378             \(\s*
379             (?:
380             (?&LITERAL)
381             (?{
382             push @{ $^R->[0][1][1] }, $^R->[1];
383             $^R->[0];
384             })
385             |
386             ((?&SELECTORS))
387             (?{
388             push @{ $^R->[0][1][1] }, $^N;
389             $^R->[0];
390             })
391             )
392             \s*\)
393             )
394             |
395             (?:
396             ((?&PSEUDOCLASS_NAME))
397             (?{ [$^R, [$^N]] })
398             (?:
399             \(\s*
400             (?&LITERAL)
401             (?{
402             push @{ $^R->[0][1][1] }, $^R->[1];
403             $^R->[0];
404             })
405             (?:
406             \s*,\s*
407             (?&LITERAL)
408             (?{
409             push @{ $^R->[0][1][1] }, $^R->[1];
410             $^R->[0];
411             })
412             )*
413             \s*\)
414             )?
415             )
416             )
417             ) # PSEUDOCLASS
418             ) # DEFINE
419             }x;
420              
421             sub parse_csel {
422 105     105 1 113053 state $re = qr{\A\s*$RE\s*\z};
423              
424 105         234 local $_ = shift;
425 105         132 local $^R;
426 105 100       173 eval { $_ =~ $re } and return $_;
  105         980  
427 3 50       9 die $@ if $@;
428 3         17 return undef;
429             }
430              
431             sub _uniq_objects {
432 158     158   269 my @uniq;
433             my %mem;
434 158         265 for (@_) {
435 727 100       2186 push @uniq, $_ unless $mem{refaddr($_)}++;
436             }
437 158         533 @uniq;
438             }
439              
440             sub _simpsel {
441 3     3   32 no warnings 'numeric', 'uninitialized';
  3         7  
  3         8048  
442              
443 81     81   246 my ($opts, $simpsel, $is_recursive, @nodes) = @_;
444              
445             #use Data::Dmp; say "D: _simpsel(expr", dmp($simpsel), ", recursive=$is_recursive, nodes=[".join(",",map {$_->{id}} @nodes)."])";
446              
447 81         108 my @res;
448 81 100       167 if ($is_recursive) {
449 78         122 @res = (@nodes, map {Code::Includable::Tree::NodeMethods::descendants($_)} @nodes);
  112         2575  
450             } else {
451 3         7 @res = @nodes;
452             }
453             #say "D: intermediate result (after walk): [".join(",",map {$_->{id}} @res)."]";
454              
455 81 100       14548 unless ($simpsel->{type} eq '*') {
456 22         43 my @fres;
457              
458             my @types_to_match;
459 22   100     30 for (@{ $opts->{class_prefixes} // [] }, @CLASS_PREFIXES) {
  22         119  
460 3 50       15 push @types_to_match, $_ . (/::$/ ? "" : "::") . $simpsel->{type};
461             }
462 22         55 push @types_to_match, $simpsel->{type};
463              
464             ELEM:
465 22         47 for my $o (@res) {
466 187         268 my $ref = ref($o);
467 187         244 for (@types_to_match) {
468 194 100       366 if ($ref eq $_) {
469 71         91 push @fres, $o;
470 71         130 next ELEM;
471             }
472             }
473             }
474 22         60 @res = @fres;
475             }
476              
477 81         188 @res = _uniq_objects(@res);
478             #say "D: intermediate result (after type): [".join(",",map {$_->{id}} @res)."]";
479              
480 81   100     120 for my $f (@{ $simpsel->{filters} // [] }) {
  81         256  
481 66 50       174 last unless @res;
482              
483 66         121 my $type = $f->{type};
484              
485 66 100       213 if ($type eq 'attr_selector') {
    100          
    100          
    50          
486              
487 34         54 my @attrs = @{ $f->{attr} };
  34         64  
488 34         65 my $op = $f->{op};
489 34         54 my $opv = $f->{value};
490              
491 34         43 my @newres;
492             ITEM:
493 34         57 for my $o0 (@res) {
494 168         238 my $o = $o0;
495 168         313 for my $i (0..$#attrs) {
496 175         309 my $attr_name = $attrs[$i]{name};
497 175         231 my $attr_args = $attrs[$i]{args};
498 175 100 100     824 next ITEM unless blessed($o) && $o->can($attr_name);
499 162 50 33     387 if ($attr_args && $i == $#attrs) {
500             # T[meth()] means T[meth() is true]
501 0 0       0 unless ($op) {
502 0         0 $op = 'is';
503 0         0 $opv = 1;
504             }
505 0         0 $o = $o->$attr_name(@$attr_args);
506             } else {
507 162         712 $o = $o->$attr_name;
508             }
509             }
510 155 100       1034 goto PASS unless $op;
511 146         191 my $val = $o;
512              
513 146 100 100     934 if ($op eq '=' || $op eq '==') {
    100 100        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    100          
    50          
514 15 100       34 if (looks_like_number($opv)) {
515 10 100       28 next ITEM unless $val == $opv;
516             } else {
517 5 100       13 next ITEM unless $val eq $opv;
518             }
519             } elsif ($op eq 'eq') {
520 8 100       21 next ITEM unless $val eq $opv;
521             } elsif ($op eq '!=' || $op eq '<>') {
522 15 100       32 if (looks_like_number($opv)) {
523 10 100       26 next ITEM unless $val != $opv;
524             } else {
525 5 100       11 next ITEM unless $val ne $opv;
526             }
527             } elsif ($op eq 'ne') {
528 5 100       13 next ITEM unless $val ne $opv;
529             } elsif ($op eq '>') {
530 10 100       23 if (looks_like_number($opv)) {
531 5 100       14 next ITEM unless $val > $opv;
532             } else {
533 5 100       11 next ITEM unless $val gt $opv;
534             }
535             } elsif ($op eq 'gt') {
536 5 100       14 next ITEM unless $val gt $opv;
537             } elsif ($op eq '>=') {
538 10 100       23 if (looks_like_number($opv)) {
539 5 100       16 next ITEM unless $val >= $opv;
540             } else {
541 5 100       12 next ITEM unless $val ge $opv;
542             }
543             } elsif ($op eq 'ge') {
544 5 100       13 next ITEM unless $val ge $opv;
545             } elsif ($op eq '<') {
546 9 100       19 if (looks_like_number($opv)) {
547 4 100       12 next ITEM unless $val < $opv;
548             } else {
549 5 100       16 next ITEM unless $val lt $opv;
550             }
551             } elsif ($op eq 'lt') {
552 5 100       13 next ITEM unless $val lt $opv;
553             } elsif ($op eq '<=') {
554 9 100       19 if (looks_like_number($opv)) {
555 4 50       11 next ITEM unless $val <= $opv;
556             } else {
557 5 100       14 next ITEM unless $val le $opv;
558             }
559             } elsif ($op eq 'le') {
560 5 100       13 next ITEM unless $val le $opv;
561             } elsif ($op eq 'is') {
562 15 100       32 if (!defined($opv)) {
    100          
563 5 100       12 next ITEM unless !defined($val);
564             } elsif ($opv) {
565 5 100       12 next ITEM unless $val;
566             } else {
567 5 100       11 next ITEM unless !$val;
568             }
569             } elsif ($op eq 'isnt') {
570 15 100       31 if (!defined($opv)) {
    100          
571 5 100       13 next ITEM unless defined($val);
572             } elsif ($opv) {
573 5 100       18 next ITEM unless !$val;
574             } else {
575 5 100       14 next ITEM unless $val;
576             }
577             } elsif ($op eq 'has') {
578 0 0 0     0 next ITEM unless defined $val && ref($val) eq 'ARRAY'
      0        
579             && defined $opv;
580 0 0       0 if (looks_like_number($opv)) {
581 0 0       0 next ITEM unless grep { $_ == $opv } @$val;
  0         0  
582             } else {
583 0 0       0 next ITEM unless grep { $_ eq $opv } @$val;
  0         0  
584             }
585             } elsif ($op eq 'hasnt') {
586 0 0 0     0 next ITEM unless defined $val && ref($val) eq 'ARRAY'
      0        
587             && defined $opv;
588 0 0       0 if (looks_like_number($opv)) {
589 0 0       0 next ITEM if grep { $_ == $opv } @$val;
  0         0  
590             } else {
591 0 0       0 next ITEM if grep { $_ eq $opv } @$val;
  0         0  
592             }
593             } elsif ($op eq 'in') {
594 0 0 0     0 next ITEM unless defined $val && defined $opv &&
      0        
595             ref($opv) eq 'ARRAY';
596 0 0       0 if (looks_like_number($val)) {
597 0 0       0 next ITEM unless grep { $_ == $val } @$opv;
  0         0  
598             } else {
599 0 0       0 next ITEM unless grep { $_ eq $val } @$opv;
  0         0  
600             }
601             } elsif ($op eq 'notin') {
602 0 0 0     0 next ITEM unless defined $val && defined $opv &&
      0        
603             ref($opv) eq 'ARRAY';
604 0 0       0 if (looks_like_number($val)) {
605 0 0       0 next ITEM if grep { $_ == $val } @$opv;
  0         0  
606             } else {
607 0 0       0 next ITEM if grep { $_ eq $val } @$opv;
  0         0  
608             }
609             } elsif ($op eq '=~') {
610 10 100       48 next ITEM unless $val =~ $opv;
611             } elsif ($op eq '!~') {
612 5 100       25 next ITEM unless $val !~ $opv;
613             } else {
614 0         0 die "BUG: Unsupported operator '$op' in attr_selector";
615             }
616              
617 81         190 PASS:
618             # pass all attribute filters, add to new result
619             #say "D: adding to result: ".$o->{id};
620             push @newres, $o0;
621             } # for each item
622 34         98 @res = @newres;
623              
624             } elsif ($type eq 'class_selector') {
625              
626 6         12 my $class = $f->{class};
627              
628 6         10 my @classes_to_match;
629 6   100     10 for (@{ $opts->{class_prefixes} // [] }, @CLASS_PREFIXES) {
  6         28  
630 1 50       9 push @classes_to_match, $_ . (/::$/ ? "" : "::") . $class;
631             }
632 6         14 push @classes_to_match, $class;
633 6         10 my @filtered_res;
634             RES:
635 6         12 for my $res (@res) {
636 45         57 for (@classes_to_match) {
637 47 100       149 if ($res->isa($_)) {
638 15         23 push @filtered_res, $res;
639 15         26 next RES;
640             }
641             }
642             }
643 6         17 @res = @filtered_res;
644              
645             } elsif ($type eq 'id_selector') {
646              
647 6   50     23 my $method = $opts->{id_method} // 'id';
648 6         11 my $id = $f->{id};
649              
650 6 50       10 @res = grep { $_->can($method) && $_->$method eq $id } @res;
  42         333  
651              
652             } elsif ($type eq 'pseudoclass') {
653              
654 20         35 my $pc = $f->{pseudoclass};
655              
656 20 100       156 if ($pc eq 'first') {
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    100          
    50          
    0          
657 1         4 @res = ($res[0]);
658             } elsif ($pc eq 'last') {
659 1         3 @res = ($res[-1]);
660             } elsif ($pc eq 'first-child') {
661 3         9 @res = grep { Code::Includable::Tree::NodeMethods::is_first_child($_) } @res;
  30         799  
662             } elsif ($pc eq 'last-child') {
663 1         3 @res = grep { Code::Includable::Tree::NodeMethods::is_last_child($_) } @res;
  10         270  
664             } elsif ($pc eq 'only-child') {
665 1         3 @res = grep { Code::Includable::Tree::NodeMethods::is_only_child($_) } @res;
  10         267  
666             } elsif ($pc eq 'nth-child') {
667 1         3 @res = grep { Code::Includable::Tree::NodeMethods::is_nth_child($_, $f->{args}[0]) } @res;
  10         275  
668             } elsif ($pc eq 'nth-last-child') {
669 1         3 @res = grep { Code::Includable::Tree::NodeMethods::is_nth_last_child($_, $f->{args}[0]) } @res;
  10         277  
670             } elsif ($pc eq 'first-of-type') {
671 1         3 @res = grep { Code::Includable::Tree::NodeMethods::is_first_child_of_type($_) } @res;
  10         329  
672             } elsif ($pc eq 'last-of-type') {
673 1         3 @res = grep { Code::Includable::Tree::NodeMethods::is_last_child_of_type($_) } @res;
  10         392  
674             } elsif ($pc eq 'only-of-type') {
675 1         3 @res = grep { Code::Includable::Tree::NodeMethods::is_only_child_of_type($_) } @res;
  10         325  
676             } elsif ($pc eq 'nth-of-type') {
677 1         3 @res = grep { Code::Includable::Tree::NodeMethods::is_nth_child_of_type($_, $f->{args}[0]) } @res;
  10         341  
678             } elsif ($pc eq 'nth-last-of-type') {
679 1         4 @res = grep { Code::Includable::Tree::NodeMethods::is_nth_last_child_of_type($_, $f->{args}[0]) } @res;
  10         338  
680             } elsif ($pc eq 'root') {
681 2         4 @res = grep { Code::Includable::Tree::NodeMethods::is_root($_) } @res;
  16         147  
682             } elsif ($pc eq 'has-min-children') {
683 0         0 @res = grep { Code::Includable::Tree::NodeMethods::has_min_children($_, $f->{args}[0]) } @res;
  0         0  
684             } elsif ($pc eq 'has-max-children') {
685 0         0 @res = grep { Code::Includable::Tree::NodeMethods::has_max_children($_, $f->{args}[0]) } @res;
  0         0  
686             } elsif ($pc eq 'has-children-between') {
687 0         0 @res = grep { Code::Includable::Tree::NodeMethods::has_children_between($_, $f->{args}[0], $f->{args}[1]) } @res;
  0         0  
688             } elsif ($pc eq 'empty') {
689 1         3 @res = grep { my @c = Code::Includable::Tree::NodeMethods::_children_as_list($_); !@c } @res;
  10         19  
  10         204  
690             } elsif ($pc eq 'has') {
691             @res = _uniq_objects(
692 2         36 map { reverse Code::Includable::Tree::NodeMethods::ancestors($_) }
693 1         8 csel($opts, $f->{args}[0], @res)
694             );
695             } elsif ($pc eq 'not') {
696             #say "D: res=(".join(",", map {$_->{id}} @res).")";
697 2         13 my @matches = csel($opts, $f->{args}[0], @res);
698             #say "D: all_matches=(".join(",", map {$_->{id}} @all_matches).")";
699 2         4 my %matches_refaddrs;
700 2         4 for (@matches) { $matches_refaddrs{refaddr($_)}++ }
  8         19  
701 2         5 @res = grep { !$matches_refaddrs{refaddr($_)} } @res;
  20         45  
702             } elsif ($pc eq 'parent') {
703 0         0 @res = _uniq_objects(map { Code::Includable::Tree::NodeMethods::retrieve_parent($_) } @res);
  0         0  
704             } else {
705 0         0 die "Unsupported pseudo-class '$pc'";
706             }
707              
708             }
709              
710             #say "D: intermediate result (after filter): [".join(",",map {$_->{id}} @res)."]";
711             } # for each filter
712 81         722 @res;
713             }
714              
715             sub _sel {
716 77     77   175 my ($opts, $sel, @nodes) = @_;
717              
718 77         129 my @simpsels = @$sel;
719 77         102 my @res;
720              
721 77         115 my $i = 0;
722 77         173 while (@simpsels) {
723 81 100       184 if ($i++ == 0) {
724 77         131 my $simpsel = shift @simpsels;
725 77         186 @res = _simpsel($opts, $simpsel, 1, @nodes);
726             } else {
727 4         9 my $combinator = shift @simpsels;
728 4         6 my $simpsel = shift @simpsels;
729 4 50       11 last unless @res;
730 4 100       21 if ($combinator->{combinator} eq ' ') { # descendant
    100          
    100          
    50          
731             @res = _simpsel($opts, $simpsel, 1,
732 1         3 map { Code::Includable::Tree::NodeMethods::_children_as_list($_) } @res);
  5         117  
733             } elsif ($combinator->{combinator} eq '>') { # child
734             @res = _simpsel($opts, $simpsel, 0,
735 1         4 map { Code::Includable::Tree::NodeMethods::_children_as_list($_) } @res);
  5         80  
736             } elsif ($combinator->{combinator} eq '~') { # sibling
737             @res = _simpsel($opts, $simpsel, 0,
738 1         3 map { Code::Includable::Tree::NodeMethods::next_siblings($_) } @res);
  5         151  
739             } elsif ($combinator->{combinator} eq '+') { # adjacent sibling
740             @res = _simpsel($opts, $simpsel, 0,
741 5         48 grep {defined}
742 1         4 map { Code::Includable::Tree::NodeMethods::next_sibling($_) }
  5         130  
743             @res);
744             } else {
745 0         0 die "BUG: Unknown combinator '$combinator->{combinator}'";
746             }
747             }
748             }
749              
750 77         255 @res;
751             }
752              
753             sub csel {
754 76     76 1 211132 my $opts;
755 76 100       238 if (ref($_[0]) eq 'HASH') {
756 75         149 $opts = shift;
757             } else {
758 1         2 $opts = {};
759             }
760 76         121 my $expr = shift;
761 76         139 my @nodes = @_;
762              
763 76         180 my $pexpr = parse_csel($expr);
764 76 50       258 $pexpr or die "Invalid CSel expression '$expr'";
765              
766 76 50       174 local $Code::Includable::Tree::NodeMethods::GET_PARENT_METHOD = $opts->{get_parent_method} if $opts->{get_parent_method};
767 76 50       145 local $Code::Includable::Tree::NodeMethods::SET_PARENT_METHOD = $opts->{set_parent_method} if $opts->{set_parent_method};
768 76 50       142 local $Code::Includable::Tree::NodeMethods::GET_CHILDREN_METHOD = $opts->{get_children_method} if $opts->{get_children_method};
769 76 50       169 local $Code::Includable::Tree::NodeMethods::SET_CHILDREN_METHOD = $opts->{set_children_method} if $opts->{set_children_method};
770              
771 76         164 my @res = _uniq_objects(map { _sel($opts, $_, @nodes) } @$pexpr );
  77         190  
772              
773 76 50       170 if ($opts->{wrap}) {
774 0         0 require Data::CSel::Selection;
775 0         0 return Data::CSel::Selection->new(\@res);
776             } else {
777 76         349 return @res;
778             }
779             }
780              
781             sub csel_each(&;@) {
782 1     1 1 829 my $cb = shift;
783 1         5 for my $node (csel(@_)) {
784 3         25 local $_ = $node;
785 3         9 $cb->($_);
786             }
787 1         8 undef;
788             }
789              
790             1;
791             # ABSTRACT: Select tree node objects using CSS Selector-like syntax
792              
793             __END__