File Coverage

blib/lib/Test/Reporter.pm
Criterion Covered Total %
statement 318 455 69.8
branch 119 282 42.2
condition 15 77 19.4
subroutine 39 48 81.2
pod 16 16 100.0
total 507 878 57.7


line stmt bran cond sub pod time code
1 4     4   71619 use 5.006;
  4         8  
  4         117  
2 4     4   14 use strict;
  4         5  
  4         99  
3 4     4   12 use warnings;
  4         5  
  4         167  
4             package Test::Reporter;
5              
6             our $VERSION = '1.61'; # TRIAL
7              
8 4     4   14 use Cwd;
  4         4  
  4         219  
9 4     4   15 use Config;
  4         5  
  4         111  
10 4     4   13 use Carp;
  4         4  
  4         167  
11 4     4   755 use FileHandle;
  4         3277  
  4         15  
12 4     4   2169 use File::Temp;
  4         19313  
  4         231  
13 4     4   1673 use Sys::Hostname;
  4         3167  
  4         178  
14 4     4   10117 use Time::Local ();
  4         5105  
  4         100  
15 4     4   20 use vars qw($AUTOLOAD $Tempfile $Report $DNS $Domain $Send);
  4         4  
  4         237  
16 4     4   13 use constant FAKE_NO_NET_DNS => 0; # for debugging only
  4         3  
  4         134  
17 4     4   12 use constant FAKE_NO_NET_DOMAIN => 0; # for debugging only
  4         4  
  4         109  
18 4     4   12 use constant FAKE_NO_MAIL_SEND => 0; # for debugging only
  4         4  
  4         10826  
