Commit | Line | Data |
4443dd53 |
1 | package CPANPLUS::Internals::Source::Memory; |
2 | |
3 | use base 'CPANPLUS::Internals::Source'; |
4 | |
5 | use strict; |
6 | |
7 | use CPANPLUS::Error; |
8 | use CPANPLUS::Module; |
9 | use CPANPLUS::Module::Fake; |
10 | use CPANPLUS::Module::Author; |
11 | use CPANPLUS::Internals::Constants; |
12 | |
13 | use File::Fetch; |
14 | use Archive::Extract; |
15 | |
16 | use IPC::Cmd qw[can_run]; |
17 | use File::Temp qw[tempdir]; |
18 | use File::Basename qw[dirname]; |
19 | use Params::Check qw[allow check]; |
20 | use Module::Load::Conditional qw[can_load]; |
21 | use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; |
22 | |
23 | $Params::Check::VERBOSE = 1; |
24 | |
25 | =head1 NAME |
26 | |
27 | CPANPLUS::Internals::Source::Memory - In memory implementation |
28 | |
29 | =cut |
30 | |
31 | ### flag to show if init_trees got its' data from storable. This allows |
32 | ### us to not write an existing stored file back to disk |
33 | { my $from_storable; |
34 | |
35 | sub _init_trees { |
36 | my $self = shift; |
37 | my $conf = $self->configure_object; |
38 | my %hash = @_; |
39 | |
40 | my($path,$uptodate,$verbose,$use_stored); |
41 | my $tmpl = { |
42 | path => { default => $conf->get_conf('base'), store => \$path }, |
43 | verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, |
44 | uptodate => { required => 1, store => \$uptodate }, |
45 | use_stored => { default => 1, store => \$use_stored }, |
46 | }; |
47 | |
48 | check( $tmpl, \%hash ) or return; |
49 | |
50 | ### retrieve the stored source files ### |
51 | my $stored = $self->__memory_retrieve_source( |
52 | path => $path, |
53 | uptodate => $uptodate && $use_stored, |
54 | verbose => $verbose, |
55 | ) || {}; |
56 | |
57 | ### we got this from storable if $stored has keys.. |
58 | $from_storable = keys %$stored ? 1 : 0; |
59 | |
60 | ### set up the trees |
61 | $self->_atree( $stored->{_atree} || {} ); |
62 | $self->_mtree( $stored->{_mtree} || {} ); |
63 | |
64 | return 1; |
65 | } |
66 | |
67 | sub _standard_trees_completed { return $from_storable } |
68 | sub _custom_trees_completed { return $from_storable } |
69 | |
70 | sub _finalize_trees { |
71 | my $self = shift; |
72 | my $conf = $self->configure_object; |
73 | my %hash = @_; |
74 | |
75 | my($path,$uptodate,$verbose); |
76 | my $tmpl = { |
77 | path => { default => $conf->get_conf('base'), store => \$path }, |
78 | verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, |
79 | uptodate => { required => 1, store => \$uptodate }, |
80 | }; |
81 | |
82 | { local $Params::Check::ALLOW_UNKNOWN = 1; |
83 | check( $tmpl, \%hash ) or return; |
84 | } |
85 | |
86 | ### write the stored files to disk, so we can keep using them |
87 | ### from now on, till they become invalid |
88 | ### write them if the original sources weren't uptodate, or |
89 | ### we didn't just load storable files |
90 | $self->__memory_save_source() if !$uptodate or not $from_storable; |
91 | |
92 | return 1; |
93 | } |
94 | |
95 | ### saves current memory state |
96 | sub _save_state { |
97 | my $self = shift; |
98 | return $self->_finalize_trees( @_, uptodate => 0 ); |
99 | } |
100 | } |
101 | |
102 | sub _add_author_object { |
103 | my $self = shift; |
104 | my %hash = @_; |
105 | |
106 | my $class; |
107 | my $tmpl = { |
108 | class => { default => 'CPANPLUS::Module::Author', store => \$class }, |
109 | map { $_ => { required => 1 } } |
110 | qw[ author cpanid email ] |
111 | }; |
112 | |
113 | my $href = do { |
114 | local $Params::Check::NO_DUPLICATES = 1; |
115 | check( $tmpl, \%hash ) or return; |
116 | }; |
117 | |
118 | my $obj = $class->new( %$href, _id => $self->_id ); |
119 | |
120 | $self->author_tree->{ $href->{'cpanid'} } = $obj or return; |
121 | |
122 | return $obj; |
123 | } |
124 | |
125 | sub _add_module_object { |
126 | my $self = shift; |
127 | my %hash = @_; |
128 | |
129 | my $class; |
130 | my $tmpl = { |
131 | class => { default => 'CPANPLUS::Module', store => \$class }, |
132 | map { $_ => { required => 1 } } |
133 | qw[ module version path comment author package description dslip mtime ] |
134 | }; |
135 | |
136 | my $href = do { |
137 | local $Params::Check::NO_DUPLICATES = 1; |
138 | check( $tmpl, \%hash ) or return; |
139 | }; |
140 | |
141 | my $obj = $class->new( %$href, _id => $self->_id ); |
142 | |
143 | ### Every module get's stored as a module object ### |
144 | $self->module_tree->{ $href->{module} } = $obj or return; |
145 | |
146 | return $obj; |
147 | } |
148 | |
149 | { my %map = ( |
150 | _source_search_module_tree => [ module_tree => 'CPANPLUS::Module' ], |
151 | _source_search_author_tree => [ author_tree => 'CPANPLUS::Module::Author' ], |
152 | ); |
153 | |
154 | while( my($sub, $aref) = each %map ) { |
155 | no strict 'refs'; |
156 | |
157 | my($meth, $class) = @$aref; |
158 | |
159 | *$sub = sub { |
160 | my $self = shift; |
161 | my $conf = $self->configure_object; |
162 | my %hash = @_; |
163 | |
164 | my($authors,$list,$verbose,$type); |
165 | my $tmpl = { |
166 | data => { default => [], |
167 | strict_type=> 1, store => \$authors }, |
168 | allow => { required => 1, default => [ ], strict_type => 1, |
169 | store => \$list }, |
170 | verbose => { default => $conf->get_conf('verbose'), |
171 | store => \$verbose }, |
172 | type => { required => 1, allow => [$class->accessors()], |
173 | store => \$type }, |
174 | }; |
175 | |
176 | my $args = check( $tmpl, \%hash ) or return; |
177 | |
178 | my @rv; |
179 | for my $obj ( values %{ $self->$meth } ) { |
180 | #push @rv, $auth if check( |
181 | # { $type => { allow => $list } }, |
182 | # { $type => $auth->$type } |
183 | # ); |
184 | push @rv, $obj if allow( $obj->$type() => $list ); |
185 | } |
186 | |
187 | return @rv; |
188 | } |
189 | } |
190 | } |
191 | |
192 | =pod |
193 | |
194 | =head2 $cb->__memory_retrieve_source(name => $name, [path => $path, uptodate => BOOL, verbose => BOOL]) |
195 | |
196 | This method retrieves a I<storable>d tree identified by C<$name>. |
197 | |
198 | It takes the following arguments: |
199 | |
200 | =over 4 |
201 | |
202 | =item name |
203 | |
204 | The internal name for the source file to retrieve. |
205 | |
206 | =item uptodate |
207 | |
208 | A flag indicating whether the file-cache is up-to-date or not. |
209 | |
210 | =item path |
211 | |
212 | The absolute path to the directory holding the source files. |
213 | |
214 | =item verbose |
215 | |
216 | A boolean flag indicating whether or not to be verbose. |
217 | |
218 | =back |
219 | |
220 | Will get information from the config file by default. |
221 | |
222 | Returns a tree on success, false on failure. |
223 | |
224 | =cut |
225 | |
226 | sub __memory_retrieve_source { |
227 | my $self = shift; |
228 | my %hash = @_; |
229 | my $conf = $self->configure_object; |
230 | |
231 | my $tmpl = { |
232 | path => { default => $conf->get_conf('base') }, |
233 | verbose => { default => $conf->get_conf('verbose') }, |
234 | uptodate => { default => 0 }, |
235 | }; |
236 | |
237 | my $args = check( $tmpl, \%hash ) or return; |
238 | |
239 | ### check if we can retrieve a frozen data structure with storable ### |
240 | my $storable = can_load( modules => {'Storable' => '0.0'} ) |
241 | if $conf->get_conf('storable'); |
242 | |
243 | return unless $storable; |
244 | |
245 | ### $stored is the name of the frozen data structure ### |
246 | my $stored = $self->__memory_storable_file( $args->{path} ); |
247 | |
248 | if ($storable && -e $stored && -s _ && $args->{'uptodate'}) { |
249 | msg( loc("Retrieving %1", $stored), $args->{'verbose'} ); |
250 | |
251 | my $href = Storable::retrieve($stored); |
252 | return $href; |
253 | } else { |
254 | return; |
255 | } |
256 | } |
257 | |
258 | =pod |
259 | |
260 | =head2 $cb->__memory_save_source([verbose => BOOL, path => $path]) |
261 | |
262 | This method saves all the parsed trees in I<storable>d format if |
263 | C<Storable> is available. |
264 | |
265 | It takes the following arguments: |
266 | |
267 | =over 4 |
268 | |
269 | =item path |
270 | |
271 | The absolute path to the directory holding the source files. |
272 | |
273 | =item verbose |
274 | |
275 | A boolean flag indicating whether or not to be verbose. |
276 | |
277 | =back |
278 | |
279 | Will get information from the config file by default. |
280 | |
281 | Returns true on success, false on failure. |
282 | |
283 | =cut |
284 | |
285 | sub __memory_save_source { |
286 | my $self = shift; |
287 | my %hash = @_; |
288 | my $conf = $self->configure_object; |
289 | |
290 | |
291 | my $tmpl = { |
292 | path => { default => $conf->get_conf('base'), allow => DIR_EXISTS }, |
293 | verbose => { default => $conf->get_conf('verbose') }, |
294 | force => { default => 1 }, |
295 | }; |
296 | |
297 | my $args = check( $tmpl, \%hash ) or return; |
298 | |
299 | my $aref = [qw[_mtree _atree]]; |
300 | |
301 | ### check if we can retrieve a frozen data structure with storable ### |
302 | my $storable; |
303 | $storable = can_load( modules => {'Storable' => '0.0'} ) |
304 | if $conf->get_conf('storable'); |
305 | return unless $storable; |
306 | |
307 | my $to_write = {}; |
308 | foreach my $key ( @$aref ) { |
309 | next unless ref( $self->$key ); |
310 | $to_write->{$key} = $self->$key; |
311 | } |
312 | |
313 | return unless keys %$to_write; |
314 | |
315 | ### $stored is the name of the frozen data structure ### |
316 | my $stored = $self->__memory_storable_file( $args->{path} ); |
317 | |
318 | if (-e $stored && not -w $stored) { |
319 | msg( loc("%1 not writable; skipped.", $stored), $args->{'verbose'} ); |
320 | return; |
321 | } |
322 | |
323 | msg( loc("Writing compiled source information to disk. This might take a little while."), |
324 | $args->{'verbose'} ); |
325 | |
326 | my $flag; |
327 | unless( Storable::nstore( $to_write, $stored ) ) { |
328 | error( loc("could not store %1!", $stored) ); |
329 | $flag++; |
330 | } |
331 | |
332 | return $flag ? 0 : 1; |
333 | } |
334 | |
335 | sub __memory_storable_file { |
336 | my $self = shift; |
337 | my $conf = $self->configure_object; |
338 | my $path = shift or return; |
339 | |
340 | ### check if we can retrieve a frozen data structure with storable ### |
341 | my $storable = $conf->get_conf('storable') |
342 | ? can_load( modules => {'Storable' => '0.0'} ) |
343 | : 0; |
344 | |
345 | return unless $storable; |
346 | |
347 | ### $stored is the name of the frozen data structure ### |
348 | ### changed to use File::Spec->catfile -jmb |
349 | my $stored = File::Spec->rel2abs( |
350 | File::Spec->catfile( |
351 | $path, #base dir |
352 | $conf->_get_source('stored') #file |
a0995fd4 |
353 | . '.s' . |
4443dd53 |
354 | $Storable::VERSION #the version of storable |
a0995fd4 |
355 | . '.c' . |
356 | $self->VERSION #the version of CPANPLUS |
357 | . STORABLE_EXT #append a suffix |
4443dd53 |
358 | ) |
359 | ); |
360 | |
361 | return $stored; |
362 | } |
363 | |
364 | |
365 | |
366 | |
367 | # Local variables: |
368 | # c-indentation-style: bsd |
369 | # c-basic-offset: 4 |
370 | # indent-tabs-mode: nil |
371 | # End: |
372 | # vim: expandtab shiftwidth=4: |
373 | |
374 | 1; |