File Coverage

blib/lib/Test/Smoke/Poster/Base.pm
Criterion Covered Total %
statement 50 54 92.5
branch 4 8 50.0
condition 1 6 16.6
subroutine 13 14 92.8
pod 4 4 100.0
total 72 86 83.7


line stmt bran cond sub pod time code
1             package Test::Smoke::Poster::Base;
2 4     4   32 use warnings;
  4         7  
  4         157  
3 4     4   22 use strict;
  4         14  
  4         70  
4 4     4   18 use Carp;
  4         12  
  4         283  
5              
6             our $VERSION = '0.002';
7              
8 4     4   41 use base 'Test::Smoke::ObjectBase';
  4         9  
  4         780  
9 4     4   449 use Test::Smoke::LogMixin;
  4         8  
  4         321  
10              
11             require Test::Smoke;
12              
13 4     4   25 use File::Spec::Functions;
  4         9  
  4         280  
14 4     4   874 use Test::Smoke::Util::LoadAJSON;
  4         9  
  4         28  
15              
16             =head1 NAME
17              
18             Test::Smoke::Poster::Base - Base class for the posters to CoreSmokeDB.
19              
20             =head1 DESCRIPTION
21              
22             Provide general methods for the poster subclasses.
23              
24             =head2 Test::Smoke::Poster::Base->new(%arguments);
25              
26             =head3 Arguments
27              
28             Named.
29              
30             =over
31              
32             =item smokedb_url => $some_url
33              
34             =item ddir => $smoke_directory
35              
36             =item jsnfile => $json_file (mktest.jsn)
37              
38             =item v => $verbosity
39              
40             =back
41              
42             =head3 Returns
43              
44             An instance of the class.
45              
46             =head3 Exceptions
47              
48             None.
49              
50             =cut
51              
52             sub new {
53 6     6 1 29 my $class = shift;
54 6         55 my %args = @_;
55             # Convert to "underscore names" for Test::Smoke::ObjecBase.
56             my %fields = map
57 6         84 +( "_$_" => delete $args{$_})
58             , keys %args;
59 6         347 return bless \%fields, $class;
60             }
61              
62             =head2 $poster->agent_string()
63              
64             Class and intstance method.
65              
66             =head3 Arguments
67              
68             None.
69              
70             =head3 Returns
71              
72             sprintf "Test::Smoke/%s (%s)", $Test::Smoke::VERSION, $class;
73              
74             =head3 Exceptions
75              
76             None.
77              
78             =cut
79              
80             sub agent_string {
81 6   33 6 1 30 my $class = ref($_[0]) || $_[0];
82              
83 6         100 return "Test::Smoke/$Test::Smoke::VERSION ($class)";
84             }
85              
86             =head2 $poster->get_json()
87              
88             =head3 Arguments
89              
90             None.
91              
92             =head3 Returns
93              
94             The json string that was stored in C<< $ddir/$jsnfile >>.
95              
96             =head3 Exceptions
97              
98             File I/O.
99              
100             =cut
101              
102             sub get_json {
103 2     2 1 13 my $self = shift;
104              
105 2         10 my $json_file = $self->json_filename();
106 2         39 $self->log_debug("Reading from (%s)", $json_file);
107 2 50       103 open my $fh, '<', $json_file or die "Cannot open($json_file): $!";
108 2         7 my $json = do { local $/; <$fh> };
  2         12  
  2         70  
109 2         22 close $fh;
110              
111 2         21 return $json;
112             }
113              
114             =head2 $poster->json_filename()
115              
116             Returns the the fully qualified file name of the jsonfile.
117              
118             =cut
119              
120             sub json_filename {
121 6     6 1 4778 my $self = shift;
122              
123 6         52 return catfile($self->ddir, $self->jsnfile);
124             }
125              
126             =head2 $poster->post()
127              
128             Post the JSON report to CoreSmokeDB.
129              
130             =head3 Arguments
131              
132             None.
133              
134             =head3 Returns
135              
136             The id of the CoreSmokeDB report on success.
137              
138             =head3 Exceptions
139              
140             HTTP or Test::Smoke::Gateway-application errors.
141              
142             =cut
143              
144             sub post {
145 2     2   2157 my $self = shift;
146              
147 2         5 my $response = eval { $self->_post_data() };
  2         8  
148 2 50       40 confess("[POST]: >$@<") if $@;
149              
150 2         6 my $response_body = eval {
151 2         33 Test::Smoke::Util::LoadAJSON->new->utf8->allow_nonref->decode($response);
152             };
153 2 50       829 confess("[decode_json] >$response< " . $@) if $@;
154              
155 2         52 $self->_process_post_result($response_body);
156             }
157              
158             =head2 $poster->_post_data()
159              
160             Abstract method that should be implemented by the subclass.
161              
162             =head3 Arguments
163              
164             None.
165              
166             =head3 Returns
167              
168             The body of the response.
169              
170             =cut
171              
172             sub _post_data {
173 0   0 0   0 my $class = ref($_[0]) || $_[0];
174 0         0 croak("Must be implemented by '$class'");
175             }
176              
177             =head2 $poster->_process_post_result($response_body)
178              
179             Process the result of the POST action to CoreSmokeDB.
180              
181             =head3 Arguments
182              
183             Positional.
184              
185             =over
186              
187             =item $response_body (the raw JSON string send by CoreSmokeDB)
188              
189             =back
190              
191             =head3 Returns
192              
193             The id of the report on success, I on failure.
194              
195             =cut
196              
197             sub _process_post_result {
198 2     2   7 my $self = shift;
199 2         7 my ($body) = @_;
200              
201 2 50       7 if (exists $body->{error}) {
202 0         0 $self->log_info("CoreSmokeDB: %s", $body->{error});
203 0         0 return;
204             }
205 2         17 return $body->{id};
206             }
207              
208             1;
209              
210             =head1 COPYRIGHT
211              
212             (c) 2002-2013, Abe Timmerman All rights reserved.
213              
214             With contributions from Jarkko Hietaniemi, Merijn Brand, Campo
215             Weijerman, Alan Burlison, Allen Smith, Alain Barbet, Dominic Dunlop,
216             Rich Rauenzahn, David Cantrell.
217              
218             This library is free software; you can redistribute it and/or modify
219             it under the same terms as Perl itself.
220              
221             See:
222              
223             =over 4
224              
225             =item * L
226              
227             =item * L
228              
229             =back
230              
231             This program is distributed in the hope that it will be useful,
232             but WITHOUT ANY WARRANTY; without even the implied warranty of
233             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
234              
235             =cut