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;