File Coverage

blib/lib/EPublisher/Source/Plugin/PerltutsCom.pm
Criterion Covered Total %
statement 34 46 73.9
branch 5 8 62.5
condition 3 3 100.0
subroutine 9 9 100.0
pod 2 2 100.0
total 53 68 77.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   186296 use strict;
  3         16  
  3         93  
7 3     3   16 use warnings;
  3         5  
  3         78  
8              
9 3     3   1679 use Encode;
  3         29600  
  3         221  
10 3     3   27 use File::Basename;
  3         7  
  3         270  
11 3     3   1983 use HTTP::Tiny;
  3         157882  
  3         198  
12              
13 3     3   1599 use parent qw( EPublisher::Source::Base );
  3         970  
  3         20  
14              
15              
16             our $VERSION = '0.6_02';
17             our $UA;
18              
19             # implementing the interface to EPublisher::Source::Base
20             sub load_source{
21 6     6 1 6168 my ($self, $name) = @_;
22              
23 6         20 $self->publisher->debug( '100: start ' . __PACKAGE__ );
24              
25 6         64 my $options = $self->_config;
26            
27 6   100     61 $name //= $options->{name};
28 6 100       19 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 5         17 $self->publisher->debug( "103: fetch tutorial $name" );
35              
36 5         51 return $self->_get_pod( $name );
37             }
38              
39             sub _get_pod {
40 5     5   15 my ($self,$name) = @_;
41              
42 5         17 my $response = $self->ua->get(
43             'http://perltuts.com/tutorials/' . $name . '?format=pod'
44             );
45              
46 5 50       373782 if ( $response->{status} !~ m{\A2} ) {
47 5         42 $self->publisher->debug(
48             "103: tutorial $name does not exist"
49             );
50              
51 5         152 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 5 100   5 1 48 $UA = HTTP::Tiny->new if !$UA;
85 5         322 $UA;
86             }
87              
88             1;
89              
90             __END__