Perl::Critic::Policy::Compatibility::PerlMinimumVersionAndWhy - explicit Perl version for features used

    use 5.010;       # the // operator is new in perl 5.010
    print $x // $y;  # ok

    [-Compatibility::PerlMinimumVersionAndWhy]

# Copyright 2009, 2010, 2011 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::PerlMinimumVersionAndWhy;
use 5.006;
use strict;
use warnings;
use version ();

# 1.208 for PPI::Token::QuoteLike::Regexp get_modifiers()
use PPI 1.208;

# 1.084 for Perl::Critic::Document highest_explicit_perl_version()
use Perl::Critic::Policy 1.084;
use base 'Perl::Critic::Policy';
use Perl::Critic::Utils qw(parse_arg_list);
use Perl::Critic::Pulp::Utils;

# uncomment this to run the ### lines
#use Smart::Comments;

our $VERSION = 61;

use constant supported_parameters =>
  ({ name        => 'above_version',
     description => 'Check only things above this version of Perl.',
     behavior    => 'string',
     parser      => \&Perl::Critic::Pulp::Utils::parameter_parse_version,
   },
   { name        => 'skip_checks',
     description => 'Version checks to skip (space separated list).',
     behavior    => 'string',
   });
use constant default_severity => $Perl::Critic::Utils::SEVERITY_LOW;
use constant default_themes   => qw(pulp compatibility);
use constant applies_to       => 'PPI::Document';


sub initialize_if_enabled {
  my ($self, $config) = @_;
  # ask that Perl::MinimumVersion is available and still has its
  # undocumented %CHECKS to mangle below
  eval { require Perl::MinimumVersion;
         scalar %Perl::MinimumVersion::CHECKS }
    or return 0;

  _setup_extra_checks();
}

sub violates {
  my ($self, $document) = @_;

  my %skip_checks;
  if (defined (my $skip_checks = $self->{_skip_checks})) {
    @skip_checks{split / /, $self->{_skip_checks}} = (); # hash slice
  }

  my $pmv = Perl::MinimumVersion->new ($document);
  my $config_above_version = $self->{'_above_version'};
  my $explicit_version = $document->highest_explicit_perl_version;

  my @violations;
  foreach my $check (sort keys %Perl::MinimumVersion::CHECKS) {
    next if exists $skip_checks{$check};
    next if $check eq '_constant_hash'; # better by ConstantPragmaHash
    # next if $check =~ /_pragmas$/;  # usually impossible in earlier
    next if $check =~ /_modules$/;  # wrong for dual-life stuff

    my $check_version = $Perl::MinimumVersion::CHECKS{$check};
    next if (defined $explicit_version
             && $check_version <= $explicit_version);
    next if (defined $config_above_version
             && $check_version <= $config_above_version);
    ### $check

    my $elem = do {
      no warnings 'redefine';
      local *PPI::Node::find_any = \&PPI::Node::find_first;
      $pmv->$check
    } || next;
    #     require Data::Dumper;
    #     print Data::Dumper::Dumper($elem);
    #     print $elem->location,"\n";
    push @violations,
      $self->violation ("$check requires $check_version",
                        '',
                        $elem);
  }
  return @violations;
}

#---------------------------------------------------------------------------
# Crib note: $document->find_first wanted func returning undef means the
# element is unwanted and also don't descend into its sub-elements.
#

