Merge pull request #423 from CPAN-API/haarg/permalinks

Improve pod links to files in the same dist
metacpan · Sep 24, 2015 · c440a8c · c440a8c
2 parents d182987 + db3fa81
commit c440a8c
Show file tree

Hide file tree

Showing 3 changed files with 85 additions and 2 deletions.
diff --git a/lib/MetaCPAN/Pod/XHTML.pm b/lib/MetaCPAN/Pod/XHTML.pm
@@ -27,6 +27,23 @@ sub handle_text {
     }
 }
 
+sub link_mappings {
+    my $self = shift;
+    if (@_) {
+        $self->{_link_map} = $_[0];
+    }
+    $self->{_link_map};
+}
+
+sub resolve_pod_page_link {
+    my ( $self, $module, $section ) = @_;
+    my $link_map = $self->{_link_map} || {};
+    if ( $module and my $link = $link_map->{$module} ) {
+        $module = $link;
+    }
+    $self->SUPER::resolve_pod_page_link( $module, $section );
+}
+
 sub start_item_text {
 
     # see end_item_text

diff --git a/lib/MetaCPAN/Server/Controller/Source.pm b/lib/MetaCPAN/Server/Controller/Source.pm
@@ -32,6 +32,69 @@ sub get : Chained('index') : PathPart('') : Args {
         $c->res->body( $res->[2]->[0] );
     }
     else {
+        my $permalinks = $c->req->query_params->{permalinks};
+        my $links      = {};
+        my $modules    = $c->model('CPAN::File')->raw->filter(
+            {
+                and => [
+                    { term => { release => $release } },
+                    { term => { author  => $author } },
+                    {
+                        or => [
+                            {
+                                and => [
+                                    {
+                                        exists => {
+                                            field => 'file.module.name',
+                                        }
+                                    },
+                                    {
+                                        term => {
+                                            'file.module.indexed' => \1
+                                        }
+                                    },
+                                ]
+                            },
+                            {
+                                and => [
+                                    {
+                                        exists => {
+                                            field => 'file.pod.analyzed',
+                                        }
+                                    },
+                                    { term => { 'file.indexed' => \1 } },
+                                ]
+                            },
+                        ]
+                    },
+                ],
+            }
+            )->fields( [qw( module path documentation distribution )] )
+            ->size(5000)->all->{hits}->{hits};
+        for my $file ( map { $_->{fields} } @$modules ) {
+            my $name = $file->{documentation} or next;
+            my ($module)
+                = grep { $_->{name} eq $name } @{ $file->{module} };
+
+            if ($permalinks) {
+                $links->{$name}
+                    = 'release/'
+                    . ( ( $module && $module->{associated_pod} )
+                        || "$author/$release/$file->{path}" );
+            }
+            elsif ( !$module ) {
+                $links->{$name}
+                    = "distribution/$file->{distribution}/$file->{path}";
+            }
+            elsif ( !$module->{authorized} || !$module->{indexed} ) {
+                $links->{$name}
+                    = 'release/'
+                    . ( $module->{associated_pod}
+                        || "$author/$release/$file->{path}" );
+            }
+        }
+        $c->stash->{link_mappings} = $links;
+
         $c->stash->{path} = $file;
 
         # Tell fastly to cache for a day (for st.aticpan.org,

diff --git a/lib/MetaCPAN/Server/View/Pod.pm b/lib/MetaCPAN/Server/View/Pod.pm
@@ -14,6 +14,7 @@ sub process {
     my $renderer = MetaCPAN::Pod::Renderer->new;
 
     my $content = $c->res->body || $c->stash->{source};
+    my $link_mappings = $c->stash->{link_mappings};
     $content = eval { join( q{}, $content->getlines ) };
 
     my ( $body, $content_type );
@@ -36,7 +37,8 @@ sub process {
         $content_type = 'text/plain';
     }
     else {
-        $body = $self->build_pod_html( $content, $show_errors, $x_codes );
+        $body = $self->build_pod_html( $content, $show_errors, $x_codes,
+            $link_mappings );
         $content_type = 'text/html';
     }
 
@@ -45,11 +47,12 @@ sub process {
 }
 
 sub build_pod_html {
-    my ( $self, $source, $show_errors, $x_codes ) = @_;
+    my ( $self, $source, $show_errors, $x_codes, $link_mappings ) = @_;
 
     my $renderer = $self->_factory->html_renderer;
     $renderer->nix_X_codes( !$x_codes );
     $renderer->no_errata_section( !$show_errors );
+    $renderer->link_mappings($link_mappings);
 
     my $html = q{};
     $renderer->output_string( \$html );