[p5sagit/p5-mst-13.2.git] / lib / CPANPLUS / Internals / Extract.pm

package CPANPLUS::Internals::Extract;

use strict;

use CPANPLUS::Error;
use CPANPLUS::Internals::Constants;

use File::Spec                  ();
use File::Basename              ();
use Archive::Extract;
use IPC::Cmd                    qw[run];
use Params::Check               qw[check];
use Module::Load::Conditional   qw[can_load check_install];
use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';

local $Params::Check::VERBOSE = 1;

=pod

=head1 NAME

CPANPLUS::Internals::Extract

=head1 SYNOPSIS

    ### for source files ###
    $self->_gunzip( file => 'foo.gz', output => 'blah.txt' );
    
    ### for modules/packages ###
    $dir = $self->_extract( module      => $modobj, 
                            extractdir  => '/some/where' );

=head1 DESCRIPTION

CPANPLUS::Internals::Extract extracts compressed files for CPANPLUS.
It can do this by either a pure perl solution (preferred) with the 
use of C<Archive::Tar> and C<Compress::Zlib>, or with binaries, like
C<gzip> and C<tar>.
 
The flow looks like this:

    $cb->_extract
        Delegate to Archive::Extract
 
=head1 METHODS

=head2 $dir = _extract( module => $modobj, [perl => '/path/to/perl', extractdir => '/path/to/extract/to', prefer_bin => BOOL, verbose => BOOL, force => BOOL] )

C<_extract> will take a module object and extract it to C<extractdir>
if provided, or the default location which is obtained from your 
config.

The file name is obtained by looking at C<< $modobj->status->fetch >>
and will be parsed to see if it's a tar or zip archive.

If it's a zip archive, C<__unzip> will be called, otherwise C<__untar>
will be called. In the unlikely event the file is of neither format,
an error will be thrown.

C<_extract> takes the following options:

=over 4

=item module

A C<CPANPLUS::Module> object. This is required.

=item extractdir

The directory to extract the archive to. By default this looks 
something like:
    /CPANPLUS_BASE/PERL_VERSION/BUILD/MODULE_NAME

=item prefer_bin

A flag indicating whether you prefer a pure perl solution, ie
C<Archive::Tar> or C<Archive::Zip> respectively, or a binary solution
like C<unzip> and C<tar>.

=item perl

The path to the perl executable to use for any perl calls. Also used
to determine the build version directory for extraction.

=item verbose

Specifies whether to be verbose or not. Defaults to your corresponding
config entry.

=item force

Specifies whether to force the extraction or not. Defaults to your
corresponding config entry.

=back

All other options are passed on verbatim to C<__unzip> or C<__untar>.

Returns the directory the file was extracted to on success and false
on failure.

=cut

sub _extract {
    my $self = shift;
    my $conf = $self->configure_object;
    my %hash = @_;
    
    local $Params::Check::ALLOW_UNKNOWN = 1;
    
    my( $mod, $verbose, $force );
    my $tmpl = {
        force       => { default => $conf->get_conf('force'),   
                            store => \$force },
        verbose     => { default => $conf->get_conf('verbose'), 
                            store => \$verbose },
        prefer_bin  => { default => $conf->get_conf('prefer_bin') },
        extractdir  => { default => $conf->get_conf('extractdir') },
        module      => { required => 1, allow => IS_MODOBJ, store => \$mod },
        perl        => { default => $^X },
    };
    
    my $args = check( $tmpl, \%hash ) or return;
    
    ### did we already extract it ? ###
    my $loc = $mod->status->extract();
    
    if( $loc && !$force ) {
        msg(loc("Already extracted '%1' to '%2'. ".
                "Won't extract again without force",
                $mod->module, $loc), $verbose);
        return $loc;
    }

    ### did we already fetch the file? ###
    my $file = $mod->status->fetch();
    unless( -s $file ) {
        error( loc( "File '%1' has zero size: cannot extract", $file ) );    
        return;
    }

    ### the dir to extract to ###
    my $to =    $args->{'extractdir'} ||
                File::Spec->catdir(
                        $conf->get_conf('base'),
                        $self->_perl_version( perl => $args->{'perl'} ),
                        $conf->_get_build('moddir'),
                );
 
    ### delegate to Archive::Extract ###
    ### set up some flags for archive::extract ###
    local $Archive::Extract::PREFER_BIN = $args->{'prefer_bin'};
    local $Archive::Extract::DEBUG      = $conf->get_conf('debug');
    local $Archive::Extract::WARN       = $verbose;

    my $ae = Archive::Extract->new( archive => $file );

    unless( $ae->extract( to => $to ) ) {
        error( loc( "Unable to extract '%1' to '%2': %3",
                    $file, $to, $ae->error ) );
        return;
    }
    
    ### if ->files is not filled, we dont know what the hell was
    ### extracted.. try to offer a suggestion and bail :(
    unless ( $ae->files ) {
        error( loc( "'%1' was not able to determine extracted ".
                    "files from the archive. Instal '%2' and ensure ".
                    "it works properly and try again",
                    $ae->is_zip ? 'Archive::Zip' : 'Archive::Tar' ) );
        return;                    
    }                    
    
    
    ### print out what files we extracted ###  
    msg(loc("Extracted '%1'",$_),$verbose) for @{$ae->files};  
    
    ### set them all to be +w for the owner, so we don't get permission
    ### denied for overwriting files that are just +r
    
    ### this is to rigurous -- just change to +w for the owner [cpan #13358] 
    #chmod 0755, map { File::Spec->rel2abs( File::Spec->catdir($to, $_) ) }
    #            @{$ae->files};
    
    for my $file ( @{$ae->files} ) { 
        my $path = File::Spec->rel2abs( File::Spec->catdir($to, $file) );
    
        $self->_mode_plus_w( file => $path );
    }
    
    ### check the return value for the extracted path ###
    ### Make an educated guess if we didn't get an extract_path
    ### back
    ### XXX apparently some people make their own dists and they 
    ### pack up '.' which means the leading directory is '.' 
    ### and only the second directory is the actual module directory
    ### so, we'll have to check if our educated guess exists first, 
    ### then see if the extract path works.. and if nothing works...
    ### well, then we really don't know.

    my $dir;
    for my $try ( File::Spec->rel2abs( File::Spec->catdir(   
                    $to, $mod->package_name .'-'. $mod->package_version ) ),
                  File::Spec->rel2abs( $ae->extract_path ),
    ) {
        ($dir = $try) && last if -d $try;
    }
                                            
    ### test if the dir exists ###
    unless( $dir && -d $dir ) {
        error(loc("Unable to determine extract dir for '%1'",$mod->module));
        return;
    
    } else {    
        msg(loc("Extracted '%1' to '%2'", $mod->module, $dir), $verbose);
        
        ### register where we extracted the files to,
        ### also store what files were extracted
        $mod->status->extract( $dir ); 
        $mod->status->files( $ae->files );
    }
      
    ### also, figure out what kind of install we're dealing with ###
    $mod->get_installer_type();

    return $mod->status->extract();
}

1;

# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4:
Commit	Line	Data
6aaee015	1	package CPANPLUS::Internals::Extract;
	2
	3	use strict;
	4
	5	use CPANPLUS::Error;
	6	use CPANPLUS::Internals::Constants;
	7
	8	use File::Spec ();
	9	use File::Basename ();
	10	use Archive::Extract;
	11	use IPC::Cmd qw[run];
	12	use Params::Check qw[check];
	13	use Module::Load::Conditional qw[can_load check_install];
	14	use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
	15
	16	local $Params::Check::VERBOSE = 1;
	17
	18	=pod
	19
	20	=head1 NAME
	21
	22	CPANPLUS::Internals::Extract
	23
	24	=head1 SYNOPSIS
	25
	26	### for source files ###
	27	$self->_gunzip( file => 'foo.gz', output => 'blah.txt' );
	28
	29	### for modules/packages ###
	30	$dir = $self->_extract( module => $modobj,
	31	extractdir => '/some/where' );
	32
	33	=head1 DESCRIPTION
	34
	35	CPANPLUS::Internals::Extract extracts compressed files for CPANPLUS.
	36	It can do this by either a pure perl solution (preferred) with the
	37	use of C<Archive::Tar> and C<Compress::Zlib>, or with binaries, like
	38	C<gzip> and C<tar>.
	39
	40	The flow looks like this:
	41
	42	$cb->_extract
	43	Delegate to Archive::Extract
	44
	45	=head1 METHODS
	46
	47	=head2 $dir = _extract( module => $modobj, [perl => '/path/to/perl', extractdir => '/path/to/extract/to', prefer_bin => BOOL, verbose => BOOL, force => BOOL] )
	48
	49	C<_extract> will take a module object and extract it to C<extractdir>
	50	if provided, or the default location which is obtained from your
	51	config.
	52
	53	The file name is obtained by looking at C<< $modobj->status->fetch >>
	54	and will be parsed to see if it's a tar or zip archive.
	55
	56	If it's a zip archive, C<__unzip> will be called, otherwise C<__untar>
	57	will be called. In the unlikely event the file is of neither format,
	58	an error will be thrown.
	59
	60	C<_extract> takes the following options:
	61
	62	=over 4
	63
	64	=item module
