File Coverage

blib/lib/Pod/Query.pm
Criterion Covered Total %
statement 314 358 87.7
branch 139 204 68.1
condition 56 81 69.1
subroutine 35 37 94.5
pod 7 7 100.0
total 551 687 80.2


line stmt bran cond sub pod time code
1             package Pod::Query;
2              
3 7     7   363922 use v5.16;
  7         47  
4 7     7   52 use strict;
  7         15  
  7         141  
5 7     7   28 use warnings;
  7         10  
  7         154  
6 7     7   3102 use Pod::Text();
  7         247190  
  7         167  
7 7     7   2818 use Pod::LOL();
  7         44250  
  7         166  
8 7     7   2538 use File::Spec::Functions qw( catfile );
  7         3750  
  7         419  
9 7     7   40 use List::Util qw( first );
  7         13  
  7         612  
10 7     7   2605 use Text::ParseWords qw( parse_line );
  7         6931  
  7         324  
11 7     7   2323 use Term::Size::Any qw( chars );
  7         1221  
  7         36  
12              
13             =head1 NAME
14              
15             Pod::Query - Query pod documents
16              
17             =head1 VERSION
18              
19             Version 0.36
20              
21             =cut
22              
23             our $VERSION = '0.36';
24             our $DEBUG_LOL_DUMP = 0;
25             our $DEBUG_STRUCT_OVER = 0;
26             our $DEBUG_TREE = 0;
27             our $DEBUG_TREE_DUMP = 0;
28             our $DEBUG_FIND_CONDITIONS = 0;
29             our $DEBUG_FIND_AFTER_DEFAULTS = 0;
30             our $DEBUG_PRE_FIND_DUMP = 0;
31             our $DEBUG_FIND = 0;
32             our $DEBUG_FIND_DUMP = 0;
33             our $DEBUG_INVERT = 0;
34             our $DEBUG_RENDER = 0;
35             our $MOCK_ROOT = 0;
36              
37             =head1 SYNOPSIS
38              
39             Query POD information from a file
40              
41             % perl -MPod::Query -E 'say for Pod::Query->new("ojo")->find("head1[0]")'
42              
43             NAME
44             ojo - Fun one-liners with Mojo
45              
46             % perl -MPod::Query -E 'say Pod::Query->new("ojo")->find("head1[0]/Para[0]")'
47              
48             ojo - Fun one-liners with Mojo
49              
50             % perl -MPod::Query -E 'say Pod::Query->new(shift)->find("head1[0]/Para[0]")' my.pod
51              
52             Find Methods:
53              
54             find_title;
55             find_method;
56             find_method_summary;
57             find_events;
58             find($query_sting);
59             find(@query_structs);
60              
61             =head1 DESCRIPTION
62              
63             This module takes a class name, extracts the POD
64             and provides methods to query specific information.
65              
66             =head1 SUBROUTINES/METHODS
67              
68             =cut
69              
70             #
71             # Method maker
72             #
73              
74             =head2 _has
75              
76             Generates class accessor methods (like Mojo::Base::attr)
77              
78             =cut
79              
80             sub _has {
81 7     7   7870 no strict 'refs';
  7         12  
  7         23578  
82 7     7   18 for my $attr ( @_ ) {
83             *$attr = sub {
84 155 100   155   477 return $_[0]{$attr} if @_ == 1; # Get: return $self-<{$attr}
85 27         63 $_[0]{$attr} = $_[1]; # Set: $self->{$attr} = $val
86 27         46 $_[0]; # return $self
87 28         167 };
88             }
89             }
90              
91             =head2 path
92              
93             Path to the pod class file
94              
95             =head2 lol
96              
97             List of lists (LOL) structure of the pod file.
98             Result of Pod::LOL.
99              
100             =head2 tree
101              
102             An hierarchy is added to the lol to create a
103             tree like structure of the pod file.
104              
105             =head2 class_is_path
106              
107             Flag to indicate if the class is really a path to the file.
108              
109             =cut
110              
111             sub import {
112 7     7   95 _has qw(
113             path
114             lol
115             tree
116             class_is_path
117             );
118             }
119              
120             #
121             # Debug
122             #
123              
124             sub _dumper {
125 0     0   0 require Data::Dumper;
126 0         0 my $data = Data::Dumper
127             ->new( [@_] )
128             ->Indent( 1 )
129             ->Sortkeys( 1 )
130             ->Terse( 1 )
131             ->Useqq( 1 )
132             ->Dump;
133 0 0       0 return $data if defined wantarray;
134 0         0 say $data;
135             }
136              
137             =head2 new
138              
139             Create a new object.
140             Return value is cached (based on the class of the pod file).
141              
142             use Pod::Query;
143             my $pod = Pod::Query->new('Pod::LOL', PATH_ONLY=0);
144              
145             PATH_ONLY can be used to determine the path to the pod
146             document without having to do much unnecessary work.
147              
148             =cut
149              
150             sub new {
151 9     9 1 6804 my ( $class, $pod_class, $path_only ) = @_;
152 9   50     39 $path_only //= 0;
153 9         9 state %CACHE;
154              
155 9         11 my $cached;
156 9 50       19 return $cached if $cached = $CACHE{$pod_class};
157              
158 9         24 my $s = bless {
159             pod_class => $pod_class,
160             lol => [],
161             tree => [],
162             }, $class;
163              
164 9         20 $s->path( $s->_class_to_path( $pod_class ) );
165              
166 9 50 33     27 return $s if $path_only or not $s->path;
167              
168 9 50       24 my $lol = $MOCK_ROOT ? _mock_root() : Pod::LOL->new_root( $s->path );
169 9         707 $lol = _flatten_for_tags( $lol );
170 9 50       23 if ( $DEBUG_LOL_DUMP ) {
171 0         0 say "DEBUG_LOL_DUMP: " . _dumper $lol;
172 0         0 exit;
173             }
174              
175 9         21 $s->lol( $lol );
176 9         17 $s->tree( _lol_to_tree( $lol ) );
177 9 50       17 if ( $DEBUG_TREE_DUMP ) {
178 0         0 say "DEBUG_TREE_DUMP: " . _dumper $s->tree();
179 0         0 exit;
180             }
181              
182 9         17 $CACHE{$pod_class} = $s;
183              
184 9         37 $s;
185             }
186              
187             =head2 _class_to_path
188              
189             Given a class name, returns the path to the pod file.
190             Return value is cached (based on the class of the pod file).
191              
192             If the class is not found in INC, it will be checked whether
193             the input is an existing file path.
194              
195             Returns an empty string if there are any errors.
196              
197             =cut
198              
199             sub _class_to_path {
200 4     4   2182 my ( $s, $pod_class ) = @_;
201 4         4 state %CACHE;
202 4         5 my $path;
203              
204 4 50       9 return $path if $path = $CACHE{$pod_class};
205              
206 4         15 my $partial_path = catfile( split /::/, $pod_class ) . '.pm';
207              
208             # Shortcut for files already used.
209 4         7 $path = $INC{$partial_path};
210 4 50 33     10 return $CACHE{$pod_class} = $path if $path and -f $path;
211              
212             # Otherwise find it ourselves.
213 4         5 for ( @INC ) {
214 22         82 $path = catfile( $_, $partial_path );
215 22 100 66     260 return $CACHE{$pod_class} = $path if $path and -f $path;
216             }
217              
218             # Check for it in PATH also.
219             # Maybe pod_class is the path.
220 2         10 for ( "", split /:/, $ENV{PATH} ) {
221              
222             # Absolute path or current folder means class is path.
223 11 100 66     49 $path = ( $_ and $_ ne "." ) ? catfile( $_, $pod_class ) : $pod_class;
224 11 100 66     94 if ( $path and -f $path ) {
225 1 50       4 $s->class_is_path( 1 ) if ref $s;
226 1         5 return $CACHE{$pod_class} = $path;
227             }
228             }
229              
230 1         4 return "";
231             }
232              
233             =head2 _mock_root
234              
235             For debugging and/or testing.
236             Builds a sample object (overwrite this in a test file).
237              
238             =cut
239              
240       0     sub _mock_root { }
241              
242             =head2 _flatten_for_tags
243              
244             Removes for tags from the lol and flattens
245             out the inner tags to be on the same level as the for
246             tag was.
247              
248             =cut
249              
250             sub _flatten_for_tags {
251 9     9   15 my ( $lol ) = @_;
252 9         12 my @flat;
253              
254 9         16 for ( @$lol ) {
255 322         375 my ( $tag, @data ) = @$_;
256 322   50     344 $tag //= '';
257              
258 322 50       395 push @flat, ( $tag eq "for" ) ? @data : $_;
259             }
260              
261 9         19 \@flat;
262             }
263              
264             =head2 _lol_to_tree
265              
266             Generates a tree from a Pod::LOL object.
267             The structure of the tree is based on the N (level) in "=headN".
268              
269             This example pod:
270              
271             =head1 FUNCTIONS
272              
273             =Para Description of Functions
274              
275             =head2 Function1
276              
277             =Para Description of Function1
278              
279             =head1 AUTHOR
280              
281             =cut
282              
283             This will be grouped as:
284              
285             =head1 FUNCTIONS
286             =Para Description of Functions
287             =head2 Function1
288             =Para Description of Function1
289             =head1 AUTHOR
290              
291             In summary:
292              
293             =over 2
294              
295             =item *
296              
297             Non "head" tags are always grouped "below".
298              
299             =item *
300              
301             HeadN tags with a higher N with also be grouped below.
302              
303             =item *
304              
305             HeadN tags with the same or lower N will be grouped higher.
306              
307             =back
308              
309             =cut
310              
311             sub _lol_to_tree {
312 14     14   20 my ( $lol ) = @_;
313 14         16 my ( $is_in, $is_out );
314 14         36 my %heads_table = __PACKAGE__->_define_heads_regex_table();
315 14         34 my $is_head = qr/ ^ head (\d) $ /x;
316 14         21 my $node = {};
317 14         15 my @tree;
318              
319             my $push = sub { # push to tree.
320 107 100   107   145 return if not %$node;
321 93         84 my $kids = $node->{kids};
322             $node->{kids} = _lol_to_tree( $kids )
323 93 100 100     347 if ref( $kids ) && first { $_->{tag} =~ /$is_head/ } @$kids;
  238         524  
324 93         174 push @tree, $node;
325 93         113 $node = {};
326 14         47 };
327              
328 14 50       48 say "\n_ROOT_TO_TREE()" if $DEBUG_TREE;
329              
330 14         23 for ( $lol->@* ) {
331 545 50       661 say "\n_=", _dumper $_ if $DEBUG_TREE;
332              
333 545         566 my $leaf = _make_leaf( $_ );
334 545 50       662 say "\nleaf=", _dumper $leaf if $DEBUG_TREE;
335              
336             # Outer tag.
337 545 100 100     1628 if ( not $is_in or $leaf->{tag} =~ /$is_out/ ) {
338 93         175 $push->();
339 93         98 $node = $leaf;
340 93 100       286 if ( $leaf->{tag} =~ /$is_head/ ) {
341 88         204 ( $is_in, $is_out ) = $heads_table{$1}->@*;
342             }
343             }
344             else {
345 452         560 push $node->{kids}->@*, $leaf;
346 452 50       623 say "node: ", _dumper $node if $DEBUG_TREE;
347             }
348             }
349              
350 14         25 $push->();
351              
352 14         122 \@tree;
353             }
354              
355             =head2 _define_heads_regex_table
356              
357             Generates the regexes for head elements inside
358             and outside the current head.
359              
360             =cut
361              
362             sub _define_heads_regex_table {
363             map {
364 14     14   25 my $inner = join "", $_ + 1 .. 5; # num=2, inner=345
  56         130  
365 56         98 my $outer = join "", 0 .. $_; # num=2, outer=012
366              
367 56         70 $_ => [ map { qr/ ^ head ([$_]) $ /x } $inner, $outer ]
  112         1129  
368             } 1 .. 4;
369             }
370              
371             =head2 _make_leaf
372              
373             Creates a new node (aka leaf).
374              
375             =cut
376              
377             sub _make_leaf {
378 545     545   546 my ( $node ) = @_;
379 545 100       877 return $node if ref $node eq ref {};
380              
381 322         491 my ( $tag, @text ) = @$node;
382 322         457 my $leaf = { tag => $tag };
383              
384 322 100       416 if ( $tag =~ / ^ over- /x ) {
385 7         11 $leaf->{kids} = _structure_over( \@text );
386 7         11 $leaf->{text} = "";
387             }
388             else {
389 315         656 $leaf->{text} = join "", @text;
390             }
391              
392 322         421 $leaf;
393             }
394              
395             =head2 _structure_over
396              
397             Restructures the text for an "over-text" element to be under it.
398             Also, "item-text" will be the first element of each group.
399              
400             =cut
401              
402             sub _structure_over {
403 7     7   8 my ( $text_list ) = @_;
404 7         8 my @struct;
405             my @nodes;
406              
407             my $push = sub {
408 74 100   74   100 return if not @nodes;
409              
410             # First is the parent node.
411 67         68 my $item_text = shift @nodes;
412              
413             # Treat the rest of the tags as kids.
414 67 100       237 push @struct,
415             { %$item_text, @nodes ? ( kids => [ splice @nodes ] ) : (), };
416 7         25 };
417              
418 7         11 for ( @$text_list ) {
419 242         345 my ( $tag, @text ) = @$_;
420 242 100       379 $push->() if $tag =~ / ^ item- /x;
421 242         634 push @nodes,
422             {
423             tag => $tag,
424             text => join( "", @text ),
425             };
426             }
427              
428 7         16 $push->();
429              
430 7 50       15 if ( $DEBUG_STRUCT_OVER ) {
431 0         0 say "DEBUG_STRUCT_OVER-IN: " . _dumper $text_list;
432 0         0 say "DEBUG_STRUCT_OVER-OUT: " . _dumper \@struct;
433             }
434              
435 7         20 \@struct;
436             }
437              
438             =head2 find_title
439              
440             Extracts the title information.
441              
442             =cut
443              
444             sub find_title {
445 9     9 1 91552 my ( $s ) = @_;
446 9         23 scalar $s->find( 'head1=NAME[0]/Para[0]' );
447             }
448              
449             =head2 find_method
450              
451             Extracts the complete method information.
452              
453             =cut
454              
455             sub find_method {
456 10     10 1 4599 my ( $s, $method ) = @_;
457 10 50       36 my $m = $s->_clean_method_name( $method ) or return "";
458              
459 10         54 $s->find( sprintf '~head=~^%s\b.*$[0]**', $m );
460             }
461              
462             =head2 find_method_summary
463              
464             Extracts the method summary.
465              
466             =cut
467              
468             sub find_method_summary {
469 10     10 1 2259 my ( $s, $method ) = @_;
470 10 50       16 my $m = $s->_clean_method_name( $method ) or return "";
471              
472 10         39 scalar $s->find( sprintf '~head=~^%s\b.*$[0]/~(Data|Para)[0]', $m );
473             }
474              
475             =head2 _clean_method_name
476              
477             Returns a method name without any possible parenthesis.
478              
479             =cut
480              
481             sub _clean_method_name {
482 20     20   30 my ( $s, $name ) = @_;
483 20         50 my $safe_start = qr/ ^ [\w_] /x;
484 20         35 my $safe_end = qr/ [\w_()] $ /x;
485 20 50       93 return if $name !~ $safe_start;
486 20 50       58 return if $name !~ $safe_end;
487              
488 20         54 my $clean = quotemeta( $name =~ s/[^a-zA-Z0-9_]+//gr );
489 20 50       54 return if $clean !~ $safe_start;
490              
491 20         55 $clean;
492             }
493              
494             =head2 find_events
495              
496             Extracts a list of events with a description.
497              
498             Returns a list of key value pairs.
499              
500             =cut
501              
502             sub find_events {
503 6     6 1 1482 my ( $s ) = @_;
504 6         12 $s->find( '~head=EVENTS[0]/~head*/(Para)[0]' );
505             }
506              
507             =head2 find
508              
509             Generic extraction command.
510              
511             Note: This function is Scalar/List context sensitive!
512              
513             $query->find($condition)
514              
515             Where condtion is a string as described in L
516              
517             $query->find(@conditions)
518              
519             Where each condition can contain:
520              
521             {
522             tag => "TAG_NAME", # Find all matching tags.
523             text => "TEXT_NAME", # Find all matching texts.
524             keep => 1, # Capture the text.
525             keep_all => 1, # Capture entire section.
526             nth => 0, # Use only the nth match.
527             nth_in_group => 0, # Use only the nth matching group.
528             }
529              
530             Return contents of entire head section:
531              
532             find (
533             {tag => "head", text => "a", keep_all => 1},
534             )
535              
536             Results:
537              
538             [
539             " my \$app = a('/hel...",
540             {text => "Create a route with ...", wrap => 1},
541             " \$ perl -Mojo -E ...",
542             ]
543              
544             =cut
545              
546             sub find {
547 123     123 1 47784 my ( $s, @raw_conditions ) = @_;
548              
549 123         133 my $find_conditions;
550              
551             # If the find condition is a single string.
552 123 50 33     468 if ( @raw_conditions == 1 and not ref $raw_conditions[0] ) {
553 123         221 $find_conditions = $s->_query_string_to_struct( $raw_conditions[0] );
554             }
555             else {
556 0         0 $find_conditions = \@raw_conditions;
557             }
558 123 50       239 say "DEBUG_FIND_CONDITIONS: " . _dumper $find_conditions
559             if $DEBUG_FIND_CONDITIONS;
560              
561 123         215 _check_conditions( $find_conditions );
562 119         187 _set_condition_defaults( $find_conditions );
563 119 50       180 say "DEBUG_FIND_AFTER_DEFAULTS " . _dumper $find_conditions
564             if $DEBUG_FIND_AFTER_DEFAULTS;
565              
566 119         221 my @tree = $s->tree->@*;
567 119         137 my $kept_all;
568 119 50       188 if ( $DEBUG_PRE_FIND_DUMP ) {
569 0         0 say "DEBUG_PRE_FIND_DUMP: " . _dumper \@tree;
570 0         0 exit;
571             }
572              
573 119         168 for ( @$find_conditions ) {
574 206         334 @tree = _find( $_, @tree );
575 206 100       370 if ( $_->{keep_all} ) {
576 18         22 $kept_all++;
577 18         21 last;
578             }
579             }
580 119 50       163 if ( $DEBUG_FIND_DUMP ) {
581 0         0 say "DEBUG_FIND_DUMP: " . _dumper \@tree;
582 0 0       0 exit if $DEBUG_FIND_DUMP > 1;
583             }
584              
585 119 100       171 if ( not $kept_all ) {
586 101         153 @tree = _invert( @tree );
587             }
588              
589 119         185 _render( $kept_all, @tree );
590             }
591              
592             =head2 _query_string_to_struct
593              
594             Convert a pod query string into a structure based on these rules:
595              
596             1. Split string by '/'.
597             Each piece is a separate list of conditions.
598              
599             2. Remove an optional '*' or '**' from the last condition.
600             Keep is set if we have '*'.
601             Keep all is set if we have '**'.
602              
603             3. Remove an optional [N] from the last condition.
604             (Where N is a decimal).
605             Set nth base on 'N'.
606             Set nth_in_group if previous word is surrounded by ():
607             (WORD)[N]
608              
609             4. Double and single quotes are removed from the ends (if matching).
610              
611             5. Split each list of conditions by "=".
612             First word is the tag.
613             Second word is the text (if any).
614             If either starts with a tilde, then the word:
615             - is treated like a pattern.
616             - is case Insensitive.
617              
618             Precedence:
619             If quoted and ~, left wins:
620             ~"head1" => qr/"head"/,
621             "~head1" => qr/head/,
622              
623             =cut
624              
625             sub _query_string_to_struct {
626 196     196   25568 my ( $s, $query_string ) = @_;
627 196         508 my $is_nth = qr/ \[ (-?\d+) \] $ /x;
628 196         749 my $is_nth_in_group = qr/ ^ \( (.+) \) $is_nth /x;
629 196         341 my $is_keep = qr/ \* $ /x;
630 196         302 my $is_keep_all = qr/ \* \* $ /x;
631              
632             my @query_struct =
633             map {
634 316         545 my @condition = parse_line( '=', "1", $_ );
635 316         17159 my $set = {};
636              
637             # Set flags based on last condition.
638 316         473 for ( $condition[-1] ) {
639 316 100       1241 if ( s/$is_keep_all// ) {
    100          
640 25         53 $set->{keep_all}++;
641             }
642             elsif ( s/$is_keep// ) {
643 28         54 $set->{keep}++;
644             }
645              
646 316 100       1471 if ( s/$is_nth_in_group// ) {
    100          
647 30         47 $_ = $1;
648 30         74 $set->{nth_in_group} = $2;
649             }
650             elsif ( s/$is_nth// ) {
651 205         522 $set->{nth} = $1;
652             }
653             }
654              
655             # Remove outer quotes (if any).
656 316         426 for ( @condition ) {
657 435         448 for my $quote ( qw/ " ' / ) {
658 866 100 66     1414 if ( $quote eq substr( $_, 0, 1 )
659             and $quote eq substr( $_, -1 ) )
660             {
661 12         19 $_ = substr( $_, 1, -1 ); # Strip first and last characters.
662 12         17 last; # Skip multi quoting.
663             }
664             }
665             }
666              
667             # Regex or literal.
668 316         350 for ( qw/ tag text / ) {
669 632 100       935 last if not @condition;
670 435         527 my $cond = shift @condition;
671 435 100       1930 $set->{$_} = ( $cond =~ s/^~// ) ? qr/$cond/i : $cond;
672             }
673              
674 316         624 $set;
675             }
676 196         477 grep { $_ } # Skip trailing and leading slashes.
  325         18171  
677             parse_line( '/', 1, $query_string );
678              
679 196         852 \@query_struct;
680             }
681              
682             =head2 _check_conditions
683              
684             Check if queries are valid.
685              
686             =cut
687              
688             sub _check_conditions {
689 123     123   146 my ( $sections ) = @_;
690              
691 123         161 my $error_message = <<'ERROR';
692              
693             Invalid input: expecting a hash reference!
694              
695             Syntax:
696              
697             $pod->find( 'QUERY' ) # As explained in _query_string_to_struct().
698              
699             # OR:
700              
701             $pod->find(
702             # section1
703             {
704             tag => "TAG", # Search to look for.
705             text => "TEXT", # Text of the tag to find.
706             keep => 1, # Must only be in last section.
707             keep_all => 1, # Keep this tag and sub tags.
708             nth => 0, # Stop searching after find so many matches.
709             nth_in_group => 0, # Nth only in the current group.
710             },
711             # ...
712             # conditionN
713             );
714             ERROR
715              
716             die "$error_message"
717             if not $sections
718             or not @$sections
719 123 100 66     442 or grep { ref() ne ref {} } @$sections;
  206   66     549  
720              
721             # keep_all should only be in the last section
722 119         173 my $last = $#$sections;
723 119         323 while ( my ( $n, $section ) = each @$sections ) {
724             die "Error: keep_all is not in last query!\n"
725 206 50 66     529 if $section->{keep_all} and $n < $last;
726             }
727              
728             # Cannot use both nth and nth_in_group (makes no sense, plus may cause errors)
729 119         252 while ( my ( $n, $section ) = each @$sections ) {
730             die "Error: nth and nth_in_group are exclusive!\n"
731             if defined $section->{nth}
732 206 50 66     616 and defined $section->{nth_in_group};
733             }
734             }
735              
736             =head2 _set_condition_defaults
737              
738             Assigns default query options.
739              
740             =cut
741              
742             sub _set_condition_defaults {
743 119     119   134 my ( $conditions ) = @_;
744 119         164 for my $condition ( @$conditions ) {
745              
746             # Text Options
747 206         232 for ( qw/ tag text / ) {
748 412 100       556 if ( defined $condition->{$_} ) {
749 283 100       771 if ( ref $condition->{$_} ne ref qr// ) {
750 155         1008 $condition->{$_} = qr/^$condition->{$_}$/;
751             }
752             }
753             else {
754 129         250 $condition->{$_} = qr//;
755             }
756             }
757              
758             # Bit Options
759 206         258 for ( qw/ keep keep_all / ) {
760 412 100       491 if ( defined $condition->{$_} ) {
761 36         62 $condition->{$_} = !!$condition->{$_};
762             }
763             else {
764 376         433 $condition->{$_} = 0;
765             }
766             }
767              
768             # Range Options
769 206         296 my $is_digit = qr/ ^ -?\d+ $ /x;
770 206         233 for ( qw/ nth nth_in_group / ) {
771 412         434 my $v = $condition->{$_};
772 412 100 66     1232 if ( defined $v and $v =~ /$is_digit/ ) {
773 156   100     453 $v ||= "0 but true";
774 156 100       281 my $end = ( $v >= 0 ) ? "pos" : "neg"; # Set negative or
775 156         230 my $name = "_${_}_$end"; # positive form.
776 156         278 $condition->{$name} = $v;
777             }
778             }
779              
780             }
781              
782             # Last condition should be keep or keep_all.
783             # (otherwise, why even query for it?)
784 119         168 for ( $conditions->[-1] ) {
785 119 100 100     316 if ( not $_->{keep} || $_->{keep_all} ) {
786 93         135 $_->{keep} = 1;
787             }
788             }
789             }
790              
791             =head2 _find
792              
793             Lower level find command.
794              
795             =cut
796              
797             sub _find {
798 206     206   299 my ( $need, @groups ) = @_;
799 206 50       275 if ( $DEBUG_FIND ) {
800 0         0 say "\n_FIND()";
801 0         0 say "need: ", _dumper $need;
802 0         0 say "groups: ", _dumper \@groups;
803             }
804              
805 206         232 my $nth_p = $need->{_nth_pos}; # Simplify code by already
806 206         244 my $nth_n = $need->{_nth_neg}; # knowing if neg or pos.
807 206         209 my $nth_in_group_p = $need->{_nth_grou_pos}; # Set in _set_section_defaults.
808 206         194 my $nth_in_group_n = $need->{_nth_grou_neg};
809 206         193 my @found;
810              
811             GROUP:
812 206         235 for my $group ( @groups ) {
813 562         601 my @tries = ( $group ); # Assume single group to process.
814 562   100     472 my @prev = @{ $group->{prev} // [] };
  562         1169  
815 562         612 my $locked_prev = 0;
816 562         466 my @found_in_group;
817 562 50       651 if ( $DEBUG_FIND ) {
818 0         0 say "\nprev: ", _dumper \@prev;
819 0         0 say "group: ", _dumper $group;
820             }
821              
822             TRY:
823 562         801 while ( my $try = shift @tries ) { # Can add to this queue if a sub tag.
824 4834 50       5204 say "\nTrying: try=", _dumper $try if $DEBUG_FIND;
825              
826 4834 50       5494 if ( defined $try->{text} ) { # over-text has no text (only kids).
827 4834 50 100     14769 if ( $DEBUG_FIND ) {
    100 100        
828 0         0 say "text=$try->{text}";
829 0         0 say "next->{tag}=$need->{tag}";
830 0         0 say "next->{text}=$need->{text}";
831             }
832              
833             elsif (
834             $try->{tag} =~ /$need->{tag}/
835             and $try->{text} =~ /$need->{text}/
836             and not defined $try->{keep} # Already found the node.
837             # Since nodes are checked again
838             # on next call to _find.
839             )
840             {
841 546 50       745 say "Found: tag=$try->{tag}, text=$try->{text}"
842             if $DEBUG_FIND;
843             push @found_in_group, {
844             %$try, # Copy current search options.
845             prev => \@prev, # Need this for the inversion step.
846             keep => $need->{keep}, # Remember for later.
847 546         1396 };
848              
849             # Specific match (positive)
850 546 50       774 say "nth_p:$nth_p and found_in_group:"
851             . _dumper \@found_in_group
852             if $DEBUG_FIND;
853 546 100 100     1136 if ( $nth_p and @found + @found_in_group > $nth_p ) {
    50 33        
854 120 50       173 say "ENFORCING: nth=$nth_p" if $DEBUG_FIND;
855 120         149 @found = $found_in_group[-1];
856 120         214 last GROUP;
857             }
858              
859             # Specific group match (positive)
860             elsif ( $nth_in_group_p
861             and @found_in_group > $nth_in_group_p )
862             {
863 0 0       0 say "ENFORCING: nth_in_group=$nth_in_group_p"
864             if $DEBUG_FIND;
865 0         0 @found_in_group = $found_in_group[-1];
866 0         0 last TRY;
867             }
868              
869 426         645 next TRY;
870             }
871             }
872              
873 4288 100 100     8014 if ( $try->{kids} and not @found_in_group ) {
874 1227 50       1365 say "Got kids and nothing yet in queue" if $DEBUG_FIND;
875 1227         1432 unshift @tries, $try->{kids}->@*; # Process kids tags.
876 1227 100 66     1563 if ( $try->{keep} and not $locked_prev++ ) {
877 8         20 unshift @prev, { %$try{qw/tag text keep/} };
878 8 50       15 say "prev changed: ", _dumper \@prev if $DEBUG_FIND;
879             }
880 1227 50       2084 say "locked_prev: $locked_prev" if $DEBUG_FIND;
881             }
882             }
883              
884             # Specific group match (negative)
885 442 50 33     594 if ( $nth_in_group_n and @found_in_group >= abs $nth_in_group_n ) {
886 0 0       0 say "ENFORCING: nth_in_group_n=$nth_in_group_n" if $DEBUG_FIND;
887 0         0 @found_in_group = $found_in_group[$nth_in_group_n];
888             }
889              
890 442 100       746 push @found, splice @found_in_group if @found_in_group;
891             }
892              
893             # Specific match (negative)
894 206 100 66     347 if ( $nth_n and @found >= abs $nth_n ) {
895 4 50       9 say "ENFORCING: nth=$nth_n" if $DEBUG_FIND;
896 4         18 @found = $found[$nth_n];
897             }
898              
899 206 50       273 say "found: ", _dumper \@found if $DEBUG_FIND;
900              
901 206         419 @found;
902             }
903              
904             =head2 _invert
905              
906             Previous elements are inside of the child
907             (due to the way the tree is created).
908              
909             This method walks through each child and puts
910             the parent in its place.
911              
912             =cut
913              
914             sub _invert {
915 101     101   124 my ( @groups ) = @_;
916 101 50       148 if ( $DEBUG_INVERT ) {
917 0         0 say "\n_INVERT()";
918 0         0 say "groups: ", _dumper \@groups;
919             }
920              
921 101         112 my @tree;
922             my %navi;
923              
924 101         120 for my $group ( @groups ) {
925 379         678 push @tree, { %$group{qw/ tag text keep kids /} };
926 379 50       740 if ( $DEBUG_INVERT ) {
927 0         0 say "\nInverting: group=", _dumper $group;
928 0         0 say "tree: ", _dumper \@tree;
929             }
930              
931 379   50     483 my $prevs = $group->{prev} // [];
932 379         408 for my $prev ( @$prevs ) {
933 8         10 my $prev_node = $navi{$prev};
934 8 50       13 if ( $DEBUG_INVERT ) {
935 0         0 say "prev: ", _dumper $prev;
936 0         0 say "prev_node: ", _dumper $prev_node;
937             }
938 8 50       10 if ( $prev_node ) {
939 0         0 push @$prev_node, pop @tree;
940 0 0       0 if ( $DEBUG_INVERT ) {
941 0         0 say "FOUND: prev_node=", _dumper $prev_node;
942             }
943 0         0 last;
944             }
945             else {
946 8         16 $prev_node = $navi{$prev} = [ $tree[-1] ];
947 8         23 $tree[-1] = { %$prev, kids => $prev_node };
948 8 50       17 if ( $DEBUG_INVERT ) {
949 0         0 say "NEW: prev_node=", _dumper $prev_node;
950             }
951             }
952             }
953              
954 379 50       495 say "tree end: ", _dumper \@tree if $DEBUG_INVERT;
955             }
956              
957 101         277 @tree;
958             }
959              
960             =head2 _render
961              
962             Transforms a tree of found nodes in a simple list
963             or a string depending on context.
964              
965             Pod::Text formatter is used for C tags when C is set.
966              
967             =cut
968              
969             sub _render {
970 119     119   158 my ( $kept_all, @tree ) = @_;
971 119 50       162 if ( $DEBUG_RENDER ) {
972 0         0 say "\n_RENDER()";
973 0         0 say "tree: ", _dumper \@tree;
974 0         0 say "kept_all: ", _dumper $kept_all;
975             }
976              
977 119         280 my $formatter = Pod::Text->new( width => get_term_width(), );
978 119         10496 $formatter->{MARGIN} = 2;
979              
980 119         137 my @lines;
981             my $n;
982              
983 119         155 for my $group ( @tree ) {
984 419         449 my @tries = ( $group );
985 419 50       498 say "\ngroup: ", _dumper $group if $DEBUG_RENDER;
986              
987 419         563 while ( my $try = shift @tries ) {
988 2839 50       3042 say "\nTrying: try=", _dumper $try if $DEBUG_RENDER;
989              
990 2839         2595 my $_text = $try->{text};
991 2839 50       2970 say "_text=$_text" if $DEBUG_RENDER;
992              
993 2839 100       3414 if ( $kept_all ) {
    100          
994 548 100       610 $_text .= ":" if ++$n == 1; # Only for the first line.
995 548 100       643 if ( $try->{tag} eq "Para" ) {
996 164 50       174 say "USING FORMATTER" if $DEBUG_RENDER;
997 164         246 $_text = $formatter->reformat( $_text );
998             }
999 548         5600 push @lines, $_text, "";
1000             }
1001             elsif ( $try->{keep} ) {
1002 387 50       437 say "keeping" if $DEBUG_RENDER;
1003 387         390 push @lines, $_text;
1004             }
1005              
1006 2839 100       4282 if ( $try->{kids} ) {
1007 738         854 unshift @tries, $try->{kids}->@*;
1008 738 50       1232 if ( $DEBUG_RENDER ) {
1009 0         0 say "Got kids";
1010 0         0 say "tries: ", _dumper \@tries;
1011             }
1012             }
1013             }
1014             }
1015              
1016 119 50       163 say "lines: ", _dumper \@lines if $DEBUG_RENDER;
1017              
1018 119 100       674 return @lines if wantarray;
1019 69         900 join "\n", @lines;
1020             }
1021              
1022             =head2 get_term_width
1023              
1024             Determines, caches and returns the terminal width.
1025              
1026             =head3 Error: Unable to get Terminal Size
1027              
1028             If terminal width cannot be detected, 80 will be assumed.
1029              
1030             =cut
1031              
1032             sub get_term_width {
1033 6     6 1 8 state $term_width;
1034              
1035 6 100       8 if ( not $term_width ) {
1036 1         1 $term_width = eval { chars() };
  1         4  
1037 1   50     19 $term_width ||= 80; # Safe default.
1038 1         2 $term_width--; # Padding.
1039             }
1040              
1041 6         19 $term_width;
1042             }
1043              
1044             =head1 SEE ALSO
1045              
1046             L
1047              
1048             L
1049              
1050             L
1051              
1052              
1053             =head1 AUTHOR
1054              
1055             Tim Potapov, C<< >>
1056              
1057             =head1 BUGS
1058              
1059             Please report any bugs or feature requests to L.
1060              
1061             =head1 CAVEAT
1062              
1063             Nothing to report.
1064              
1065             =head1 SUPPORT
1066              
1067             You can find documentation for this module with the perldoc command.
1068              
1069             perldoc Pod::Query
1070              
1071              
1072             You can also look for information at:
1073              
1074             L
1075             L
1076              
1077              
1078             =head1 ACKNOWLEDGEMENTS
1079              
1080             TBD
1081              
1082             =head1 LICENSE AND COPYRIGHT
1083              
1084             This software is Copyright (c) 2022 by Tim Potapov.
1085              
1086             This is free software, licensed under:
1087              
1088             The Artistic License 2.0 (GPL Compatible)
1089              
1090              
1091             =cut
1092              
1093             1; # End of Pod::Query