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