add permalinks option to pod rendering endpoint

If the 'permalinks' option is used, links to modules within the same dist will use long form URLs linking to the specific version.
metacpan · Sep 14, 2015 · 62bfa80 · 62bfa80
1 parent d182987
commit 62bfa80
Show file tree

Hide file tree

Showing 3 changed files with 74 additions and 2 deletions.
diff --git a/lib/MetaCPAN/Pod/XHTML.pm b/lib/MetaCPAN/Pod/XHTML.pm
@@ -27,6 +27,25 @@ sub handle_text {
     }
 }
 
+sub link_mappings {
+    my $self = shift;
+    if (@_) {
+        $self->{_link_map} = $_[0];
+    }
+    $self->{_link_map};
+}
+
+sub resolve_pod_page_link {
+    my $self = shift;
+    my ( $module, $section ) = @_;
+    my $link_map = $self->{_link_map} || {};
+    if ( $module and my $link = $link_map->{$module} ) {
+        $section = $section ? "#$section" : '';
+        return $self->perldoc_url_prefix . "release/" . $link . $section;
+    }
+    $self->SUPER::resolve_pod_page_link(@_);
+}
+
 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,56 @@ sub get : Chained('index') : PathPart('') : Args {
         $c->res->body( $res->[2]->[0] );
     }
     else {
+        if ( $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 )] )->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} };
+                my $link = ( $module && $module->{associated_pod} )
+                    || "$author/$release/$file->{path}";
+                $links->{$name} = $link;
+            }
+            $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 );