[perl5.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.84";

=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 },
        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 },
        _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 ] .
                     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( {} );

        ### 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.

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

    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 RGS	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
8d5f6fc7	43	$VERSION = "0.84";
6aaee015 RGS	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 JB	102	=back
622d31ac JB	103
6aaee015 RGS	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 RGS	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 JB	127	# continue if 'make test' fails?
622d31ac JB	128	proceed_on_test_failure => sub { return 0 },
502c7995	129	munge_dist_metafile => sub { return $_[1] },
6aaee015 RGS	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 ] .
d0baa00e	163	qq[running program\n], 'CPANPLUS', $class);
6aaee015 RGS	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
622d31ac JB	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
502c7995 JB	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
6aaee015 RGS	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: