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