Skip to content

Commit b0458ac

Browse files
haargkhwilliamson
haarg
authored and
khwilliamson
committed
Add select method compatible with Pod::Select
1 parent 01b24a5 commit b0458ac

File tree

4 files changed

+286
-9
lines changed

4 files changed

+286
-9
lines changed

‎lib/Pod/Simple/BlackBox.pm

+160-8
Original file line numberDiff line numberDiff line change
@@ -601,6 +601,158 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines)
601601

602602
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
603603

604+
sub _maybe_handle_element_start {
605+
my $self = shift;
606+
return $self->_handle_element_start(@_)
607+
if !$self->{filter};
608+
609+
my ($element_name, $attr) = @_;
610+
611+
if ($element_name =~ /\Ahead(\d)\z/) {
612+
$self->{_in_head} = {
613+
element => $element_name,
614+
level => $1 + 0,
615+
events => [],
616+
text => '',
617+
};
618+
}
619+
620+
if (my $head = $self->{_in_head}) {
621+
push @{ $head->{events} }, [ '_handle_element_start', @_ ];
622+
return;
623+
}
624+
625+
return
626+
if !$self->{_filter_allowed};
627+
628+
$self->_handle_element_start(@_);
629+
}
630+
631+
sub _maybe_handle_element_end {
632+
my $self = shift;
633+
return $self->_handle_element_end(@_)
634+
if !$self->{filter};
635+
636+
my ($element_name, $attr) = @_;
637+
638+
if (my $head = $self->{_in_head}) {
639+
if ($element_name ne $head->{element}) {
640+
push @{ $head->{events} }, [ '_handle_element_end', @_ ];
641+
return;
642+
}
643+
644+
delete $self->{_in_head};
645+
646+
my $headings = $self->{_current_headings} ||= [];
647+
@$headings = (@{$headings}[0 .. $head->{level} - 2], $head->{text});
648+
649+
my $allowed = $self->{_filter_allowed} = $self->_filter_allows(@$headings);
650+
651+
if ($allowed) {
652+
for my $event (@{ $head->{events} }) {
653+
my ($method, @args) = @$event;
654+
$self->$method(@args);
655+
}
656+
}
657+
}
658+
659+
return
660+
if !$self->{_filter_allowed};
661+
662+
$self->_handle_element_end(@_);
663+
}
664+
665+
sub _maybe_handle_text {
666+
my $self = shift;
667+
return $self->_handle_text(@_)
668+
if !$self->{filter};
669+
670+
my ($text) = @_;
671+
672+
if (my $head = $self->{_in_head}) {
673+
push @{ $head->{events} }, [ '_handle_text', @_ ];
674+
$head->{text} .= $text;
675+
return;
676+
}
677+
678+
return
679+
if !$self->{_filter_allowed};
680+
681+
$self->_handle_text(@_);
682+
}
683+
684+
sub _filter_allows {
685+
my $self = shift;
686+
my @headings = @_;
687+
688+
my $filter = $self->{filter}
689+
or return 1;
690+
691+
SPEC: for my $spec ( @$filter ) {
692+
for my $i (0 .. $#$spec) {
693+
my $regex = $spec->[$i];
694+
my $heading = $headings[$i];
695+
$heading = ''
696+
if !defined $heading;
697+
next SPEC
698+
if $heading !~ $regex;
699+
}
700+
return 1;
701+
}
702+
703+
return 0;
704+
}
705+
706+
sub select {
707+
my $self = shift;
708+
my (@selections) = @_;
709+
710+
my $filter = $self->{filter} ||= [];
711+
if (@selections && $selections[0] eq '+') {
712+
shift @selections;
713+
}
714+
else {
715+
@$filter = ();
716+
}
717+
718+
for my $spec (@selections) {
719+
eval {
720+
push @$filter, $self->_compile_heading_spec($spec);
721+
1;
722+
} or do {
723+
warn $@;
724+
warn qq{Ignoring section spec "$spec"!\n};
725+
};
726+
}
727+
}
728+
729+
sub _compile_heading_spec {
730+
my $self = shift;
731+
my ($spec) = @_;
732+
733+
my @bad;
734+
my @parts = $spec =~ m{(?:\A|\G/)((?:[^/\\]|\\.)*)}g;
735+
for my $part (@parts) {
736+
$part =~ s{\\(.)}{$1}g;
737+
my $negate = $part =~ s{\A!}{};
738+
$part = '.*'
739+
if !length $part;
740+
741+
eval {
742+
$part = $negate ? qr{^(?!$part$)} : qr{^$part$};
743+
1;
744+
} or do {
745+
push @bad, qq{Bad regular expression /$part/ in "$spec": $@\n};
746+
};
747+
}
748+
749+
Carp::croak(join '', @bad)
750+
if @bad;
751+
752+
return \@parts;
753+
}
754+
755+
604756
sub _handle_encoding_line {
605757
my($self, $line) = @_;
606758

@@ -1346,7 +1498,7 @@ sub _ponder_begin {
13461498
DEBUG > 1 and print STDERR "Ignoring ignorable =begin\n";
13471499
} else {
13481500
$self->{'content_seen'} ||= 1 unless $self->{'~tried_gen_errata'};
1349-
$self->_handle_element_start((my $scratch='for'), $para->[1]);
1501+
$self->_maybe_handle_element_start((my $scratch='for'), $para->[1]);
13501502
}
13511503

13521504
return 1;
@@ -1414,7 +1566,7 @@ sub _ponder_end {
14141566
# what's that for?
14151567

14161568
$self->{'content_seen'} ||= 1 unless $self->{'~tried_gen_errata'};
1417-
$self->_handle_element_end( my $scratch = 'for', $para->[1]);
1569+
$self->_maybe_handle_element_end( my $scratch = 'for', $para->[1]);
14181570
}
14191571
DEBUG > 1 and print STDERR "Popping $curr_open->[-1][0] $curr_open->[-1][1]{'target'} because of =end $content\n";
14201572
pop @$curr_open;
@@ -1536,7 +1688,7 @@ sub _ponder_over {
15361688
DEBUG > 1 and print STDERR "=over found of type $list_type\n";
15371689

15381690
$self->{'content_seen'} ||= 1 unless $self->{'~tried_gen_errata'};
1539-
$self->_handle_element_start((my $scratch = 'over-' . $list_type), $para->[1]);
1691+
$self->_maybe_handle_element_start((my $scratch = 'over-' . $list_type), $para->[1]);
15401692

15411693
return;
15421694
}
@@ -1558,7 +1710,7 @@ sub _ponder_back {
15581710
# Expected case: we're closing the most recently opened thing
15591711
#my $over = pop @$curr_open;
15601712
$self->{'content_seen'} ||= 1 unless $self->{'~tried_gen_errata'};
1561-
$self->_handle_element_end( my $scratch =
1713+
$self->_maybe_handle_element_end( my $scratch =
15621714
'over-' . ( (pop @$curr_open)->[1]{'~type'} ), $para->[1]
15631715
);
15641716
} else {
@@ -1843,19 +1995,19 @@ sub _traverse_treelet_bit { # for use only by the routine above
18431995
my($self, $name) = splice @_,0,2;
18441996
18451997
my $scratch;
1846-
$self->_handle_element_start(($scratch=$name), shift @_);
1998+
$self->_maybe_handle_element_start(($scratch=$name), shift @_);
18471999
18482000
while (@_) {
18492001
my $x = shift;
18502002
if (ref($x)) {
18512003
&_traverse_treelet_bit($self, @$x);
18522004
} else {
18532005
$x .= shift while @_ && !ref($_[0]);
1854-
$self->_handle_text($x);
2006+
$self->_maybe_handle_text($x);
18552007
}
18562008
}
18572009
1858-
$self->_handle_element_end($scratch=$name);
2010+
$self->_maybe_handle_element_end($scratch=$name);
18592011
return;
18602012
}
18612013
@@ -2426,7 +2578,7 @@ sub reinit {
24262578
foreach (qw(source_dead source_filename doc_has_started
24272579
start_of_pod_block content_seen last_was_blank paras curr_open
24282580
line_count pod_para_count in_pod ~tried_gen_errata all_errata errata errors_seen
2429-
Title)) {
2581+
Title _current_headings _in_head _filter_allowed)) {
24302582

24312583
delete $self->{$_};
24322584
}

‎t/filter-html.t

+63
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,63 @@
1+
use strict;
2+
use warnings;
3+
4+
use Test::More;
5+
use Pod::Simple::XHTML;
6+
7+
sub convert {
8+
my ($pod, $select) = @_;
9+
10+
my $out = '';
11+
my $parser = Pod::Simple::XHTML->new;
12+
$parser->html_header('');
13+
$parser->html_footer('');
14+
$parser->output_string(\$out);
15+
$parser->select(@$select);
16+
17+
$parser->parse_string_document($pod);
18+
return $out;
19+
}
20+
21+
sub compare {
22+
my ($in, $want, $select, $name) = @_;
23+
for my $pod ($in, $want) {
24+
if ($pod =~ /\A([\t ]+)/) {
25+
my $prefix = $1;
26+
$pod =~ s{^$prefix}{}gm;
27+
}
28+
}
29+
my $got = convert($in, $select);
30+
local $Test::Builder::Level = $Test::Builder::Level + 1;
31+
is $got, $want, $name;
32+
}
33+
34+
compare <<'END_POD', <<'END_HTML', [ 'DESCRIPTION/guff' ];
35+
=head1 NAME
36+
37+
NAME content
38+
39+
=head2 welp
40+
41+
welp content
42+
43+
=head3 hork
44+
45+
hork content
46+
47+
=head1 DESCRIPTION
48+
49+
DESCRIPTION content
50+
51+
=head2 guff
52+
53+
guff content
54+
55+
=cut
56+
END_POD
57+
<h2 id="guff">guff</h2>
58+
59+
<p>guff content</p>
60+
61+
END_HTML
62+
63+
done_testing;

‎t/filter.t

+62
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,62 @@
1+
use strict;
2+
use warnings;
3+
use Test::More;
4+
use Pod::Simple::JustPod;
5+
6+
sub convert {
7+
my ($pod, $select) = @_;
8+
9+
my $out = '';
10+
my $parser = Pod::Simple::JustPod->new;
11+
$parser->output_string(\$out);
12+
$parser->select(@$select);
13+
14+
$parser->parse_string_document($pod);
15+
return $out;
16+
}
17+
18+
sub compare {
19+
my ($in, $want, $select, $name) = @_;
20+
for my $pod ($in, $want) {
21+
if ($pod =~ /\A([\t ]+)/) {
22+
my $prefix = $1;
23+
$pod =~ s{^$prefix}{}gm;
24+
}
25+
}
26+
my $got = convert($in, $select);
27+
$got =~ s/\A=pod\n\n//;
28+
local $Test::Builder::Level = $Test::Builder::Level + 1;
29+
is $got, $want, $name;
30+
}
31+
32+
compare <<'END_IN_POD', <<'END_OUT_POD', [ 'DESCRIPTION/guff' ];
33+
=head1 NAME
34+
35+
NAME content
36+
37+
=head2 welp
38+
39+
welp content
40+
41+
=head3 hork
42+
43+
hork content
44+
45+
=head1 DESCRIPTION
46+
47+
DESCRIPTION content
48+
49+
=head2 guff
50+
51+
guff content
52+
53+
=cut
54+
END_IN_POD
55+
=head2 guff
56+
57+
guff content
58+
59+
=cut
60+
END_OUT_POD
61+
62+
done_testing;

‎t/search50.t

+1-1
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,7 @@
11
use strict;
22
use warnings;
33

4-
use Test::More;
4+
use Test::More skip_all => 'slow';
55

66
#sub Pod::Simple::Search::DEBUG () {5};
77

0 commit comments

Comments
 (0)