1package Parse::CPAN::Packages; 2use Moo; 3use CPAN::DistnameInfo; 4use Compress::Zlib; 5use Path::Class (); 6use File::Slurp 'read_file'; 7use Parse::CPAN::Packages::Distribution; 8use Parse::CPAN::Packages::Package; 9use Types::Standard qw( HashRef Maybe Str ); 10use version; 11our $VERSION = '2.40'; 12 13has 'filename' => ( is => 'rw', isa => Str ); 14has 'mirror_dir' => ( is => 'lazy', isa => Maybe [Str] ); 15 16has 'details' => ( is => 'rw', isa => HashRef, default => sub { {} } ); 17has 'data' => ( is => 'rw', isa => HashRef, default => sub { {} } ); 18has 'dists' => ( is => 'rw', isa => HashRef, default => sub { {} } ); 19has 'latestdists' => ( is => 'rw', isa => HashRef, default => sub { {} } ); 20 21sub BUILDARGS { 22 my ( $class, @args ) = @_; 23 return {@args} if @args > 1; 24 return { filename => $args[0] }; 25} 26 27sub BUILD { 28 my $self = shift; 29 my $filename = $self->filename; 30 31 # read the file then parse it if present 32 $self->parse( $filename ) if $filename; 33 34 return $self; 35} 36 37sub _build_mirror_dir { 38 my ( $self ) = @_; 39 return if $self->filename =~ /\n/; 40 return if !-f $self->filename; 41 my $dir = Path::Class::file( $self->filename )->dir->parent; 42 return $dir->stringify; 43} 44 45# read the file into memory and return it 46sub _slurp_details { 47 my ( $self, $filename ) = @_; 48 $filename ||= '02packages.details.txt.gz'; 49 50 return $filename if $filename =~ /Description:/; 51 return Compress::Zlib::memGunzip( $filename ) if $filename =~ /^\037\213/; 52 53 my @read_params = ( $filename ); 54 push @read_params, ( binmode => ':raw' ) if $filename =~ /\.gz/; 55 56 my $data = read_file( @read_params ); 57 58 return Compress::Zlib::memGunzip( $data ) if $filename =~ /\.gz/; 59 return $data; 60} 61 62for my $subname ( qw(file url description columns intended_for written_by line_count last_updated) ) { 63 no strict 'refs'; 64 *{$subname} = sub { return shift->{preamble}{$subname} }; 65} 66 67sub parse { 68 my ( $self, $filename ) = @_; 69 70 # read the preamble 71 my @details = split "\n", $self->_slurp_details( $filename ); 72 while ( @details ) { 73 local $_ = shift @details; 74 last if /^\s*$/; 75 next unless /^([^:]+):\s*(.*)/; 76 my ( $key, $value ) = ( lc( $1 ), $2 ); 77 $key =~ tr/-/_/; 78 $self->{preamble}{$key} = $value; 79 } 80 81 # run though each line of the file 82 for my $line ( @details ) { 83 84 # make a package object from the line 85 my ( $package_name, $package_version, $prefix ) = split ' ', $line; 86 $self->add_quick( $package_name, $package_version, $prefix ); 87 } 88} 89 90sub add_quick { 91 my ( $self, $package_name, $package_version, $prefix ) = @_; 92 93 # create a distribution object (or get an existing one) 94 my $dist = $self->distribution_from_prefix( $prefix ); 95 96 # create the package object 97 my $m = Parse::CPAN::Packages::Package->new( 98 { 99 package => $package_name, 100 version => $package_version, 101 distribution => $dist 102 } 103 ); 104 105 # make the package have the distribion and the distribution 106 # have the package. Yes, this creates a cirtular reference. eek! 107 $dist->add_package( $m ); 108 109 # record this distribution and package 110 $self->add_distribution( $dist ); 111 $self->add_package( $m ); 112} 113 114sub distribution_from_prefix { 115 my ( $self, $prefix ) = @_; 116 117 # see if we have one of these already and return it if we do. 118 my $d = $self->distribution( $prefix ); 119 return $d if $d; 120 121 # create a new one otherwise 122 my $i = CPAN::DistnameInfo->new( $prefix ); 123 $d = Parse::CPAN::Packages::Distribution->new( 124 { 125 prefix => $prefix, 126 dist => $i->dist, 127 version => $i->version, 128 maturity => $i->maturity, 129 filename => $i->filename, 130 cpanid => $i->cpanid, 131 distvname => $i->distvname, 132 mirror_dir => $self->mirror_dir, 133 } 134 ); 135 return $d; 136} 137 138sub add_package { 139 my ( $self, $package ) = @_; 140 141 # store it 142 $self->data->{ $package->package } = $package; 143 144 return $self; 145} 146 147sub package { 148 my ( $self, $package_name ) = @_; 149 return $self->data->{$package_name}; 150} 151 152sub packages { 153 my $self = shift; 154 return values %{ $self->data }; 155} 156 157sub add_distribution { 158 my ( $self, $dist ) = @_; 159 160 $self->_store_distribution( $dist ); 161 $self->_ensure_latest_distribution( $dist ); 162} 163 164sub _store_distribution { 165 my ( $self, $dist ) = @_; 166 167 $self->dists->{ $dist->prefix } = $dist; 168} 169 170sub _ensure_latest_distribution { 171 my ( $self, $new ) = @_; 172 173 my $latest = $self->latest_distribution( $new->dist ); 174 if ( !$latest ) { 175 $self->_set_latest_distribution( $new ); 176 return; 177 } 178 my $new_version = $new->version; 179 my $latest_version = $latest->version; 180 my ( $newv, $latestv ); 181 182 eval { 183 no warnings; 184 $newv = version->new( $new_version || 0 ); 185 $latestv = version->new( $latest_version || 0 ); 186 }; 187 188 $self->_set_latest_distribution( $new ) if $self->_dist_is_latest( $newv, $latestv, $new_version, $latest_version ); 189 190 return; 191} 192 193sub _dist_is_latest { 194 my ( $self, $newv, $latestv, $new_version, $latest_version ) = @_; 195 return 1 if $newv && $latestv && $newv > $latestv; 196 no warnings; 197 return 1 if $new_version > $latest_version; 198 return 0; 199} 200 201sub distribution { 202 my ( $self, $dist ) = @_; 203 return $self->dists->{$dist}; 204} 205 206sub distributions { 207 my $self = shift; 208 return values %{ $self->dists }; 209} 210 211sub _set_latest_distribution { 212 my ( $self, $dist ) = @_; 213 return unless $dist->dist; 214 $self->latestdists->{ $dist->dist } = $dist; 215} 216 217sub latest_distribution { 218 my ( $self, $dist ) = @_; 219 return unless $dist; 220 return $self->latestdists->{$dist}; 221} 222 223sub latest_distributions { 224 my $self = shift; 225 return values %{ $self->latestdists }; 226} 227 228sub package_count { 229 my $self = shift; 230 return scalar scalar $self->packages; 231} 232 233sub distribution_count { 234 my $self = shift; 235 return scalar $self->distributions; 236} 237 238sub latest_distribution_count { 239 my $self = shift; 240 return scalar $self->latest_distributions; 241} 242 2431; 244 245__END__ 246 247=head1 NAME 248 249Parse::CPAN::Packages - Parse 02packages.details.txt.gz 250 251=head1 SYNOPSIS 252 253 use Parse::CPAN::Packages; 254 255 # must have downloaded 256 my $p = Parse::CPAN::Packages->new("02packages.details.txt.gz"); 257 # either a filename as above or pass in the contents of the file 258 # (uncompressed) 259 my $p = Parse::CPAN::Packages->new($packages_details_contents); 260 261 my $m = $p->package("Acme::Colour"); 262 # $m is a Parse::CPAN::Packages::Package object 263 print $m->package, "\n"; # Acme::Colour 264 print $m->version, "\n"; # 1.00 265 266 my $d = $m->distribution(); 267 # $d is a Parse::CPAN::Packages::Distribution object 268 print $d->prefix, "\n"; # L/LB/LBROCARD/Acme-Colour-1.00.tar.gz 269 print $d->dist, "\n"; # Acme-Colour 270 print $d->version, "\n"; # 1.00 271 print $d->maturity, "\n"; # released 272 print $d->filename, "\n"; # Acme-Colour-1.00.tar.gz 273 print $d->cpanid, "\n"; # LBROCARD 274 print $d->distvname, "\n"; # Acme-Colour-1.00 275 276 # all the package objects 277 my @packages = $p->packages; 278 279 # all the distribution objects 280 my @distributions = $p->distributions; 281 282 # the latest distribution 283 $d = $p->latest_distribution("Acme-Colour"); 284 is($d->prefix, "L/LB/LBROCARD/Acme-Colour-1.00.tar.gz"); 285 is($d->version, "1.00"); 286 287 # all the latest distributions 288 my @distributions = $p->latest_distributions; 289 290=head1 DESCRIPTION 291 292The Comprehensive Perl Archive Network (CPAN) is a very useful 293collection of Perl code. It has several indices of the files that it 294hosts, including a file named "02packages.details.txt.gz" in the 295"modules" directory. This file contains lots of useful information and 296this module provides a simple interface to the data contained within. 297 298In a future release L<Parse::CPAN::Packages::Package> and 299L<Parse::CPAN::Packages::Distribution> might have more information. 300 301=head2 Methods 302 303=over 304 305=item new 306 307Creates a new instance from a details file. 308 309The constructor can be passed either the path to the 310C<02packages.details.txt.gz> file, a path to an ungzipped version of 311this file, or a scalar containing the entire uncompressed contents of 312the file. 313 314Note that this module does not concern itself with downloading this 315file. You should do this yourself. For example: 316 317 use LWP::Simple qw(get); 318 my $data = get("http://www.cpan.org/modules/02packages.details.txt.gz"); 319 my $p = Parse::CPAN::Packages->new($data); 320 321If you have a configured L<CPAN>, then there's usually already a 322cached file available: 323 324 use CPAN; 325 $CPAN::Be_Silent = 1; 326 CPAN::HandleConfig->load; 327 my $file = $CPAN::Config->{keep_source_where} . "/modules/02packages.details.txt.gz"; 328 my $p = Parse::CPAN::Packages->new($file); 329 330=item package($packagename) 331 332Returns a C<Parse::CPAN::Packages::Package> that represents the 333named package. 334 335 my $p = Parse::CPAN::Packages->new($gzfilename); 336 my $package = $p->package("Acme::Colour"); 337 338=item packages() 339 340Returns a list of B<Parse::CPAN::Packages::Package> objects 341representing all the packages that were extracted from the file. 342 343=item package_count() 344 345Returns the number of packages stored. 346 347=item distribution($filename) 348 349Returns a B<Parse::CPAN::Packages::Distribution> object that 350represents the filename passed: 351 352 my $p = Parse::CPAN::Packages->new($gzfilename); 353 my $dist = $p->distribution('L/LB/LBROCARD/Acme-Colour-1.00.tar.gz'); 354 355=item distributions() 356 357Returns a list of B<Parse::CPAN::Packages::Distribution> objects 358representing all the known distributions. 359 360=item distribution_count() 361 362Returns the number of distributions stored. 363 364=item latest_distribution($distname) 365 366Returns the C<Parse::CPAN::Packages::Distribution> object that 367represents the latest distribution for the named disribution passed, 368that is to say it returns the distribution that has the highest 369version number (as determined by version.pm or number comparison if 370that fails): 371 372 my $p = Parse::CPAN::Packages->new($gzfilename); 373 my $dist = $p->distribution('Acme-Color'); 374 375=item latest_distrbutions() 376 377Returns a list of B<Parse::CPAN::Packages::Distribution> objects 378representing all the latest distributions. 379 380=item latest_distribution_count() 381 382Returns the number of distributions stored. 383 384=back 385 386=head2 Preamble Methods 387 388These methods return the information from the preamble 389at the start of the file. They return undef if for any reason 390no matching preamble line was found. 391 392=over 393 394=item file() 395 396=item url() 397 398=item description() 399 400=item columns() 401 402=item intended_for() 403 404=item written_by() 405 406=item line_count() 407 408=item last_updated() 409 410=back 411 412=head2 Addtional Methods 413 414These are additional methods that you may find useful. 415 416=over 417 418=item parse($filename) 419 420Parses the filename. Works in a similar fashion to the the 421constructor (i.e. you can pass it a filename for a 422compressed/1uncompressed file, a uncompressed scalar containing the 423file. You can also pass nothing to indicate to load the compressed 424file from the current working directory.) 425 426Note that each time this function is run the packages and distribtions 427found will be C<added> to the current list of packages. 428 429=item add_quick($package_name, $package_version, $prefix) 430 431Quick way of adding a new package and distribution. 432 433=item add_package($package_obj) 434 435Adds a package. Note that you'll probably want to add the 436corrisponding distribution for that package too (it's not done 437automatically.) 438 439=item add_distribution($distribution_obj) 440 441Adds a distribution. Note that you'll probably want to add the 442corresponding packages for that distribution too (it's not done 443automatically.) 444 445=item distribution_from_prefix($prefix) 446 447Returns a distribution given a prefix. 448 449=item latest_distributions 450 451Returns all the latest distributions: 452 453 my @distributions = $p->latest_distributions; 454 455=cut 456 457=back 458 459=head1 AUTHOR 460 461Leon Brocard <acme@astray.com> 462 463=head1 COPYRIGHT 464 465Copyright (C) 2004-9, Leon Brocard 466 467=head1 LICENSE 468 469This module is free software; you can redistribute it or modify it under 470the same terms as Perl itself. 471 472=head1 BUGS 473 474This module leaks memory as packages hold distributions and 475distributions hold packages. No attempt has been made to fix this as 476it's not anticpated that this will be used in long running programs 477that will dispose of the objects once created. 478 479The old interface for C<new> where if you passed no arguments it would 480look for a C<02packages.details.txt.gz> in your current directory is 481no longer supported. 482 483=head1 TODO 484 485delete_* methods. merge_into method. Documentation for other modules. 486 487=head1 SEE ALSO 488 489L<CPAN::DistInfoname>, L<Parse::CPAN::Packages::Writer>. 490