File Coverage

blib/lib/Perl/MinimumVersion.pm

Criterion	Covered	Total	%
statement	437	484	90.2
branch	278	394	70.5
condition	109	166	65.6
subroutine	95	102	93.1
pod	7	12	58.3
total	926	1158	79.9

package Perl::MinimumVersion;
$Perl::MinimumVersion::VERSION = '1.42'; # TRIAL
=pod

=head1 NAME

Perl::MinimumVersion - Find a minimum required version of perl for Perl code

=head1 SYNOPSIS

  # Create the version checking object
  $object = Perl::MinimumVersion->new( $filename );
  $object = Perl::MinimumVersion->new( \$source  );
  $object = Perl::MinimumVersion->new( $ppi_document );

  # Find the minimum version
  $version = $object->minimum_version;

=head1 DESCRIPTION

C takes Perl source code and calculates the minimum
version of perl required to be able to run it. Because it is based on
L, it can do this without having to actually load the code.

Currently it tests both the syntax of your code, and the use of explicit
version dependencies such as C.

Future plans are to also add support for tracing module dependencies.

Using C is dead simple, the synopsis pretty much
covers it.

The distribution comes with a script called L,
which is the easiest way to run C on your code:

 % perlver lib/Foo/Bar.pm

See the L for more details.

=head1 METHODS

=cut

use 5.006;
use strict;
use warnings;
use version             0.76   ();
use Carp                        ();
use Exporter                    ();
use List::Util          1.20    qw(max first);
use Params::Util        0.25    ('_INSTANCE', '_CLASS');
use PPI::Util                   ('_Document');
use PPI                 1.252   ();
use PPIx::Utils                 qw{
	:classification
	:traversal
};
use PPIx::Regexp        0.051;
use Perl::MinimumVersion::Reason ();

our (@ISA, @EXPORT_OK, %CHECKS, @CHECKS_RV ,%MATCHES);
BEGIN {
	# Export the PMV convenience constant
	@ISA       = 'Exporter';
	@EXPORT_OK = 'PMV';

	# The primary list of version checks
	%CHECKS = (
		_heredoc_indent          => version->new('5.025.007'),
		_double_diamond_operator => version->new('5.021.005'),
		_postfix_deref           => version->new('5.020'),

        # _stacked_labels         => version->new('5.014'),

		_yada_yada_yada         => version->new('5.012'),
		_pkg_name_version       => version->new('5.012'),
		_postfix_when           => version->new('5.012'),
		_perl_5012_pragmas      => version->new('5.012'),
		_while_readdir          => version->new('5.012'),

		_perl_5010_pragmas      => version->new('5.010'),
		_perl_5010_operators    => version->new('5.010'),
		_perl_5010_magic        => version->new('5.010'),
		_state_declaration      => version->new('5.010'),

		# Various small things
		_bugfix_magic_errno     => version->new('5.008.003'),
		_is_utf8                => version->new('5.008.001'),
		_unquoted_versions      => version->new('5.008.001'),
		_perl_5008_pragmas      => version->new('5.008'),
		_constant_hash          => version->new('5.008'),
		_local_soft_reference   => version->new('5.008'),
		_use_carp_version       => version->new('5.008'),
		_open_temp              => version->new('5.008'),
		_open_scalar            => version->new('5.008'),
		_internals_svreadonly   => version->new('5.008'),

		# Included in 5.6. Broken until 5.8
		_pragma_utf8            => version->new('5.008'),
	);
	@CHECKS_RV = ( #subs that return version
		'_feature_bundle', '_regex', '_re_flags', '_each_argument', '_binmode_2_arg',
		'_scheduled_blocks', '_experimental_bundle',
	);

	# Predefine some indexes needed by various check methods
	%MATCHES = (
		_perl_5012_pragmas => {
			deprecate => 1,
		},
		_perl_5010_pragmas => {
			mro     => 1,
			feature => 1,
		},
		_perl_5010_operators => {
			'//'  => 1,
			'//=' => 1,
			'~~'  => 1,
		},
		_perl_5010_magic => {
			'%+' => 1,
			'%-' => 1,
		},
		_perl_5008_pragmas => {
			threads           => 1,
			'threads::shared' => 1,
			sort              => 1,
			encoding          => 1,
		},
	);
}

sub PMV () { 'Perl::MinimumVersion' }





#####################################################################
# Constructor

=pod

=head2 new

  # Create the version checking object
  $object = Perl::MinimumVersion->new( $filename );
  $object = Perl::MinimumVersion->new( \$source  );
  $object = Perl::MinimumVersion->new( $ppi_document );

The C constructor creates a new version checking object for a
L. You can also provide the document to be read as a
file name, or as a C reference containing the code.

Returns a new C object, or C on error.

=cut

