local-lib5/lib/perl5/Module/Install/Admin/Bundle.pm

   1 package Module::Install::Admin::Bundle;
   2
   3 use strict;
   4 use Module::Install::Base;
   5
   6 use vars qw{$VERSION @ISA};
   7 BEGIN {
   8         $VERSION = '0.91';;
   9         @ISA     = qw{Module::Install::Base};
  10 }
  11
  12 sub bundle {
  13     my $self       = shift;
  14     my $bundle_dir = $self->_top->{bundle};
  15
  16     require Cwd;
  17     require CPANPLUS::Backend;
  18
  19     my $cwd = Cwd::getcwd();
  20
  21     # This code is what we _should_ be doing, but CPANPLUS doesn't
  22     # let you have multiple Backends in one program.
  23     # my $cp   = CPANPLUS::Backend->new;
  24     #
  25     # Jos Boumans tells us that this is the best way to do what we want
  26     # It still scares me.
  27     my $cp      = CPANPLUS::Internals->_retrieve_id( CPANPLUS::Internals->_last_id )
  28                || CPANPLUS::Backend->new;
  29     my $conf    = $cp->configure_object;
  30     my $modtree = $cp->module_tree;
  31
  32     $conf->set_conf( verbose   => 1 );
  33     $conf->set_conf( signature => 0 );
  34     $conf->set_conf( md5       => 0 );
  35
  36     mkdir $bundle_dir;
  37
  38     my %bundles;
  39
  40     while ( my ( $name, $version ) = splice( @_, 0, 2 ) ) {
  41         my $mod = $cp->module_tree($name);
  42         next unless $mod;
  43         if ( $mod->package_is_perl_core or $self->{already_bundled}{$mod->package} ) {
  44                 next;
  45         }
  46
  47         my $where = $mod->fetch( fetchdir => $bundle_dir, );
  48         next unless ($where);
  49         my $file = Cwd::abs_path($where);
  50
  51         my $extract_result = $mod->extract(
  52             files      => [ $file ],
  53             extractdir => $bundle_dir,
  54         );
  55
  56         unlink $file;
  57         next unless ($extract_result);
  58         $bundles{$name} = $extract_result;
  59         $self->{already_bundled}{ $mod->package }++;
  60
  61     }
  62
  63     chdir $cwd;
  64
  65     local *FH;
  66     open FH, ">> $bundle_dir.yml" or die "Cannot write to $bundle_dir.yml: $!";
  67     foreach my $name ( sort keys %bundles ) {
  68         print FH "$name: '$bundles{$name}'\n";
  69     }
  70     close FH;
  71 }
  72
  73 1;