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