2 # $Id: Reporter.pm,v 1.20 2003/03/05 09:15:53 afoxson Exp $
4 # Test::Reporter - sends test results to cpan-testers@perl.org
5 # Copyright (c) 2003 Adam J. Foxson. All rights reserved.
7 # This program is free software; you can redistribute it and/or modify
8 # it under the same terms as Perl itself.
10 # This program is distributed in the hope that it will be useful,
11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
14 package Test
::Reporter
;
22 use Test
::Reporter
::Mail
::Util
;
23 use Test
::Reporter
::Date
::Format
;
24 use vars
qw($VERSION $AUTOLOAD $Tempfile $Report $MacMPW $MacApp $DNS $Domain $Send);
26 $MacMPW = $^O eq 'MacOS' && $MacPerl::Version =~ /MPW/;
27 $MacApp = $^O eq 'MacOS' && $MacPerl::Version =~ /Application/;
32 sub FAKE_NO_NET_DNS() {0} # for debugging only
33 sub FAKE_NO_NET_DOMAIN() {0} # for debugging only
34 sub FAKE_NO_MAIL_SEND() {0} # for debugging only
38 my $class = ref($type) || $type;
40 '_mx' => ['mx1.x.perl.org', 'mx2.x.perl.org'],
41 '_address' => 'cpan-testers@perl.org',
43 '_distribution' => undef,
50 '_mail_send_args' => '',
62 _address _distribution _comments _errstr _via _timeout _debug _dir
66 warn __PACKAGE__
, ": new\n" if $self->debug();
67 croak __PACKAGE__
, ": new: even number of named arguments required"
68 unless scalar @_ % 2 == 0;
70 $self->_process_params(@_) if @_;
71 $self->_get_mx(@_) if $self->_have_net_dns();
78 warn __PACKAGE__
, ": _get_mx\n" if $self->debug();
82 return if exists $params{'mx'};
84 my $dom = $params{'address'} || $self->address();
89 for my $mx (sort {$a->preference() <=> $b->preference()} Net
::DNS
::mx
($dom)) {
90 push @mx, $mx->exchange();
95 ": _get_mx: unable to find MX's for $dom, using defaults\n" if
103 sub _process_params
{
105 warn __PACKAGE__
, ": _process_params\n" if $self->debug();
109 mx address grade distribution from comments via timeout debug dir);
110 my %defaults = map {$_ => 1} @defaults;
112 for my $param (keys %params) {
113 croak __PACKAGE__
, ": new: parameter '$param' is invalid." unless
114 exists $defaults{$param};
117 for my $param (keys %params) {
118 $self->$param($params{$param});
124 warn __PACKAGE__
, ": subject\n" if $self->debug();
125 croak __PACKAGE__
, ": subject: grade and distribution must first be set"
126 if not defined $self->{_grade
} or not defined $self->{_distribution
};
128 return $self->{_subject
} if $self->{_subject_lock
};
130 my $subject = uc($self->{_grade
}) . ' ' . $self->{_distribution
} .
131 " $Config{archname} $Config{osvers}";
133 return $self->{_subject
} = $subject;
138 warn __PACKAGE__
, ": report\n" if $self->debug();
140 return $self->{_report
} if $self->{_report_lock
};
143 This distribution has been tested as part of the cpan
-testers
144 effort to test as many new uploads to CPAN as possible
. See
145 http
://testers
.cpan
.org
/
147 Please cc any replies to cpan
-testers\
@perl.org to keep other
148 test volunteers informed
and to prevent any duplicate effort
.
152 $report =~ s/\t{2}//g;
154 if (not $self->{_comments
}) {
155 $report .= "\n\n--\n\n";
158 $report .= "\n--\n" . $self->{_comments
} . "\n--\n\n";
161 $report .= Config
::myconfig
();
166 return $self->{_report
} = $report;
170 my ($self, $grade) = @_;
171 warn __PACKAGE__
, ": grade\n" if $self->debug();
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",
180 return $self->{_grade
} if scalar @_ == 1;
182 croak __PACKAGE__
, ":grade: '$grade' is invalid, choose from: " .
183 join ' ', keys %grades unless $grades{$grade};
185 return $self->{_grade
} = $grade;
189 my($self, %args) = @_;
190 warn __PACKAGE__
, ": edit_comments\n" if $self->debug();
192 my %tempfile_args = (
197 if (exists $args{'suffix'} && defined $args{'suffix'} && length $args{'suffix'}) {
198 $tempfile_args{SUFFIX
} = $args{'suffix'};
199 # prefix the extension with a period, if the user didn't.
200 $tempfile_args{SUFFIX
} =~ s/^(?!\.)(?=.)/./;
203 ($Tempfile, $Report) = File
::Temp
::tempfile
(%tempfile_args);
205 print $Tempfile $self->{_comments
};
207 $self->_start_editor();
212 open FH
, $Report or die __PACKAGE__
, ": Can't open comment file '$Report': $!";
214 close FH
or die __PACKAGE__
, ": Can't close comment file '$Report': $!";
219 $self->{_comments
} = $comments;
225 my ($self, @recipients) = @_;
226 warn __PACKAGE__
, ": send\n" if $self->debug();
232 return unless $self->_verify();
234 if ($^O
!~ /^(?:cygwin|MSWin32)$/ && $self->_have_mail_send()) {
235 return $self->_mail_send(@recipients);
238 return $self->_send_smtp(@recipients);
244 warn __PACKAGE__
, ": write\n" if $self->debug();
246 my $from = $self->from();
247 my $report = $self->report();
248 my $subject = $self->subject();
249 my $distribution = $self->distribution();
250 my $grade = $self->grade();
251 my $dir = $self->dir() || cwd
;
253 return unless $self->_verify();
255 $distribution =~ s/[^A-Za-z0-9\.\-]+//g;
257 my($fh, $file); unless ($fh = $_[0]) {
258 $file = "$dir/$grade.$distribution.$Config{archname}.$Config{osvers}.${\(time)}.$$.rpt";
259 warn $file if $self->debug();
260 open $fh, ">$file" or die __PACKAGE__
, ": Can't open report file '$file': $!";
262 print $fh "From: $from\n";
263 print $fh "Subject: $subject\n";
264 print $fh "Report: $report";
266 close $fh or die __PACKAGE__
, ": Can't close report file '$file': $!";
267 warn $file if $self->debug();
275 my ($self, $file) = @_;
276 warn __PACKAGE__
, ": read\n" if $self->debug();
282 open REPORT
, $file or die __PACKAGE__
, ": Can't open report file '$file': $!";
284 close REPORT
or die __PACKAGE__
, ": Can't close report file '$file': $!";
287 if (my ($from, $subject, $report) = $buffer =~ /^From:\s(.+)Subject:\s(.+)Report:\s(.+)$/s) {
288 my ($grade, $distribution) = (split /\s/, $subject)[0,1];
289 $self->from($from) unless $self->from();
290 $self->{_subject
} = $subject;
291 $self->{_report
} = $report;
292 $self->{_grade
} = lc $grade;
293 $self->{_distribution
} = $distribution;
294 $self->{_subject_lock
} = 1;
295 $self->{_report_lock
} = 1;
297 die __PACKAGE__
, ": Failed to parse report file '$file'\n";
305 warn __PACKAGE__
, ": _verify\n" if $self->debug();
309 for my $key (keys %{$self}) {
310 push @undefined, $key unless defined $self->{$key};
313 $self->errstr(__PACKAGE__
. ": Missing values for: " .
314 join ', ', map {$_ =~ /^_(.+)$/} @undefined) if
315 scalar @undefined > 0;
316 return $self->errstr() ?
return 0 : return 1;
321 warn __PACKAGE__
, ": _mail_send\n" if $self->debug();
326 my $via = $self->via();
327 my $msg = Mail
::Send
->new();
330 $recipients = join ', ', @recipients;
335 $via = ', via ' . $via if $via;
337 $msg->to($self->address());
338 $msg->set('From', $self->from());
339 $msg->subject($self->subject());
340 $msg->add('X-Reported-Via', "Test::Reporter ${VERSION}$via");
341 $msg->add('Cc', $recipients) if @_;
343 if ($self->mail_send_args() and ref $self->mail_send_args() eq 'ARRAY') {
344 $fh = $msg->open(@
{$self->mail_send_args()});
350 print $fh $self->report();
357 warn __PACKAGE__
, ": _send_smtp\n" if $self->debug();
359 my $helo = $self->_maildomain();
360 my $from = $self->from();
361 my $via = $self->via();
362 my $debug = $self->debug();
364 my @tmprecipients = ();
372 for my $server (@
{$self->{_mx
}}) {
373 $smtp = Net
::SMTP
->new($server, Hello
=> $helo,
374 Timeout
=> $self->{_timeout
}, Debug
=> $debug);
384 unless ($mx && $smtp) {
385 $self->errstr(__PACKAGE__
. ': Unable to connect to any MX\'s');
390 if ($mx =~ /(?:^|\.)(?:perl|cpan)\.org$/) {
391 for my $recipient (sort @recipients) {
392 if ($recipient =~ /(?:@|\.)(?:perl|cpan)\.org$/) {
393 push @tmprecipients, $recipient;
395 push @bad, $recipient;
400 warn __PACKAGE__
, ": Will not attempt to cc the following recipients since perl.org MX's will not relay for them. Either install Mail::Send, use other MX's, or only cc address ending in cpan.org or perl.org: ${\(join ', ', @bad)}.\n";
403 @recipients = @tmprecipients;
406 $recipients = join ', ', @recipients;
411 $via = ', via ' . $via if $via;
413 $success += $smtp->mail($from);
414 $success += $smtp->to($self->{_address
});
415 $success += $smtp->cc(@recipients) if @recipients;
416 $success += $smtp->data();
417 $success += $smtp->datasend("Date: ", time2str
("%a, %e %b %Y %T %z", time), "\n");
418 $success += $smtp->datasend("Subject: ", $self->subject(), "\n");
419 $success += $smtp->datasend("From: $from\n");
420 $success += $smtp->datasend("To: ", $self->{_address
}, "\n");
421 $success += $smtp->datasend("Cc: $recipients\n") if @recipients && $success == 8;
423 $smtp->datasend("X-Reported-Via: Test::Reporter ${VERSION}$via\n");
424 $success += $smtp->datasend("\n");
425 $success += $smtp->datasend($self->report());
426 $success += $smtp->dataend();
427 $success += $smtp->quit;
430 $self->errstr(__PACKAGE__
.
431 ": Unable to send test report to one or more recipients\n") if $success != 14;
434 $self->errstr(__PACKAGE__
. ": Unable to send test report\n") if $success != 12;
437 return $self->errstr() ?
0 : 1;
442 warn __PACKAGE__
, ": from\n" if $self->debug();
445 $self->{_from
} = shift;
448 $self->{_from
} = $self->_mailaddress();
451 return $self->{_from
};
456 warn __PACKAGE__
, ": mx\n" if $self->debug();
461 ": mx: array reference required" if ref $mx ne 'ARRAY';
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" unless $self->_have_mail_send();
474 my $mail_send_args = shift;
475 croak __PACKAGE__
, ": mail_send_args: array reference required" if
476 ref $mail_send_args ne 'ARRAY';
477 $self->{_mail_send_args
} = $mail_send_args;
480 return $self->{_mail_send_args
};
485 my ($package, $method) = ($AUTOLOAD =~ /(.*)::(.*)/);
487 return if $method =~ /^DESTROY$/;
489 unless ($self->{_attr
}->{"_$method"}) {
490 croak __PACKAGE__
, ": No such method: $method; aborting";
496 warn __PACKAGE__, ": METHOD\n" if $self->{_debug};
497 $self->{_METHOD} = shift if @_;
498 return $self->{_METHOD};
502 $code =~ s/METHOD/$method/g;
506 *$AUTOLOAD = eval $code;
514 warn __PACKAGE__, ": _have_net_dns\n" if $self->debug();
516 return $DNS if defined $DNS;
517 return 0 if FAKE_NO_NET_DNS;
519 $DNS = eval {require Net::DNS};
522 sub _have_net_domain {
524 warn __PACKAGE__, ": _have_net_domain\n" if $self->debug();
526 return $Domain if defined $Domain;
527 return 0 if FAKE_NO_NET_DOMAIN;
529 $Domain = eval {require Net::Domain};
532 sub _have_mail_send {
534 warn __PACKAGE__, ": _have_mail_send\n" if $self->debug();
536 return $Send if defined $Send;
537 return 0 if FAKE_NO_MAIL_SEND;
539 $Send = eval {require Mail::Send};
542 sub _start_editor_mac {
544 warn __PACKAGE__, ": _start_editor_mac\n" if $self->debug();
548 use vars '%Application';
549 for my $mod (qw(Mac::MoreFiles Mac::AppleEvents::Simple Mac::AppleEvents)) {
550 eval qq(require $mod) or die __PACKAGE__
, ": Can't load $mod; \$\@: $@\n";
551 eval qq($mod->import());
554 my $app = $Application{$editor};
555 die __PACKAGE__
, ": Application with ID '$editor' not found.\n" if !$app;
557 my $obj = 'obj {want:type(cobj), from:null(), ' .
558 'form:enum(name), seld:TEXT(@)}';
559 my $evt = do_event
(qw
/aevt odoc MACS/,
560 "'----': $obj, usin: $obj", $Report, $app);
562 if (my $err = AEGetParamDesc
($evt->{REP
}, 'errn')) {
563 die __PACKAGE__
, ": AppleEvent error: ${\AEPrint($err)}.\n";
566 $self->_prompt('Done?', 'Yes') if $MacMPW;
567 MacPerl
::Answer
('Done?') if $MacApp;
572 warn __PACKAGE__
, ": _start_editor\n" if $self->debug();
574 my $editor = $ENV{VISUAL
} || $ENV{EDITOR
} || $ENV{EDIT
}
575 || ($^O
eq 'VMS' and "edit/tpu")
576 || ($^O
eq 'MSWin32' and "notepad")
577 || ($^O
eq 'MacOS' and 'ttxt')
580 $editor = $self->_prompt('Editor', $editor) unless $MacApp;
582 if ($^O
eq 'MacOS') {
583 $self->_start_editor_mac($editor);
586 die __PACKAGE__
, ": The editor `$editor' could not be run" if system "$editor $Report";
587 die __PACKAGE__
, ": Report has disappeared; terminated" unless -e
$Report;
588 die __PACKAGE__
, ": Empty report; terminated" unless -s
$Report > 2;
594 warn __PACKAGE__
, ": _prompt\n" if $self->debug();
596 my ($label, $default) = @_;
598 printf "$label%s", ($MacMPW ?
":\n$default" : " [$default]: ");
599 my $input = scalar <STDIN
>;
602 return (length $input) ?
$input : $default;
607 Test::Reporter - sends test results to cpan-testers@perl.org
613 my $reporter = Test::Reporter->new();
615 $reporter->grade('pass');
616 $reporter->distribution('Mail-Freshmeat-1.20');
617 $reporter->send() || die $reporter->errstr();
621 my $reporter = Test::Reporter->new();
623 $reporter->grade('fail');
624 $reporter->distribution('Mail-Freshmeat-1.20');
625 $reporter->comments('output of a failed make test goes here...');
626 $reporter->edit_comments(); # if you want to edit comments in an editor
627 $reporter->send('afoxson@cpan.org') || die $reporter->errstr();
631 my $reporter = Test::Reporter->new(
633 distribution => 'Mail-Freshmeat-1.20',
634 from => 'whoever@wherever.net (Whoever Wherever)',
635 comments => 'output of a failed make test goes here...',
636 via => 'CPANPLUS X.Y.Z',
638 $reporter->send() || die $reporter->errstr();
642 Test::Reporter reports the test results of any given distribution to the
643 CPAN testing service. See B<http://testers.cpan.org/> for details.
645 Test::Reporter has wide support for various perl5's and platforms.
653 This constructor returns a Test::Reporter object. It will optionally accept
654 named parameters for: mx, address, grade, distribution, from, comments,
655 via, timeout, debug and dir.
659 Returns the subject line of a report, i.e.
660 "PASS Mail-Freshmeat-1.20 Darwin 6.0". 'grade' and 'distribution' must
661 first be specified before calling this method.
665 Returns the actual content of a report, i.e.
666 "This distribution has been tested as part of the cpan-testers...".
667 'comments' must first be specified before calling this method, if you have
668 comments to make and expect them to be included in the report.
672 Optional. Gets or sets the comments on the test report. This is most
673 commonly used for distributions that did not pass a 'make test'.
675 =item * B<edit_comments>
677 Optional. Allows one to interactively edit the comments within a text
678 editor. comments() doesn't have to be first specified, but it will work
679 properly if it was. Accepts an optional hash of arguments:
685 Optional. Allows one to specify the suffix ("extension") of the temp
686 file used by B<edit_comments>. Defaults to '.txt'.
692 Returns an error message describing why something failed. You must check
693 errstr() on a send() in order to be guaranteed delivery. This is optional
694 if you don't intend to use Test::Reporter to send reports via e-mail,
695 see 'send' below for more information.
699 Optional. Gets or sets the e-mail address of the individual submitting
700 the test report, i.e. "afoxson@pobox.com (Adam Foxson)". This is
701 mostly of use to testers running under Windows, since Test::Reporter
702 will usually figure this out automatically.
706 Gets or sets the success or failure of the distributions's 'make test'
707 result. This must be one of:
711 pass all tests passed
712 fail one or more tests failed
713 na distribution will not work on this platform
714 unknown distribution did not include tests
716 =item * B<distribution>
718 Gets or sets the name of the distribution you're working on, for example
719 Foo-Bar-0.01. There are no restrictions on what can be put here.
723 Sends the test report to cpan-testers@perl.org and cc's the e-mail to the
724 specified recipients, if any. If you do specify recipients to be cc'd and
725 you do not have Mail::Send installed be sure that you use the author's
726 @cpan.org address otherwise they will not be delivered. You must check
727 errstr() on a send() in order to be guaranteed delivery. Technically, this
728 is optional, as you may use Test::Reporter to only obtain the 'subject' and
729 'report' without sending an e-mail at all, although that would be unusual.
733 Optional. Gets or sets the timeout value for the submission of test
734 reports. Default is 120 seconds.
738 Optional. Gets or sets the value that will be appended to
739 X-Reported-Via, generally this is useful for distributions that use
740 Test::Reporter to report test results. This would be something
741 like "CPANPLUS 0.036".
745 Optional. Gets or sets the value that will turn debugging on or off.
746 Debug messages are sent to STDERR. 1 for on, 0 for off. Debugging
747 generates very verbose output and is useful mainly for finding bugs
748 in Test::Reporter itself.
752 Optional. Gets or sets the e-mail address that the reports will be
753 sent to. By default, this is set to cpan-testers@perl.org. You shouldn't
754 need this unless the CPAN Tester's change the e-mail address to send
759 Optional. Gets or sets the mail exchangers that will be used to send
760 the test reports. If you override the default values make sure you
761 pass in a reference to an array. By default, this contains the MX's
762 known at the time of release for perl.org. If you do not have
763 Mail::Send installed (thus using the Net::SMTP interface) and do have
764 Net::DNS installed it will dynamically retrieve the latest MX's. You
765 really shouldn't need to use this unless the hardcoded MX's have
766 become wrong and you don't have Net::DNS installed.
768 =item * B<mail_send_args>
770 Optional. If you have MailTools installed and you want to have it
771 behave in a non-default manner, parameters that you give this
772 method will be passed directly to the constructor of
773 Mail::Mailer. See L<Mail::Mailer> and L<Mail::Send> for details.
777 Optional. Defaults to the current working directory. This method specifies
778 the directory that write() writes test report files to.
780 =item * B<write and read>
782 These methods are used in situations where you test on a machine that has
783 port 25 blocked and there is no local MTA. You use write() on the machine
784 that you are testing from, transfer the written test reports from the
785 testing machine to the sending machine, and use read() on the machine that
786 you actually want to submit the reports from. write() will write a file in
787 an internal format that contains 'From', 'Subject', and the content of the
788 report. The filename will be represented as:
789 grade.distribution.archname.osvers.seconds_since_epoch.pid.rpt. write()
790 uses the value of dir() if it was specified, else the cwd.
792 On the machine you are testing from:
794 my $reporter = Test::Reporter->new
797 distribution => 'Test-Reporter-1.16',
800 On the machine you are submitting from:
803 $reporter = Test::Reporter->new()->read('pass.Test-Reporter-1.16.i686-linux.2.2.16.1046685296.14961.rpt')->send() || die $reporter->errstr(); # wrap in an opendir if you've a lot to submit
805 write() also accepts an optional filehandle argument:
807 my $fh; open $fh, '>-'; # create a STDOUT filehandle object
808 $reporter->write($fh); # prints the report to STDOUT
814 If you specify recipients to be cc'd while using send() (and you do not have
815 Mail::Send installed) be sure that you use the author's @cpan.org address
816 otherwise they may not be delivered, since the perl.org MX's are unlikely
817 to relay for anything other than perl.org and cpan.org.
821 If you happen to find one please email me at afoxson@pobox.com, and/or report
822 it to the below URL. Thank you.
824 http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Reporter
828 Copyright (c) 2003 Adam J. Foxson. All rights reserved.
832 This program is free software; you may redistribute it
833 and/or modify it under the same terms as Perl itself.
845 =item * L<File::Spec>
847 =item * L<File::Temp>
849 =item * L<Net::Domain>
851 This is optional. If it's installed Test::Reporter will try even
852 harder at guessing your mail domain.
856 This is optional. If it's installed Test::Reporter will dynamically
857 retrieve the mail exchangers for perl.org, instead of relying on the
858 MX's known at the time of this release.
860 =item * L<Mail::Send>
862 This is optional. If it's installed Test::Reporter will use Mail::Send
863 instead of Net::SMTP.
869 Adam J. Foxson E<lt>F<afoxson@pobox.com>E<gt> and
870 Richard Soderberg E<lt>F<rsod@cpan.org>E<gt>, with much deserved credit to
871 Kirrily "Skud" Robert E<lt>F<skud@cpan.org>E<gt>, and
872 Kurt Starsinic E<lt>F<Kurt.Starsinic@isinet.com>E<gt> for predecessor versions
873 (CPAN::Test::Reporter, and cpantest respectively).