Merge pull request #404 from CPAN-API/oalders/pod-parser

Make Pod parsing easier to test
metacpan · Apr 17, 2015 · 1e0dcaf · 1e0dcaf
2 parents 5a755ff + 0120fab
commit 1e0dcaf
Show file tree

Hide file tree

Showing 5 changed files with 179 additions and 48 deletions.
diff --git a/lib/MetaCPAN/Document/File.pm b/lib/MetaCPAN/Document/File.pm
@@ -11,7 +11,6 @@ use Encode;
 use List::AllUtils qw( any );
 use List::MoreUtils qw(any uniq);
 use MetaCPAN::Document::Module;
-use MetaCPAN::Pod::XHTML;
 use MetaCPAN::Types qw(:all);
 use MetaCPAN::Util;
 use MooseX::Types::Moose qw(ArrayRef);

diff --git a/lib/MetaCPAN/Pod/Renderer.pm b/lib/MetaCPAN/Pod/Renderer.pm
@@ -0,0 +1,95 @@
+package MetaCPAN::Pod::Renderer;
+
+use strict;
+use warnings;
+
+use Moose;
+
+use MetaCPAN::Pod::XHTML;
+use MetaCPAN::Types qw( Uri );
+use Pod::Markdown;
+use Pod::POM;
+use Pod::POM::View::Pod;
+use Pod::Text;
+
+has perldoc_url_prefix => (
+    is      => 'rw',
+    isa     => Uri,
+    coerce  => 1,
+    default => 'https://metacpan.org/pod/',
+);
+
+sub markdown_renderer {
+    my $self = shift;
+    return Pod::Markdown->new(
+        perldoc_url_prefix => $self->perldoc_url_prefix );
+}
+
+sub pod_renderer {
+    my $self = shift;
+    return Pod::POM->new;
+}
+
+sub text_renderer {
+    my $self = shift;
+    return Pod::Text->new( sentence => 0, width => 78 );
+}
+
+sub html_renderer {
+    my $self = shift;
+
+    my $parser = MetaCPAN::Pod::XHTML->new;
+
+    $parser->html_footer('');
+    $parser->html_header('');
+    $parser->index(1);
+    $parser->no_errata_section(1);
+    $parser->perldoc_url_prefix( $self->perldoc_url_prefix );
+
+    return $parser;
+}
+
+sub to_markdown {
+    my $self   = shift;
+    my $source = shift;
+
+    return $self->_generic_render( $self->markdown_renderer, $source );
+}
+
+sub to_text {
+    my $self   = shift;
+    my $source = shift;
+
+    return $self->_generic_render( $self->text_renderer, $source );
+}
+
+sub to_html {
+    my $self   = shift;
+    my $source = shift;
+
+    return $self->_generic_render( $self->html_renderer, $source );
+}
+
+sub to_pod {
+    my $self   = shift;
+    my $source = shift;
+
+    my $renderer = $self->pod_renderer;
+    my $pom      = $renderer->parse_text($source);
+    return Pod::POM::View::Pod->print($pom);
+}
+
+sub _generic_render {
+    my $self     = shift;
+    my $renderer = shift;
+    my $source   = shift;
+    my $output   = q{};
+
+    $renderer->output_string( \$output );
+    $renderer->parse_string_document($source);
+
+    return $output;
+}
+
+__PACKAGE__->meta->make_immutable();
+1;
diff --git a/lib/MetaCPAN/Pod/XHTML.pm b/lib/MetaCPAN/Pod/XHTML.pm
@@ -4,6 +4,7 @@ use strict;
 use warnings;
 
 # Keep the coding style of Pod::Simple for consistency and performance.
+# Pod::Simple::XHTML expects you to subclass and then override methods.
 
 use parent 'Pod::Simple::XHTML';
 
@@ -26,12 +27,6 @@ sub handle_text {
     }
 }
 
