libperl-minimumversion-perl 1.38-1 / usr / bin / perlver

#!/usr/bin/perl

eval 'exec /usr/bin/perl  -S $0 ${1+"$@"}'
    if 0; # not running under some shell

package perlver;
$perlver::VERSION = '1.38';
=pod

=head1 NAME

perlver - The Perl Minimum Version Analyzer

=head1 SYNOPSIS

  adam@red:~$ perlver Perl-MinimumVersion
  Found directory '.'
  Searching for Perl files... found 3 file(s)
  Scanning lib/Perl/MinimumVersion.pm... done
  Scanning t/01_compile.t... done
  Scanning t/02_main.t... done

      ---------------------------------------------------------
    | file                       | explicit | syntax | external |
    | --------------------------------------------------------- |
    | lib/Perl/MinimumVersion.pm | 5.005    | ~      | n/a      |
    | t/01_compile.t             | ~        | ~      | n/a      |
    | t/02_main.t                | ~        | ~      | n/a      |
      ---------------------------------------------------------

  Minimum version of Perl required: ...

  adam@red:~$

=head1 DESCRIPTION

C<perlver> is a console script created to provide convenient access to the
functionality provided by L<Perl::MinimumVersion>.

--blame option shows code which requires this version of perl

The synopsis above pretty much covers all you need to know at this point.

=cut

use 5.005;
use strict;
use version                'qv';
use File::Spec             ();
use Getopt::Long           'GetOptions';
use Params::Util           '_INSTANCE';
use File::Find::Rule       ();
use File::Find::Rule::Perl ();
use Perl::MinimumVersion   'PMV';

# Define prototypes
sub verbose        ($);
sub message        ($);
sub error          (@);
sub format_version ($);
sub dist           ($);

use vars qw{$VERBOSE $BLAME $EXPLAIN};
BEGIN {

	# Configuration globals
	$VERBOSE = '';
	$BLAME   = '';
	$EXPLAIN = '';

	# Unbuffer output
	$| = 1;
}





#####################################################################
# Configuration

GetOptions(
	verbose => \$VERBOSE,
	blame   => \$BLAME,
	explain => \$EXPLAIN,
);

# Get the target
my $target = shift @ARGV;
unless ( $target ) {
	error("You did not provide a file or directory to check");
}

print "\n";
if ( $BLAME ) {
	blame($target);
} else {
	summary($target);
}

exit(0);





#####################################################################
# Regular Mode

sub summary {
	my $target = shift;
	my @files  = ();
	if ( -d $target ) {
		verbose "Found directory '$target'\n";
		verbose "Searching for Perl files... ";
		@files = find($target);
		verbose "found " . scalar(@files) . " file(s)\n";
	} elsif ( -f $target ) {
		verbose "Found file '$target'\n";
		@files = $target;
	} else {
		error "File or directory '$target' does not exist";
	}

	# Scan the files
	verbose "Processing files...\n";
	my @results  = ();
	my $file_len = 12 + List::Util::max map { length $_ } @files;
	foreach my $file ( @files ) {
		# Set up the results data
		verbose sprintf("%-${file_len}s", "Scanning $file...");
		my $result  = [ $file, undef, undef ];
		push @results, $result;

		# Load the document standalone first so we store the file name
		my $document = PPI::Document::File->new(
			$file,
			readonly => 1,
		);
		unless ( $document ) {
			verbose "[error]\n";
			next;
		}

		# Create the version checker
		my $pmv = PMV->new( $document );
		unless ( $pmv ) {
			verbose "[error]\n";
			next;
		}

		# Check the explicit version
		$result->[1] = $pmv->minimum_explicit_version;

		# Check the syntax version
		$result->[2] = $pmv->minimum_syntax_version;

		$result->[4] = $pmv->{syntax_check_failed} if exists $pmv->{syntax_check_failed};

		verbose "[ok]\n";
	}

	# Calculate the minimum explicit, syntax and total versions
	verbose "Compiling results...\n";
	my $pmv_explicit = PMV->_max( map { $_->[1] } @results   );
	my $pmv_syntax   = PMV->_max( map { $_->[2] } @results   );
	my $pmv_bug      = !! ($pmv_explicit and $pmv_syntax and $pmv_syntax > $pmv_explicit);
	my $pmv_total    = PMV->_max( $pmv_explicit, $pmv_syntax );

	# Generate the output values
	my @outputs = ( [ 'file', 'explicit', 'syntax', 'external' ] );
	foreach my $result ( @results ) {
		my $output = [];
		$output->[0] = $result->[0];
		$output->[1] = format_version($result->[1]);
		$output->[2] = format_version($result->[2]);
		# $output->[3] = format_version($result->[3]);
		$output->[3] = 'n/a';
		$output->[4] = $result->[4] || '' if ($EXPLAIN);
		push @outputs, $output;
	}

	# Complete the output preperation work
	$pmv_explicit     = format_version( $pmv_explicit );
	$pmv_syntax       = format_version( $pmv_syntax   );
	$pmv_total        = format_version( $pmv_total    );
	if ( $pmv_total eq '~' ) {
		$pmv_total = format_version( qv(5.004) ) . ' (default)';
	}
	my $len0          = List::Util::max map { length $_->[0] } @outputs;
	my $len1          = List::Util::max map { length $_->[1] } @outputs;
	my $len2          = List::Util::max map { length $_->[2] } @outputs;
	my $len3          = List::Util::max map { length $_->[3] } @outputs;
	my $len_all       = $len0 + $len1 + $len2 + $len3 + 9;
	my $len_totals    = $len1 + $len2 + $len3 + 6;
	my $line_format   = " | %-${len0}s | %-${len1}s | %-${len2}s | %-${len3}s |\n";
	if ($EXPLAIN) {
	  chomp($line_format);
	  $line_format.="  (%s)\n";
	}
	my $spacer        = '-' x $len_all;
	my $error_message = "ERROR DETECTED : ACTUAL DEPENDENCY HIGHER THAN SPECIFIED";
	my $error_length  = length $error_message;
	if ( $error_length > $len_all ) {
		my $diff = $error_length - $len_all;
		$len_all += $diff;
		$len0    += $diff;
	}

	# Prepare formatting parts
	my $divider = " | $spacer |\n";
	my $capline = "   $spacer  \n";
	my $rowline = " | %-${len_all}s |\n";

	# Print the results
	print "\n";
	print $capline;
	printf( $line_format, @{shift(@outputs)} );
	print $divider;
	foreach my $result ( @outputs ) {
		printf( $line_format, @$result );
	}
	print $divider;
	printf( $rowline, "Minimum explicit version : $pmv_explicit" );
	printf( $rowline, "Minimum syntax version   : $pmv_syntax"   );
	printf( $rowline, "Minimum version of perl  : $pmv_total"    );
	if ( $pmv_bug ) {
		print $divider;
		printf( $rowline, "ERROR   : ACTUAL DEPENDENCY HIGHER THAN SPECIFIED" );
		printf( $rowline, "DETAILS : perlver --blame $target" );
	}
	print $capline;
	print "\n";
}

