# Copyright 2009, 2010, 2011, 2013 Kevin Ryde
# Perl-Critic-Pulp is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 3, or (at your option) any later
# version.
#
# Perl-Critic-Pulp is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Perl-Critic-Pulp. If not, see <http://www.gnu.org/licenses/>.
package Perl::Critic::Policy::Compatibility::inprogressTestMore;
use 5.006;
use strict;
use warnings;
use List::Util;
use version (); # but don't import qv()
use base 'Perl::Critic::Policy';
use Perl::Critic::Utils qw(is_function_call);
use Perl::Critic::Pulp::Utils;
use constant DEBUG => 0;
use constant supported_parameters => ();
use constant default_severity => $Perl::Critic::Utils::SEVERITY_MEDIUM;
use constant default_themes => qw(pulp bugs);
use constant applies_to => ('PPI::Token::Word', 'PPI::Token::Symbol');
my %functions = ('explain' => { module => 'Test::More',
modver => version->new('0.82'),
perlver => version->new('5.010001'),
export => 1 }
);
sub violates {
my ($self, $elem, $document) = @_;
my $elem_str;
if ($elem->isa('PPI::Token::Symbol')) {
$elem->symbol_type eq '&'
or return; # not &foo function
$elem_str = substr ($elem->symbol, 1);
} else {
# PPI::Token::Word
$elem_str = $elem->content;
}
my ($elem_qualifier, $elem_basename) = _qualifier_and_basename ($elem_str);
if (defined $elem_qualifier && $elem_qualifier ne 'Test::More') {
return; # some other Foo::Bar::func()
}
my $want = $functions{$elem_basename} || return;
is_function_call ($elem)
or return;
my $got_perl = $document->highest_explicit_perl_version;
if (defined $got_perl
&& ref $got_perl
&& $got_perl >= $want->{'perlver'}) {
return; # high enough "use 5.010" or whatnot
}
my $got_testmore = _highest_explicit_module_version ($document,'Test::More');
if (! defined $got_testmore && ! defined $elem_qualifier) {
return; # no "use Test::More", so unqualified foo() is not it
}
if (defined $got_testmore
&& ref $got_testmore
&& $got_testmore >= $want->{'modver'}) {
return; # high enough "use Test::More 0.90" etc
}
return $self->violation
("$elem requires Test::More $want->{'modver'} or perl $want->{'perlver'}, but file has "
. (defined $got_testmore && ref $got_testmore
? "Test::More $got_testmore"
: "no version for Test::More")
. (defined $got_perl && ref $got_perl
? ", and perl $got_perl"
: ", and no perl version"),
'',
$elem);
}
sub _qualifier_and_basename {
my ($str) = @_;
return ($str =~ /(?:(.*)::)?(.*)/)
}
# return true if $document has a "use" of $module (string name of a package)
sub _document_uses_module {
my ($document, $module) = @_;
my $aref = $document->find ('PPI::Statement::Include')
|| return; # if no Includes at all
return List::Util::first {$_->type eq 'use'
&& (($_->module || '') eq $module)
} @$aref;
}
# return a "version" object which is the highest explicit use for $module (a
# string) in $document
#
# A call like Foo::Bar->VERSION(123) is a version check, but not sure that's
# worth looking for.
#
# If there's no version number on any "use" of $module then the return is
# version->new(0). If there's no "use" of $module at all then the return is
# undef.
#
sub _highest_explicit_module_version {
my ($document, $module) = @_;
my $cache_key = __PACKAGE__.'::_highest_explicit_module_version--'.$module;
if (exists $document->{$cache_key}) { return $document->{$cache_key}; }
my $aref = $document->find ('PPI::Statement::Include')
|| return; # if no Includes at all
my @incs = grep {$_->type eq 'use'
&& (($_->module || '') eq $module)} @$aref;
if (DEBUG) { local $, = "\n";
print " all incs",@$aref,'';
print " matched incs",@incs,''; }
if (! @incs) { return undef; }
my @vers = map { _include_module_version_with_exporter($_) } @incs;
if (DEBUG) { local $,=' / '; print " versions",@vers,"\n"; }
@vers = grep {defined} @vers;
if (! @vers) { return 0; }
@vers = map {version->new($_)} @vers;
my $maxver = List::Util::reduce {$a >= $b ? $a : $b} @vers;
return ($document->{$cache_key} = $maxver);
}
# $inc is a PPI::Statement::Include.
#
# If $inc has a version number, either in perl's native form or as a string
# or number as handled by the Exporter package, then return that as a
# version object.
#
sub _include_module_version_with_exporter {
my ($inc) = @_;
if (my $ver = Perl::Critic::Pulp::Utils::include_module_version ($inc)) {
return version->new ($ver->content);
}
if (my $ver = Perl::Critic::Pulp::Utils::include_module_first_arg ($inc)) {
if ($ver->isa('PPI::Token::Number')) {
$ver = $ver->content;
} elsif ($ver->isa('PPI::Token::Quote')) {
$ver = $ver->string;
} else {
return undef;
}
# Exporter looks only for a leading digit before calling ->VERSION, but
# be tighter here to avoid errors from version.pm about bad values
if ($ver =~ $Perl::Critic::Pulp::Utils::use_module_version_number_re) {
return version->new ($ver);
}
}
return undef;
}
1;
__END__
=head1 NAME
Perl::Critic::Policy::Compatibility::inprogressTestMore - new enough Test::More for its functions
=head1 DESCRIPTION
This policy is part of the L<C<Perl::Critic::Pulp>|Perl::Critic::Pulp>
add-on. It checks ...
As always if you don't care about this then you can disable C<inprogressTestMore>
from your F<.perlcriticrc> in the usual way (see
L<Perl::Critic/CONFIGURATION>),
[-Compatibility::inprogressTestMore]
=head1 SEE ALSO
L<Perl::Critic::Pulp>, L<Perl::Critic>
=head1 HOME PAGE
http://user42.tuxfamily.org/perl-critic-pulp/index.html
=head1 COPYRIGHT
Copyright 2009, 2010, 2011, 2013 Kevin Ryde
Perl-Critic-Pulp is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3, or (at your option) any later
version.
Perl-Critic-Pulp is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
more details.
You should have received a copy of the GNU General Public License along with
Perl-Critic-Pulp. If not, see <http://www.gnu.org/licenses/>.
=cut