-sub perldoc_url_prefix {
-    'https://metacpan.org/pod/';
-}
-
-# thanks to Marc Green
-
 sub start_item_text {
 
     # see end_item_text

diff --git a/lib/MetaCPAN/Server/View/Pod.pm b/lib/MetaCPAN/Server/View/Pod.pm
@@ -3,18 +3,19 @@ package MetaCPAN::Server::View::Pod;
 use strict;
 use warnings;
 
-use MetaCPAN::Pod::XHTML;
+use MetaCPAN::Pod::Renderer;
 use Moose;
-use Pod::Markdown;
-use Pod::POM;
-use Pod::Text;
 
 extends 'Catalyst::View';
 
 sub process {
     my ( $self, $c ) = @_;
+
+    my $renderer = MetaCPAN::Pod::Renderer->new;
+
     my $content = $c->res->body || $c->stash->{source};
-    $content = eval { join( "", $content->getlines ) };
+    $content = eval { join( q{}, $content->getlines ) };
+
     my ( $body, $content_type );
     my $accept = eval { $c->req->preferred_content_type } || 'text/html';
     my $show_errors = $c->req->params->{show_errors};
@@ -23,63 +24,42 @@ sub process {
     $x_codes = $c->config->{pod_html_x_codes} unless defined $x_codes;
 
     if ( $accept eq 'text/plain' ) {
-        $body         = $self->build_pod_txt($content);
+        $body         = $self->_factory->to_txt($content);
         $content_type = 'text/plain';
     }
     elsif ( $accept eq 'text/x-pod' ) {
-        $body         = $self->extract_pod($content);
+        $body         = $self->_factory->to_pod($content);
         $content_type = 'text/plain';
     }
     elsif ( $accept eq 'text/x-markdown' ) {
-        $body         = $self->build_pod_markdown($content);
+        $body         = $self->_factory->to_markdown($content);
         $content_type = 'text/plain';
     }
     else {
         $body = $self->build_pod_html( $content, $show_errors, $x_codes );
         $content_type = 'text/html';
     }
+
     $c->res->content_type($content_type);
     $c->res->body($body);
 }
 
-sub build_pod_markdown {
-    my ( $self, $source ) = @_;
-    my $parser = Pod::Markdown->new;
-    my $mkdn   = q[];
-    $parser->output_string( \$mkdn );
-    $parser->parse_string_document($source);
-    return $mkdn;
-}
-
 sub build_pod_html {
     my ( $self, $source, $show_errors, $x_codes ) = @_;
-    my $parser = MetaCPAN::Pod::XHTML->new();
-    $parser->index(1);
-    $parser->html_header('');
-    $parser->html_footer('');
-    $parser->perldoc_url_prefix('');
-    $parser->no_errata_section( !$show_errors );
-    $parser->nix_X_codes( !$x_codes );
-    my $html = "";
-    $parser->output_string( \$html );
-    $parser->parse_string_document($source);
-    return $html;
-}
 
-sub extract_pod {
-    my ( $self, $source ) = @_;
-    my $parser = Pod::POM->new;
-    my $pom    = $parser->parse_text($source);
-    return Pod::POM::View::Pod->print($pom);
+    my $renderer = $self->_factory->html_renderer;
+    $renderer->nix_X_codes( !$x_codes );
+    $renderer->no_errata_section( !$show_errors );
+
+    my $html = q{};
+    $renderer->output_string( \$html );
+    $renderer->parse_string_document($source);
+    return $html;
 }
 
-sub build_pod_txt {
-    my ( $self, $source ) = @_;
-    my $parser = Pod::Text->new( sentence => 0, width => 78 );
-    my $text = "";
-    $parser->output_string( \$text );
-    $parser->parse_string_document($source);
-    return $text;
+sub _factory {
+    my $self = shift;
+    return MetaCPAN::Pod::Renderer->new;
 }
 
 1;
diff --git a/t/pod/renderer.t b/t/pod/renderer.t
@@ -0,0 +1,62 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+use MetaCPAN::Pod::Renderer;
+
+my $factory       = MetaCPAN::Pod::Renderer->new();
+my $html_renderer = $factory->html_renderer;
+$html_renderer->index(0);
+
+my $got = q{};
+
+my $source = <<'EOF';
+=pod
+
+=head1 DESCRIPTION
+L<Plack>
+=cut
+EOF
+
+{
+    my $html = <<'EOF';
+<h1 id="DESCRIPTION-Plack">DESCRIPTION <a href="https://metacpan.org/pod/Plack">Plack</a></h1>
+
+EOF
+
+    $html_renderer->output_string( \$got );
+    $html_renderer->parse_string_document($source);
+    is( $got, $html, 'XHTML linkifies to metacpan by default' );
+}
+
+{
+    my $md = <<'EOF';
+# DESCRIPTION
+[Plack](https://metacpan.org/pod/Plack)
+EOF
+
+    is( $factory->to_markdown($source), $md, 'markdown' );
+}
+
+{
+    my $text = <<'EOF';
+DESCRIPTION
+Plack
+EOF
+
+    is( $factory->to_text($source), $text, 'text' );
+}
+
+{
+    my $pod = <<'EOF';
+=head1 DESCRIPTION
+L<Plack>
+=cut
+
+
+EOF
+
+    is( $factory->to_pod($source), $pod, 'pod' );
+}
+done_testing();