Skip to content

Commit

Permalink
better link targets for headX/item
Browse files Browse the repository at this point in the history 
Pod::Simple::XHTML does heavy filtering of the link targets it
generates.  This results in many targets being nearly useless for
external use.

Change the targets generated to use less filtering, but also generate
additional targets, one with the first word and one with the old target
like Pod::Simple::XHTML creates.

This is especially useful for pages like perlvar and perlfunc.  Many of
the targets in perlvar consist entirely of characters that are filtered
by Pod::Simple::XHTML.  The targets would therefore look like 'pod5'.
With this change, the unfiltered targets will be available, so linking
to variables will work properly.  The first word target is useful for
perlfunc or any other page that includes parameters function listings.
This will allow links like L<perlfunc/open> to work as people expect.

The Pod::Simple::XHTML style target is maintained for compatibility with
existing links on the web.
  • Loading branch information
@haarg
haarg committed Dec 27, 2016
1 parent 78b90c1 commit d77aba5
Show file tree
Hide file tree
Showing 2 changed files with 105 additions and 4 deletions.
1 change: 1 addition & 0 deletions cpanfile
View file
Expand Up @@ -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';
Expand Down
108 changes: 104 additions & 4 deletions lib/MetaCPAN/Pod/XHTML.pm
View file
Expand Up @@ -7,16 +7,112 @@ 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+$//;

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+$//;

# $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
Expand Down Expand Up @@ -80,8 +176,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

0 comments on commit d77aba5

Please sign in to comment.