File Coverage

blib/lib/EPublisher/Source/Plugin/PerltutsCom.pm
Criterion Covered Total %
statement 46 46 100.0
branch 8 8 100.0
condition 3 3 100.0
subroutine 9 9 100.0
pod 2 2 100.0
total 68 68 100.0


line stmt bran cond sub pod time code
1             package EPublisher::Source::Plugin::PerltutsCom;
2              
3              
4             # ABSTRACT: Get POD from tutorials published on perltuts.com
5              
6 3     3   118301 use strict;
  3         16  
  3         76  
7 3     3   15 use warnings;
  3         4  
  3         64  
8              
9 3     3   1390 use Encode;
  3         25698  
  3         201  
10 3     3   20 use File::Basename;
  3         6  
  3         264  
11 3     3   1677 use HTTP::Tiny;
  3         124499  
  3         119  
12              
13 3     3   1246 use parent qw( EPublisher::Source::Base );
  3         736  
  3         18  
14              
15              
16             our $VERSION = '0.7';
17             our $UA;
18              
19             # implementing the interface to EPublisher::Source::Base
20             sub load_source{
21 7     7 1 12564 my ($self, $name) = @_;
22              
23 7         24 $self->publisher->debug( '100: start ' . __PACKAGE__ );
24              
25 7         64 my $options = $self->_config;
26            
27 7   100     60 $name //= $options->{name};
28 7 100       20 if ( !$name ) {
29 1         3 $self->publisher->debug( '400: No tutorial name given' );
30 1         8 return;
31             }
32              
33             # fetching the requested tutorial from metacpan
34 6         17 $self->publisher->debug( "103: fetch tutorial $name" );
35              
36 6         51 return $self->_get_pod( $name );
37             }
38              
39             sub _get_pod {
40 6     6   16 my ($self,$name) = @_;
41              
42 6         19 my $response = $self->ua->get(
43             'http://perltuts.com/tutorials/' . $name . '?format=pod'
44             );
45              
46 6 100       321378 if ( $response->{status} !~ m{\A2} ) {
47 4         33 $self->publisher->debug(
48             "103: tutorial $name does not exist"
49             );
50              
51 4         78 return;
52             };
53              
54 2         5 my $pod = $response->{content};
55              
56             # perltuts.com always provides utf-8 encoded data, so we have
57             # to decode it otherwise the target plugins may produce garbage
58 2         6 eval{ $pod = decode( 'utf-8', $pod ); };
  2         10  
59              
60 2         267 my $title = $name;
61 2         11 my $info = { pod => $pod, filename => $name, title => $title };
62 2         6 my @pod = $info;
63              
64             # make some nice debug output for what is in $info
65 2         4 my $pod_short;
66 2 100       19 if ($pod =~ m/(.{50})/s) {
67 1         6 $pod_short = $1 . '[...]';
68             }
69             else {
70 1         3 $pod_short = $pod;
71             }
72              
73 2         21 $self->publisher->debug(
74             "103: passed info: "
75             . "filename => $name, "
76             . "title => $title, "
77             . 'pod => ' . substr($pod, 0, 30) . '<<<
78             );
79              
80 2         58 return @pod;
81             }
82              
83             sub ua {
84 6 100   6 1 33 $UA = HTTP::Tiny->new if !$UA;
85 6         315 $UA;
86             }
87              
88             1;
89              
90             __END__