[p5sagit/p5-mst-13.2.git] / lib / CPANPLUS / Internals.pm

package CPANPLUS::Internals;

### we /need/ perl5.6.1 or higher -- we use coderefs in @INC,
### and 5.6.0 is just too buggy
use 5.006001;

use strict;
use Config;


use CPANPLUS::Error;

use CPANPLUS::Selfupdate;

use CPANPLUS::Internals::Extract;
use CPANPLUS::Internals::Fetch;
use CPANPLUS::Internals::Utils;
use CPANPLUS::Internals::Constants;
use CPANPLUS::Internals::Search;
use CPANPLUS::Internals::Report;


require base;
use Cwd                         qw[cwd];
use Module::Load                qw[load];
use Params::Check               qw[check];
use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
use Module::Load::Conditional   qw[can_load];

use Object::Accessor;


local $Params::Check::VERBOSE = 1;

use vars qw[@ISA $VERSION];

@ISA = qw[
            CPANPLUS::Internals::Extract
            CPANPLUS::Internals::Fetch
            CPANPLUS::Internals::Utils
            CPANPLUS::Internals::Search
            CPANPLUS::Internals::Report
        ];

$VERSION = "0.87_02";

=pod

=head1 NAME

CPANPLUS::Internals

=head1 SYNOPSIS

    my $internals   = CPANPLUS::Internals->_init( _conf => $conf );
    my $backend     = CPANPLUS::Internals->_retrieve_id( $ID );

=head1 DESCRIPTION

This module is the guts of CPANPLUS -- it inherits from all other
modules in the CPANPLUS::Internals::* namespace, thus defying normal
rules of OO programming -- but if you're reading this, you already
know what's going on ;)

Please read the C<CPANPLUS::Backend> documentation for the normal API.

=head1 ACCESSORS

=over 4

=item _conf

Get/set the configure object

=item _id

Get/set the id

=cut

### autogenerate accessors ###
for my $key ( qw[_conf _id _modules _hosts _methods _status
                 _callbacks _selfupdate _mtree _atree]
) {
    no strict 'refs';
    *{__PACKAGE__."::$key"} = sub {
        $_[0]->{$key} = $_[1] if @_ > 1;
        return $_[0]->{$key};
    }
}

=pod

=back

=head1 METHODS

=head2 $internals = CPANPLUS::Internals->_init( _conf => CONFIG_OBJ )

C<_init> creates a new CPANPLUS::Internals object.

You have to pass it a valid C<CPANPLUS::Configure> object.

Returns the object on success, or dies on failure.

=cut
{   ### NOTE:
    ### if extra callbacks are added, don't forget to update the
    ### 02-internals.t test script with them!
    my $callback_map = {
        ### name                default value    
        install_prerequisite    => 1,   # install prereqs when 'ask' is set?
        edit_test_report        => 0,   # edit the prepared test report?
        send_test_report        => 1,   # send the test report?
                                        # munge the test report
        munge_test_report       => sub { return $_[1] },
                                        # filter out unwanted prereqs
        filter_prereqs          => sub { return $_[1] },
                                        # continue if 'make test' fails?
        proceed_on_test_failure => sub { return 0 },
        munge_dist_metafile     => sub { return $_[1] },
    };
    
    my $status = Object::Accessor->new;
    $status->mk_accessors(qw[pending_prereqs]);

    my $callback = Object::Accessor->new;
    $callback->mk_accessors(keys %$callback_map);

    my $conf;
    my $Tmpl = {
        _conf       => { required => 1, store => \$conf,
                            allow => IS_CONFOBJ },
        _id         => { default => '',                 no_override => 1 },
        _authortree => { default => '',                 no_override => 1 },
        _modtree    => { default => '',                 no_override => 1 },
        _hosts      => { default => {},                 no_override => 1 },
        _methods    => { default => {},                 no_override => 1 },
        _status     => { default => '<empty>',          no_override => 1 },
        _callbacks  => { default => '<empty>',          no_override => 1 },
    };

    sub _init {
        my $class   = shift;
        my %hash    = @_;

        ### temporary warning until we fix the storing of multiple id's
        ### and their serialization:
        ### probably not going to happen --kane
        if( my $id = $class->_last_id ) {
            # make it a singleton.
            warn loc(q[%1 currently only supports one %2 object per ] .
                     qq[running program\n], 'CPANPLUS', $class);

            return $class->_retrieve_id( $id );
        }

        my $args = check($Tmpl, \%hash)
                    or die loc(qq[Could not initialize '%1' object], $class);

        bless $args, $class;

        $args->{'_id'}          = $args->_inc_id;
        $args->{'_status'}      = $status;
        $args->{'_callbacks'}   = $callback;

        ### initialize callbacks to default state ###
        for my $name ( $callback->ls_accessors ) {
            my $rv = ref $callback_map->{$name} ? 'sub return value' :
                         $callback_map->{$name} ? 'true' : 'false';
        
            $args->_callbacks->$name(
                sub { msg(loc("DEFAULT '%1' HANDLER RETURNING '%2'",
                              $name, $rv), $args->_conf->get_conf('debug')); 
                      return ref $callback_map->{$name} 
                                ? $callback_map->{$name}->( @_ )
                                : $callback_map->{$name};
                } 
            );
        }

        ### create a selfupdate object
        $args->_selfupdate( CPANPLUS::Selfupdate->new( $args ) );

        ### initalize it as an empty hashref ###
        $args->_status->pending_prereqs( {} );

        $conf->_set_build( startdir => cwd() ),
            or error( loc("couldn't locate current dir!") );

        $ENV{FTP_PASSIVE} = 1, if $conf->get_conf('passive');

        my $id = $args->_store_id( $args );

        unless ( $id == $args->_id ) {
            error( loc("IDs do not match: %1 != %2. Storage failed!",
                        $id, $args->_id) );
        }

        ### different source engines available now, so set them here
        {   my $store = $conf->get_conf( 'source_engine' ) 
                            || DEFAULT_SOURCE_ENGINE;

            unless( can_load( modules => { $store => '0.0' }, verbose => 1 ) ) {
                error( loc( "Could not load source engine '%1'", $store ) );
            
                if( $store ne DEFAULT_SOURCE_ENGINE ) {
                    msg( loc("Falling back to %1", DEFAULT_SOURCE_ENGINE), 1 );
                   
                    load DEFAULT_SOURCE_ENGINE;
                    
                    base->import( DEFAULT_SOURCE_ENGINE );
                } else {
                    return;
                }     
            } else {
                 base->import( $store );
            }                
        }

        return $args;
    }

=pod

=head2 $bool = $internals->_flush( list => \@caches )

Flushes the designated caches from the C<CPANPLUS> object.

Returns true on success, false if one or more caches could not be
be flushed.

=cut

    sub _flush {
        my $self = shift;
        my $conf = $self->configure_object;
        my %hash = @_;

        my $aref;
        my $tmpl = {
            list    => { required => 1, default => [],
                            strict_type => 1, store => \$aref },
        };

        my $args = check( $tmpl, \%hash ) or return;

        my $flag = 0;
        for my $what (@$aref) {
            my $cache = '_' . $what;

            ### set the include paths back to their original ###
            if( $what eq 'lib' ) {
                $ENV{PERL5LIB}  = $conf->_perl5lib || '';
                @INC            = @{$conf->_lib};

            ### give all modules a new status object -- this is slightly
            ### costly, but the best way to make sure all statusses are
            ### forgotten --kane
            } elsif ( $what eq 'modules' ) {
                for my $modobj ( values %{$self->module_tree} ) {

                    $modobj->_flush;
                }

            ### blow away the methods cache... currently, that's only
            ### File::Fetch's method fail list
            } elsif ( $what eq 'methods' ) {

                ### still fucking p4 :( ###
                $File'Fetch::METHOD_FAIL = $File'Fetch::METHOD_FAIL = {};

            ### blow away the m::l::c cache, so modules can be (re)loaded
            ### again if they become available
            } elsif ( $what eq 'load' ) {
                undef $Module::Load::Conditional::CACHE;

            } else {
                unless ( exists $self->{$cache} && exists $Tmpl->{$cache} ) {
                    error( loc( "No such cache: '%1'", $what ) );
                    $flag++;
                    next;
                } else {
                    $self->$cache( {} );
                }
            }
        }
        return !$flag;
    }

### NOTE:
### if extra callbacks are added, don't forget to update the
### 02-internals.t test script with them!

=pod 

=head2 $bool = $internals->_register_callback( name => CALLBACK_NAME, code => CODEREF );

Registers a callback for later use by the internal libraries.

Here is a list of the currently used callbacks:

=over 4

=item install_prerequisite

Is called when the user wants to be C<asked> about what to do with
prerequisites. Should return a boolean indicating true to install
the prerequisite and false to skip it.

=item send_test_report

Is called when the user should be prompted if he wishes to send the
test report. Should return a boolean indicating true to send the 
test report and false to skip it.

=item munge_test_report

Is called when the test report message has been composed, giving
the user a chance to programatically alter it. Should return the 
(munged) message to be sent.

=item edit_test_report

Is called when the user should be prompted to edit test reports
about to be sent out by Test::Reporter. Should return a boolean 
indicating true to edit the test report in an editor and false 
to skip it.

=item proceed_on_test_failure

Is called when 'make test' or 'Build test' fails. Should return
a boolean indicating whether the install should continue even if
the test failed.

=item munge_dist_metafile

Is called when the C<CPANPLUS::Dist::*> metafile is created, like
C<control> for C<CPANPLUS::Dist::Deb>, giving the user a chance to
programatically alter it. Should return the (munged) text to be
written to the metafile.

=back

=cut

    sub _register_callback {
        my $self = shift or return;
        my %hash = @_;

        my ($name,$code);
        my $tmpl = {
            name    => { required => 1, store => \$name,
                         allow => [$callback->ls_accessors] },
            code    => { required => 1, allow => IS_CODEREF,
                         store => \$code },
        };

        check( $tmpl, \%hash ) or return;

        $self->_callbacks->$name( $code ) or return;

        return 1;
    }

# =head2 $bool = $internals->_add_callback( name => CALLBACK_NAME, code => CODEREF );
# 
# Adds a new callback to be used from anywhere in the system. If the callback
# is already known, an error is raised and false is returned. If the callback
# is not yet known, it is added, and the corresponding coderef is registered
# using the
# 
# =cut
# 
#     sub _add_callback {
#         my $self = shift or return;
#         my %hash = @_;
#         
#         my ($name,$code);
#         my $tmpl = {
#             name    => { required => 1, store => \$name, },
#             code    => { required => 1, allow => IS_CODEREF,
#                          store => \$code },
#         };
# 
#         check( $tmpl, \%hash ) or return;
# 
#         if( $callback->can( $name ) ) {
#             error(loc("Callback '%1' is already registered"));
#             return;
#         }
# 
#         $callback->mk_accessor( $name );
# 
#         $self->_register_callback( name => $name, code => $code ) or return;
# 
#         return 1;
#     }

}

