File Coverage

blib/lib/Test/Smoke/Poster.pm
Criterion Covered Total %
statement 42 45 93.3
branch 5 10 50.0
condition 1 3 33.3
subroutine 9 9 100.0
pod 1 1 100.0
total 58 68 85.2


line stmt bran cond sub pod time code
1             package Test::Smoke::Poster;
2 4     4   412 use warnings;
  4         8  
  4         138  
3 4     4   19 use strict;
  4         8  
  4         85  
4 4     4   17 use Carp;
  4         9  
  4         314  
5              
6             our $VERSION = '0.001';
7              
8 4     4   30 use Cwd qw/:DEFAULT abs_path/;
  4         7  
  4         626  
9 4     4   574 use File::Spec::Functions qw/:DEFAULT rel2abs/;
  4         984  
  4         588  
10 4     4   1642 use Test::Smoke::Poster::Curl;
  4         13  
  4         151  
11 4     4   1692 use Test::Smoke::Poster::HTTP_Tiny;
  4         10  
  4         121  
12 4     4   1584 use Test::Smoke::Poster::LWP_UserAgent;
  4         10  
  4         1747  
13              
14             =head1 NAME
15              
16             Test::Smoke::Poster - Factory for poster objects.
17              
18             =head1 SYNOPSIS
19              
20             use Test::Smoke::Poster;
21             my $poster = Test::Smoke::Poster->new(
22             'LWP::UserAgent',
23             ddir => '.',
24             smokedb_url => 'http://perl5.test-smoke.org/report',
25             );
26             $poster->post();
27              
28             =head1 DESCRIPTION
29              
30             Returns a instance of the object-class requested.
31              
32             =cut
33              
34             my %CONFIG = (
35             df_poster => 'HTTP::Tiny',
36             df_ddir => undef,
37             df_jsnfile => 'mktest.jsn',
38             df_v => 0,
39              
40             df_smokedb_url => 'http://perl5.test-smoke.org/report',
41              
42             df_ua_timeout => undef,
43              
44             df_curlargs => [ ],
45              
46             'LWP::UserAgent' => {
47             allowed => [qw/ua_timeout/],
48             required => [],
49             class => 'Test::Smoke::Poster::LWP_UserAgent',
50             },
51             'HTTP::Tiny' => {
52             allowed => [qw/ua_timeout/],
53             required => [],
54             class => 'Test::Smoke::Poster::HTTP_Tiny',
55             },
56             'curl' => {
57             allowed => [qw/curlbin curlargs ua_timeout/],
58             required => [qw/curlbin/],
59             class => 'Test::Smoke::Poster::Curl',
60             },
61              
62             valid_type => {
63             'LWP::UserAgent' => 1,
64             'HTTP::Tiny' => 1,
65             },
66              
67             general_options => [qw/ddir jsnfile v smokedb_url poster/],
68             );
69              
70             =head2 Test::Smoke::Poster->new($poster_type, %arguments)
71              
72             Check arguments and return an instance of $poster_type.
73              
74             =cut
75              
76             sub new {
77 6     6 1 117 my $factory = shift;
78 6   33     52 my $poster = shift || $CONFIG{df_poster};
79              
80 6 50       115 my %args = ref $_[0] eq 'HASH' ? %{$_[0]} : @_;
  0         0  
81              
82             my %fields = map {
83 36 100       86 my $value = exists $args{$_} ? $args{ $_ } : $CONFIG{ "df_$_" };
84 36         135 ( $_ => $value )
85 6         25 } ( @{ $CONFIG{general_options} }, @{ $CONFIG{$poster}{allowed} } );
  6         24  
  6         22  
86 6 50       77 if ( ! file_name_is_absolute( $fields{ddir} ) ) {
87 6         259 $fields{ddir} = catdir( abs_path(), $fields{ddir} );
88             }
89 6         103 $fields{ddir} = rel2abs( $fields{ddir}, abs_path() );
90 6         188 $fields{poster} = $poster;
91              
92 6         13 my @missing;
93 6         30 for my $required (@{ $CONFIG{$poster}{required} }) {
  6         39  
94             push(
95             @missing,
96             "option '$required' missing for '$CONFIG{$poster}{class}'"
97 0 0       0 ) if !defined $fields{$required};
98             }
99 6 50       32 if (@missing) {
100 0         0 croak("Missing option:\n\t", join("\n\t", @missing));
101             }
102              
103 6         29 my $class = $CONFIG{$poster}{class};
104 6         91 return $class->new(%fields);
105             }
106              
107             1;
108              
109             =head1 COPYRIGHT
110              
111             (c) 2002-2013, Abe Timmerman All rights reserved.
112              
113             With contributions from Jarkko Hietaniemi, Merijn Brand, Campo
114             Weijerman, Alan Burlison, Allen Smith, Alain Barbet, Dominic Dunlop,
115             Rich Rauenzahn, David Cantrell.
116              
117             This library is free software; you can redistribute it and/or modify
118             it under the same terms as Perl itself.
119              
120             See:
121              
122             =over 4
123              
124             =item * L
125              
126             =item * L
127              
128             =back
129              
130             This program is distributed in the hope that it will be useful,
131             but WITHOUT ANY WARRANTY; without even the implied warranty of
132             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
133              
134             =cut