File Coverage

blib/lib/App/Smolder/Report.pm
Criterion Covered Total %
statement 130 133 97.7
branch 62 72 86.1
condition n/a
subroutine 26 26 100.0
pod 0 12 0.0
total 218 243 89.7


line stmt bran cond sub pod time code
1             package App::Smolder::Report;
2              
3 3     3   162040 use warnings;
  3         6  
  3         110  
4 3     3   17 use strict;
  3         4  
  3         102  
5 3     3   93 use 5.008;
  3         15  
  3         125  
6 3     3   8389 use LWP::UserAgent;
  3         530944  
  3         337  
7 3     3   7197 use Getopt::Long;
  3         139081  
  3         25  
8 3     3   7763 use Carp::Clan qw(App::Smolder::Report);
  3         11967  
  3         29  
9              
10             our $VERSION = '0.04';
11              
12              
13             ###################
14             # Smolder reporting
15              
16             sub report {
17 12     12 0 13037 my $self = shift;
18            
19 12         33 $self->{run_as_api} = 1;
20 12         42 return $self->_do_report(@_);
21             }
22              
23             sub _do_report {
24 13     13   25 my $self = shift;
25            
26 13 100       41 $self->_fatal("Required 'server' setting is empty or missing")
27             unless $self->server;
28 12 100       33 $self->_fatal("Required 'project_id' setting is empty or missing")
29             unless $self->project_id;
30 11 100       59 $self->_fatal("Required 'username' setting is empty or missing")
31             unless $self->username;
32 10 100       25 $self->_fatal("Required 'password' setting is empty or missing")
33             unless $self->password;
34 9 100       24 $self->_fatal("You must provide at least one report to upload")
35             unless @_;
36            
37 8         29 return $self->_upload_reports(@_);
38             }
39              
40             sub _upload_reports {
41 8     8   20 my ($self, @reports) = @_;
42 8         16 my $server = $self->server;
43 8         10 my $reports_url;
44            
45 8 100       40 $server = "http://$server"
46             unless $server =~ m/^http/;
47            
48 8         52 my $ua = LWP::UserAgent->new;
49 8         52 my $url
50             = $server
51             . '/app/developer_projects/process_add_report/'
52             . $self->project_id;
53            
54             REPORT_FILE:
55 8         18 foreach my $report_file (@reports) {
56 11 100       289 $self->_fatal("Could not read report file '$report_file'")
57             unless -r $report_file;
58            
59 10 100       32 if ($self->dry_run) {
60 1         7 $self->_log("Dry run: would POST to $url: $report_file");
61 1         4 next REPORT_FILE;
62             }
63            
64 9         25 my $response = $ua->post(
65             $url,
66             'Content-Type' => 'form-data',
67             'Content' => [
68             username => $self->username,
69             password => $self->password,
70             tags => '',
71             report_file => [$report_file],
72             ],
73             );
74            
75 9 100       1150 if ($response->code == 302) {
76 8 100       88 if (! $reports_url) {
77 6         35 $reports_url = $response->header('Location');
78 6 50       279 $reports_url = "$server$reports_url"
79             unless $reports_url =~ m/^http/;
80             }
81            
82 8         34 $self->_log("Report '$report_file' sent successfully");
83            
84 8 100       21 if ($self->delete) {
85 2 50       154 if (!unlink($report_file)) {
86 0         0 $self->_log("WARNING: could not delete file $report_file: $!");
87             }
88             }
89             }
90             else {
91 1         15 $self->_fatal(
92             "Could not upload report '$report_file'",
93             "HTTP Code: ".$response->code,
94             $response->message,
95             );
96             }
97             }
98            
99 6 100       30 $self->_log("See all reports at $reports_url") if $reports_url;
100 6         76 return $reports_url;
101             }
102              
103              
104             ###################################
105             # Configuration loading and merging
106              
107             sub _load_configs {
108 5     5   39 my ($self) = @_;
109            
110 5         35 my $filename = '.smolder.conf';
111 5         10 my @files_to_check = ($filename);
112 5 50       27 unshift @files_to_check, "$ENV{HOME}/$filename" if $ENV{HOME};
113 5 100       19 push @files_to_check, $ENV{APP_SMOLDER_REPORT_CONF}
114             if $ENV{APP_SMOLDER_REPORT_CONF};
115            
116 5         8 foreach my $file (@files_to_check) {
117 14         28 $self->_merge_cfg_file($file);
118             }
119            
120 5         12 return;
121             }
122              
123             sub _merge_cfg_file {
124 15     15   57 my ($self, $file) = @_;
125            
126 15         53 my $cfg = $self->_read_cfg_file($file);
127 15 50       37 return unless $cfg;
128            
129 15         37 $self->_merge_cfg_hash($cfg);
130            
131 15 100       36 if (%$cfg) {
132 1         4 my @bad_keys = sort keys %$cfg;
133 1         4 $self->_fatal("Invalid configuration keys in $file:", @bad_keys);
134             }
135            
136 14         35 return;
137             }
138              
139             sub _read_cfg_file {
140 17     17   128 my ($self, $file) = @_;
141 17         22 my %cfg;
142 17         20 local $_;
143            
144 17 50       803 open(my $fh, '<', $file) || return;
145 17         301 while (<$fh>) {
146 57         354 s/^\s+|\s+$//g;
147 57 100       212 next if /^(#.*)?$/;
148            
149 44 100       215 if (/^(\S+)\s*=\s*(["'])(.*)\2$/) {
    100          
150 32         200 $cfg{$1} = $3;
151             }
152             elsif (/^(\S+)\s*=\s*(.+)$/) {
153 11         106 $cfg{$1} = $2;
154             }
155             else {
156 1         13 $self->_fatal("Could not parse line $. of $file: $_");
157             }
158             }
159 16         172 close($fh);
160            
161 16         97 return \%cfg;
162             }
163              
164             sub _merge_cfg_hash {
165 24     24   23509 my ($self, $cfg) = @_;
166            
167 24         63 my @valid_settings = qw{
168             server project_id
169             username password
170             delete
171             };
172 24         48 foreach my $cfg_key (@valid_settings) {
173 120 100       282 next unless exists $cfg->{$cfg_key};
174 49         129 $self->{$cfg_key} = delete $cfg->{$cfg_key};
175             }
176            
177 24         61 return;
178             }
179              
180              
181             ##################################
182             # Deal with command line arguments
183              
184             sub process_args {
185 2     2 0 60 my ($self) = @_;
186            
187 2         3 my ($username, $password, $server, $project_id, $dry_run, $delete, $quiet);
188 2         17 my $ok = GetOptions(
189             "username=s" => \$username,
190             "password=s" => \$password,
191             "server=s" => \$server,
192             "project-id=i" => \$project_id,
193             "dry-run|n" => \$dry_run,
194             "quiet" => \$quiet,
195             "delete" => \$delete,
196             );
197 2 50       1787 exit(2) unless $ok;
198            
199 2         8 $self->_load_configs;
200            
201 2 100       7 $self->{username} = $username if defined $username;
202 2 50       6 $self->{password} = $password if defined $password;
203 2 100       7 $self->{server} = $server if defined $server;
204 2 100       6 $self->{project_id} = $project_id if defined $project_id;
205 2 100       6 $self->{dry_run} = $dry_run if defined $dry_run;
206 2 100       10 $self->{quiet} = $quiet if defined $quiet;
207 2 50       6 $self->{delete} = $delete if defined $delete;
208            
209 2         7 return;
210             }
211              
212             sub run {
213 1     1 0 38 my $self = shift;
214            
215 1         3 $self->{run_as_api} = 0;
216 1         5 return $self->_do_report(@_);
217             }
218              
219              
220             #######
221             # Utils
222              
223             sub _fatal {
224 9     9   40 my ($self, $mesg, @more) = @_;
225            
226 9         21 $mesg = "FATAL: $mesg\n";
227 9         19 foreach my $line (@more) {
228 3         8 $mesg .= " $line\n";
229             }
230            
231 9 50       24 croak($mesg) if $self->run_as_api;
232              
233 0         0 print $mesg;
234 0         0 exit(1);
235             }
236              
237             sub _log {
238 14     14   25 my ($self, $mesg) = @_;
239 14 100       32 return if $self->run_as_api;
240 2 50       7 return if $self->quiet;
241              
242 2         55 print "$mesg\n";
243              
244 2         6 return;
245             }
246              
247              
248             ###########################
249             # Constructor and accessors
250             # boring stuff
251              
252             sub new {
253 7     7 0 43 my $class = shift;
254 7         20 my $self = bless {}, $class;
255              
256 7         12 my %args;
257 7 100       24 if (ref($_[0])) { %args = %{$_[0]} }
  2         4  
  2         13  
258 5         12 else { %args = @_ }
259              
260 7 100       28 $self->_load_configs if delete $args{load_config};
261            
262 7         30 while (my ($k, $v) = each %args) {
263 2         14 $self->{$k} = $v;
264             }
265            
266 7         21 return $self;
267             }
268              
269 13     13 0 510 sub dry_run { return $_[0]{dry_run} }
270 4     4 0 19 sub quiet { return $_[0]{quiet} }
271 28     28 0 112 sub username { return $_[0]{username} }
272 27     27 0 143 sub password { return $_[0]{password} }
273 10     10 0 76 sub delete { return $_[0]{delete} }
274 28     28 0 115 sub project_id { return $_[0]{project_id} }
275 29     29 0 158 sub server { return $_[0]{server} }
276 24     24 0 130 sub run_as_api { return $_[0]{run_as_api} }
277              
278             __END__