lib/CPANPLUS/Internals.pm

   1 package CPANPLUS::Internals;
   2
   3 ### we /need/ perl5.6.1 or higher -- we use coderefs in @INC,
   4 ### and 5.6.0 is just too buggy
   5 use 5.006001;
   6
   7 use strict;
   8 use Config;
   9
  10
  11 use CPANPLUS::Error;
  12
  13 use CPANPLUS::Selfupdate;
  14
  15 use CPANPLUS::Internals::Extract;
  16 use CPANPLUS::Internals::Fetch;
  17 use CPANPLUS::Internals::Utils;
  18 use CPANPLUS::Internals::Constants;
  19 use CPANPLUS::Internals::Search;
  20 use CPANPLUS::Internals::Report;
  21
  22
  23 require base;
  24 use Cwd                         qw[cwd];
  25 use Module::Load                qw[load];
  26 use Params::Check               qw[check];
  27 use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
  28 use Module::Load::Conditional   qw[can_load];
  29
  30 use Object::Accessor;
  31
  32
  33 local $Params::Check::VERBOSE = 1;
  34
  35 use vars qw[@ISA $VERSION];
  36
  37 @ISA = qw[
  38             CPANPLUS::Internals::Extract
  39             CPANPLUS::Internals::Fetch
  40             CPANPLUS::Internals::Utils
  41             CPANPLUS::Internals::Search
  42             CPANPLUS::Internals::Report
  43         ];
  44
  45 $VERSION = "0.86_06";
  46
  47 =pod
  48
  49 =head1 NAME
  50
  51 CPANPLUS::Internals
  52
  53 =head1 SYNOPSIS
  54
  55     my $internals   = CPANPLUS::Internals->_init( _conf => $conf );
  56     my $backend     = CPANPLUS::Internals->_retrieve_id( $ID );
  57
  58 =head1 DESCRIPTION
  59
  60 This module is the guts of CPANPLUS -- it inherits from all other
  61 modules in the CPANPLUS::Internals::* namespace, thus defying normal
  62 rules of OO programming -- but if you're reading this, you already
  63 know what's going on ;)
  64
  65 Please read the C<CPANPLUS::Backend> documentation for the normal API.
  66
  67 =head1 ACCESSORS
  68
  69 =over 4
  70
  71 =item _conf
  72
  73 Get/set the configure object
  74
  75 =item _id
  76
  77 Get/set the id
  78
  79 =cut
  80
  81 ### autogenerate accessors ###
  82 for my $key ( qw[_conf _id _modules _hosts _methods _status
  83                  _callbacks _selfupdate _mtree _atree]
  84 ) {
  85     no strict 'refs';
  86     *{__PACKAGE__."::$key"} = sub {
  87         $_[0]->{$key} = $_[1] if @_ > 1;
  88         return $_[0]->{$key};
  89     }
  90 }
  91
  92 =pod
  93
  94 =back
  95
  96 =head1 METHODS
  97
  98 =head2 $internals = CPANPLUS::Internals->_init( _conf => CONFIG_OBJ )
  99
 100 C<_init> creates a new CPANPLUS::Internals object.
 101
 102 You have to pass it a valid C<CPANPLUS::Configure> object.
 103
 104 Returns the object on success, or dies on failure.
 105
 106 =cut
 107 {   ### NOTE:
 108     ### if extra callbacks are added, don't forget to update the
 109     ### 02-internals.t test script with them!
 110     my $callback_map = {
 111         ### name                default value
 112         install_prerequisite    => 1,   # install prereqs when 'ask' is set?
 113         edit_test_report        => 0,   # edit the prepared test report?
 114         send_test_report        => 1,   # send the test report?
 115                                         # munge the test report
 116         munge_test_report       => sub { return $_[1] },
 117                                         # filter out unwanted prereqs
 118         filter_prereqs          => sub { return $_[1] },
 119                                         # continue if 'make test' fails?
 120         proceed_on_test_failure => sub { return 0 },
 121         munge_dist_metafile     => sub { return $_[1] },
 122     };
 123
 124     my $status = Object::Accessor->new;
 125     $status->mk_accessors(qw[pending_prereqs]);
 126
 127     my $callback = Object::Accessor->new;
 128     $callback->mk_accessors(keys %$callback_map);
 129
 130     my $conf;
 131     my $Tmpl = {
 132         _conf       => { required => 1, store => \$conf,
 133                             allow => IS_CONFOBJ },
 134         _id         => { default => '',                 no_override => 1 },
 135         _authortree => { default => '',                 no_override => 1 },
 136         _modtree    => { default => '',                 no_override => 1 },
 137         _hosts      => { default => {},                 no_override => 1 },
 138         _methods    => { default => {},                 no_override => 1 },
 139         _status     => { default => '<empty>',          no_override => 1 },
 140         _callbacks  => { default => '<empty>',          no_override => 1 },
 141     };
 142
 143     sub _init {
 144         my $class   = shift;
 145         my %hash    = @_;
 146
 147         ### temporary warning until we fix the storing of multiple id's
 148         ### and their serialization:
 149         ### probably not going to happen --kane
 150         if( my $id = $class->_last_id ) {
 151             # make it a singleton.
 152             warn loc(q[%1 currently only supports one %2 object per ] .
 153                      qq[running program\n], 'CPANPLUS', $class);
 154
 155             return $class->_retrieve_id( $id );
 156         }
 157
 158         my $args = check($Tmpl, \%hash)
 159                     or die loc(qq[Could not initialize '%1' object], $class);
 160
 161         bless $args, $class;
 162
 163         $args->{'_id'}          = $args->_inc_id;
 164         $args->{'_status'}      = $status;
 165         $args->{'_callbacks'}   = $callback;
 166
 167         ### initialize callbacks to default state ###
 168         for my $name ( $callback->ls_accessors ) {
 169             my $rv = ref $callback_map->{$name} ? 'sub return value' :
 170                          $callback_map->{$name} ? 'true' : 'false';
 171
 172             $args->_callbacks->$name(
 173                 sub { msg(loc("DEFAULT '%1' HANDLER RETURNING '%2'",
 174                               $name, $rv), $args->_conf->get_conf('debug'));
 175                       return ref $callback_map->{$name}
 176                                 ? $callback_map->{$name}->( @_ )
 177                                 : $callback_map->{$name};
 178                 }
 179             );
 180         }
 181
 182         ### create a selfupdate object
 183         $args->_selfupdate( CPANPLUS::Selfupdate->new( $args ) );
 184
 185         ### initalize it as an empty hashref ###
 186         $args->_status->pending_prereqs( {} );
 187
 188         $conf->_set_build( startdir => cwd() ),
 189             or error( loc("couldn't locate current dir!") );
 190
 191         $ENV{FTP_PASSIVE} = 1, if $conf->get_conf('passive');
 192
 193         my $id = $args->_store_id( $args );
 194
 195         unless ( $id == $args->_id ) {
 196             error( loc("IDs do not match: %1 != %2. Storage failed!",
 197                         $id, $args->_id) );
 198         }
 199
 200         ### different source engines available now, so set them here
 201         {   my $store = $conf->get_conf( 'source_engine' )
 202                             || DEFAULT_SOURCE_ENGINE;
 203
 204             unless( can_load( modules => { $store => '0.0' }, verbose => 1 ) ) {
 205                 error( loc( "Could not load source engine '%1'", $store ) );
 206
 207                 if( $store ne DEFAULT_SOURCE_ENGINE ) {
 208                     msg( loc("Falling back to %1", DEFAULT_SOURCE_ENGINE), 1 );
 209
 210                     load DEFAULT_SOURCE_ENGINE;
 211
 212                     base->import( DEFAULT_SOURCE_ENGINE );
 213                 } else {
 214                     return;
 215                 }
 216             } else {
 217                  base->import( $store );
 218             }
 219         }
 220
 221         return $args;
 222     }
 223
 224 =pod
 225
 226 =head2 $bool = $internals->_flush( list => \@caches )
 227
 228 Flushes the designated caches from the C<CPANPLUS> object.
 229
 230 Returns true on success, false if one or more caches could not be
 231 be flushed.
 232
 233 =cut
 234
 235     sub _flush {
 236         my $self = shift;
 237         my $conf = $self->configure_object;
 238         my %hash = @_;
 239
 240         my $aref;
 241         my $tmpl = {
 242             list    => { required => 1, default => [],
 243                             strict_type => 1, store => \$aref },
 244         };
 245
 246         my $args = check( $tmpl, \%hash ) or return;
 247
 248         my $flag = 0;
 249         for my $what (@$aref) {
 250             my $cache = '_' . $what;
 251
 252             ### set the include paths back to their original ###
 253             if( $what eq 'lib' ) {
 254                 $ENV{PERL5LIB}  = $conf->_perl5lib || '';
 255                 @INC            = @{$conf->_lib};
 256
 257             ### give all modules a new status object -- this is slightly
 258             ### costly, but the best way to make sure all statusses are
 259             ### forgotten --kane
 260             } elsif ( $what eq 'modules' ) {
 261                 for my $modobj ( values %{$self->module_tree} ) {
 262
 263                     $modobj->_flush;
 264                 }
 265
 266             ### blow away the methods cache... currently, that's only
 267             ### File::Fetch's method fail list
 268             } elsif ( $what eq 'methods' ) {
 269
 270                 ### still fucking p4 :( ###
 271                 $File'Fetch::METHOD_FAIL = $File'Fetch::METHOD_FAIL = {};
 272
 273             ### blow away the m::l::c cache, so modules can be (re)loaded
 274             ### again if they become available
 275             } elsif ( $what eq 'load' ) {
 276                 undef $Module::Load::Conditional::CACHE;
 277
 278             } else {
 279                 unless ( exists $self->{$cache} && exists $Tmpl->{$cache} ) {
 280                     error( loc( "No such cache: '%1'", $what ) );
 281                     $flag++;
 282                     next;
 283                 } else {
 284                     $self->$cache( {} );
 285                 }
 286             }
 287         }
 288         return !$flag;
 289     }
 290
 291 ### NOTE:
 292 ### if extra callbacks are added, don't forget to update the
 293 ### 02-internals.t test script with them!
 294
 295 =pod
 296
 297 =head2 $bool = $internals->_register_callback( name => CALLBACK_NAME, code => CODEREF );
 298
 299 Registers a callback for later use by the internal libraries.
 300
 301 Here is a list of the currently used callbacks:
 302
 303 =over 4
 304
 305 =item install_prerequisite
 306
 307 Is called when the user wants to be C<asked> about what to do with
 308 prerequisites. Should return a boolean indicating true to install
 309 the prerequisite and false to skip it.
 310
 311 =item send_test_report
 312
 313 Is called when the user should be prompted if he wishes to send the
 314 test report. Should return a boolean indicating true to send the
 315 test report and false to skip it.
 316
 317 =item munge_test_report
 318
 319 Is called when the test report message has been composed, giving
 320 the user a chance to programatically alter it. Should return the
 321 (munged) message to be sent.
 322
 323 =item edit_test_report
 324
 325 Is called when the user should be prompted to edit test reports
 326 about to be sent out by Test::Reporter. Should return a boolean
 327 indicating true to edit the test report in an editor and false
 328 to skip it.
 329
 330 =item proceed_on_test_failure
 331
 332 Is called when 'make test' or 'Build test' fails. Should return
 333 a boolean indicating whether the install should continue even if
 334 the test failed.
 335
 336 =item munge_dist_metafile
 337
 338 Is called when the C<CPANPLUS::Dist::*> metafile is created, like
 339 C<control> for C<CPANPLUS::Dist::Deb>, giving the user a chance to
 340 programatically alter it. Should return the (munged) text to be
 341 written to the metafile.
 342
 343 =back
 344
 345 =cut
 346
 347     sub _register_callback {
 348         my $self = shift or return;
 349         my %hash = @_;
 350
 351         my ($name,$code);
 352         my $tmpl = {
 353             name    => { required => 1, store => \$name,
 354                          allow => [$callback->ls_accessors] },
 355             code    => { required => 1, allow => IS_CODEREF,
 356                          store => \$code },
 357         };
 358
 359         check( $tmpl, \%hash ) or return;
 360
 361         $self->_callbacks->$name( $code ) or return;
 362
 363         return 1;
 364     }
 365
 366 # =head2 $bool = $internals->_add_callback( name => CALLBACK_NAME, code => CODEREF );
 367 #
 368 # Adds a new callback to be used from anywhere in the system. If the callback
 369 # is already known, an error is raised and false is returned. If the callback
 370 # is not yet known, it is added, and the corresponding coderef is registered
 371 # using the
 372 #
 373 # =cut
 374 #
 375 #     sub _add_callback {
 376 #         my $self = shift or return;
 377 #         my %hash = @_;
 378 #
 379 #         my ($name,$code);
 380 #         my $tmpl = {
 381 #             name    => { required => 1, store => \$name, },
 382 #             code    => { required => 1, allow => IS_CODEREF,
 383 #                          store => \$code },
 384 #         };
 385 #
 386 #         check( $tmpl, \%hash ) or return;
 387 #
 388 #         if( $callback->can( $name ) ) {
 389 #             error(loc("Callback '%1' is already registered"));
 390 #             return;
 391 #         }
 392 #
 393 #         $callback->mk_accessor( $name );
 394 #
 395 #         $self->_register_callback( name => $name, code => $code ) or return;
 396 #
 397 #         return 1;
 398 #     }
 399
 400 }
 401
 402 =pod
 403
 404 =head2 $bool = $internals->_add_to_includepath( directories => \@dirs )
 405
 406 Adds a list of directories to the include path.
 407 This means they get added to C<@INC> as well as C<$ENV{PERL5LIB}>.
 408
 409 Returns true on success, false on failure.
 410
 411 =cut
 412
 413 sub _add_to_includepath {
 414     my $self = shift;
 415     my %hash = @_;
 416
 417     my $dirs;
 418     my $tmpl = {
 419         directories => { required => 1, default => [], store => \$dirs,
 420                          strict_type => 1 },
 421     };
 422
 423     check( $tmpl, \%hash ) or return;
 424
 425     for my $lib (@$dirs) {
 426         push @INC, $lib unless grep { $_ eq $lib } @INC;
 427     }
 428
 429     {   local $^W;  ### it will be complaining if $ENV{PERL5LIB]
 430                     ### is not defined (yet).
 431         $ENV{'PERL5LIB'} .= join '', map { $Config{'path_sep'} . $_ } @$dirs;
 432     }
 433
 434     return 1;
 435 }
 436
 437 =pod
 438
 439 =head2 $id = CPANPLUS::Internals->_last_id
 440
 441 Return the id of the last object stored.
 442
 443 =head2 $id = CPANPLUS::Internals->_store_id( $internals )
 444
 445 Store this object; return its id.
 446
 447 =head2 $obj = CPANPLUS::Internals->_retrieve_id( $ID )
 448
 449 Retrieve an object based on its ID -- return false on error.
 450
 451 =head2 CPANPLUS::Internals->_remove_id( $ID )
 452
 453 Remove the object marked by $ID from storage.
 454
 455 =head2 @objs = CPANPLUS::Internals->_return_all_objects
 456
 457 Return all stored objects.
 458
 459 =cut
 460
 461
 462 ### code for storing multiple objects
 463 ### -- although we only support one right now
 464 ### XXX when support for multiple objects comes, saving source will have
 465 ### to change
 466 {
 467     my $idref = {};
 468     my $count = 0;
 469
 470     sub _inc_id { return ++$count; }
 471
 472     sub _last_id { $count }
 473
 474     sub _store_id {
 475         my $self    = shift;
 476         my $obj     = shift or return;
 477
 478        unless( IS_INTERNALS_OBJ->($obj) ) {
 479             error( loc("The object you passed has the wrong ref type: '%1'",
 480                         ref $obj) );
 481             return;
 482         }
 483
 484         $idref->{ $obj->_id } = $obj;
 485         return $obj->_id;
 486     }
 487
 488     sub _retrieve_id {
 489         my $self    = shift;
 490         my $id      = shift or return;
 491
 492         my $obj = $idref->{$id};
 493         return $obj;
 494     }
 495
 496     sub _remove_id {
 497         my $self    = shift;
 498         my $id      = shift or return;
 499
 500         return delete $idref->{$id};
 501     }
 502
 503     sub _return_all_objects { return values %$idref }
 504 }
 505
 506 1;
 507
 508 # Local variables:
 509 # c-indentation-style: bsd
 510 # c-basic-offset: 4
 511 # indent-tabs-mode: nil
 512 # End:
 513 # vim: expandtab shiftwidth=4: