Acme-ComeFrom
view release on metacpan or search on metacpan
execution. The "comefrom" may not be inside any construct that
requires initialization, such as a subroutine or a "foreach" loop,
unless the targeting "LABEL" is also in the same construct.
comefrom EXPR
The "comefrom-EXPR" form expects a label name, whose scope will be
resolved dynamically. This allows for computed "comefrom"s by
checking the "EXPR" before every label (a.k.a. watchpoints), so you
can write:
# $i below evaluates in the LABEL's scope
comefrom ("FOO", "BAR", "GLARCH")[$i];
Starting from version 0.05, the value of EXPR is evaluated each
time, instead of the old *frozen at the first check* behaviour. If
this breaks your code -- as if there's any code based on comefrom --
You may retain the original behaviour by assigning a true value to
$Acme::ComeFrom::CacheEXPR.
comefrom &NAME
The "comefrom-&NAME" form is quite different from the other forms of
"comefrom". In fact, it isn't a comefrom in the normal sense at all,
and doesn't have the stigma associated with other "comefrom"s.
Instead, it installs a post-processing handler for the subroutine,
inc/Module/Install.pm view on Meta::CPAN
unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
}
foreach my $rv ( $self->find_extensions($path) ) {
my ($file, $pkg) = @{$rv};
next if $self->{pathnames}{$pkg};
local $@;
my $new = eval { require $file; $pkg->can('new') };
unless ( $new ) {
warn $@ if $@;
next;
}
$self->{pathnames}{$pkg} = delete $INC{$file};
push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
}
$self->{extensions} ||= [];
}
inc/Module/Install/Base.pm view on Meta::CPAN
}
bless( \%args, $class );
}
#line 61
sub AUTOLOAD {
my $self = shift;
local $@;
my $autoload = eval { $self->_top->autoload } or return;
goto &$autoload;
}
#line 76
sub _top { $_[0]->{_top} }
#line 89
sub admin {
inc/Module/Install/Can.pm view on Meta::CPAN
sub can_use {
my ($self, $mod, $ver) = @_;
$mod =~ s{::|\\}{/}g;
$mod .= '.pm' unless $mod =~ /\.pm$/i;
my $pkg = $mod;
$pkg =~ s{/}{::}g;
$pkg =~ s{\.pm$}{}i;
local $@;
eval { require $mod; $pkg->VERSION($ver || 0); 1 };
}
# check if we can run some command
sub can_run {
my ($self, $cmd) = @_;
my $_cmd = $cmd;
return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
inc/Module/Install/Fetch.pm view on Meta::CPAN
$VERSION = '0.67';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
sub get_file {
my ($self, %args) = @_;
my ($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
$args{url} = $args{ftp_url}
or (warn("LWP support unavailable!\n"), return);
($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
}
$|++;
print "Fetching '$file' from $host... ";
unless (eval { require Socket; Socket::inet_aton($host) }) {
warn "'$host' resolve failed!\n";
return;
}
return unless $scheme eq 'ftp' or $scheme eq 'http';
require Cwd;
my $dir = Cwd::getcwd();
chdir $args{local_dir} or return if exists $args{local_dir};
if (eval { require LWP::Simple; 1 }) {
LWP::Simple::mirror($args{url}, $file);
}
elsif (eval { require Net::FTP; 1 }) { eval {
# use Net::FTP to get past firewall
my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
$ftp->login("anonymous", 'anonymous@example.com');
$ftp->cwd($path);
$ftp->binary;
$ftp->get($file) or (warn("$!\n"), return);
$ftp->quit;
} }
elsif (my $ftp = $self->can_run('ftp')) { eval {
# no Net::FTP, fallback to ftp.exe
require FileHandle;
my $fh = FileHandle->new;
local $SIG{CHLD} = 'IGNORE';
unless ($fh->open("|$ftp -n")) {
warn "Couldn't open ftp: $!\n";
chdir $dir; return;
}
inc/Module/Install/Makefile.pm view on Meta::CPAN
$args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args);
$args->{VERSION} = $self->version || $self->determine_VERSION($args);
$args->{NAME} =~ s/-/::/g;
if ( $self->tests ) {
$args->{test} = { TESTS => $self->tests };
}
if ($] >= 5.005) {
$args->{ABSTRACT} = $self->abstract;
$args->{AUTHOR} = $self->author;
}
if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
$args->{NO_META} = 1;
}
if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
$args->{SIGN} = 1;
}
unless ( $self->is_admin ) {
delete $args->{SIGN};
}
# merge both kinds of requires into prereq_pm
my $prereq = ($args->{PREREQ_PM} ||= {});
%$prereq = ( %$prereq,
map { @$_ }
inc/Module/Install/Makefile.pm view on Meta::CPAN
my $subdirs = ($args->{DIR} ||= []);
if ($self->bundles) {
foreach my $bundle (@{ $self->bundles }) {
my ($file, $dir) = @$bundle;
push @$subdirs, $dir if -d $dir;
delete $prereq->{$file};
}
}
if ( my $perl_version = $self->perl_version ) {
eval "use $perl_version; 1"
or die "ERROR: perl: Version $] is installed, "
. "but we need version >= $perl_version";
}
$args->{INSTALLDIRS} = $self->installdirs;
my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
my $user_preop = delete $args{dist}->{PREOP};
if (my $preop = $self->admin->preop($user_preop)) {
inc/Test/Builder.pm view on Meta::CPAN
use 5.004;
# $^C was only introduced in 5.005-ish. We do this to prevent
# use of uninitialized value warnings in older perls.
$^C ||= 0;
use strict;
use vars qw($VERSION);
$VERSION = '0.70';
$VERSION = eval $VERSION; # make the alpha version come out as a number
# Make Test::Builder thread-safe for ithreads.
BEGIN {
use Config;
# Load threads::shared when threads are turned on.
# 5.8.0's threads are so busted we no longer support them.
if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'}) {
require threads::shared;
# Hack around YET ANOTHER threads::shared bug. It would
inc/Test/Builder.pm view on Meta::CPAN
# Treat overloaded objects as numbers if we're asked to do a
# numeric comparison.
my $unoverload = $numeric_cmps{$type} ? '_unoverload_num'
: '_unoverload_str';
$self->$unoverload(\$got, \$expect);
my $test;
{
local($@,$!,$SIG{__DIE__}); # isolate eval
my $code = $self->_caller_context;
# Yes, it has to look like this or 5.4.5 won't see the #line directive.
# Don't ask me, man, I just work here.
$test = eval "
$code" . "\$got $type \$expect;";
}
local $Level = $Level + 1;
my $ok = $self->ok($test, $name);
unless( $ok ) {
if( $type =~ /^(eq|==)$/ ) {
$self->_is_diag($got, $type, $expect);
}
inc/Test/Builder.pm view on Meta::CPAN
unless (defined $usable_regex) {
$ok = $self->ok( 0, $name );
$self->diag(" '$regex' doesn't look much like a regex to me.");
return $ok;
}
{
my $test;
my $code = $self->_caller_context;
local($@, $!, $SIG{__DIE__}); # isolate eval
# Yes, it has to look like this or 5.4.5 won't see the #line directive.
# Don't ask me, man, I just work here.
$test = eval "
$code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
$test = !$test if $cmp eq '!~';
local $Level = $Level + 1;
$ok = $self->ok( $test, $name );
}
unless( $ok ) {
$this = defined $this ? "'$this'" : 'undef';
inc/Test/Builder.pm view on Meta::CPAN
# I'm not ready to publish this. It doesn't deal with array return
# values from the code or context.
#line 1000
sub _try {
my($self, $code) = @_;
local $!; # eval can mess up $!
local $@; # don't set $@ in the test
local $SIG{__DIE__}; # don't trip an outside DIE handler.
my $return = eval { $code->() };
return wantarray ? ($return, $@) : $return;
}
#line 1022
sub is_fh {
my $self = shift;
my $maybe_fh = shift;
return 0 unless defined $maybe_fh;
return 1 if ref $maybe_fh eq 'GLOB'; # its a glob
return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob ref
return eval { $maybe_fh->isa("IO::Handle") } ||
# 5.5.4's tied() and can() doesn't like getting undef
eval { (tied($maybe_fh) || '')->can('TIEHANDLE') };
}
#line 1067
sub level {
my($self, $level) = @_;
if( defined $level ) {
$Level = $level;
inc/Test/Builder.pm view on Meta::CPAN
sub _my_exit {
$? = $_[0];
return 1;
}
#line 1672
$SIG{__DIE__} = sub {
# We don't want to muck with death in an eval, but $^S isn't
# totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
# with it. Instead, we use caller. This also means it runs under
# 5.004!
my $in_eval = 0;
for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) {
$in_eval = 1 if $sub =~ /^\(eval\)/;
}
$Test->{Test_Died} = 1 unless $in_eval;
};
sub _ending {
my $self = shift;
$self->_sanity_check();
# Don't bother with an ending if this is a forked copy. Only the parent
# should do the ending.
# Exit if plan() was never called. This is so "require Test::Simple"
inc/Test/More.pm view on Meta::CPAN
# actually happened.
sub _carp {
my($file, $line) = (caller(1))[1,2];
warn @_, " at $file line $line\n";
}
use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
$VERSION = '0.70';
$VERSION = eval $VERSION; # make the alpha version come out as a number
use Test::Builder::Module;
@ISA = qw(Test::Builder::Module);
@EXPORT = qw(ok use_ok require_ok
is isnt like unlike is_deeply
cmp_ok
skip todo todo_skip
pass fail
eq_array eq_hash eq_set
$TODO
inc/Test/More.pm view on Meta::CPAN
#line 653
sub use_ok ($;@) {
my($module, @imports) = @_;
@imports = () unless @imports;
my $tb = Test::More->builder;
my($pack,$filename,$line) = caller;
local($@,$!,$SIG{__DIE__}); # isolate eval
if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
# probably a version check. Perl needs to see the bare number
# for it to work with non-Exporter based modules.
eval <<USE;
package $pack;
use $module $imports[0];
USE
}
else {
eval <<USE;
package $pack;
use $module \@imports;
USE
}
my $ok = $tb->ok( !$@, "use $module;" );
unless( $ok ) {
chomp $@;
$@ =~ s{^BEGIN failed--compilation aborted at .*$}
inc/Test/More.pm view on Meta::CPAN
sub require_ok ($) {
my($module) = shift;
my $tb = Test::More->builder;
my $pack = caller;
# Try to deterine if we've been given a module name or file.
# Module names must be barewords, files not.
$module = qq['$module'] unless _is_module_name($module);
local($!, $@, $SIG{__DIE__}); # isolate eval
local $SIG{__DIE__};
eval <<REQUIRE;
package $pack;
require $module;
REQUIRE
my $ok = $tb->ok( !$@, "require $module;" );
unless( $ok ) {
chomp $@;
$tb->diag(<<DIAGNOSTIC);
Tried to require '$module'.
lib/Acme/ComeFrom.pm view on Meta::CPAN
my $chunk = '';
foreach my $iter ( 0 .. $#{$v} ) {
my $fork = ( $iter != $#{$v} );
if ( defined $cond->[$iter] ) {
my $forktext = ( $fork ? ' or fork' : '' );
$chunk .= "
if (\$Acme::ComeFrom::CacheEXPR) {
$pkg\::CACHE[$v->[$iter]] = eval q;$cond->[$iter];
unless exists $pkg\::CACHE[$v->[$iter]];
goto $Mark$v->[$iter] unless
('$label' ne $pkg\::CACHE[$v->[$iter]])$forktext;
}
else {
goto $Mark$v->[$iter] unless
('$label' ne eval q;$cond->[$iter];)$forktext;
}
";
}
else {
$chunk .= "goto $Mark$v->[$iter]" . ( $fork ? " unless fork();" : ';' );
}
}
$chunk =~ s/\n */ /g;
return $chunk;
lib/Acme/ComeFrom.pm view on Meta::CPAN
requires initialization, such as a subroutine or a C<foreach> loop,
unless the targeting C<LABEL> is also in the same construct.
=item comefrom EXPR
The C<comefrom-EXPR> form expects a label name, whose scope will be
resolved dynamically. This allows for computed C<comefrom>s by
checking the C<EXPR> before every label (a.k.a. watchpoints), so
you can write:
# $i below evaluates in the LABEL's scope
comefrom ("FOO", "BAR", "GLARCH")[$i];
Starting from version 0.05, the value of EXPR is evaluated each time,
instead of the old I<frozen at the first check> behaviour. If this
breaks your code -- as if there's any code based on comefrom --
You may retain the original behaviour by assigning a true value
to C<$Acme::ComeFrom::CacheEXPR>.
=item comefrom &NAME
The C<comefrom-&NAME> form is quite different from the other forms of
C<comefrom>. In fact, it isn't a comefrom in the normal sense at all,
and doesn't have the stigma associated with other C<comefrom>s. Instead,
t/0-signature.t view on Meta::CPAN
use strict;
print "1..1\n";
if (!$ENV{TEST_SIGNATURE}) {
print "ok 1 # skip set the environment variable TEST_SIGNATURE to enable this test\n";
}
elsif (!-s 'SIGNATURE') {
print "ok 1 # skip No signature file found\n";
}
elsif (!eval { require Module::Signature; 1 }) {
print "ok 1 # skip ",
"Next time around, consider install Module::Signature, ",
"so you can verify the integrity of this distribution.\n";
}
elsif (!eval { require Socket; Socket::inet_aton('pgp.mit.edu') }) {
print "ok 1 # skip ",
"Cannot connect to the keyserver\n";
}
else {
(Module::Signature::verify() == Module::Signature::SIGNATURE_OK())
or print "not ";
print "ok 1 # Valid signature\n";
}
__END__
t/1-basic.t view on Meta::CPAN
if ($] eq "Lisp") { # This is never true...
NOK('(disabled)') # ...so this will not happen.
}
use Acme::ComeFrom; # Resumes filtering.
{
my $i = 0;
DUMMY: 0; # This evalutes the "$i++" below.
EXPR1: NOK('uncached EXPR');
if ($] eq "FORTRAN") { # This is never true, but:
comefrom 'EXPR'.$i++; # Coming from "EXPR1:" above...
OK('uncached EXPR'); # ...and OKs the test
}
}
t/2-cached.t view on Meta::CPAN
sub OK { ok(1, "comefrom @_") }
sub NOK { ok(0, "comefrom @_") }
$Acme::ComeFrom::CacheEXPR = 0; # Avoid 'once' warnings
{
my $i = 1;
$Acme::ComeFrom::CacheEXPR = 1;
DUMMY: 0; # This does not evalutes the "$i++" below.
EXPR1: NOK('cached EXPR');
if ($] eq "FORTRAN") { # This is never true, but:
comefrom 'EXPR'.$i++; # Coming from "EXPR1:" above...
OK('cached EXPR'); # ...and OKs the test
}
}
__END__
( run in 0.883 second using v1.01-cache-2.11-cpan-ceb78f64989 )