[Summary view] [Print] [Text view]

   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: