——————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::inc;
use
CPANPLUS::Error;
use
Object::Accessor;
local
$Params::Check::VERBOSE
= 1;
@ISA
=
qw[
CPANPLUS::Internals::Source
CPANPLUS::Internals::Extract
CPANPLUS::Internals::Fetch
CPANPLUS::Internals::Utils
CPANPLUS::Internals::Search
CPANPLUS::Internals::Report
]
;
$VERSION
=
'0.055'
;
=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]
) {
no
strict
'refs'
;
*{__PACKAGE__.
"::$key"
} =
sub
{
$_
[0]->{
$key
} =
$_
[1]
if
@_
> 1;
return
$_
[0]->{
$key
};
}
}
=pod
=head1 METHODS
=head2 _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
{
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] },
};
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
};
}
);
}
### 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 _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 _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.
=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;
}
}
=pod
=head2 _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 _last_id
Return the id of the last object stored.
=head2 _store_id
Store this object; return its id.
=head2 _retrieve_id( $ID )
Retrieve an object based on its ID -- return false on error.
=head2 _remove_id( $ID )
Remove the object marked by $ID from storage.
=head2 _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
}
}
sub
END {
my
@obs
= __PACKAGE__->_return_all_objects();
$obs
[0]->_save_source()
if
scalar
@obs
;
}
1;
# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4: