Acme-CPANAuthors-GeekHouse
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
local *FH;
open FH, "> $_[0]" or die "open($_[0]): $!";
foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
close FH or die "close($_[0]): $!";
}
sub _version ($) {
my $s = shift || 0;
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
# Cloned from Params::Util::_CLASS
sub _CLASS ($) {
(
defined $_[0]
and
! ref $_[0]
inc/Module/Install/Makefile.pm view on Meta::CPAN
if ( $self->tests ) {
die "tests_recursive will not work if tests are already defined";
}
my $dir = shift || 't';
unless ( -d $dir ) {
die "tests_recursive dir '$dir' does not exist";
}
%test_dir = ();
require File::Find;
File::Find::find( \&_wanted_t, $dir );
$self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
}
sub write {
my $self = shift;
die "&Makefile->write() takes no arguments\n" if @_;
# Make sure we have a new enough
require ExtUtils::MakeMaker;
# MakeMaker can complain about module versions that include
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->configure_requires, $self->build_requires, $self->requires)
);
# Remove any reference to perl, PREREQ_PM doesn't support it
delete $args->{PREREQ_PM}->{perl};
# merge both kinds of requires into prereq_pm
my $subdirs = ($args->{DIR} ||= []);
if ($self->bundles) {
inc/Module/Install/Makefile.pm view on Meta::CPAN
}
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)) {
$args{dist} = $preop;
}
my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
$self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
}
inc/Module/Install/Metadata.pm view on Meta::CPAN
$self->{values}{$key} = shift;
return $self;
};
}
foreach my $key ( @resource_keys ) {
*$key = sub {
my $self = shift;
unless ( @_ ) {
return () unless $self->{values}{resources};
return map { $_->[1] }
grep { $_->[0] eq $key }
@{ $self->{values}{resources} };
}
return $self->{values}{resources}{$key} unless @_;
my $uri = shift or die(
"Did not provide a value to $key()"
);
$self->resources( $key => $uri );
return 1;
};
inc/Module/Install/Metadata.pm view on Meta::CPAN
my $self = shift;
while ( @_ ) {
my $module = shift or last;
my $version = shift || 0;
push @{ $self->{values}{bundles} }, [ $module, $version ];
}
$self->{values}{bundles};
}
# Resource handling
my %lc_resource = map { $_ => 1 } qw{
homepage
license
bugtracker
repository
};
sub resources {
my $self = shift;
while ( @_ ) {
my $name = shift or last;
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;
}
sub features {
my $self = shift;
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
my($self, $this, $regex, $name) = @_;
local $Level = $Level + 1;
$self->_regex_ok($this, $regex, '!~', $name);
}
#line 677
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
}
sub _copy_io_layers {
my($self, $src, $dst) = @_;
$self->_try(sub {
require PerlIO;
my @src_layers = PerlIO::get_layers($src);
binmode $dst, join " ", map ":$_", @src_layers if @src_layers;
});
}
#line 1423
sub _message_at_caller {
my $self = shift;
local $Level = $Level + 1;
my($pack, $file, $line) = $self->caller;
inc/Test/Builder.pm view on Meta::CPAN
}
return $self->{Curr_Test};
}
#line 1516
sub summary {
my($self) = shift;
return map { $_->{'ok'} } @{ $self->{Test_Results} };
}
#line 1571
sub details {
my $self = shift;
return @{ $self->{Test_Results} };
}
#line 1597
inc/Test/More.pm view on Meta::CPAN
foreach my $method (@methods) {
$tb->_try(sub { $proto->can($method) }) or 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 522
sub isa_ok ($$;$) {
my($object, $class, $obj_name) = @_;
my $tb = Test::More->builder;
( run in 0.658 second using v1.01-cache-2.11-cpan-49f99fa48dc )