sub new {
	my $class    = ref $_[0] ? ref shift : shift;
	my $Document = _Document(shift) or return undef;
	my $default  = _INSTANCE(shift, 'version') || version->new('5.006');

	# Create the object
	my $self = bless {
		Document => $Document,

		# Checking limit and default minimum version.
		# Explicitly don't check below this version.
		default  => $default,

		# Caches for resolved versions
		explicit => undef,
		syntax   => undef,
		external => undef,
	}, $class;

	$self;
}

=pod

=head2 Document

The C accessor can be used to get the L object
back out of the version checker.

=cut

sub Document {
	$_[0]->{Document}
}





#####################################################################
# Main Methods

=pod

=head2 minimum_version

The C method is the primary method for finding the
minimum perl version required based on C factors in the document.

At the present time, this is just syntax and explicit version checks,
as L is not yet completed.

Returns a L object, or C on error.

=cut

sub minimum_version {
	my $self    = _SELF(\@_) or return undef;
	my $minimum = $self->{default}; # Sensible default

	# Is the explicit version greater?
	my $explicit = $self->minimum_explicit_version;
	return undef unless defined $explicit;
	if ( $explicit and $explicit > $minimum ) {
		$minimum = $explicit;
	}

	# Is the syntax version greater?
	# Since this is the most expensive operation (for this file),
	# we need to be careful we don't run things we don't need to.
	my $syntax = $self->minimum_syntax_version;
	return undef unless defined $syntax;
	if ( $syntax and $syntax > $minimum ) {
		$minimum = $syntax;
	}

	### FIXME - Disabled until minimum_external_version completed
	# Is the external version greater?
	#my $external = $self->minimum_external_version;
	#return undef unless defined $external;
	#if ( $external and $external > $minimum ) {
	#	$minimum = $external;
	#}

	$minimum;
}

sub minimum_reason {
	my $self    = _SELF(\@_) or return undef;
	my $minimum = $self->default_reason; # Sensible default

	# Is the explicit version greater?
	my $explicit = $self->minimum_explicit_version;
	return undef unless defined $explicit;
	if ( $explicit and $explicit > $minimum ) {
		$minimum = $explicit;
	}

}

sub default_reason {
	Perl::MinimumVersion::Reason->new(
		rule    => 'default',
		version => $_[0]->{default},
		element => undef,
	);
}

=pod

=head2 minimum_explicit_version

The C method checks through Perl code for the
use of explicit version dependencies such as.

  use 5.006;
  require 5.005_03;

Although there is almost always only one of these in a file, if more than
one are found, the highest version dependency will be returned.

Returns a L object, false if no dependencies could be found,
or C on error.

=cut

sub minimum_explicit_version {
	my $self   = _SELF(\@_) or return undef;
	my $reason = $self->minimum_explicit_reason(@_);
	return $reason ? $reason->version : $reason;
}

sub minimum_explicit_reason {
	my $self = _SELF(\@_) or return undef;
	unless ( defined $self->{explicit} ) {
		$self->{explicit} = $self->_minimum_explicit_version;
	}
	return $self->{explicit};
}

sub _minimum_explicit_version {
	my $self     = shift or return undef;
	my $explicit = $self->Document->find( sub {
		$_[1]->isa('PPI::Statement::Include') or return '';
		$_[1]->version                        or return '';
		1;
	} );
	return $explicit unless $explicit;

	# Find the highest version
	my $max     = undef;
	my $element = undef;
	foreach my $include ( @$explicit ) {
		my $version = version->new($include->version);
		if ( not $element or $version > $max ) {
			$max     = $version;
			$element = $include;
		}
	}

	return Perl::MinimumVersion::Reason->new(
		rule    => 'explicit',
		version => $max,
		element => $element,
	);
}

=pod

=head2 minimum_syntax_version $limit

The C method will explicitly test only the
Document's syntax to determine it's minimum version, to the extent
that this is possible.

It takes an optional parameter of a L object defining
the lowest known current value. For example, if it is already known
that it must be 5.006 or higher, then you can provide a param of
qv(5.006) and the method will not run any of the tests below this
version. This should provide dramatic speed improvements for
large and/or complex documents.

The limitations of parsing Perl mean that this method may provide
artificially low results, but should not artificially high results.

For example, if C returned 5.006, you can be
confident it will not run on anything lower, although there is a chance
that during actual execution it may use some untestable feature that
creates a dependency on a higher version.

Returns a L object, false if no dependencies could be found,
or C on error.

=cut

sub minimum_syntax_version {
	my $self   = _SELF(\@_) or return undef;
	my $reason = $self->minimum_syntax_reason(@_);
	return $reason ? $reason->version : $reason;
}

