File Coverage

lib/CPANPLUS/Internals/Source.pm
Criterion Covered Total %
statement 215 227 94.7
branch 60 100 60.0
condition 27 44 61.4
subroutine 24 24 100.0
pod n/a
total 326 395 82.5


line stmt bran cond sub pod time code
1             package CPANPLUS::Internals::Source;
2              
3 15     15   236 use strict;
  15         232  
  15         256  
4              
5 15     15   1066 use CPANPLUS::Error;
  15         216  
  15         242  
6 15     15   671 use CPANPLUS::Module;
  15         189  
  15         510  
7 15     15   599 use CPANPLUS::Module::Fake;
  15         942  
  15         509  
8 15     15   296 use CPANPLUS::Module::Author;
  15         185  
  15         269  
9 15     15   273 use CPANPLUS::Internals::Constants;
  15         138  
  15         347  
10              
11 15     15   654 use Archive::Extract;
  15         228  
  15         522  
12              
13 15     15   280 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
  15         141  
  15         499  
14 15     15   250 use Params::Check qw[check];
  15         141  
  15         527  
15 15     15   240 use IPC::Cmd qw[can_run];
  15         140  
  15         409  
16 15     15   266 use Module::Load::Conditional qw[can_load];
  15         136  
  15         278  
17              
18             $Params::Check::VERBOSE = 1;
19              
20             =pod
21            
22             =head1 NAME
23            
24             CPANPLUS::Internals::Source
25            
26             =head1 SYNOPSIS
27            
28             ### lazy load author/module trees ###
29            
30             $cb->_author_tree;
31             $cb->_module_tree;
32            
33             =head1 DESCRIPTION
34            
35             CPANPLUS::Internals::Source controls the updating of source files and
36             the parsing of them into usable module/author trees to be used by
37             C<CPANPLUS>.
38            
39             Functions exist to check if source files are still C<good to use> as
40             well as update them, and then parse them.
41            
42             The flow looks like this:
43            
44             $cb->_author_tree || $cb->_module_tree
45             $cb->__check_trees
46             $cb->__check_uptodate
47             $cb->_update_source
48             $cb->_build_trees
49             $cb->__create_author_tree
50             $cb->__retrieve_source
51             $cb->__create_module_tree
52             $cb->__retrieve_source
53             $cb->__create_dslip_tree
54             $cb->__retrieve_source
55             $cb->_save_source
56            
57             $cb->_dslip_defs
58            
59             =head1 METHODS
60            
61             =cut
62              
63             {
64                 my $recurse; # flag to prevent recursive calls to *_tree functions
65              
66             ### lazy loading of module tree
67                 sub _module_tree {
68 16503     16503   207384         my $self = $_[0];
69              
70 16503 100 66     264925         unless ($self->{_modtree} or $recurse++ > 0) {
71 6         606             my $uptodate = $self->_check_trees( @_[1..$#_] );
72 6         728             $self->_build_trees(uptodate => $uptodate);
73                     }
74              
75 16503         196430         $recurse--;
76 16503         277943         return $self->{_modtree};
77                 }
78              
79             ### lazy loading of author tree
80                 sub _author_tree {
81 370     370   5686         my $self = $_[0];
82              
83 370 50 33     5783         unless ($self->{_authortree} or $recurse++ > 0) {
84 0         0             my $uptodate = $self->_check_trees( @_[1..$#_] );
85 0         0             $self->_build_trees(uptodate => $uptodate);
86                     }
87              
88 370         4216         $recurse--;
89 370         6731         return $self->{_authortree};
90                 }
91              
92             }
93              
94             =pod
95            
96             =head2 $cb->_check_trees( [update_source => BOOL, path => PATH, verbose => BOOL] )
97            
98             Retrieve source files and return a boolean indicating whether or not
99             the source files are up to date.
100            
101             Takes several arguments:
102            
103             =over 4
104            
105             =item update_source
106            
107             A flag to force re-fetching of the source files, even
108             if they are still up to date.
109            
110             =item path
111            
112             The absolute path to the directory holding the source files.
113            
114             =item verbose
115            
116             A boolean flag indicating whether or not to be verbose.
117            
118             =back
119            
120             Will get information from the config file by default.
121            
122             =cut
123              
124             ### retrieve source files, and returns a boolean indicating if it's up to date
125             sub _check_trees {
126 25     25   659     my ($self, %hash) = @_;
127 25         2967     my $conf = $self->configure_object;
128              
129 25         287     my $update_source;
130 25         232     my $verbose;
131 25         337     my $path;
132              
133 25         568     my $tmpl = {
134                     path => { default => $conf->get_conf('base'),
135                                          store => \$path
136                                     },
137                     verbose => { default => $conf->get_conf('verbose'),
138                                          store => \$verbose
139                                     },
140                     update_source => { default => 0, store => \$update_source },
141                 };
142              
143 25 50       958     my $args = check( $tmpl, \%hash ) or return;
144              
145             ### if the user never wants to update their source without explicitly
146             ### telling us, shortcircuit here
147 25 50 33     492     return 1 if $conf->get_conf('no_update') && !$update_source;
148              
149             ### a check to see if our source files are still up to date ###
150 25         1257     msg( loc("Checking if source files are up to date"), $verbose );
151              
152 25         818     my $uptodate = 1; # default return value
153              
154 25         1073     for my $name (qw[auth dslip mod]) {
155 75         2804         for my $file ( $conf->_get_source( $name ) ) {
156 75 100       3784             $self->__check_uptodate(
157                             file => File::Spec->catfile( $args->{path}, $file ),
158                             name => $name,
159                             update_source => $update_source,
160                             verbose => $verbose,
161                         ) or $uptodate = 0;
162                     }
163                 }
164              
165 25         2722     return $uptodate;
166             }
167              
168             =pod
169            
170             =head2 $cb->__check_uptodate( file => $file, name => $name, [update_source => BOOL, verbose => BOOL] )
171            
172             C<__check_uptodate> checks if a given source file is still up-to-date
173             and if not, or when C<update_source> is true, will re-fetch the source
174             file.
175            
176             Takes the following arguments:
177            
178             =over 4
179            
180             =item file
181            
182             The source file to check.
183            
184             =item name
185            
186             The internal shortcut name for the source file (used for config
187             lookups).
188            
189             =item update_source
190            
191             Flag to force updating of sourcefiles regardless.
192            
193             =item verbose
194            
195             Boolean to indicate whether to be verbose or not.
196            
197             =back
198            
199             Returns a boolean value indicating whether the current files are up
200             to date or not.
201            
202             =cut
203              
204             ### this method checks whether or not the source files we are using are still up to date
205             sub __check_uptodate {
206 75     75   695     my $self = shift;
207 75         1729     my %hash = @_;
208 75         1277     my $conf = $self->configure_object;
209              
210              
211 75         1785     my $tmpl = {
212                     file => { required => 1 },
213                     name => { required => 1 },
214                     update_source => { default => 0 },
215                     verbose => { default => $conf->get_conf('verbose') },
216                 };
217              
218 75 50       1483     my $args = check( $tmpl, \%hash ) or return;
219              
220 75         684     my $flag;
221 75 100 66     6330     unless ( -e $args->{'file'} && (
222                         ( stat $args->{'file'} )[9]
223                         + $conf->_get_source('update') )
224                         > time ) {
225 3         26         $flag = 1;
226                 }
227              
228 75 100 100     2523     if ( $flag or $args->{'update_source'} ) {
229              
230 6 50       181          if ( $self->_update_source( name => $args->{'name'} ) ) {
231 6         1071               return 0; # return 0 so 'uptodate' will be set to 0, meaning no use
232             # of previously stored hashrefs!
233                      } else {
234 0         0               msg( loc("Unable to update source, attempting to get away with using old source file!"), $args->{verbose} );
235 0         0               return 1;
236                      }
237              
238                 } else {
239 69         1840         return 1;
240                 }
241             }
242              
243             =pod
244            
245             =head2 $cb->_update_source( name => $name, [path => $path, verbose => BOOL] )
246            
247             This method does the actual fetching of source files.
248            
249             It takes the following arguments:
250            
251             =over 4
252            
253             =item name
254            
255             The internal shortcut name for the source file (used for config
256             lookups).
257            
258             =item path
259            
260             The full path where to write the files.
261            
262             =item verbose
263            
264             Boolean to indicate whether to be verbose or not.
265            
266             =back
267            
268             Returns a boolean to indicate success.
269            
270             =cut
271              
272             ### this sub fetches new source files ###
273             sub _update_source {
274 9     9   204     my $self = shift;
275 9         195     my %hash = @_;
276 9         316     my $conf = $self->configure_object;
277              
278              
279 9         394     my $tmpl = {
280                     name => { required => 1 },
281                     path => { default => $conf->get_conf('base') },
282                     verbose => { default => $conf->get_conf('verbose') },
283                 };
284              
285 9 50       350     my $args = check( $tmpl, \%hash ) or return;
286              
287              
288 9         215     my $path = $args->{path};
289 9         213     my $now = time;
290              
291                 { ### this could use a clean up - Kane
292             ### no worries about the / -> we get it from the _ftp configuration, so
293             ### it's not platform dependant. -kane
294 9         77         my ($dir, $file) = $conf->_get_mirror( $args->{'name'} ) =~ m|(.+/)(.+)$|sg;
  9         282  
295              
296 9         608         msg( loc("Updating source file '%1'", $file), $args->{'verbose'} );
297              
298 9         618         my $fake = CPANPLUS::Module::Fake->new(
299                                     module => $args->{'name'},
300                                     path => $dir,
301                                     package => $file,
302                                     _id => $self->_id,
303                                 );
304              
305             ### can't use $fake->fetch here, since ->parent won't work --
306             ### the sources haven't been saved yet
307 9         753         my $rv = $self->_fetch(
308                                 module => $fake,
309                                 fetchdir => $path,
310                                 force => 1,
311                             );
312              
313              
314 9 50       352         unless ($rv) {
315 0         0             error( loc("Couldn't fetch '%1'", $file) );
316 0         0             return;
317                     }
318              
319             ### `touch` the file, so windoze knows it's new -jmb
320             ### works on *nix too, good fix -Kane
321 9 50       238         utime ( $now, $now, File::Spec->catfile($path, $file) ) or
322                         error( loc("Couldn't touch %1", $file) );
323              
324                 }
325 9         6637     return 1;
326             }
327              
328             =pod
329            
330             =head2 $cb->_build_trees( uptodate => BOOL, [use_stored => BOOL, path => $path, verbose => BOOL] )
331            
332             This method rebuilds the author- and module-trees from source.
333            
334             It takes the following arguments:
335            
336             =over 4
337            
338             =item uptodate
339            
340             Indicates whether any on disk caches are still ok to use.
341            
342             =item path
343            
344             The absolute path to the directory holding the source files.
345            
346             =item verbose
347            
348             A boolean flag indicating whether or not to be verbose.
349            
350             =item use_stored
351            
352             A boolean flag indicating whether or not it is ok to use previously
353             stored trees. Defaults to true.
354            
355             =back
356            
357             Returns a boolean indicating success.
358            
359             =cut
360              
361             ### (re)build the trees ###
362             sub _build_trees {
363 25     25   1033     my ($self, %hash) = @_;
364 25         603     my $conf = $self->configure_object;
365              
366 25         280     my($path,$uptodate,$use_stored);
367 25         627     my $tmpl = {
368                     path => { default => $conf->get_conf('base'), store => \$path },
369                     verbose => { default => $conf->get_conf('verbose') },
370                     uptodate => { required => 1, store => \$uptodate },
371                     use_stored => { default => 1, store => \$use_stored },
372                 };
373              
374 25 50       624     my $args = check( $tmpl, \%hash ) or return undef;
375              
376             ### retrieve the stored source files ###
377 25   100     2023     my $stored = $self->__retrieve_source(
      100        
378                                         path => $path,
379                                         uptodate => $uptodate && $use_stored,
380                                         verbose => $args->{'verbose'},
381                                     ) || {};
382              
383             ### build the trees ###
384 25   66     4090     $self->{_authortree} = $stored->{_authortree} ||
385                                         $self->__create_author_tree(
386                                                 uptodate => $uptodate,
387                                                 path => $path,
388                                                 verbose => $args->{verbose},
389                                             );
390 25   66     3362     $self->{_modtree} = $stored->{_modtree} ||
391                                         $self->_create_mod_tree(
392                                                 uptodate => $uptodate,
393                                                 path => $path,
394                                                 verbose => $args->{verbose},
395                                             );
396              
397             ### return if we weren't able to build the trees ###
398 25 50 33     4212     return unless $self->{_modtree} && $self->{_authortree};
399              
400             ### write the stored files to disk, so we can keep using them
401             ### from now on, till they become invalid
402             ### write them if the original sources weren't uptodate, or
403             ### we didn't just load storable files
404 25 100 100     5523     $self->_save_source() if !$uptodate or not keys %$stored;
405              
406             ### still necessary? can only run one instance now ###
407             ### will probably stay that way --kane
408             # my $id = $self->_store_id( $self );
409             #
410             # unless ( $id == $self->_id ) {
411             # error( loc("IDs do not match: %1 != %2. Storage failed!", $id, $self->_id) );
412             # }
413              
414 25         10079     return 1;
415             }
416              
417             =pod
418            
419             =head2 $cb->__retrieve_source(name => $name, [path => $path, uptodate => BOOL, verbose => BOOL])
420            
421             This method retrieves a I<storable>d tree identified by C<$name>.
422            
423             It takes the following arguments:
424            
425             =over 4
426            
427             =item name
428            
429             The internal name for the source file to retrieve.
430            
431             =item uptodate
432            
433             A flag indicating whether the file-cache is up-to-date or not.
434            
435             =item path
436            
437             The absolute path to the directory holding the source files.
438            
439             =item verbose
440            
441             A boolean flag indicating whether or not to be verbose.
442            
443             =back
444            
445             Will get information from the config file by default.
446            
447             Returns a tree on success, false on failure.
448            
449             =cut
450              
451             sub __retrieve_source {
452 25     25   302     my $self = shift;
453 25         382     my %hash = @_;
454 25         351     my $conf = $self->configure_object;
455              
456 25         438     my $tmpl = {
457                     path => { default => $conf->get_conf('base') },
458                     verbose => { default => $conf->get_conf('verbose') },
459                     uptodate => { default => 0 },
460                 };
461              
462 25 50       636     my $args = check( $tmpl, \%hash ) or return;
463              
464             ### check if we can retrieve a frozen data structure with storable ###
465 25 50       451     my $storable = can_load( modules => {'Storable' => '0.0'} )
466                                     if $conf->get_conf('storable');
467              
468 25 50       2642     return unless $storable;
469              
470             ### $stored is the name of the frozen data structure ###
471 25         2010     my $stored = $self->__storable_file( $args->{path} );
472              
473 25 100 33     9281     if ($storable && -e $stored && -s _ && $args->{'uptodate'}) {
      33        
      66        
474 5         671         msg( loc("Retrieving %1", $stored), $args->{'verbose'} );
475              
476 5         750         my $href = Storable::retrieve($stored);
477 5         627         return $href;
478                 } else {
479 20         11320         return;
480                 }
481             }
482              
483             =pod
484            
485             =head2 $cb->_save_source([verbose => BOOL, path => $path])
486            
487             This method saves all the parsed trees in I<storable>d format if
488             C<Storable> is available.
489            
490             It takes the following arguments:
491            
492             =over 4
493            
494             =item path
495            
496             The absolute path to the directory holding the source files.
497            
498             =item verbose
499            
500             A boolean flag indicating whether or not to be verbose.
501            
502             =back
503            
504             Will get information from the config file by default.
505            
506             Returns true on success, false on failure.
507            
508             =cut
509              
510             sub _save_source {
511 20     20   209     my $self = shift;
512 20         452     my %hash = @_;
513 20         930     my $conf = $self->configure_object;
514              
515              
516 20         393     my $tmpl = {
517                     path => { default => $conf->get_conf('base'), allow => DIR_EXISTS },
518                     verbose => { default => $conf->get_conf('verbose') },
519                     force => { default => 1 },
520                 };
521              
522 20 50       363     my $args = check( $tmpl, \%hash ) or return;
523              
524 20         240     my $aref = [qw[_modtree _authortree]];
525              
526             ### check if we can retrieve a frozen data structure with storable ###
527 20         214     my $storable;
528 20 50       322     $storable = can_load( modules => {'Storable' => '0.0'} )
529                                 if $conf->get_conf('storable');
530 20 50       4521     return unless $storable;
531              
532 20         199     my $to_write = {};
533 20         579     foreach my $key ( @$aref ) {
534 40 50       463         next unless ref( $self->{$key} );
535 40         1068         $to_write->{$key} = $self->{$key};
536                 }
537              
538 20 50       228     return unless keys %$to_write;
539              
540             ### $stored is the name of the frozen data structure ###
541 20         1134     my $stored = $self->__storable_file( $args->{path} );
542              
543 20 50 33     6528     if (-e $stored && not -w $stored) {
544 0         0         msg( loc("%1 not writable; skipped.", $stored), $args->{'verbose'} );
545 0         0         return;
546                 }
547              
548 20         2096     msg( loc("Writing compiled source information to disk. This might take a little while."),
549             $args->{'verbose'} );
550              
551 20         1725     my $flag;
552 20 50       1920     unless( Storable::nstore( $to_write, $stored ) ) {
553 0         0         error( loc("could not store %1!", $stored) );
554 0         0         $flag++;
555                 }
556              
557 20 50       4173     return $flag ? 0 : 1;
558             }
559              
560             sub __storable_file {
561 45     45   769     my $self = shift;
562 45         923     my $conf = $self->configure_object;
563 45 50       955     my $path = shift or return;
564              
565             ### check if we can retrieve a frozen data structure with storable ###
566 45 50       973     my $storable = $conf->get_conf('storable')
567                                     ? can_load( modules => {'Storable' => '0.0'} )
568                                     : 0;
569              
570 45 50       3272     return unless $storable;
571                 
572             ### $stored is the name of the frozen data structure ###
573             ### changed to use File::Spec->catfile -jmb
574 45         1046     my $stored = File::Spec->rel2abs(
575                     File::Spec->catfile(
576                         $path, #base dir
577                         $conf->_get_source('stored') #file
578                         . '.' .
579                         $Storable::VERSION #the version of storable
580                         . '.stored' #append a suffix
581                     )
582                 );
583              
584 45         9385     return $stored;
585             }
586              
587             =pod
588            
589             =head2 $cb->__create_author_tree([path => $path, uptodate => BOOL, verbose => BOOL])
590            
591             This method opens a source files and parses its contents into a
592             searchable author-tree or restores a file-cached version of a
593             previous parse, if the sources are uptodate and the file-cache exists.
594            
595             It takes the following arguments:
596            
597             =over 4
598            
599             =item uptodate
600            
601             A flag indicating whether the file-cache is uptodate or not.
602            
603             =item path
604            
605             The absolute path to the directory holding the source files.
606            
607             =item verbose
608            
609             A boolean flag indicating whether or not to be verbose.
610            
611             =back
612            
613             Will get information from the config file by default.
614            
615             Returns a tree on success, false on failure.
616            
617             =cut
618              
619             sub __create_author_tree() {
620 20     20   403     my $self = shift;
621 20         690     my %hash = @_;
622 20         1879     my $conf = $self->configure_object;
623              
624              
625 20         3203     my $tmpl = {
626                     path => { default => $conf->get_conf('base') },
627                     verbose => { default => $conf->get_conf('verbose') },
628                     uptodate => { default => 0 },
629                 };
630              
631 20 50       2205     my $args = check( $tmpl, \%hash ) or return;
632 20         367     my $tree = {};
633 20         478     my $file = File::Spec->catfile(
634                                             $args->{path},
635                                             $conf->_get_source('auth')
636                                         );
637              
638 20         1876     msg(loc("Rebuilding author tree, this might take a while"),
639                     $args->{verbose});
640              
641             ### extract the file ###
642 20 50       3556     my $ae = Archive::Extract->new( archive => $file ) or return;
643 20         16027     my $out = STRIP_GZ_SUFFIX->($file);
644              
645             ### make sure to set the PREFER_BIN flag if desired ###
646 20         352     { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin');
  20         2494  
647 20 50       1226         $ae->extract( to => $out ) or return;
648                 }
649              
650 20 50       10000     my $cont = $self->_get_file_contents( file => $out ) or return;
651              
652             ### don't need it anymore ###
653 20         4087     unlink $out;
654              
655 20         1197     for ( split /\n/, $cont ) {
656 160         7984         my($id, $name, $email) = m/^alias \s+
657             (\S+) \s+
658             "\s* ([^\"\<]+?) \s* <(.+)> \s*"
659             /x;
660              
661 160         6272         $tree->{$id} = CPANPLUS::Module::Author->new(
662                         author => $name, #authors name
663                         email => $email, #authors email address
664                         cpanid => $id, #authors CPAN ID
665                         _id => $self->_id, #id of this internals object
666                     );
667                 }
668              
669 20         8686     return $tree;
670              
671             } #__create_author_tree
672              
673             =pod
674            
675             =head2 $cb->_create_mod_tree([path => $path, uptodate => BOOL, verbose => BOOL])
676            
677             This method opens a source files and parses its contents into a
678             searchable module-tree or restores a file-cached version of a
679             previous parse, if the sources are uptodate and the file-cache exists.
680            
681             It takes the following arguments:
682            
683             =over 4
684            
685             =item uptodate
686            
687             A flag indicating whether the file-cache is up-to-date or not.
688            
689             =item path
690            
691             The absolute path to the directory holding the source files.
692            
693             =item verbose
694            
695             A boolean flag indicating whether or not to be verbose.
696            
697             =back
698            
699             Will get information from the config file by default.
700            
701             Returns a tree on success, false on failure.
702            
703             =cut
704              
705             ### this builds a hash reference with the structure of the cpan module tree ###
706             sub _create_mod_tree {
707 20     20   259     my $self = shift;
708 20         296     my %hash = @_;
709 20         1552     my $conf = $self->configure_object;
710              
711              
712 20         2873     my $tmpl = {
713                     path => { default => $conf->get_conf('base') },
714                     verbose => { default => $conf->get_conf('verbose') },
715                     uptodate => { default => 0 },
716                 };
717              
718 20 50       427     my $args = check( $tmpl, \%hash ) or return undef;
719 20         592     my $file = File::Spec->catfile($args->{path}, $conf->_get_source('mod'));
720              
721 20         1894     msg(loc("Rebuilding module tree, this might take a while"),
722                     $args->{verbose});
723              
724              
725 20         1223     my $dslip_tree = $self->__create_dslip_tree( %$args );
726              
727             ### extract the file ###
728 20 50       2740     my $ae = Archive::Extract->new( archive => $file ) or return;
729 20         14485     my $out = STRIP_GZ_SUFFIX->($file);
730              
731             ### make sure to set the PREFER_BIN flag if desired ###
732 20         471     { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin');
  20         3052  
733 20 50       1184         $ae->extract( to => $out ) or return;
734                 }
735              
736 20 50       2558     my $cont = $self->_get_file_contents( file => $out ) or return;
737              
738             ### don't need it anymore ###
739 20         3660     unlink $out;
740              
741 20         960     my $tree = {};
742 20         366     my $flag;
743              
744 20         1054     for ( split /\n/, $cont ) {
745              
746             ### quick hack to read past the header of the file ###
747             ### this is still rather evil... fix some time - Kane
748 380 100       6090         $flag = 1 if m|^\s*$|;
749 380 100       4129         next unless $flag;
750              
751             ### skip empty lines ###
752 220 100       5587         next unless /\S/;
753 180         1979         chomp;
754              
755 180         5671         my @data = split /\s+/;
756              
757             ### filter out the author and filename as well ###
758             ### authors can apparently have digits in their names,
759             ### and dirs can have dots... blah!
760 180         6400         my ($author, $package) = $data[2] =~
761                             m| [A-Z\d-]/
762             [A-Z\d-]{2}/
763             ([A-Z\d-]+) (?:/[\S]+)?/
764             ([^/]+)$
765             |xsg;
766              
767             ### remove file name from the path
768 180         2770         $data[2] =~ s|/[^/]+$||;
769              
770              
771 180 50       4361         unless( $self->author_tree($author) ) {
772 0         0             error( loc( "No such author '%1' -- can't make module object " .
773                                     "'%2' that is supposed to belong to this author",
774                                     $author, $data[0] ) );
775 0         0             next;
776                     }
777              
778             ### adding the dslip info
779             ### probably can use some optimization
780 180         1626         my $dslip;
781 180         2170         for my $item ( qw[ statd stats statl stati statp ] ) {
782             ### checking if there's an entry in the dslip info before
783             ### catting it on. appeasing warnings this way
784 900 100       14924             $dslip .= $dslip_tree->{ $data[0] }->{$item}
785                                         ? $dslip_tree->{ $data[0] }->{$item}
786                                         : ' ';
787                     }
788              
789             ### Every module get's stored as a module object ###
790 180 50       7066         $tree->{ $data[0] } = CPANPLUS::Module->new(
791                             module => $data[0], # full module name
792                             version => ($data[1] eq 'undef' # version number
793                                                 ? '0.0'
794                                                 : $data[1]),
795                             path => File::Spec::Unix->catfile(
796                                                 $conf->_get_mirror('base'),
797                                                 $data[2],
798                                             ), # extended path on the cpan mirror,
799             # like /A/AB/ABIGAIL
800                             comment => $data[3], # comment on the module
801                             author => $self->author_tree($author),
802                             package => $package, # package name, like
803             # 'foo-bar-baz-1.03.tar.gz'
804                             description => $dslip_tree->{ $data[0] }->{'description'},
805                             dslip => $dslip,
806                             _id => $self->_id, #id of this internals object
807                     );
808              
809                 } #for
810              
811 20         7982     return $tree;
812              
813             } #_create_mod_tree
814              
815             =pod
816            
817             =head2 $cb->__create_dslip_tree([path => $path, uptodate => BOOL, verbose => BOOL])
818            
819             This method opens a source files and parses its contents into a
820             searchable dslip-tree or restores a file-cached version of a
821             previous parse, if the sources are uptodate and the file-cache exists.
822            
823             It takes the following arguments:
824            
825             =over 4
826            
827             =item uptodate
828            
829             A flag indicating whether the file-cache is uptodate or not.
830            
831             =item path
832            
833             The absolute path to the directory holding the source files.
834            
835             =item verbose
836            
837             A boolean flag indicating whether or not to be verbose.
838            
839             =back
840            
841             Will get information from the config file by default.
842            
843             Returns a tree on success, false on failure.
844            
845             =cut
846              
847             sub __create_dslip_tree {
848 20     20   294     my $self = shift;
849 20         291     my %hash = @_;
850 20         287     my $conf = $self->configure_object;
851              
852 20         381     my $tmpl = {
853                     path => { default => $conf->get_conf('base') },
854                     verbose => { default => $conf->get_conf('verbose') },
855                     uptodate => { default => 0 },
856                 };
857              
858 20 50       2248     my $args = check( $tmpl, \%hash ) or return;
859              
860             ### get the file name of the source ###
861 20         1253     my $file = File::Spec->catfile($args->{path}, $conf->_get_source('dslip'));
862              
863             ### extract the file ###
864 20 50       1564     my $ae = Archive::Extract->new( archive => $file ) or return;
865 20         15218     my $out = STRIP_GZ_SUFFIX->($file);
866              
867             ### make sure to set the PREFER_BIN flag if desired ###
868 20         424     { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin');
  20         2638  
869 20 50       1045         $ae->extract( to => $out ) or return;
870                 }
871              
872 20 50       2504     my $in = $self->_get_file_contents( file => $out ) or return;
873              
874             ### don't need it anymore ###
875 20         3198     unlink $out;
876              
877              
878             ### get rid of the comments and the code ###
879             ### need a smarter parser, some people have this in their dslip info:
880             # [
881             # 'Statistics::LTU',
882             # 'R',
883             # 'd',
884             # 'p',
885             # 'O',
886             # '?',
887             # 'Implements Linear Threshold Units',
888             # ...skipping...
889             # "\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!",
890             # 'BENNIE',
891             # '11'
892             # ],
893             ### also, older versions say:
894             ### $cols = [....]
895             ### and newer versions say:
896             ### $CPANPLUS::Modulelist::cols = [...]
897             ### split '$cols' and '$data' into 2 variables ###
898             ### use this regex to make sure dslips with ';' in them don't cause
899             ### parser errors
900 20         2327     my ($ds_one, $ds_two) = ($in =~ m|.+}\s+
901             (\$(?:CPAN::Modulelist::)?cols.*?)
902             (\$(?:CPAN::Modulelist::)?data.*)
903             |sx);
904              
905             ### eval them into existence ###
906             ### still not too fond of this solution - kane ###
907 20         297     my ($cols, $data);
908                 { #local $@; can't use this, it's buggy -kane
909              
910 20         275         $cols = eval $ds_one;
  20         4238  
911 20 50       646         error( loc("Error in eval of dslip source files: %1", $@) ) if $@;
912              
913 20         1675         $data = eval $ds_two;
914 20 50       1289         error( loc("Error in eval of dslip source files: %1", $@) ) if $@;
915              
916                 }
917              
918 20         2467     my $tree = {};
919 20         426     my $primary = "modid";
920              
921             ### this comes from CPAN::Modulelist
922             ### which is in 03modlist.data.gz
923 20         499     for (@$data){
924 20         181         my %hash;
925 20         2321         @hash{@$cols} = @$_;
926 20         890         $tree->{$hash{$primary}} = \%hash;
927                 }
928              
929 20         8782     return $tree;
930              
931             } #__create_dslip_tree
932              
933             =pod
934            
935             =head2 $cb->_dslip_defs ()
936            
937             This function returns the definition structure (ARRAYREF) of the
938             dslip tree.
939            
940             =cut
941              
942             ### these are the definitions used for dslip info
943             ### they shouldn't change over time.. so hardcoding them doesn't appear to
944             ### be a problem. if it is, we need to parse 03modlist.data better to filter
945             ### all this out.
946             ### right now, this is just used to look up dslip info from a module
947             sub _dslip_defs {
948 10     10   134     my $self = shift;
949              
950 10         129     my $aref = [
951              
952             # D
953                     [ q|Development Stage|, {
954                         i => loc('Idea, listed to gain consensus or as a placeholder'),
955                         c => loc('under construction but pre-alpha (not yet released)'),
956                         a => loc('Alpha testing'),
957                         b => loc('Beta testing'),
958                         R => loc('Released'),
959                         M => loc('Mature (no rigorous definition)'),
960                         S => loc('Standard, supplied with Perl 5'),
961                     }],
962              
963             # S
964                     [ q|Support Level|, {
965                         m => loc('Mailing-list'),
966                         d => loc('Developer'),
967                         u => loc('Usenet newsgroup comp.lang.perl.modules'),
968                         n => loc('None known, try comp.lang.perl.modules'),
969                         a => loc('Abandoned; volunteers welcome to take over maintainance'),
970                     }],
971              
972             # L
973                     [ q|Language Used|, {
974                         p => loc('Perl-only, no compiler needed, should be platform independent'),
975                         c => loc('C and perl, a C compiler will be needed'),
976                         h => loc('Hybrid, written in perl with optional C code, no compiler needed'),
977                         '+' => loc('C++ and perl, a C++ compiler will be needed'),
978                         o => loc('perl and another language other than C or C++'),
979                     }],
980              
981             # I
982                     [ q|Interface Style|, {
983                         f => loc('plain Functions, no references used'),
984                         h => loc('hybrid, object and function interfaces available'),
985                         n => loc('no interface at all (huh?)'),
986                         r => loc('some use of unblessed References or ties'),
987                         O => loc('Object oriented using blessed references and/or inheritance'),
988                     }],
989              
990             # P
991                     [ q|Public License|, {
992                         p => loc('Standard-Perl: user may choose between GPL and Artistic'),
993                         g => loc('GPL: GNU General Public License'),
994                         l => loc('LGPL: "GNU Lesser General Public License" (previously known as "GNU Library General Public License")'),
995                         b => loc('BSD: The BSD License'),
996                         a => loc('Artistic license alone'),
997                         o => loc('other (but distribution allowed without restrictions)'),
998                     }],
999                 ];
1000              
1001 10         717     return $aref;
1002             }
1003              
1004             # Local variables:
1005             # c-indentation-style: bsd
1006             # c-basic-offset: 4
1007             # indent-tabs-mode: nil
1008             # End:
1009             # vim: expandtab shiftwidth=4:
1010              
1011             1;
1012