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} ) { |
2b54c3f6 |
186 | my $path = File::Spec->rel2abs( File::Spec->catfile($to, $file) ); |
6aaee015 |
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; |
5bc5f6dc |
202 | for my $try ( |
203 | File::Spec->rel2abs( |
5879cbe1 |
204 | ### _safe_path must be called before catdir because catdir on |
205 | ### VMS currently will not handle the extra dots in the directories. |
206 | File::Spec->catdir( $self->_safe_path( path => $to ) , |
207 | $self->_safe_path( path => |
208 | $mod->package_name .'-'. |
209 | $mod->package_version |
210 | ) ) ) , |
5bc5f6dc |
211 | File::Spec->rel2abs( $ae->extract_path ), |
6aaee015 |
212 | ) { |
213 | ($dir = $try) && last if -d $try; |
214 | } |
215 | |
216 | ### test if the dir exists ### |
217 | unless( $dir && -d $dir ) { |
218 | error(loc("Unable to determine extract dir for '%1'",$mod->module)); |
219 | return; |
220 | |
221 | } else { |
222 | msg(loc("Extracted '%1' to '%2'", $mod->module, $dir), $verbose); |
223 | |
224 | ### register where we extracted the files to, |
225 | ### also store what files were extracted |
226 | $mod->status->extract( $dir ); |
227 | $mod->status->files( $ae->files ); |
228 | } |
229 | |
230 | ### also, figure out what kind of install we're dealing with ### |
231 | $mod->get_installer_type(); |
232 | |
233 | return $mod->status->extract(); |
234 | } |
235 | |
236 | 1; |
237 | |
238 | # Local variables: |
239 | # c-indentation-style: bsd |
240 | # c-basic-offset: 4 |
241 | # indent-tabs-mode: nil |
242 | # End: |
243 | # vim: expandtab shiftwidth=4: |