sub _setup_extra_checks {

  # 5.10.0
  my $v5010 = version->new('5.010');
  unless (eval { Perl::MinimumVersion->VERSION(1.28); 1 }) {
    # fixed in 1.28 up
    $Perl::MinimumVersion::CHECKS{_Pulp__5010_magic__fix}     = $v5010;
    $Perl::MinimumVersion::CHECKS{_Pulp__5010_operators__fix} = $v5010;
  }
  $Perl::MinimumVersion::CHECKS{_Pulp__5010_qr_m_propagate_properly} = $v5010;

  # 5.8.0
  my $v5008 = version->new('5.008');
  $Perl::MinimumVersion::CHECKS{_Pulp__fat_comma_across_newline} = $v5008;

  # 5.6.0
  my $v5006 = version->new('5.006');
  $Perl::MinimumVersion::CHECKS{_Pulp__exists_subr}       = $v5006;
  $Perl::MinimumVersion::CHECKS{_Pulp__exists_array_elem} = $v5006;
  $Perl::MinimumVersion::CHECKS{_Pulp__delete_array_elem} = $v5006;
  $Perl::MinimumVersion::CHECKS{_Pulp__0b_number}         = $v5006;
  $Perl::MinimumVersion::CHECKS{_Pulp__syswrite_length_optional} = $v5006;
  $Perl::MinimumVersion::CHECKS{_Pulp__open_my_filehandle} = $v5006;

  # 5.005
  my $v5005 = version->new('5.005');
  unless (exists
          $Perl::MinimumVersion::CHECKS{_bareword_ends_with_double_colon}) {
    # adopted into Perl::MinimumVersion 1.28
    $Perl::MinimumVersion::CHECKS{_Pulp__bareword_double_colon} = $v5005;
  }
  $Perl::MinimumVersion::CHECKS{_Pulp__my_list_with_undef} = $v5005;

  # 5.004
  my $v5004 = version->new('5.004');
  $Perl::MinimumVersion::CHECKS{_Pulp__special_literal__PACKAGE__} = $v5004;
  $Perl::MinimumVersion::CHECKS{_Pulp__use_version_number}         = $v5004;
  $Perl::MinimumVersion::CHECKS{_Pulp__for_loop_variable_using_my} = $v5004;
  $Perl::MinimumVersion::CHECKS{_Pulp__arrow_coderef_call}         = $v5004;
  $Perl::MinimumVersion::CHECKS{_Pulp__sysseek_builtin}            = $v5004;

  # pack()/unpack()
  $Perl::MinimumVersion::CHECKS{_Pulp__pack_format_5004} = $v5004;
  $Perl::MinimumVersion::CHECKS{_Pulp__pack_format_5006} = $v5006;
  $Perl::MinimumVersion::CHECKS{_Pulp__pack_format_5008} = $v5008;
  $Perl::MinimumVersion::CHECKS{_Pulp__pack_format_5010} = $v5010;
}

{
  # Perl::MinimumVersion prior to 1.28 had 'PPI::Token::Operator' and
  # 'PPI::Token::Magic' swapped between the respective operator/magic tests

  package Perl::MinimumVersion;
  use vars qw(%MATCHES);
  sub _Pulp__5010_operators__fix {
    shift->Document->find_first
      (sub {
         $_[1]->isa('PPI::Token::Operator')
           and
             $MATCHES{_perl_5010_operators}->{$_[1]->content}
           } );
  }
  sub _Pulp__5010_magic__fix {
    shift->Document->find_first
      (sub {
         $_[1]->isa('PPI::Token::Magic')
           and
             $MATCHES{_perl_5010_magic}->{$_[1]->content}
           } );
  }
}

sub Perl::MinimumVersion::_Pulp__5010_qr_m_propagate_properly {
  my ($pmv) = @_;
  ### _Pulp__5010_qr_m_propagate_properly() check
  $pmv->Document->find_first
    (sub {
       my ($document, $elem) = @_;
       $elem->isa('PPI::Token::QuoteLike::Regexp') || return 0;
       my %modifiers = $elem->get_modifiers;
       ### content: $elem->content
       ### modifiers: \%modifiers
       return ($modifiers{'m'} ? 1 : 0);
     });
}

#-----------------------------------------------------------------------------
# foo \n => fat comma across newline new in 5.8.0
# extra code in 5.8 toke.c under comment "not a keyword" checking for =>
#

