Acme-CPANAuthors-GeekHouse
view release on metacpan or search on metacpan
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.76';
$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;
$args->{VERSION} = $self->version;
$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/Spiffy.pm view on Meta::CPAN
$code .= sprintf $fragment, $field, $args->{-init}, ($field) x 4;
}
$code .= sprintf $code{set_default}, $field, $default_string, $field
if defined $default;
$code .= sprintf $code{return_if_get}, $field;
$code .= sprintf $code{set}, $field;
$code .= sprintf $code{weaken}, $field, $field
if $args->{-weak};
$code .= sprintf $code{sub_end}, $field;
my $sub = eval $code;
die $@ if $@;
no strict 'refs';
*{"${package}::$field"} = $sub;
return $code if defined wantarray;
}
sub default_as_code {
require Data::Dumper;
local $Data::Dumper::Sortkeys = 1;
my $code = Data::Dumper::Dumper(shift);
inc/Spiffy.pm view on Meta::CPAN
# Spiffy module. See the documentation of Spiffy.pm for details.
# END
# }
sub spiffy_base_import {
my @base_classes = @_;
shift @base_classes;
no strict 'refs';
goto &$real_base_import
unless grep {
eval "require $_" unless %{"$_\::"};
$_->isa('Spiffy');
} @base_classes;
my $inheritor = caller(0);
for my $base_class (@base_classes) {
next if $inheritor->isa($base_class);
croak "Can't mix Spiffy and non-Spiffy classes in 'use base'.\n",
"See the documentation of Spiffy.pm for details\n "
unless $base_class->isa('Spiffy');
$stack_frame = 1; # tell import to use different caller
import($base_class, '-base');
inc/Spiffy.pm view on Meta::CPAN
my $target_class = ref($self);
spiffy_mixin_import($target_class, @_)
}
sub spiffy_mixin_import {
my $target_class = shift;
$target_class = caller(0)
if $target_class eq 'mixin';
my $mixin_class = shift
or die "Nothing to mixin";
eval "require $mixin_class";
my @roles = @_;
my $pseudo_class = join '-', $target_class, $mixin_class, @roles;
my %methods = spiffy_mixin_methods($mixin_class, @roles);
no strict 'refs';
no warnings;
@{"$pseudo_class\::ISA"} = @{"$target_class\::ISA"};
@{"$target_class\::ISA"} = ($pseudo_class);
for (keys %methods) {
*{"$pseudo_class\::$_"} = $methods{$_};
}
inc/Test/Base.pm view on Meta::CPAN
sub block_class { $self->find_class('Block') }
sub filter_class { $self->find_class('Filter') }
sub find_class {
my $suffix = shift;
my $class = ref($self) . "::$suffix";
return $class if $class->can('new');
$class = __PACKAGE__ . "::$suffix";
return $class if $class->can('new');
eval "require $class";
return $class if $class->can('new');
die "Can't find a class for $suffix";
}
sub check_late {
if ($self->{block_list}) {
my $caller = (caller(1))[3];
$caller =~ s/.*:://;
croak "Too late to call $caller()"
}
inc/Test/Base.pm view on Meta::CPAN
push @$filters, @_;
}
return $self;
}
sub filter_arguments() {
$Test::Base::Filter::arguments;
}
sub have_text_diff {
eval { require Text::Diff; 1 } &&
$Text::Diff::VERSION >= 0.35 &&
$Algorithm::Diff::VERSION >= 1.15;
}
sub is($$;$) {
(my ($self), @_) = find_my_self(@_);
my ($actual, $expected, $name) = @_;
local $Test::Builder::Level = $Test::Builder::Level + 1;
if ($ENV{TEST_SHOW_NO_DIFFS} or
not defined $actual or
inc/Test/Base.pm view on Meta::CPAN
for my $block (@{$self->block_list}) {
next unless exists($block->{$x}) and defined($y);
$block->run_filters unless $block->is_filtered;
my $regexp = ref $y ? $y : $block->$y;
unlike($block->$x, $regexp,
$block->name ? $block->name : ()
);
}
}
sub _pre_eval {
my $spec = shift;
return $spec unless $spec =~
s/\A\s*<<<(.*?)>>>\s*$//sm;
my $eval_code = $1;
eval "package main; $eval_code";
croak $@ if $@;
return $spec;
}
sub _block_list_init {
my $spec = $self->spec;
$spec = $self->_pre_eval($spec);
my $cd = $self->block_delim;
my @hunks = ($spec =~ /^(\Q${cd}\E.*?(?=^\Q${cd}\E|\z))/msg);
my $blocks = $self->_choose_blocks(@hunks);
$self->block_list($blocks); # Need to set early for possible filter use
my $seq = 1;
for my $block (@$blocks) {
$block->blocks_object($self);
$block->seq_num($seq++);
}
return $blocks;
inc/Test/Base/Filter.pm view on Meta::CPAN
require Data::Dumper;
local $Data::Dumper::Sortkeys = 1;
local $Data::Dumper::Indent = 1;
local $Data::Dumper::Terse = 1;
Data::Dumper::Dumper(@_);
}
sub escape {
$self->assert_scalar(@_);
my $text = shift;
$text =~ s/(\\.)/eval "qq{$1}"/ge;
return $text;
}
sub eval {
$self->assert_scalar(@_);
my @return = CORE::eval(shift);
return $@ if $@;
return @return;
}
sub eval_all {
$self->assert_scalar(@_);
my $out = '';
my $err = '';
Test::Base::tie_output(*STDOUT, $out);
Test::Base::tie_output(*STDERR, $err);
my $return = CORE::eval(shift);
no warnings;
untie *STDOUT;
untie *STDERR;
return $return, $@, $out, $err;
}
sub eval_stderr {
$self->assert_scalar(@_);
my $output = '';
Test::Base::tie_output(*STDERR, $output);
CORE::eval(shift);
no warnings;
untie *STDERR;
return $output;
}
sub eval_stdout {
$self->assert_scalar(@_);
my $output = '';
Test::Base::tie_output(*STDOUT, $output);
CORE::eval(shift);
no warnings;
untie *STDOUT;
return $output;
}
sub exec_perl_stdout {
my $tmpfile = "/tmp/test-blocks-$$";
$self->_write_to($tmpfile, @_);
open my $execution, "$^X $tmpfile 2>&1 |"
or die "Couldn't open subprocess: $!\n";
inc/Test/Base/Filter.pm view on Meta::CPAN
my $text = shift;
my $flags = $self->current_arguments;
if ($text =~ /\n.*?\n/s) {
$flags = 'xism'
unless defined $flags;
}
else {
CORE::chomp($text);
}
$flags ||= '';
my $regexp = eval "qr{$text}$flags";
die $@ if $@;
return $regexp;
}
sub reverse {
CORE::reverse(@_);
}
sub slice {
die "Invalid args for slice"
inc/Test/Builder.pm view on Meta::CPAN
#line 1
package Test::Builder;
use 5.006;
use strict;
our $VERSION = '0.80';
$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 1009
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 1031
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 ref
return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
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 1076
sub level {
my($self, $level) = @_;
if( defined $level ) {
$Level = $level;
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.80';
$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
}
else {
$code = <<USE;
package $pack;
use $module \@{\$args[0]};
1;
USE
}
my($eval_result, $eval_error) = _eval($code, \@imports);
my $ok = $tb->ok( $eval_result, "use $module;" );
unless( $ok ) {
chomp $eval_error;
$@ =~ s{^BEGIN failed--compilation aborted at .*$}
{BEGIN failed--compilation aborted at $filename line $line.}m;
$tb->diag(<<DIAGNOSTIC);
Tried to use '$module'.
Error: $eval_error
DIAGNOSTIC
}
return $ok;
}
sub _eval {
my($code) = shift;
my @args = @_;
# Work around oddities surrounding resetting of $@ by immediately
# storing it.
local($@,$!,$SIG{__DIE__}); # isolate eval
my $eval_result = eval $code;
my $eval_error = $@;
return($eval_result, $eval_error);
}
#line 718
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);
my $code = <<REQUIRE;
package $pack;
require $module;
1;
REQUIRE
my($eval_result, $eval_error) = _eval($code);
my $ok = $tb->ok( $eval_result, "require $module;" );
unless( $ok ) {
chomp $eval_error;
$tb->diag(<<DIAGNOSTIC);
Tried to require '$module'.
Error: $eval_error
DIAGNOSTIC
}
return $ok;
}
sub _is_module_name {
my $module = shift;
( run in 2.469 seconds using v1.01-cache-2.11-cpan-98e64b0badf )