——#!/usr/bin/perl
# $File: //member/autrijus/cpanplus/dist/bin/cpansmoke $ $Author: autrijus $
# $Revision: #5 $ $Change: 3825 $ $DateTime: 2002/04/09 11:17:33 $
use
strict;
use
Config;
use
Getopt::Std;
use
CPANPLUS::Backend;
my
$VERSION
=
'0.02'
;
=head1 NAME
cpansmoke - CPAN Smoke Tester
=head1 SYNOPSIS
B<cpansmoke> S<[ -B<acdflpv> ]> S<[ -B<t> I<timeout> ]> I<packages>...
=head1 DESCRIPTION
This script uses B<CPANPLUS> to test one or more distributions from
CPAN. It accept both distribution names with absolute author directory
(e.g. C<K/KA/KANE/CPANPLUS-0.01.tar.gz>), or module names (e.g.
C<CPANPLUS::Backend>), in which case the latest distribution containing
the module is tested.
=head1 OPTIONS
-a Automatically send reports without prompting or editing
-c Always Cc: to the module author (only on FAIL by default)
-d Display each package's existing result before testing it
-f Force re-fetching cached packages and checksum data
-l Use user-configured hosts; www.cpan.org is preferred by default
-p Install prerequisite modules; this is disabled by default
-s Skip modules that have testing results from the same settings
-v Print verbose proceeding informations
-t Sets timeout for each package's install; default to 300
=cut
############################################################################
### Parse Options ##########################################################
############################################################################
show_usage()
unless
@ARGV
;
my
%args
; getopts(
'acdflpsvt:'
, \
%args
);
my
(
$auto
,
$cc
,
$display
,
$force
,
$local
,
$prereq
,
$skip
,
$verbose
,
$timeout
)
=
@args
{
qw|a c d f l p s v t|
};
############################################################################
### Initialize Environment #################################################
############################################################################
my
$cp
= CPANPLUS::Backend->new;
# CPANPLUS Backend object
my
$conf
=
$cp
->configure_object;
# Configuration for this session
my
$shell
=
bless
({},
'main'
);
# fake shell object
$cp
->{_shell} =
$shell
;
$ENV
{VISUAL} =
'echo'
if
$auto
;
# let cpantest skip editing
$conf
->set_conf(
prereq
=>
$prereq
);
$conf
->set_conf(
force
=>
$force
);
$conf
->set_conf(
verbose
=>
$verbose
);
$conf
->set_conf(
cpantest
=>
$args
{c} ?
'always_cc'
: 1 );
$conf
->_set_ftp(
urilist
=> [ {
# prefers www.cpan.org
path
=>
'/'
,
scheme
=>
'http'
,
host
=>
'www.cpan.org'
,
}, @{
$conf
->_get_ftp(
'urilist'
) } ])
unless
$local
;
############################################################################
### Start Smoking ##########################################################
############################################################################
foreach
my
$pkg
(
@ARGV
) {
$pkg
=~ s|.
*authors
/id||;
# strip leading paths
$pkg
=
"/$pkg"
if
$pkg
=~ m|^[^/].*/|;
# add leading / if needed
### Translate module names to package names
my
$dist
= (
$pkg
=~ m|^/|) ?
$pkg
: _distname(
$cp
->module_tree->{
$pkg
})
or (
(
"No such module: $pkg, skipping.\n"
),
next
);
return
unless
defined
$dist
;
my
$report
=
$cp
->reports(
modules
=> [
$dist
] )
if
$display
or
$skip
;
my
$is_there
;
my
$my_platform
=
join
(
' '
, $^O,
$Config
{osvers},
$Config
{archname});
while
(
my
(
$name
,
$href
) =
each
(
%$report
) ) {
while
(
my
(
$dist
,
$pf_ref
) =
each
(
%$href
) ) {
"[$dist]\n"
if
$display
;
for
my
$platform
(
sort
keys
%{
$pf_ref
}) {
printf
"%8s %s\n"
,
$pf_ref
->{
$platform
},
$platform
if
$display
;
$is_there
= 1
if
$platform
eq
$my_platform
;
}
}
}
if
(
$skip
and
$is_there
) {
"$dist already tested on this configuration; skipping.\n"
;
next
;
}
"Testing: "
.(
$pkg
=~ m|^/| ?
$pkg
:
"$pkg ($dist)"
).
"\n"
;
eval
{
local
$SIG
{ALRM} =
sub
{
die
"\n"
};
# alarm handler
alarm
(
$timeout
|| 300);
# default timeout is 5 mins
$cp
->install(
# perform the install
modules
=> [
$dist
],
# one module at a time
target
=>
'test'
,
# but stop after 'make test'
);
alarm
0;
# reset alarm
};
warn
$@
if
$@;
# warns any errors
}
sub
_distname {
my
$module
=
shift
or
return
;
my
(
$author
,
$package
) = @{
$module
}{
qw|author package|
};
return
join
(
'/'
,
''
,
substr
(
$author
, 0, 1),
substr
(
$author
, 0, 2),
$author
,
$package
,
);
}
### Fake shell method to confirm sending out report ###
sub
_ask_report {
my
$obj
=
shift
;
my
%args
=
@_
;
my
$dist
=
$args
{dist};
my
$grade
=
$args
{grade};
return
1
if
$auto
;
$obj
->{_term} ||= Term::ReadLine->new($0);
return
$obj
->{_term}->
readline
(
"Report ${dist}'s testing result (\U$grade\E)? [y/N]: "
) =~ /^[yY]/;
}
### Display usage info ###
sub
show_usage {
<<
"."
;
Usage:
$0 [ -acflpv ] [ -t timeout ] <module | distribution> ...
-a Automatically
send
reports without prompting or editing
-c Always Cc: to the module author (only on FAIL by
default
)
-d Display
each
package
's existing result
before
testing it
-f Force re-fetching cached packages and checksum data
-l Use user-configured hosts; www.cpan.org is preferred by
default
-p Install prerequisite modules; this is disabled by
default
-s Skip modules that have testing results from the same settings
-v Print verbose proceeding informations
-t Sets timeout
for
each
package
's install;
default
to 300
.
exit
;
}
### Answers whether to install prerequisites -- should never be called ###
sub
_ask_prereq {
return
$prereq
;
}
__END__
=head1 SEE ALSO
L<CPANPLUS>, L<cpantest>
=head1 AUTHORS
Autrijus Tang E<lt>autrijus@autrijus.orgE<gt>
=head1 COPYRIGHT
Copyright 2001, 2002 by Autrijus Tang E<lt>autrijus@autrijus.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut