Acme-Albed
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
unless ( grep { ! ref $_ and 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
unless ( defined &{"${class}::load"} ) {
*{"${class}::load"} = sub { shift->_top->load(@_) };
}
bless { @_ }, $class;
}
#line 61
sub AUTOLOAD {
local $@;
my $func = eval { shift->_top->autoload } or return;
goto &$func;
}
#line 75
sub _top {
$_[0]->{_top};
}
#line 90
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.91';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
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
$self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
}
sub write {
my $self = shift;
die "&Makefile->write() takes no arguments\n" if @_;
# Check the current Perl version
my $perl_version = $self->perl_version;
if ( $perl_version ) {
eval "use $perl_version; 1"
or die "ERROR: perl: Version $] is installed, "
. "but we need version >= $perl_version";
}
# Make sure we have a new enough MakeMaker
require ExtUtils::MakeMaker;
if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) {
# MakeMaker can complain about module versions that include
# an underscore, even though its own version may contain one!
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/Module/Install/Metadata.pm view on Meta::CPAN
# MYMETA Support
sub WriteMyMeta {
die "WriteMyMeta has been deprecated";
}
sub write_mymeta_yaml {
my $self = shift;
# We need YAML::Tiny to write the MYMETA.yml file
unless ( eval { require YAML::Tiny; 1; } ) {
return 1;
}
# Generate the data
my $meta = $self->_write_mymeta_data or return 1;
# Save as the MYMETA.yml file
print "Writing MYMETA.yml\n";
YAML::Tiny::DumpFile('MYMETA.yml', $meta);
}
sub write_mymeta_json {
my $self = shift;
# We need JSON to write the MYMETA.json file
unless ( eval { require JSON; 1; } ) {
return 1;
}
# Generate the data
my $meta = $self->_write_mymeta_data or return 1;
# Save as the MYMETA.yml file
print "Writing MYMETA.json\n";
Module::Install::_write(
'MYMETA.json',
inc/Module/Install/Metadata.pm view on Meta::CPAN
);
}
sub _write_mymeta_data {
my $self = shift;
# If there's no existing META.yml there is nothing we can do
return undef unless -f 'META.yml';
# We need Parse::CPAN::Meta to load the file
unless ( eval { require Parse::CPAN::Meta; 1; } ) {
return undef;
}
# Merge the perl version into the dependencies
my $val = $self->Meta->{values};
my $perl = delete $val->{perl_version};
if ( $perl ) {
$val->{requires} ||= [];
my $requires = $val->{requires};
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
my $regexp = ref $y ? $y : $block->$y;
unlike($block->$x, $regexp,
$block->name ? $block->name : ()
);
}
}
sub skip_all_unless_require() {
(my ($self), @_) = find_my_self(@_);
my $module = shift;
eval "require $module; 1"
or Test::More::plan(
skip_all => "$module failed to load"
);
}
sub is_deep() {
(my ($self), @_) = find_my_self(@_);
require Test::Deep;
Test::Deep::cmp_deeply(@_);
}
inc/Test/Base.pm view on Meta::CPAN
my ($x, $y) = $self->_section_names(@_);
for my $block (@{$self->block_list}) {
next unless exists($block->{$x}) and exists($block->{$y});
$block->run_filters unless $block->is_filtered;
is_deep($block->$x, $block->$y,
$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;
use warnings;
our $VERSION = '0.94';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
BEGIN {
if( $] < 5.008 ) {
require Test::Builder::IO::Scalar;
}
}
# Make Test::Builder thread-safe for ithreads.
BEGIN {
inc/Test/Builder.pm view on Meta::CPAN
$self->croak("subtest()'s second argument must be a code ref");
}
# Turn the child into the parent so anyone who has stored a copy of
# the Test::Builder singleton will get the child.
my $child = $self->child($name);
my %parent = %$self;
%$self = %$child;
my $error;
if( !eval { $subtests->(); 1 } ) {
$error = $@;
}
# Restore the parent and the copied child.
%$child = %$self;
%$self = %parent;
# Die *after* we restore the parent.
die $error if $error and !eval { $error->isa('Test::Builder::Exception') };
return $child->finalize;
}
#line 250
sub finalize {
my $self = shift;
inc/Test/Builder.pm view on Meta::CPAN
my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
sub cmp_ok {
my( $self, $got, $type, $expect, $name ) = @_;
my $test;
my $error;
{
## no critic (BuiltinFunctions::ProhibitStringyEval)
local( $@, $!, $SIG{__DIE__} ); # isolate eval
my($pack, $file, $line) = $self->caller();
$test = eval qq[
#line 1 "cmp_ok [from $file line $line]"
\$got $type \$expect;
];
$error = $@;
}
local $Level = $Level + 1;
my $ok = $self->ok( $test, $name );
# Treat overloaded objects as numbers if we're asked to do a
# numeric comparison.
inc/Test/Builder.pm view on Meta::CPAN
$self->diag(" '$regex' doesn't look much like a regex to me.");
return $ok;
}
{
## no critic (BuiltinFunctions::ProhibitStringyEval)
my $test;
my $context = $self->_caller_context;
local( $@, $!, $SIG{__DIE__} ); # isolate eval
$test = eval $context . 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';
my $match = $cmp eq '=~' ? "doesn't match" : "matches";
inc/Test/Builder.pm view on Meta::CPAN
# values from the code or context.
#line 1389
sub _try {
my( $self, $code, %opts ) = @_;
my $error;
my $return;
{
local $!; # eval can mess up $!
local $@; # don't set $@ in the test
local $SIG{__DIE__}; # don't trip an outside DIE handler.
$return = eval { $code->() };
$error = $@;
}
die $error if $error and $opts{die_on_fail};
return wantarray ? ( $return, $error ) : $return;
}
#line 1418
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") } ||
eval { tied($maybe_fh)->can('TIEHANDLE') };
}
#line 1461
sub level {
my( $self, $level ) = @_;
if( defined $level ) {
$Level = $level;
}
inc/Test/Builder/Module.pm view on Meta::CPAN
package Test::Builder::Module;
use strict;
use Test::Builder;
require Exporter;
our @ISA = qw(Exporter);
our $VERSION = '0.94';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
#line 74
sub import {
my($class) = shift;
# Don't run all this when loading ourself.
return 1 if $class eq 'Test::Builder::Module';
inc/Test/More.pm view on Meta::CPAN
# Can't use Carp because it might cause use_ok() to accidentally succeed
# even though the module being used forgot to use Carp. Yes, this
# actually happened.
sub _carp {
my( $file, $line ) = ( caller(1) )[ 1, 2 ];
return warn @_, " at $file line $line\n";
}
our $VERSION = '0.94';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
use Test::Builder::Module;
our @ISA = qw(Test::Builder::Module);
our @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
USE
}
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, @args ) = @_;
# Work around oddities surrounding resetting of $@ by immediately
# storing it.
my( $sigdie, $eval_result, $eval_error );
{
local( $@, $!, $SIG{__DIE__} ); # isolate eval
$eval_result = eval $code; ## no critic (BuiltinFunctions::ProhibitStringyEval)
$eval_error = $@;
$sigdie = $SIG{__DIE__} || undef;
}
# make sure that $code got a chance to set $SIG{__DIE__}
$SIG{__DIE__} = $sigdie if defined $sigdie;
return( $eval_result, $eval_error );
}
#line 875
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;
xt/01_podspell.t view on Meta::CPAN
use strict;
use warnings;
use Test::More;
eval q{ use Test::Spelling };
plan skip_all => "Test::Spelling is not installed." if $@;
my $spell_cmd;
foreach my $path (split(/:/, $ENV{PATH}))
{
-x "$path/spell" and $spell_cmd="spell", last;
-x "$path/ispell" and $spell_cmd="ispell -l", last;
-x "$path/aspell" and $spell_cmd="aspell list", last;
}
$ENV{SPELL_CMD} and $spell_cmd = $ENV{SPELL_CMD};
xt/02_perlcritic.t view on Meta::CPAN
use strict;
use Test::More;
eval {
require Test::Perl::Critic;
Test::Perl::Critic->import( -profile => 'xt/perlcriticrc');
};
plan skip_all => "Test::Perl::Critic is not installed." if $@;
all_critic_ok('lib');
xt/03_pod.t view on Meta::CPAN
use Test::More;
eval "use Test::Pod 1.00";
plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
all_pod_files_ok();
( run in 1.159 second using v1.01-cache-2.11-cpan-98e64b0badf )