perl
view release on metacpan or search on metacpan
cpan/CPAN/lib/CPAN/HandleConfig.pm view on Meta::CPAN
# XXX does anything do this? can it be simplified? -- dagolden, 2011-01-19
if (@args) {
if ($args[0] eq "args") {
# we have not signed that contract
} else {
$configpm = $args[0];
}
}
# use provided name or the current config or create a new MyConfig
$configpm ||= require_myconfig_or_config() || make_new_config();
# commit to MyConfig if we can't write to Config
if ( ! -w $configpm && $configpm =~ m{CPAN/Config\.pm} ) {
my $myconfig = _new_config_name();
$CPAN::Frontend->mywarn(
"Your $configpm file\n".
"is not writable. I will attempt to write your configuration to\n" .
"$myconfig instead.\n\n"
);
$configpm = make_new_config();
cpan/CPAN/lib/CPAN/HandleConfig.pm view on Meta::CPAN
}
sub load {
my($self, %args) = @_;
$CPAN::Be_Silent+=0; # protect against 'used only once'
$CPAN::Be_Silent++ if $args{be_silent}; # do not use; planned to be removed in 2011
my $do_init = delete $args{do_init} || 0;
my $make_myconfig = delete $args{make_myconfig};
$loading = 0 unless defined $loading;
my $configpm = require_myconfig_or_config;
my @miss = $self->missing_config_data;
CPAN->debug("do_init[$do_init]loading[$loading]miss[@miss]") if $CPAN::DEBUG;
return unless $do_init || @miss;
if (@miss==1 and $miss[0] eq "pushy_https" && !$do_init) {
$CPAN::Frontend->myprint(<<'END');
Starting with version 2.29 of the cpan shell, a new download mechanism
is the default which exclusively uses cpan.org as the host to download
from. The configuration variable pushy_https can be used to (de)select
the new mechanism. Please read more about it and make your choice
cpan/Module-Load-Conditional/lib/Module/Load/Conditional.pm view on Meta::CPAN
$ERROR = $error;
Carp::carp( loc(q|%1 [THIS MAY BE A PROBLEM!]|,$error) ) if $args->{verbose};
return;
} else {
return 1;
}
}
=back
=head2 @list = requires( MODULE );
C<requires> can tell you what other modules a particular module
requires. This is particularly useful when you're intending to write
a module for public release and are listing its prerequisites.
C<requires> takes but one argument: the name of a module.
It will then first check if it can actually load this module, and
return undef if it can't.
Otherwise, it will return a list of modules and pragmas that would
have been loaded on the module's behalf.
cpan/Test-Simple/t/Legacy/BEGIN_require_ok.t view on Meta::CPAN
}
else {
unshift @INC, 't/lib';
}
}
use Test::More;
my $result;
BEGIN {
$result = require_ok("strict");
}
ok $result, "require_ok ran";
done_testing(2);
lib/B/Deparse-core.t view on Meta::CPAN
readdir 1 -
# readline handled specially
readlink 01 $
# readpipe handled specially
recv 4 p
# redo handled specially
ref 01 $
rename 2 p
# XXX This code prints 'Undefined subroutine &main::require called':
# use subs (); subs->import('require');
# eval q[no strict 'vars'; sub { () = require; }]; print $@;
# so disable for now
#require 01 $+
reset 01 -
# return handled specially
reverse @ p1 # also tested specially
rewinddir 1 -
rindex 23 p
rmdir 01 $
say @ p$+
scalar 1 +
(long)require, (long) needed));
cp = (char *)sbrk(require);
#ifdef DEBUGGING_MSTATS
sbrks++;
#endif
if (cp == last_sbrk_top) {
/* Common case, anything is fine. */
sbrk_goodness++;
ovp = (union overhead *) (cp - sbrked_remains);
last_op = cp - sbrked_remains;
sbrked_remains = require - (needed - sbrked_remains);
} else if (cp == (char *)-1) { /* no more room! */
ovp = (union overhead *)emergency_sbrk(needed);
if (ovp == (union overhead *)-1)
return 0;
if (((char*)ovp) > last_op) { /* Cannot happen with current emergency_sbrk() */
last_op = 0;
}
return ovp;
} else { /* Non-continuous or first sbrk(). */
long add = sbrked_remains;
"failed to fix bad sbrk()\n"));
#ifdef PACK_MALLOC
if (slack) {
MALLOC_UNLOCK;
fatalcroak("panic: Off-page sbrk\n");
}
#endif
if (sbrked_remains) {
/* Try again. */
#if defined(DEBUGGING_MSTATS)
sbrk_slack += require;
#endif
require = needed;
DEBUG_m(PerlIO_printf(Perl_debug_log,
"straight sbrk(%ld)\n",
(long)require));
cp = (char *)sbrk(require);
#ifdef DEBUGGING_MSTATS
sbrks++;
#endif
if (cp == (char *)-1)
(int)(PTR2UV(ovp) & (MEM_ALIGNBYTES - 1))));
ovp = INT2PTR(union overhead *,(PTR2UV(ovp) + MEM_ALIGNBYTES) &
(MEM_ALIGNBYTES - 1));
(*nblksp)--;
# if defined(DEBUGGING_MSTATS)
/* This is only approx. if TWO_POT_OPTIMIZE: */
sbrk_slack += (1 << (bucket >> BUCKET_POW2_SHIFT));
# endif
}
; /* Finish "else" */
sbrked_remains = require - needed;
last_op = cp;
}
#if !defined(PLAIN_MALLOC) && !defined(NO_FANCY_MALLOC)
emergency_buffer_last_req = 0;
#endif
last_sbrk_top = cp + require;
#ifdef DEBUGGING_MSTATS
goodsbrk += require;
#endif
return ovp;
}
static int
getpages_adjacent(MEM_SIZE require)
{
if (require <= sbrked_remains) {
sbrked_remains -= require;
} else {
char *cp;
require -= sbrked_remains;
/* We do not try to optimize sbrks here, we go for place. */
cp = (char*) sbrk(require);
#ifdef DEBUGGING_MSTATS
sbrks++;
goodsbrk += require;
#endif
if (cp == last_sbrk_top) {
sbrked_remains = 0;
last_sbrk_top = cp + require;
} else {
if (cp == (char*)-1) { /* Out of memory */
#ifdef DEBUGGING_MSTATS
goodsbrk -= require;
#endif
return 0;
}
/* Report the failure: */
if (sbrked_remains)
add_to_chain((void*)(last_sbrk_top - sbrked_remains),
sbrked_remains, 0);
add_to_chain((void*)cp, require, 0);
sbrk_goodness -= SBRK_FAILURE_PRICE;
sbrked_remains = 0;
t/comp/require.t view on Meta::CPAN
'sub foo {}; (0, return 0);',
'sub foo {}; "some_true_value";',
'sub foo {}; return "some_true_value";',
'sub foo {}; (0, return "some_true_value");',
'sub foo {}; (0, return "some_true_value");',
undef,
);
my @eval_code = (
'use PACK;',
'require PACK;',
'$return_val = require PACK;',
'@return_val = require PACK;',
'require "PACK.pm";',
'$return_val = require "PACK.pm";',
'@return_val = require "PACK.pm";',
);
# build a list of tuples. for now this just keeps the test
# indent level reasonable for the main test loop, but we could
# compute this at BEGIN time and then add the number of tests
# to the total count
my %seen;
foreach my $debugger_state (0,0xA) {
foreach my $param_str (@params) {
foreach my $mod_code (@module_code) {
t/comp/require.t view on Meta::CPAN
print "# code: $_\n" for split /\n/, $this_code || "NO CODE";
}
}
}
{
write_file('blorn.pm', "package blorn;\nuse v5.37;\nsub foo {};\nno feature 'module_true';\n");
local $@;
my $result = 0;
my $not = eval "\$result = require 'blorn.pm'; 1" ? 'not ' : '';
$i++;
print "${not}ok $i - disabling module_true should not return a true value ($result)\n";
$not = $@ =~ /did not return a true value/ ? '' : 'not ';
$i++;
print "${not}ok $i - ... and should fail to compile without a true return value\n";
}
{
write_file('blunge.pm', "package blunge;\nuse feature ':5.38';\n".
"sub bar {};\nno feature 'module_true';\n3;\n");
local $@;
my $result = 0;
eval "\$result = require 'blunge.pm'; 1";
my $not = $result == 3 ? '' : 'not ';
$i++;
print "${not}ok $i - disabling 'module_true' and should not override module's return value ($result)\n";
$not = $@ eq '' ? '' : 'not ';
$i++;
print "${not}ok $i - ... but should compile successfully with a provided return value\n";
}
for $main::test_mode (1..4) {
my $pack= "Demo$main::test_mode";
write_file("$pack.pm", sprintf(<<'CODE', $pack)=~s/^#//mgr);
t/comp/require.t view on Meta::CPAN
#return 0 if $main::test_mode == 2;
#
#{
# no feature 'module_true';
# return 0 if $main::test_mode == 3;
#}
#no feature 'module_true';
CODE
local $@;
my $result = 0;
my $ok= eval "\$result = require '$pack.pm'; 1";
my $err= $ok ? "" : $@;
if ($main::test_mode >= 3) {
my $not = $ok ? 'not ' : '';
$i++;
print "${not}ok $i - in $pack disabling module_true "
. "should not return a true value ($result)\n";
$not = $err =~ /did not return a true value/ ? '' : 'not ';
$i++;
print "${not}ok $i - ... and should throw the expected error\n";
if ($not) {
( run in 0.647 second using v1.01-cache-2.11-cpan-05444aca049 )