=pod

=head2 $bool = $internals->_add_to_includepath( directories => \@dirs )

Adds a list of directories to the include path.
This means they get added to C<@INC> as well as C<$ENV{PERL5LIB}>.

Returns true on success, false on failure.

=cut

sub _add_to_includepath {
    my $self = shift;
    my %hash = @_;

    my $dirs;
    my $tmpl = {
        directories => { required => 1, default => [], store => \$dirs,
                         strict_type => 1 },
    };

    check( $tmpl, \%hash ) or return;

    my $s = $Config{'path_sep'};
    
    ### only add if it's not added yet
    for my $lib (@$dirs) {
        push @INC, $lib unless grep { $_ eq $lib } @INC;
        #
        ### it will be complaining if $ENV{PERL5LIB] is not defined (yet).   
        local $^W;  
        $ENV{'PERL5LIB'} .= $s . $lib 
            unless $ENV{'PERL5LIB'} =~ qr|\Q$s$lib\E|;
    }

    return 1;
}

=pod

=head2 $id = CPANPLUS::Internals->_last_id

Return the id of the last object stored.

=head2 $id = CPANPLUS::Internals->_store_id( $internals )

Store this object; return its id.

=head2 $obj = CPANPLUS::Internals->_retrieve_id( $ID )

Retrieve an object based on its ID -- return false on error.

=head2 CPANPLUS::Internals->_remove_id( $ID )

Remove the object marked by $ID from storage.

=head2 @objs = CPANPLUS::Internals->_return_all_objects

Return all stored objects.

=cut


### code for storing multiple objects
### -- although we only support one right now
### XXX when support for multiple objects comes, saving source will have
### to change
{
    my $idref = {};
    my $count = 0;

    sub _inc_id { return ++$count; }

    sub _last_id { $count }

    sub _store_id {
        my $self    = shift;
        my $obj     = shift or return;

       unless( IS_INTERNALS_OBJ->($obj) ) {
            error( loc("The object you passed has the wrong ref type: '%1'",
                        ref $obj) );
            return;
        }

        $idref->{ $obj->_id } = $obj;
        return $obj->_id;
    }

    sub _retrieve_id {
        my $self    = shift;
        my $id      = shift or return;

        my $obj = $idref->{$id};
        return $obj;
    }

    sub _remove_id {
        my $self    = shift;
        my $id      = shift or return;

        return delete $idref->{$id};
    }

    sub _return_all_objects { return values %$idref }
}

1;

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