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
CommitLineData
6aaee015
RGS
1package CPANPLUS::Internals::Source;
2
3use strict;
4
5use CPANPLUS::Error;
6use CPANPLUS::Module;
7use CPANPLUS::Module::Fake;
8use CPANPLUS::Module::Author;
9use CPANPLUS::Internals::Constants;
10
11use Archive::Extract;
12
13use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
14use Params::Check qw[check];
15use IPC::Cmd qw[can_run];
16use Module::Load::Conditional qw[can_load];
17
18$Params::Check::VERBOSE = 1;
19
20=pod
21
22=head1 NAME
23
24CPANPLUS::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
35CPANPLUS::Internals::Source controls the updating of source files and
36the parsing of them into usable module/author trees to be used by
37C<CPANPLUS>.
38
39Functions exist to check if source files are still C<good to use> as
40well as update them, and then parse them.
41
42The 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
98Retrieve source files and return a boolean indicating whether or not
99the source files are up to date.
100
101Takes several arguments:
102
103=over 4
104
105=item update_source
106
107A flag to force re-fetching of the source files, even
108if they are still up to date.
109
110=item path
111
112The absolute path to the directory holding the source files.
113
114=item verbose
115
116A boolean flag indicating whether or not to be verbose.
117
118=back
119
120Will 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
125sub _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
172C<__check_uptodate> checks if a given source file is still up-to-date
173and if not, or when C<update_source> is true, will re-fetch the source
174file.
175
176Takes the following arguments:
177
178=over 4
179
180=item file
181
182The source file to check.
183
184=item name
185
186The internal shortcut name for the source file (used for config
187lookups).
188
189=item update_source
190
191Flag to force updating of sourcefiles regardless.
192
193=item verbose
194
195Boolean to indicate whether to be verbose or not.
196
197=back
198
199Returns a boolean value indicating whether the current files are up
200to 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
205sub __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
247This method does the actual fetching of source files.
248
249It takes the following arguments:
250
251=over 4
252
253=item name
254
255The internal shortcut name for the source file (used for config
256lookups).
257
258=item path
259
260The full path where to write the files.
261
262=item verbose
263
264Boolean to indicate whether to be verbose or not.
265
266=back
267
268Returns a boolean to indicate success.
269
270=cut
271
272### this sub fetches new source files ###
273sub _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
808cb88e
SH
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) )) {
6aaee015 324 error( loc("Couldn't touch %1", $file) );
808cb88e 325 }
6aaee015
RGS
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
335This method rebuilds the author- and module-trees from source.
336
337It takes the following arguments:
338
339=over 4
340
341=item uptodate
342
343Indicates whether any on disk caches are still ok to use.
344
345=item path
346
347The absolute path to the directory holding the source files.
348
349=item verbose
350
351A boolean flag indicating whether or not to be verbose.
352
353=item use_stored
354
355A boolean flag indicating whether or not it is ok to use previously
356stored trees. Defaults to true.
357
358=back
359
360Returns a boolean indicating success.
361
362=cut
363
364### (re)build the trees ###
365sub _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
424This method retrieves a I<storable>d tree identified by C<$name>.
425
426It takes the following arguments:
427
428=over 4
429
430=item name
431
432The internal name for the source file to retrieve.
433
434=item uptodate
435
436A flag indicating whether the file-cache is up-to-date or not.
437
438=item path
439
440The absolute path to the directory holding the source files.
441
442=item verbose
443
444A boolean flag indicating whether or not to be verbose.
445
446=back
447
448Will get information from the config file by default.
449
450Returns a tree on success, false on failure.
451
452=cut
453
454sub __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
490This method saves all the parsed trees in I<storable>d format if
491C<Storable> is available.
492
493It takes the following arguments:
494
495=over 4
496
497=item path
498
499The absolute path to the directory holding the source files.
500
501=item verbose
502
503A boolean flag indicating whether or not to be verbose.
504
505=back
506
507Will get information from the config file by default.
508
509Returns true on success, false on failure.
510
511=cut
512
513sub _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
563sub __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
594This method opens a source files and parses its contents into a
595searchable author-tree or restores a file-cached version of a
596previous parse, if the sources are uptodate and the file-cache exists.
597
598It takes the following arguments:
599
600=over 4
601
602=item uptodate
603
604A flag indicating whether the file-cache is uptodate or not.
605
606=item path
607
608The absolute path to the directory holding the source files.
609
610=item verbose
611
612A boolean flag indicating whether or not to be verbose.
613
614=back
615
616Will get information from the config file by default.
617
618Returns a tree on success, false on failure.
619
620=cut
621
622sub __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
680This method opens a source files and parses its contents into a
681searchable module-tree or restores a file-cached version of a
682previous parse, if the sources are uptodate and the file-cache exists.
683
684It takes the following arguments:
685
686=over 4
687
688=item uptodate
689
690A flag indicating whether the file-cache is up-to-date or not.
691
692=item path
693
694The absolute path to the directory holding the source files.
695
696=item verbose
697
698A boolean flag indicating whether or not to be verbose.
699
700=back
701
702Will get information from the config file by default.
703
704Returns 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 ###
709sub _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
822This method opens a source files and parses its contents into a
823searchable dslip-tree or restores a file-cached version of a
824previous parse, if the sources are uptodate and the file-cache exists.
825
826It takes the following arguments:
827
828=over 4
829
830=item uptodate
831
832A flag indicating whether the file-cache is uptodate or not.
833
834=item path
835
836The absolute path to the directory holding the source files.
837
838=item verbose
839
840A boolean flag indicating whether or not to be verbose.
841
842=back
843
844Will get information from the config file by default.
845
846Returns a tree on success, false on failure.
847
848=cut
849
850sub __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
940This function returns the definition structure (ARRAYREF) of the
941dslip 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
950sub _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
10141;