sub Perl::MinimumVersion::_Pulp__fat_comma_across_newline {
  my ($pmv) = @_;
  ### _Pulp__fat_comma_across_newline() check
  $pmv->Document->find_first
    (sub {
       my ($document, $elem) = @_;
       ### elem: "$elem"
       if ($elem->isa('PPI::Token::Operator')
           && $elem->content eq '=>') {
         my ($prev, $saw_newline) = sprevious_sibling_and_newline($elem);
         ### prev: "$prev"
         ### $saw_newline
         if ($saw_newline
             && $prev
             && $prev->isa('PPI::Token::Word')
             && $prev !~ /^-/   # -foo self-quotes
             && ! Perl::Critic::Utils::is_method_call($prev)) { # ->foo
           return 1; # found
         }
       }
       return 0; # continue searching
     });
}

sub sprevious_sibling_and_newline {
  my ($elem) = @_;
  ### sprevious_sibling_and_newline()
  my $saw_newline;
  for (;;) {
    $elem = $elem->previous_sibling || last;
    if ($elem->isa('PPI::Token::Whitespace')) {
      $saw_newline ||= ($elem->content =~ /\n/);
    } elsif ($elem->isa('PPI::Token::Comment')) {
      $saw_newline = 1;
    } else {
      last;
    }
  }
  return ($elem, $saw_newline);
}

#-----------------------------------------------------------------------------

# delete $array[0] and exists $array[0] new in 5.6.0
# two functions so the "exists" or "delete" appears in the check name
#
sub Perl::MinimumVersion::_Pulp__exists_array_elem {
  my ($pmv) = @_;
  ### _Pulp__exists_array_elem() check
  return _exists_or_delete_array_elem ($pmv, 'exists');
}
sub Perl::MinimumVersion::_Pulp__delete_array_elem {
  my ($pmv) = @_;
  ### _Pulp__delete_array_elem() check
  return _exists_or_delete_array_elem ($pmv, 'delete');
}
#use Smart::Comments;
sub _exists_or_delete_array_elem {
  my ($pmv, $which) = @_;
  ### _exists_or_delete_array_elem()
  $pmv->Document->find_first
    (sub {
       my ($document, $elem) = @_;
       if ($elem->isa('PPI::Token::Word')
           && $elem eq $which
           && Perl::Critic::Utils::is_function_call($elem)
           && _arg_is_array_elem($elem->snext_sibling)) {
         return 1;
       } else {
         return 0;
       }
     });
}
sub _arg_is_array_elem {
  my ($elem) = @_;
  ### _arg_is_array_elem: "$elem"

  (($elem = _descend_through_lists($elem))
   && $elem->isa('PPI::Token::Symbol')
   && $elem->raw_type eq '$'
   && ($elem = $elem->snext_sibling))
    or return 0;

  my $ret = 0;
  for (;;) {
    if ($elem->isa('PPI::Structure::Subscript')) {
      # adjacent $x{key}[123]
      $ret = ($elem->start eq '[');
    } elsif ($elem->isa('PPI::Structure::List')) {
      # $x[0]->() function call
      return 0;
    } elsif ($elem->isa('PPI::Token::Operator')
             && $elem eq '->') {
      # subscript ->, continue
    } else {
      # anything else below -> precedence, stop
      last;
    }
    $elem = $elem->snext_sibling || last;
  }
  ### $ret
  return $ret;
}
#no Smart::Comments;

sub _descend_through_lists {
  my ($elem) = @_;
  while ($elem
         && ($elem->isa('PPI::Structure::List')
        || $elem->isa('PPI::Statement::Expression')
             || $elem->isa('PPI::Statement'))) {
    $elem = $elem->schild(0);
  }
  return $elem;
}

# exists(&subr) new in 5.6.0
#
sub Perl::MinimumVersion::_Pulp__exists_subr {
  my ($pmv) = @_;
  ### _Pulp__exists_subr() check
  $pmv->Document->find_first
    (sub {
       my ($document, $elem) = @_;
       if ($elem->isa('PPI::Token::Word')
           && $elem eq 'exists'
           && Perl::Critic::Utils::is_function_call($elem)
           && ($elem = _symbol_or_list_symbol($elem->snext_sibling))
           && $elem->symbol_type eq '&') {
         return 1;
       } else {
         return 0;
       }
     });
}

