2016-11-12 09:24:52 +01:00
|
|
|
#!/usr/bin/perl -w
|
|
|
|
use strict;
|
|
|
|
|
|
|
|
use Test::More;
|
|
|
|
use Getopt::Std;
|
|
|
|
use CPAN::Meta;
|
2018-04-13 11:24:02 +02:00
|
|
|
use File::Temp;
|
2016-11-12 09:24:52 +01:00
|
|
|
|
|
|
|
sub usage {
|
|
|
|
my $exit = shift;
|
|
|
|
$exit = 0 if !defined $exit;
|
|
|
|
print "Usage: $0 [ Some::Module] ...\n";
|
|
|
|
print "\tthe perl module is guessed from META.{json,yml} if not given as argument\n";
|
|
|
|
exit $exit;
|
|
|
|
}
|
|
|
|
|
|
|
|
my %opts;
|
|
|
|
getopts('h', \%opts)
|
|
|
|
or usage();
|
|
|
|
|
|
|
|
usage(0) if $opts{h};
|
|
|
|
|
|
|
|
sub getmodule {
|
|
|
|
my $module;
|
|
|
|
my $conffile = "debian/tests/pkg-perl/use-name";
|
|
|
|
$conffile = "debian/tests/pkg-perl/module-name" if ! -e $conffile; # backcompat
|
|
|
|
$conffile = "debian/tests/module-name" if ! -e $conffile; # backcompat squared
|
2018-04-13 11:24:02 +02:00
|
|
|
|
|
|
|
$module = read_conffile($conffile);
|
|
|
|
return $module if defined $module;
|
|
|
|
return getmeta();
|
|
|
|
}
|
|
|
|
|
|
|
|
sub read_conffile {
|
|
|
|
my $conffile = shift;
|
|
|
|
my $ret;
|
2016-11-12 09:24:52 +01:00
|
|
|
if ( -f $conffile ) {
|
|
|
|
open(M, "<", $conffile)
|
|
|
|
or BAIL_OUT("$conffile exists but can't be read");
|
|
|
|
while (<M>) {
|
|
|
|
chomp;
|
|
|
|
next if /^\s*#/;
|
2018-04-13 11:24:02 +02:00
|
|
|
/(\S+)/ and $ret = $1, last;
|
2016-11-12 09:24:52 +01:00
|
|
|
}
|
2018-04-13 11:24:02 +02:00
|
|
|
close M;
|
|
|
|
BAIL_OUT("can't find anything in $conffile")
|
|
|
|
if !defined $ret;
|
2016-11-12 09:24:52 +01:00
|
|
|
}
|
2018-04-13 11:24:02 +02:00
|
|
|
return $ret;
|
|
|
|
}
|
2016-11-12 09:24:52 +01:00
|
|
|
|
2018-04-13 11:24:02 +02:00
|
|
|
sub getmeta {
|
2016-11-12 09:24:52 +01:00
|
|
|
my $meta;
|
|
|
|
my $dist;
|
|
|
|
eval { $meta = CPAN::Meta->load_file('META.json') };
|
|
|
|
eval { $meta = CPAN::Meta->load_file('META.yml' ) } if !$meta;
|
|
|
|
plan skip_all => "can't guess package from META.json or META.yml"
|
|
|
|
if !$meta;
|
|
|
|
|
|
|
|
$dist = $meta->name;
|
|
|
|
|
2018-04-13 11:24:02 +02:00
|
|
|
my $module = $dist;
|
2016-11-12 09:24:52 +01:00
|
|
|
$module =~ s,-,::,g;
|
|
|
|
|
|
|
|
my $file = "$dist.pm";
|
|
|
|
$file =~ s,-,/,g;
|
|
|
|
|
|
|
|
my $basefile = $file;
|
|
|
|
$basefile =~ s,.*/,,;
|
|
|
|
|
|
|
|
( -f $basefile ) or (-f "lib/$file") or plan skip_all => "$basefile or lib/$file not found";
|
|
|
|
|
|
|
|
return $module;
|
|
|
|
}
|
|
|
|
|
2018-04-13 11:24:02 +02:00
|
|
|
sub getwhitelist {
|
|
|
|
my $whitelist = 'debian/tests/pkg-perl/use-whitelist';
|
|
|
|
my $ret;
|
|
|
|
$ret = read_conffile($whitelist) if ( -f $whitelist );
|
|
|
|
$ret;
|
|
|
|
}
|
|
|
|
|
2016-11-12 09:24:52 +01:00
|
|
|
my @modules = @ARGV ? @ARGV : getmodule();
|
|
|
|
|
2018-04-13 11:24:02 +02:00
|
|
|
my $whitelist = getwhitelist();
|
|
|
|
|
2016-11-12 09:24:52 +01:00
|
|
|
usage() if !@modules;
|
|
|
|
|
2018-04-13 11:24:02 +02:00
|
|
|
plan tests => 4 * scalar @modules;
|
|
|
|
|
|
|
|
# don't run the command in the source directory, in case
|
|
|
|
# cwd is on @INC
|
|
|
|
|
|
|
|
my $dir;
|
|
|
|
$dir = $ENV{'AUTOPKGTEST_TMP'};
|
|
|
|
$dir = $ENV{'ADTTMP'} if !defined $dir;
|
|
|
|
$dir = File::Temp::tempdir( CLEANUP => 1 ) if !defined $dir;
|
|
|
|
|
|
|
|
chdir($dir) or die("can't chdir to $dir");
|
2016-11-12 09:24:52 +01:00
|
|
|
|
|
|
|
for my $mod (@modules) {
|
2018-04-13 11:24:02 +02:00
|
|
|
for my $envprefix ('', 'env PERL_DL_NONLAZY=1 ') {
|
|
|
|
my $cmd = qq($envprefix $^X -w -M"$mod" -e 1 2>&1);
|
2016-11-12 09:24:52 +01:00
|
|
|
my @out = qx($cmd);
|
|
|
|
note(@out) if @out;
|
|
|
|
ok(!$?, "$cmd exited successfully");
|
2018-04-13 11:24:02 +02:00
|
|
|
@out = grep { !/$whitelist/ } @out if defined $whitelist;
|
|
|
|
ok(!@out, "$cmd produced no (non-whitelisted) output");
|
|
|
|
}
|
2016-11-12 09:24:52 +01:00
|
|
|
}
|