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