This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add CPANPLUS 0.78
[perl5.git] / lib / CPANPLUS / Internals / Source.pm
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
11 use Archive::Extract;
12
13 use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
14 use Params::Check               qw[check];
15 use IPC::Cmd                    qw[can_run];
16 use Module::Load::Conditional   qw[can_load];
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         my $self = $_[0];
69
70         unless ($self->{_modtree} or $recurse++ > 0) {
71             my $uptodate = $self->_check_trees( @_[1..$#_] );
72             $self->_build_trees(uptodate => $uptodate);
73         }
74
75         $recurse--;
76         return $self->{_modtree};
77     }
78
79     ### lazy loading of author tree
80     sub _author_tree {
81         my $self = $_[0];
82
83         unless ($self->{_authortree} or $recurse++ > 0) {
84             my $uptodate = $self->_check_trees( @_[1..$#_] );
85             $self->_build_trees(uptodate => $uptodate);
86         }
87
88         $recurse--;
89         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     my ($self, %hash) = @_;
127     my $conf          = $self->configure_object;
128
129     my $update_source;
130     my $verbose;
131     my $path;
132
133     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     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     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     msg( loc("Checking if source files are up to date"), $verbose );
151
152     my $uptodate = 1; # default return value
153
154     for my $name (qw[auth dslip mod]) {
155         for my $file ( $conf->_get_source( $name ) ) {
156             $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     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     my $self = shift;
207     my %hash = @_;
208     my $conf = $self->configure_object;
209
210
211     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     my $args = check( $tmpl, \%hash ) or return;
219
220     my $flag;
221     unless ( -e $args->{'file'} && (
222             ( stat $args->{'file'} )[9]
223             + $conf->_get_source('update') )
224             > time ) {
225         $flag = 1;
226     }
227
228     if ( $flag or $args->{'update_source'} ) {
229
230          if ( $self->_update_source( name => $args->{'name'} ) ) {
231               return 0;       # return 0 so 'uptodate' will be set to 0, meaning no use
232                               # of previously stored hashrefs!
233          } else {
234               msg( loc("Unable to update source, attempting to get away with using old source file!"), $args->{verbose} );
235               return 1;
236          }
237
238     } else {
239         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     my $self = shift;
275     my %hash = @_;
276     my $conf = $self->configure_object;
277
278
279     my $tmpl = {
280         name    => { required => 1 },
281         path    => { default => $conf->get_conf('base') },
282         verbose => { default => $conf->get_conf('verbose') },
283     };
284
285     my $args = check( $tmpl, \%hash ) or return;
286
287
288     my $path = $args->{path};
289     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         my ($dir, $file) = $conf->_get_mirror( $args->{'name'} ) =~ m|(.+/)(.+)$|sg;
295
296         msg( loc("Updating source file '%1'", $file), $args->{'verbose'} );
297
298         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         my $rv = $self->_fetch(
308                     module      => $fake,
309                     fetchdir    => $path,
310                     force       => 1,
311                 );
312
313
314         unless ($rv) {
315             error( loc("Couldn't fetch '%1'", $file) );
316             return;
317         }
318
319         ### `touch` the file, so windoze knows it's new -jmb
320         ### works on *nix too, good fix -Kane
321         utime ( $now, $now, File::Spec->catfile($path, $file) ) or
322             error( loc("Couldn't touch %1", $file) );
323
324     }
325     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     my ($self, %hash)   = @_;
364     my $conf            = $self->configure_object;
365
366     my($path,$uptodate,$use_stored);
367     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     my $args = check( $tmpl, \%hash ) or return undef;
375
376     ### retrieve the stored source files ###
377     my $stored      = $self->__retrieve_source(
378                             path        => $path,
379                             uptodate    => $uptodate && $use_stored,
380                             verbose     => $args->{'verbose'},
381                         ) || {};
382
383     ### build the trees ###
384     $self->{_authortree} =  $stored->{_authortree} ||
385                             $self->__create_author_tree(
386                                     uptodate    => $uptodate,
387                                     path        => $path,
388                                     verbose     => $args->{verbose},
389                                 );
390     $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     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     $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     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     my $self = shift;
453     my %hash = @_;
454     my $conf = $self->configure_object;
455
456     my $tmpl = {
457         path     => { default => $conf->get_conf('base') },
458         verbose  => { default => $conf->get_conf('verbose') },
459         uptodate => { default => 0 },
460     };
461
462     my $args = check( $tmpl, \%hash ) or return;
463
464     ### check if we can retrieve a frozen data structure with storable ###
465     my $storable = can_load( modules => {'Storable' => '0.0'} )
466                         if $conf->get_conf('storable');
467
468     return unless $storable;
469
470     ### $stored is the name of the frozen data structure ###
471     my $stored = $self->__storable_file( $args->{path} );
472
473     if ($storable && -e $stored && -s _ && $args->{'uptodate'}) {
474         msg( loc("Retrieving %1", $stored), $args->{'verbose'} );
475
476         my $href = Storable::retrieve($stored);
477         return $href;
478     } else {
479         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     my $self = shift;
512     my %hash = @_;
513     my $conf = $self->configure_object;
514
515
516     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     my $args = check( $tmpl, \%hash ) or return;
523
524     my $aref = [qw[_modtree _authortree]];
525
526     ### check if we can retrieve a frozen data structure with storable ###
527     my $storable;
528     $storable = can_load( modules => {'Storable' => '0.0'} )
529                     if $conf->get_conf('storable');
530     return unless $storable;
531
532     my $to_write = {};
533     foreach my $key ( @$aref ) {
534         next unless ref( $self->{$key} );
535         $to_write->{$key} = $self->{$key};
536     }
537
538     return unless keys %$to_write;
539
540     ### $stored is the name of the frozen data structure ###
541     my $stored = $self->__storable_file( $args->{path} );
542
543     if (-e $stored && not -w $stored) {
544         msg( loc("%1 not writable; skipped.", $stored), $args->{'verbose'} );
545         return;
546     }
547
548     msg( loc("Writing compiled source information to disk. This might take a little while."),
549             $args->{'verbose'} );
550
551     my $flag;
552     unless( Storable::nstore( $to_write, $stored ) ) {
553         error( loc("could not store %1!", $stored) );
554         $flag++;
555     }
556
557     return $flag ? 0 : 1;
558 }
559
560 sub __storable_file {
561     my $self = shift;
562     my $conf = $self->configure_object;
563     my $path = shift or return;
564
565     ### check if we can retrieve a frozen data structure with storable ###
566     my $storable = $conf->get_conf('storable')
567                         ? can_load( modules => {'Storable' => '0.0'} )
568                         : 0;
569
570     return unless $storable;
571     
572     ### $stored is the name of the frozen data structure ###
573     ### changed to use File::Spec->catfile -jmb
574     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     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     my $self = shift;
621     my %hash = @_;
622     my $conf = $self->configure_object;
623
624
625     my $tmpl = {
626         path     => { default => $conf->get_conf('base') },
627         verbose  => { default => $conf->get_conf('verbose') },
628         uptodate => { default => 0 },
629     };
630
631     my $args = check( $tmpl, \%hash ) or return;
632     my $tree = {};
633     my $file = File::Spec->catfile(
634                                 $args->{path},
635                                 $conf->_get_source('auth')
636                             );
637
638     msg(loc("Rebuilding author tree, this might take a while"),
639         $args->{verbose});
640
641     ### extract the file ###
642     my $ae      = Archive::Extract->new( archive => $file ) or return;
643     my $out     = STRIP_GZ_SUFFIX->($file);
644
645     ### make sure to set the PREFER_BIN flag if desired ###
646     {   local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin');
647         $ae->extract( to => $out )                              or return;
648     }
649
650     my $cont    = $self->_get_file_contents( file => $out ) or return;
651
652     ### don't need it anymore ###
653     unlink $out;
654
655     for ( split /\n/, $cont ) {
656         my($id, $name, $email) = m/^alias \s+
657                                     (\S+) \s+
658                                     "\s* ([^\"\<]+?) \s* <(.+)> \s*"
659                                 /x;
660
661         $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     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     my $self = shift;
708     my %hash = @_;
709     my $conf = $self->configure_object;
710
711
712     my $tmpl = {
713         path     => { default => $conf->get_conf('base') },
714         verbose  => { default => $conf->get_conf('verbose') },
715         uptodate => { default => 0 },
716     };
717
718     my $args = check( $tmpl, \%hash ) or return undef;
719     my $file = File::Spec->catfile($args->{path}, $conf->_get_source('mod'));
720
721     msg(loc("Rebuilding module tree, this might take a while"),
722         $args->{verbose});
723
724
725     my $dslip_tree = $self->__create_dslip_tree( %$args );
726
727     ### extract the file ###
728     my $ae      = Archive::Extract->new( archive => $file ) or return;
729     my $out     = STRIP_GZ_SUFFIX->($file);
730
731     ### make sure to set the PREFER_BIN flag if desired ###
732     {   local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin');
733         $ae->extract( to => $out )                              or return;
734     }
735
736     my $cont    = $self->_get_file_contents( file => $out ) or return;
737
738     ### don't need it anymore ###
739     unlink $out;
740
741     my $tree = {};
742     my $flag;
743
744     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         $flag = 1 if m|^\s*$|;
749         next unless $flag;
750
751         ### skip empty lines ###
752         next unless /\S/;
753         chomp;
754
755         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         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         $data[2] =~ s|/[^/]+$||;
769
770
771         unless( $self->author_tree($author) ) {
772             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             next;
776         }
777
778         ### adding the dslip info
779         ### probably can use some optimization
780         my $dslip;
781         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             $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         $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     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     my $self = shift;
849     my %hash = @_;
850     my $conf = $self->configure_object;
851
852     my $tmpl = {
853         path     => { default => $conf->get_conf('base') },
854         verbose  => { default => $conf->get_conf('verbose') },
855         uptodate => { default => 0 },
856     };
857
858     my $args = check( $tmpl, \%hash ) or return;
859
860     ### get the file name of the source ###
861     my $file = File::Spec->catfile($args->{path}, $conf->_get_source('dslip'));
862
863     ### extract the file ###
864     my $ae      = Archive::Extract->new( archive => $file ) or return;
865     my $out     = STRIP_GZ_SUFFIX->($file);
866
867     ### make sure to set the PREFER_BIN flag if desired ###
868     {   local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin');
869         $ae->extract( to => $out )                              or return;
870     }
871
872     my $in      = $self->_get_file_contents( file => $out ) or return;
873
874     ### don't need it anymore ###
875     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     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     my ($cols, $data);
908     {   #local $@; can't use this, it's buggy -kane
909
910         $cols = eval $ds_one;
911         error( loc("Error in eval of dslip source files: %1", $@) ) if $@;
912
913         $data = eval $ds_two;
914         error( loc("Error in eval of dslip source files: %1", $@) ) if $@;
915
916     }
917
918     my $tree = {};
919     my $primary = "modid";
920
921     ### this comes from CPAN::Modulelist
922     ### which is in 03modlist.data.gz
923     for (@$data){
924         my %hash;
925         @hash{@$cols} = @$_;
926         $tree->{$hash{$primary}} = \%hash;
927     }
928
929     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     my $self = shift;
949
950     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     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;