File Coverage

blib/lib/Pod/Simple/Role/XHTML/WithExtraTargets.pm
Criterion Covered Total %
statement 37 37 100.0
branch 1 2 50.0
condition n/a
subroutine 7 7 100.0
pod 0 1 0.0
total 45 47 95.7


line stmt bran cond sub pod time code
1             package Pod::Simple::Role::XHTML::WithExtraTargets;
2 1     1   148939 use Moo::Role;
  1         5  
  1         4  
3              
4             our $VERSION = '0.003000';
5             $VERSION =~ tr/_//d;
6              
7 1     1   286 use HTML::Entities qw(decode_entities encode_entities);
  1         2  
  1         62  
8 1     1   338 use URL::Encode qw(url_encode_utf8);
  1         4022  
  1         45  
9 1     1   6 use Pod::Simple::XHTML ();
  1         2  
  1         22  
10              
11 1     1   5 use constant BAD_LINK_ENCODING => !defined &Pod::Simple::XHTML::decode_entities;
  1         1  
  1         82  
12              
13 1     1   357 use namespace::clean;
  1         8998  
  1         4  
14              
15             with qw(Pod::Simple::Role::XHTML::WithPostProcess);
16              
17             # we're using around to ensure proper ordering when combined with
18             # RepairLinkEncoding
19             around _end_head => sub {
20             my $orig = shift;
21             my $self = shift;
22             my $link_text = $self->{htext};
23             my $filtered_id = $self->idify($link_text, 1);
24              
25             # old Pod::Simple::XHTML
26             if (BAD_LINK_ENCODING) {
27             # will be encoded, but without formatting
28             $link_text = decode_entities($link_text);
29             $filtered_id = decode_entities($filtered_id);
30             }
31              
32             $self->{__more_ids_for} = [ $link_text, $filtered_id ];
33             $self->$orig(@_);
34             };
35              
36             around end_item_text => sub {
37             my $orig = shift;
38             my $self = shift;
39             if ( $self->{anchor_items} ) {
40             my $link_text = BAD_LINK_ENCODING ? $self->{scratch} : $self->{itext};
41             my $filtered_id = $self->idify($link_text, 1);
42              
43             # old Pod::Simple::XHTML
44             if (BAD_LINK_ENCODING) {
45             # will be encoded, but also include tags
46             $link_text =~ s/<[^>]+>//g;
47             $link_text = decode_entities($link_text);
48             $filtered_id = decode_entities($filtered_id);
49             }
50              
51             $self->{__more_ids_for} = [ $link_text, $filtered_id ];
52             }
53             $self->$orig(@_);
54             };
55              
56             after pre_process => sub {
57             my ($self, $content) = @_;
58             if (my $for = delete $self->{__more_ids_for}) {
59             # match the first tag in the content being added. this will contain the
60             # primary id to use for links, so it should be unique. we'll be searching
61             # for it later to add the additional link targets.
62             my ($tag) = $content =~ /(<\w[^>]*>)/s;
63             if ($tag && $tag =~ /id=/) {
64             $self->{__extra_ids}{$tag} = $for;
65             }
66             }
67             };
68              
69             around post_process => sub {
70             my $orig = shift;
71             my $self = shift;
72             my $output = $self->$orig(@_);
73             my $extras = delete $self->{__extra_ids}
74             or return $output;
75              
76             # search for any of the tags we found when preprocessing
77             my $match = join '|', map quotemeta, keys %$extras;
78             # inject extra links for each tag found
79             $output =~ s{($match)}{
80             join '', $1,
81             map '',
82             $self->id_extras(@{ $extras->{$1} });
83             }ge;
84             return $output;
85             };
86              
87             sub id_extras {
88 16     16 0 34 my ( $self, $t, @existing ) = @_;
89              
90 16         20 my @ids;
91              
92             # our preferred linking style, with very little filtering
93 16         21 my $ours = $t;
94 16         29 $ours =~ s/^\s+//;
95 16         29 $ours =~ s/\s+$//;
96 16         48 $ours =~ s/[\s-]+/-/g;
97 16         26 push @ids, $ours;
98              
99             # first word, stripping off $self type invocants
100 16         47 my ($first) = $t =~ /^\s*(?:\$\w+->)?(\w+)/;
101 16 50       39 push @ids, $first
102             if defined $first;
103              
104             # the way this id would be generated by Pod::Simple::XHTML
105 16         21 my $maybe_encoded = $t;
106 16         30 $maybe_encoded = encode_entities($maybe_encoded)
107             if BAD_LINK_ENCODING;
108 16         207 push @ids, $self->Pod::Simple::XHTML::idify($maybe_encoded, 1);
109              
110             # don't try to generate ids we've already seen
111 16         275 my %s = map { $_ => 1 } @existing;
  16         38  
112              
113             #warn "original: $filtered_id\n";
114             #warn " adding: $_\n" for @ids;
115              
116 16         26 my $ids = $self->{ids};
117             return (
118             map {
119 16         21 my $i = '';
120 16         40 $i++ while $ids->{"$_$i"}++;
121 16         47 "$_$i";
122             }
123 16         82 grep !$s{$_}++,
124             @ids
125             );
126             }
127              
128             after reinit => sub {
129             my $self = shift;
130             delete $self->{__more_ids_for};
131             delete $self->{__extra_ids};
132             };
133              
134             1;
135             __END__