65
66	A C<CPANPLUS::Module> object. This is required.
67
68	=item extractdir
69
70	The directory to extract the archive to. By default this looks
71	something like:
72	/CPANPLUS_BASE/PERL_VERSION/BUILD/MODULE_NAME
73
74	=item prefer_bin
75
76	A flag indicating whether you prefer a pure perl solution, ie
77	C<Archive::Tar> or C<Archive::Zip> respectively, or a binary solution
78	like C<unzip> and C<tar>.
79
80	=item perl
81
82	The path to the perl executable to use for any perl calls. Also used
83	to determine the build version directory for extraction.
84
85	=item verbose
86
87	Specifies whether to be verbose or not. Defaults to your corresponding
88	config entry.
89
90	=item force
91
92	Specifies whether to force the extraction or not. Defaults to your
93	corresponding config entry.
94
95	=back
96
97	All other options are passed on verbatim to C<__unzip> or C<__untar>.
98
99	Returns the directory the file was extracted to on success and false
100	on failure.
101
102	=cut
103
104	sub _extract {
105	my $self = shift;
106	my $conf = $self->configure_object;
107	my %hash = @_;
108
109	local $Params::Check::ALLOW_UNKNOWN = 1;
110
111	my( $mod, $verbose, $force );
112	my $tmpl = {
113	force => { default => $conf->get_conf('force'),
114	store => \$force },
115	verbose => { default => $conf->get_conf('verbose'),
116	store => \$verbose },
117	prefer_bin => { default => $conf->get_conf('prefer_bin') },
118	extractdir => { default => $conf->get_conf('extractdir') },
119	module => { required => 1, allow => IS_MODOBJ, store => \$mod },
120	perl => { default => $^X },
121	};
122
123	my $args = check( $tmpl, \%hash ) or return;
124
125	### did we already extract it ? ###
126	my $loc = $mod->status->extract();
127
128	if( $loc && !$force ) {
129	msg(loc("Already extracted '%1' to '%2'. ".
130	"Won't extract again without force",
131	$mod->module, $loc), $verbose);
132	return $loc;
133	}
134
135	### did we already fetch the file? ###
136	my $file = $mod->status->fetch();
137	unless( -s $file ) {
138	error( loc( "File '%1' has zero size: cannot extract", $file ) );
139	return;
140	}
141
142	### the dir to extract to ###
143	my $to = $args->{'extractdir'} \|\|
144	File::Spec->catdir(
145	$conf->get_conf('base'),
146	$self->_perl_version( perl => $args->{'perl'} ),
147	$conf->_get_build('moddir'),
148	);
149
150	### delegate to Archive::Extract ###
151	### set up some flags for archive::extract ###
152	local $Archive::Extract::PREFER_BIN = $args->{'prefer_bin'};
153	local $Archive::Extract::DEBUG = $conf->get_conf('debug');
154	local $Archive::Extract::WARN = $verbose;
155
156	my $ae = Archive::Extract->new( archive => $file );
157
158	unless( $ae->extract( to => $to ) ) {
159	error( loc( "Unable to extract '%1' to '%2': %3",
160	$file, $to, $ae->error ) );
161	return;
162	}
163
164	### if ->files is not filled, we dont know what the hell was
165	### extracted.. try to offer a suggestion and bail :(
166	unless ( $ae->files ) {
167	error( loc( "'%1' was not able to determine extracted ".
168	"files from the archive. Instal '%2' and ensure ".
169	"it works properly and try again",
170	$ae->is_zip ? 'Archive::Zip' : 'Archive::Tar' ) );
171	return;
172	}
173
174
175	### print out what files we extracted ###
176	msg(loc("Extracted '%1'",$_),$verbose) for @{$ae->files};
177
178	### set them all to be +w for the owner, so we don't get permission
179	### denied for overwriting files that are just +r
180
181	### this is to rigurous -- just change to +w for the owner [cpan #13358]
182	#chmod 0755, map { File::Spec->rel2abs( File::Spec->catdir($to, $_) ) }
183	# @{$ae->files};
184
185	for my $file ( @{$ae->files} ) {
186	my $path = File::Spec->rel2abs( File::Spec->catdir($to, $file) );
187
188	$self->_mode_plus_w( file => $path );
189	}
190
191	### check the return value for the extracted path ###
192	### Make an educated guess if we didn't get an extract_path
193	### back
194	### XXX apparently some people make their own dists and they
195	### pack up '.' which means the leading directory is '.'
196	### and only the second directory is the actual module directory
197	### so, we'll have to check if our educated guess exists first,
198	### then see if the extract path works.. and if nothing works...
199	### well, then we really don't know.
200
201	my $dir;
202	for my $try ( File::Spec->rel2abs( File::Spec->catdir(
203	$to, $mod->package_name .'-'. $mod->package_version ) ),
204	File::Spec->rel2abs( $ae->extract_path ),
205	) {
206	($dir = $try) && last if -d $try;
207	}
208
209	### test if the dir exists ###
210	unless( $dir && -d $dir ) {
211	error(loc("Unable to determine extract dir for '%1'",$mod->module));
212	return;
213
214	} else {
215	msg(loc("Extracted '%1' to '%2'", $mod->module, $dir), $verbose);
216
217	### register where we extracted the files to,
218	### also store what files were extracted
219	$mod->status->extract( $dir );
220	$mod->status->files( $ae->files );
221	}
222
223	### also, figure out what kind of install we're dealing with ###
224	$mod->get_installer_type();
225
226	return $mod->status->extract();
227	}
228
229	1;
230
231	# Local variables:
232	# c-indentation-style: bsd
233	# c-basic-offset: 4
234	# indent-tabs-mode: nil
235	# End:
236	# vim: expandtab shiftwidth=4: