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;