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