File Coverage

blib/lib/Module/Install/Admin/Bundle.pm
Criterion Covered Total %
statement 11 42 26.1
branch 0 8 0.0
condition 0 6 0.0
subroutine 4 5 80.0
pod 0 1 0.0
total 15 62 24.1


line stmt bran cond sub pod time code
1             package Module::Install::Admin::Bundle;
2              
3 1     1   1509 use strict;
  1         3  
  1         31  
4 1     1   5 use Module::Install::Base;
  1         3  
  1         33  
5              
6 1     1   10 use vars qw{$VERSION @ISA};
  1         1  
  1         58  
7             BEGIN {
8 1     1   3 $VERSION = '1.21';
9 1         425 @ISA = qw{Module::Install::Base};
10             }
11              
12             sub bundle {
13 0     0 0   my $self = shift;
14 0           my $bundle_dir = $self->_top->{bundle};
15              
16 0           require Cwd;
17 0           require CPANPLUS::Backend;
18              
19 0           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 0   0       my $cp = CPANPLUS::Internals->_retrieve_id( CPANPLUS::Internals->_last_id )
28             || CPANPLUS::Backend->new;
29 0           my $conf = $cp->configure_object;
30 0           my $modtree = $cp->module_tree;
31              
32 0           $conf->set_conf( verbose => 1 );
33 0           $conf->set_conf( signature => 0 );
34 0           $conf->set_conf( md5 => 0 );
35              
36 0           mkdir( $bundle_dir, 0777 );
37              
38 0           while ( my ( $name, $version ) = splice( @_, 0, 2 ) ) {
39 0           my $mod = $cp->module_tree($name);
40 0 0         if (not $mod) {
41 0           warn "Warning: Could not find distribution for module $name on CPAN. Bundle it manually.\n";
42 0           next;
43             }
44              
45 0 0 0       if ( $mod->package_is_perl_core or $self->{already_bundled}{$mod->package} ) {
46 0           next;
47             }
48              
49 0           my $where = $mod->fetch( fetchdir => $bundle_dir, );
50 0 0         unless ($where) {
51 0           warn "Warning: Could not download distribution $bundle_dir. Download it manually.\n";
52 0           next;
53             }
54 0           my $file = Cwd::abs_path($where);
55              
56 0           my $extract_result = $mod->extract(
57             files => [ $file ],
58             extractdir => $bundle_dir,
59             );
60              
61 0           unlink $file;
62 0 0         unless ($extract_result) {
63 0           warn "Warning: Could not extract distribution $bundle_dir. Extract it manually.\n";
64 0           next;
65             }
66              
67 0           $self->{already_bundled}{ $mod->package }++;
68             }
69              
70 0           chdir $cwd;
71             }
72              
73             1;