#!perl
sub
diag (;@) {
warn
@_
;
return
;
}
sub
pass () {
print
"ok 1\n1..1\n"
;
return
;
}
my
$CPAN_META
=
'CPAN::Meta'
;
my
$CPAN_META_PRE
=
'CPAN::Meta::Prereqs'
;
my
@DISPLAY_VARS
=
grep
{
$_
ne
'none'
}
qw( AUTHOR_TESTING
AUTOMATED_TESTING
EXTENDED_TESTING
NONINTERACTIVE_TESTING
PERL_CPAN_REPORTER_CONFIG
PERL_CR_SMOKER_CURRENT
PERL5_CPAN_IS_RUNNING
PERL5_CPANPLUS_IS_VERSION
TEST_CRITIC
TEST_SPELLING )
;
my
$DO_VERIFY_PREREQS
= 1;
my
@EXCLUDE
=
qw( )
;
my
$HOST
=
lc
hostname;
my
@INCLUDE
=
qw( )
;
my
$LAX_VERSION_RE
=
qr{(?: undef | (?: (?:[0-9]+) (?: \. | (?:\.[0-9]+) (?:_[0-9]+)? )?
|
(?:\.[0-9]+) (?:_[0-9]+)?
) | (?:
v (?:[0-9]+) (?: (?:\.[0-9]+)+ (?:_[0-9]+)? )?
|
(?:[0-9]+)? (?:\.[0-9]+){2,}
(?:_[0-9]+)?
)
)}x;
my
$OSNAME
=
lc
$^O;
my
$STATIC_PREREQS
=
do
't/00report-metadata.dd'
;
my
$diag_env
=
sub
{
my
$k
=
shift
;
my
$v
=
exists
$ENV
{
$k
} ?
$ENV
{
$k
} :
'undef'
;
return
diag
sprintf
" \$%-30s %s\n"
,
$k
,
$v
;
};
my
$max
=
sub
{
my
$v
=
shift
;
$v
= (
$_
>
$v
) ?
$_
:
$v
for
@_
;
return
$v
;
};
my
$merge_prereqs
=
sub
{
my
(
$collector
,
$prereqs
) =
@_
;
ref
$collector
eq
$CPAN_META_PRE
and
return
$collector
->with_merged_prereqs
( CPAN::Meta::Prereqs->new(
$prereqs
) );
for
my
$phase
(
keys
%{
$prereqs
}) {
for
my
$type
(
keys
%{
$prereqs
->{
$phase
} }) {
for
my
$module
(
keys
%{
$prereqs
->{
$phase
}{
$type
} }) {
$collector
->{
$phase
}{
$type
}{
$module
}
=
$prereqs
->{
$phase
}{
$type
}{
$module
};
}
}
}
return
$collector
;
};
my
$cpan_meta_ver
=
"${CPAN_META}->VERSION( '2.120900' )"
;
my
$has_cpan_meta
=
eval
"require ${CPAN_META}; ${cpan_meta_ver}"
&&
eval
"require ${CPAN_META_PRE}"
;
my
$full_prereqs
=
$merge_prereqs
->
( (
$has_cpan_meta
?
$CPAN_META_PRE
->new : {} ),
$STATIC_PREREQS
);
my
(
$source
) =
grep
{ -f }
'MYMETA.json'
,
'MYMETA.yml'
;
if
(
$source
and
$has_cpan_meta
) {
if
(
my
$meta
=
eval
{ CPAN::Meta->load_file(
$source
) }) {
$full_prereqs
=
$merge_prereqs
->(
$full_prereqs
,
$meta
->prereqs );
}
}
else
{
$source
=
'static metadata'
}
my
@full_reports
;
my
@dep_errors
;
my
$req_hash
=
$has_cpan_meta
?
$full_prereqs
->as_string_hash :
$full_prereqs
;
for
my
$mod
(
@INCLUDE
) {
$req_hash
->{other}{modules}{
$mod
} = 0;
}
for
my
$phase
(
qw( configure build test runtime develop other )
) {
$req_hash
->{
$phase
} or
next
;
$phase
eq
'develop'
and not
$ENV
{AUTHOR_TESTING} and
next
;
for
my
$type
(
qw( requires recommends suggests conflicts modules )
) {
$req_hash
->{
$phase
}{
$type
} or
next
;
my
$title
= (
ucfirst
$phase
).
' '
.(
ucfirst
$type
);
my
@reports
= [
qw( Module Want Have )
];
for
my
$mod
(
sort
keys
%{
$req_hash
->{
$phase
}{
$type
} }) {
$mod
eq
'perl'
and
next
;
grep
{
$_
eq
$mod
}
@EXCLUDE
and
next
;
my
$file
=
$mod
;
$file
=~ s{ :: }{/}gmx;
$file
.=
'.pm'
;
my
(
$prefix
) =
grep
{ -e File::Spec->catfile(
$_
,
$file
) }
@INC
;
my
$want
=
$req_hash
->{
$phase
}{
$type
}{
$mod
};
defined
$want
or
$want
=
'undef'
;
not
$want
and
$want
== 0 and
$want
=
'any'
;
my
$req_string
=
$want
eq
'any'
?
'any version required'
:
"version '${want}' required"
;
if
(
$prefix
) {
my
$path
= File::Spec->catfile(
$prefix
,
$file
);
my
$info
= Module::Metadata->new_from_file(
$path
);
my
$have
=
$info
->version;
defined
$have
or
$have
=
'undef'
;
push
@reports
, [
$mod
,
$want
,
$have
];
if
(
$DO_VERIFY_PREREQS
and
$has_cpan_meta
and
$type
eq
'requires'
) {
if
(
$have
!~ m{ \A
$LAX_VERSION_RE
\z }mx) {
push
@dep_errors
,
"${mod} version '${have}' cannot be parsed (${req_string})"
;
}
elsif
( !
$full_prereqs
->requirements_for(
$phase
,
$type
)->accepts_module(
$mod
=>
$have
) ) {
push
@dep_errors
,
"${mod} version '${have}' is not in required range '${want}'"
;
}
}
}
else
{
push
@reports
, [
$mod
,
$want
,
'missing'
];
$DO_VERIFY_PREREQS
and
$type
eq
'requires'
and
push
@dep_errors
,
"${mod} is not installed (${req_string})"
;
}
}
if
(
@reports
) {
push
@full_reports
,
"=== ${title} ===\n\n"
;
my
$ml
=
$max
->(
map
{
length
$_
->[ 0 ] }
@reports
);
my
$wl
=
$max
->(
map
{
length
$_
->[ 1 ] }
@reports
);
my
$hl
=
$max
->(
map
{
length
$_
->[ 2 ] }
@reports
);
if
(
$type
eq
'modules'
) {
splice
@reports
, 1, 0, [
'-'
x
$ml
,
q()
,
'-'
x
$hl
];
push
@full_reports
,
map
{
sprintf
" %*s %*s\n"
, -
$ml
,
$_
->[ 0 ],
$hl
,
$_
->[ 2 ] }
@reports
;
}
else
{
splice
@reports
, 1, 0, [
'-'
x
$ml
,
'-'
x
$wl
,
'-'
x
$hl
];
push
@full_reports
,
map
{
sprintf
" %*s %*s %*s\n"
, -
$ml
,
$_
->[ 0 ],
$wl
,
$_
->[ 1 ],
$hl
,
$_
->[ 2 ] }
@reports
;
}
push
@full_reports
,
"\n"
;
}
}
}
if
(
@DISPLAY_VARS
) {
diag
"\nOS: ${OSNAME}, Host: ${HOST}\n"
;
diag
"\n=== Environment variables ===\n\n"
;
$diag_env
->(
$_
)
for
(
@DISPLAY_VARS
);
}
if
(
@full_reports
) {
diag
"\nVersions for all modules listed in ${source} (including optional ones):\n\n"
,
@full_reports
;
}
if
(
@dep_errors
) {
diag
join
"\n"
,
"\n*** WARNING WARNING WARNING WARNING WARNING WARNING ***\n"
,
"The following REQUIRED prerequisites were not satisfied:\n"
,
@dep_errors
,
"\n"
;
}
pass;
exit
0;