Commit | Line | Data |
6aaee015 |
1 | package CPANPLUS::Internals::Source; |
2 | |
3 | use strict; |
4 | |
5 | use CPANPLUS::Error; |
6 | use CPANPLUS::Module; |
7 | use CPANPLUS::Module::Fake; |
8 | use CPANPLUS::Module::Author; |
9 | use CPANPLUS::Internals::Constants; |
10 | |
5bc5f6dc |
11 | use File::Fetch; |
6aaee015 |
12 | use Archive::Extract; |
13 | |
6aaee015 |
14 | use IPC::Cmd qw[can_run]; |
5bc5f6dc |
15 | use File::Temp qw[tempdir]; |
16 | use File::Basename qw[dirname]; |
17 | use Params::Check qw[check]; |
6aaee015 |
18 | use Module::Load::Conditional qw[can_load]; |
5bc5f6dc |
19 | use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; |
6aaee015 |
20 | |
21 | $Params::Check::VERBOSE = 1; |
22 | |
23 | =pod |
24 | |
25 | =head1 NAME |
26 | |
27 | CPANPLUS::Internals::Source |
28 | |
29 | =head1 SYNOPSIS |
30 | |
31 | ### lazy load author/module trees ### |
32 | |
33 | $cb->_author_tree; |
34 | $cb->_module_tree; |
35 | |
36 | =head1 DESCRIPTION |
37 | |
38 | CPANPLUS::Internals::Source controls the updating of source files and |
39 | the parsing of them into usable module/author trees to be used by |
40 | C<CPANPLUS>. |
41 | |
42 | Functions exist to check if source files are still C<good to use> as |
43 | well as update them, and then parse them. |
44 | |
45 | The flow looks like this: |
46 | |
47 | $cb->_author_tree || $cb->_module_tree |
5bc5f6dc |
48 | $cb->_check_trees |
6aaee015 |
49 | $cb->__check_uptodate |
50 | $cb->_update_source |
5bc5f6dc |
51 | $cb->__update_custom_module_sources |
52 | $cb->__update_custom_module_source |
6aaee015 |
53 | $cb->_build_trees |
54 | $cb->__create_author_tree |
55 | $cb->__retrieve_source |
56 | $cb->__create_module_tree |
57 | $cb->__retrieve_source |
58 | $cb->__create_dslip_tree |
59 | $cb->__retrieve_source |
5bc5f6dc |
60 | $cb->__create_custom_module_entries |
6aaee015 |
61 | $cb->_save_source |
62 | |
63 | $cb->_dslip_defs |
64 | |
65 | =head1 METHODS |
66 | |
67 | =cut |
68 | |
69 | { |
70 | my $recurse; # flag to prevent recursive calls to *_tree functions |
71 | |
72 | ### lazy loading of module tree |
73 | sub _module_tree { |
74 | my $self = $_[0]; |
75 | |
76 | unless ($self->{_modtree} or $recurse++ > 0) { |
77 | my $uptodate = $self->_check_trees( @_[1..$#_] ); |
78 | $self->_build_trees(uptodate => $uptodate); |
79 | } |
80 | |
81 | $recurse--; |
82 | return $self->{_modtree}; |
83 | } |
84 | |
85 | ### lazy loading of author tree |
86 | sub _author_tree { |
87 | my $self = $_[0]; |
88 | |
89 | unless ($self->{_authortree} or $recurse++ > 0) { |
90 | my $uptodate = $self->_check_trees( @_[1..$#_] ); |
91 | $self->_build_trees(uptodate => $uptodate); |
92 | } |
93 | |
94 | $recurse--; |
95 | return $self->{_authortree}; |
96 | } |
97 | |
98 | } |
99 | |
100 | =pod |
101 | |
102 | =head2 $cb->_check_trees( [update_source => BOOL, path => PATH, verbose => BOOL] ) |
103 | |
104 | Retrieve source files and return a boolean indicating whether or not |
105 | the source files are up to date. |
106 | |
107 | Takes several arguments: |
108 | |
109 | =over 4 |
110 | |
111 | =item update_source |
112 | |
113 | A flag to force re-fetching of the source files, even |
114 | if they are still up to date. |
115 | |
116 | =item path |
117 | |
118 | The absolute path to the directory holding the source files. |
119 | |
120 | =item verbose |
121 | |
122 | A boolean flag indicating whether or not to be verbose. |
123 | |
124 | =back |
125 | |
126 | Will get information from the config file by default. |
127 | |
128 | =cut |
129 | |
130 | ### retrieve source files, and returns a boolean indicating if it's up to date |
131 | sub _check_trees { |
132 | my ($self, %hash) = @_; |
133 | my $conf = $self->configure_object; |
134 | |
135 | my $update_source; |
136 | my $verbose; |
137 | my $path; |
138 | |
139 | my $tmpl = { |
140 | path => { default => $conf->get_conf('base'), |
141 | store => \$path |
142 | }, |
143 | verbose => { default => $conf->get_conf('verbose'), |
144 | store => \$verbose |
145 | }, |
146 | update_source => { default => 0, store => \$update_source }, |
147 | }; |
148 | |
149 | my $args = check( $tmpl, \%hash ) or return; |
150 | |
151 | ### if the user never wants to update their source without explicitly |
152 | ### telling us, shortcircuit here |
153 | return 1 if $conf->get_conf('no_update') && !$update_source; |
154 | |
155 | ### a check to see if our source files are still up to date ### |
156 | msg( loc("Checking if source files are up to date"), $verbose ); |
157 | |
158 | my $uptodate = 1; # default return value |
159 | |
160 | for my $name (qw[auth dslip mod]) { |
161 | for my $file ( $conf->_get_source( $name ) ) { |
162 | $self->__check_uptodate( |
163 | file => File::Spec->catfile( $args->{path}, $file ), |
164 | name => $name, |
165 | update_source => $update_source, |
166 | verbose => $verbose, |
167 | ) or $uptodate = 0; |
168 | } |
169 | } |
170 | |
5bc5f6dc |
171 | ### if we're explicitly asked to update the sources, or if the |
172 | ### standard source files are out of date, update the custom sources |
173 | ### as well |
174 | $self->__update_custom_module_sources( verbose => $verbose ) |
175 | if $update_source or !$uptodate; |
176 | |
6aaee015 |
177 | return $uptodate; |
178 | } |
179 | |
180 | =pod |
181 | |
182 | =head2 $cb->__check_uptodate( file => $file, name => $name, [update_source => BOOL, verbose => BOOL] ) |
183 | |
184 | C<__check_uptodate> checks if a given source file is still up-to-date |
185 | and if not, or when C<update_source> is true, will re-fetch the source |
186 | file. |
187 | |
188 | Takes the following arguments: |
189 | |
190 | =over 4 |
191 | |
192 | =item file |
193 | |
194 | The source file to check. |
195 | |
196 | =item name |
197 | |
198 | The internal shortcut name for the source file (used for config |
199 | lookups). |
200 | |
201 | =item update_source |
202 | |
203 | Flag to force updating of sourcefiles regardless. |
204 | |
205 | =item verbose |
206 | |
207 | Boolean to indicate whether to be verbose or not. |
208 | |
209 | =back |
210 | |
211 | Returns a boolean value indicating whether the current files are up |
212 | to date or not. |
213 | |
214 | =cut |
215 | |
216 | ### this method checks whether or not the source files we are using are still up to date |
217 | sub __check_uptodate { |
218 | my $self = shift; |
219 | my %hash = @_; |
220 | my $conf = $self->configure_object; |
221 | |
222 | |
223 | my $tmpl = { |
224 | file => { required => 1 }, |
225 | name => { required => 1 }, |
226 | update_source => { default => 0 }, |
227 | verbose => { default => $conf->get_conf('verbose') }, |
228 | }; |
229 | |
230 | my $args = check( $tmpl, \%hash ) or return; |
231 | |
232 | my $flag; |
233 | unless ( -e $args->{'file'} && ( |
234 | ( stat $args->{'file'} )[9] |
235 | + $conf->_get_source('update') ) |
236 | > time ) { |
237 | $flag = 1; |
238 | } |
239 | |
240 | if ( $flag or $args->{'update_source'} ) { |
241 | |
242 | if ( $self->_update_source( name => $args->{'name'} ) ) { |
5bc5f6dc |
243 | return 0; # return 0 so 'uptodate' will be set to 0, meaning no |
244 | # use of previously stored hashrefs! |
6aaee015 |
245 | } else { |
246 | msg( loc("Unable to update source, attempting to get away with using old source file!"), $args->{verbose} ); |
247 | return 1; |
248 | } |
249 | |
250 | } else { |
251 | return 1; |
252 | } |
253 | } |
254 | |
255 | =pod |
256 | |
257 | =head2 $cb->_update_source( name => $name, [path => $path, verbose => BOOL] ) |
258 | |
259 | This method does the actual fetching of source files. |
260 | |
261 | It takes the following arguments: |
262 | |
263 | =over 4 |
264 | |
265 | =item name |
266 | |
267 | The internal shortcut name for the source file (used for config |
268 | lookups). |
269 | |
270 | =item path |
271 | |
272 | The full path where to write the files. |
273 | |
274 | =item verbose |
275 | |
276 | Boolean to indicate whether to be verbose or not. |
277 | |
278 | =back |
279 | |
280 | Returns a boolean to indicate success. |
281 | |
282 | =cut |
283 | |
284 | ### this sub fetches new source files ### |
285 | sub _update_source { |
286 | my $self = shift; |
287 | my %hash = @_; |
288 | my $conf = $self->configure_object; |
289 | |
5bc5f6dc |
290 | my $verbose; |
6aaee015 |
291 | my $tmpl = { |
292 | name => { required => 1 }, |
293 | path => { default => $conf->get_conf('base') }, |
5bc5f6dc |
294 | verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, |
6aaee015 |
295 | }; |
296 | |
297 | my $args = check( $tmpl, \%hash ) or return; |
298 | |
299 | |
300 | my $path = $args->{path}; |
6aaee015 |
301 | { ### this could use a clean up - Kane |
302 | ### no worries about the / -> we get it from the _ftp configuration, so |
303 | ### it's not platform dependant. -kane |
304 | my ($dir, $file) = $conf->_get_mirror( $args->{'name'} ) =~ m|(.+/)(.+)$|sg; |
305 | |
5bc5f6dc |
306 | msg( loc("Updating source file '%1'", $file), $verbose ); |
6aaee015 |
307 | |
308 | my $fake = CPANPLUS::Module::Fake->new( |
309 | module => $args->{'name'}, |
310 | path => $dir, |
311 | package => $file, |
312 | _id => $self->_id, |
313 | ); |
314 | |
315 | ### can't use $fake->fetch here, since ->parent won't work -- |
316 | ### the sources haven't been saved yet |
317 | my $rv = $self->_fetch( |
318 | module => $fake, |
319 | fetchdir => $path, |
320 | force => 1, |
321 | ); |
322 | |
323 | |
324 | unless ($rv) { |
325 | error( loc("Couldn't fetch '%1'", $file) ); |
326 | return; |
327 | } |
328 | |
5bc5f6dc |
329 | $self->_update_timestamp( file => File::Spec->catfile($path, $file) ); |
6aaee015 |
330 | } |
5bc5f6dc |
331 | |
6aaee015 |
332 | return 1; |
333 | } |
334 | |
335 | =pod |
336 | |
337 | =head2 $cb->_build_trees( uptodate => BOOL, [use_stored => BOOL, path => $path, verbose => BOOL] ) |
338 | |
339 | This method rebuilds the author- and module-trees from source. |
340 | |
341 | It takes the following arguments: |
342 | |
343 | =over 4 |
344 | |
345 | =item uptodate |
346 | |
347 | Indicates whether any on disk caches are still ok to use. |
348 | |
349 | =item path |
350 | |
351 | The absolute path to the directory holding the source files. |
352 | |
353 | =item verbose |
354 | |
355 | A boolean flag indicating whether or not to be verbose. |
356 | |
357 | =item use_stored |
358 | |
359 | A boolean flag indicating whether or not it is ok to use previously |
360 | stored trees. Defaults to true. |
361 | |
362 | =back |
363 | |
364 | Returns a boolean indicating success. |
365 | |
366 | =cut |
367 | |
368 | ### (re)build the trees ### |
369 | sub _build_trees { |
370 | my ($self, %hash) = @_; |
371 | my $conf = $self->configure_object; |
372 | |
373 | my($path,$uptodate,$use_stored); |
374 | my $tmpl = { |
375 | path => { default => $conf->get_conf('base'), store => \$path }, |
376 | verbose => { default => $conf->get_conf('verbose') }, |
377 | uptodate => { required => 1, store => \$uptodate }, |
378 | use_stored => { default => 1, store => \$use_stored }, |
379 | }; |
380 | |
381 | my $args = check( $tmpl, \%hash ) or return undef; |
382 | |
383 | ### retrieve the stored source files ### |
384 | my $stored = $self->__retrieve_source( |
385 | path => $path, |
386 | uptodate => $uptodate && $use_stored, |
387 | verbose => $args->{'verbose'}, |
388 | ) || {}; |
389 | |
390 | ### build the trees ### |
391 | $self->{_authortree} = $stored->{_authortree} || |
392 | $self->__create_author_tree( |
393 | uptodate => $uptodate, |
394 | path => $path, |
395 | verbose => $args->{verbose}, |
396 | ); |
397 | $self->{_modtree} = $stored->{_modtree} || |
398 | $self->_create_mod_tree( |
399 | uptodate => $uptodate, |
400 | path => $path, |
401 | verbose => $args->{verbose}, |
402 | ); |
403 | |
404 | ### return if we weren't able to build the trees ### |
405 | return unless $self->{_modtree} && $self->{_authortree}; |
406 | |
5bc5f6dc |
407 | ### update them if the other sources are also deemed out of date |
408 | unless( $uptodate ) { |
409 | $self->__update_custom_module_sources( verbose => $args->{verbose} ) |
410 | or error(loc("Could not update custom module sources")); |
411 | } |
412 | |
413 | ### add custom sources here |
414 | $self->__create_custom_module_entries( verbose => $args->{verbose} ) |
415 | or error(loc("Could not create custom module entries")); |
416 | |
6aaee015 |
417 | ### write the stored files to disk, so we can keep using them |
418 | ### from now on, till they become invalid |
419 | ### write them if the original sources weren't uptodate, or |
420 | ### we didn't just load storable files |
421 | $self->_save_source() if !$uptodate or not keys %$stored; |
422 | |
423 | ### still necessary? can only run one instance now ### |
424 | ### will probably stay that way --kane |
425 | # my $id = $self->_store_id( $self ); |
426 | # |
427 | # unless ( $id == $self->_id ) { |
428 | # error( loc("IDs do not match: %1 != %2. Storage failed!", $id, $self->_id) ); |
429 | # } |
430 | |
431 | return 1; |
432 | } |
433 | |
434 | =pod |
435 | |
436 | =head2 $cb->__retrieve_source(name => $name, [path => $path, uptodate => BOOL, verbose => BOOL]) |
437 | |
438 | This method retrieves a I<storable>d tree identified by C<$name>. |
439 | |
440 | It takes the following arguments: |
441 | |
442 | =over 4 |
443 | |
444 | =item name |
445 | |
446 | The internal name for the source file to retrieve. |
447 | |
448 | =item uptodate |
449 | |
450 | A flag indicating whether the file-cache is up-to-date or not. |
451 | |
452 | =item path |
453 | |
454 | The absolute path to the directory holding the source files. |
455 | |
456 | =item verbose |
457 | |
458 | A boolean flag indicating whether or not to be verbose. |
459 | |
460 | =back |
461 | |
462 | Will get information from the config file by default. |
463 | |
464 | Returns a tree on success, false on failure. |
465 | |
466 | =cut |
467 | |
468 | sub __retrieve_source { |
469 | my $self = shift; |
470 | my %hash = @_; |
471 | my $conf = $self->configure_object; |
472 | |
473 | my $tmpl = { |
474 | path => { default => $conf->get_conf('base') }, |
475 | verbose => { default => $conf->get_conf('verbose') }, |
476 | uptodate => { default => 0 }, |
477 | }; |
478 | |
479 | my $args = check( $tmpl, \%hash ) or return; |
480 | |
481 | ### check if we can retrieve a frozen data structure with storable ### |
482 | my $storable = can_load( modules => {'Storable' => '0.0'} ) |
483 | if $conf->get_conf('storable'); |
484 | |
485 | return unless $storable; |
486 | |
487 | ### $stored is the name of the frozen data structure ### |
488 | my $stored = $self->__storable_file( $args->{path} ); |
489 | |
490 | if ($storable && -e $stored && -s _ && $args->{'uptodate'}) { |
491 | msg( loc("Retrieving %1", $stored), $args->{'verbose'} ); |
492 | |
493 | my $href = Storable::retrieve($stored); |
494 | return $href; |
495 | } else { |
496 | return; |
497 | } |
498 | } |
499 | |
500 | =pod |
501 | |
502 | =head2 $cb->_save_source([verbose => BOOL, path => $path]) |
503 | |
504 | This method saves all the parsed trees in I<storable>d format if |
505 | C<Storable> is available. |
506 | |
507 | It takes the following arguments: |
508 | |
509 | =over 4 |
510 | |
511 | =item path |
512 | |
513 | The absolute path to the directory holding the source files. |
514 | |
515 | =item verbose |
516 | |
517 | A boolean flag indicating whether or not to be verbose. |
518 | |
519 | =back |
520 | |
521 | Will get information from the config file by default. |
522 | |
523 | Returns true on success, false on failure. |
524 | |
525 | =cut |
526 | |
527 | sub _save_source { |
528 | my $self = shift; |
529 | my %hash = @_; |
530 | my $conf = $self->configure_object; |
531 | |
532 | |
533 | my $tmpl = { |
534 | path => { default => $conf->get_conf('base'), allow => DIR_EXISTS }, |
535 | verbose => { default => $conf->get_conf('verbose') }, |
536 | force => { default => 1 }, |
537 | }; |
538 | |
539 | my $args = check( $tmpl, \%hash ) or return; |
540 | |
541 | my $aref = [qw[_modtree _authortree]]; |
542 | |
543 | ### check if we can retrieve a frozen data structure with storable ### |
544 | my $storable; |
545 | $storable = can_load( modules => {'Storable' => '0.0'} ) |
546 | if $conf->get_conf('storable'); |
547 | return unless $storable; |
548 | |
549 | my $to_write = {}; |
550 | foreach my $key ( @$aref ) { |
551 | next unless ref( $self->{$key} ); |
552 | $to_write->{$key} = $self->{$key}; |
553 | } |
554 | |
555 | return unless keys %$to_write; |
556 | |
557 | ### $stored is the name of the frozen data structure ### |
558 | my $stored = $self->__storable_file( $args->{path} ); |
559 | |
560 | if (-e $stored && not -w $stored) { |
561 | msg( loc("%1 not writable; skipped.", $stored), $args->{'verbose'} ); |
562 | return; |
563 | } |
564 | |
565 | msg( loc("Writing compiled source information to disk. This might take a little while."), |
566 | $args->{'verbose'} ); |
567 | |
568 | my $flag; |
569 | unless( Storable::nstore( $to_write, $stored ) ) { |
570 | error( loc("could not store %1!", $stored) ); |
571 | $flag++; |
572 | } |
573 | |
574 | return $flag ? 0 : 1; |
575 | } |
576 | |
577 | sub __storable_file { |
578 | my $self = shift; |
579 | my $conf = $self->configure_object; |
580 | my $path = shift or return; |
581 | |
582 | ### check if we can retrieve a frozen data structure with storable ### |
583 | my $storable = $conf->get_conf('storable') |
584 | ? can_load( modules => {'Storable' => '0.0'} ) |
585 | : 0; |
586 | |
587 | return unless $storable; |
588 | |
589 | ### $stored is the name of the frozen data structure ### |
590 | ### changed to use File::Spec->catfile -jmb |
591 | my $stored = File::Spec->rel2abs( |
592 | File::Spec->catfile( |
593 | $path, #base dir |
594 | $conf->_get_source('stored') #file |
595 | . '.' . |
596 | $Storable::VERSION #the version of storable |
597 | . '.stored' #append a suffix |
598 | ) |
599 | ); |
600 | |
601 | return $stored; |
602 | } |
603 | |
604 | =pod |
605 | |
606 | =head2 $cb->__create_author_tree([path => $path, uptodate => BOOL, verbose => BOOL]) |
607 | |
608 | This method opens a source files and parses its contents into a |
609 | searchable author-tree or restores a file-cached version of a |
610 | previous parse, if the sources are uptodate and the file-cache exists. |
611 | |
612 | It takes the following arguments: |
613 | |
614 | =over 4 |
615 | |
616 | =item uptodate |
617 | |
618 | A flag indicating whether the file-cache is uptodate or not. |
619 | |
620 | =item path |
621 | |
622 | The absolute path to the directory holding the source files. |
623 | |
624 | =item verbose |
625 | |
626 | A boolean flag indicating whether or not to be verbose. |
627 | |
628 | =back |
629 | |
630 | Will get information from the config file by default. |
631 | |
632 | Returns a tree on success, false on failure. |
633 | |
634 | =cut |
635 | |
5bc5f6dc |
636 | sub __create_author_tree { |
6aaee015 |
637 | my $self = shift; |
638 | my %hash = @_; |
639 | my $conf = $self->configure_object; |
640 | |
641 | |
642 | my $tmpl = { |
643 | path => { default => $conf->get_conf('base') }, |
644 | verbose => { default => $conf->get_conf('verbose') }, |
645 | uptodate => { default => 0 }, |
646 | }; |
647 | |
648 | my $args = check( $tmpl, \%hash ) or return; |
649 | my $tree = {}; |
650 | my $file = File::Spec->catfile( |
651 | $args->{path}, |
652 | $conf->_get_source('auth') |
653 | ); |
654 | |
655 | msg(loc("Rebuilding author tree, this might take a while"), |
656 | $args->{verbose}); |
657 | |
658 | ### extract the file ### |
659 | my $ae = Archive::Extract->new( archive => $file ) or return; |
660 | my $out = STRIP_GZ_SUFFIX->($file); |
661 | |
662 | ### make sure to set the PREFER_BIN flag if desired ### |
663 | { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin'); |
664 | $ae->extract( to => $out ) or return; |
665 | } |
666 | |
667 | my $cont = $self->_get_file_contents( file => $out ) or return; |
668 | |
669 | ### don't need it anymore ### |
670 | unlink $out; |
671 | |
672 | for ( split /\n/, $cont ) { |
673 | my($id, $name, $email) = m/^alias \s+ |
674 | (\S+) \s+ |
675 | "\s* ([^\"\<]+?) \s* <(.+)> \s*" |
676 | /x; |
677 | |
678 | $tree->{$id} = CPANPLUS::Module::Author->new( |
679 | author => $name, #authors name |
680 | email => $email, #authors email address |
681 | cpanid => $id, #authors CPAN ID |
682 | _id => $self->_id, #id of this internals object |
683 | ); |
684 | } |
685 | |
686 | return $tree; |
687 | |
688 | } #__create_author_tree |
689 | |
690 | =pod |
691 | |
692 | =head2 $cb->_create_mod_tree([path => $path, uptodate => BOOL, verbose => BOOL]) |
693 | |
694 | This method opens a source files and parses its contents into a |
695 | searchable module-tree or restores a file-cached version of a |
696 | previous parse, if the sources are uptodate and the file-cache exists. |
697 | |
698 | It takes the following arguments: |
699 | |
700 | =over 4 |
701 | |
702 | =item uptodate |
703 | |
704 | A flag indicating whether the file-cache is up-to-date or not. |
705 | |
706 | =item path |
707 | |
708 | The absolute path to the directory holding the source files. |
709 | |
710 | =item verbose |
711 | |
712 | A boolean flag indicating whether or not to be verbose. |
713 | |
714 | =back |
715 | |
716 | Will get information from the config file by default. |
717 | |
718 | Returns a tree on success, false on failure. |
719 | |
720 | =cut |
721 | |
722 | ### this builds a hash reference with the structure of the cpan module tree ### |
723 | sub _create_mod_tree { |
724 | my $self = shift; |
725 | my %hash = @_; |
726 | my $conf = $self->configure_object; |
727 | |
728 | |
729 | my $tmpl = { |
730 | path => { default => $conf->get_conf('base') }, |
731 | verbose => { default => $conf->get_conf('verbose') }, |
732 | uptodate => { default => 0 }, |
733 | }; |
734 | |
735 | my $args = check( $tmpl, \%hash ) or return undef; |
736 | my $file = File::Spec->catfile($args->{path}, $conf->_get_source('mod')); |
737 | |
738 | msg(loc("Rebuilding module tree, this might take a while"), |
739 | $args->{verbose}); |
740 | |
741 | |
742 | my $dslip_tree = $self->__create_dslip_tree( %$args ); |
743 | |
744 | ### extract the file ### |
745 | my $ae = Archive::Extract->new( archive => $file ) or return; |
746 | my $out = STRIP_GZ_SUFFIX->($file); |
747 | |
748 | ### make sure to set the PREFER_BIN flag if desired ### |
749 | { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin'); |
750 | $ae->extract( to => $out ) or return; |
751 | } |
752 | |
753 | my $cont = $self->_get_file_contents( file => $out ) or return; |
754 | |
755 | ### don't need it anymore ### |
756 | unlink $out; |
757 | |
758 | my $tree = {}; |
759 | my $flag; |
760 | |
761 | for ( split /\n/, $cont ) { |
762 | |
763 | ### quick hack to read past the header of the file ### |
764 | ### this is still rather evil... fix some time - Kane |
765 | $flag = 1 if m|^\s*$|; |
766 | next unless $flag; |
767 | |
768 | ### skip empty lines ### |
769 | next unless /\S/; |
770 | chomp; |
771 | |
772 | my @data = split /\s+/; |
773 | |
774 | ### filter out the author and filename as well ### |
775 | ### authors can apparently have digits in their names, |
776 | ### and dirs can have dots... blah! |
777 | my ($author, $package) = $data[2] =~ |
5bc5f6dc |
778 | m| (?:[A-Z\d-]/)? |
779 | (?:[A-Z\d-]{2}/)? |
6aaee015 |
780 | ([A-Z\d-]+) (?:/[\S]+)?/ |
781 | ([^/]+)$ |
782 | |xsg; |
783 | |
784 | ### remove file name from the path |
785 | $data[2] =~ s|/[^/]+$||; |
786 | |
787 | |
788 | unless( $self->author_tree($author) ) { |
789 | error( loc( "No such author '%1' -- can't make module object " . |
790 | "'%2' that is supposed to belong to this author", |
791 | $author, $data[0] ) ); |
792 | next; |
793 | } |
794 | |
795 | ### adding the dslip info |
796 | ### probably can use some optimization |
797 | my $dslip; |
798 | for my $item ( qw[ statd stats statl stati statp ] ) { |
799 | ### checking if there's an entry in the dslip info before |
800 | ### catting it on. appeasing warnings this way |
801 | $dslip .= $dslip_tree->{ $data[0] }->{$item} |
802 | ? $dslip_tree->{ $data[0] }->{$item} |
803 | : ' '; |
804 | } |
805 | |
806 | ### Every module get's stored as a module object ### |
807 | $tree->{ $data[0] } = CPANPLUS::Module->new( |
808 | module => $data[0], # full module name |
809 | version => ($data[1] eq 'undef' # version number |
810 | ? '0.0' |
811 | : $data[1]), |
812 | path => File::Spec::Unix->catfile( |
813 | $conf->_get_mirror('base'), |
814 | $data[2], |
815 | ), # extended path on the cpan mirror, |
816 | # like /A/AB/ABIGAIL |
817 | comment => $data[3], # comment on the module |
818 | author => $self->author_tree($author), |
819 | package => $package, # package name, like |
820 | # 'foo-bar-baz-1.03.tar.gz' |
821 | description => $dslip_tree->{ $data[0] }->{'description'}, |
822 | dslip => $dslip, |
823 | _id => $self->_id, #id of this internals object |
824 | ); |
825 | |
826 | } #for |
827 | |
828 | return $tree; |
829 | |
830 | } #_create_mod_tree |
831 | |
832 | =pod |
833 | |
834 | =head2 $cb->__create_dslip_tree([path => $path, uptodate => BOOL, verbose => BOOL]) |
835 | |
836 | This method opens a source files and parses its contents into a |
837 | searchable dslip-tree or restores a file-cached version of a |
838 | previous parse, if the sources are uptodate and the file-cache exists. |
839 | |
840 | It takes the following arguments: |
841 | |
842 | =over 4 |
843 | |
844 | =item uptodate |
845 | |
846 | A flag indicating whether the file-cache is uptodate or not. |
847 | |
848 | =item path |
849 | |
850 | The absolute path to the directory holding the source files. |
851 | |
852 | =item verbose |
853 | |
854 | A boolean flag indicating whether or not to be verbose. |
855 | |
856 | =back |
857 | |
858 | Will get information from the config file by default. |
859 | |
860 | Returns a tree on success, false on failure. |
861 | |
862 | =cut |
863 | |
864 | sub __create_dslip_tree { |
865 | my $self = shift; |
866 | my %hash = @_; |
867 | my $conf = $self->configure_object; |
868 | |
869 | my $tmpl = { |
870 | path => { default => $conf->get_conf('base') }, |
871 | verbose => { default => $conf->get_conf('verbose') }, |
872 | uptodate => { default => 0 }, |
873 | }; |
874 | |
875 | my $args = check( $tmpl, \%hash ) or return; |
876 | |
877 | ### get the file name of the source ### |
878 | my $file = File::Spec->catfile($args->{path}, $conf->_get_source('dslip')); |
879 | |
880 | ### extract the file ### |
881 | my $ae = Archive::Extract->new( archive => $file ) or return; |
882 | my $out = STRIP_GZ_SUFFIX->($file); |
883 | |
884 | ### make sure to set the PREFER_BIN flag if desired ### |
885 | { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin'); |
886 | $ae->extract( to => $out ) or return; |
887 | } |
888 | |
889 | my $in = $self->_get_file_contents( file => $out ) or return; |
890 | |
891 | ### don't need it anymore ### |
892 | unlink $out; |
893 | |
894 | |
895 | ### get rid of the comments and the code ### |
896 | ### need a smarter parser, some people have this in their dslip info: |
897 | # [ |
898 | # 'Statistics::LTU', |
899 | # 'R', |
900 | # 'd', |
901 | # 'p', |
902 | # 'O', |
903 | # '?', |
904 | # 'Implements Linear Threshold Units', |
905 | # ...skipping... |
906 | # "\x{c4}dd \x{fc}ml\x{e4}\x{fc}ts t\x{f6} \x{eb}v\x{eb}r\x{ff}th\x{ef}ng!", |
907 | # 'BENNIE', |
908 | # '11' |
909 | # ], |
910 | ### also, older versions say: |
911 | ### $cols = [....] |
912 | ### and newer versions say: |
913 | ### $CPANPLUS::Modulelist::cols = [...] |
914 | ### split '$cols' and '$data' into 2 variables ### |
915 | ### use this regex to make sure dslips with ';' in them don't cause |
916 | ### parser errors |
917 | my ($ds_one, $ds_two) = ($in =~ m|.+}\s+ |
918 | (\$(?:CPAN::Modulelist::)?cols.*?) |
919 | (\$(?:CPAN::Modulelist::)?data.*) |
920 | |sx); |
921 | |
922 | ### eval them into existence ### |
923 | ### still not too fond of this solution - kane ### |
924 | my ($cols, $data); |
925 | { #local $@; can't use this, it's buggy -kane |
926 | |
927 | $cols = eval $ds_one; |
928 | error( loc("Error in eval of dslip source files: %1", $@) ) if $@; |
929 | |
930 | $data = eval $ds_two; |
931 | error( loc("Error in eval of dslip source files: %1", $@) ) if $@; |
932 | |
933 | } |
934 | |
935 | my $tree = {}; |
936 | my $primary = "modid"; |
937 | |
938 | ### this comes from CPAN::Modulelist |
939 | ### which is in 03modlist.data.gz |
940 | for (@$data){ |
941 | my %hash; |
942 | @hash{@$cols} = @$_; |
943 | $tree->{$hash{$primary}} = \%hash; |
944 | } |
945 | |
946 | return $tree; |
947 | |
948 | } #__create_dslip_tree |
949 | |
950 | =pod |
951 | |
952 | =head2 $cb->_dslip_defs () |
953 | |
954 | This function returns the definition structure (ARRAYREF) of the |
955 | dslip tree. |
956 | |
957 | =cut |
958 | |
959 | ### these are the definitions used for dslip info |
960 | ### they shouldn't change over time.. so hardcoding them doesn't appear to |
961 | ### be a problem. if it is, we need to parse 03modlist.data better to filter |
962 | ### all this out. |
963 | ### right now, this is just used to look up dslip info from a module |
964 | sub _dslip_defs { |
965 | my $self = shift; |
966 | |
967 | my $aref = [ |
968 | |
969 | # D |
970 | [ q|Development Stage|, { |
971 | i => loc('Idea, listed to gain consensus or as a placeholder'), |
972 | c => loc('under construction but pre-alpha (not yet released)'), |
973 | a => loc('Alpha testing'), |
974 | b => loc('Beta testing'), |
975 | R => loc('Released'), |
976 | M => loc('Mature (no rigorous definition)'), |
977 | S => loc('Standard, supplied with Perl 5'), |
978 | }], |
979 | |
980 | # S |
981 | [ q|Support Level|, { |
982 | m => loc('Mailing-list'), |
983 | d => loc('Developer'), |
984 | u => loc('Usenet newsgroup comp.lang.perl.modules'), |
985 | n => loc('None known, try comp.lang.perl.modules'), |
986 | a => loc('Abandoned; volunteers welcome to take over maintainance'), |
987 | }], |
988 | |
989 | # L |
990 | [ q|Language Used|, { |
991 | p => loc('Perl-only, no compiler needed, should be platform independent'), |
992 | c => loc('C and perl, a C compiler will be needed'), |
993 | h => loc('Hybrid, written in perl with optional C code, no compiler needed'), |
994 | '+' => loc('C++ and perl, a C++ compiler will be needed'), |
995 | o => loc('perl and another language other than C or C++'), |
996 | }], |
997 | |
998 | # I |
999 | [ q|Interface Style|, { |
1000 | f => loc('plain Functions, no references used'), |
1001 | h => loc('hybrid, object and function interfaces available'), |
1002 | n => loc('no interface at all (huh?)'), |
1003 | r => loc('some use of unblessed References or ties'), |
1004 | O => loc('Object oriented using blessed references and/or inheritance'), |
1005 | }], |
1006 | |
1007 | # P |
1008 | [ q|Public License|, { |
1009 | p => loc('Standard-Perl: user may choose between GPL and Artistic'), |
1010 | g => loc('GPL: GNU General Public License'), |
1011 | l => loc('LGPL: "GNU Lesser General Public License" (previously known as "GNU Library General Public License")'), |
1012 | b => loc('BSD: The BSD License'), |
1013 | a => loc('Artistic license alone'), |
1014 | o => loc('other (but distribution allowed without restrictions)'), |
1015 | }], |
1016 | ]; |
1017 | |
1018 | return $aref; |
1019 | } |
1020 | |
5bc5f6dc |
1021 | =head2 $file = $cb->_add_custom_module_source( uri => URI, [verbose => BOOL] ); |
1022 | |
1023 | Adds a custom source index and updates it based on the provided URI. |
1024 | |
1025 | Returns the full path to the index file on success or false on failure. |
1026 | |
1027 | =cut |
1028 | |
1029 | sub _add_custom_module_source { |
1030 | my $self = shift; |
1031 | my $conf = $self->configure_object; |
1032 | my %hash = @_; |
1033 | |
1034 | my($verbose,$uri); |
1035 | my $tmpl = { |
1036 | verbose => { default => $conf->get_conf('verbose'), |
1037 | store => \$verbose }, |
1038 | uri => { required => 1, store => \$uri } |
1039 | }; |
1040 | |
1041 | check( $tmpl, \%hash ) or return; |
1042 | |
1043 | my $index = File::Spec->catfile( |
1044 | $conf->get_conf('base'), |
1045 | $conf->_get_build('custom_sources'), |
1046 | $self->_uri_encode( uri => $uri ), |
1047 | ); |
1048 | |
1049 | ### already have it. |
1050 | if( IS_FILE->( $index ) ) { |
1051 | msg(loc("Source '%1' already added", $uri)); |
1052 | return 1; |
1053 | } |
1054 | |
1055 | ### do we need to create the targe dir? |
1056 | { my $dir = dirname( $index ); |
1057 | unless( IS_DIR->( $dir ) ) { |
1058 | $self->_mkdir( dir => $dir ) or return |
1059 | } |
1060 | } |
1061 | |
1062 | ### write the file |
1063 | my $fh = OPEN_FILE->( $index => '>' ) or do { |
1064 | error(loc("Could not write index file for '%1'", $uri)); |
1065 | return; |
1066 | }; |
1067 | |
1068 | ### basically we 'touched' it. |
1069 | close $fh; |
1070 | |
1071 | $self->__update_custom_module_source( |
1072 | remote => $uri, |
1073 | local => $index, |
1074 | verbose => $verbose, |
1075 | ) or do { |
1076 | ### we faild to update it, we probably have an empty |
1077 | ### possibly silly filename on disk now -- remove it |
1078 | 1 while unlink $index; |
1079 | return; |
1080 | }; |
1081 | |
1082 | return $index; |
1083 | } |
1084 | |
1085 | =head2 $file = $cb->_remove_custom_module_source( uri => URI, [verbose => BOOL] ); |
1086 | |
1087 | Removes a custom index file based on the URI provided. |
1088 | |
1089 | Returns the full path to the index file on success or false on failure. |
1090 | |
1091 | =cut |
1092 | |
1093 | sub _remove_custom_module_source { |
1094 | my $self = shift; |
1095 | my $conf = $self->configure_object; |
1096 | my %hash = @_; |
1097 | |
1098 | my($verbose,$uri); |
1099 | my $tmpl = { |
1100 | verbose => { default => $conf->get_conf('verbose'), |
1101 | store => \$verbose }, |
1102 | uri => { required => 1, store => \$uri } |
1103 | }; |
1104 | |
1105 | check( $tmpl, \%hash ) or return; |
1106 | |
1107 | ### use uri => local, instead of the other way around |
1108 | my %files = reverse $self->__list_custom_module_sources; |
1109 | |
1110 | my $file = $files{ $uri } or do { |
1111 | error(loc("No such custom source '%1'", $uri)); |
1112 | return; |
1113 | }; |
1114 | |
1115 | 1 while unlink $file; |
1116 | |
1117 | if( IS_FILE->( $file ) ) { |
1118 | error(loc("Could not remove index file '%1' for custom source '%2'", |
1119 | $file, $uri)); |
1120 | return; |
1121 | } |
1122 | |
1123 | msg(loc("Successfully removed index file for '%1'", $uri), $verbose); |
1124 | |
1125 | return $file; |
1126 | } |
1127 | |
1128 | =head2 %files = $cb->__list_custom_module_sources |
1129 | |
1130 | This method scans the 'custom-sources' directory in your base directory |
1131 | for additional sources to include in your module tree. |
1132 | |
1133 | Returns a list of key value pairs as follows: |
1134 | |
1135 | /full/path/to/source/file%3Fencoded => http://decoded/mirror/path |
1136 | |
1137 | =cut |
1138 | |
1139 | sub __list_custom_module_sources { |
1140 | my $self = shift; |
1141 | my $conf = $self->configure_object; |
1142 | |
1143 | my $dir = File::Spec->catdir( |
1144 | $conf->get_conf('base'), |
1145 | $conf->_get_build('custom_sources'), |
1146 | ); |
1147 | |
1148 | unless( IS_DIR->( $dir ) ) { |
1149 | msg(loc("No '%1' dir, skipping custom sources", $dir)); |
1150 | return; |
1151 | } |
1152 | |
1153 | ### unencode the files |
1154 | ### skip ones starting with # though |
1155 | my %files = map { |
1156 | my $org = $_; |
1157 | my $dec = $self->_uri_decode( uri => $_ ); |
1158 | File::Spec->catfile( $dir, $org ) => $dec |
1159 | } grep { $_ !~ /^#/ } READ_DIR->( $dir ); |
1160 | |
1161 | return %files; |
1162 | } |
1163 | |
1164 | =head2 $bool = $cb->__update_custom_module_sources( [verbose => BOOL] ); |
1165 | |
1166 | Attempts to update all the index files to your custom module sources. |
1167 | |
1168 | If the index is missing, and it's a C<file://> uri, it will generate |
1169 | a new local index for you. |
1170 | |
1171 | Return true on success, false on failure. |
1172 | |
1173 | =cut |
1174 | |
1175 | sub __update_custom_module_sources { |
1176 | my $self = shift; |
1177 | my $conf = $self->configure_object; |
1178 | my %hash = @_; |
1179 | |
1180 | my $verbose; |
1181 | my $tmpl = { |
1182 | verbose => { default => $conf->get_conf('verbose'), |
1183 | store => \$verbose } |
1184 | }; |
1185 | |
1186 | check( $tmpl, \%hash ) or return; |
1187 | |
1188 | my %files = $self->__list_custom_module_sources; |
1189 | |
1190 | ### uptodate check has been done a few levels up. |
1191 | my $fail; |
1192 | while( my($local,$remote) = each %files ) { |
1193 | |
1194 | $self->__update_custom_module_source( |
1195 | remote => $remote, |
1196 | local => $local, |
1197 | verbose => $verbose, |
1198 | ) or ( $fail++, next ); |
1199 | } |
1200 | |
1201 | error(loc("Failed updating one or more remote sources files")) if $fail; |
1202 | |
1203 | return if $fail; |
1204 | return 1; |
1205 | } |
1206 | |
1207 | =head2 $ok = $cb->__update_custom_module_source |
1208 | |
1209 | Attempts to update all the index files to your custom module sources. |
1210 | |
1211 | If the index is missing, and it's a C<file://> uri, it will generate |
1212 | a new local index for you. |
1213 | |
1214 | Return true on success, false on failure. |
1215 | |
1216 | =cut |
1217 | |
1218 | sub __update_custom_module_source { |
1219 | my $self = shift; |
1220 | my $conf = $self->configure_object; |
1221 | my %hash = @_; |
1222 | |
1223 | my($verbose,$local,$remote); |
1224 | my $tmpl = { |
1225 | verbose => { default => $conf->get_conf('verbose'), |
1226 | store => \$verbose }, |
1227 | local => { store => \$local, allow => FILE_EXISTS }, |
1228 | remote => { required => 1, store => \$remote }, |
1229 | }; |
1230 | |
1231 | check( $tmpl, \%hash ) or return; |
1232 | |
1233 | msg( loc("Updating sources from '%1'", $remote), $verbose); |
1234 | |
1235 | ### if you didn't provide a local file, we'll look in your custom |
1236 | ### dir to find the local encoded version for you |
1237 | $local ||= do { |
1238 | ### find all files we know of |
1239 | my %files = reverse $self->__list_custom_module_sources or do { |
1240 | error(loc("No custom modules sources defined -- need '%1' argument", |
1241 | 'local')); |
1242 | return; |
1243 | }; |
1244 | |
1245 | ### return the local file we're supposed to use |
1246 | $files{ $remote } or do { |
1247 | error(loc("Remote source '%1' unknown -- needs '%2' argument", |
1248 | $remote, 'local')); |
1249 | return; |
1250 | }; |
1251 | }; |
1252 | |
1253 | my $uri = join '/', $remote, $conf->_get_source('custom_index'); |
1254 | my $ff = File::Fetch->new( uri => $uri ); |
5a5ddb34 |
1255 | |
1256 | ### tempdir doesn't clean up by default, as opposed to tempfile() |
1257 | ### so add it explicitly. |
1258 | my $dir = tempdir( CLEANUP => 1 ); |
1259 | |
5bc5f6dc |
1260 | my $res = do { local $File::Fetch::WARN = 0; |
1261 | local $File::Fetch::WARN = 0; |
1262 | $ff->fetch( to => $dir ); |
1263 | }; |
1264 | |
1265 | ### couldn't get the file |
1266 | unless( $res ) { |
1267 | |
1268 | ### it's not a local scheme, so can't auto index |
1269 | unless( $ff->scheme eq 'file' ) { |
1270 | error(loc("Could not update sources from '%1': %2", |
1271 | $remote, $ff->error )); |
1272 | return; |
1273 | |
1274 | ### it's a local uri, we can index it ourselves |
1275 | } else { |
1276 | msg(loc("No index file found at '%1', generating one", |
1277 | $ff->uri), $verbose ); |
1278 | |
1279 | $self->__write_custom_module_index( |
1280 | path => File::Spec->catdir( |
1281 | File::Spec::Unix->splitdir( $ff->path ) |
1282 | ), |
1283 | to => $local, |
1284 | verbose => $verbose, |
1285 | ) or return; |
1286 | |
1287 | ### XXX don't write that here, __write_custom_module_index |
1288 | ### already prints this out |
1289 | #msg(loc("Index file written to '%1'", $to), $verbose); |
1290 | } |
1291 | |
1292 | ### copy it to the real spot and update it's timestamp |
1293 | } else { |
1294 | $self->_move( file => $res, to => $local ) or return; |
1295 | $self->_update_timestamp( file => $local ); |
1296 | |
1297 | msg(loc("Index file saved to '%1'", $local), $verbose); |
1298 | } |
1299 | |
1300 | return $local; |
1301 | } |
1302 | |
1303 | =head2 $bool = $cb->__write_custom_module_index( path => /path/to/packages, [to => /path/to/index/file, verbose => BOOL] ) |
1304 | |
1305 | Scans the C<path> you provided for packages and writes an index with all |
1306 | the available packages to C<$path/packages.txt>. If you'd like the index |
1307 | to be written to a different file, provide the C<to> argument. |
1308 | |
1309 | Returns true on success and false on failure. |
1310 | |
1311 | =cut |
1312 | |
1313 | sub __write_custom_module_index { |
1314 | my $self = shift; |
1315 | my $conf = $self->configure_object; |
1316 | my %hash = @_; |
1317 | |
1318 | my ($verbose, $path, $to); |
1319 | my $tmpl = { |
1320 | verbose => { default => $conf->get_conf('verbose'), |
1321 | store => \$verbose }, |
1322 | path => { required => 1, allow => DIR_EXISTS, store => \$path }, |
1323 | to => { store => \$to }, |
1324 | }; |
1325 | |
1326 | check( $tmpl, \%hash ) or return; |
1327 | |
1328 | ### no explicit to? then we'll use our default |
1329 | $to ||= File::Spec->catfile( $path, $conf->_get_source('custom_index') ); |
1330 | |
1331 | my @files; |
1332 | require File::Find; |
1333 | File::Find::find( sub { |
1334 | ### let's see if A::E can even parse it |
1335 | my $ae = do { |
1336 | local $Archive::Extract::WARN = 0; |
1337 | local $Archive::Extract::WARN = 0; |
1338 | Archive::Extract->new( archive => $File::Find::name ) |
1339 | } or return; |
1340 | |
1341 | ### it's a type A::E recognize, so we can add it |
1342 | $ae->type or return; |
1343 | |
1344 | ### neither $_ nor $File::Find::name have the chunk of the path in |
1345 | ### it starting $path -- it's either only the filename, or the full |
1346 | ### path, so we have to strip it ourselves |
1347 | ### make sure to remove the leading slash as well. |
1348 | my $copy = $File::Find::name; |
1349 | my $re = quotemeta($path); |
1350 | $copy =~ s|^$path[\\/]?||i; |
1351 | |
1352 | push @files, $copy; |
1353 | |
1354 | }, $path ); |
1355 | |
1356 | ### does the dir exist? if not, create it. |
1357 | { my $dir = dirname( $to ); |
1358 | unless( IS_DIR->( $dir ) ) { |
1359 | $self->_mkdir( dir => $dir ) or return |
1360 | } |
1361 | } |
1362 | |
1363 | ### create the index file |
1364 | my $fh = OPEN_FILE->( $to => '>' ) or return; |
1365 | |
1366 | print $fh "$_\n" for @files; |
1367 | close $fh; |
1368 | |
1369 | msg(loc("Successfully written index file to '%1'", $to), $verbose); |
1370 | |
1371 | return $to; |
1372 | } |
1373 | |
1374 | |
1375 | =head2 $bool = $cb->__create_custom_module_entries( [verbose => BOOL] ) |
1376 | |
1377 | Creates entries in the module tree based upon the files as returned |
1378 | by C<__list_custom_module_sources>. |
1379 | |
1380 | Returns true on success, false on failure. |
1381 | |
1382 | =cut |
1383 | |
1384 | ### use $auth_obj as a persistant version, so we don't have to recreate |
1385 | ### modules all the time |
1386 | { my $auth_obj; |
1387 | |
1388 | sub __create_custom_module_entries { |
1389 | my $self = shift; |
1390 | my $conf = $self->configure_object; |
1391 | my %hash = @_; |
1392 | |
1393 | my $verbose; |
1394 | my $tmpl = { |
1395 | verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, |
1396 | }; |
1397 | |
1398 | check( $tmpl, \%hash ) or return undef; |
1399 | |
1400 | my %files = $self->__list_custom_module_sources; |
1401 | |
1402 | while( my($file,$name) = each %files ) { |
1403 | |
1404 | msg(loc("Adding packages from custom source '%1'", $name), $verbose); |
1405 | |
1406 | my $fh = OPEN_FILE->( $file ) or next; |
1407 | |
1408 | while( <$fh> ) { |
1409 | chomp; |
1410 | next if /^#/; |
1411 | next unless /\S+/; |
1412 | |
1413 | ### join on / -- it's a URI after all! |
1414 | my $parse = join '/', $name, $_; |
1415 | |
1416 | ### try to make a module object out of it |
1417 | my $mod = $self->parse_module( module => $parse ) or ( |
1418 | error(loc("Could not parse '%1'", $_)), |
1419 | next |
1420 | ); |
1421 | |
1422 | ### mark this object with a custom author |
1423 | $auth_obj ||= do { |
1424 | my $id = CUSTOM_AUTHOR_ID; |
1425 | |
1426 | ### if the object is being created for the first time, |
1427 | ### make sure there's an entry in the author tree as |
1428 | ### well, so we can search on the CPAN ID |
1429 | $self->author_tree->{ $id } = |
1430 | CPANPLUS::Module::Author::Fake->new( cpanid => $id ); |
1431 | }; |
1432 | |
1433 | $mod->author( $auth_obj ); |
1434 | |
1435 | ### and now add it to the modlue tree -- this MAY |
1436 | ### override things of course |
1437 | if( $self->module_tree( $mod->module ) ) { |
1438 | msg(loc("About to overwrite module tree entry for '%1' with '%2'", |
1439 | $mod->module, $mod->package), $verbose); |
1440 | } |
1441 | |
1442 | ### mark where it came from |
1443 | $mod->description( loc("Custom source from '%1'",$name) ); |
1444 | |
1445 | ### store it in the module tree |
1446 | $self->module_tree->{ $mod->module } = $mod; |
1447 | } |
1448 | } |
1449 | |
1450 | return 1; |
1451 | } |
1452 | } |
1453 | |
1454 | |
6aaee015 |
1455 | # Local variables: |
1456 | # c-indentation-style: bsd |
1457 | # c-basic-offset: 4 |
1458 | # indent-tabs-mode: nil |
1459 | # End: |
1460 | # vim: expandtab shiftwidth=4: |
1461 | |
1462 | 1; |