CPAN-PackageDetails

 view release on metacpan or  search on metacpan

lib/CPAN/PackageDetails.pm  view on Meta::CPAN

	1. That there are entries in the file
	2. The number of entries matches those declared in the Line-Count header
	3. All paths listed in the file exist under CPAN_PATH
	4. All distributions under CPAN_PATH have an entry (not counting older versions)

If any of these checks fail, C<check_file> croaks with a hash reference
with these keys:

	# present in every error object
	filename                the FILE you passed in
	cpan_path               the CPAN_PATH you passed in
	cwd                     the current working directory
	error_count

	# if FILE is missing
	missing_file          exists and true if FILE doesn't exist

	# if the entry count in the file is wrong
	# that is, the actual line count and header disagree
	entry_count_mismatch    true
	line_count              the line count declared in the header

lib/CPAN/PackageDetails.pm  view on Meta::CPAN

	# if some entries in FILE are missing the file in CPAN_HOME
	missing_in_repo         anonymous array of missing paths

=cut

sub ENTRY_COUNT_MISMATCH () { 1 }
sub MISSING_IN_REPO      () { 2 }
sub MISSING_IN_FILE      () { 3 }

sub check_file {
	my( $either, $file, $cpan_path ) = @_;

	# works with a class or an instance. We have to create a new
	# instance, so we need the class. However, I'm concerned about
	# subclasses, so if the higher level application just has the
	# object, and maybe from a class I don't know about, they should
	# be able to call this method and have it end up here if they
	# didn't override it. That is, don't encourage them to hard code
	# a class name
	my $class = ref $either || $either;

	# file exists
	my $error = {
		error_count => 0,
		cpan_path   => $cpan_path,
		filename    => $file,
		cwd         => cwd(),
		};
	unless( -e $file ) {
		$error->{missing_file}         = 1;
		$error->{error_count}         +=  1;
		}

	# file is gzipped

lib/CPAN/PackageDetails.pm  view on Meta::CPAN

		$error->{error_count}         +=  1;
		}

	unless( $header_count == $entries_count ) {
		$error->{entry_count_mismatch} = 1;
		$error->{line_count}           = $header_count;
		$error->{entry_count}          = $entries_count;
		$error->{error_count}         +=  1;
		}

	if( $cpan_path ) {
		my $missing_in_file = $packages->check_for_missing_dists_in_file( $cpan_path );
		my $missing_in_repo = $packages->check_for_missing_dists_in_repo( $cpan_path );

		$error->{missing_in_file}  =  $missing_in_file if @$missing_in_file;
		$error->{missing_in_repo}  =  $missing_in_repo if @$missing_in_repo;
		$error->{error_count}     += @$missing_in_file  + @$missing_in_repo;
		}

	croak $error if $error->{error_count};

	return 1;
	}

lib/CPAN/PackageDetails.pm  view on Meta::CPAN

Given an object and a CPAN_PATH, return an anonymous array of the
distributions in the object that are not in CPAN_PATH. That is,
complain when the object has extra distributions.

C<check_file> calls this for you and adds the result to its
error output.

=cut

sub check_for_missing_dists_in_repo {
	my( $packages, $cpan_path ) = @_;

	my @missing;
	my( $entries ) = $packages->as_unique_sorted_list;
	foreach my $entry ( @$entries ) {
		my $path = $entry->path;

		my $native_path = catfile( $cpan_path, split m|/|, $path );

		push @missing, $path unless -e $native_path;
		}

	return \@missing;
	}

=item check_for_missing_dists_in_file( CPAN_PATH )

Given an object and a CPAN_PATH, return an anonymous array of the
distributions in CPAN_PATH that do not show up in the object. That is,
complain when the object doesn't have all the dists.

C<check_file> calls this for you and adds the result to its
error output.

=cut

sub check_for_missing_dists_in_file {
	my( $packages, $cpan_path ) = @_;

	my $dists = $packages->_get_repo_dists( $cpan_path );

	$packages->_filter_older_dists( $dists );

	my %files = map { $_, 1 } @$dists;
	use Data::Dumper;

	my( $entries ) = $packages->as_unique_sorted_list;

	foreach my $entry ( @$entries ) {
		my $path = $entry->path;
		my $native_path = catfile( $cpan_path, split m|/|, $path );
		delete $files{$native_path};
		}

	[ keys %files ];
	}

sub _filter_older_dists {
	my( $self, $array ) = @_;

	my %Seen;

t/check_file.t  view on Meta::CPAN

my $method = 'check_file';

use_ok( $class );
can_ok( $class, $method );

my @files =  map { [ $_, 1 ] } glob( catfile( qw( corpus good *.gz ) ) );
push @files, map { [ $_, 0 ] } glob( catfile( qw( corpus bad *.gz )  ) );

diag( "Going to test " . @files . " files" ) if $ENV{DEBUG};

my $cpan_path = catfile( qw(corpus cpan) );

use Carp;
use Data::Dumper;
foreach my $pair ( @files ) {
	my( $file, $expected ) = @$pair;

	my $result = eval { $class->$method( $file, $cpan_path ) };
	my $at = $@;
	diag( "\n$file had an error: [", Dumper($at), "\n" ) if $ENV{DEBUG};

	is( !! $result, !! $expected,
		$expected ?
			"The good 02packages.details.gz [$file] checks out!"
				:
			"The bad 02packages.details.gz [$file] doesn't check out!"
		);