# 0b110011 binary literals new in 5.6.0
#
sub Perl::MinimumVersion::_Pulp__0b_number {
  my ($pmv) = @_;
  ### _Pulp__0b_number() check
  $pmv->Document->find_first
    (sub {
       my ($document, $elem) = @_;
       if ($elem->isa('PPI::Token::Number::Binary')) {
         return 1;
       } else {
         return 0;
       }
     });
}

# syswrite($fh,$str) length optional in 5.6.0
#
sub Perl::MinimumVersion::_Pulp__syswrite_length_optional {
  my ($pmv) = @_;
  ### _Pulp__syswrite_length_optional() check
  $pmv->Document->find_first
    (sub {
       my ($document, $elem) = @_;
       my @args;
       if ($elem->isa('PPI::Token::Word')
           && $elem eq 'syswrite'
           && Perl::Critic::Utils::is_function_call($elem)
           && (@args = Perl::Critic::Utils::parse_arg_list($elem)) == 2) {
         return 1;
       } else {
         return 0;
       }
     });
}

# open(my $fh,...) auto-creating a handle glob new in 5.6.0
#
my %open_func = (open       => 1,
                 opendir    => 1,
                 pipe       => 2,
                 socketpair => 2,
                 sysopen    => 1,
                 socket     => 1,
                 accept     => 1);
sub Perl::MinimumVersion::_Pulp__open_my_filehandle {
  my ($pmv) = @_;
  ### _Pulp__open_my_filehandle() check
  $pmv->Document->find_first
    (sub {
       my ($document, $elem) = @_;
       my ($count, $my, $fh);
       unless ($elem->isa('PPI::Token::Word')
               && ($count = $open_func{$elem})
               && Perl::Critic::Utils::is_function_call($elem)) {
         return 0;
       }
       $my = $elem->snext_sibling;

       # with parens is
       #   PPI::Token::Word         'open'
       #    PPI::Structure::List    ( ... )
       #      PPI::Statement::Variable
       #       PPI::Token::Word     'my'
       #       PPI::Token::Symbol   '$fh'
       #       PPI::Token::Operator         ','
       #
       if ($my->isa('PPI::Structure::List')) {
         $my = $my->schild(0) || return 0;
       }
       if ($my->isa('PPI::Statement::Variable')) {
         $my = $my->schild(0) || return 0;
       }

       foreach (1 .. $count) {
         ### my: "$my"
         if (_is_uninitialized_my($my)) {
           return 1;
         }
         $my = _skip_to_next_arg($my) || last;
       }
       return 0;
     });
}

sub _is_uninitialized_my {
  my ($my) = @_;
  my ($fh, $after);
  return ($my->isa('PPI::Token::Word')
          && $my eq 'my'
          && ($fh = $my->snext_sibling)
          && $fh->isa('PPI::Token::Symbol')
          && $fh->symbol_type eq '$'
          && ! (($after = $fh->snext_sibling)
                && $after->isa('PPI::Token::Operator')
                && $after eq '='));
}

# FIXME: is this enough for prototyped funcalls in the args?
sub _skip_to_next_arg {
  my ($elem) = @_;
  for (;;) {
    my $next = $elem->snext_sibling || return undef;
    if ($elem->isa('PPI::Token::Operator')
        && $Perl::Critic::Pulp::Utils::COMMA{$elem}) {
      return $next;
    }
    $elem = $next;
  }
}

    

#-----------------------------------------------------------------------------
# Foo::Bar:: bareword new in 5.005
# generally a compile-time syntax error in 5.004
#
sub Perl::MinimumVersion::_Pulp__bareword_double_colon {
  my ($pmv) = @_;
  ### _Pulp__bareword_double_colon() check
  $pmv->Document->find_first
    (sub {
       my ($document, $elem) = @_;
       if ($elem->isa('PPI::Token::Word')
           && $elem =~ /::$/) {
         return 1;
       } else {
         return 0;
       }
     });
}