19              
20             local $^W = 1;
21              
22             sub new {
23 12     12 1 1926 my $type = shift;
24 12   33     77 my $class = ref($type) || $type;
25 12         408 my $self = {
26             '_grade' => undef,
27             '_distribution' => undef,
28             # XXX distfile => undef would break old clients :-( -- dagolden, 2009-03-30
29             '_distfile' => '',
30             '_report' => undef,
31             '_subject' => undef,
32             '_from' => undef,
33             '_comments' => '',
34             '_errstr' => '',
35             '_via' => '',
36             '_timeout' => 120,
37             '_debug' => 0,
38             '_dir' => '',
39             '_subject_lock' => 0,
40             '_report_lock' => 0,
41             '_perl_version' => {
42             '_archname' => $Config{archname},
43             '_osvers' => $Config{osvers},
44             },
45             '_transport' => '',
46             '_transport_args' => [],
47             # DEPRECATED ARGS
48             '_address' => 'cpan-testers@perl.org',
49             '_mx' => ['mx.develooper.com'],
50             '_mail_send_args' => '',
51             };
52              
53 12         64 bless $self, $class;
54              
55 12         43 $self->{_perl_version}{_myconfig} = $self->_get_perl_V;
56 12         153 $self->{_perl_version}{_version} = $self->_normalize_perl_version;
57              
58 108         357 $self->{_attr} = {
59 12         68 map {$_ => 1} qw(
60             _address _distribution _distfile _comments _errstr _via _timeout _debug _dir
61             )
62             };
63              
64 12 50       72 warn __PACKAGE__, ": new\n" if $self->debug();
65 12 50       64 croak __PACKAGE__, ": new: even number of named arguments required"
66             unless scalar @_ % 2 == 0;
67              
68 12 100       73 $self->_process_params(@_) if @_;
69 12 100       48 $self->transport('Null') unless $self->transport();
70 12 50       59 $self->_get_mx(@_) if $self->_have_net_dns();
71              
72 12         92 return $self;
73             }
74              
75             sub debug {
76 254     254 1 268 my $self = shift;
77 254         752 return $self->{_debug};
78             }
79              
80             sub _get_mx {
81 12     12   228165 my $self = shift;
82 12 50       35 warn __PACKAGE__, ": _get_mx\n" if $self->debug();
83              
84 12         40 my %params = @_;
85              
86 12 100       33 return if exists $params{'mx'};
87              
88 11   33     237 my $dom = $params{'address'} || $self->address();
89 11         18 my @mx;
90              
91 11         65 $dom =~ s/^.+\@//;
92              
93 11         68 for my $mx (sort {$a->preference() <=> $b->preference()} Net::DNS::mx($dom)) {
  0         0  
94 11         60165 push @mx, $mx->exchange();
95             }
96              
97 11 50       597 if (not @mx) {
98 0 0       0 warn __PACKAGE__,
99             ": _get_mx: unable to find MX's for $dom, using defaults\n" if
100             $self->debug();
101 0         0 return;
102             }
103              
104 11         66 $self->mx(\@mx);
105             }
106              
107             sub _process_params {
108 4     4   11 my $self = shift;
109 4 50       16 warn __PACKAGE__, ": _process_params\n" if $self->debug();
110              
111 4         57 my %params = @_;
112 4         46 my @defaults = qw(
113             mx address grade distribution distfile from comments via timeout debug dir perl_version transport_args transport );
114 4         11 my %defaults = map {$_ => 1} @defaults;
  56         103  
115              
116 4         29 for my $param (keys %params) {
117 19 50       40 croak __PACKAGE__, ": new: parameter '$param' is invalid." unless
118             exists $defaults{$param};
119             }
120              
121             # XXX need to process transport_args directly rather than through
122             # the following -- store array ref directly
123 4         15 for my $param (keys %params) {
124 19         407 $self->$param($params{$param});
125             }
126             }
127              
128             sub subject {
129 14     14 1 4057 my $self = shift;
130 14 50       31 warn __PACKAGE__, ": subject\n" if $self->debug();
131 14 50 33     92 croak __PACKAGE__, ": subject: grade and distribution must first be set"
132             if not defined $self->{_grade} or not defined $self->{_distribution};
133              
134 14 100       64 return $self->{_subject} if $self->{_subject_lock};
135              
136 10         56 my $subject = uc($self->{_grade}) . ' ' . $self->{_distribution} .
137             " $self->{_perl_version}->{_archname} $self->{_perl_version}->{_osvers}";
138              
139 10         31 return $self->{_subject} = $subject;
140             }
141              
142             sub report {
143 21     21 1 40 my $self = shift;
144 21 50       39 warn __PACKAGE__, ": report\n" if $self->debug();
145              
146 21 100       66 return $self->{_report} if $self->{_report_lock};
147              
148 15         17 my $report;
149 15         29 $report .= "This distribution has been tested as part of the CPAN Testers\n";
150 15         19 $report .= "project, supporting the Perl programming language. See\n";
151 15         67 $report .= "http://wiki.cpantesters.org/ for more information or email\n";
152 15         20 $report .= "questions to cpan-testers-discuss\@perl.org\n\n";
153              
154 15 100       39 if (not $self->{_comments}) {
155 9         11 $report .= "\n\n--\n\n";
156             }
157             else {
158 6         12 $report .= "\n--\n" . $self->{_comments} . "\n--\n\n";
159             }
160              
161 15         70 $report .= $self->{_perl_version}->{_myconfig};
162              
163 15         26 chomp $report;
164 15         23 chomp $report;
165              
166 15         78 return $self->{_report} = $report;
167             }
168              
169             sub grade {
170 18     18 1 2171 my ($self, $grade) = @_;
171 18 50       40 warn __PACKAGE__, ": grade\n" if $self->debug();
172              
173 18         112 my %grades = (
174             'pass' => "all tests passed",
175             'fail' => "one or more tests failed",
176             'na' => "distribution will not work on this platform",
177             'unknown' => "distribution did not include tests",
178             );
179              
180 18 100       103 return $self->{_grade} if scalar @_ == 1;
181              
182 8 50       26 croak __PACKAGE__, ":grade: '$grade' is invalid, choose from: " .
183             join ' ', keys %grades unless $grades{$grade};
184              
185 8         30 return $self->{_grade} = $grade;
186             }
187              
188             sub transport {
189 29     29 1 697 my $self = shift;
190 29 50       56 warn __PACKAGE__, ": transport\n" if $self->debug();
191              
192 29 100       122 return $self->{_transport} unless scalar @_;
193              
194 15         26 my $transport = shift;
195              
196 15         45 my $transport_class = "Test::Reporter::Transport::$transport";
197 15 100       1488 unless ( eval "require $transport_class; 1" ) { ## no critic
198 1         166 croak __PACKAGE__ . ": could not load '$transport_class'\n$@\n";
199             }
200              
201 14         50 my @args = @_;
202              
203             # XXX keep this for legacy support
204 14 50 66     140 if ( @args && $transport eq 'Mail::Send' && ref $args[0] eq 'ARRAY' ) {
    100 33        
205             # treat as old form of Mail::Send arguments and convert to list
206 0         0 $self->transport_args(@{$args[0]});
  0         0  
207             }
208             elsif ( @args ) {
209 2         11 $self->transport_args(@args);
210             }
211              
212 14         69 return $self->{_transport} = $transport;
213             }
214              
215             sub edit_comments {
216 0     0 1 0 my($self, %args) = @_;
217 0 0       0 warn __PACKAGE__, ": edit_comments\n" if $self->debug();
218              
219 0         0 my %tempfile_args = (
220             UNLINK => 1,
221             SUFFIX => '.txt',
222             EXLOCK => 0,
223             );
224              
225 0 0 0     0 if (exists $args{'suffix'} && defined $args{'suffix'} && length $args{'suffix'}) {
      0        
226 0         0 $tempfile_args{SUFFIX} = $args{'suffix'};
227             # prefix the extension with a period, if the user didn't.
228 0         0 $tempfile_args{SUFFIX} =~ s/^(?!\.)(?=.)/./;
229             }
230              
231 0         0 ($Tempfile, $Report) = File::Temp::tempfile(%tempfile_args);
232              
233 0         0 print $Tempfile $self->{_comments};
234              
235 0         0 $self->_start_editor();
236              
237 0         0 my $comments;
238             {
239 0         0 local $/;
  0         0  
240 0 0       0 open my $fh, "<", $Report or die __PACKAGE__, ": Can't open comment file '$Report': $!";
241 0         0 $comments = <$fh>;
242 0 0       0 close $fh or die __PACKAGE__, ": Can't close comment file '$Report': $!";
243             }
244              
245 0         0 chomp $comments;
246              
247 0         0 $self->{_comments} = $comments;
248              
249 0         0 return;
250             }
251              
252             sub send {
253 1     1 1 7 my ($self) = @_;
254 1 50       3 warn __PACKAGE__, ": send\n" if $self->debug();
255              
256 1         4 $self->from();
257 1         3 $self->report();
258 1         3 $self->subject();
259              
260 1 50       9 return unless $self->_verify();
261              
262 1 50       30 if ($self->_is_a_perl_release($self->distribution())) {
263 0         0 $self->errstr(__PACKAGE__ . ": use perlbug for reporting test " .
264             "results against perl itself");
265 0         0 return;
266             }
267              
268 1   50     4 my $transport_type = $self->transport() || 'Null';
269 1         4 my $transport_class = "Test::Reporter::Transport::$transport_type";
270 1         3 my $transport = $transport_class->new( $self->transport_args() );
271              
272 1 50       4 unless ( eval { $transport->send( $self ) } ) {
  1         6  
273 0         0 $self->errstr(__PACKAGE__ . ": error from '$transport_class:'\n$@\n");
274 0         0 return;
275             }
276              
277 1         13 return 1;
278             }
279              
280             sub _normalize_perl_version {
281 12     12   30 my $self = shift;
282 12         271 my $perl_version = sprintf("v%vd",$^V);
283 12         79 my $perl_V = $self->perl_version->{_myconfig};
284 12         94 my ($rc) = $perl_V =~ /Locally applied patches:\n\s+(RC\d+)/m;
285 12 50       29 $perl_version .= " $rc" if $rc;
286 12         45 return $perl_version;
287             }
288              
289             sub write {
290 3     3 1 984 my $self = shift;
291 3 50       14 warn __PACKAGE__, ": write\n" if $self->debug();
292              
293 3         48 my $from = $self->from();
294 3         11 my $report = $self->report();
295 3         12 my $subject = $self->subject();
296 3         136 my $distribution = $self->distribution();
297 3         11 my $grade = $self->grade();
298 3   66     54 my $dir = $self->dir() || cwd;
299 3   50     31 my $distfile = $self->{_distfile} || '';
300 3         25 my $perl_version = $self->perl_version->{_version};
301              
302 3 50       18 return unless $self->_verify();
303              
304 3         13 $distribution =~ s/[^A-Za-z0-9\.\-]+//g;
305              
306 3 50       7 my($fh, $file); unless ($fh = $_[0]) {
  3         17  
307 3         17 $file = "$grade.$distribution.$self->{_perl_version}->{_archname}.$self->{_perl_version}->{_osvers}.${\(time)}.$$.rpt";
  3         24  
308              
309 3 50       19 if ($^O eq 'VMS') {
310 0         0 $file = "$grade.$distribution.$self->{_perl_version}->{_archname}";
311 0         0 my $ext = "$self->{_perl_version}->{_osvers}.${\(time)}.$$.rpt";
  0         0  
312             # only 1 period in filename
313             # we also only have 39.39 for filename
314 0         0 $file =~ s/\./_/g;
315 0         0 $ext =~ s/\./_/g;
316 0         0 $file = $file . '.' . $ext;
317             }
318              
319 3         86 $file = File::Spec->catfile($dir, $file);
320              
321 3 50       10 warn $file if $self->debug();
322 3         35 $fh = FileHandle->new();
323 3 50       519 open $fh, ">", $file or die __PACKAGE__, ": Can't open report file '$file': $!";
324             }
325 3         50 print $fh "From: $from\n";
326 3 50       16 if ($distfile ne '') {
327 3         14 print $fh "X-Test-Reporter-Distfile: $distfile\n";
328             }
329 3         13 print $fh "X-Test-Reporter-Perl: $perl_version\n";
330 3         9 print $fh "Subject: $subject\n";
331 3         18 print $fh "Report: $report";
332 3 50       16 unless ($_[0]) {
333 3 50       137 close $fh or die __PACKAGE__, ": Can't close report file '$file': $!";
334 3 50       12 warn $file if $self->debug();
335 3         35 return $file;
336             } else {
337 0         0 return $fh;
338             }
339             }
340              
341             sub read {
342 3     3 1 11 my ($self, $file) = @_;
343 3 50       11 warn __PACKAGE__, ": read\n" if $self->debug();
344              
345             # unlock these; if not locked later, we have a parse error
346 3         9 $self->{_report_lock} = $self->{_subject_lock} = 0;
347              
348 3         6 my $buffer;
349              
350             {
351 3         6 local $/;
  3         18  
352 3 50       153 open my $fh, "<", $file or die __PACKAGE__, ": Can't open report file '$file': $!";
353 3         68 $buffer = <$fh>;
354 3 50       38 close $fh or die __PACKAGE__, ": Can't close report file '$file': $!";
355             }
356              
357             # convert line endings
358 3         11 my $CR = "\015";
359 3         7 my $LF = "\012";
360 3         143 $buffer =~ s{$CR$LF}{$LF}g;
361 3         32 $buffer =~ s{$CR}{$LF}g;
362              
363             # parse out headers
364 3         48 foreach my $line (split(/\n/, $buffer)) {
365 15 50       74 if ($line =~ /^(.+):\s(.+)$/) {
366 15         36 my ($header, $content) = ($1, $2);
367 15 100       63 if ($header eq "From") {
    100          
    100          
    100          
    50          
368 3         12 $self->{_from} = $content;
369             } elsif ($header eq "Subject") {
370 3         7 $self->{_subject} = $content;
371 3         20 my ($grade, $distribution, $archname) = (split /\s/, $content)[0..2];
372 3         8 $self->{_grade} = lc $grade;
373 3         52 $self->{_distribution} = $distribution;
374 3         10 $self->{_perl_version}{_archname} = $archname;
375 3         8 $self->{_subject_lock} = 1;
376             } elsif ($header eq "X-Test-Reporter-Distfile") {
377 3         9 $self->{_distfile} = $content;
378             } elsif ($header eq "X-Test-Reporter-Perl") {
379 3         11 $self->{_perl_version}{_version} = $content;
380             } elsif ($header eq "Report") {
381 3         8 last;
382             }
383             }
384             }
385              
386             # parse out body
387 3 50 33     33 if ( $self->{_from} && $self->{_subject} ) {
388 3         32 ($self->{_report}) = ($buffer =~ /^.+?Report:\s(.+)$/s);
389 3         22 my ($perlv) = $self->{_report} =~ /(^Summary of my perl5.*)\z/ms;
390 3 50       12 $self->{_perl_version}{_myconfig} = $perlv if $perlv;
391 3         7 $self->{_report_lock} = 1;
392             }
393              
394             # check that the full report was parsed
395 3 50       9 if ( ! $self->{_report_lock} ) {
396 0         0 die __PACKAGE__, ": Failed to parse report file '$file'\n";
397             }
398              
399 3         13 return $self;
400             }
401              
402             sub _verify {
403 4     4   8 my $self = shift;
404 4 50       12 warn __PACKAGE__, ": _verify\n" if $self->debug();
405              
406 4         9 my @undefined;
407              
408 4         6 for my $key (keys %{$self}) {
  4         57  
409 84 50       198 push @undefined, $key unless defined $self->{$key};
410             }
411              
412 0         0 $self->errstr(__PACKAGE__ . ": Missing values for: " .
413 4 50       23 join ', ', map {$_ =~ /^_(.+)$/} @undefined) if
414             scalar @undefined > 0;
415 4 50       82 return $self->errstr() ? return 0 : return 1;
416             }
417              
418             # Courtesy of Email::MessageID
419             sub message_id {
420 1     1 1 2 my $self = shift;
421 1 50       2 warn __PACKAGE__, ": message_id\n" if $self->debug();
422              
423 1         1 my $unique_value = 0;
424 1         4 my @CHARS = ('A'..'F','a'..'f',0..9);
425 1         1 my $length = 3;
426              
427 1         6 $length = rand(8) until $length > 3;
428              
429 1         12 my $pseudo_random = join '', (map $CHARS[rand $#CHARS], 0 .. $length), $unique_value++;
430 1         7 my $user = join '.', time, $pseudo_random, $$;
431              
432 1         7 return '<' . $user . '@' . Sys::Hostname::hostname() . '>';
433             }
434              
435             sub from {
436 15     15 1 45 my $self = shift;
437 15 50       31 warn __PACKAGE__, ": from\n" if $self->debug();
438              
439 15 100       42 if (@_) {
440 5         14 $self->{_from} = shift;
441 5         14 return $self->{_from};
442             }
443             else {
444 10 50 33     140 return $self->{_from} if defined $self->{_from} and $self->{_from};
445 0         0 $self->{_from} = $self->_mailaddress();
446 0         0 return $self->{_from};
447             }
448              
449             }
450              
451             sub mx {
452 15     15 1 27 my $self = shift;
453 15 50       38 warn __PACKAGE__, ": mx\n" if $self->debug();
454              
455 15 100       38 if (@_) {
456 13         22 my $mx = shift;
457 13 50       44 croak __PACKAGE__,
458             ": mx: array reference required" if ref $mx ne 'ARRAY';
459 13         28 $self->{_mx} = $mx;
460             }
461              
462 15         62 return $self->{_mx};
463             }
464              
465             # Deprecated, but kept for backwards compatibility
466             # Passes through to transport_args -- converting from array ref to list to
467             # store and converting from list to array ref to get
468             sub mail_send_args {
469 0     0 1 0 my $self = shift;
470 0 0       0 warn __PACKAGE__, ": mail_send_args\n" if $self->debug();
471 0 0       0 croak __PACKAGE__, ": mail_send_args cannot be called unless Mail::Send is installed\n"
472             unless $self->_have_mail_send();
473 0 0       0 if (@_) {
474 0         0 my $mail_send_args = shift;
475 0 0       0 croak __PACKAGE__, ": mail_send_args: array reference required\n"
476             if ref $mail_send_args ne 'ARRAY';
477 0         0 $self->transport_args(@$mail_send_args);
478             }
479 0         0 return [ $self->transport_args() ];
480             }
481              
482              
483              
484             sub transport_args {
485 4     4 1 9 my $self = shift;
486 4 50       10 warn __PACKAGE__, ": transport_args\n" if $self->debug();
487              
488 4 100       11 if (@_) {
489 2 50       12 $self->{_transport_args} = ref $_[0] eq 'ARRAY' ? $_[0] : [ @_ ];
490             }
491              
492 4         6 return @{ $self->{_transport_args} };
  4         14  
493             }
494              
495             # quote for command-line perl
496 15 50 33 15   223 sub _get_sh_quote { ( ($^O eq "MSWin32") || ($^O eq 'VMS') ) ? '"' : "'" }
497              
498              
499             sub perl_version {
500 22     22 1 1277 my $self = shift;
501 22 50       96 warn __PACKAGE__, ": perl_version\n" if $self->debug();
502              
503 22 100       72 if( @_) {
504 2         2 my $perl = shift;
505 2         6 my $q = $self->_get_sh_quote;
506 2         7 my $magick = int(rand(1000)); # just to check that we get a valid result back
507 2         7 my $cmd = "$perl -MConfig -e$q print qq{$magick\n\$Config{archname}\n\$Config{osvers}\n};$q";
508 2 50       8 if($^O eq 'VMS'){
509 0         0 my $sh = $Config{'sh'};
510 0         0 $cmd = "$sh $perl $q-MConfig$q -e$q print qq{$magick\\n\$Config{archname}\\n\$Config{osvers}\\n};$q";
511             }
512 2         15202 my $conf = `$cmd`;
513 2         20 chomp $conf;
514 2         7 my %conf;
515 2         30 ( @conf{ qw( magick _archname _osvers) } ) = split( /\n/, $conf, 3);
516 2 100       231 croak __PACKAGE__, ": cannot get perl version info from $perl: $conf" if( $conf{magick} ne $magick);
517 1         4 delete $conf{magick};
518 1         11 $conf{_myconfig} = $self->_get_perl_V($perl);
519 1         8 chomp $conf;
520 1         12 $self->{_perl_version} = \%conf;
521             }
522 21         103 return $self->{_perl_version};
523             }
524              
525             sub _get_perl_V {
526 13     13   24 my $self = shift;
527 13   66     76 my $perl = shift || qq{"$^X"};
528 13         47 my $q = $self->_get_sh_quote;
529 13         30 my $cmdv = "$perl -V";
530 13 50       41 if($^O eq 'VMS'){
531 0         0 my $sh = $Config{'sh'};
532 0         0 $cmdv = "$sh $perl $q-V$q";
533             }
534 13         189434 my $perl_V = `$cmdv`;
535 13         120 chomp $perl_V;
536 13         358 return $perl_V;
537             }
538              
539             sub AUTOLOAD {
540 19     19   87 my $self = $_[0];
541 19         150 my ($package, $method) = ($AUTOLOAD =~ /(.*)::(.*)/);
542              
543 19 50       65 return if $method =~ /^DESTROY$/;
544              
545 19 50       86 unless ($self->{_attr}->{"_$method"}) {
546 0         0 croak __PACKAGE__, ": No such method: $method; aborting";
547             }
548              
549 19         33 my $code = q{
550             sub {
551             my $self = shift;
552             warn __PACKAGE__, ": METHOD\n" if $self->{_debug};
553             $self->{_METHOD} = shift if @_;
554             return $self->{_METHOD};
555             }
556             };
557              
558 19         110 $code =~ s/METHOD/$method/g;
559              
560             {
561 4     4   24 no strict 'refs';
  4         4  
  4         4651  
  19         27  
562 19 50   9   2285 *$AUTOLOAD = eval $code; ## no critic
  9 100       40  
  9 50       42  
  9 100       30  
  9 50       39  
  7 100       16  
  7 50       47  
  7 100       24  
  7 50       4805  
  9 100       19  
  9 50       37  
  9 100       28  
  9 50       34  
  13 50       43  
  13 50       48  
  13 100       35  
  13         65  
  9         34  
  9         39  
  9         30  
  9         32  
  9         75  
  9         31  
  9         26  
  9         36  
  1         1  
  1         9  
  1         4  
  1         5  
  4         8  
  4         25  
  4         12  
  4         20  
563             }
564              
565 19         463 goto &$AUTOLOAD;
566             }
567              
568             sub _have_net_dns {
569 12     12   16 my $self = shift;
570 12 50       29 warn __PACKAGE__, ": _have_net_dns\n" if $self->debug();
571              
572 12 100       79 return $DNS if defined $DNS;
573 4         6 return 0 if FAKE_NO_NET_DNS;
574              
575 4         6 $DNS = eval {require Net::DNS};
  4         1986  
576             }
577              
578             sub _have_net_domain {
579 0     0   0 my $self = shift;
580 0 0       0 warn __PACKAGE__, ": _have_net_domain\n" if $self->debug();
581              
582 0 0       0 return $Domain if defined $Domain;
583 0         0 return 0 if FAKE_NO_NET_DOMAIN;
584              
585 0         0 $Domain = eval {require Net::Domain};
  0         0  
586             }
587              
588             sub _have_mail_send {
589 0     0   0 my $self = shift;
590 0 0       0 warn __PACKAGE__, ": _have_mail_send\n" if $self->debug();
591              
592 0 0       0 return $Send if defined $Send;
593 0         0 return 0 if FAKE_NO_MAIL_SEND;
594              
595 0         0 $Send = eval {require Mail::Send};
  0         0  
596             }
597              
598             sub _start_editor {
599 0     0   0 my $self = shift;
600 0 0       0 warn __PACKAGE__, ": _start_editor\n" if $self->debug();
601              
602 0   0     0 my $editor = $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT}
603             || ($^O eq 'VMS' and "edit/tpu")
604             || ($^O eq 'MSWin32' and "notepad")
605             || 'vi';
606              
607 0         0 $editor = $self->_prompt('Editor', $editor);
608              
609 0 0       0 die __PACKAGE__, ": The editor `$editor' could not be run on '$Report': $!" if system "$editor $Report";
610 0 0       0 die __PACKAGE__, ": Report has disappeared; terminated" unless -e $Report;
611 0 0       0 die __PACKAGE__, ": Empty report; terminated" unless -s $Report > 2;
612             }
613              
614             sub _prompt {
615 0     0   0 my $self = shift;
616 0 0       0 warn __PACKAGE__, ": _prompt\n" if $self->debug();
617              
618 0         0 my ($label, $default) = @_;
619              
620 0         0 printf "$label%s", (" [$default]: ");
621 0         0 my $input = scalar ;
622 0         0 chomp $input;
623              
624 0 0       0 return (length $input) ? $input : $default;
625             }
626              
627             # From Mail::Util 1.74 (c) 1995-2001 Graham Barr (c) 2002-2005 Mark Overmeer
628             {
629             # cache the mail domain, so we don't try to resolve this *every* time
630             # (thanks you kane)
631             my $domain;
632              
633             sub _maildomain {
634 0     0   0 my $self = shift;
635 0 0       0 warn __PACKAGE__, ": _maildomain\n" if $self->debug();
636              
637             # use cached value if set
638 0 0       0 return $domain if defined $domain;
639              
640             # prefer MAILDOMAIN if set
641 0 0       0 if ( defined $ENV{MAILDOMAIN} ) {
642 0         0 return $domain = $ENV{MAILDOMAIN};
643             }
644              
645 0         0 local $_;
646              
647 0         0 my @sendmailcf = qw(
648             /etc /etc/sendmail /etc/ucblib /etc/mail /usr/lib /var/adm/sendmail
649             );
650              
651 0         0 my $config = (grep(-r, map("$_/sendmail.cf", @sendmailcf)))[0];
652              
653 0 0 0     0 if (defined $config && open(my $cf, "<", $config)) {
654 0         0 my %var;
655 0         0 while (<$cf>) {
656 0 0       0 if (my ($v, $arg) = /^D([a-zA-Z])([\w.\$\-]+)/) {
657 0 0       0 $arg =~ s/\$([a-zA-Z])/exists $var{$1} ? $var{$1} : '$'.$1/eg;
  0         0  
658 0         0 $var{$v} = $arg;
659             }
660             }
661 0 0       0 close($cf) || die $!;
662 0 0       0 $domain = $var{j} if defined $var{j};
663 0 0       0 $domain = $var{M} if defined $var{M};
664              
665 0 0 0     0 $domain = $1
666             if ($domain && $domain =~ m/([A-Za-z0-9](?:[\.\-A-Za-z0-9]+))/);
667              
668 0 0 0     0 undef $domain if $^O eq 'darwin' && $domain =~ /\.local$/;
669              
670 0 0 0     0 return $domain if (defined $domain && $domain !~ /\$/);
671             }
672              
673 0 0       0 if (open(my $cf, "<", "/usr/lib/smail/config")) {
674 0         0 while (<$cf>) {
675 0 0       0 if (/\A\s*hostnames?\s*=\s*(\S+)/) {
676 0         0 $domain = (split(/:/,$1))[0];
677 0 0 0     0 undef $domain if $^O eq 'darwin' && $domain =~ /\.local$/;
678 0 0 0     0 last if defined $domain and $domain;
679             }
680             }
681 0 0       0 close($cf) || die $!;
682              
683 0 0       0 return $domain if defined $domain;
684             }
685              
686 0 0       0 if (eval {require Net::SMTP}) {
  0         0  
687 0         0 for my $host (qw(mailhost smtp localhost)) {
688              
689             # default timeout is 120, which is Very Very Long, so lower
690             # it to 5 seconds. Total slowdown will not be more than
691             # 15 seconds ( 5 x @hosts ) --kane
692 0         0 my $smtp = eval {Net::SMTP->new($host, Timeout => 5)};
  0         0  
693              
694 0 0       0 if (defined $smtp) {
695 0         0 $domain = $smtp->domain;
696 0         0 $smtp->quit;
697 0 0 0     0 undef $domain if $^O eq 'darwin' && $domain =~ /\.local$/;
698 0 0 0     0 last if defined $domain and $domain;
699             }
700             }
701             }
702              
703 0 0       0 unless (defined $domain) {
704 0 0       0 if ($self->_have_net_domain()) {
705             ###################################################################
706             # The below statement might possibly exhibit intermittent blocking
707             # behavior. Be advised!
708             ###################################################################
709 0         0 $domain = Net::Domain::domainname();
710 0 0 0     0 undef $domain if $^O eq 'darwin' && $domain =~ /\.local$/;
711             }
712             }
713              
714 0 0       0 $domain = "localhost" unless defined $domain;
715              
716 0         0 return $domain;
717             }
718             }
719              
720             # From Mail::Util 1.74 (c) 1995-2001 Graham Barr (c) 2002-2005 Mark Overmeer
721             sub _mailaddress {
722 0     0   0 my $self = shift;
723 0 0       0 warn __PACKAGE__, ": _mailaddress\n" if $self->debug();
724              
725 0         0 my $mailaddress = $ENV{MAILADDRESS};
726             $mailaddress ||= $ENV{USER} ||
727             $ENV{LOGNAME} ||
728 0   0     0 eval {getpwuid($>)} ||
      0        
729             "postmaster";
730 0 0       0 $mailaddress .= '@' . $self->_maildomain() unless $mailaddress =~ /\@/;
731 0         0 $mailaddress =~ s/(^.*<|>.*$)//g;
732              
733 0         0 my $realname = $self->_realname();
734 0 0       0 if ($realname) {
735 0         0 $mailaddress = "$mailaddress ($realname)";
736             }
737              
738 0         0 return $mailaddress;
739             }
740              
741             sub _realname {
742 0     0   0 my $self = shift;
743 0 0       0 warn __PACKAGE__, ": _realname\n" if $self->debug();
744              
745 0         0 my $realname = '';
746              
747             $realname =
748 0   0     0 eval {(split /,/, (getpwuid($>))[6])[0]} ||
749             $ENV{QMAILNAME} ||
750             $ENV{REALNAME} ||
751             $ENV{USER};
752              
753 0         0 return $realname;
754             }
755              
756             sub _is_a_perl_release {
757 55     55   694 my $self = shift;
758 55 50       83 warn __PACKAGE__, ": _is_a_perl_release\n" if $self->debug();
759              
760 55         77 my $perl = shift;
761              
762 55         239 return $perl =~ /^perl-?\d\.\d/;
763             }
764              
765             1;
766              
767             # ABSTRACT: sends test results to cpan-testers@perl.org
768              
769             =pod
770              
771             =encoding UTF-8
772              
773             =head1 NAME
774              
775             Test::Reporter - sends test results to cpan-testers@perl.org
776              
777             =head1 VERSION
778              
779             version 1.61
780              
781             =head1 SYNOPSIS
782              
783             use Test::Reporter;
784              
785             my $reporter = Test::Reporter->new(
786             transport => 'File',
787             transport_args => [ '/tmp' ],
788             );
789              
790             $reporter->grade('pass');
791             $reporter->distribution('Mail-Freshmeat-1.20');
792             $reporter->send() || die $reporter->errstr();
793              
794             # or
795              
796             my $reporter = Test::Reporter->new(
797             transport => 'File',
798             transport_args => [ '/tmp' ],
799             );
800              
801             $reporter->grade('fail');
802             $reporter->distribution('Mail-Freshmeat-1.20');
803             $reporter->comments('output of a failed make test goes here...');
804             $reporter->edit_comments(); # if you want to edit comments in an editor
805             $reporter->send() || die $reporter->errstr();
806              
807             # or
808              
809             my $reporter = Test::Reporter->new(
810             transport => 'File',
811             transport_args => [ '/tmp' ],
812             grade => 'fail',
813             distribution => 'Mail-Freshmeat-1.20',
814             from => 'whoever@wherever.net (Whoever Wherever)',
815             comments => 'output of a failed make test goes here...',
816             via => 'CPANPLUS X.Y.Z',
817             );
818             $reporter->send() || die $reporter->errstr();
819              
820             =head1 DESCRIPTION
821              
822             Test::Reporter reports the test results of any given distribution to the CPAN
823             Testers project. Test::Reporter has wide support for various perl5's and
824             platforms.
825              
826             CPAN Testers no longer receives test reports by email, but reports still
827             resemble an email message. This module has numerous legacy "features"
828             left over from the days of email transport.
829              
830             =head2 Transport mechanism
831              
832             The choice of transport is set with the C argument. CPAN Testers
833             should usually install L and use
834             'Metabase' as the C. See that module for necessary transport
835             arguments. Advanced testers may wish to test on a machine different from the
836             one used to send reports. Consult the L
837             Wiki|http://wiki.cpantesters.org/> for examples using other transport classes.
838              
839             The legacy email-based transports have been split out into a separate
840             L distribution and methods solely
841             related to email have been deprecated.
842              
843             =head1 ATTRIBUTES
844              
845             =head2 Required attributes
846              
847             =over
848              
849             =item * B
850              
851             Gets or sets the name of the distribution you're working on, for example
852             Foo-Bar-0.01. There are no restrictions on what can be put here.
853              
854             =item * B
855              
856             Gets or sets the e-mail address of the individual submitting
857             the test report, i.e. "John Doe ".
858              
859             =item * B
860              
861             Gets or sets the success or failure of the distributions's 'make test'
862             result. This must be one of:
863              
864             grade meaning
865             ----- -------
866             pass all tests passed
867             fail one or more tests failed
868             na distribution will not work on this platform
869             unknown tests did not exist or could not be run
870              
871             =back
872              
873             =head2 Transport attributes
874              
875             =over
876              
877             =item * B
878              
879             Gets or sets the transport type. The transport type argument is
880             refers to a 'Test::Reporter::Transport' subclass. The default is 'Null',
881             which uses the L class and does
882             nothing when C is called.
883              
884             You can add additional arguments after the transport
885             selection. These will be passed to the constructor of the lower-level
886             transport. See C.
887              
888             $reporter->transport(
889             'File', '/tmp'
890             );
891              
892             This is not designed to be an extensible platform upon which to build
893             transport plugins. That functionality is planned for the next-generation
894             release of Test::Reporter, which will reside in the CPAN::Testers namespace.
895              
896             =item * B
897              
898             Optional. Gets or sets transport arguments that will used in the constructor
899             for the selected transport, as appropriate.
900              
901             =back
902              
903             =head2 Optional attributes
904              
905             =over
906              
907             =item * B
908              
909             Gets or sets the comments on the test report. This is most
910             commonly used for distributions that did not pass a 'make test'.
911              
912             =item * B
913              
914             Gets or sets the value that will turn debugging on or off.
915             Debug messages are sent to STDERR. 1 for on, 0 for off. Debugging
916             generates very verbose output and is useful mainly for finding bugs
917             in Test::Reporter itself.
918              
919             =item * B
920              
921             Defaults to the current working directory. This method specifies
922             the directory that write() writes test report files to.
923              
924             =item * B
925              
926             Gets or sets the timeout value for the submission of test
927             reports. Default is 120 seconds.
928              
929             =item * B
930              
931             Gets or sets the value that will be appended to
932             X-Reported-Via, generally this is useful for distributions that use
933             Test::Reporter to report test results. This would be something
934             like "CPANPLUS 0.036".
935              
936             =back
937              
938             =head2 Deprecated attributes
939              
940             CPAN Testers no longer uses email for submitting reports. These attributes
941             are deprecated.
942              
943             =over
944              
945             =item * B
946              
947             =item * B
948              
949             =item * B
950              
951             =back
952              
953             =head1 METHODS
954              
955             =over
956              
957             =item * B
958              
959             This constructor returns a Test::Reporter object.
960              
961             =item * B
962              
963             Returns a hashref containing _archname, _osvers, and _myconfig based upon the
964             perl that you are using. Alternatively, you may supply a different perl (path
965             to the binary) as an argument, in which case the supplied perl will be used as
966             the basis of the above data. Make sure you protect it from the shell in
967             case there are spaces in the path:
968              
969             $reporter->perl_version(qq{"$^X"});
970              
971             =item * B
972              
973             Returns the subject line of a report, i.e.
974             "PASS Mail-Freshmeat-1.20 Darwin 6.0". 'grade' and 'distribution' must
975             first be specified before calling this method.
976              
977             =item * B
978              
979             Returns the actual content of a report, i.e.
980             "This distribution has been tested as part of the cpan-testers...".
981             'comments' must first be specified before calling this method, if you have
982             comments to make and expect them to be included in the report.
983              
984             =item * B
985              
986             Sends the test report to cpan-testers@perl.org via the defined C
987             mechanism. You must check errstr() on a send() in order to be guaranteed
988             delivery.
989              
990             =item * B
991              
992             Allows one to interactively edit the comments within a text
993             editor. comments() doesn't have to be first specified, but it will work
994             properly if it was. Accepts an optional hash of arguments:
995              
996             =over
997              
998             =item * B
999              
1000             Optional. Allows one to specify the suffix ("extension") of the temp
1001             file used by B. Defaults to '.txt'.
1002              
1003             =back
1004              
1005             =item * B
1006              
1007             Returns an error message describing why something failed. You must check
1008             errstr() on a send() in order to be guaranteed delivery.
1009              
1010             =item * B
1011              
1012             These methods are used in situations where you wish to save reports locally
1013             rather than transmitting them to CPAN Testers immediately. You use write() on
1014             the machine that you are testing from, transfer the written test reports from
1015             the testing machine to the sending machine, and use read() on the machine that
1016             you actually want to submit the reports from. write() will write a file in an
1017             internal format that contains 'From', 'Subject', and the content of the report.
1018             The filename will be represented as:
1019             grade.distribution.archname.osvers.seconds_since_epoch.pid.rpt. write() uses
1020             the value of dir() if it was specified, else the cwd.
1021              
1022             On the machine you are testing from:
1023              
1024             my $reporter = Test::Reporter->new
1025             (
1026             grade => 'pass',
1027             distribution => 'Test-Reporter-1.16',
1028             )->write();
1029              
1030             On the machine you are submitting from:
1031              
1032             # wrap in an opendir if you've a lot to submit
1033             my $reporter;
1034             $reporter = Test::Reporter->new()->read(
1035             'pass.Test-Reporter-1.16.i686-linux.2.2.16.1046685296.14961.rpt'
1036             )->send() || die $reporter->errstr();
1037              
1038             write() also accepts an optional filehandle argument:
1039              
1040             my $fh; open $fh, '>-'; # create a STDOUT filehandle object
1041             $reporter->write($fh); # prints the report to STDOUT
1042              
1043             =back
1044              
1045             =head2 Deprecated methods
1046              
1047             =over
1048              
1049             =item * B
1050              
1051             =back
1052              
1053             =head1 CAVEATS
1054              
1055             If you experience a long delay sending reports with Test::Reporter, you may be
1056             experiencing a wait as Test::Reporter attempts to determine your email
1057             address. Always use the C parameter to set your email address
1058             explicitly.
1059              
1060             =head1 SEE ALSO
1061              
1062             For more about CPAN Testers:
1063              
1064             =over 4
1065              
1066             =item *
1067              
1068             L
1069              
1070             =item *
1071              
1072             L
1073              
1074             =back
1075              
1076             =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
1077              
1078             =head1 SUPPORT
1079              
1080             =head2 Bugs / Feature Requests
1081              
1082             Please report any bugs or feature requests through the issue tracker
1083             at L.
1084             You will be notified automatically of any progress on your issue.
1085              
1086             =head2 Source Code
1087              
1088             This is open source software. The code repository is available for
1089             public review and contribution under the terms of the license.
1090              
1091             L
1092              
1093             git clone https://github.com/cpan-testers/Test-Reporter.git
1094              
1095             =head1 AUTHORS
1096              
1097             =over 4
1098              
1099             =item *
1100              
1101             Adam J. Foxson
1102              
1103             =item *
1104              
1105             David Golden
1106              
1107             =item *
1108              
1109             Kirrily "Skud" Robert
1110              
1111             =item *
1112              
1113             Ricardo Signes
1114              
1115             =item *
1116              
1117             Richard Soderberg
1118              
1119             =item *
1120              
1121             Kurt Starsinic
1122              
1123             =back
1124              
1125             =head1 CONTRIBUTORS
1126              
1127             =for stopwords Andreas Koenig Ed J Tatsuhiko Miyagawa Vincent Pit
1128              
1129             =over 4
1130              
1131             =item *
1132              
1133             Andreas Koenig
1134              
1135             =item *
1136              
1137             Ed J
1138              
1139             =item *
1140              
1141             Tatsuhiko Miyagawa
1142              
1143             =item *
1144              
1145             Vincent Pit
1146              
1147             =back
1148              
1149             =head1 COPYRIGHT AND LICENSE
1150              
1151             This software is copyright (c) 2015 by Authors and Contributors.
1152              
1153             This is free software; you can redistribute it and/or modify it under
1154             the same terms as the Perl 5 programming language system itself.
1155              
1156             =cut
1157              
1158             __END__