CPANPLUS
view release on metacpan or search on metacpan
of the bundles modules to be indexed. This release is
only relevant to the PAUSE indexer, and changes nothing
on the client side whatsoever.
0.052 Wed Feb 9 18:44:13 CET 2005
* Make auto-installation work (with some guess work) if
$ENV{PERL_MM_USE_DEFAULT} is set.
* Setup decent defaults for the callbacks, so scripts
don't have to set them unless they want actual callback
behaviour (This helps ExtUtils::AutoInstall greatly).
* chmod() extracted files to 755 so we do not get permission
denied errors when trying to remove them or copy over them
if they were not +w for the user.
* Don't use sudo, even if it's configured, if the user is
root already.
* Default to 'prefer binary programs' if Compress::Zlib is
not installed.
* Make 'parse_module' deal better with paths that have sub
bundled/Build.pm view on Meta::CPAN
>= version->new('0.9102');
}
### allows for a user defined callback to filter the prerequisite
### list as they see fit, to remove (or add) any prereqs they see
### fit. The default installed callback will return the hashref in
### an unmodified form
### this callback got added after cpanplus 0.0562, so use a 'can'
### to find out if it's supported. For older versions, we'll just
### return the hashref as is ourselves.
my $href = $cb->_callbacks->can('filter_prereqs')
? $cb->_callbacks->filter_prereqs->( $cb, $prereqs )
: $prereqs;
$self->status->prereqs( $href );
### make sure it's not the same ref
return { %$href };
}
sub create {
bundled/Build.pm view on Meta::CPAN
unless ( scalar run( command => $cmd,
buffer => \$test_output,
verbose => $verbose )
) {
error( loc( "MAKE TEST failed:\n%1 ", $test_output ), ( $verbose ? 0 : 1 ) );
### mark specifically *test* failure.. so we don't
### send success on force...
$test_fail++;
if( !$force and !$cb->_callbacks->proceed_on_test_failure->(
$self, $@ )
) {
$dist->status->test(0);
if ( $conf->get_conf('cpantest') ) {
$status->{stage} = 'test';
$status->{capture} = $test_output;
}
$fail++; last RUN;
}
inc/bundle/HTTP/Tiny.pm view on Meta::CPAN
$self->_update_cookie_jar( $url, $response ) if $self->{cookie_jar};
my @redir_args = $self->_maybe_redirect($request, $response, $args);
my $known_message_length;
if ($method eq 'HEAD' || $response->{status} =~ /^[23]04/) {
# response has no message body
$known_message_length = 1;
}
else {
# Ignore any data callbacks during redirection.
my $cb_args = @redir_args ? +{} : $args;
my $data_cb = $self->_prepare_data_cb($response, $cb_args);
$known_message_length = $handle->read_body($data_cb, $response);
}
if ( $self->{keep_alive}
&& $handle->connected
&& $known_message_length
&& $response->{protocol} eq 'HTTP/1.1'
&& ($response->{headers}{connection} || '') ne 'close'
inc/bundle/JSON/PP.pm view on Meta::CPAN
if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) {
my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} );
if (@val == 0) {
return $o;
}
elsif (@val == 1) {
return $val[0];
}
else {
Carp::croak("filter_json_single_key_object callbacks must not return more than one scalar");
}
}
my @val = $cb_object->($o) if ($cb_object);
if (@val == 0) {
return $o;
}
elsif (@val == 1) {
return $val[0];
}
else {
Carp::croak("filter_json_object callbacks must not return more than one scalar");
}
}
sub PP_decode_box {
{
text => $text,
at => $at,
ch => $ch,
len => $len,
inc/bundle/JSON/PP.pm view on Meta::CPAN
C<JSON::PP> throws an exception.
=back
=head3 DESERIALISATION
For deserialisation there are only two cases to consider: either
nonstandard tagging was used, in which case C<allow_tags> decides,
or objects cannot be automatically be deserialised, in which
case you can use postprocessing or the C<filter_json_object> or
C<filter_json_single_key_object> callbacks to get some real objects our of
your JSON.
This section only considers the tagged value case: a tagged JSON object
is encountered during decoding and C<allow_tags> is disabled, a parse
error will result (as if tagged values were not part of the grammar).
If C<allow_tags> is enabled, C<JSON::PP> will look up the C<THAW> method
of the package/classname used during serialisation (it will not attempt
to load the package as a Perl module). If there is no such method, the
decoding will fail with an error.
inc/bundle/Object/Accessor.pm view on Meta::CPAN
package Object::Accessor;
use if $] > 5.017, 'deprecate';
use strict;
use Carp qw[carp croak];
use vars qw[$FATAL $DEBUG $AUTOLOAD $VERSION];
use Params::Check qw[allow];
### some objects might have overload enabled, we'll need to
### disable string overloading for callbacks
require overload;
$VERSION = '0.48';
$FATAL = 0;
$DEBUG = 0;
use constant VALUE => 0; # array index in the hash value
use constant ALLOW => 1; # array index in the hash value
use constant ALIAS => 2; # array index in the hash value
inc/bundle/Object/Accessor.pm view on Meta::CPAN
$obj = My::Class->new; # create base object
$bool = $obj->mk_accessors('foo'); # create accessors, etc...
### make all attempted access to non-existent accessors fatal
### (defaults to false)
$Object::Accessor::FATAL = 1;
### enable debugging
$Object::Accessor::DEBUG = 1;
### advanced usage -- callbacks
{ my $obj = Object::Accessor->new('foo');
$obj->register_callback( sub { ... } );
$obj->foo( 1 ); # these calls invoke the callback you registered
$obj->foo() # which allows you to change the get/set
# behaviour and what is returned to the caller.
}
### advanced usage -- lvalue attributes
{ my $obj = Object::Accessor::Lvalue->new('foo');
inc/bundle/Object/Accessor.pm view on Meta::CPAN
### is this an alias?
if( my $org = $self->{ $acc }->[ ALIAS ] ) {
$clone->___alias( $acc => $org );
}
}
### copy the accessors from $self to $clone
$clone->mk_accessors( \%hash ) if %hash;
$clone->mk_accessors( @list ) if @list;
### copy callbacks
#$clone->{"$clone"} = $self->{"$self"} if $self->{"$self"};
$clone->___callback( $self->___callback );
return $clone;
}
=head2 $bool = $self->mk_flush;
Flushes all the data from the current object; all accessors will be
set back to their default state of C<undef>.
inc/bundle/Object/Accessor.pm view on Meta::CPAN
local $Params::Check::VERBOSE = 0;
allow( $val, $self->{$method}->[ALLOW] ) or (
__PACKAGE__->___error(
"'$val' is an invalid value for '$method'", 1),
return
);
}
}
### callbacks?
if( my $sub = $self->___callback ) {
$val = eval { $sub->( $self, $method, ($assign ? [$val] : []) ) };
### register the error
$self->___error( $@, 1 ), return if $@;
}
### now we can actually assign it
if( $assign ) {
$self->___set( $method, $val ) or return;
}
return [$val];
}
=head2 $val = $self->___get( METHOD_NAME );
Method to directly access the value of the given accessor in the
object. It circumvents all calls to allow checks, callbacks, etc.
Use only if you C<Know What You Are Doing>! General usage for
this functionality would be in your own custom callbacks.
=cut
### XXX O::A::lvalue is mirroring this behaviour! if this
### changes, lvalue's autoload must be changed as well
sub ___get {
my $self = shift;
my $method = shift or return;
return $self->{$method}->[VALUE];
}
=head2 $bool = $self->___set( METHOD_NAME => VALUE );
Method to directly set the value of the given accessor in the
object. It circumvents all calls to allow checks, callbacks, etc.
Use only if you C<Know What You Are Doing>! General usage for
this functionality would be in your own custom callbacks.
=cut
sub ___set {
my $self = shift;
my $method = shift or return;
### you didn't give us a value to set!
@_ or return;
my $val = shift;
lib/CPANPLUS/Dist.pm view on Meta::CPAN
### so don't ask again if the module turns out to be uptodate
### see bug [#11840]
### if either force or prereq_build are given, the prereq
### should be built anyway
next if (!$force and !$prereq_build) &&
$dist->prereq_satisfied(modobj => $modobj, version => $version);
### either we're told to ignore the prereq,
### or the user wants us to ask him
if( ( $conf->get_conf('prereqs') == PREREQ_ASK and not
$cb->_callbacks->install_prerequisite->($self, $modobj)
)
) {
msg(loc("Will not install prerequisite '%1' -- Note " .
"that the overall install may fail due to this",
$modobj->module), $verbose);
next;
}
### value set and false -- means failure ###
if( defined $modobj->status->installed
lib/CPANPLUS/Dist/MM.pm view on Meta::CPAN
file => { required => 1, allow => FILE_READABLE, store => \$file },
};
my $args = check( $tmpl, \%hash ) or return;
### see if we got prereqs from MYMETA
my $prereqs = $dist->find_mymeta_requires();
### we found some prereqs, we'll trust MYMETA
### but we do need to run it through the callback
return $cb->_callbacks->filter_prereqs->( $cb, $prereqs ) if keys %$prereqs;
my $fh = FileHandle->new();
unless( $fh->open( $file ) ) {
error( loc( "Cannot open '%1': %2", $file, $! ) );
return;
}
my %p;
while( local $_ = <$fh> ) {
my ($found) = m|^[\#]\s+PREREQ_PM\s+=>\s+(.+)|;
lib/CPANPLUS/Dist/MM.pm view on Meta::CPAN
$p{$1} = $ver
if $cb->_vcmp( $ver, $p{$1} ) > 0;
}
else {
$p{$1} = $cb->_version_to_number(version => $2);
}
}
last;
}
my $href = $cb->_callbacks->filter_prereqs->( $cb, \%p );
$self->status->prereqs( $href );
### just to make sure it's not the same reference ###
return { %$href };
}
=pod
=head2 $bool = $dist->create([perl => '/path/to/perl', make => '/path/to/make', makeflags => 'EXTRA=FLAGS', prereq_target => TARGET, skiptest => BOOL, force => BOOL, verbose => BOOL])
lib/CPANPLUS/Dist/MM.pm view on Meta::CPAN
}
### send out error report here? or do so at a higher level?
### --higher level --kane.
$dist->status->test(0);
### mark specifically *test* failure.. so we don't
### send success on force...
$test_fail++;
if( !$force and !$cb->_callbacks->proceed_on_test_failure->(
$self, $captured )
) {
$fail++; last RUN;
}
}
}
} #</RUN>
unless( $cb->_chdir( dir => $orig ) ) {
error( loc( "Could not chdir back to start dir '%1'", $orig ) );
lib/CPANPLUS/Internals.pm view on Meta::CPAN
Get/set the configure object
=item _id
Get/set the id
=cut
### autogenerate accessors ###
for my $key ( qw[_conf _id _modules _hosts _methods _status _path
_callbacks _selfupdate _mtree _atree]
) {
no strict 'refs';
*{__PACKAGE__."::$key"} = sub {
$_[0]->{$key} = $_[1] if @_ > 1;
return $_[0]->{$key};
}
}
=pod
lib/CPANPLUS/Internals.pm view on Meta::CPAN
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] },
lib/CPANPLUS/Internals.pm view on Meta::CPAN
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 },
_path => { default => $ENV{PATH} || '', 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
lib/CPANPLUS/Internals.pm view on Meta::CPAN
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
lib/CPANPLUS/Internals.pm view on Meta::CPAN
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
lib/CPANPLUS/Internals.pm view on Meta::CPAN
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
lib/CPANPLUS/Internals/Report.pm view on Meta::CPAN
### set a custom mx, if requested
$reporter->mx( [ $conf->get_conf('cpantest_mx') ] )
if $conf->get_conf('cpantest_mx');
### set the from address ###
$reporter->from( $conf->get_conf('email') )
if $conf->get_conf('email') !~ /\@example\.\w+$/i;
### give the user a chance to programmatically alter the message
$message = $self->_callbacks->munge_test_report->($mod, $message, $grade);
### add the body if we have any ###
$reporter->comments( $message ) if defined $message && length $message;
### do a callback to ask if we should send the report
unless ($self->_callbacks->send_test_report->($mod, $grade)) {
msg(loc("Ok, not sending test report"));
return 1;
}
### do a callback to ask if we should edit the report
if ($self->_callbacks->edit_test_report->($mod, $grade)) {
### test::reporter 1.20 and lower don't have a way to set
### the preferred editor with a method call, but it does
### respect your env variable, so let's set that.
local $ENV{VISUAL} = $conf->get_program('editor')
if $conf->get_program('editor');
$reporter->edit_comments;
}
### allow to be overridden, but default to the normal address ###
lib/CPANPLUS/Shell/Default.pm view on Meta::CPAN
### register install callback ###
$cb->_register_callback(
name => 'install_prerequisite',
code => \&__ask_about_install,
);
### execute any login commands specified ###
$self->dispatch_on_input( input => $rc->{'login'} )
if defined $rc->{'login'};
### register test report callbacks ###
$cb->_register_callback(
name => 'edit_test_report',
code => \&__ask_about_edit_test_report,
);
$cb->_register_callback(
name => 'send_test_report',
code => \&__ask_about_send_test_report,
);
t/02_CPANPLUS-Internals.t view on Meta::CPAN
munge_test_report => $$, # munge the test report
filter_prereqs => $$, # limit prereqs
proceed_on_test_failure => 0, # continue on failed 'make test'?
munge_dist_metafile => $$, # munge the metailfe
};
for my $callback ( keys %$callback_map ) {
{ my $rv = $callback_map->{$callback};
is( $rv, $cb->_callbacks->$callback->( $0, $$ ),
"Default callback '$callback' called" );
like( CPANPLUS::Error->stack_as_string, qr/DEFAULT '\S+' HANDLER/s,
" Default handler warning recorded" );
CPANPLUS::Error->flush;
}
### try to register the callback
my $ok = $cb->_register_callback(
name => $callback,
code => sub { return $callback }
);
ok( $ok, "Registered callback '$callback' ok" );
my $sub = $cb->_callbacks->$callback;
ok( $sub, " Retrieved callback" );
ok( IS_CODEREF->($sub), " Callback is a sub" );
my $rv = $sub->();
ok( $rv, " Callback called ok" );
is( $rv, $callback, " Got expected return value" );
}
}
t/20_CPANPLUS-Dist-MM.t view on Meta::CPAN
#$IPC::Cmd::DEBUG = $Verbose;
### Make sure we get the _EUMM_NOXS_ version
my $ModName = TEST_CONF_MODULE;
### This is the module name that gets /installed/
my $InstName = TEST_CONF_INST_MODULE;
### don't start sending test reports now... ###
$cb->_callbacks->send_test_report( sub { 0 } );
$conf->set_conf( cpantest => 0 );
### Redirect errors to file ###
*STDERR = output_handle() unless $conf->get_conf('verbose');
### dont uncomment this, it screws up where STDOUT goes and makes
### test::harness create test counter mismatches
#*STDOUT = output_handle() unless @ARGV;
### for the same test-output counter mismatch, we disable verbose
### mode
t/40_CPANPLUS-Internals-Report.t view on Meta::CPAN
my $int_ver = $CPANPLUS::Internals::VERSION;
### explicitly enable testing if possible ###
$CB->configure_object->set_conf(cpantest =>1) if $ARGV[0];
my $map = {
all_ok => {
buffer => '', # output from build process
failed => 0, # indicate failure
match => [qw|/PASS/|], # list of regexes for the output
check => 0, # check if callbacks got called?
},
skipped_test => {
buffer => '',
failed => 0,
match => ['/PASS/',
'/tests for this module were skipped during this build/',
],
check => 0,
skiptests
=> 1, # did we skip the tests?
t/40_CPANPLUS-Internals-Report.t view on Meta::CPAN
like($str, qr/toolchain/, "Correct message in report" );
use CPANPLUS;
like($str, qr/CPANPLUS\s+\Q$CPANPLUS::VERSION\E/,
"CPANPLUS has correct version in report" );
}
}
### callback tests
{ ### as reported in bug 13086, this callback returned the wrong item
### from the list:
### $self->_callbacks->munge_test_report->($Mod, $message, $grade);
my $rv = $CB->_callbacks->munge_test_report->( 1..4 );
is( $rv, 2, "Default 'munge_test_report' callback OK" );
}
### test creating test reports ###
SKIP: {
skip "You have chosen not to enable test reporting", $total_tests,
unless $CB->configure_object->get_conf('cpantest');
skip "No report send & query modules installed", $total_tests
t/40_CPANPLUS-Internals-Report.t view on Meta::CPAN
}
#unlink $file;
### T::R tests don't even try to mail, let's not try and be smarter
### ourselves
# { ### use a dummy 'editor' and see if the editor
# ### invocation doesn't break things
# $conf->set_program( editor => "$^X -le1" );
# $CB->_callbacks->edit_test_report( sub { 1 } );
#
# ### XXX whitebox test!!! Might change =/
# ### this makes test::reporter not ask for what editor to use
# ### XXX stupid lousy perl warnings;
# local $Test::Reporter::MacApp = 1;
# local $Test::Reporter::MacApp = 1;
#
# ### now try and mail the report to a /dev/null'd mailbox
# my $ok = $CB->_send_report(
# module => $Mod,
( run in 0.565 second using v1.01-cache-2.11-cpan-9b1e4054eb1 )