# my ($x, undef, $y), undef in a my() list new in 5.005
# usually something like my (undef, $x) = @values
#
sub Perl::MinimumVersion::_Pulp__my_list_with_undef {
  my ($pmv) = @_;
  ### _Pulp__my_list_with_undef() check
  $pmv->Document->find_first
    (sub {
       my ($document, $elem) = @_;
       if ($elem->isa('PPI::Token::Word')
           && $elem eq 'my'
           && _list_contains_undef ($elem->snext_sibling)) {
         return 1;
       } else {
         return 0;
       }
     });
}

# $elem is a PPI::Element or false
# return true if it's a list and there's an 'undef' element in the list
#
#     PPI::Structure::List    ( ... )
#       PPI::Statement::Expression
#         PPI::Token::Symbol   '$x'
#         PPI::Token::Operator         ','
#         PPI::Token::Word     'undef'
#         PPI::Token::Operator         ','
#         PPI::Token::Symbol   '$y'
#
# Or for multi-parens: my ((undef)) with PPI::Statement in the middle
#
#     PPI::Structure::List    ( ... )
#       PPI::Statement
#         PPI::Structure::List        ( ... )
#           PPI::Statement::Expression
#            PPI::Token::Word         'undef'
#
sub _list_contains_undef {
  my ($elem) = @_;
  ### _list_contains_undef: "$elem"
  $elem or return;
  $elem->isa('PPI::Structure::List') or return;
  my @search = ($elem);
  while (@search) {
    $elem = pop @search;
    ### elem: "$elem"
    if ($elem->isa('PPI::Structure::List')
        || $elem->isa('PPI::Statement::Expression')
        || $elem->isa('PPI::Statement')) {
      push @search, $elem->schildren;
    } elsif ($elem->isa('PPI::Token::Word')
             && $elem eq 'undef') {
      return 1;
    }
  }
}


#-----------------------------------------------------------------------------
# pack() / unpack()

