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