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

package Pod::Simple::Role::XHTML::WithExtraTargets;
use Moo::Role;

our $VERSION = '0.003000';
$VERSION =~ tr/_//d;

use HTML::Entities qw(decode_entities encode_entities);
use URL::Encode qw(url_encode_utf8);
use Pod::Simple::XHTML ();

use constant BAD_LINK_ENCODING => !defined &Pod::Simple::XHTML::decode_entities;

use namespace::clean;

with qw(Pod::Simple::Role::XHTML::WithPostProcess);

# we're using around to ensure proper ordering when combined with
# RepairLinkEncoding
around _end_head => sub {
  my $orig = shift;
  my $self = shift;
  my $link_text = $self->{htext};
  my $filtered_id = $self->idify($link_text, 1);

  # old Pod::Simple::XHTML
  if (BAD_LINK_ENCODING) {
    # will be encoded, but without formatting
    $link_text = decode_entities($link_text);
    $filtered_id = decode_entities($filtered_id);
  }

  $self->{__more_ids_for} = [ $link_text, $filtered_id ];
  $self->$orig(@_);
};

around end_item_text => sub {
  my $orig = shift;
  my $self = shift;
  if ( $self->{anchor_items} ) {
    my $link_text = BAD_LINK_ENCODING ? $self->{scratch} : $self->{itext};
    my $filtered_id = $self->idify($link_text, 1);

    # old Pod::Simple::XHTML
    if (BAD_LINK_ENCODING) {
      # will be encoded, but also include tags
      $link_text =~ s/<[^>]+>//g;
      $link_text = decode_entities($link_text);
      $filtered_id = decode_entities($filtered_id);
    }

    $self->{__more_ids_for} = [ $link_text, $filtered_id ];
  }
  $self->$orig(@_);
};

after pre_process => sub {
  my ($self, $content) = @_;
  if (my $for = delete $self->{__more_ids_for}) {
    # match the first tag in the content being added. this will contain the
    # primary id to use for links, so it should be unique. we'll be searching
    # for it later to add the additional link targets.
    my ($tag) = $content =~ /(<\w[^>]*>)/s;
    if ($tag && $tag =~ /id=/) {
      $self->{__extra_ids}{$tag} = $for;
    }
  }
};

around post_process => sub {
  my $orig = shift;
  my $self = shift;
  my $output = $self->$orig(@_);
  my $extras = delete $self->{__extra_ids}
    or return $output;

  # search for any of the tags we found when preprocessing
  my $match = join '|', map quotemeta, keys %$extras;
  # inject extra links for each tag found
  $output =~ s{($match)}{
    join '', $1,
      map '',
      $self->id_extras(@{ $extras->{$1} });
  }ge;
  return $output;
};

sub id_extras {
  my ( $self, $t, @existing ) = @_;

  my @ids;

  # our preferred linking style, with very little filtering
  my $ours = $t;
  $ours =~ s/^\s+//;
  $ours =~ s/\s+$//;
  $ours =~ s/[\s-]+/-/g;
  push @ids, $ours;

  # first word, stripping off $self type invocants
  my ($first) = $t =~ /^\s*(?:\$\w+->)?(\w+)/;
  push @ids, $first
    if defined $first;

  # the way this id would be generated by Pod::Simple::XHTML
  my $maybe_encoded = $t;
  $maybe_encoded = encode_entities($maybe_encoded)
    if BAD_LINK_ENCODING;
  push @ids, $self->Pod::Simple::XHTML::idify($maybe_encoded, 1);

  # don't try to generate ids we've already seen
  my %s = map { $_ => 1 } @existing;

  #warn "original: $filtered_id\n";
  #warn "  adding: $_\n" for @ids;

  my $ids = $self->{ids};
  return (
    map {
      my $i = '';
      $i++ while $ids->{"$_$i"}++;
      "$_$i";
    }
    grep !$s{$_}++,
    @ids
  );
}

after reinit => sub {
  my $self = shift;
  delete $self->{__more_ids_for};
  delete $self->{__extra_ids};
};

1;
__END__