Merge pull request #608 from metacpan/haarg/pod-link-targets

better link targets for headX/item
metacpan · Jan 6, 2017 · b373b33 · b373b33
2 parents 1724afa + 0bac9e2
commit b373b33
Show file tree

Hide file tree

Showing 3 changed files with 108 additions and 5 deletions.
diff --git a/cpanfile b/cpanfile
@@ -67,6 +67,7 @@ requires 'FindBin';
 requires 'Git::Helpers';
 requires 'Graph::Centrality::Pagerank';
 requires 'Gravatar::URL';
+requires 'HTML::Entities';
 requires 'HTML::TokeParser::Simple';
 requires 'HTTP::Request::Common';
 requires 'Hash::Merge::Simple';

diff --git a/lib/MetaCPAN/Pod/XHTML.pm b/lib/MetaCPAN/Pod/XHTML.pm
@@ -7,16 +7,114 @@ use warnings;
 # Pod::Simple::XHTML expects you to subclass and then override methods.
 
 use parent 'Pod::Simple::XHTML';
+use HTML::Entities qw(decode_entities);
 
 __PACKAGE__->_accessorize('link_mappings');
 
 sub resolve_pod_page_link {
     my ( $self, $module, $section ) = @_;
+    return undef
+        unless defined $module || defined $section;
+    $section = defined $section ? '#' . $self->idify( $section, 1 ) : '';
+    return $section
+        unless defined $module;
     my $link_map = $self->link_mappings || {};
-    if ( $module and my $link = $link_map->{$module} ) {
+    if ( defined( my $link = $link_map->{$module} ) ) {
         $module = $link;
     }
-    $self->SUPER::resolve_pod_page_link( $module, $section );
+    my ( $prefix, $postfix ) = map +( defined $_ ? $_ : '' ),
+        $self->perldoc_url_prefix, $self->perldoc_url_postfix;
+    return $self->encode_entities( $prefix . $module . $postfix . $section );
+}
+
+sub _end_head {
+    my $self      = shift;
+    my $head_name = $self->{htext};
+    $self->{more_ids} = [ $self->id_extras($head_name) ];
+    $self->SUPER::_end_head(@_);
+    my $index_entry = $self->{'to_index'}[-1];
+    $index_entry->[1] = $self->url_encode( $index_entry->[1] );
+    return;
+}
+
+sub end_item_text {
+    my $self = shift;
+    if ( $self->{anchor_items} ) {
+        my $item_name = $self->{'scratch'};
+        $self->{more_ids} = [ $self->id_extras($item_name) ];
+    }
+    $self->SUPER::end_item_text(@_);
+}
+
+sub emit {
+    my $self = shift;
+    my $ids  = delete $self->{more_ids};
+    if ( $ids && @$ids ) {
+        my $scratch = $self->{scratch};
+        my $add = join '', map qq{<a id="$_"></a>}, @$ids;
+        $scratch =~ s/(<\w[^>]*>)/$1$add/;
+        $self->{scratch} = $scratch;
+    }
+    $self->SUPER::emit(@_);
+}
+
+my %encode = map +( chr($_) => sprintf( '%%%02X', $_ ) ), 0 .. 255;
+
+sub url_encode {
+    my ( undef, $t ) = @_;
+    utf8::encode($t);
+    $t =~ s{([^a-zA-Z0-9-._~!\$&'()*+,;=:@/?])}{$encode{$1}}g;
+    $t;
+}
+
+sub idify {
+    my ( $self, $t, $for_link ) = @_;
+
+    $t =~ s/<[^>]+>//g;
+    $t = decode_entities($t);
+    $t =~ s/^\s+//;
+    $t =~ s/\s+$//;
+    $t =~ s/[\s-]+/-/g;
+
+    return $self->url_encode($t)
+        if $for_link;
+
+    my $ids = $self->{ids};
+    my $i   = '';
+    $i++ while $ids->{"$t$i"}++;
+    $self->encode_entities("$t$i");
+}
+
+sub id_extras {
+    my ( $self, $t ) = @_;
+
+    $t =~ s/<[^>]+>//g;
+    $t = decode_entities($t);
+    $t =~ s/^\s+//;
+    $t =~ s/\s+$//;
+    $t =~ s/[\s-]+/-/g;
+
+    # $full will be our preferred linking style, without much filtering
+    # $first will be the first word, often a method/function name
+    # $old will be a heavily filtered form for backwards compatibility
+
+    my $full = $t;
+    my ($first) = $t =~ /^(\w+)/;
+    $t =~ s/^[^a-zA-Z]+//;
+    $t =~ s/^$/pod/;
+    $t =~ s/[^-a-zA-Z0-9_:.]+/-/g;
+    $t =~ s/[-:.]+$//;
+    my $old = $t;
+    my %s   = ( $full => 1 );
+    my $ids = $self->{ids};
+    return map $self->encode_entities($_), map {
+        my $i = '';
+        $i++ while $ids->{"$_$i"}++;
+        "$_$i";
+        }
+        grep !$s{$_}++,
+        grep defined,
+        ( $first, $old );
 }
 
 # Custom handling of errata section
@@ -80,8 +178,12 @@ sub _emit_custom_errata {
 
 =pod
 
-=head2 perldoc_url_prefix
+=head1 NAME
+
+MetaCPAN::Pod::XHTML - Format Pod as HTML for MetaCPAN
+
+=head1 ATTRIBUTES
 
-Set perldoc domain to C<metacpan.org>.
+=head2 link_mappings
 
 =cut
diff --git a/t/pod/renderer.t b/t/pod/renderer.t
@@ -21,7 +21,7 @@ EOF
 
 {
     my $html = <<'EOF';
-<h1 id="DESCRIPTION-Plack">DESCRIPTION <a href="https://metacpan.org/pod/Plack">Plack</a></h1>
+<h1 id="DESCRIPTION-Plack"><a id="DESCRIPTION"></a>DESCRIPTION <a href="https://metacpan.org/pod/Plack">Plack</a></h1>
 
 EOF