sub minimum_syntax_reason {
	my $self  = _SELF(\@_) or return undef;
	my $limit = shift;
	if ( defined $limit and not _INSTANCE($limit, 'version') ) {
		$limit = version->new("$limit");
	}
	if ( defined $self->{syntax} ) {
		if ( !defined($limit) or $self->{syntax}->version >= $limit ) {
			# Previously discovered minimum is what they want
			return $self->{syntax};
		}

		# Rather than return a value BELOW their filter,
		# which they would not be expecting, return false.
		return '';
	}

	# Look for the value
	my $syntax = $self->_minimum_syntax_version( $limit );

	# If we found a value, it will be stable, cache it.
	# If we did NOT, don't cache as subsequent runs without
	# the filter may find a version.
	if ( $syntax ) {
		$self->{syntax} = $syntax;
		return $self->{syntax};
	}

	return '';
}

#for Perl::Critic::Policy::Compatibility::PerlMinimumVersionAndWhy
sub _set_checks2skip {
	my $self = shift;
	my $list = shift;
	$self->{_checks2skip} = $list;
}
sub _set_collect_all_reasons {
	my $self = shift;
	my $value = shift;
	$value = 1 unless defined $value;
	$self->{_collect_all_reasons} = $value;
}

sub _minimum_syntax_version {
	my $self   = shift;
	my $filter = shift || $self->{default};

	my %checks2skip;
	@checks2skip{ @{ $self->{_checks2skip} || [] } } = ();

	my %rv_result;
	my $current_reason;
	foreach my $rule ( @CHECKS_RV ) {
		next if exists $checks2skip{$rule};
		my ($v, $obj) = $self->$rule();
		$v = version->new($v);
		if ( $v > $filter ) {
			$current_reason = Perl::MinimumVersion::Reason->new(
				rule    => $rule,
				version => $v,
				element => _INSTANCE($obj, 'PPI::Element'),
			);
		    if ($self->{_collect_all_reasons}) {
				push @{ $self->{_all_reasons} }, $current_reason;
			} else {
				$filter = $v;
			}
	    }
	}


	# Always check in descending version order.
	# By doing it this way, the version of the first check that matches
	# is also the version of the document as a whole.
	my @rules = sort {
		$CHECKS{$b} <=> $CHECKS{$a}
	} grep {
	    not(exists $checks2skip{$_}) and $CHECKS{$_} > $filter
	} keys %CHECKS;

	foreach my $rule ( @rules ) {
		my $result = $self->$rule() or next;

		# Create the result object
		my $reason = Perl::MinimumVersion::Reason->new(
			rule    => $rule,
			version => $CHECKS{$rule},
			element => _INSTANCE($result, 'PPI::Element'),
		);
		if ($self->{_collect_all_reasons}) {
			push @{ $self->{_all_reasons} }, $current_reason;
		} else {
			return $reason;
		}

	}

	# Found nothing of interest
	return $current_reason || '';
}

=pod

=head2 minimum_external_version

B
an exception>

The C examines code for dependencies on other
external files, and recursively traverses the dependency tree applying the
same tests to those files as it does to the original.

Returns a C object, false if no dependencies could be found, or
C on error.

=cut

sub minimum_external_version {
	my $self   = _SELF(\@_) or return undef;
	my $reason = $self->minimum_explicit_reason(@_);
	return $reason ? $reason->version : $reason;
}

sub minimum_external_reason {
	my $self = _SELF(\@_) or return undef;
	unless ( defined $self->{external} ) {
		$self->{external} = $self->_minimum_external_version;
	}
	$self->{external};
}

sub _minimum_external_version {
	Carp::croak("Perl::MinimumVersion::minimum_external_version is not implemented");
}

=pod

=head2 version_markers

This method returns a list of pairs in the form:

  ($version, \@markers)

Each pair represents all the markers that could be found indicating that the
version was the minimum needed version.  C<@markers> is an array of strings.
Currently, these strings are not as clear as they might be, but this may be
changed in the future.  In other words: don't rely on them as specific
identifiers.

=cut

sub version_markers {
	my $self = _SELF(\@_) or return undef;

	my %markers;

	if ( my $explicit = $self->minimum_explicit_version ) {
		$markers{ $explicit } = [ 'explicit' ];
	}

	foreach my $check ( keys %CHECKS ) {
		next unless $self->$check();
		my $markers = $markers{ $CHECKS{$check} } ||= [];
		push @$markers, $check;
	}

	my @rv;
	my %marker_ver = map { $_ => version->new($_) } keys %markers;

	foreach my $ver ( sort { $marker_ver{$b} <=> $marker_ver{$a} } keys %markers ) {
		push @rv, $marker_ver{$ver} => $markers{$ver};
	}

	return @rv;
}




#####################################################################
# Version Check Methods

