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 File::Fetch;
  12 use Archive::Extract;
  13
  14 use IPC::Cmd                    qw[can_run];
  15 use File::Temp                  qw[tempdir];
  16 use File::Basename              qw[dirname];
  17 use Params::Check               qw[check];
  18 use Module::Load::Conditional   qw[can_load];
  19 use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
  20
  21 $Params::Check::VERBOSE = 1;
  22
  23 =pod
  24
  25 =head1 NAME
  26
  27 CPANPLUS::Internals::Source
  28
  29 =head1 SYNOPSIS
  30
  31     ### lazy load author/module trees ###
  32
  33     $cb->_author_tree;
  34     $cb->_module_tree;
  35
  36 =head1 DESCRIPTION
  37
  38 CPANPLUS::Internals::Source controls the updating of source files and
  39 the parsing of them into usable module/author trees to be used by
  40 C<CPANPLUS>.
  41
  42 Functions exist to check if source files are still C<good to use> as
  43 well as update them, and then parse them.
  44
  45 The flow looks like this:
  46
  47     $cb->_author_tree || $cb->_module_tree
  48         $cb->_check_trees
  49             $cb->__check_uptodate
  50                 $cb->_update_source
  51             $cb->__update_custom_module_sources
  52                 $cb->__update_custom_module_source
  53         $cb->_build_trees
  54             $cb->__create_author_tree
  55                 $cb->__retrieve_source
  56             $cb->__create_module_tree
  57                 $cb->__retrieve_source
  58                 $cb->__create_dslip_tree
  59                     $cb->__retrieve_source
  60             $cb->__create_custom_module_entries
  61             $cb->_save_source
  62
  63     $cb->_dslip_defs
  64
  65 =head1 METHODS
  66
  67 =cut
  68
  69 {
  70     my $recurse; # flag to prevent recursive calls to *_tree functions
  71
  72     ### lazy loading of module tree
  73     sub _module_tree {
  74         my $self = $_[0];
  75
  76         unless ($self->{_modtree} or $recurse++ > 0) {
  77             my $uptodate = $self->_check_trees( @_[1..$#_] );
  78             $self->_build_trees(uptodate => $uptodate);
  79         }
  80
  81         $recurse--;
  82         return $self->{_modtree};
  83     }
  84
  85     ### lazy loading of author tree
  86     sub _author_tree {
  87         my $self = $_[0];
  88
  89         unless ($self->{_authortree} or $recurse++ > 0) {
  90             my $uptodate = $self->_check_trees( @_[1..$#_] );
  91             $self->_build_trees(uptodate => $uptodate);
  92         }
  93
  94         $recurse--;
  95         return $self->{_authortree};
  96     }
  97
  98 }
  99
 100 =pod
 101
 102 =head2 $cb->_check_trees( [update_source => BOOL, path => PATH, verbose => BOOL] )
 103
 104 Retrieve source files and return a boolean indicating whether or not
 105 the source files are up to date.
 106
 107 Takes several arguments:
 108
 109 =over 4
 110
 111 =item update_source
 112
 113 A flag to force re-fetching of the source files, even
 114 if they are still up to date.
 115
 116 =item path
 117
 118 The absolute path to the directory holding the source files.
 119
 120 =item verbose
 121
 122 A boolean flag indicating whether or not to be verbose.
 123
 124 =back
 125
 126 Will get information from the config file by default.
 127
 128 =cut
 129
 130 ### retrieve source files, and returns a boolean indicating if it's up to date
 131 sub _check_trees {
 132     my ($self, %hash) = @_;
 133     my $conf          = $self->configure_object;
 134
 135     my $update_source;
 136     my $verbose;
 137     my $path;
 138
 139     my $tmpl = {
 140         path            => { default => $conf->get_conf('base'),
 141                              store => \$path
 142                         },
 143         verbose         => { default => $conf->get_conf('verbose'),
 144                              store => \$verbose
 145                         },
 146         update_source   => { default => 0, store => \$update_source },
 147     };
 148
 149     my $args = check( $tmpl, \%hash ) or return;
 150
 151     ### if the user never wants to update their source without explicitly
 152     ### telling us, shortcircuit here
 153     return 1 if $conf->get_conf('no_update') && !$update_source;
 154
 155     ### a check to see if our source files are still up to date ###
 156     msg( loc("Checking if source files are up to date"), $verbose );
 157
 158     my $uptodate = 1; # default return value
 159
 160     for my $name (qw[auth dslip mod]) {
 161         for my $file ( $conf->_get_source( $name ) ) {
 162             $self->__check_uptodate(
 163                 file            => File::Spec->catfile( $args->{path}, $file ),
 164                 name            => $name,
 165                 update_source   => $update_source,
 166                 verbose         => $verbose,
 167             ) or $uptodate = 0;
 168         }
 169     }
 170
 171     ### if we're explicitly asked to update the sources, or if the
 172     ### standard source files are out of date, update the custom sources
 173     ### as well
 174     $self->__update_custom_module_sources( verbose => $verbose )
 175         if $update_source or !$uptodate;
 176
 177     return $uptodate;
 178 }
 179
 180 =pod
 181
 182 =head2 $cb->__check_uptodate( file => $file, name => $name, [update_source => BOOL, verbose => BOOL] )
 183
 184 C<__check_uptodate> checks if a given source file is still up-to-date
 185 and if not, or when C<update_source> is true, will re-fetch the source
 186 file.
 187
 188 Takes the following arguments:
 189
 190 =over 4
 191
 192 =item file
 193
 194 The source file to check.
 195
 196 =item name
 197
 198 The internal shortcut name for the source file (used for config
 199 lookups).
 200
 201 =item update_source
 202
 203 Flag to force updating of sourcefiles regardless.
 204
 205 =item verbose
 206
 207 Boolean to indicate whether to be verbose or not.
 208
 209 =back
 210
 211 Returns a boolean value indicating whether the current files are up
 212 to date or not.
 213
 214 =cut
 215
 216 ### this method checks whether or not the source files we are using are still up to date
 217 sub __check_uptodate {
 218     my $self = shift;
 219     my %hash = @_;
 220     my $conf = $self->configure_object;
 221
 222
 223     my $tmpl = {
 224         file            => { required => 1 },
 225         name            => { required => 1 },
 226         update_source   => { default => 0 },
 227         verbose         => { default => $conf->get_conf('verbose') },
 228     };
 229
 230     my $args = check( $tmpl, \%hash ) or return;
 231
 232     my $flag;
 233     unless ( -e $args->{'file'} && (
 234             ( stat $args->{'file'} )[9]
 235             + $conf->_get_source('update') )
 236             > time ) {
 237         $flag = 1;
 238     }
 239
 240     if ( $flag or $args->{'update_source'} ) {
 241
 242          if ( $self->_update_source( name => $args->{'name'} ) ) {
 243               return 0;       # return 0 so 'uptodate' will be set to 0, meaning no
 244                               # use of previously stored hashrefs!
 245          } else {
 246               msg( loc("Unable to update source, attempting to get away with using old source file!"), $args->{verbose} );
 247               return 1;
 248          }
 249
 250     } else {
 251         return 1;
 252     }
 253 }
 254
 255 =pod
 256
 257 =head2 $cb->_update_source( name => $name, [path => $path, verbose => BOOL] )
 258
 259 This method does the actual fetching of source files.
 260
 261 It takes the following arguments:
 262
 263 =over 4
 264
 265 =item name
 266
 267 The internal shortcut name for the source file (used for config
 268 lookups).
 269
 270 =item path
 271
 272 The full path where to write the files.
 273
 274 =item verbose
 275
 276 Boolean to indicate whether to be verbose or not.
 277
 278 =back
 279
 280 Returns a boolean to indicate success.
 281
 282 =cut
 283
 284 ### this sub fetches new source files ###
 285 sub _update_source {
 286     my $self = shift;
 287     my %hash = @_;
 288     my $conf = $self->configure_object;
 289
 290     my $verbose;
 291     my $tmpl = {
 292         name    => { required => 1 },
 293         path    => { default => $conf->get_conf('base') },
 294         verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
 295     };
 296
 297     my $args = check( $tmpl, \%hash ) or return;
 298
 299
 300     my $path = $args->{path};
 301     {   ### this could use a clean up - Kane
 302         ### no worries about the / -> we get it from the _ftp configuration, so
 303         ### it's not platform dependant. -kane
 304         my ($dir, $file) = $conf->_get_mirror( $args->{'name'} ) =~ m|(.+/)(.+)$|sg;
 305
 306         msg( loc("Updating source file '%1'", $file), $verbose );
 307
 308         my $fake = CPANPLUS::Module::Fake->new(
 309                         module  => $args->{'name'},
 310                         path    => $dir,
 311                         package => $file,
 312                         _id     => $self->_id,
 313                     );
 314
 315         ### can't use $fake->fetch here, since ->parent won't work --
 316         ### the sources haven't been saved yet
 317         my $rv = $self->_fetch(
 318                     module      => $fake,
 319                     fetchdir    => $path,
 320                     force       => 1,
 321                 );
 322
 323
 324         unless ($rv) {
 325             error( loc("Couldn't fetch '%1'", $file) );
 326             return;
 327         }
 328
 329         $self->_update_timestamp( file => File::Spec->catfile($path, $file) );
 330     }
 331
 332     return 1;
 333 }
 334
 335 =pod
 336
 337 =head2 $cb->_build_trees( uptodate => BOOL, [use_stored => BOOL, path => $path, verbose => BOOL] )
 338
 339 This method rebuilds the author- and module-trees from source.
 340
 341 It takes the following arguments:
 342
 343 =over 4
 344
 345 =item uptodate
 346
 347 Indicates whether any on disk caches are still ok to use.
 348
 349 =item path
 350
 351 The absolute path to the directory holding the source files.
 352
 353 =item verbose
 354
 355 A boolean flag indicating whether or not to be verbose.
 356
 357 =item use_stored
 358
 359 A boolean flag indicating whether or not it is ok to use previously
 360 stored trees. Defaults to true.
 361
 362 =back
 363
 364 Returns a boolean indicating success.
 365
 366 =cut
 367
 368 ### (re)build the trees ###
 369 sub _build_trees {
 370     my ($self, %hash)   = @_;
 371     my $conf            = $self->configure_object;
 372
 373     my($path,$uptodate,$use_stored);
 374     my $tmpl = {
 375         path        => { default => $conf->get_conf('base'), store => \$path },
 376         verbose     => { default => $conf->get_conf('verbose') },
 377         uptodate    => { required => 1, store => \$uptodate },
 378         use_stored  => { default => 1, store => \$use_stored },
 379     };
 380
 381     my $args = check( $tmpl, \%hash ) or return undef;
 382
 383     ### retrieve the stored source files ###
 384     my $stored      = $self->__retrieve_source(
 385                             path        => $path,
 386                             uptodate    => $uptodate && $use_stored,
 387                             verbose     => $args->{'verbose'},
 388                         ) || {};
 389
 390     ### build the trees ###
 391     $self->{_authortree} =  $stored->{_authortree} ||
 392                             $self->__create_author_tree(
 393                                     uptodate    => $uptodate,
 394                                     path        => $path,
 395                                     verbose     => $args->{verbose},
 396                                 );
 397     $self->{_modtree}    =  $stored->{_modtree} ||
 398                             $self->_create_mod_tree(
 399                                     uptodate    => $uptodate,
 400                                     path        => $path,
 401                                     verbose     => $args->{verbose},
 402                                 );
 403
 404     ### return if we weren't able to build the trees ###
 405     return unless $self->{_modtree} && $self->{_authortree};
 406
 407     ### update them if the other sources are also deemed out of date
 408     unless( $uptodate ) {
 409         $self->__update_custom_module_sources( verbose => $args->{verbose} )
 410             or error(loc("Could not update custom module sources"));
 411     }
 412
 413     ### add custom sources here
 414     $self->__create_custom_module_entries( verbose => $args->{verbose} )
 415         or error(loc("Could not create custom module entries"));
 416
 417     ### write the stored files to disk, so we can keep using them
 418     ### from now on, till they become invalid
 419     ### write them if the original sources weren't uptodate, or
 420     ### we didn't just load storable files
 421     $self->_save_source() if !$uptodate or not keys %$stored;
 422
 423     ### still necessary? can only run one instance now ###
 424     ### will probably stay that way --kane
 425 #     my $id = $self->_store_id( $self );
 426 #
 427 #     unless ( $id == $self->_id ) {
 428 #         error( loc("IDs do not match: %1 != %2. Storage failed!", $id, $self->_id) );
 429 #     }
 430
 431     return 1;
 432 }
 433
 434 =pod
 435
 436 =head2 $cb->__retrieve_source(name => $name, [path => $path, uptodate => BOOL, verbose => BOOL])
 437
 438 This method retrieves a I<storable>d tree identified by C<$name>.
 439
 440 It takes the following arguments:
 441
 442 =over 4
 443
 444 =item name
 445
 446 The internal name for the source file to retrieve.
 447
 448 =item uptodate
 449
 450 A flag indicating whether the file-cache is up-to-date or not.
 451
 452 =item path
 453
 454 The absolute path to the directory holding the source files.
 455
 456 =item verbose
 457
 458 A boolean flag indicating whether or not to be verbose.
 459
 460 =back
 461
 462 Will get information from the config file by default.
 463
 464 Returns a tree on success, false on failure.
 465
 466 =cut
 467
 468 sub __retrieve_source {
 469     my $self = shift;
 470     my %hash = @_;
 471     my $conf = $self->configure_object;
 472
 473     my $tmpl = {
 474         path     => { default => $conf->get_conf('base') },
 475         verbose  => { default => $conf->get_conf('verbose') },
 476         uptodate => { default => 0 },
 477     };
 478
 479     my $args = check( $tmpl, \%hash ) or return;
 480
 481     ### check if we can retrieve a frozen data structure with storable ###
 482     my $storable = can_load( modules => {'Storable' => '0.0'} )
 483                         if $conf->get_conf('storable');
 484
 485     return unless $storable;
 486
 487     ### $stored is the name of the frozen data structure ###
 488     my $stored = $self->__storable_file( $args->{path} );
 489
 490     if ($storable && -e $stored && -s _ && $args->{'uptodate'}) {
 491         msg( loc("Retrieving %1", $stored), $args->{'verbose'} );
 492
 493         my $href = Storable::retrieve($stored);
 494         return $href;
 495     } else {
 496         return;
 497     }
 498 }
 499
 500 =pod
 501
 502 =head2 $cb->_save_source([verbose => BOOL, path => $path])
 503
 504 This method saves all the parsed trees in I<storable>d format if
 505 C<Storable> is available.
 506
 507 It takes the following arguments:
 508
 509 =over 4
 510
 511 =item path
 512
 513 The absolute path to the directory holding the source files.
 514
 515 =item verbose
 516
 517 A boolean flag indicating whether or not to be verbose.
 518
 519 =back
 520
 521 Will get information from the config file by default.
 522
 523 Returns true on success, false on failure.
 524
 525 =cut
 526
 527 sub _save_source {
 528     my $self = shift;
 529     my %hash = @_;
 530     my $conf = $self->configure_object;
 531
 532
 533     my $tmpl = {
 534         path     => { default => $conf->get_conf('base'), allow => DIR_EXISTS },
 535         verbose  => { default => $conf->get_conf('verbose') },
 536         force    => { default => 1 },
 537     };
 538
 539     my $args = check( $tmpl, \%hash ) or return;
 540
 541     my $aref = [qw[_modtree _authortree]];
 542
 543     ### check if we can retrieve a frozen data structure with storable ###
 544     my $storable;
 545     $storable = can_load( modules => {'Storable' => '0.0'} )
 546                     if $conf->get_conf('storable');
 547     return unless $storable;
 548
 549     my $to_write = {};
 550     foreach my $key ( @$aref ) {
 551         next unless ref( $self->{$key} );
 552         $to_write->{$key} = $self->{$key};
 553     }
 554
 555     return unless keys %$to_write;
 556
 557     ### $stored is the name of the frozen data structure ###
 558     my $stored = $self->__storable_file( $args->{path} );
 559
 560     if (-e $stored && not -w $stored) {
 561         msg( loc("%1 not writable; skipped.", $stored), $args->{'verbose'} );
 562         return;
 563     }
 564
 565     msg( loc("Writing compiled source information to disk. This might take a little while."),
 566             $args->{'verbose'} );
 567
 568     my $flag;
 569     unless( Storable::nstore( $to_write, $stored ) ) {
 570         error( loc("could not store %1!", $stored) );
 571         $flag++;
 572     }
 573
 574     return $flag ? 0 : 1;
 575 }
 576
 577 sub __storable_file {
 578     my $self = shift;
 579     my $conf = $self->configure_object;
 580     my $path = shift or return;
 581
 582     ### check if we can retrieve a frozen data structure with storable ###
 583     my $storable = $conf->get_conf('storable')
 584                         ? can_load( modules => {'Storable' => '0.0'} )
 585                         : 0;
 586
 587     return unless $storable;
 588
 589     ### $stored is the name of the frozen data structure ###
 590     ### changed to use File::Spec->catfile -jmb
 591     my $stored = File::Spec->rel2abs(
 592         File::Spec->catfile(
 593             $path,                          #base dir
 594             $conf->_get_source('stored')    #file
 595             . '.' .
 596             $Storable::VERSION              #the version of storable
 597             . '.stored'                     #append a suffix
 598         )
 599     );
 600
 601     return $stored;
 602 }
 603
 604 =pod
 605
 606 =head2 $cb->__create_author_tree([path => $path, uptodate => BOOL, verbose => BOOL])
 607
 608 This method opens a source files and parses its contents into a
 609 searchable author-tree or restores a file-cached version of a
 610 previous parse, if the sources are uptodate and the file-cache exists.
 611
 612 It takes the following arguments:
 613
 614 =over 4
 615
 616 =item uptodate
 617
 618 A flag indicating whether the file-cache is uptodate or not.
 619
 620 =item path
 621
 622 The absolute path to the directory holding the source files.
 623
 624 =item verbose
 625
 626 A boolean flag indicating whether or not to be verbose.
 627
 628 =back
 629
 630 Will get information from the config file by default.
 631
 632 Returns a tree on success, false on failure.
 633
 634 =cut
 635
 636 sub __create_author_tree {
 637     my $self = shift;
 638     my %hash = @_;
 639     my $conf = $self->configure_object;
 640
 641
 642     my $tmpl = {
 643         path     => { default => $conf->get_conf('base') },
 644         verbose  => { default => $conf->get_conf('verbose') },
 645         uptodate => { default => 0 },
 646     };
 647
 648     my $args = check( $tmpl, \%hash ) or return;
 649     my $tree = {};
 650     my $file = File::Spec->catfile(
 651                                 $args->{path},
 652                                 $conf->_get_source('auth')
 653                             );
 654
 655     msg(loc("Rebuilding author tree, this might take a while"),
 656         $args->{verbose});
 657
 658     ### extract the file ###
 659     my $ae      = Archive::Extract->new( archive => $file ) or return;
 660     my $out     = STRIP_GZ_SUFFIX->($file);
 661
 662     ### make sure to set the PREFER_BIN flag if desired ###
 663     {   local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin');
 664         $ae->extract( to => $out )                              or return;
 665     }
 666
 667     my $cont    = $self->_get_file_contents( file => $out ) or return;
 668
 669     ### don't need it anymore ###
 670     unlink $out;
 671
 672     for ( split /\n/, $cont ) {
 673         my($id, $name, $email) = m/^alias \s+
 674                                     (\S+) \s+
 675                                     "\s* ([^\"\<]+?) \s* <(.+)> \s*"
 676                                 /x;
 677
 678         $tree->{$id} = CPANPLUS::Module::Author->new(
 679             author  => $name,           #authors name
 680             email   => $email,          #authors email address
 681             cpanid  => $id,             #authors CPAN ID
 682             _id     => $self->_id,    #id of this internals object
 683         );
 684     }
 685
 686     return $tree;
 687
 688 } #__create_author_tree
 689
 690 =pod
 691
 692 =head2 $cb->_create_mod_tree([path => $path, uptodate => BOOL, verbose => BOOL])
 693
 694 This method opens a source files and parses its contents into a
 695 searchable module-tree or restores a file-cached version of a
 696 previous parse, if the sources are uptodate and the file-cache exists.
 697
 698 It takes the following arguments:
 699
 700 =over 4
 701
 702 =item uptodate
 703
 704 A flag indicating whether the file-cache is up-to-date or not.
 705
 706 =item path
 707
 708 The absolute path to the directory holding the source files.
 709
 710 =item verbose
 711
 712 A boolean flag indicating whether or not to be verbose.
 713
 714 =back
 715
 716 Will get information from the config file by default.
 717
 718 Returns a tree on success, false on failure.
 719
 720 =cut
 721
 722 ### this builds a hash reference with the structure of the cpan module tree ###
 723 sub _create_mod_tree {
 724     my $self = shift;
 725     my %hash = @_;
 726     my $conf = $self->configure_object;
 727
 728
 729     my $tmpl = {
 730         path     => { default => $conf->get_conf('base') },
 731         verbose  => { default => $conf->get_conf('verbose') },
 732         uptodate => { default => 0 },
 733     };
 734
 735     my $args = check( $tmpl, \%hash ) or return undef;
 736     my $file = File::Spec->catfile($args->{path}, $conf->_get_source('mod'));
 737
 738     msg(loc("Rebuilding module tree, this might take a while"),
 739         $args->{verbose});
 740
 741
 742     my $dslip_tree = $self->__create_dslip_tree( %$args );
 743
 744     ### extract the file ###
 745     my $ae      = Archive::Extract->new( archive => $file ) or return;
 746     my $out     = STRIP_GZ_SUFFIX->($file);
 747
 748     ### make sure to set the PREFER_BIN flag if desired ###
 749     {   local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin');
 750         $ae->extract( to => $out )                              or return;
 751     }
 752
 753     my $cont    = $self->_get_file_contents( file => $out ) or return;
 754
 755     ### don't need it anymore ###
 756     unlink $out;
 757
 758     my $tree = {};
 759     my $flag;
 760
 761     for ( split /\n/, $cont ) {
 762
 763         ### quick hack to read past the header of the file ###
 764         ### this is still rather evil... fix some time - Kane
 765         $flag = 1 if m|^\s*$|;
 766         next unless $flag;
 767
 768         ### skip empty lines ###
 769         next unless /\S/;
 770         chomp;
 771
 772         my @data = split /\s+/;
 773
 774         ### filter out the author and filename as well ###
 775         ### authors can apparently have digits in their names,
 776         ### and dirs can have dots... blah!
 777         my ($author, $package) = $data[2] =~
 778                 m|  (?:[A-Z\d-]/)?
 779                     (?:[A-Z\d-]{2}/)?
 780                     ([A-Z\d-]+) (?:/[\S]+)?/
 781                     ([^/]+)$
 782                 |xsg;
 783
 784         ### remove file name from the path
 785         $data[2] =~ s|/[^/]+$||;
 786
 787
 788         unless( $self->author_tree($author) ) {
 789             error( loc( "No such author '%1' -- can't make module object " .
 790                         "'%2' that is supposed to belong to this author",
 791                         $author, $data[0] ) );
 792             next;
 793         }
 794
 795         ### adding the dslip info
 796         ### probably can use some optimization
 797         my $dslip;
 798         for my $item ( qw[ statd stats statl stati statp ] ) {
 799             ### checking if there's an entry in the dslip info before
 800             ### catting it on. appeasing warnings this way
 801             $dslip .=   $dslip_tree->{ $data[0] }->{$item}
 802                             ? $dslip_tree->{ $data[0] }->{$item}
 803                             : ' ';
 804         }
 805
 806         ### Every module get's stored as a module object ###
 807         $tree->{ $data[0] } = CPANPLUS::Module->new(
 808                 module      => $data[0],            # full module name
 809                 version     => ($data[1] eq 'undef' # version number
 810                                     ? '0.0'
 811                                     : $data[1]),
 812                 path        => File::Spec::Unix->catfile(
 813                                     $conf->_get_mirror('base'),
 814                                     $data[2],
 815                                 ),          # extended path on the cpan mirror,
 816                                             # like /A/AB/ABIGAIL
 817                 comment     => $data[3],    # comment on the module
 818                 author      => $self->author_tree($author),
 819                 package     => $package,    # package name, like
 820                                             # 'foo-bar-baz-1.03.tar.gz'
 821                 description => $dslip_tree->{ $data[0] }->{'description'},
 822                 dslip       => $dslip,
 823                 _id         => $self->_id,  # id of this internals object
 824         );
 825
 826     } #for
 827
 828     return $tree;
 829
 830 } #_create_mod_tree
 831
 832 =pod
 833
 834 =head2 $cb->__create_dslip_tree([path => $path, uptodate => BOOL, verbose => BOOL])
 835
 836 This method opens a source files and parses its contents into a
 837 searchable dslip-tree or restores a file-cached version of a
 838 previous parse, if the sources are uptodate and the file-cache exists.
 839
 840 It takes the following arguments:
 841
 842 =over 4
 843
 844 =item uptodate
 845
 846 A flag indicating whether the file-cache is uptodate or not.
 847
 848 =item path
 849
 850 The absolute path to the directory holding the source files.
 851
 852 =item verbose
 853
 854 A boolean flag indicating whether or not to be verbose.
 855
 856 =back
 857
 858 Will get information from the config file by default.
 859
 860 Returns a tree on success, false on failure.
 861
 862 =cut
 863
 864 sub __create_dslip_tree {
 865     my $self = shift;
 866     my %hash = @_;
 867     my $conf = $self->configure_object;
 868
 869     my $tmpl = {
 870         path     => { default => $conf->get_conf('base') },
 871         verbose  => { default => $conf->get_conf('verbose') },
 872         uptodate => { default => 0 },
 873     };
 874
 875     my $args = check( $tmpl, \%hash ) or return;
 876
 877     ### get the file name of the source ###
 878     my $file = File::Spec->catfile($args->{path}, $conf->_get_source('dslip'));
 879
 880     ### extract the file ###
 881     my $ae      = Archive::Extract->new( archive => $file ) or return;
 882     my $out     = STRIP_GZ_SUFFIX->($file);
 883
 884     ### make sure to set the PREFER_BIN flag if desired ###
 885     {   local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin');
 886         $ae->extract( to => $out )                              or return;
 887     }
 888
 889     my $in      = $self->_get_file_contents( file => $out ) or return;
 890
 891     ### don't need it anymore ###
 892     unlink $out;
 893
 894
 895     ### get rid of the comments and the code ###
 896     ### need a smarter parser, some people have this in their dslip info:
 897     # [
 898     # 'Statistics::LTU',
 899     # 'R',
 900     # 'd',
 901     # 'p',
 902     # 'O',
 903     # '?',
 904     # 'Implements Linear Threshold Units',
 905     # ...skipping...
 906     # "\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!",
 907     # 'BENNIE',
 908     # '11'
 909     # ],
 910     ### also, older versions say:
 911     ### $cols = [....]
 912     ### and newer versions say:
 913     ### $CPANPLUS::Modulelist::cols = [...]
 914     ### split '$cols' and '$data' into 2 variables ###
 915     ### use this regex to make sure dslips with ';' in them don't cause
 916     ### parser errors
 917     my ($ds_one, $ds_two) = ($in =~ m|.+}\s+
 918                                                                                 (\$(?:CPAN::Modulelist::)?cols.*?)
 919                                                                                 (\$(?:CPAN::Modulelist::)?data.*)
 920                                                                         |sx);
 921
 922     ### eval them into existence ###
 923     ### still not too fond of this solution - kane ###
 924     my ($cols, $data);
 925     {   #local $@; can't use this, it's buggy -kane
 926
 927         $cols = eval $ds_one;
 928         error( loc("Error in eval of dslip source files: %1", $@) ) if $@;
 929
 930         $data = eval $ds_two;
 931         error( loc("Error in eval of dslip source files: %1", $@) ) if $@;
 932
 933     }
 934
 935     my $tree = {};
 936     my $primary = "modid";
 937
 938     ### this comes from CPAN::Modulelist
 939     ### which is in 03modlist.data.gz
 940     for (@$data){
 941         my %hash;
 942         @hash{@$cols} = @$_;
 943         $tree->{$hash{$primary}} = \%hash;
 944     }
 945
 946     return $tree;
 947
 948 } #__create_dslip_tree
 949
 950 =pod
 951
 952 =head2 $cb->_dslip_defs ()
 953
 954 This function returns the definition structure (ARRAYREF) of the
 955 dslip tree.
 956
 957 =cut
 958
 959 ### these are the definitions used for dslip info
 960 ### they shouldn't change over time.. so hardcoding them doesn't appear to
 961 ### be a problem. if it is, we need to parse 03modlist.data better to filter
 962 ### all this out.
 963 ### right now, this is just used to look up dslip info from a module
 964 sub _dslip_defs {
 965     my $self = shift;
 966
 967     my $aref = [
 968
 969         # D
 970         [ q|Development Stage|, {
 971             i   => loc('Idea, listed to gain consensus or as a placeholder'),
 972             c   => loc('under construction but pre-alpha (not yet released)'),
 973             a   => loc('Alpha testing'),
 974             b   => loc('Beta testing'),
 975             R   => loc('Released'),
 976             M   => loc('Mature (no rigorous definition)'),
 977             S   => loc('Standard, supplied with Perl 5'),
 978         }],
 979
 980         # S
 981         [ q|Support Level|, {
 982             m   => loc('Mailing-list'),
 983             d   => loc('Developer'),
 984             u   => loc('Usenet newsgroup comp.lang.perl.modules'),
 985             n   => loc('None known, try comp.lang.perl.modules'),
 986             a   => loc('Abandoned; volunteers welcome to take over maintainance'),
 987         }],
 988
 989         # L
 990         [ q|Language Used|, {
 991             p   => loc('Perl-only, no compiler needed, should be platform independent'),
 992             c   => loc('C and perl, a C compiler will be needed'),
 993             h   => loc('Hybrid, written in perl with optional C code, no compiler needed'),
 994             '+' => loc('C++ and perl, a C++ compiler will be needed'),
 995             o   => loc('perl and another language other than C or C++'),
 996         }],
 997
 998         # I
 999         [ q|Interface Style|, {
1000             f   => loc('plain Functions, no references used'),
1001             h   => loc('hybrid, object and function interfaces available'),
1002             n   => loc('no interface at all (huh?)'),
1003             r   => loc('some use of unblessed References or ties'),
1004             O   => loc('Object oriented using blessed references and/or inheritance'),
1005         }],
1006
1007         # P
1008         [ q|Public License|, {
1009             p   => loc('Standard-Perl: user may choose between GPL and Artistic'),
1010             g   => loc('GPL: GNU General Public License'),
1011             l   => loc('LGPL: "GNU Lesser General Public License" (previously known as "GNU Library General Public License")'),
1012             b   => loc('BSD: The BSD License'),
1013             a   => loc('Artistic license alone'),
1014             o   => loc('other (but distribution allowed without restrictions)'),
1015         }],
1016     ];
1017
1018     return $aref;
1019 }
1020
1021 =head2 $file = $cb->_add_custom_module_source( uri => URI, [verbose => BOOL] );
1022
1023 Adds a custom source index and updates it based on the provided URI.
1024
1025 Returns the full path to the index file on success or false on failure.
1026
1027 =cut
1028
1029 sub _add_custom_module_source {
1030     my $self = shift;
1031     my $conf = $self->configure_object;
1032     my %hash = @_;
1033
1034     my($verbose,$uri);
1035     my $tmpl = {
1036         verbose => { default => $conf->get_conf('verbose'),
1037                      store   => \$verbose },
1038         uri     => { required => 1, store => \$uri }
1039     };
1040
1041     check( $tmpl, \%hash ) or return;
1042
1043     ### what index file should we use on disk?
1044     my $index = $self->__custom_module_source_index_file( uri => $uri );
1045
1046     ### already have it.
1047     if( IS_FILE->( $index ) ) {
1048         msg(loc("Source '%1' already added", $uri));
1049         return 1;
1050     }
1051
1052     ### do we need to create the targe dir?
1053     {   my $dir = dirname( $index );
1054         unless( IS_DIR->( $dir ) ) {
1055             $self->_mkdir( dir => $dir ) or return
1056         }
1057     }
1058
1059     ### write the file
1060     my $fh = OPEN_FILE->( $index => '>' ) or do {
1061         error(loc("Could not open index file for '%1'", $uri));
1062         return;
1063     };
1064
1065     ### basically we 'touched' it. Check the return value, may be
1066     ### important on win32 and similar OS, where there's file length
1067     ### limits
1068     close $fh or do {
1069         error(loc("Could not write index file to disk for '%1'", $uri));
1070         return;
1071     };
1072
1073     $self->__update_custom_module_source(
1074                 remote  => $uri,
1075                 local   => $index,
1076                 verbose => $verbose,
1077             ) or do {
1078                 ### we faild to update it, we probably have an empty
1079                 ### possibly silly filename on disk now -- remove it
1080                 1 while unlink $index;
1081                 return;
1082             };
1083
1084     return $index;
1085 }
1086
1087 =head2 $index = $cb->__custom_module_source_index_file( uri => $uri );
1088
1089 Returns the full path to the encoded index file for C<$uri>, as used by
1090 all C<custom module source> routines.
1091
1092 =cut
1093
1094 sub __custom_module_source_index_file {
1095     my $self = shift;
1096     my $conf = $self->configure_object;
1097     my %hash = @_;
1098
1099     my($verbose,$uri);
1100     my $tmpl = {
1101         uri     => { required => 1, store => \$uri }
1102     };
1103
1104     check( $tmpl, \%hash ) or return;
1105
1106     my $index = File::Spec->catfile(
1107                     $conf->get_conf('base'),
1108                     $conf->_get_build('custom_sources'),
1109                     $self->_uri_encode( uri => $uri ),
1110                 );
1111
1112     return $index;
1113 }
1114
1115 =head2 $file = $cb->_remove_custom_module_source( uri => URI, [verbose => BOOL] );
1116
1117 Removes a custom index file based on the URI provided.
1118
1119 Returns the full path to the index file on success or false on failure.
1120
1121 =cut
1122
1123 sub _remove_custom_module_source {
1124     my $self = shift;
1125     my $conf = $self->configure_object;
1126     my %hash = @_;
1127
1128     my($verbose,$uri);
1129     my $tmpl = {
1130         verbose => { default => $conf->get_conf('verbose'),
1131                      store   => \$verbose },
1132         uri     => { required => 1, store => \$uri }
1133     };
1134
1135     check( $tmpl, \%hash ) or return;
1136
1137     ### use uri => local, instead of the other way around
1138     my %files = reverse $self->__list_custom_module_sources;
1139
1140     ### On VMS the case of key to %files can be either exact or lower case
1141     ### XXX abstract this lookup out? --kane
1142     my $file = $files{ $uri };
1143     $file    = $files{ lc $uri } if !defined($file) && ON_VMS;
1144
1145     unless (defined $file) {
1146         error(loc("No such custom source '%1'", $uri));
1147         return;
1148     };
1149
1150     1 while unlink $file;
1151
1152     if( IS_FILE->( $file ) ) {
1153         error(loc("Could not remove index file '%1' for custom source '%2'",
1154                     $file, $uri));
1155         return;
1156     }
1157
1158     msg(loc("Successfully removed index file for '%1'", $uri), $verbose);
1159
1160     return $file;
1161 }
1162
1163 =head2 %files = $cb->__list_custom_module_sources
1164
1165 This method scans the 'custom-sources' directory in your base directory
1166 for additional sources to include in your module tree.
1167
1168 Returns a list of key value pairs as follows:
1169
1170   /full/path/to/source/file%3Fencoded => http://decoded/mirror/path
1171
1172 =cut
1173
1174 sub __list_custom_module_sources {
1175     my $self = shift;
1176     my $conf = $self->configure_object;
1177
1178     my $dir = File::Spec->catdir(
1179                     $conf->get_conf('base'),
1180                     $conf->_get_build('custom_sources'),
1181                 );
1182
1183     unless( IS_DIR->( $dir ) ) {
1184         msg(loc("No '%1' dir, skipping custom sources", $dir));
1185         return;
1186     }
1187
1188     ### unencode the files
1189     ### skip ones starting with # though
1190     my %files = map {
1191         my $org = $_;
1192         my $dec = $self->_uri_decode( uri => $_ );
1193         File::Spec->catfile( $dir, $org ) => $dec
1194     } grep { $_ !~ /^#/ } READ_DIR->( $dir );
1195
1196     return %files;
1197 }
1198
1199 =head2 $bool = $cb->__update_custom_module_sources( [verbose => BOOL] );
1200
1201 Attempts to update all the index files to your custom module sources.
1202
1203 If the index is missing, and it's a C<file://> uri, it will generate
1204 a new local index for you.
1205
1206 Return true on success, false on failure.
1207
1208 =cut
1209
1210 sub __update_custom_module_sources {
1211     my $self = shift;
1212     my $conf = $self->configure_object;
1213     my %hash = @_;
1214
1215     my $verbose;
1216     my $tmpl = {
1217         verbose => { default => $conf->get_conf('verbose'),
1218                      store   => \$verbose }
1219     };
1220
1221     check( $tmpl, \%hash ) or return;
1222
1223     my %files = $self->__list_custom_module_sources;
1224
1225     ### uptodate check has been done a few levels up.
1226     my $fail;
1227     while( my($local,$remote) = each %files ) {
1228
1229         $self->__update_custom_module_source(
1230                     remote  => $remote,
1231                     local   => $local,
1232                     verbose => $verbose,
1233                 ) or ( $fail++, next );
1234     }
1235
1236     error(loc("Failed updating one or more remote sources files")) if $fail;
1237
1238     return if $fail;
1239     return 1;
1240 }
1241
1242 =head2 $ok = $cb->__update_custom_module_source
1243
1244 Attempts to update all the index files to your custom module sources.
1245
1246 If the index is missing, and it's a C<file://> uri, it will generate
1247 a new local index for you.
1248
1249 Return true on success, false on failure.
1250
1251 =cut
1252
1253 sub __update_custom_module_source {
1254     my $self = shift;
1255     my $conf = $self->configure_object;
1256     my %hash = @_;
1257
1258     my($verbose,$local,$remote);
1259     my $tmpl = {
1260         verbose => { default  => $conf->get_conf('verbose'),
1261                      store    => \$verbose },
1262         local   => { store    => \$local, allow => FILE_EXISTS },
1263         remote  => { required => 1, store => \$remote },
1264     };
1265
1266     check( $tmpl, \%hash ) or return;
1267
1268     msg( loc("Updating sources from '%1'", $remote), $verbose);
1269
1270     ### if you didn't provide a local file, we'll look in your custom
1271     ### dir to find the local encoded version for you
1272     $local ||= do {
1273         ### find all files we know of
1274         my %files = reverse $self->__list_custom_module_sources or do {
1275             error(loc("No custom modules sources defined -- need '%1' argument",
1276                       'local'));
1277             return;
1278         };
1279
1280         ### On VMS the case of key to %files can be either exact or lower case
1281         ### XXX abstract this lookup out? --kane
1282         my $file = $files{ $remote };
1283         $file    = $files{ lc $remote } if !defined ($file) && ON_VMS;
1284
1285         ### return the local file we're supposed to use
1286         $file or do {
1287             error(loc("Remote source '%1' unknown -- needs '%2' argument",
1288                       $remote, 'local'));
1289             return;
1290         };
1291     };
1292
1293     my $uri =  join '/', $remote, $conf->_get_source('custom_index');
1294     my $ff  =  File::Fetch->new( uri => $uri );
1295
1296     ### tempdir doesn't clean up by default, as opposed to tempfile()
1297     ### so add it explicitly.
1298     my $dir =  tempdir( CLEANUP => 1 );
1299
1300     my $res =  do {  local $File::Fetch::WARN = 0;
1301                     local $File::Fetch::WARN = 0;
1302                     $ff->fetch( to => $dir );
1303                 };
1304
1305     ### couldn't get the file
1306     unless( $res ) {
1307
1308         ### it's not a local scheme, so can't auto index
1309         unless( $ff->scheme eq 'file' ) {
1310             error(loc("Could not update sources from '%1': %2",
1311                       $remote, $ff->error ));
1312             return;
1313
1314         ### it's a local uri, we can index it ourselves
1315         } else {
1316             msg(loc("No index file found at '%1', generating one",
1317                     $ff->uri), $verbose );
1318
1319             ### ON VMS, if you are working with a UNIX file specification,
1320             ### you need currently use the UNIX variants of the File::Spec.
1321             my $ff_path = do {
1322                 my $file_class = 'File::Spec';
1323                 $file_class .= '::Unix' if ON_VMS;
1324                 $file_class->catdir( File::Spec::Unix->splitdir( $ff->path ) );
1325             };
1326
1327             $self->__write_custom_module_index(
1328                 path    => $ff_path,
1329                 to      => $local,
1330                 verbose => $verbose,
1331             ) or return;
1332
1333             ### XXX don't write that here, __write_custom_module_index
1334             ### already prints this out
1335             #msg(loc("Index file written to '%1'", $to), $verbose);
1336         }
1337
1338     ### copy it to the real spot and update it's timestamp
1339     } else {
1340         $self->_move( file => $res, to => $local ) or return;
1341         $self->_update_timestamp( file => $local );
1342
1343         msg(loc("Index file saved to '%1'", $local), $verbose);
1344     }
1345
1346     return $local;
1347 }
1348
1349 =head2 $bool = $cb->__write_custom_module_index( path => /path/to/packages, [to => /path/to/index/file, verbose => BOOL] )
1350
1351 Scans the C<path> you provided for packages and writes an index with all
1352 the available packages to C<$path/packages.txt>. If you'd like the index
1353 to be written to a different file, provide the C<to> argument.
1354
1355 Returns true on success and false on failure.
1356
1357 =cut
1358
1359 sub __write_custom_module_index {
1360     my $self = shift;
1361     my $conf = $self->configure_object;
1362     my %hash = @_;
1363
1364     my ($verbose, $path, $to);
1365     my $tmpl = {
1366         verbose => { default => $conf->get_conf('verbose'),
1367                      store   => \$verbose },
1368         path    => { required => 1, allow => DIR_EXISTS, store => \$path },
1369         to      => { store => \$to },
1370     };
1371
1372     check( $tmpl, \%hash ) or return;
1373
1374     ### no explicit to? then we'll use our default
1375     $to ||= File::Spec->catfile( $path, $conf->_get_source('custom_index') );
1376
1377     my @files;
1378     require File::Find;
1379     File::Find::find( sub {
1380         ### let's see if A::E can even parse it
1381         my $ae = do {
1382             local $Archive::Extract::WARN = 0;
1383             local $Archive::Extract::WARN = 0;
1384             Archive::Extract->new( archive => $File::Find::name )
1385         } or return;
1386
1387         ### it's a type A::E recognize, so we can add it
1388         $ae->type or return;
1389
1390         ### neither $_ nor $File::Find::name have the chunk of the path in
1391         ### it starting $path -- it's either only the filename, or the full
1392         ### path, so we have to strip it ourselves
1393         ### make sure to remove the leading slash as well.
1394         my $copy = $File::Find::name;
1395         my $re   = quotemeta($path);
1396         $copy    =~ s|^$re[\\/]?||i;
1397
1398         push @files, $copy;
1399
1400     }, $path );
1401
1402     ### does the dir exist? if not, create it.
1403     {   my $dir = dirname( $to );
1404         unless( IS_DIR->( $dir ) ) {
1405             $self->_mkdir( dir => $dir ) or return
1406         }
1407     }
1408
1409     ### create the index file
1410     my $fh = OPEN_FILE->( $to => '>' ) or return;
1411
1412     print $fh "$_\n" for @files;
1413     close $fh;
1414
1415     msg(loc("Successfully written index file to '%1'", $to), $verbose);
1416
1417     return $to;
1418 }
1419
1420
1421 =head2 $bool = $cb->__create_custom_module_entries( [verbose => BOOL] )
1422
1423 Creates entries in the module tree based upon the files as returned
1424 by C<__list_custom_module_sources>.
1425
1426 Returns true on success, false on failure.
1427
1428 =cut
1429
1430 ### use $auth_obj as a persistant version, so we don't have to recreate
1431 ### modules all the time
1432 {   my $auth_obj;
1433
1434     sub __create_custom_module_entries {
1435         my $self    = shift;
1436         my $conf    = $self->configure_object;
1437         my %hash    = @_;
1438
1439         my $verbose;
1440         my $tmpl = {
1441             verbose     => { default => $conf->get_conf('verbose'), store => \$verbose },
1442         };
1443
1444         check( $tmpl, \%hash ) or return undef;
1445
1446         my %files = $self->__list_custom_module_sources;
1447
1448         while( my($file,$name) = each %files ) {
1449
1450             msg(loc("Adding packages from custom source '%1'", $name), $verbose);
1451
1452             my $fh = OPEN_FILE->( $file ) or next;
1453
1454             while( <$fh> ) {
1455                 chomp;
1456                 next if /^#/;
1457                 next unless /\S+/;
1458
1459                 ### join on / -- it's a URI after all!
1460                 my $parse = join '/', $name, $_;
1461
1462                 ### try to make a module object out of it
1463                 my $mod = $self->parse_module( module => $parse ) or (
1464                     error(loc("Could not parse '%1'", $_)),
1465                     next
1466                 );
1467
1468                 ### mark this object with a custom author
1469                 $auth_obj ||= do {
1470                     my $id = CUSTOM_AUTHOR_ID;
1471
1472                     ### if the object is being created for the first time,
1473                     ### make sure there's an entry in the author tree as
1474                     ### well, so we can search on the CPAN ID
1475                     $self->author_tree->{ $id } =
1476                         CPANPLUS::Module::Author::Fake->new( cpanid => $id );
1477                 };
1478
1479                 $mod->author( $auth_obj );
1480
1481                 ### and now add it to the modlue tree -- this MAY
1482                 ### override things of course
1483                 if( my $old_mod = $self->module_tree( $mod->module ) ) {
1484
1485                     ### On VMS use the old module name to get the real case
1486                     $mod->module( $old_mod->module ) if ON_VMS;
1487
1488                     msg(loc("About to overwrite module tree entry for '%1' with '%2'",
1489                             $mod->module, $mod->package), $verbose);
1490                 }
1491
1492                 ### mark where it came from
1493                 $mod->description( loc("Custom source from '%1'",$name) );
1494
1495                 ### store it in the module tree
1496                 $self->module_tree->{ $mod->module } = $mod;
1497             }
1498         }
1499
1500         return 1;
1501     }
1502 }
1503
1504
1505 # Local variables:
1506 # c-indentation-style: bsd
1507 # c-basic-offset: 4
1508 # indent-tabs-mode: nil
1509 # End:
1510 # vim: expandtab shiftwidth=4:
1511
1512 1;