home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / CPANPLUS / Internals.pm < prev    next >
Encoding:
Perl POD Document  |  2009-06-26  |  13.7 KB  |  508 lines
  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:
  508.