Acme-Hyde
view release on metacpan or search on metacpan
inc/Module/AutoInstall.pm view on Meta::CPAN
use strict;
use Cwd ();
use ExtUtils::MakeMaker ();
use vars qw{$VERSION};
BEGIN {
$VERSION = '1.03';
}
# special map on pre-defined feature sets
my %FeatureMap = (
'' => 'Core Features', # XXX: deprecated
'-core' => 'Core Features',
);
# various lexical flags
my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS );
my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly );
my ( $PostambleActions, $PostambleUsed );
inc/Module/AutoInstall.pm view on Meta::CPAN
print "*** Checking for Perl dependencies...\n";
my $cwd = Cwd::cwd();
$Config = [];
my $maxlen = length(
(
sort { length($b) <=> length($a) }
grep { /^[^\-]/ }
map {
ref($_)
? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} )
: ''
}
map { +{@args}->{$_} }
grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} }
)[0]
);
while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) {
my ( @required, @tests, @skiptests );
my $default = 1;
my $conflict = 0;
if ( $feature =~ m/^-(\w+)$/ ) {
inc/Module/AutoInstall.pm view on Meta::CPAN
unshift @$modules, $arg;
$arg = 0;
}
# XXX: check for conflicts and uninstalls(!) them.
if (
defined( my $cur = _version_check( _load($mod), $arg ||= 0 ) ) )
{
print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n";
push @Existing, $mod => $arg;
$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
}
else {
print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n";
push @required, $mod => $arg;
}
}
next unless @required;
my $mandatory = ( $feature eq '-core' or $core_all );
inc/Module/AutoInstall.pm view on Meta::CPAN
qq{==> Auto-install the }
. ( @required / 2 )
. ( $mandatory ? ' mandatory' : ' optional' )
. qq{ module(s) from CPAN?},
$default ? 'y' : 'n',
) =~ /^[Yy]/
)
)
{
push( @Missing, @required );
$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
}
elsif ( !$SkipInstall
and $default
and $mandatory
and
_prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', )
=~ /^[Nn]/ )
{
push( @Missing, @required );
$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
}
else {
$DisabledTests{$_} = 1 for map { glob($_) } @tests;
}
}
$UnderCPAN = _check_lock(); # check for $UnderCPAN
if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) {
require Config;
print
"*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n";
inc/Module/AutoInstall.pm view on Meta::CPAN
}
close LOCK;
return;
}
sub install {
my $class = shift;
my $i; # used below to strip leading '-' from config keys
my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } );
my ( @modules, @installed );
while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) {
# grep out those already installed
if ( defined( _version_check( _load($pkg), $ver ) ) ) {
push @installed, $pkg;
}
else {
push @modules, $pkg, $ver;
inc/Module/AutoInstall.pm view on Meta::CPAN
require ExtUtils::Manifest;
my $manifest = ExtUtils::Manifest::maniread('MANIFEST');
$args{EXE_FILES} =
[ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ];
}
$args{test}{TESTS} ||= 't/*.t';
$args{test}{TESTS} = join( ' ',
grep { !exists( $DisabledTests{$_} ) }
map { glob($_) } split( /\s+/, $args{test}{TESTS} ) );
my $missing = join( ',', @Missing );
my $config =
join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
if $Config;
$PostambleActions = (
$missing
? "\$(PERL) $0 --config=$config --installdeps=$missing"
: "\$(NOECHO) \$(NOOP)"
inc/Module/Install/AutoInstall.pm view on Meta::CPAN
sub write {
my $self = shift;
$self->auto_install(@_);
}
sub auto_install {
my $self = shift;
return if $self->{done}++;
# Flatten array of arrays into a single array
my @core = map @$_, map @$_, grep ref,
$self->build_requires, $self->requires;
my @config = @_;
# We'll need Module::AutoInstall
$self->include('Module::AutoInstall');
require Module::AutoInstall;
Module::AutoInstall->import(
(@config ? (-config => \@config) : ()),
inc/Module/Install/Makefile.pm view on Meta::CPAN
}
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 { @$_ } map { @$_ } grep $_,
($self->build_requires, $self->requires) );
# merge both kinds of requires into prereq_pm
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";
}
my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
if ($self->admin->preop) {
$args{dist} = $self->admin->preop;
}
my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
$self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
}
sub fix_up_makefile {
my $self = shift;
inc/Module/Install/Metadata.pm view on Meta::CPAN
# The user used ->feature like ->features by passing in the second
# argument as a reference. Accomodate for that.
$mods = $_[0];
} else {
$mods = \@_;
}
my $count = 0;
push @$features, (
$name => [
map {
ref($_) ? ( ref($_) eq 'HASH' ) ? %$_
: @$_
: $_
} @$mods
]
);
return @$features;
}
inc/Spiffy.pm view on Meta::CPAN
use Carp;
require Exporter;
our $VERSION = '0.30';
our @EXPORT = ();
our @EXPORT_BASE = qw(field const stub super);
our @EXPORT_OK = (@EXPORT_BASE, qw(id WWW XXX YYY ZZZ));
our %EXPORT_TAGS = (XXX => [qw(WWW XXX YYY ZZZ)]);
my $stack_frame = 0;
my $dump = 'yaml';
my $bases_map = {};
sub WWW; sub XXX; sub YYY; sub ZZZ;
# This line is here to convince "autouse" into believing we are autousable.
sub can {
($_[1] eq 'import' and caller()->isa('autouse'))
? \&Exporter::import # pacify autouse's equality test
: $_[0]->SUPER::can($_[1]) # normal case
}
inc/Spiffy.pm view on Meta::CPAN
} ( @{"$class\::EXPORT"},
($args->{-Base} or $args->{-base})
? @{"$class\::EXPORT_BASE"} : (),
);
my @export_ok = grep {
not defined &{"$caller_package\::$_"};
} @{"$class\::EXPORT_OK"};
# Avoid calling the expensive Exporter::export
# if there is nothing to do (optimization)
my %exportable = map { ($_, 1) } @export, @export_ok;
next unless keys %exportable;
my @export_save = @{"$class\::EXPORT"};
my @export_ok_save = @{"$class\::EXPORT_OK"};
@{"$class\::EXPORT"} = @export;
@{"$class\::EXPORT_OK"} = @export_ok;
my @list = grep {
(my $v = $_) =~ s/^[\!\:]//;
$exportable{$v} or ${"$class\::EXPORT_TAGS"}{$v};
} @export_list;
inc/Spiffy.pm view on Meta::CPAN
$_ = $data;
my @my_subs;
s[^(sub\s+\w+\s+\{)(.*\n)]
[${1}my \$self = shift;$2]gm;
s[^(sub\s+\w+)\s*\(\s*\)(\s+\{.*\n)]
[${1}${2}]gm;
s[^my\s+sub\s+(\w+)(\s+\{)(.*)((?s:.*?\n))\}\n]
[push @my_subs, $1; "\$$1 = sub$2my \$self = shift;$3$4\};\n"]gem;
my $preclare = '';
if (@my_subs) {
$preclare = join ',', map "\$$_", @my_subs;
$preclare = "my($preclare);";
}
$_ = "use strict;use warnings;$preclare${_};1;\n$end";
if ($filter_dump) { print; exit }
if ($filter_save) { $filter_result = $_; $_ = $filter_result; }
$done = 1;
}
);
}
sub base {
push @_, -base;
goto &import;
}
sub all_my_bases {
my $class = shift;
return $bases_map->{$class}
if defined $bases_map->{$class};
my @bases = ($class);
no strict 'refs';
for my $base_class (@{"${class}::ISA"}) {
push @bases, @{all_my_bases($base_class)};
}
my $used = {};
$bases_map->{$class} = [grep {not $used->{$_}++} @bases];
}
my %code = (
sub_start =>
"sub {\n",
set_default =>
" \$_[0]->{%s} = %s\n unless exists \$_[0]->{%s};\n",
init =>
" return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" .
" unless \$#_ > 0 or defined \$_[0]->{%s};\n",
inc/Spiffy.pm view on Meta::CPAN
sub {
require Carp;
Carp::confess
"Method $field in package $package must be subclassed";
}
}
sub parse_arguments {
my $class = shift;
my ($args, @values) = ({}, ());
my %booleans = map { ($_, 1) } $class->boolean_arguments;
my %pairs = map { ($_, 1) } $class->paired_arguments;
while (@_) {
my $elem = shift;
if (defined $elem and defined $booleans{$elem}) {
$args->{$elem} = (@_ and $_[0] =~ /^[01]$/)
? shift
: 1;
}
elsif (defined $elem and defined $pairs{$elem} and @_) {
$args->{$elem} = shift;
}
inc/Spiffy.pm view on Meta::CPAN
@{"$target_class\::ISA"} = ($pseudo_class);
for (keys %methods) {
*{"$pseudo_class\::$_"} = $methods{$_};
}
}
sub spiffy_mixin_methods {
my $mixin_class = shift;
no strict 'refs';
my %methods = spiffy_all_methods($mixin_class);
map {
$methods{$_}
? ($_, \ &{"$methods{$_}\::$_"})
: ($_, \ &{"$mixin_class\::$_"})
} @_
? (get_roles($mixin_class, @_))
: (keys %methods);
}
sub get_roles {
my $mixin_class = shift;
my @roles = @_;
while (grep /^!*:/, @roles) {
@roles = map {
s/!!//g;
/^!:(.*)/ ? do {
my $m = "_role_$1";
map("!$_", $mixin_class->$m);
} :
/^:(.*)/ ? do {
my $m = "_role_$1";
($mixin_class->$m);
} :
($_)
} @roles;
}
if (@roles and $roles[0] =~ /^!/) {
my %methods = spiffy_all_methods($mixin_class);
inc/Spiffy.pm view on Meta::CPAN
if /^!(.*)/;
$roles{$_} = 1;
}
keys %roles;
}
sub spiffy_all_methods {
no strict 'refs';
my $class = shift;
return if $class eq 'Spiffy';
my %methods = map {
($_, $class)
} grep {
defined &{"$class\::$_"} and not /^_/
} keys %{"$class\::"};
my %super_methods;
%super_methods = spiffy_all_methods(${"$class\::ISA"}[0])
if @{"$class\::ISA"};
%{{%super_methods, %methods}};
}
inc/Test/Base.pm view on Meta::CPAN
tie_output no_diag_on_only
find_my_self default_object
croak carp cluck confess
));
field '_spec_file';
field '_spec_string';
field _filters => [qw(norm trim)];
field _filters_map => {};
field spec =>
-init => '$self->_spec_init';
field block_list =>
-init => '$self->_block_list_init';
field _next_list => [];
field block_delim =>
-init => '$self->block_delim_default';
field data_delim =>
-init => '$self->data_delim_default';
field _filters_delay => 0;
inc/Test/Base.pm view on Meta::CPAN
sub spec_string() {
(my ($self), @_) = find_my_self(@_);
$self->check_late;
$self->_spec_string(shift);
return $self;
}
sub filters() {
(my ($self), @_) = find_my_self(@_);
if (ref($_[0]) eq 'HASH') {
$self->_filters_map(shift);
}
else {
my $filters = $self->_filters;
push @$filters, @_;
}
return $self;
}
sub filter_arguments() {
$Test::Base::Filter::arguments;
inc/Test/Base.pm view on Meta::CPAN
my $name = $1;
my @parts = split /^\Q${dd}\E +\(?(\w+)\)? *(.*)?\n/m, $hunk;
my $description = shift @parts;
$description ||= '';
unless ($description =~ /\S/) {
$description = $name;
}
$description =~ s/\s*\z//;
$block->set_value(description => $description);
my $section_map = {};
my $section_order = [];
while (@parts) {
my ($type, $filters, $value) = splice(@parts, 0, 3);
$self->_check_reserved($type);
$value = '' unless defined $value;
$filters = '' unless defined $filters;
if ($filters =~ /:(\s|\z)/) {
croak "Extra lines not allowed in '$type' section"
if $value =~ /\S/;
($filters, $value) = split /\s*:(?:\s+|\z)/, $filters, 2;
$value = '' unless defined $value;
$value =~ s/^\s*(.*?)\s*$/$1/;
}
$section_map->{$type} = {
filters => $filters,
};
push @$section_order, $type;
$block->set_value($type, $value);
}
$block->set_value(name => $name);
$block->set_value(_section_map => $section_map);
$block->set_value(_section_order => $section_order);
return $block;
}
sub _spec_init {
return $self->_spec_string
if $self->_spec_string;
local $/;
my $spec;
if (my $spec_file = $self->_spec_file) {
inc/Test/Base.pm view on Meta::CPAN
sub set_value {
no strict 'refs';
my $accessor = shift;
block_accessor $accessor
unless defined &$accessor;
$self->{$accessor} = [@_];
}
sub run_filters {
my $map = $self->_section_map;
my $order = $self->_section_order;
Carp::croak "Attempt to filter a block twice"
if $self->is_filtered;
for my $type (@$order) {
my $filters = $map->{$type}{filters};
my @value = $self->$type;
$self->original_values->{$type} = $value[0];
for my $filter ($self->_get_filters($type, $filters)) {
$Test::Base::Filter::arguments =
$filter =~ s/=(.*)$// ? $1 : undef;
my $function = "main::$filter";
no strict 'refs';
if (defined &$function) {
local $_ = join '', @value;
my $old = $_;
inc/Test/Base.pm view on Meta::CPAN
}
}
$self->is_filtered(1);
}
sub _get_filters {
my $type = shift;
my $string = shift || '';
$string =~ s/\s*(.*?)\s*/$1/;
my @filters = ();
my $map_filters = $self->blocks_object->_filters_map->{$type} || [];
$map_filters = [ $map_filters ] unless ref $map_filters;
my @append = ();
for (
@{$self->blocks_object->_filters},
@$map_filters,
split(/\s+/, $string),
) {
my $filter = $_;
last unless length $filter;
if ($filter =~ s/^-//) {
@filters = grep { $_ ne $filter } @filters;
}
elsif ($filter =~ s/^\+//) {
push @append, $filter;
}
else {
push @filters, $filter;
}
}
return @filters, @append;
}
{
%$reserved_section_names = map {
($_, 1);
} keys(%Test::Base::Block::), qw( new DESTROY );
}
__DATA__
#line 1328
inc/Test/Base/Filter.pm view on Meta::CPAN
if (ref $_[0] eq 'ARRAY') {
for my $aref (@_) {
@$aref = $self->_apply_deepest($method, @$aref);
}
return @_;
}
$self->$method(@_);
}
sub _split_array {
map {
[$self->split($_)];
} @_;
}
sub _peel_deepest {
return () unless @_;
if (ref $_[0] eq 'ARRAY') {
if (ref $_[0]->[0] eq 'ARRAY') {
for my $aref (@_) {
@$aref = $self->_peel_deepest(@$aref);
}
return @_;
}
return map { $_->[0] } @_;
}
return @_;
}
#===============================================================================
# these filters work on the leaves of nested arrays
#===============================================================================
sub Join { $self->_peel_deepest($self->_apply_deepest(join => @_)) }
sub Reverse { $self->_apply_deepest(reverse => @_) }
sub Split { $self->_apply_deepest(_split_array => @_) }
sub Sort { $self->_apply_deepest(sort => @_) }
sub append {
my $suffix = $self->current_arguments;
map { $_ . $suffix } @_;
}
sub array {
return [@_];
}
sub base64_decode {
$self->assert_scalar(@_);
require MIME::Base64;
MIME::Base64::decode_base64(shift);
}
sub base64_encode {
$self->assert_scalar(@_);
require MIME::Base64;
MIME::Base64::encode_base64(shift);
}
sub chomp {
map { CORE::chomp; $_ } @_;
}
sub chop {
map { CORE::chop; $_ } @_;
}
sub dumper {
no warnings 'once';
require Data::Dumper;
local $Data::Dumper::Sortkeys = 1;
local $Data::Dumper::Indent = 1;
local $Data::Dumper::Terse = 1;
Data::Dumper::Dumper(@_);
}
inc/Test/Base/Filter.pm view on Meta::CPAN
close $execution;
unlink($tmpfile)
or die "Couldn't unlink $tmpfile: $!\n";
return $output;
}
sub flatten {
$self->assert_scalar(@_);
my $ref = shift;
if (ref($ref) eq 'HASH') {
return map {
($_, $ref->{$_});
} sort keys %$ref;
}
if (ref($ref) eq 'ARRAY') {
return @$ref;
}
die "Can only flatten a hash or array ref";
}
sub get_url {
inc/Test/Base/Filter.pm view on Meta::CPAN
$self->assert_scalar(@_);
my $text = shift;
$text = '' unless defined $text;
$text =~ s/\015\012/\n/g;
$text =~ s/\r/\n/g;
return $text;
}
sub prepend {
my $prefix = $self->current_arguments;
map { $prefix . $_ } @_;
}
sub read_file {
$self->assert_scalar(@_);
my $file = shift;
CORE::chomp $file;
open my $fh, $file
or die "Can't open '$file' for input:\n$!";
CORE::join '', <$fh>;
}
inc/Test/Base/Filter.pm view on Meta::CPAN
use warnings;
...
}
sub tail {
my $size = $self->current_arguments || 1;
return splice(@_, @_ - $size, $size);
}
sub trim {
map {
s/\A([ \t]*\n)+//;
s/(?<=\n)\s*\z//g;
$_;
} @_;
}
sub unchomp {
map { $_ . "\n" } @_;
}
sub write_file {
my $file = $self->current_arguments
or die "No file specified for write_file filter";
if ($file =~ /(.*)[\\\/]/) {
my $dir = $1;
if (not -e $dir) {
require File::Path;
File::Path::mkpath($dir)
inc/Test/Builder.pm view on Meta::CPAN
DIAGNOSTIC
}
return $ok;
}
#line 781
my %numeric_cmps = map { ($_, 1) }
("<", "<=", ">", ">=", "==", "!=", "<=>");
sub cmp_ok {
my($self, $got, $type, $expect, $name) = @_;
# Treat overloaded objects as numbers if we're asked to do a
# numeric comparison.
my $unoverload = $numeric_cmps{$type} ? '_unoverload_num'
: '_unoverload_str';
inc/Test/Builder.pm view on Meta::CPAN
my($self, @msgs) = @_;
return if $self->no_diag;
return unless @msgs;
# Prevent printing headers when compiling (i.e. -c)
return if $^C;
# Smash args together like print does.
# Convert undef to 'undef' so its readable.
my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
# Escape each line with a #.
$msg =~ s/^/# /gm;
# Stick a newline on the end if it needs it.
$msg .= "\n" unless $msg =~ /\n\Z/;
local $Level = $Level + 1;
$self->_print_diag($msg);
inc/Test/Builder.pm view on Meta::CPAN
}
return $self->{Curr_Test};
}
#line 1393
sub summary {
my($self) = shift;
return map { $_->{'ok'} } @{ $self->{Test_Results} };
}
#line 1448
sub details {
my $self = shift;
return @{ $self->{Test_Results} };
}
#line 1473
inc/Test/More.pm view on Meta::CPAN
# eval sometimes resets $!
eval { $proto->can($method) } || push @nok, $method;
}
my $name;
$name = @methods == 1 ? "$class->can('$methods[0]')"
: "$class->can(...)";
my $ok = $tb->ok( !@nok, $name );
$tb->diag(map " $class->can('$_') failed\n", @nok);
return $ok;
}
#line 525
sub isa_ok ($$;$) {
my($object, $class, $obj_name) = @_;
my $tb = Test::More->builder;
( run in 1.669 second using v1.01-cache-2.11-cpan-49f99fa48dc )