sub Perl::MinimumVersion::_Pulp__pack_format_5004 {
  my ($pmv) = @_;
  # w - BER integer
  return _pack_format ($pmv, qr/w/);
}
sub Perl::MinimumVersion::_Pulp__pack_format_5006 {
  my ($pmv) = @_;
  # Z - asciz
  # q - signed quad
  # Q - unsigned quad
  # ! - native size
  # / - counted string
  # # - comment
 return _pack_format ($pmv, qr{[ZqQ!/#]});
}
sub Perl::MinimumVersion::_Pulp__pack_format_5008 {
  my ($pmv) = @_;
  # F - NV
  # D - long double
  # j - IV
  # J - UV
  # ( - group
  # [ - in a repeat count like "L[20]"
  return _pack_format ($pmv, qr/[FDjJ([]/);
}
sub Perl::MinimumVersion::_Pulp__pack_format_5010 {
  my ($pmv) = @_;
  # < - little endian
  # > - big endian
  return _pack_format ($pmv, qr/[<>]/);
}
# Think nothing new in 5012 ...

my %pack_func = (pack => 1, unpack => 1);
sub _pack_format {
  my ($pmv, $regexp) = @_;
  require Perl::Critic::Policy::Miscellanea::TextDomainPlaceholders;
  $pmv->Document->find_first
    (sub {
       my ($document, $elem) = @_;

       $elem->isa ('PPI::Token::Word') || return 0;
       $pack_func{$elem->content} || return 0;
       Perl::Critic::Utils::is_function_call($elem) || return 0;

       my @args = parse_arg_list ($elem);
       my $format_arg = $args[0];
       ### format: @$format_arg

       my ($str, $any_vars) = Perl::Critic::Policy::Miscellanea::TextDomainPlaceholders::_arg_string ($format_arg);
       ### $str
       ### $any_vars

       if ($any_vars) { return 0; }
       return ($str =~ $regexp);
     });
}

# 5.004 new __PACKAGE__
#
sub Perl::MinimumVersion::_Pulp__special_literal__PACKAGE__ {
  my ($pmv) = @_;
  ### _Pulp__special_literal__PACKAGE__
  $pmv->Document->find_first
    (sub {
       my ($document, $elem) = @_;
       if ($elem->isa('PPI::Token::Word')
           && $elem eq '__PACKAGE__'
           && ! Perl::Critic::Utils::is_hash_key($elem)) {
         return 1;
       } else {
         return 0;
       }
     });
}

# 5.004 new "use VERSION"
#
# "use MODULE VERSION" is not as easy, fairly sure it depends whether the
# target module uses Exporter.pm or not since the VERSION part is passed to
# import() and Exporter.pm checks it.
#
sub Perl::MinimumVersion::_Pulp__use_version_number {
  my ($pmv) = @_;
  ### _Pulp__use_version_number
  $pmv->Document->find_first
    (sub {
       my ($document, $elem) = @_;
       $elem->isa('PPI::Statement::Include') or return 0;
       $elem->type eq 'use' or return 0;
       if ($elem->version ne '') {  # empty string '' for not a "use VERSION"
         return 1;
       } else {
         return 0;
       }
     });
}

# 5.004 new "foreach my $i" lexical loop variable
#
sub Perl::MinimumVersion::_Pulp__for_loop_variable_using_my {
  my ($pmv) = @_;
  ### _Pulp__for_loop_variable_using_my
  $pmv->Document->find_first
    (sub {
       my ($document, $elem) = @_;
       $elem->isa('PPI::Statement::Compound') or return 0;
       $elem->type eq 'foreach' or return 0;
       my $second = $elem->schild(1) || return 0;
       $second->isa('PPI::Token::Word') or return 0;
       if ($second eq 'my') {
         return 1;
       } else {
         return 0;
       }
     });
}

# 5.004 new "$foo->(PARAMS)" coderef call
#
sub Perl::MinimumVersion::_Pulp__arrow_coderef_call {
  my ($pmv) = @_;
  ### _Pulp__arrow_coderef_call
  $pmv->Document->find_first
    (sub {
       my ($document, $elem) = @_;
       $elem->isa('PPI::Token::Operator') or return 0;
       ### operator: "$elem"
       $elem eq '->' or return 0;
       $elem = $elem->snext_sibling || return 0;
       ### next: "$elem"
       if ($elem->isa('PPI::Structure::List')) {
         return 1;
       } else {
         return 0;
       }
     });
}

# 5.004 new sysseek() function
#
# Crib note: the prototype() function is newly documented in 5.004 but
# existed earlier, or something.  Might have returned a trailing "\0" in
# 5.003.
#
sub Perl::MinimumVersion::_Pulp__sysseek_builtin {
  my ($pmv) = @_;
  ### _Pulp__sysseek_builtin
  $pmv->Document->find_first
    (sub {
       my ($document, $elem) = @_;
       if ($elem->isa('PPI::Token::Word')
           && ($elem eq 'sysseek' || $elem eq 'CORE::sysseek')
           && Perl::Critic::Utils::is_function_call ($elem)) {
         return 1;
       } else {
         return 0;
       }
     });
}


#---------------------------------------------------------------------------
# generic

# if $elem is a symbol or a List of a symbol then return that symbol elem,
# otherwise return an empty list
#
sub _symbol_or_list_symbol {
  my ($elem) = @_;
  if ($elem->isa('PPI::Structure::List')) {
    $elem = $elem->schild(0) || return;
    $elem->isa('PPI::Statement::Expression') || return;
    $elem = $elem->schild(0) || return;
  }
  $elem->isa('PPI::Token::Symbol') || return;
  return $elem;
}


#---------------------------------------------------------------------------

1;
__END__