my %feature =
(
    'say'               => '5.10',
    'smartmatch'        => '5.10',
    'state'             => '5.10',
    'switch'            => '5.10',
    'unicode_strings'   => '5.14',
    'unicode_eval'      => '5.16',
    'evalbytes'         => '5.16',
    'current_sub'       => '5.16',
    'array_base'        => '5.16', #defined only in 5.16
    'fc'                => '5.16',
    'lexical_subs'      => '5.18',
    'postderef'         => '5.20',
    'postderef_qq'      => '5.20',
    'signatures'        => '5.20',
    'refaliasing'       => '5.22',
    'bitwise'           => '5.22',
    'declared_refs'     => '5.26',
    'isa'               => '5.32',
    'indirect'          => '5.32', #defined only in 5.32
);
my $feature_regexp = join('|', keys %feature);

#:5.14 means same as :5.12, but :5.14 is not defined in feature.pm in perl 5.12.
sub _feature_bundle {
    my @versions;
    my ($version, $obj);
	shift->Document->find( sub {
		$_[1]->isa('PPI::Statement::Include') or return '';
		$_[1]->pragma eq 'feature'            or return '';
		my @child = $_[1]->schildren;
		my @args = @child[1..$#child]; # skip 'use', 'feature' and ';'
		foreach my $arg (@args) {
		    my $v = 0;
		    $v = $1 if ($arg->content =~ /:(5\.\d+)(?:\.\d+)?/);
		    $v = max($v, $feature{$1}) if ($arg->content =~ /\b($feature_regexp)\b/);
			#
			if ($v and $v > ($version || 0) ) {
				$version = $v;
				$obj = $_[1];
			}
		}
		return '';
	} );
	return (defined($version)?"$version.0":undef, $obj);
}

# list copied from experimental.pm v0.021 itself
my %experimental =
(
    array_base      => '5',
    autoderef       => '5.14',
    bitwise         => '5.22',
    const_attr      => '5.22',
    current_sub     => '5.16',
    declared_refs   => '5.26',
    evalbytes       => '5.16',
    fc              => '5.16',
    isa             => '5.32',
    lexical_topic   => '5.10',
    lexical_subs    => '5.18',
    postderef       => '5.20',
    postderef_qq    => '5.20',
    refaliasing     => '5.22',
    regex_sets      => '5.18',
    say             => '5.10',
    smartmatch      => '5.10',
    signatures      => '5.20',
    state           => '5.10',
    switch          => '5.10',
    unicode_eval    => '5.16',
    unicode_strings => '5.12',
);
my $experimental_regexp = join('|', keys %experimental);
sub _experimental_bundle {
    my ($version, $obj);

    shift->Document->find( sub {
        return '' unless $_[1]->isa('PPI::Statement::Include')
                     and $_[1]->pragma eq 'experimental';

        my @child = $_[1]->schildren;
        my @args = @child[1..$#child]; # skip 'use', 'experimental' and ';'
        foreach my $arg (@args) {
            my $v = 0;
            $v = $1 if ($arg->content =~ /:(5\.\d+)(?:\.\d+)?/);
            $v = max($v, $experimental{$1}) if ($arg->content =~ /\b($experimental_regexp)\b/);

            if ($v and $v > ($version || 0) ) {
                $version = $v;
                $obj = $_[1];
            }
        }
        return '';
    } );

    return (defined($version)?"$version.0":undef, $obj);
}

my %SCHEDULED_BLOCK =
(
    'INIT'      => '5.006',
    'CHECK'     => '5.006002',
    'UNITCHECK' => '5.010',
);

sub _scheduled_blocks
{
    my @versions;
    my ($version, $obj);

	shift->Document->find( sub {
		$_[1]->isa('PPI::Statement::Scheduled') or return '';
        ($_[1]->children)[0]->isa('PPI::Token::Word') or return '';
        my $function = (($_[1]->children)[0])->content;
        exists( $SCHEDULED_BLOCK{ $function }) or return '';

        my $v = $SCHEDULED_BLOCK{ ($_[1]->children)[0]->content };
        if ($v and $v > ($version || 0) ) {
            $version = $v;
            $obj = $_[1];
        }

		return '';
	} );
	return (defined($version) ? $version : undef, $obj);
}

sub _regex {
	my $self = shift;
	my @versions;
	my ($version, $obj);
	$self->Document->find( sub {
		return '' unless
			grep { $_[1]->isa($_) }
			qw/PPI::Token::QuoteLike::Regexp PPI::Token::Regexp::Match PPI::Token::Regexp::Substitute/;
			my $re = PPIx::Regexp->new( $_[1] );
			my $v = $re->perl_version_introduced;
			if ($v and $v > ($version || 0) ) {
				$version = $v;
				$obj = $_[1];
			}
		return '';
	} );
	my $tr_r_version = version->new('5.013.007');
	$self->Document->find( sub {
		return '' unless
			$_[1]->isa(q/PPI::Token::Regexp::Transliterate/);
			if( exists $_[1]->get_modifiers->{r}
				&& $tr_r_version > ( $version || 0 )
			) {
				$version = $tr_r_version;
				$obj = $_[1];
			}
		return '';
	} );
	$version = undef if ($version and $version eq '5.000');
	return ($version, $obj);
}

# Check for use re "/flags";
sub _re_flags {
	my ($version, $obj);
	shift->Document->find( sub {
		return '' unless $_[1]->isa('PPI::Statement::Include')
			and ($_[1]->module eq 're' or $_[1]->pragma eq 're');
		my $included = $_[1]->schild(2);
		my @literal = $included->can('literal') ? $included->literal() : $included->string();
		my $v = "5.005";
		my @flags = grep {index($_, '/') == 0} @literal;
		$v = '5.014' if @flags;
		$v = max $v, map {
			my $empty_regex_w_flag = "/$_";
			PPIx::Regexp->new( $empty_regex_w_flag )->perl_version_introduced;
		} @flags;
		if ($v and $v > ($version || 0) ) {
			$version = $v;
			$obj = $_[1];
		}

	} );
	$version = undef if ($version and $version eq '5.000');
	return ($version, $obj);
}

sub _each_argument {
    my ($version, $obj);
	shift->Document->find( sub {
		$_[1]->isa('PPI::Token::Word') or return '';
		$_[1]->content =~ '^(each|keys|values)$'  or return '';
		return '' if is_method_call($_[1]);
		my $next = $_[1]->snext_sibling;
		$next = $next->schild(0)->schild(0) if $next->isa('PPI::Structure::List');
		if($next->isa('PPI::Token::Cast')) {
			if($next->content eq '@' && 5.012 > ($version || 0)) {
				$version = 5.012;
				$obj = $_[1]->parent;
			} elsif($next->content eq '$' && 5.014 > ($version || 0)) {
				$version = 5.014;
				$obj = $_[1]->parent;
			}
		} elsif($next->isa('PPI::Token::Symbol')) {
			if($next->raw_type eq '@' && 5.012 > ($version || 0)) {
				$version = 5.012;
				$obj = $_[1]->parent;
			} elsif($next->raw_type eq '$' && 5.014 > ($version || 0)) {
				$version = 5.014;
				$obj = $_[1]->parent;
			}
		} elsif($next->isa('PPI::Token::Operator')) { # % $a
			return '';
		} elsif($_[1]->parent->isa('PPI::Statement::Sub')) { # sub each|keys|values
			return '';
		} else { # function call or other should be reference
			if(5.014 > ($version || 0)) {
				$version = 5.014;
				$obj = $_[1]->parent;
			}
		}
		return 1 if ($version and $version == 5.014);
		return '';
	} );
	return (defined($version)?"$version":undef, $obj);
}

#Is string (first argument) in list (other arguments)
sub _str_in_list {
	my $str = shift;
	foreach my $s (@_) {
		return 1 if $s eq $str;
	}
	return 0;
}


sub _binmode_2_arg {
    my ($version, $obj);
	shift->Document->find_first( sub {
		my $main_element=$_[1];
		$main_element->isa('PPI::Token::Word') or return '';
		$main_element->content eq 'binmode'       or return '';
		return '' if is_hash_key($main_element);
		return '' if is_method_call($main_element);
		return '' if is_subroutine_name($main_element);
		return '' if is_included_module_name($main_element);
		return '' if is_package_declaration($main_element);
		my @arguments = parse_arg_list($main_element);
		if ( scalar @arguments == 2 ) {
		    my $arg2=$arguments[1][0];
			if ( $arg2->isa('PPI::Token::Quote')) { #check second argument
				my $str = $arg2->string;
				$str =~ s/^\s+//s;
				$str =~ s/\s+$//s;
				$str =~ s/:\s+/:/g;
				if ( !_str_in_list( $str => qw/:raw :crlf/) and $str !~ /[\$\@\%]/) {
            		$version = 5.008;
		            $obj = $main_element;
					return 1;
				}
			}
			if (!$version) {
        	    $version = 5.006;
	            $obj = $main_element;
	        }
		}
		return '';
	} );
	return ($version, $obj);
}



#http://perldoc.perl.org/functions/readdir.html
#while(readdir $dh) requires perl 5.12
sub _while_readdir {
	shift->Document->find_first( sub {
		$_[1]->isa('PPI::Token::Word') or return '';
		$_[1]->content eq 'while' or return '';
		return '' if is_hash_key($_[1]);
		return '' if is_method_call($_[1]);
		my $e1 = $_[1]->next_sibling or return '';
		if ($e1->isa('PPI::Structure::Condition')) { #while ()
			my @children = $e1->children;
			$e1 = $children[0];
		}
		$e1->isa('PPI::Statement::Expression') or return '';
		my @children = $e1->schildren;
	    $e1 = $children[0];

		$e1->isa('PPI::Token::Word') or return '';
		$e1->content eq 'readdir' or return '';
		return 1 if @children == 1; #incorrect call
		return '' if @children > 2; #not only readdir
		$e1 = $children[1];
		$e1->isa('PPI::Structure::List') or $e1->isa('PPI::Token::Symbol') or return '';
		#readdir($dh) or readdir $dh

		return 1;
	} );
}

sub _perl_5012_pragmas {
	shift->Document->find_first( sub {
		$_[1]->isa('PPI::Statement::Include')
		and
		$MATCHES{_perl_5012_pragmas}->{$_[1]->pragma}
	} );
}

sub _open_temp {
	shift->Document->find_first( sub {
		$_[1]->isa('PPI::Statement') or return '';
		my @children = $_[1]->children;
		#@children >= 7                or return '';
		my $main_element = $children[0];
		$main_element->isa('PPI::Token::Word') or return '';
		$main_element->content eq 'open'       or return '';
		my @arguments = parse_arg_list($main_element);
		if ( scalar @arguments == 3 and scalar(@{$arguments[2]}) == 1) {
		    my $arg3 = $arguments[2][0];
		    if ($arg3->isa('PPI::Token::Word') and $arg3->content eq 'undef') {
				return 1;
			}
		}
		return '';
	} );
}

sub _open_scalar {
	shift->Document->find_first( sub {
		$_[1]->isa('PPI::Statement') or return '';
		my @children = $_[1]->children;
		#@children >= 7                or return '';
		my $main_element = $children[0];
		$main_element->isa('PPI::Token::Word') or return '';
		$main_element->content eq 'open'       or return '';
		my @arguments = parse_arg_list($main_element);
		if ( scalar @arguments == 3) {
		    my $arg3 = $arguments[2][0];
		    if ($arg3->isa('PPI::Token::Cast') and $arg3->content eq '\\') {
				return 1;
			}
		}
		return '';
	} );
}

sub _get_resulting_sigil {
	my $elem = shift;
	if ($elem->isa('PPI::Token::Cast')) {
		return $elem->content;
	} elsif ($elem->isa('PPI::Token::Symbol')) {
		return $elem->symbol_type;
	} else {
		return undef;
	}
}

sub _heredoc_indent {
	shift->Document->find_first( sub {
		my $main_element = $_[1];
		$main_element->isa('PPI::Token::HereDoc') or return '';
		$main_element->content =~ /^\Q<<~\E/ or return '';
		return 1;
	});
}

# Postfix dereference new (and experimental) in 5.20, mainstream in 5.24.
# THIS CODE ASSUMES PPI 1.237_001 OR ABOVE -- i.e. support for postfix
# dereferencing.
#
my %postfix_deref = (
	'$*'	=> \&_postfix_deref_entire,
	'@*'	=> \&_postfix_deref_entire,
	'$#*'	=> \&_postfix_deref_entire,
	'%*'	=> \&_postfix_deref_entire,
	'&*'	=> \&_postfix_deref_entire,
	'**'	=> \&_postfix_deref_entire,
	'@'	=> \&_postfix_deref_slice,
	'%'	=> \&_postfix_deref_slice,
);

sub _postfix_deref_slice {
	my ( $elem ) = @_;
	my $next = $elem->snext_sibling()
		or return;
	return $next->isa( 'PPI::Structure::Subscript' );
}

sub _postfix_deref_entire {
	return 1;
}

sub _postfix_deref {
	shift->Document->find_first( sub {
		my $main_element=$_[1];
		$main_element->isa('PPI::Token::Cast') or return '';
		my $prev = $main_element->sprevious_sibling()
			or return '';
		return '' unless $prev->isa('PPI::Token::Operator') &&
			$prev->content() eq '->';
		$prev = $prev->sprevious_sibling()
			or return '';
		return '' unless $prev->isa('PPI::Token::Symbol') &&
			(_get_resulting_sigil($prev) || '') eq '$';
		my $code = $postfix_deref{ $main_element->content() }
			or return '';
		return $code->( $main_element ) || '';
	} );
}

sub _postfix_when {
	shift->Document->find_first( sub {
		my $main_element=$_[1];
		$main_element->isa('PPI::Token::Word') or return '';
		$main_element->content eq 'when'    or return '';
		return '' if is_hash_key($main_element);
		return '' if is_method_call($main_element);
		return '' if is_subroutine_name($main_element);
		return '' if is_included_module_name($main_element);
		return '' if is_package_declaration($main_element);
		my $stmnt = $main_element->statement();
		return '' if !$stmnt;
		return '' if $stmnt->isa('PPI::Statement::When');
		return 1;
	} );
}

sub _yada_yada_yada {
	shift->Document->find_first( sub {
		$_[1]->isa('PPI::Token::Operator')
		and $_[1]->content eq '...'  or return '';
		my @child = $_[1]->parent->schildren;
		@child == 1 and return 1;
		if (@child == 2) {
			$child[1]->isa('PPI::Token::Structure')
		}
	} );
}

sub _state_declaration {
	shift->Document->find_first( sub {
		$_[1]->isa('PPI::Statement::Variable')
        and ($_[1]->children)[0]->isa('PPI::Token::Word')
        and ($_[1]->children)[0]->content eq 'state'
	} );
}

sub _stacked_labels {
	shift->Document->find_first( sub {
		$_[1]->isa('PPI::Statement::Compound') || return '';
		$_[1]->schild(0)->isa('PPI::Token::Label') || return '';

		my $next = $_[1]->snext_sibling || return '';

        if (   $next->isa('PPI::Statement::Compound')
            && $next->schild(0)->isa('PPI::Token::Label')) {
            return 1;
        }

        0;
    } );
}

sub _internals_svreadonly {
	shift->Document->find_first( sub {
		$_[1]->isa('PPI::Statement')
        and ($_[1]->children)[0]->isa('PPI::Token::Word')
        and ($_[1]->children)[0]->content eq 'Internals::SvREADONLY'
	} );
}

sub _pkg_name_version {
	shift->Document->find_first( sub {
		$_[1]->isa('PPI::Statement::Package') or return '';
		my @child = $_[1]->schildren();
		$child[0]->isa('PPI::Token::Word')    or return '';
		$child[0]->content eq 'package'       or return '';
		$child[1]->isa('PPI::Token::Word')    or return '';
		$child[2]->isa('PPI::Token::Number')  or return '';
		return 1;
	} );
}

sub _perl_5010_pragmas {
	shift->Document->find_first( sub {
		$_[1]->isa('PPI::Statement::Include')
		and
		$MATCHES{_perl_5010_pragmas}->{$_[1]->pragma}
	} );
}

sub _perl_5010_operators {
	shift->Document->find_first( sub {
		$_[1]->isa('PPI::Token::Operator')
		and
		$MATCHES{_perl_5010_operators}->{$_[1]->content}
	} );
}

sub _perl_5010_magic {
	shift->Document->find_first( sub {
		$_[1]->isa('PPI::Token::Magic')
		and
		$MATCHES{_perl_5010_magic}->{$_[1]->symbol}
	} );
}

sub _perl_5008_pragmas {
	shift->Document->find_first( sub {
		$_[1]->isa('PPI::Statement::Include')
		and
		$MATCHES{_perl_5008_pragmas}->{$_[1]->pragma}
	} );
}

# 5.8.3: Reading $^E now preserves $!. Previously, the C code implementing $^E did not preserve errno, so reading $^E could cause errno and therefore $! to change unexpectedly.
sub _bugfix_magic_errno {
	my $Document = shift->Document;
	my $element = $Document->find_first( sub {
		$_[1]->isa('PPI::Token::Magic')
		and
		$_[1]->symbol eq '$^E'
	} ) || return undef;
	#$^E is more rare than $!, so search for it first and return it
	$Document->find_any( sub {
		$_[1]->isa('PPI::Token::Magic')
		and
		$_[1]->symbol eq '$!'
	} ) || return '';
	return $element;
}

# utf8::is_utf requires 5.8.1 unlike the rest of utf8
sub _is_utf8 {
	shift->Document->find_first( sub {
		$_[1]->isa('PPI::Token::Word') or return '';
		$_[1] eq 'utf8::is_utf'        or return '';
		return 1;
	} );
}

# version->new(5.005.004);
sub _unquoted_versions {
	shift->Document->find_first( sub {
		$_[1]->isa('PPI::Token::Number')       or return '';
		$_[1]->{_subtype}                      or return '';
		$_[1]->{_subtype} eq 'base256'         or return '';
		my $stmt   = $_[1]->parent             or return '';
		my $braces = $stmt->parent             or return '';
		$braces->isa('PPI::Structure')         or return '';
		$braces->braces eq '()'                or return '';
		my $new = $braces->previous_sibling    or return '';
		$new->isa('PPI::Token::Word')          or return '';
		$new->content eq 'new'                 or return '';
		my $method = $new->previous_sibling    or return '';
		$method->isa('PPI::Token::Operator')   or return '';
		$method->content eq '->'               or return '';
		my $_class = $method->previous_sibling or return '';
		$_class->isa('PPI::Token::Word')       or return '';
		$_class->content eq 'version'          or return '';
		1;
	} );
}

sub _pragma_utf8 {
	shift->Document->find_first( sub {
		$_[1]->isa('PPI::Statement::Include')
		and
		(
			($_[1]->module and $_[1]->module eq 'utf8')
			or
			($_[1]->pragma and $_[1]->pragma eq 'utf8')
		)
		# This used to be just pragma(), but that was buggy in PPI v1.118
	} );
}

# Check for the use of 'use constant { ... }'
sub _constant_hash {
	shift->Document->find_first( sub {
		$_[1]->isa('PPI::Statement::Include')
		and
		$_[1]->type
		and
		$_[1]->type eq 'use'
		and
		$_[1]->module eq 'constant'
		and
		$_[1]->schild(2)->isa('PPI::Structure')
	} );
}

# You can't localize a soft reference
sub _local_soft_reference {
	shift->Document->find_first( sub {
		$_[1]->isa('PPI::Statement::Variable')  or return '';
		$_[1]->type eq 'local'                  or return '';

		# The second child should be a '$' cast.
		my @child = $_[1]->schildren;
		scalar(@child) >= 2                     or return '';
		$child[1]->isa('PPI::Token::Cast')      or return '';
		$child[1]->content eq '$'               or return '';

		# The third child should be a block
		$child[2]->isa('PPI::Structure::Block') or return '';

		# Inside the block should be a string in a statement
		my $statement = $child[2]->schild(0)    or return '';
		$statement->isa('PPI::Statement')       or return '';
		my $inside = $statement->schild(0)      or return '';
		$inside->isa('PPI::Token::Quote')       or return '';

		# This is indeed a localized soft reference
		return 1;
	} );
}

# Carp.pm did not have a $VERSION in 5.6.2
# Therefore, even "use Carp 0" imposes a 5.8.0 dependency.
sub _use_carp_version {
	shift->Document->find_first( sub {
		$_[1]->isa('PPI::Statement::Include') or return '';
		$_[1]->module eq 'Carp'               or return '';

		my $version = $_[1]->module_version;
		return !! ( defined $version and length "$version" );
	} );
}

# Double-diamond operator.
# Detecting this requires at least PPI 1.252
sub _double_diamond_operator {
	shift->Document->find_first( sub {
		$_[1]->isa('PPI::Token::QuoteLike::Readline') or return '';
		$_[1]->content eq '<<>>'		or return '';
		return 1;
	} );
}

#####################################################################
# Support Functions

# Let sub be a function, object method, and static method
sub _SELF {
	my $param = shift;
	if ( _INSTANCE($param->[0], 'Perl::MinimumVersion') ) {
		return shift @$param;
	}
	if (
		_CLASS($param->[0])
		and
		$param->[0]->isa('Perl::MinimumVersion')
	) {
		my $class   = shift @$param;
		my $options = shift @$param;
		return $class->new($options);
	}
	Perl::MinimumVersion->new(shift @$param);
}

# Find the maximum version, ignoring problems
sub _max {
	defined $_[0] and "$_[0]" eq PMV and shift;

	# Filter and prepare for a Schwartian maximum
	my @valid = map {
		[ $_, $_->isa('Perl::MinimumVersion::Reason') ? $_->version : $_ ]
	} grep {
		_INSTANCE($_, 'Perl::MinimumVersion::Reason')
		or
		_INSTANCE($_, 'version')
	} @_ or return '';

	# Find the maximum
	my $max = shift @valid;
	foreach my $it ( @valid ) {
		$max = $it if $it->[1] > $max->[1];
	}

	return $max->[0];
}

1;

=pod

=head1 BUGS

B does a reasonable job of catching the best-known
explicit version dependencies.

B it is exceedingly easy to add a new syntax check, so if you
find something this is missing, copy and paste one of the existing
5 line checking functions, modify it to find what you want, and report it
to rt.cpan.org, along with the version needed.

I don't even need an entire diff... just the function and version.

=head1 TO DO

B

- Perl 5.10 operators and language structures

- Three-argument open

B

B

_while_readdir for postfix while without brackets

B
C, C<...>, and C)>

=head1 SUPPORT

All bugs should be filed via the CPAN bug tracker at

L

For other issues, or commercial enhancement or support, contact the author.

=head1 AUTHORS

Adam Kennedy [e-mail]

=head1 SEE ALSO

L - the command-line script for running C
on your code.

L - another module which does the same thing.
It's a lot faster, but only supports Perl 5.8.1+.

L, L, L

=head1 REPOSITORY

L

=head1 COPYRIGHT

Copyright 2005 - 2014 Adam Kennedy.

This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.

The full text of the license can be found in the
LICENSE file included with this module.

=cut