sub blame {
	my $target = shift;
	my @files  = ();
	if ( -d $target ) {
		verbose "Found directory '$target'\n";
		verbose "Searching for Perl files... ";
		@files = find($target);
		verbose "found " . scalar(@files) . " file(s)\n";
	} elsif ( -f $target ) {
		verbose "Found file '$target'\n";
		@files = $target;
	} else {
		error "File or directory '$target' does not exist";
	}

	# Scan the files
	verbose "Processing files...\n";
	my $maximum  = undef;
	my $blame    = undef;
	my $file_len = 12 + List::Util::max map { length $_ } @files;
	my $max      = undef;
	my $maxpmv   = undef;
	foreach my $file ( @files ) {
		# Set up the results data
		verbose sprintf("%-${file_len}s", "Scanning $file...");

		# Load the document standalone first so we store the file name
		my $document = PPI::Document::File->new(
			$file,
			readonly => 1,
		);
		unless ( $document ) {
			verbose "[error]\n";
			next;
		}

		# Create the version checker
		my $pmv = PMV->new( $document );
		unless ( $pmv ) {
			verbose "[error]\n";
			next;
		}

		# Check the syntax version
		my $reason = $pmv->minimum_syntax_reason( $max ? $max->version : undef );
		if ( $reason ) {
			verbose $reason->version . "\n";
		} else {
			verbose "~\n";
			next;
		}

		# Handle the first successful case
		if ( ! $max or $reason->version > $max->version ) {
			$max    = $reason;
			$maxpmv = $pmv;
			next;
		}
	}

	# Anything?
	unless ( $max ) {
		print "Nothing obvious to blame\n";
		exit(0);
	}

	# Index and prepare
	my $element  = $max->element or die "Reason element unknown";
	my $document = $element->top or die "Reason document unknown";
	$document->index_locations;

	# Generate the location message
	my $file    = $document->filename;
	my $line    = $element->line_number;
	my $char    = $element->column_number;
	my $content = $element->content;
	my $rule    = $max->rule;
	my $version = $max->version;
	print " ------------------------------------------------------------\n";
	print " File    : $file\n";
	print " Line    : $line\n";
	print " Char    : $char\n";
	print " Rule    : $rule\n";
	print " Version : $version\n";
	print " ------------------------------------------------------------\n";
	print " $content\n";
	print " ------------------------------------------------------------\n";
}

sub find {
	my $dir   = shift;
	my $perl  = File::Find::Rule->perl_file;
	my $build = File::Find::Rule->name('blib', '_build')->directory;
	return dist($dir)
		? File::Find::Rule->any(
				$build->prune->discard,
				$perl,
		  )->in( $dir )
		: $perl->in( $dir );
}





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

sub verbose ($) {
	return 1 unless $VERBOSE;
	print ' ' . $_[0];
}

sub message ($) {
	print ' ' . $_[0];
}

sub error (@) {
	print ' ' . join '', map { "$_\n" } ('', @_, '');
	exit(255);
}

sub format_version ($) {
	my $version = shift;
	if ( _INSTANCE($version, 'Perl::MinimumVersion::Reason') ) {
		$version = $version->version->normal;
	} elsif ( _INSTANCE($version, 'version') ) {
		return $version->normal;
	} elsif ( $version ) {
		return "$version";
	} elsif ( defined $version ) {
		return '~';
	} else {
		return 'undef';
	}
}

sub format_reason ($) {
	my $reason = shift;

	# Index the document of the worse offender
	my $element  = $reason->element;
	my $document = $element->top;
	$document->index_locations;

	$DB::single = 1;

	1;
}

sub dist ($) {
	my $dir = shift;
	if ( -f File::Spec->catfile($dir, 'Makefile.PL') ) {
		return 1;
	}
	if ( -f File::Spec->catfile($dir, 'Build.PL') ) {
		return 1;
	}
	return '';
}

=pod

=head1 TO DO

- Add PPI::Cache integration

- Add PPI::Metrics integration (once it exists)

- Add some sort of parseable output

=head1 SUPPORT

All bugs should be filed via the bug tracker at

L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Perl-MinimumVersion>

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

=head1 AUTHORS

Adam Kennedy <adamk@cpan.org>

=head1 SEE ALSO

L<PPI>, L<Perl::MinimumVersion>

=head1 COPYRIGHT

Copyright 2005 - 2012 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