This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix a CPANPLUS test that fails when run on a read-only source tree
[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         ### make sure it is writable first, otherwise the `touch` will fail
322         unless (chmod ( 0644, File::Spec->catfile($path, $file) ) &&
323                 utime ( $now, $now, File::Spec->catfile($path, $file) )) {
324             error( loc("Couldn't touch %1", $file) );
325         }
326
327     }
328     return 1;
329 }
330
331 =pod
332
333 =head2 $cb->_build_trees( uptodate => BOOL, [use_stored => BOOL, path => $path, verbose => BOOL] )
334
335 This method rebuilds the author- and module-trees from source.
336
337 It takes the following arguments:
338
339 =over 4
340
341 =item uptodate
342
343 Indicates whether any on disk caches are still ok to use.
344
345 =item path
346
347 The absolute path to the directory holding the source files.
348
349 =item verbose
350
351 A boolean flag indicating whether or not to be verbose.
352
353 =item use_stored
354
355 A boolean flag indicating whether or not it is ok to use previously
356 stored trees. Defaults to true.
357
358 =back
359
360 Returns a boolean indicating success.
361
362 =cut
363
364 ### (re)build the trees ###
365 sub _build_trees {
366     my ($self, %hash)   = @_;
367     my $conf            = $self->configure_object;
368
369     my($path,$uptodate,$use_stored);
370     my $tmpl = {
371         path        => { default => $conf->get_conf('base'), store => \$path },
372         verbose     => { default => $conf->get_conf('verbose') },
373         uptodate    => { required => 1, store => \$uptodate },
374         use_stored  => { default => 1, store => \$use_stored },
375     };
376
377     my $args = check( $tmpl, \%hash ) or return undef;
378
379     ### retrieve the stored source files ###
380     my $stored      = $self->__retrieve_source(
381                             path        => $path,
382                             uptodate    => $uptodate && $use_stored,
383                             verbose     => $args->{'verbose'},
384                         ) || {};
385
386     ### build the trees ###
387     $self->{_authortree} =  $stored->{_authortree} ||
388                             $self->__create_author_tree(
389                                     uptodate    => $uptodate,
390                                     path        => $path,
391                                     verbose     => $args->{verbose},
392                                 );
393     $self->{_modtree}    =  $stored->{_modtree} ||
394                             $self->_create_mod_tree(
395                                     uptodate    => $uptodate,
396                                     path        => $path,
397                                     verbose     => $args->{verbose},
398                                 );
399
400     ### return if we weren't able to build the trees ###
401     return unless $self->{_modtree} && $self->{_authortree};
402
403     ### write the stored files to disk, so we can keep using them
404     ### from now on, till they become invalid
405     ### write them if the original sources weren't uptodate, or
406     ### we didn't just load storable files
407     $self->_save_source() if !$uptodate or not keys %$stored;
408
409     ### still necessary? can only run one instance now ###
410     ### will probably stay that way --kane
411 #     my $id = $self->_store_id( $self );
412 #
413 #     unless ( $id == $self->_id ) {
414 #         error( loc("IDs do not match: %1 != %2. Storage failed!", $id, $self->_id) );
415 #     }
416
417     return 1;
418 }
419
420 =pod
421
422 =head2 $cb->__retrieve_source(name => $name, [path => $path, uptodate => BOOL, verbose => BOOL])
423
424 This method retrieves a I<storable>d tree identified by C<$name>.
425
426 It takes the following arguments:
427
428 =over 4
429
430 =item name
431
432 The internal name for the source file to retrieve.
433
434 =item uptodate
435
436 A flag indicating whether the file-cache is up-to-date or not.
437
438 =item path
439
440 The absolute path to the directory holding the source files.
441
442 =item verbose
443
444 A boolean flag indicating whether or not to be verbose.
445
446 =back
447
448 Will get information from the config file by default.
449
450 Returns a tree on success, false on failure.
451
452 =cut
453
454 sub __retrieve_source {
455     my $self = shift;
456     my %hash = @_;
457     my $conf = $self->configure_object;
458
459     my $tmpl = {
460         path     => { default => $conf->get_conf('base') },
461         verbose  => { default => $conf->get_conf('verbose') },
462         uptodate => { default => 0 },
463     };
464
465     my $args = check( $tmpl, \%hash ) or return;
466
467     ### check if we can retrieve a frozen data structure with storable ###
468     my $storable = can_load( modules => {'Storable' => '0.0'} )
469                         if $conf->get_conf('storable');
470
471     return unless $storable;
472
473     ### $stored is the name of the frozen data structure ###
474     my $stored = $self->__storable_file( $args->{path} );
475
476     if ($storable && -e $stored && -s _ && $args->{'uptodate'}) {
477         msg( loc("Retrieving %1", $stored), $args->{'verbose'} );
478
479         my $href = Storable::retrieve($stored);
480         return $href;
481     } else {
482         return;
483     }
484 }
485
486 =pod
487
488 =head2 $cb->_save_source([verbose => BOOL, path => $path])
489
490 This method saves all the parsed trees in I<storable>d format if
491 C<Storable> is available.
492
493 It takes the following arguments:
494
495 =over 4
496
497 =item path
498
499 The absolute path to the directory holding the source files.
500
501 =item verbose
502
503 A boolean flag indicating whether or not to be verbose.
504
505 =back
506
507 Will get information from the config file by default.
508
509 Returns true on success, false on failure.
510
511 =cut
512
513 sub _save_source {
514     my $self = shift;
515     my %hash = @_;
516     my $conf = $self->configure_object;
517
518
519     my $tmpl = {
520         path     => { default => $conf->get_conf('base'), allow => DIR_EXISTS },
521         verbose  => { default => $conf->get_conf('verbose') },
522         force    => { default => 1 },
523     };
524
525     my $args = check( $tmpl, \%hash ) or return;
526
527     my $aref = [qw[_modtree _authortree]];
528
529     ### check if we can retrieve a frozen data structure with storable ###
530     my $storable;
531     $storable = can_load( modules => {'Storable' => '0.0'} )
532                     if $conf->get_conf('storable');
533     return unless $storable;
534
535     my $to_write = {};
536     foreach my $key ( @$aref ) {
537         next unless ref( $self->{$key} );
538         $to_write->{$key} = $self->{$key};
539     }
540
541     return unless keys %$to_write;
542
543     ### $stored is the name of the frozen data structure ###
544     my $stored = $self->__storable_file( $args->{path} );
545
546     if (-e $stored && not -w $stored) {
547         msg( loc("%1 not writable; skipped.", $stored), $args->{'verbose'} );
548         return;
549     }
550
551     msg( loc("Writing compiled source information to disk. This might take a little while."),
552             $args->{'verbose'} );
553
554     my $flag;
555     unless( Storable::nstore( $to_write, $stored ) ) {
556         error( loc("could not store %1!", $stored) );
557         $flag++;
558     }
559
560     return $flag ? 0 : 1;
561 }
562
563 sub __storable_file {
564     my $self = shift;
565     my $conf = $self->configure_object;
566     my $path = shift or return;
567
568     ### check if we can retrieve a frozen data structure with storable ###
569     my $storable = $conf->get_conf('storable')
570                         ? can_load( modules => {'Storable' => '0.0'} )
571                         : 0;
572
573     return unless $storable;
574     
575     ### $stored is the name of the frozen data structure ###
576     ### changed to use File::Spec->catfile -jmb
577     my $stored = File::Spec->rel2abs(
578         File::Spec->catfile(
579             $path,                          #base dir
580             $conf->_get_source('stored')    #file
581             . '.' .
582             $Storable::VERSION              #the version of storable 
583             . '.stored'                     #append a suffix
584         )
585     );
586
587     return $stored;
588 }
589
590 =pod
591
592 =head2 $cb->__create_author_tree([path => $path, uptodate => BOOL, verbose => BOOL])
593
594 This method opens a source files and parses its contents into a
595 searchable author-tree or restores a file-cached version of a
596 previous parse, if the sources are uptodate and the file-cache exists.
597
598 It takes the following arguments:
599
600 =over 4
601
602 =item uptodate
603
604 A flag indicating whether the file-cache is uptodate or not.
605
606 =item path
607
608 The absolute path to the directory holding the source files.
609
610 =item verbose
611
612 A boolean flag indicating whether or not to be verbose.
613
614 =back
615
616 Will get information from the config file by default.
617
618 Returns a tree on success, false on failure.
619
620 =cut
621
622 sub __create_author_tree() {
623     my $self = shift;
624     my %hash = @_;
625     my $conf = $self->configure_object;
626
627
628     my $tmpl = {
629         path     => { default => $conf->get_conf('base') },
630         verbose  => { default => $conf->get_conf('verbose') },
631         uptodate => { default => 0 },
632     };
633
634     my $args = check( $tmpl, \%hash ) or return;
635     my $tree = {};
636     my $file = File::Spec->catfile(
637                                 $args->{path},
638                                 $conf->_get_source('auth')
639                             );
640
641     msg(loc("Rebuilding author tree, this might take a while"),
642         $args->{verbose});
643
644     ### extract the file ###
645     my $ae      = Archive::Extract->new( archive => $file ) or return;
646     my $out     = STRIP_GZ_SUFFIX->($file);
647
648     ### make sure to set the PREFER_BIN flag if desired ###
649     {   local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin');
650         $ae->extract( to => $out )                              or return;
651     }
652
653     my $cont    = $self->_get_file_contents( file => $out ) or return;
654
655     ### don't need it anymore ###
656     unlink $out;
657
658     for ( split /\n/, $cont ) {
659         my($id, $name, $email) = m/^alias \s+
660                                     (\S+) \s+
661                                     "\s* ([^\"\<]+?) \s* <(.+)> \s*"
662                                 /x;
663
664         $tree->{$id} = CPANPLUS::Module::Author->new(
665             author  => $name,           #authors name
666             email   => $email,          #authors email address
667             cpanid  => $id,             #authors CPAN ID
668             _id     => $self->_id,    #id of this internals object
669         );
670     }
671
672     return $tree;
673
674 } #__create_author_tree
675
676 =pod
677
678 =head2 $cb->_create_mod_tree([path => $path, uptodate => BOOL, verbose => BOOL])
679
680 This method opens a source files and parses its contents into a
681 searchable module-tree or restores a file-cached version of a
682 previous parse, if the sources are uptodate and the file-cache exists.
683
684 It takes the following arguments:
685
686 =over 4
687
688 =item uptodate
689
690 A flag indicating whether the file-cache is up-to-date or not.
691
692 =item path
693
694 The absolute path to the directory holding the source files.
695
696 =item verbose
697
698 A boolean flag indicating whether or not to be verbose.
699
700 =back
701
702 Will get information from the config file by default.
703
704 Returns a tree on success, false on failure.
705
706 =cut
707
708 ### this builds a hash reference with the structure of the cpan module tree ###
709 sub _create_mod_tree {
710     my $self = shift;
711     my %hash = @_;
712     my $conf = $self->configure_object;
713
714
715     my $tmpl = {
716         path     => { default => $conf->get_conf('base') },
717         verbose  => { default => $conf->get_conf('verbose') },
718         uptodate => { default => 0 },
719     };
720
721     my $args = check( $tmpl, \%hash ) or return undef;
722     my $file = File::Spec->catfile($args->{path}, $conf->_get_source('mod'));
723
724     msg(loc("Rebuilding module tree, this might take a while"),
725         $args->{verbose});
726
727
728     my $dslip_tree = $self->__create_dslip_tree( %$args );
729
730     ### extract the file ###
731     my $ae      = Archive::Extract->new( archive => $file ) or return;
732     my $out     = STRIP_GZ_SUFFIX->($file);
733
734     ### make sure to set the PREFER_BIN flag if desired ###
735     {   local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin');
736         $ae->extract( to => $out )                              or return;
737     }
738
739     my $cont    = $self->_get_file_contents( file => $out ) or return;
740
741     ### don't need it anymore ###
742     unlink $out;
743
744     my $tree = {};
745     my $flag;
746
747     for ( split /\n/, $cont ) {
748
749         ### quick hack to read past the header of the file ###
750         ### this is still rather evil... fix some time - Kane
751         $flag = 1 if m|^\s*$|;
752         next unless $flag;
753
754         ### skip empty lines ###
755         next unless /\S/;
756         chomp;
757
758         my @data = split /\s+/;
759
760         ### filter out the author and filename as well ###
761         ### authors can apparently have digits in their names,
762         ### and dirs can have dots... blah!
763         my ($author, $package) = $data[2] =~
764                 m|  [A-Z\d-]/
765                     [A-Z\d-]{2}/
766                     ([A-Z\d-]+) (?:/[\S]+)?/
767                     ([^/]+)$
768                 |xsg;
769
770         ### remove file name from the path
771         $data[2] =~ s|/[^/]+$||;
772
773
774         unless( $self->author_tree($author) ) {
775             error( loc( "No such author '%1' -- can't make module object " .
776                         "'%2' that is supposed to belong to this author",
777                         $author, $data[0] ) );
778             next;
779         }
780
781         ### adding the dslip info
782         ### probably can use some optimization
783         my $dslip;
784         for my $item ( qw[ statd stats statl stati statp ] ) {
785             ### checking if there's an entry in the dslip info before
786             ### catting it on. appeasing warnings this way
787             $dslip .=   $dslip_tree->{ $data[0] }->{$item}
788                             ? $dslip_tree->{ $data[0] }->{$item}
789                             : ' ';
790         }
791
792         ### Every module get's stored as a module object ###
793         $tree->{ $data[0] } = CPANPLUS::Module->new(
794                 module      => $data[0],            # full module name
795                 version     => ($data[1] eq 'undef' # version number 
796                                     ? '0.0' 
797                                     : $data[1]), 
798                 path        => File::Spec::Unix->catfile(
799                                     $conf->_get_mirror('base'),
800                                     $data[2],
801                                 ),          # extended path on the cpan mirror,
802                                             # like /A/AB/ABIGAIL
803                 comment     => $data[3],    # comment on the module
804                 author      => $self->author_tree($author),
805                 package     => $package,    # package name, like
806                                             # 'foo-bar-baz-1.03.tar.gz'
807                 description => $dslip_tree->{ $data[0] }->{'description'},
808                 dslip       => $dslip,
809                 _id         => $self->_id,  #id of this internals object
810         );
811
812     } #for
813
814     return $tree;
815
816 } #_create_mod_tree
817
818 =pod
819
820 =head2 $cb->__create_dslip_tree([path => $path, uptodate => BOOL, verbose => BOOL])
821
822 This method opens a source files and parses its contents into a
823 searchable dslip-tree or restores a file-cached version of a
824 previous parse, if the sources are uptodate and the file-cache exists.
825
826 It takes the following arguments:
827
828 =over 4
829
830 =item uptodate
831
832 A flag indicating whether the file-cache is uptodate or not.
833
834 =item path
835
836 The absolute path to the directory holding the source files.
837
838 =item verbose
839
840 A boolean flag indicating whether or not to be verbose.
841
842 =back
843
844 Will get information from the config file by default.
845
846 Returns a tree on success, false on failure.
847
848 =cut
849
850 sub __create_dslip_tree {
851     my $self = shift;
852     my %hash = @_;
853     my $conf = $self->configure_object;
854
855     my $tmpl = {
856         path     => { default => $conf->get_conf('base') },
857         verbose  => { default => $conf->get_conf('verbose') },
858         uptodate => { default => 0 },
859     };
860
861     my $args = check( $tmpl, \%hash ) or return;
862
863     ### get the file name of the source ###
864     my $file = File::Spec->catfile($args->{path}, $conf->_get_source('dslip'));
865
866     ### extract the file ###
867     my $ae      = Archive::Extract->new( archive => $file ) or return;
868     my $out     = STRIP_GZ_SUFFIX->($file);
869
870     ### make sure to set the PREFER_BIN flag if desired ###
871     {   local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin');
872         $ae->extract( to => $out )                              or return;
873     }
874
875     my $in      = $self->_get_file_contents( file => $out ) or return;
876
877     ### don't need it anymore ###
878     unlink $out;
879
880
881     ### get rid of the comments and the code ###
882     ### need a smarter parser, some people have this in their dslip info:
883     # [
884     # 'Statistics::LTU',
885     # 'R',
886     # 'd',
887     # 'p',
888     # 'O',
889     # '?',
890     # 'Implements Linear Threshold Units',
891     # ...skipping...
892     # "\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!",
893     # 'BENNIE',
894     # '11'
895     # ],
896     ### also, older versions say:
897     ### $cols = [....]
898     ### and newer versions say:
899     ### $CPANPLUS::Modulelist::cols = [...]
900     ### split '$cols' and '$data' into 2 variables ###
901     ### use this regex to make sure dslips with ';' in them don't cause
902     ### parser errors
903     my ($ds_one, $ds_two) = ($in =~ m|.+}\s+
904                                                                                 (\$(?:CPAN::Modulelist::)?cols.*?)
905                                                                                 (\$(?:CPAN::Modulelist::)?data.*)
906                                                                         |sx);
907
908     ### eval them into existence ###
909     ### still not too fond of this solution - kane ###
910     my ($cols, $data);
911     {   #local $@; can't use this, it's buggy -kane
912
913         $cols = eval $ds_one;
914         error( loc("Error in eval of dslip source files: %1", $@) ) if $@;
915
916         $data = eval $ds_two;
917         error( loc("Error in eval of dslip source files: %1", $@) ) if $@;
918
919     }
920
921     my $tree = {};
922     my $primary = "modid";
923
924     ### this comes from CPAN::Modulelist
925     ### which is in 03modlist.data.gz
926     for (@$data){
927         my %hash;
928         @hash{@$cols} = @$_;
929         $tree->{$hash{$primary}} = \%hash;
930     }
931
932     return $tree;
933
934 } #__create_dslip_tree
935
936 =pod
937
938 =head2 $cb->_dslip_defs ()
939
940 This function returns the definition structure (ARRAYREF) of the
941 dslip tree.
942
943 =cut
944
945 ### these are the definitions used for dslip info
946 ### they shouldn't change over time.. so hardcoding them doesn't appear to
947 ### be a problem. if it is, we need to parse 03modlist.data better to filter
948 ### all this out.
949 ### right now, this is just used to look up dslip info from a module
950 sub _dslip_defs {
951     my $self = shift;
952
953     my $aref = [
954
955         # D
956         [ q|Development Stage|, {
957             i   => loc('Idea, listed to gain consensus or as a placeholder'),
958             c   => loc('under construction but pre-alpha (not yet released)'),
959             a   => loc('Alpha testing'),
960             b   => loc('Beta testing'),
961             R   => loc('Released'),
962             M   => loc('Mature (no rigorous definition)'),
963             S   => loc('Standard, supplied with Perl 5'),
964         }],
965
966         # S
967         [ q|Support Level|, {
968             m   => loc('Mailing-list'),
969             d   => loc('Developer'),
970             u   => loc('Usenet newsgroup comp.lang.perl.modules'),
971             n   => loc('None known, try comp.lang.perl.modules'),
972             a   => loc('Abandoned; volunteers welcome to take over maintainance'),
973         }],
974
975         # L
976         [ q|Language Used|, {
977             p   => loc('Perl-only, no compiler needed, should be platform independent'),
978             c   => loc('C and perl, a C compiler will be needed'),
979             h   => loc('Hybrid, written in perl with optional C code, no compiler needed'),
980             '+' => loc('C++ and perl, a C++ compiler will be needed'),
981             o   => loc('perl and another language other than C or C++'),
982         }],
983
984         # I
985         [ q|Interface Style|, {
986             f   => loc('plain Functions, no references used'),
987             h   => loc('hybrid, object and function interfaces available'),
988             n   => loc('no interface at all (huh?)'),
989             r   => loc('some use of unblessed References or ties'),
990             O   => loc('Object oriented using blessed references and/or inheritance'),
991         }],
992
993         # P
994         [ q|Public License|, {
995             p   => loc('Standard-Perl: user may choose between GPL and Artistic'),
996             g   => loc('GPL: GNU General Public License'),
997             l   => loc('LGPL: "GNU Lesser General Public License" (previously known as "GNU Library General Public License")'),
998             b   => loc('BSD: The BSD License'),
999             a   => loc('Artistic license alone'),
1000             o   => loc('other (but distribution allowed without restrictions)'),
1001         }],
1002     ];
1003
1004     return $aref;
1005 }
1006
1007 # Local variables:
1008 # c-indentation-style: bsd
1009 # c-basic-offset: 4
1010 # indent-tabs-mode: nil
1011 # End:
1012 # vim: expandtab shiftwidth=4:
1013
1014 1;