File Coverage

blib/lib/EPublisher/Source/Plugin/PerltutsCom.pm
Criterion Covered Total %
statement 34 46 73.9
branch 3 6 50.0
condition 3 6 50.0
subroutine 9 9 100.0
pod 2 2 100.0
total 51 69 73.9


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   139477 use strict;
  3         14  
  3         88  
7 3     3   16 use warnings;
  3         6  
  3         73  
8              
9 3     3   1533 use Encode;
  3         46703  
  3         242  
10 3     3   25 use File::Basename;
  3         7  
  3         271  
11 3     3   2143 use HTTP::Tiny;
  3         160959  
  3         122  
12              
13 3     3   1301 use parent qw( EPublisher::Source::Base );
  3         818  
  3         22  
14              
15              
16             our $VERSION = '0.6_01';
17             our $UA;
18              
19             # implementing the interface to EPublisher::Source::Base
20             sub load_source{
21 3     3 1 1750 my ($self, $name) = @_;
22              
23 3         10 $self->publisher->debug( '100: start ' . __PACKAGE__ );
24              
25 3         38 my $options = $self->_config;
26            
27 3   66     38 $name //= $options->{name};
28 3 100       10 if ( !$name ) {
29 1         4 $self->publisher->debug( '400: No tutorial name given' );
30 1         10 return;
31             }
32              
33             # fetching the requested tutorial from metacpan
34 2         9 $self->publisher->debug( "103: fetch tutorial $name" );
35              
36 2         25 return $self->_get_pod( $name );
37             }
38              
39             sub _get_pod {
40 2     2   7 my ($self,$name) = @_;
41              
42 2         9 my $response = $self->ua->get(
43             'http://perltuts.com/tutorials/' . $name . '?format=pod'
44             );
45              
46 2 50       259075 if ( $response !~ m{\A2} ) {
47 2         24 $self->publisher->debug(
48             "103: tutorial $name does not exist"
49             );
50              
51 2         53 return;
52             };
53              
54 0         0 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 0         0 eval{ $pod = decode( 'utf-8', $pod ); };
  0         0  
59              
60 0         0 my $title = $name;
61 0         0 my $info = { pod => $pod, filename => $name, title => $title };
62 0         0 my @pod = $info;
63              
64             # make some nice debug output for what is in $info
65 0         0 my $pod_short;
66 0 0       0 if ($pod =~ m/(.{50})/s) {
67 0         0 $pod_short = $1 . '[...]';
68             }
69             else {
70 0         0 $pod_short = $pod;
71             }
72              
73 0         0 $self->publisher->debug(
74             "103: passed info: "
75             . "filename => $name, "
76             . "title => $title, "
77             . 'pod => ' . substr($pod, 0, 30) . '<<<
78             );
79              
80 0         0 return @pod;
81             }
82              
83             sub ua {
84 2   33 2 1 26 $UA //= HTTP::Tiny->new;
85 2         319 $UA;
86             }
87              
88             1;
89              
90             __END__