view release on metacpan or  search on metacpan

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

C<write_file> carps and returns nothing if you pass it no arguments, if
it cannot open OUTPUT_FILE for writing, or if it cannot rename the file.

=cut

sub write_file {
	my( $self, $output_file ) = @_;

	unless( defined $output_file ) {
		carp "Missing argument!";
		return;
		}

	require IO::Compress::Gzip;

	my $fh = IO::Compress::Gzip->new( "$output_file.$$" ) or do {
		carp "Could not open $output_file.$$ for writing: $IO::Compress::Gzip::GzipError";
		return;
		};

	$self->write_fh( $fh );
	$fh->close;

	unless( rename "$output_file.$$", $output_file ) {
		carp "Could not rename temporary file to $output_file!\n";
		return;
		}

	return 1;
	}

=item write_fh( FILEHANDLE )

Formats the object as a string and writes it to FILEHANDLE

=cut

sub write_fh {
	my( $self, $fh ) = @_;

	print $fh $self->header->as_string, $self->entries->as_string;
	}

=item check_file( FILE, CPAN_PATH )

This method takes an existing F<02packages.details.txt.gz> named in FILE and
the CPAN root at CPAN_PATH (to append to the relative paths in the
index), then checks the file for several things:

	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
	entry_count             the actual count

	# if some distros in CPAN_HOME are missing in FILE
	missing_in_file         anonymous array of missing paths

	# 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

	# check header # # # # # # # # # # # # # # # # # # #
	my $packages = $class->read( $file );

	# count of entries in non-zero # # # # # # # # # # # # # # # # # # #

	my $header_count = $packages->get_header( 'line_count' );
	my $entries_count = $packages->count;

	unless( $header_count ) {
		$error->{entry_count_mismatch} = 1;
		$error->{line_count}           = $header_count;
		$error->{entry_count}          = $entries_count;
		$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;
	}



=item check_for_missing_dists_in_repo( CPAN_PATH )

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;
	my @order;
	require  CPAN::DistnameInfo;
	foreach my $path ( @$array ) {
		my( $basename, $directory, $suffix ) = fileparse( $path, qw(.tar.gz .tgz .zip .tar.bz2) );
		my( $name, $version, $developer ) = CPAN::DistnameInfo::distname_info( $basename );
		my $tuple = [ $path, $name, $version ];
		push @order, $name;

		   # first branch, haven't seen the distro yet
		   if( ! exists $Seen{ $name } )        { $Seen{ $name } = $tuple }
		   # second branch, the version we see now is greater than before
		elsif( $Seen{ $name }[2] lt $version )  { $Seen{ $name } = $tuple }
		   # third branch, nothing. Really? Are you sure there's not another case?
		else                                   { () }
		}

	@$array = map {
		if( exists $Seen{$_} ) {
			my $dist = $Seen{$_}[0];
			delete $Seen{$_};
			$dist;
			}
		else {
			()
			}
		} @order;

	return 1;
	}


sub _distname_info {
	my $file = shift or return;

	my ($dist, $version) = $file =~ /^
		(                          # start of dist name
			(?:
				[-+.]*

				(?:
					[A-Za-z0-9]+
						|
					(?<=\D)_
						|
					_(?=\D)
				)*

	 			(?:
					[A-Za-z]
					(?=