lib/Packaging/Tools.pm

   1 package Packaging::Tools;
   2
   3 use 5.008;
   4 use strict;
   5 use warnings;
   6 use version;
   7
   8 use Carp qw/croak/;
   9
  10 use CPAN;
  11 use CPAN::DistnameInfo;
  12 use Module::CoreList;
  13
  14 require File::Basename;
  15 require File::ShareDir;
  16 require File::Find::Rule;
  17 require File::Spec;
  18
  19 use Moo;
  20 use namespace::clean;
  21
  22 =head1 NAME
  23
  24 Packaging::Tools - Support tools packagers packaging Perl 5 modules
  25
  26 =cut
  27
  28 our $VERSION = '0.001';
  29
  30 use constant {
  31                STATE_OK                 => 0,
  32                STATE_NEWER_IN_CPAN      => 1,
  33                STATE_NEWER_IN_CORE      => 2,
  34                STATE_OUT_OF_SYNC        => 3,
  35                STATE_REMOVED_FROM_INDEX => 4,
  36                STATE_ERROR              => 101,
  37              };
  38
  39 my @state_remarks;
  40 $state_remarks[STATE_OK]                 = 'fine';
  41 $state_remarks[STATE_NEWER_IN_CPAN]      = 'needs update';
  42 $state_remarks[STATE_NEWER_IN_CORE]      = 'newer in Core';
  43 $state_remarks[STATE_OUT_OF_SYNC]        = 'out of sync';
  44 $state_remarks[STATE_REMOVED_FROM_INDEX] = 'not in CPAN index';
  45 $state_remarks[STATE_ERROR]              = '';
  46
  47 my @state_cmpops;
  48 $state_cmpops[STATE_OK]            = '==';
  49 $state_cmpops[STATE_NEWER_IN_CPAN] = '<';
  50 $state_cmpops[STATE_OUT_OF_SYNC]   = '!=';
  51
  52 =head1 SYNOPSIS
  53
  54 =head1 SUBROUTINES/METHODS
  55
  56 =head2 new($dist_type,\%args)
  57
  58 Instantiates new Packaging::Tools instance and connects to a
  59 Packaging::Tools::Plugin::$dist_type instance.
  60
  61 The plugin is installed with \%args as parameters.
  62
  63 =cut
  64
  65 sub new
  66 {
  67     my ( $class, $dist_type, $args ) = @_;
  68
  69     eval "require Packaging::Tools::Plugin::$dist_type" or die $@;
  70
  71     my $dist_type_class = "Packaging::Tools::Plugin::$dist_type";
  72
  73     my $self = bless( {}, $class );
  74     $self->{_dist_tools} = $dist_type_class->new($args);
  75     $self->{_pkg_dist}   = $dist_type;
  76
  77     return $self;
  78 }
  79
  80 =head2 get_state_remarks
  81
  82 Return the list of the remarks for the known states.
  83
  84 See the example templates how to use it.
  85
  86 =cut
  87
  88 sub get_state_remarks { return @state_remarks; }
  89
  90 =head2 get_state_cmpops
  91
  92 Return the list of compare operations for the known states (e.g. "<" for
  93 STATE_NEWER_IN_CPAN).
  94
  95 See the example templates how to use it.
  96
  97 =cut
  98
  99 sub get_state_cmpops { return @state_cmpops; }
 100
 101 =head2 get_template_directories(;$tool)
 102
 103 Returns the directories containing the templates, either in general or for
 104 specific tools.
 105
 106 =cut
 107
 108 sub get_template_directories
 109 {
 110     my ( $self, $tool ) = @_;
 111
 112     my @tt_src_dirs = (
 113                         File::ShareDir::dist_dir("Packaging-Tools"),
 114                         $self->{_dist_tools}->get_template_directories()
 115                       );
 116
 117     $tool and return map { File::Spec->catdir( $_, $tool ) } @tt_src_dirs;
 118
 119     return @tt_src_dirs;
 120 }
 121
 122 =head2 find_templates(;$tool)
 123
 124 Find templates (full qualified path name) for processing, either in general
 125 or for specific tools.
 126
 127 =cut
 128
 129 sub find_templates
 130 {
 131     my ( $self, $tool ) = @_;
 132
 133     $tool //= File::Basename::fileparse( $0, qr/\.[^.]*/ );
 134
 135     my @tt_src_dirs = $self->get_template_directories($tool);
 136     my @templates   = File::Find::Rule->file()->name("*.tt2")->maxdepth(1)->in(@tt_src_dirs);
 137
 138     return @templates;
 139 }
 140
 141 =head2 load_cpan_config(;$cpan_home)
 142
 143 Loads the CPAN config. If a I<$cpan_home> is given and the is a
 144 C<CPAN/MyConfig.pm> in there, this file is loaded. If a I<$cpan_home>
 145 is given without a C<CPAN/MyConfig.pm> in there, I<$CPAN::Config{cpan_home}>
 146 is set to given I<$cpan_home>. Otherwise, only CPAN::HandleConfig->load()
 147 is called.
 148
 149 =cut
 150
 151 sub load_cpan_config
 152 {
 153     my ( $self, $cpan_home ) = @_;
 154
 155     if ( defined($cpan_home) and -e File::Spec->catfile( $cpan_home, 'CPAN', 'MyConfig.pm' ) )
 156     {
 157         my $file = File::Spec->catfile( $cpan_home, 'CPAN', 'MyConfig.pm' );
 158
 159         # XXX taken from App:Cpan::_load_config()
 160         $CPAN::Config = {};
 161         delete $INC{'CPAN/Config.pm'};
 162
 163         my $rc = eval { require $file };
 164         my $err_myconfig = $@;
 165         if ( $err_myconfig and $err_myconfig !~ m#locate \Q$file\E# )
 166         {
 167             croak "Error while requiring ${file}:\n$err_myconfig";
 168         }
 169         elsif ($err_myconfig)
 170         {
 171             CPAN::HandleConfig->load();
 172             defined( $INC{"CPAN/MyConfig.pm"} )
 173               and $CPAN::Config_loaded++;
 174             defined( $INC{"CPAN/Config.pm"} )
 175               and $CPAN::Config_loaded++;
 176         }
 177         else
 178         {
 179             # CPAN::HandleConfig::require_myconfig_or_config looks for this
 180             $INC{'CPAN/MyConfig.pm'} = 'fake out!';
 181
 182             # CPAN::HandleConfig::load looks for this
 183             $CPAN::Config_loaded = 'fake out';
 184         }
 185     }
 186     else
 187     {
 188         CPAN::HandleConfig->load();
 189         defined( $INC{"CPAN/MyConfig.pm"} )
 190           and $CPAN::Config_loaded++;
 191         defined( $INC{"CPAN/Config.pm"} )
 192           and $CPAN::Config_loaded++;
 193         defined($cpan_home)
 194           and -d $cpan_home
 195           and $CPAN::Config{cpan_home} = $cpan_home;
 196     }
 197
 198     $CPAN::Config_loaded
 199       or croak("Can't load CPAN::Config - please setup CPAN first");
 200 }
 201
 202 =head2 get_cpan_versions(;$update_index)
 203
 204 (Re-)Loads the CPAN Index. When I<$update_index> is given and true, a newer
 205 index is tried to fetch from configured mirror sites.
 206
 207 =cut
 208
 209 sub get_cpan_versions
 210 {
 211     my ( $self, $update_idx ) = @_;
 212
 213     defined( $self->{cpan_idx} ) and !$update_idx and return %{ $self->{cpan_idx} };
 214     $CPAN::Config_loaded or $self->load_cpan_config();
 215
 216     $self->{cpan_idx} = {};
 217
 218     defined($update_idx)
 219       and $update_idx
 220       and $CPAN::Index::LAST_TIME = 0;
 221     CPAN::Index->reload( defined($update_idx) and $update_idx );
 222     $CPAN::Index::LAST_TIME
 223       or carp("Can't reload CPAN Index");
 224
 225     my @all_dists = $CPAN::META->all_objects("CPAN::Distribution");
 226
 227     foreach my $dist (@all_dists)
 228     {
 229         my $dinfo = CPAN::DistnameInfo->new( $dist->id() );
 230         my ( $distname, $distver ) = ( $dinfo->dist(), $dinfo->version() );
 231         defined($distname) or next;
 232         defined($distver)  or next;
 233         if (
 234              !defined( $self->{cpan_idx}->{$distname} )
 235              || ( defined( $self->{cpan_idx}->{$distname} )
 236                   && _is_gt( $distver, $self->{cpan_idx}->{$distname} ) )
 237            )
 238         {
 239             $self->{cpan_idx}->{$distname} = $distver;
 240         }
 241     }
 242
 243     return;
 244 }
 245
 246 =head2 get_modules_by_distribution
 247
 248 Builds internal data structure of cpan available distributions
 249 from index of modules.
 250
 251 =cut
 252
 253 sub get_modules_by_distribution
 254 {
 255     my $self = shift;
 256
 257     defined( $self->{cpan_mods_by_dist} ) and return;
 258
 259     $self->get_cpan_versions();
 260
 261     my @all_modules = $CPAN::META->all_objects("CPAN::Module");
 262     my %modsbydist;
 263
 264     foreach my $module (@all_modules)
 265     {
 266         my $modname = $module->id();
 267         $module->cpan_version() or next;
 268         my $distfile = $module->cpan_file();
 269         my $dinfo    = CPAN::DistnameInfo->new($distfile);
 270         my ( $distname, $distver ) = ( $dinfo->dist(), $dinfo->version() );
 271         defined($distname) or next;
 272         defined($distver)  or next;
 273         $modsbydist{$distname} //= [];
 274         push( @{ $modsbydist{$distname} }, $modname );
 275     }
 276
 277     $self->{cpan_mods_by_dist} = \%modsbydist;
 278
 279     return;
 280 }
 281
 282 =head2 get_installed_packages
 283
 284 Returns hash of name =E<gt> version of installed packages.
 285
 286 =cut
 287
 288 sub get_installed_packages
 289 {
 290     my $self = $_[0];
 291
 292     defined( $self->{installed_packages} )
 293       and return %{ $self->{installed_packages} };
 294     $self->{installed_packages} = { $self->{_dist_tools}->get_installed_packages() };
 295
 296     return %{ $self->{installed_packages} };
 297 }
 298
 299 =head2 find_packaged_modules
 300
 301 Returns list of packaged perl modules. The list has no specific order.
 302
 303 =cut
 304
 305 sub find_packaged_modules
 306 {
 307     my $self = $_[0];
 308
 309     defined( $self->{packaged_modules} )
 310       and return keys %{ $self->{packaged_modules} };
 311     $self->{packaged_modules} = { map { $_ => 1 } $self->{_dist_tools}->find_packaged_modules() };
 312
 313     return keys %{ $self->{packaged_modules} };
 314 }
 315
 316 sub _is_gt
 317 {
 318     my $gt;
 319     defined( $_[0] ) and $_[0] =~ /^v/ and $_[1] !~ /^v/ and $_[1] = "v$_[1]";
 320     defined( $_[0] ) and $_[0] !~ /^v/ and $_[1] =~ /^v/ and $_[0] = "v$_[0]";
 321     eval { $gt = defined( $_[0] ) && ( version->parse( $_[0] ) > version->parse( $_[1] ) ); };
 322     if ($@)
 323     {
 324         $gt = defined( $_[0] ) && ( $_[0] gt $_[1] );
 325     }
 326     return $gt;
 327 }
 328
 329 sub _is_ne
 330 {
 331     my $ne;
 332     defined( $_[0] ) and $_[0] =~ /^v/ and $_[1] !~ /^v/ and $_[1] = "v$_[1]";
 333     defined( $_[0] ) and $_[0] !~ /^v/ and $_[1] =~ /^v/ and $_[0] = "v$_[0]";
 334     eval { $ne = defined( $_[0] )
 335           && ( version->parse( $_[0] ) != version->parse( $_[1] ) ); };
 336     if ($@)
 337     {
 338         $ne = defined( $_[0] ) && ( $_[0] ne $_[1] );
 339     }
 340     return $ne;
 341 }
 342
 343 =head2 get_pkg_details($pkg_ident,@var_names)
 344
 345 Returns package details.
 346
 347 =over 4
 348
 349 =item * I<$pkg_ident>
 350
 351 One value from the list of L</find_packaged_modules|packaged modules>.
 352
 353 =item * I<@var_names>
 354
 355 One from the variables the distribution tool plugin
 356 L<Packaging::Tools::Plugin/get_pkg_details($pkg_ident,@var_names)|provides>
 357 or any combination of:
 358
 359 =over 8
 360
 361 =item CPAN_VERSION
 362
 363 =item CPAN_NAME
 364
 365 =item CHECK_STATE
 366
 367 =item CHECK_COMMENT
 368
 369 =back
 370
 371 =back
 372
 373 =cut
 374
 375 sub get_pkg_details
 376 {
 377     my ( $self, $pkg_ident, @var_names ) = @_;
 378
 379     my @local_vars = grep { $_ =~ m/^(?:CPAN|CHECK)_/ } @var_names;
 380     my @pkg_vars = grep { !( $_ ~~ @local_vars ) } @var_names;
 381
 382     my %result;
 383     @result{@pkg_vars} = $self->{_dist_tools}->get_pkg_details( $pkg_ident, @pkg_vars );
 384
 385     unless ( defined( $self->{pkg_details}->{$pkg_ident} ) )
 386     {
 387         my $dist_name = $result{DIST_NAME}
 388           // $self->{_dist_tools}->get_pkg_details( $pkg_ident, 'DIST_NAME' );
 389         $self->{pkg_details}->{$pkg_ident}->{CPAN_VERSION} = $self->{cpan_idx}->{$dist_name};
 390         $self->{pkg_details}->{$pkg_ident}->{CPAN_NAME}    = $dist_name;
 391     }
 392
 393     @result{@local_vars} = @{ $self->{pkg_details}->{$pkg_ident} }{@local_vars};
 394
 395     return @result{@var_names};
 396 }
 397
 398 =head2 check_pkg_up2date_state($pkg_ident)
 399
 400 Returns the state of specified package.
 401
 402 Returned state is one of
 403
 404 =over 4
 405
 406 =item STATE_OK
 407
 408 Distribution package is up to date compared against fetched CPAN Index.
 409
 410 =item STATE_NEWER_IN_CPAN
 411
 412 There is a newer version of packaged distribution in CPAN.
 413
 414 =item STATE_NEWER_IN_CORE
 415
 416 There is a newer version of at least one module provided by the most recent
 417 package in the current used Perl Core.
 418
 419 =item STATE_REMOVED_FROM_INDEX
 420
 421 Cannot find distribution in CPAN Index, most likely the module was removed
 422 or never indexed for any reason.
 423
 424 =item STATE_OUT_OF_SYNC
 425
 426 The distribution packaged version is newer than newest one found in fetched
 427 CPAN Index, which can have either the same reason as for
 428 STATE_REMOVED_FROM_INDEX or the distribution is provided from somewhere else
 429 instead of CPAN.
 430
 431 =item STATE_ERROR
 432
 433 Error getting distribution information for specified package.
 434
 435 =back
 436
 437 =cut
 438
 439 sub check_pkg_up2date_state
 440 {
 441     my ( $self, $pkg_ident ) = @_;
 442
 443     defined( $self->{installed_packages} ) or $self->get_installed_packages();
 444     defined( $self->{cpan_mods_by_dist} )  or $self->get_modules_by_distribution();
 445
 446     my @pkg_det_keys = (qw(DIST_NAME DIST_VERSION PKG_VERSION CPAN_VERSION MASTER_SITES));
 447     my ( $dist_name, $dist_version, $pkg_version, $cpan_version, $master_sites ) =
 448       eval { $self->get_pkg_details( $pkg_ident, @pkg_det_keys ); };
 449
 450     if ( $@ or !defined($dist_name) or !defined($dist_version) )
 451     {
 452         $self->{pkg_details}->{$pkg_ident}->{CHECK_COMMENT} = 'Error getting distribution data';
 453         return $self->{pkg_details}->{$pkg_ident}->{CHECK_STATE} = STATE_ERROR;
 454     }
 455
 456     $dist_name eq 'perl'
 457       and return $self->{pkg_details}->{$pkg_ident}->{CHECK_STATE} = STATE_OK;
 458
 459     foreach my $distmod ( @{ $self->{cpan_mods_by_dist}->{$dist_name} } )
 460     {
 461         defined( $Module::CoreList::version{$]}->{$distmod} ) or next;
 462         my $mod = $CPAN::META->instance( "CPAN::Module", $distmod );
 463         if ( _is_gt( $Module::CoreList::version{$]}->{$distmod}, $mod->cpan_version() ) )
 464         {
 465             $self->{pkg_details}->{$pkg_ident}->{CORE_NEWER}->{$distmod} =
 466               [ $Module::CoreList::version{$]}->{$distmod}, $mod->cpan_version() ];
 467         }
 468     }
 469     if ( defined( $self->{pkg_details}->{$pkg_ident}->{CORE_NEWER} ) )
 470     {
 471         $self->{pkg_details}->{$pkg_ident}->{CHECK_COMMENT} =
 472           "$dist_name-$dist_version has newer modules in core: " . join(
 473             ", ",
 474             map {
 475                     $_ . " "
 476                   . $self->{pkg_details}->{$pkg_ident}->{CORE_NEWER}->{$_}->[0] . " > "
 477                   . $self->{pkg_details}->{$pkg_ident}->{CORE_NEWER}->{$_}->[1]
 478               } keys %{ $self->{pkg_details}->{$pkg_ident}->{CORE_NEWER} }
 479           );
 480         return $self->{pkg_details}->{$pkg_ident}->{CHECK_STATE} = STATE_NEWER_IN_CORE;
 481     }
 482
 483     if ( !defined($cpan_version) )
 484     {
 485         defined($master_sites)
 486           and $master_sites !~ m/cpan/i
 487           and return $self->{pkg_details}->{$pkg_ident}->{CHECK_STATE} = STATE_OK;
 488         return $self->{pkg_details}->{$pkg_ident}->{CHECK_STATE} = STATE_REMOVED_FROM_INDEX;
 489     }
 490     elsif ( _is_gt( $cpan_version, $dist_version ) )
 491     {
 492         return $self->{pkg_details}->{$pkg_ident}->{CHECK_STATE} = STATE_NEWER_IN_CPAN;
 493     }
 494     elsif ( _is_ne( $cpan_version, $dist_version ) )
 495     {
 496         return $self->{pkg_details}->{$pkg_ident}->{CHECK_STATE} = STATE_OUT_OF_SYNC;
 497     }
 498
 499     return $self->{pkg_details}->{$pkg_ident}->{CHECK_STATE} = STATE_OK;
 500 }
 501
 502 sub get_distribution_for_module
 503 {
 504     my ( $self, $module ) = @_;
 505     my @found;
 506
 507     if ( $CPAN::META->exists( "CPAN::Module", $module ) )
 508     {
 509         my $cpan_mod  = $CPAN::META->instance( "CPAN::Module", $module );
 510         my $cpan_dist = CPAN::DistnameInfo->new( $cpan_mod->cpan_file() )->dist();
 511         my $pkg_ident = $self->{_dist_tools}->find_package( DIST_NAME => $cpan_dist );
 512
 513         push @found, $pkg_ident;
 514     }
 515
 516     defined( $Module::CoreList::version{$]}->{$module} ) and push @found, "Core ($])";
 517
 518     return wantarray ? @found : join( ",", @found );
 519 }
 520
 521 =head1 AUTHOR
 522
 523 Jens Rehsack, C<< <rehsack at cpan.org> >>
 524
 525 =head1 BUGS
 526
 527 Please report any bugs or feature requests to C<bug-packaging-tools at rt.cpan.org>, or through
 528 the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Packaging-Tools>.  I will be notified, and then you'll
 529 automatically be notified of progress on your bug as I make changes.
 530
 531 =head1 SUPPORT
 532
 533 You can find documentation for this module with the perldoc command.
 534
 535     perldoc Packaging::Tools
 536
 537
 538 You can also look for information at:
 539
 540 =over 4
 541
 542 =item * RT: CPAN's request tracker (report bugs here)
 543
 544 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Packaging-Tools>
 545
 546 =item * AnnoCPAN: Annotated CPAN documentation
 547
 548 L<http://annocpan.org/dist/Packaging-Tools>
 549
 550 =item * CPAN Ratings
 551
 552 L<http://cpanratings.perl.org/d/Packaging-Tools>
 553
 554 =item * Search CPAN
 555
 556 L<http://search.cpan.org/dist/Packaging-Tools/>
 557
 558 =back
 559
 560
 561 =head1 ACKNOWLEDGEMENTS
 562
 563
 564 =head1 LICENSE AND COPYRIGHT
 565
 566 Copyright 2012 Jens Rehsack.
 567
 568 This program is free software; you can redistribute it and/or modify it
 569 under the terms of either: the GNU General Public License as published
 570 by the Free Software Foundation; or the Artistic License.
 571
 572 See http://dev.perl.org/licenses/ for more information.
 573
 574
 575 =cut
 576
 577 1;    # End of Packaging::Tools