File Coverage

lib/CallBackery/Plugin/Doc.pm
Criterion Covered Total %
statement 101 106 95.2
branch 6 14 42.8
condition 8 18 44.4
subroutine 15 17 88.2
pod 1 1 100.0
total 131 156 83.9


line stmt bran cond sub pod time code
1             package CallBackery::Plugin::Doc;
2 1     1   9 use strict;
  1         2  
  1         33  
3 1     1   5 use warnings;
  1         2  
  1         28  
4              
5             # based on Mojolicious::Plugin::PodRenderer
6              
7 1     1   5 use Mojo::Base 'Mojolicious::Plugin';
  1         2  
  1         6  
8              
9 1     1   181 use File::Basename 'dirname';
  1         2  
  1         48  
10 1     1   5 use File::Spec;
  1         3  
  1         35  
11 1     1   6 use IO::File;
  1         2  
  1         259  
12 1     1   8 use Mojo::Asset::File;
  1         11  
  1         33  
13 1     1   40 use Mojo::ByteStream 'b';
  1         2  
  1         48  
14 1     1   6 use Mojo::DOM;
  1         2  
  1         66  
15 1     1   6 use Mojo::Util 'url_escape';
  1         2  
  1         59  
16 1     1   710 use Pod::Simple::HTML;
  1         15438  
  1         46  
17 1     1   689 use Pod::Simple::Search;
  1         6692  
  1         1145  
18              
19             # Paths
20             our @PATHS = map { ($_ , "$_/pods") } @INC;
21              
22             # "This is my first visit to the Galaxy of Terror and I'd like it to be a
23             # pleasant one."
24             sub register {
25 1     1 1 966 my ($self, $app, $conf) = @_;
26             # Config
27 1   50     5 $conf ||= {};
28 1   50     9 my $name = $conf->{name} || 'pod';
29 1   50     6 my $preprocess = $conf->{preprocess} || 'ep';
30 1   50     7 my $index = $conf->{index} || die 'index attribute is required';
31 1   50     4 my $root = $conf->{root} || die 'root attribute is required';
32 1   50     4 my $template = $conf->{template} || die 'template attribute is required';
33              
34             # Add "pod" handler
35             $app->renderer->add_handler(
36             $name => sub {
37 0     0   0 my ($r, $c, $output, $options) = @_;
38              
39             # Preprocess with ep and then render
40 0 0       0 return unless $r->handlers->{$preprocess}->($r, $c, $output, $options);
41 0         0 $$output = _pod_to_html($$output)
42             }
43 1         9 );
44              
45             # Add "pod_to_html" helper
46 1     0   40 $app->helper(pod_to_html => sub { shift; b(_pod_to_html(@_)) });
  0         0  
  0         0  
47              
48             # Perldoc
49             $app->routes->any(
50             $root.'/*module' => { module => $index } => sub {
51 2     2   2323 my $self = shift;
52              
53             # Find module
54 2         13 my $module = $self->param('module');
55 2         104 my $html;
56 2         8 my $cpan = 'http://search.cpan.org/perldoc';
57 2         10 $module =~ s/\//\:\:/g;
58 2         4 my $path;
59 2         30 $path = Pod::Simple::Search->new->find($module, @PATHS);
60             # Redirect to CPAN
61 2 50 33     1477 return $self->redirect_to("$cpan?$module")
62             unless $path && -r $path;
63              
64             # Turn POD into HTML
65 2         31 my $file = IO::File->new;
66 2         107 $file->open("< $path");
67 2         278 $html = _pod_to_html(join '', <$file>);
68              
69             # Rewrite links
70 2         62 my $dom = Mojo::DOM->new("$html");
71 2         11730 my $perldoc = $self->url_for($root.'/');
72             $dom->find('a[href]')->each(
73             sub {
74 30         4893 my $attr = shift->attr;
75 30 50       581 if ($attr->{href} =~ /^$cpan/) {
76 30         186 $attr->{href} =~ s/^$cpan\?/$perldoc/;
77 30         5236 $attr->{href} =~ s/%3A%3A/\//gi;
78             }
79             }
80 2         797 );
81              
82             # Rewrite code sections for syntax highlighting
83             # $dom->find('pre')->each(
84             # sub {
85             # my $attrs = shift->attrs;
86             # my $class = $attrs->{class};
87             # $attrs->{class} =
88             # defined $class ? "$class prettyprint lang-perl" : 'prettyprint lang-perl';
89             # }
90             # );
91              
92             # Rewrite headers
93 2         48 my $url = $self->req->url->clone;
94 2         211 $url =~ s/%2F/\//gi;
95 2         257 my $toc = Mojo::URL->new->fragment('toc');
96              
97 2         34 my $sections = [];
98 2         9 for my $e ($dom->find('h1, h2, h3')->each) {
99 14 50 33     15001 push @$sections, [] if $e->tag eq 'h1' || !@$sections;
100 14         258 my $anchor = $e->{id};
101 14         240 my $link = Mojo::URL->new->fragment($anchor);
102 14         203 push @{$sections->[-1]}, my $text = $e->all_text, $link;
  14         43  
103 14         605 my $permalink = $self->link_to('#' => $link, class => 'permalink');
104 14         5463 $e->content($permalink . $self->link_to($text => $toc, id => $anchor));
105             }
106              
107              
108             # Try to find a title
109 2         1568 my $title = 'Perldoc';
110 2         10 $dom->find('h1 + p')->first(sub { $title = shift->text });
  2         8226  
111              
112             # Combine everything to a proper response
113 2         87 $self->content_for(perldoc => "$dom");
114 2         5323 $self->content_for(index_link => $root.'/');
115             # $self->app->plugins->run_hook(before_perldoc => $self);
116 2         101 $self->render(
117             inline => $template,
118             title => $title,
119             sections => $sections
120             );
121 2         400 $self->res->headers->content_type('text/html;charset="UTF-8"');
122             }
123 1         211 );
124 1         762 return;
125             }
126              
127             sub _pod_to_html {
128 2     2   11 my $pod = shift;
129 2 50       9 return unless defined $pod;
130              
131             # Block
132 2 50       12 $pod = $pod->() if ref $pod eq 'CODE';
133              
134             # Parser
135 2         28 my $parser = Pod::Simple::HTML->new;
136 2         1277 $parser->force_title('');
137 2         23 $parser->html_header_before_title('');
138 2         18 $parser->html_header_after_title('');
139 2         22 $parser->html_footer('');
140 2         27 $parser->index(0);
141              
142             # Parse
143 2         12 my $output;
144 2         20 $parser->output_string(\$output);
145 2         1490 eval { $parser->parse_string_document("$pod") };
  2         24  
146 2 50       48944 return $@ if $@;
147              
148             # Filter
149 2         44 $output =~ s/<\/a>\n//g;
150 2         57 $output =~ s/(.*?)<\/a>/$1/sg;
151              
152 2         73 return $output;
153             }
154              
155             1;
156              
157             __END__