App-cpanminus
view release on metacpan or search on metacpan
lib/App/cpanminus/fatscript.pm view on Meta::CPAN
}, $class;
}
sub env {
my($self, $key) = @_;
$ENV{"PERL_CPANM_" . $key};
}
sub maybe_ci {
my $class = shift;
grep $ENV{$_}, qw( TRAVIS CI AUTOMATED_TESTING AUTHOR_TESTING );
}
sub install_type_handlers {
my $self = shift;
my @handlers;
for my $type (qw( recommends suggests )) {
push @handlers, "with-$type" => sub {
my %uniq;
$self->{install_types} = [ grep !$uniq{$_}++, @{$self->{install_types}}, $type ];
};
push @handlers, "without-$type" => sub {
$self->{install_types} = [ grep $_ ne $type, @{$self->{install_types}} ];
};
}
@handlers;
}
sub build_args_handlers {
my $self = shift;
my @handlers;
for my $phase (qw( configure build test install )) {
push @handlers, "$phase-args=s" => \($self->{build_args}{$phase});
}
@handlers;
}
sub parse_options {
my $self = shift;
local @ARGV = @{$self->{argv}};
push @ARGV, grep length, split /\s+/, $self->env('OPT');
push @ARGV, @_;
Getopt::Long::Configure("bundling");
Getopt::Long::GetOptions(
'f|force' => sub { $self->{skip_installed} = 0; $self->{force} = 1 },
'n|notest!' => \$self->{notest},
'test-only' => sub { $self->{notest} = 0; $self->{skip_installed} = 0; $self->{test_only} = 1 },
'S|sudo!' => \$self->{sudo},
'v|verbose' => \$self->{verbose},
'verify!' => \$self->{verify},
'q|quiet!' => \$self->{quiet},
'h|help' => sub { $self->{action} = 'show_help' },
'V|version' => sub { $self->{action} = 'show_version' },
'perl=s' => sub {
$self->diag("--perl is deprecated since it's known to be fragile in figuring out dependencies. Run `$_[1] -S cpanm` instead.\n", 1);
$self->{perl} = $_[1];
},
'l|local-lib=s' => sub { $self->{local_lib} = $self->maybe_abs($_[1]) },
'L|local-lib-contained=s' => sub {
$self->{local_lib} = $self->maybe_abs($_[1]);
$self->{self_contained} = 1;
$self->{pod2man} = undef;
},
'self-contained!' => \$self->{self_contained},
'exclude-vendor!' => \$self->{exclude_vendor},
'mirror=s@' => $self->{mirrors},
'mirror-only!' => \$self->{mirror_only},
'mirror-index=s' => sub { $self->{mirror_index} = $self->maybe_abs($_[1]) },
'M|from=s' => sub {
$self->{mirrors} = [$_[1]];
$self->{mirror_only} = 1;
},
'cpanmetadb=s' => \$self->{cpanmetadb},
'cascade-search!' => \$self->{cascade_search},
'prompt!' => \$self->{prompt},
'installdeps' => \$self->{installdeps},
'skip-installed!' => \$self->{skip_installed},
'skip-satisfied!' => \$self->{skip_satisfied},
'reinstall' => sub { $self->{skip_installed} = 0 },
'interactive!' => \$self->{interactive},
'i|install' => sub { $self->{cmd} = 'install' },
'info' => sub { $self->{cmd} = 'info' },
'look' => sub { $self->{cmd} = 'look'; $self->{skip_installed} = 0 },
'U|uninstall' => sub { $self->{cmd} = 'uninstall' },
'self-upgrade' => sub { $self->{action} = 'self_upgrade' },
'uninst-shadows!' => \$self->{uninstall_shadows},
'lwp!' => \$self->{try_lwp},
'wget!' => \$self->{try_wget},
'curl!' => \$self->{try_curl},
'auto-cleanup=s' => \$self->{auto_cleanup},
'man-pages!' => \$self->{pod2man},
'scandeps' => \$self->{scandeps},
'showdeps' => sub { $self->{showdeps} = 1; $self->{skip_installed} = 0 },
'format=s' => \$self->{format},
'save-dists=s' => sub {
$self->{save_dists} = $self->maybe_abs($_[1]);
},
'skip-configure!' => \$self->{skip_configure},
'dev!' => \$self->{dev_release},
'metacpan!' => \$self->{metacpan},
'report-perl-version!' => \$self->{report_perl_version},
'configure-timeout=i' => \$self->{configure_timeout},
'build-timeout=i' => \$self->{build_timeout},
'test-timeout=i' => \$self->{test_timeout},
'with-develop' => \$self->{with_develop},
'without-develop' => sub { $self->{with_develop} = 0 },
'with-configure' => \$self->{with_configure},
'without-configure' => sub { $self->{with_configure} = 0 },
'with-feature=s' => sub { $self->{features}{$_[1]} = 1 },
'without-feature=s' => sub { $self->{features}{$_[1]} = 0 },
'with-all-features' => sub { $self->{features}{__all} = 1 },
'pp|pureperl!' => \$self->{pure_perl},
"cpanfile=s" => \$self->{cpanfile_path},
$self->install_type_handlers,
$self->build_args_handlers,
lib/App/cpanminus/fatscript.pm view on Meta::CPAN
$self->diag_fail("Cannot uncompress -- please install gunzip or Compress::Zlib");
return;
}
}
utime $index_mtime, $index_mtime, $file;
}
return 1;
}
sub search_mirror_index {
my ($self, $mirror, $module, $version) = @_;
$self->search_mirror_index_file($self->package_index_for($mirror), $module, $version);
}
sub search_mirror_index_file {
my($self, $file, $module, $version) = @_;
open my $fh, '<', $file or return;
my $found;
while (<$fh>) {
if (m!^\Q$module\E\s+([\w\.]+)\s+(\S*)!m) {
$found = $self->cpan_module($module, $2, $1);
last;
}
}
return $found unless $self->{cascade_search};
if ($found) {
if ($self->satisfy_version($module, $found->{module_version}, $version)) {
return $found;
} else {
$self->chat("Found $module $found->{module_version} which doesn't satisfy $version.\n");
}
}
return;
}
sub with_version_range {
my($self, $version) = @_;
defined($version) && $version =~ /(?:<|!=|==)/;
}
sub encode_json {
my($self, $data) = @_;
require JSON::PP;
my $json = JSON::PP::encode_json($data);
$self->uri_escape($json);
}
sub decode_json {
my($self, $json) = @_;
require JSON::PP;
JSON::PP::decode_json($json);
}
sub uri_escape {
my($self, $fragment) = @_;
$fragment =~ s/([^A-Za-z0-9\-\._~])/uc sprintf("%%%02X", ord($1))/eg;
$fragment;
}
sub uri_params {
my($self, @params) = @_;
my @param_strings;
while (my $key = shift @params) {
my $value = shift @params;
push @param_strings, join '=', map $self->uri_escape($_), $key, $value;
}
return join '&', @param_strings;
}
# version->new("1.00_00")->numify => "1.00_00" :/
sub numify_ver {
my($self, $ver) = @_;
eval version->new($ver)->numify;
}
sub search_metacpan {
my($self, $module, $version, $dev_release) = @_;
my $metacpan_uri = 'http://fastapi.metacpan.org/v1/download_url/';
my $url = $metacpan_uri . $module;
my $query = $self->uri_params(
($version ? (version => $version) : ()),
($dev_release ? (dev => 1) : ()),
);
$url .= '?' . $query
if length $query;
my $dist_json = $self->get($url);
my $dist_meta = eval { $self->decode_json($dist_json) };
if ($dist_meta && $dist_meta->{download_url}) {
(my $distfile = $dist_meta->{download_url}) =~ s!.+/authors/id/!!;
local $self->{mirrors} = $self->{mirrors};
$self->{mirrors} = [ 'http://cpan.metacpan.org' ];
return $self->cpan_module($module, $distfile, $dist_meta->{version});
}
$self->chat("! Could not find a release matching $module".($version?" ($version)":'')." on MetaCPAN.\n");
return;
}
sub search_database {
my($self, $module, $version) = @_;
my $found;
if ($self->{dev_release} or $self->{metacpan}) {
$found = $self->search_metacpan($module, $version, $self->{dev_release}) and return $found;
$found = $self->search_cpanmetadb($module, $version, $self->{dev_release}) and return $found;
} else {
$found = $self->search_cpanmetadb($module, $version) and return $found;
$found = $self->search_metacpan($module, $version) and return $found;
}
}
lib/App/cpanminus/fatscript.pm view on Meta::CPAN
my $resources = $meta->{resources} || {};
if ( $meta->{license_url} && ! $resources->{license} ) {
$resources->{license} = $meta->{license_url}
if _is_urlish($meta->{license_url});
}
return unless keys %$resources;
return _convert($resources, $resource1_spec);
}
my $resource_downgrade_spec = {
license => sub { return ref $_[0] ? $_[0]->[0] : $_[0] },
homepage => \&_url_or_drop,
bugtracker => sub { return $_[0]->{web} },
repository => sub { return $_[0]->{url} || $_[0]->{web} },
':custom' => \&_no_prefix_ucfirst_custom,
};
sub _downgrade_resources {
my (undef, undef, $meta, $version) = @_;
return unless exists $meta->{resources};
return _convert($meta->{resources}, $resource_downgrade_spec);
}
sub _release_status {
my ($element, undef, $meta) = @_;
return $element if $element && $element =~ m{\A(?:stable|testing|unstable)\z};
return _release_status_from_version(undef, undef, $meta);
}
sub _release_status_from_version {
my (undef, undef, $meta) = @_;
my $version = $meta->{version} || '';
return ( $version =~ /_/ ) ? 'testing' : 'stable';
}
my $provides_spec = {
file => \&_keep,
version => \&_keep,
};
my $provides_spec_2 = {
file => \&_keep,
version => \&_keep,
':custom' => \&_prefix_custom,
};
sub _provides {
my ($element, $key, $meta, $to_version) = @_;
return unless defined $element && ref $element eq 'HASH';
my $spec = $to_version == 2 ? $provides_spec_2 : $provides_spec;
my $new_data = {};
for my $k ( keys %$element ) {
$new_data->{$k} = _convert($element->{$k}, $spec, $to_version);
$new_data->{$k}{version} = _clean_version($element->{$k}{version})
if exists $element->{$k}{version};
}
return $new_data;
}
sub _convert {
my ($data, $spec, $to_version, $is_fragment) = @_;
my $new_data = {};
for my $key ( keys %$spec ) {
next if $key eq ':custom' || $key eq ':drop';
next unless my $fcn = $spec->{$key};
if ( $is_fragment && $key eq 'generated_by' ) {
$fcn = \&_keep;
}
die "spec for '$key' is not a coderef"
unless ref $fcn && ref $fcn eq 'CODE';
my $new_value = $fcn->($data->{$key}, $key, $data, $to_version);
$new_data->{$key} = $new_value if defined $new_value;
}
my $drop_list = $spec->{':drop'};
my $customizer = $spec->{':custom'} || \&_keep;
for my $key ( keys %$data ) {
next if $drop_list && grep { $key eq $_ } @$drop_list;
next if exists $spec->{$key}; # we handled it
$new_data->{ $customizer->($key) } = $data->{$key};
}
return $new_data;
}
#--------------------------------------------------------------------------#
# define converters for each conversion
#--------------------------------------------------------------------------#
# each converts from prior version
# special ":custom" field is used for keys not recognized in spec
my %up_convert = (
'2-from-1.4' => {
# PRIOR MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_license_2,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# CHANGED TO MANDATORY
'dynamic_config' => \&_keep_or_one,
# ADDED MANDATORY
'release_status' => \&_release_status,
# PRIOR OPTIONAL
'keywords' => \&_keep,
'no_index' => \&_no_index_directory,
'optional_features' => \&_upgrade_optional_features,
'provides' => \&_provides,
'resources' => \&_upgrade_resources_2,
# ADDED OPTIONAL
'description' => \&_keep,
'prereqs' => \&_prereqs_from_1,
# drop these deprecated fields, but only after we convert
':drop' => [ qw(
build_requires
configure_requires
conflicts
distribution_type
license_url
private
recommends
requires
lib/App/cpanminus/fatscript.pm view on Meta::CPAN
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'recommends' => \&_version_map,
'requires' => \&_version_map,
# ADDED OPTIONAL
'keywords' => \&_keep,
'no_index' => \&_no_index_1_2,
'optional_features' => \&_optional_features_as_map,
'provides' => \&_provides,
'resources' => \&_resources_1_2,
# other random keys are OK if already valid
':custom' => \&_keep
},
'1.1' => {
# CHANGED TO MANDATORY
'version' => \&_keep,
# IMPLIED MANDATORY
'name' => \&_keep,
'meta-spec' => \&_change_meta_spec,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'recommends' => \&_version_map,
'requires' => \&_version_map,
# ADDED OPTIONAL
'license_url' => \&_url_or_drop,
'private' => \&_keep,
# other random keys are OK if already valid
':custom' => \&_keep
},
'1.0' => {
# IMPLIED MANDATORY
'name' => \&_keep,
'meta-spec' => \&_change_meta_spec,
'version' => \&_keep,
# IMPLIED OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'recommends' => \&_version_map,
'requires' => \&_version_map,
# other random keys are OK if already valid
':custom' => \&_keep,
},
);
# for a given field in a spec version, what fields will it feed
# into in the *latest* spec (i.e. v2); meta-spec omitted because
# we always expect a meta-spec to be generated
my %fragments_generate = (
'2' => {
'abstract' => 'abstract',
'author' => 'author',
'generated_by' => 'generated_by',
'license' => 'license',
'name' => 'name',
'version' => 'version',
'dynamic_config' => 'dynamic_config',
'release_status' => 'release_status',
'keywords' => 'keywords',
'no_index' => 'no_index',
'optional_features' => 'optional_features',
'provides' => 'provides',
'resources' => 'resources',
'description' => 'description',
'prereqs' => 'prereqs',
},
'1.4' => {
'abstract' => 'abstract',
'author' => 'author',
'generated_by' => 'generated_by',
'license' => 'license',
'name' => 'name',
'version' => 'version',
'build_requires' => 'prereqs',
'conflicts' => 'prereqs',
'distribution_type' => 'distribution_type',
'dynamic_config' => 'dynamic_config',
'keywords' => 'keywords',
'no_index' => 'no_index',
'optional_features' => 'optional_features',
'provides' => 'provides',
'recommends' => 'prereqs',
'requires' => 'prereqs',
'resources' => 'resources',
'configure_requires' => 'prereqs',
},
);
# this is not quite true but will work well enough
# as 1.4 is a superset of earlier ones
$fragments_generate{$_} = $fragments_generate{'1.4'} for qw/1.3 1.2 1.1 1.0/;
#--------------------------------------------------------------------------#
# Code
#--------------------------------------------------------------------------#
#pod =method new
#pod
#pod my $cmc = CPAN::Meta::Converter->new( $struct );
#pod
#pod The constructor should be passed a valid metadata structure but invalid
#pod structures are accepted. If no meta-spec version is provided, version 1.0 will
#pod be assumed.
#pod
#pod Optionally, you can provide a C<default_version> argument after C<$struct>:
#pod
#pod my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" );
#pod
#pod This is only needed when converting a metadata fragment that does not include a
#pod C<meta-spec> field.
#pod
#pod =cut
sub new {
my ($class,$data,%args) = @_;
# create an attributes hash
my $self = {
'data' => $data,
'spec' => _extract_spec_version($data, $args{default_version}),
};
# create the object
return bless $self, $class;
}
sub _extract_spec_version {
my ($data, $default) = @_;
my $spec = $data->{'meta-spec'};
# is meta-spec there and valid?
return( $default || "1.0" ) unless defined $spec && ref $spec eq 'HASH'; # before meta-spec?
# does the version key look like a valid version?
my $v = $spec->{version};
if ( defined $v && $v =~ /^\d+(?:\.\d+)?$/ ) {
return $v if defined $v && grep { $v eq $_ } keys %known_specs; # known spec
return $v+0 if defined $v && grep { $v == $_ } keys %known_specs; # 2.0 => 2
}
# otherwise, use heuristics: look for 1.x vs 2.0 fields
return "2" if exists $data->{prereqs};
return "1.4" if exists $data->{configure_requires};
return( $default || "1.2" ); # when meta-spec was first defined
}
#pod =method convert
#pod
#pod my $new_struct = $cmc->convert( version => "2" );
#pod
#pod Returns a new hash reference with the metadata converted to a different form.
#pod C<convert> will die if any conversion/standardization still results in an
#pod invalid structure.
#pod
#pod Valid parameters include:
#pod
#pod =over
#pod
#pod =item *
#pod
#pod C<version> -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2").
#pod Defaults to the latest version of the CPAN Meta Spec.
#pod
#pod =back
#pod
#pod Conversion proceeds through each version in turn. For example, a version 1.2
#pod structure might be converted to 1.3 then 1.4 then finally to version 2. The
#pod conversion process attempts to clean-up simple errors and standardize data.
#pod For example, if C<author> is given as a scalar, it will converted to an array
#pod reference containing the item. (Converting a structure to its own version will
#pod also clean-up and standardize.)
#pod
#pod When data are cleaned and standardized, missing or invalid fields will be
#pod replaced with sensible defaults when possible. This may be lossy or imprecise.
#pod For example, some badly structured META.yml files on CPAN have prerequisite
#pod modules listed as both keys and values:
#pod
#pod requires => { 'Foo::Bar' => 'Bam::Baz' }
#pod
#pod These would be split and each converted to a prerequisite with a minimum
#pod version of zero.
#pod
#pod When some mandatory fields are missing or invalid, the conversion will attempt
#pod to provide a sensible default or will fill them with a value of 'unknown'. For
#pod example a missing or unrecognized C<license> field will result in a C<license>
#pod field of 'unknown'. Fields that may get an 'unknown' include:
#pod
#pod =for :list
#pod * abstract
#pod * author
#pod * license
#pod
#pod =cut
sub convert {
my ($self, %args) = @_;
my $args = { %args };
my $new_version = $args->{version} || $HIGHEST;
my $is_fragment = $args->{is_fragment};
my ($old_version) = $self->{spec};
my $converted = _dclone($self->{data});
if ( $old_version == $new_version ) {
$converted = _convert( $converted, $cleanup{$old_version}, $old_version, $is_fragment );
unless ( $args->{is_fragment} ) {
my $cmv = CPAN::Meta::Validator->new( $converted );
unless ( $cmv->is_valid ) {
my $errs = join("\n", $cmv->errors);
die "Failed to clean-up $old_version metadata. Errors:\n$errs\n";
}
}
return $converted;
}
elsif ( $old_version > $new_version ) {
my @vers = sort { $b <=> $a } keys %known_specs;
for my $i ( 0 .. $#vers-1 ) {
next if $vers[$i] > $old_version;
last if $vers[$i+1] < $new_version;
my $spec_string = "$vers[$i+1]-from-$vers[$i]";
$converted = _convert( $converted, $down_convert{$spec_string}, $vers[$i+1], $is_fragment );
unless ( $args->{is_fragment} ) {
my $cmv = CPAN::Meta::Validator->new( $converted );
unless ( $cmv->is_valid ) {
my $errs = join("\n", $cmv->errors);
die "Failed to downconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
}
}
}
return $converted;
}
else {
my @vers = sort { $a <=> $b } keys %known_specs;
for my $i ( 0 .. $#vers-1 ) {
next if $vers[$i] < $old_version;
last if $vers[$i+1] > $new_version;
my $spec_string = "$vers[$i+1]-from-$vers[$i]";
$converted = _convert( $converted, $up_convert{$spec_string}, $vers[$i+1], $is_fragment );
unless ( $args->{is_fragment} ) {
my $cmv = CPAN::Meta::Validator->new( $converted );
unless ( $cmv->is_valid ) {
my $errs = join("\n", $cmv->errors);
die "Failed to upconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
}
}
}
return $converted;
}
}
#pod =method upgrade_fragment
#pod
#pod my $new_struct = $cmc->upgrade_fragment;
#pod
#pod Returns a new hash reference with the metadata converted to the latest version
#pod of the CPAN Meta Spec. No validation is done on the result -- you must
#pod validate after merging fragments into a complete metadata document.
#pod
#pod Available since version 2.141170.
#pod
#pod =cut
sub upgrade_fragment {
my ($self) = @_;
my ($old_version) = $self->{spec};
my %expected =
map {; $_ => 1 }
grep { defined }
map { $fragments_generate{$old_version}{$_} }
keys %{ $self->{data} };
my $converted = $self->convert( version => $HIGHEST, is_fragment => 1 );
for my $key ( keys %$converted ) {
next if $key =~ /^x_/i || $key eq 'meta-spec';
delete $converted->{$key} unless $expected{$key};
}
return $converted;
}
1;
# ABSTRACT: Convert CPAN distribution metadata structures
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::Converter - Convert CPAN distribution metadata structures
=head1 VERSION
version 2.150005
=head1 SYNOPSIS
my $struct = decode_json_file('META.json');
my $cmc = CPAN::Meta::Converter->new( $struct );
my $new_struct = $cmc->convert( version => "2" );
=head1 DESCRIPTION
This module converts CPAN Meta structures from one form to another. The
primary use is to convert older structures to the most modern version of
the specification, but other transformations may be implemented in the
future as needed. (E.g. stripping all custom fields or stripping all
optional fields.)
=head1 METHODS
=head2 new
my $cmc = CPAN::Meta::Converter->new( $struct );
The constructor should be passed a valid metadata structure but invalid
structures are accepted. If no meta-spec version is provided, version 1.0 will
be assumed.
Optionally, you can provide a C<default_version> argument after C<$struct>:
my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" );
This is only needed when converting a metadata fragment that does not include a
C<meta-spec> field.
=head2 convert
my $new_struct = $cmc->convert( version => "2" );
Returns a new hash reference with the metadata converted to a different form.
C<convert> will die if any conversion/standardization still results in an
invalid structure.
Valid parameters include:
=over
=item *
C<version> -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2").
Defaults to the latest version of the CPAN Meta Spec.
=back
Conversion proceeds through each version in turn. For example, a version 1.2
structure might be converted to 1.3 then 1.4 then finally to version 2. The
conversion process attempts to clean-up simple errors and standardize data.
For example, if C<author> is given as a scalar, it will converted to an array
reference containing the item. (Converting a structure to its own version will
also clean-up and standardize.)
When data are cleaned and standardized, missing or invalid fields will be
replaced with sensible defaults when possible. This may be lossy or imprecise.
For example, some badly structured META.yml files on CPAN have prerequisite
modules listed as both keys and values:
requires => { 'Foo::Bar' => 'Bam::Baz' }
These would be split and each converted to a prerequisite with a minimum
version of zero.
When some mandatory fields are missing or invalid, the conversion will attempt
to provide a sensible default or will fill them with a value of 'unknown'. For
example a missing or unrecognized C<license> field will result in a C<license>
field of 'unknown'. Fields that may get an 'unknown' include:
=over 4
=item *
abstract
=item *
author
=item *
license
=back
=head2 upgrade_fragment
my $new_struct = $cmc->upgrade_fragment;
Returns a new hash reference with the metadata converted to the latest version
of the CPAN Meta Spec. No validation is done on the result -- you must
validate after merging fragments into a complete metadata document.
Available since version 2.141170.
=head1 BUGS
Please report any bugs or feature using the CPAN Request Tracker.
Bugs can be submitted through the web interface at
L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
When submitting a bug or request, please include a test-file or a patch to an
existing test-file that illustrates the bug or desired feature.
=head1 AUTHORS
=over 4
=item *
David Golden <dagolden@cpan.org>
=item *
Ricardo Signes <rjbs@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by David Golden and Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__
# vim: ts=2 sts=2 sw=2 et :
CPAN_META_CONVERTER
$fatpacked{"CPAN/Meta/Feature.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_FEATURE';
use 5.006;
use strict;
use warnings;
package CPAN::Meta::Feature;
our $VERSION = '2.150005';
use CPAN::Meta::Prereqs;
#pod =head1 DESCRIPTION
#pod
#pod A CPAN::Meta::Feature object describes an optional feature offered by a CPAN
#pod distribution and specified in the distribution's F<META.json> (or F<META.yml>)
#pod file.
#pod
#pod For the most part, this class will only be used when operating on the result of
#pod the C<feature> or C<features> methods on a L<CPAN::Meta> object.
#pod
lib/App/cpanminus/fatscript.pm view on Meta::CPAN
croak 'default version required' if not exists $arguments{default_version};
my %mapping = %default;
my %extra = %{ $arguments{extra_mappings} || {} };
for my $key (keys %extra) {
if (ref($mapping{$key}) eq 'HASH') {
$mapping{$key} = { %{ $mapping{$key} }, %{ $extra{$key} } };
}
else {
$mapping{$key} = $extra{$key};
}
}
return bless {
default_version => $arguments{default_version},
mapping => _coerce_mapping(\%mapping, []),
}, $class;
}
my %coderef_for = (
set_addition => \&_set_addition,
uniq_map => \&_uniq_map,
identical => \&_identical,
improvize => \&_improvize,
);
sub _coerce_mapping {
my ($orig, $map_path) = @_;
my %ret;
for my $key (keys %{$orig}) {
my $value = $orig->{$key};
if (ref($orig->{$key}) eq 'CODE') {
$ret{$key} = $value;
}
elsif (ref($value) eq 'HASH') {
my $mapping = _coerce_mapping($value, [ @{$map_path}, $key ]);
$ret{$key} = sub {
my ($left, $right, $path) = @_;
return _merge($left, $right, $mapping, [ @{$path} ]);
};
}
elsif ($coderef_for{$value}) {
$ret{$key} = $coderef_for{$value};
}
else {
croak "Don't know what to do with " . join '.', @{$map_path}, $key;
}
}
return \%ret;
}
sub merge {
my ($self, @items) = @_;
my $current = {};
for my $next (@items) {
if ( blessed($next) && $next->isa('CPAN::Meta') ) {
$next = $next->as_struct;
}
elsif ( ref($next) eq 'HASH' ) {
my $cmc = CPAN::Meta::Converter->new(
$next, default_version => $self->{default_version}
);
$next = $cmc->upgrade_fragment;
}
else {
croak "Don't know how to merge '$next'";
}
$current = _merge($current, $next, $self->{mapping}, []);
}
return $current;
}
1;
# ABSTRACT: Merging CPAN Meta fragments
# vim: ts=2 sts=2 sw=2 et :
__END__
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::Merge - Merging CPAN Meta fragments
=head1 VERSION
version 2.150005
=head1 SYNOPSIS
my $merger = CPAN::Meta::Merge->new(default_version => "2");
my $meta = $merger->merge($base, @additional);
=head1 DESCRIPTION
=head1 METHODS
=head2 new
This creates a CPAN::Meta::Merge object. It takes one mandatory named
argument, C<version>, declaring the version of the meta-spec that must be
used for the merge. It can optionally take an C<extra_mappings> argument
that allows one to add additional merging functions for specific elements.
=head2 merge(@fragments)
Merge all C<@fragments> together. It will accept both CPAN::Meta objects and
(possibly incomplete) hashrefs of metadata.
=head1 AUTHORS
=over 4
=item *
David Golden <dagolden@cpan.org>
=item *
Ricardo Signes <rjbs@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by David Golden and Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
CPAN_META_MERGE
$fatpacked{"CPAN/Meta/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_PREREQS';
use 5.006;
use strict;
use warnings;
package CPAN::Meta::Prereqs;
our $VERSION = '2.150005';
#pod =head1 DESCRIPTION
#pod
#pod A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN
#pod distribution or one of its optional features. Each set of prereqs is
#pod organized by phase and type, as described in L<CPAN::Meta::Prereqs>.
#pod
#pod =cut
use Carp qw(confess);
use Scalar::Util qw(blessed);
use CPAN::Meta::Requirements 2.121;
#pod =method new
#pod
#pod my $prereq = CPAN::Meta::Prereqs->new( \%prereq_spec );
#pod
#pod This method returns a new set of Prereqs. The input should look like the
#pod contents of the C<prereqs> field described in L<CPAN::Meta::Spec>, meaning
#pod something more or less like this:
#pod
#pod my $prereq = CPAN::Meta::Prereqs->new({
#pod runtime => {
#pod requires => {
#pod 'Some::Module' => '1.234',
#pod ...,
#pod },
lib/App/cpanminus/fatscript.pm view on Meta::CPAN
#pod Validates that the given key begins with 'x_' or 'X_', to indicate a user
#pod defined keyword and only has characters in the class [-_a-zA-Z]
#pod
#pod =item *
#pod
#pod identifier($self,$key,$value)
#pod
#pod Validates that key is in an acceptable format for the META specification,
#pod for an identifier, i.e. any that matches the regular expression
#pod qr/[a-z][a-z_]/i.
#pod
#pod =item *
#pod
#pod module($self,$key,$value)
#pod
#pod Validates that a given key is in an acceptable module name format, e.g.
#pod 'Test::CPAN::Meta::Version'.
#pod
#pod =back
#pod
#pod =end :internals
#pod
#pod =cut
sub header {
my ($self,$key,$value) = @_;
if(defined $value) {
return 1 if($value && $value =~ /^--- #YAML:1.0/);
}
$self->_error( "file does not have a valid YAML header." );
return 0;
}
sub release_status {
my ($self,$key,$value) = @_;
if(defined $value) {
my $version = $self->{data}{version} || '';
if ( $version =~ /_/ ) {
return 1 if ( $value =~ /\A(?:testing|unstable)\z/ );
$self->_error( "'$value' for '$key' is invalid for version '$version'" );
}
else {
return 1 if ( $value =~ /\A(?:stable|testing|unstable)\z/ );
$self->_error( "'$value' for '$key' is invalid" );
}
}
else {
$self->_error( "'$key' is not defined" );
}
return 0;
}
# _uri_split taken from URI::Split by Gisle Aas, Copyright 2003
sub _uri_split {
return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,;
}
sub url {
my ($self,$key,$value) = @_;
if(defined $value) {
my ($scheme, $auth, $path, $query, $frag) = _uri_split($value);
unless ( defined $scheme && length $scheme ) {
$self->_error( "'$value' for '$key' does not have a URL scheme" );
return 0;
}
unless ( defined $auth && length $auth ) {
$self->_error( "'$value' for '$key' does not have a URL authority" );
return 0;
}
return 1;
}
$value ||= '';
$self->_error( "'$value' for '$key' is not a valid URL." );
return 0;
}
sub urlspec {
my ($self,$key,$value) = @_;
if(defined $value) {
return 1 if($value && $known_specs{$self->{spec}} eq $value);
if($value && $known_urls{$value}) {
$self->_error( 'META specification URL does not match version' );
return 0;
}
}
$self->_error( 'Unknown META specification' );
return 0;
}
sub anything { return 1 }
sub string {
my ($self,$key,$value) = @_;
if(defined $value) {
return 1 if($value || $value =~ /^0$/);
}
$self->_error( "value is an undefined string" );
return 0;
}
sub string_or_undef {
my ($self,$key,$value) = @_;
return 1 unless(defined $value);
return 1 if($value || $value =~ /^0$/);
$self->_error( "No string defined for '$key'" );
return 0;
}
sub file {
my ($self,$key,$value) = @_;
return 1 if(defined $value);
$self->_error( "No file defined for '$key'" );
return 0;
}
sub exversion {
my ($self,$key,$value) = @_;
if(defined $value && ($value || $value =~ /0/)) {
my $pass = 1;
for(split(",",$value)) { $self->version($key,$_) or ($pass = 0); }
return $pass;
lib/App/cpanminus/fatscript.pm view on Meta::CPAN
=head2 decode
$perl_scalar = $json->decode($json_text)
The opposite of C<encode>: expects a JSON text and tries to parse it,
returning the resulting simple scalar or reference. Croaks on error.
JSON numbers and strings become simple Perl scalars. JSON arrays become
Perl arrayrefs and JSON objects become Perl hashrefs. C<true> becomes
C<1> (C<JSON::true>), C<false> becomes C<0> (C<JSON::false>) and
C<null> becomes C<undef>.
=head2 decode_prefix
($perl_scalar, $characters) = $json->decode_prefix($json_text)
This works like the C<decode> method, but instead of raising an exception
when there is trailing garbage after the first JSON object, it will
silently stop parsing there and return the number of characters consumed
so far.
JSON->new->decode_prefix ("[1] the tail")
=> ([], 3)
=head1 INCREMENTAL PARSING
Most of this section are copied and modified from L<JSON::XS/INCREMENTAL PARSING>.
In some cases, there is the need for incremental parsing of JSON texts.
This module does allow you to parse a JSON stream incrementally.
It does so by accumulating text until it has a full JSON object, which
it then can decode. This process is similar to using C<decode_prefix>
to see if a full JSON object is available, but is much more efficient
(and can be implemented with a minimum of method calls).
This module will only attempt to parse the JSON text once it is sure it
has enough text to get a decisive result, using a very simple but
truly incremental parser. This means that it sometimes won't stop as
early as the full parser, for example, it doesn't detect parenthese
mismatches. The only thing it guarantees is that it starts decoding as
soon as a syntactically valid JSON text has been seen. This means you need
to set resource limits (e.g. C<max_size>) to ensure the parser will stop
parsing in the presence if syntax errors.
The following methods implement this incremental parser.
=head2 incr_parse
$json->incr_parse( [$string] ) # void context
$obj_or_undef = $json->incr_parse( [$string] ) # scalar context
@obj_or_empty = $json->incr_parse( [$string] ) # list context
This is the central parsing function. It can both append new text and
extract objects from the stream accumulated so far (both of these
functions are optional).
If C<$string> is given, then this string is appended to the already
existing JSON fragment stored in the C<$json> object.
After that, if the function is called in void context, it will simply
return without doing anything further. This can be used to add more text
in as many chunks as you want.
If the method is called in scalar context, then it will try to extract
exactly I<one> JSON object. If that is successful, it will return this
object, otherwise it will return C<undef>. If there is a parse error,
this method will croak just as C<decode> would do (one can then use
C<incr_skip> to skip the errornous part). This is the most common way of
using the method.
And finally, in list context, it will try to extract as many objects
from the stream as it can find and return them, or the empty list
otherwise. For this to work, there must be no separators between the JSON
objects or arrays, instead they must be concatenated back-to-back. If
an error occurs, an exception will be raised as in the scalar context
case. Note that in this case, any previously-parsed JSON texts will be
lost.
Example: Parse some JSON arrays/objects in a given string and return them.
my @objs = JSON->new->incr_parse ("[5][7][1,2]");
=head2 incr_text
$lvalue_string = $json->incr_text
This method returns the currently stored JSON fragment as an lvalue, that
is, you can manipulate it. This I<only> works when a preceding call to
C<incr_parse> in I<scalar context> successfully returned an object. Under
all other circumstances you must not call this function (I mean it.
although in simple tests it might actually work, it I<will> fail under
real world conditions). As a special exception, you can also call this
method before having parsed anything.
This function is useful in two cases: a) finding the trailing text after a
JSON object or b) parsing multiple JSON objects separated by non-JSON text
(such as commas).
$json->incr_text =~ s/\s*,\s*//;
In Perl 5.005, C<lvalue> attribute is not available.
You must write codes like the below:
$string = $json->incr_text;
$string =~ s/\s*,\s*//;
$json->incr_text( $string );
=head2 incr_skip
$json->incr_skip
This will reset the state of the incremental parser and will remove the
parsed text from the input buffer. This is useful after C<incr_parse>
died, in which case the input buffer and incremental parser state is left
unchanged, to skip the text parsed so far and to reset the parse state.
=head2 incr_reset
$json->incr_reset
This completely resets the incremental parser, that is, after this call,
it will be as if the parser had never parsed anything.
This is useful if you want ot repeatedly parse JSON objects and want to
ignore any trailing data, which means you have to reset the parser after
each successful decode.
See to L<JSON::XS/INCREMENTAL PARSING> for examples.
=head1 JSON::PP OWN METHODS
=head2 allow_singlequote
$json = $json->allow_singlequote([$enable])
If C<$enable> is true (or missing), then C<decode> will accept
JSON strings quoted by single quotations that are invalid JSON
format.
$json->allow_singlequote->decode({"foo":'bar'});
$json->allow_singlequote->decode({'foo':"bar"});
$json->allow_singlequote->decode({'foo':'bar'});
As same as the C<relaxed> option, this option may be used to parse
application-specific files written by humans.
( run in 0.685 second using v1.01-cache-2.11-cpan-364913b4093 )