[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::Source;
use CPANPLUS::Internals::Extract;
use CPANPLUS::Internals::Fetch;
use CPANPLUS::Internals::Utils;
use CPANPLUS::Internals::Constants;
use CPANPLUS::Internals::Search;
use CPANPLUS::Internals::Report;

use Cwd                         qw[cwd];
use Params::Check               qw[check];
use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';

use Object::Accessor;


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

use vars qw[@ISA $VERSION];

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

$VERSION = "0.79_03";

=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

=item _lib

Get/set the current @INC path -- @INC is reset to this after each
install.

=item _perl5lib

Get/set the current PERL5LIB environment variable -- $ENV{PERL5LIB}
is reset to this after each install.

=cut

### autogenerate accessors ###
for my $key ( qw[_conf _id _lib _perl5lib _modules _hosts _methods _status
                 _callbacks _selfupdate]
) {
    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 },
    };
    
    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 },
        _lib        => { default => [ @INC ],           no_override => 1 },
        _perl5lib   => { default => $ENV{'PERL5LIB'},   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 ] .
                     q[running program], '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( {} );

        ### allow for dirs to be added to @INC at runtime,
        ### rather then compile time
        push @INC, @{$conf->get_conf('lib')};

        ### add any possible new dirs ###
        $args->_lib( [@INC] );

        $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) );
        }

        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 %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}  = $self->_perl5lib || '';
                @INC            = @{$self->_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.

=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;

    for my $lib (@$dirs) {
        push @INC, $lib unless grep { $_ eq $lib } @INC;
    }

    {   local $^W;  ### it will be complaining if $ENV{PERL5LIB]
                    ### is not defined (yet).
        $ENV{'PERL5LIB'} .= join '', map { $Config{'path_sep'} . $_ } @$dirs;
    }

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