+++ /dev/null
-use 5.006;
-use strict;
-use warnings;
-package CPAN::Meta;
-
-our $VERSION = '2.150005';
-
-#pod =head1 SYNOPSIS
-#pod
-#pod use v5.10;
-#pod use strict;
-#pod use warnings;
-#pod use CPAN::Meta;
-#pod use Module::Load;
-#pod
-#pod my $meta = CPAN::Meta->load_file('META.json');
-#pod
-#pod printf "testing requirements for %s version %s\n",
-#pod $meta->name,
-#pod $meta->version;
-#pod
-#pod my $prereqs = $meta->effective_prereqs;
-#pod
-#pod for my $phase ( qw/configure runtime build test/ ) {
-#pod say "Requirements for $phase:";
-#pod my $reqs = $prereqs->requirements_for($phase, "requires");
-#pod for my $module ( sort $reqs->required_modules ) {
-#pod my $status;
-#pod if ( eval { load $module unless $module eq 'perl'; 1 } ) {
-#pod my $version = $module eq 'perl' ? $] : $module->VERSION;
-#pod $status = $reqs->accepts_module($module, $version)
-#pod ? "$version ok" : "$version not ok";
-#pod } else {
-#pod $status = "missing"
-#pod };
-#pod say " $module ($status)";
-#pod }
-#pod }
-#pod
-#pod =head1 DESCRIPTION
-#pod
-#pod Software distributions released to the CPAN include a F<META.json> or, for
-#pod older distributions, F<META.yml>, which describes the distribution, its
-#pod contents, and the requirements for building and installing the distribution.
-#pod The data structure stored in the F<META.json> file is described in
-#pod L<CPAN::Meta::Spec>.
-#pod
-#pod CPAN::Meta provides a simple class to represent this distribution metadata (or
-#pod I<distmeta>), along with some helpful methods for interrogating that data.
-#pod
-#pod The documentation below is only for the methods of the CPAN::Meta object. For
-#pod information on the meaning of individual fields, consult the spec.
-#pod
-#pod =cut
-
-use Carp qw(carp croak);
-use CPAN::Meta::Feature;
-use CPAN::Meta::Prereqs;
-use CPAN::Meta::Converter;
-use CPAN::Meta::Validator;
-use Parse::CPAN::Meta 1.4414 ();
-
-BEGIN { *_dclone = \&CPAN::Meta::Converter::_dclone }
-
-#pod =head1 STRING DATA
-#pod
-#pod The following methods return a single value, which is the value for the
-#pod corresponding entry in the distmeta structure. Values should be either undef
-#pod or strings.
-#pod
-#pod =for :list
-#pod * abstract
-#pod * description
-#pod * dynamic_config
-#pod * generated_by
-#pod * name
-#pod * release_status
-#pod * version
-#pod
-#pod =cut
-
-BEGIN {
- my @STRING_READERS = qw(
- abstract
- description
- dynamic_config
- generated_by
- name
- release_status
- version
- );
-
- no strict 'refs';
- for my $attr (@STRING_READERS) {
- *$attr = sub { $_[0]{ $attr } };
- }
-}
-
-#pod =head1 LIST DATA
-#pod
-#pod These methods return lists of string values, which might be represented in the
-#pod distmeta structure as arrayrefs or scalars:
-#pod
-#pod =for :list
-#pod * authors
-#pod * keywords
-#pod * licenses
-#pod
-#pod The C<authors> and C<licenses> methods may also be called as C<author> and
-#pod C<license>, respectively, to match the field name in the distmeta structure.
-#pod
-#pod =cut
-
-BEGIN {
- my @LIST_READERS = qw(
- author
- keywords
- license
- );
-
- no strict 'refs';
- for my $attr (@LIST_READERS) {
- *$attr = sub {
- my $value = $_[0]{ $attr };
- croak "$attr must be called in list context"
- unless wantarray;
- return @{ _dclone($value) } if ref $value;
- return $value;
- };
- }
-}
-
-sub authors { $_[0]->author }
-sub licenses { $_[0]->license }
-
-#pod =head1 MAP DATA
-#pod
-#pod These readers return hashrefs of arbitrary unblessed data structures, each
-#pod described more fully in the specification:
-#pod
-#pod =for :list
-#pod * meta_spec
-#pod * resources
-#pod * provides
-#pod * no_index
-#pod * prereqs
-#pod * optional_features
-#pod
-#pod =cut
-
-BEGIN {
- my @MAP_READERS = qw(
- meta-spec
- resources
- provides
- no_index
-
- prereqs
- optional_features
- );
-
- no strict 'refs';
- for my $attr (@MAP_READERS) {
- (my $subname = $attr) =~ s/-/_/;
- *$subname = sub {
- my $value = $_[0]{ $attr };
- return _dclone($value) if $value;
- return {};
- };
- }
-}
-
-#pod =head1 CUSTOM DATA
-#pod
-#pod A list of custom keys are available from the C<custom_keys> method and
-#pod particular keys may be retrieved with the C<custom> method.
-#pod
-#pod say $meta->custom($_) for $meta->custom_keys;
-#pod
-#pod If a custom key refers to a data structure, a deep clone is returned.
-#pod
-#pod =cut
-
-sub custom_keys {
- return grep { /^x_/i } keys %{$_[0]};
-}
-
-sub custom {
- my ($self, $attr) = @_;
- my $value = $self->{$attr};
- return _dclone($value) if ref $value;
- return $value;
-}
-
-#pod =method new
-#pod
-#pod my $meta = CPAN::Meta->new($distmeta_struct, \%options);
-#pod
-#pod Returns a valid CPAN::Meta object or dies if the supplied metadata hash
-#pod reference fails to validate. Older-format metadata will be up-converted to
-#pod version 2 if they validate against the original stated specification.
-#pod
-#pod It takes an optional hashref of options. Valid options include:
-#pod
-#pod =over
-#pod
-#pod =item *
-#pod
-#pod lazy_validation -- if true, new will attempt to convert the given metadata
-#pod to version 2 before attempting to validate it. This means than any
-#pod fixable errors will be handled by CPAN::Meta::Converter before validation.
-#pod (Note that this might result in invalid optional data being silently
-#pod dropped.) The default is false.
-#pod
-#pod =back
-#pod
-#pod =cut
-
-sub _new {
- my ($class, $struct, $options) = @_;
- my $self;
-
- if ( $options->{lazy_validation} ) {
- # try to convert to a valid structure; if succeeds, then return it
- my $cmc = CPAN::Meta::Converter->new( $struct );
- $self = $cmc->convert( version => 2 ); # valid or dies
- return bless $self, $class;
- }
- else {
- # validate original struct
- my $cmv = CPAN::Meta::Validator->new( $struct );
- unless ( $cmv->is_valid) {
- die "Invalid metadata structure. Errors: "
- . join(", ", $cmv->errors) . "\n";
- }
- }
-
- # up-convert older spec versions
- my $version = $struct->{'meta-spec'}{version} || '1.0';
- if ( $version == 2 ) {
- $self = $struct;
- }
- else {
- my $cmc = CPAN::Meta::Converter->new( $struct );
- $self = $cmc->convert( version => 2 );
- }
-
- return bless $self, $class;
-}
-
-sub new {
- my ($class, $struct, $options) = @_;
- my $self = eval { $class->_new($struct, $options) };
- croak($@) if $@;
- return $self;
-}
-
-#pod =method create
-#pod
-#pod my $meta = CPAN::Meta->create($distmeta_struct, \%options);
-#pod
-#pod This is same as C<new()>, except that C<generated_by> and C<meta-spec> fields
-#pod will be generated if not provided. This means the metadata structure is
-#pod assumed to otherwise follow the latest L<CPAN::Meta::Spec>.
-#pod
-#pod =cut
-
-sub create {
- my ($class, $struct, $options) = @_;
- my $version = __PACKAGE__->VERSION || 2;
- $struct->{generated_by} ||= __PACKAGE__ . " version $version" ;
- $struct->{'meta-spec'}{version} ||= int($version);
- my $self = eval { $class->_new($struct, $options) };
- croak ($@) if $@;
- return $self;
-}
-
-#pod =method load_file
-#pod
-#pod my $meta = CPAN::Meta->load_file($distmeta_file, \%options);
-#pod
-#pod Given a pathname to a file containing metadata, this deserializes the file
-#pod according to its file suffix and constructs a new C<CPAN::Meta> object, just
-#pod like C<new()>. It will die if the deserialized version fails to validate
-#pod against its stated specification version.
-#pod
-#pod It takes the same options as C<new()> but C<lazy_validation> defaults to
-#pod true.
-#pod
-#pod =cut
-
-sub load_file {
- my ($class, $file, $options) = @_;
- $options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
-
- croak "load_file() requires a valid, readable filename"
- unless -r $file;
-
- my $self;
- eval {
- my $struct = Parse::CPAN::Meta->load_file( $file );
- $self = $class->_new($struct, $options);
- };
- croak($@) if $@;
- return $self;
-}
-
-#pod =method load_yaml_string
-#pod
-#pod my $meta = CPAN::Meta->load_yaml_string($yaml, \%options);
-#pod
-#pod This method returns a new CPAN::Meta object using the first document in the
-#pod given YAML string. In other respects it is identical to C<load_file()>.
-#pod
-#pod =cut
-
-sub load_yaml_string {
- my ($class, $yaml, $options) = @_;
- $options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
-
- my $self;
- eval {
- my ($struct) = Parse::CPAN::Meta->load_yaml_string( $yaml );
- $self = $class->_new($struct, $options);
- };
- croak($@) if $@;
- return $self;
-}
-
-#pod =method load_json_string
-#pod
-#pod my $meta = CPAN::Meta->load_json_string($json, \%options);
-#pod
-#pod This method returns a new CPAN::Meta object using the structure represented by
-#pod the given JSON string. In other respects it is identical to C<load_file()>.
-#pod
-#pod =cut
-
-sub load_json_string {
- my ($class, $json, $options) = @_;
- $options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
-
- my $self;
- eval {
- my $struct = Parse::CPAN::Meta->load_json_string( $json );
- $self = $class->_new($struct, $options);
- };
- croak($@) if $@;
- return $self;
-}
-
-#pod =method load_string
-#pod
-#pod my $meta = CPAN::Meta->load_string($string, \%options);
-#pod
-#pod If you don't know if a string contains YAML or JSON, this method will use
-#pod L<Parse::CPAN::Meta> to guess. In other respects it is identical to
-#pod C<load_file()>.
-#pod
-#pod =cut
-
-sub load_string {
- my ($class, $string, $options) = @_;
- $options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
-
- my $self;
- eval {
- my $struct = Parse::CPAN::Meta->load_string( $string );
- $self = $class->_new($struct, $options);
- };
- croak($@) if $@;
- return $self;
-}
-
-#pod =method save
-#pod
-#pod $meta->save($distmeta_file, \%options);
-#pod
-#pod Serializes the object as JSON and writes it to the given file. The only valid
-#pod option is C<version>, which defaults to '2'. On Perl 5.8.1 or later, the file
-#pod is saved with UTF-8 encoding.
-#pod
-#pod For C<version> 2 (or higher), the filename should end in '.json'. L<JSON::PP>
-#pod is the default JSON backend. Using another JSON backend requires L<JSON> 2.5 or
-#pod later and you must set the C<$ENV{PERL_JSON_BACKEND}> to a supported alternate
-#pod backend like L<JSON::XS>.
-#pod
-#pod For C<version> less than 2, the filename should end in '.yml'.
-#pod L<CPAN::Meta::Converter> is used to generate an older metadata structure, which
-#pod is serialized to YAML. CPAN::Meta::YAML is the default YAML backend. You may
-#pod set the C<$ENV{PERL_YAML_BACKEND}> to a supported alternative backend, though
-#pod this is not recommended due to subtle incompatibilities between YAML parsers on
-#pod CPAN.
-#pod
-#pod =cut
-
-sub save {
- my ($self, $file, $options) = @_;
-
- my $version = $options->{version} || '2';
- my $layer = $] ge '5.008001' ? ':utf8' : '';
-
- if ( $version ge '2' ) {
- carp "'$file' should end in '.json'"
- unless $file =~ m{\.json$};
- }
- else {
- carp "'$file' should end in '.yml'"
- unless $file =~ m{\.yml$};
- }
-
- my $data = $self->as_string( $options );
- open my $fh, ">$layer", $file
- or die "Error opening '$file' for writing: $!\n";
-
- print {$fh} $data;
- close $fh
- or die "Error closing '$file': $!\n";
-
- return 1;
-}
-
-#pod =method meta_spec_version
-#pod
-#pod This method returns the version part of the C<meta_spec> entry in the distmeta
-#pod structure. It is equivalent to:
-#pod
-#pod $meta->meta_spec->{version};
-#pod
-#pod =cut
-
-sub meta_spec_version {
- my ($self) = @_;
- return $self->meta_spec->{version};
-}
-
-#pod =method effective_prereqs
-#pod
-#pod my $prereqs = $meta->effective_prereqs;
-#pod
-#pod my $prereqs = $meta->effective_prereqs( \@feature_identifiers );
-#pod
-#pod This method returns a L<CPAN::Meta::Prereqs> object describing all the
-#pod prereqs for the distribution. If an arrayref of feature identifiers is given,
-#pod the prereqs for the identified features are merged together with the
-#pod distribution's core prereqs before the CPAN::Meta::Prereqs object is returned.
-#pod
-#pod =cut
-
-sub effective_prereqs {
- my ($self, $features) = @_;
- $features ||= [];
-
- my $prereq = CPAN::Meta::Prereqs->new($self->prereqs);
-
- return $prereq unless @$features;
-
- my @other = map {; $self->feature($_)->prereqs } @$features;
-
- return $prereq->with_merged_prereqs(\@other);
-}
-
-#pod =method should_index_file
-#pod
-#pod ... if $meta->should_index_file( $filename );
-#pod
-#pod This method returns true if the given file should be indexed. It decides this
-#pod by checking the C<file> and C<directory> keys in the C<no_index> property of
-#pod the distmeta structure. Note that neither the version format nor
-#pod C<release_status> are considered.
-#pod
-#pod C<$filename> should be given in unix format.
-#pod
-#pod =cut
-
-sub should_index_file {
- my ($self, $filename) = @_;
-
- for my $no_index_file (@{ $self->no_index->{file} || [] }) {
- return if $filename eq $no_index_file;
- }
-
- for my $no_index_dir (@{ $self->no_index->{directory} }) {
- $no_index_dir =~ s{$}{/} unless $no_index_dir =~ m{/\z};
- return if index($filename, $no_index_dir) == 0;
- }
-
- return 1;
-}
-
-#pod =method should_index_package
-#pod
-#pod ... if $meta->should_index_package( $package );
-#pod
-#pod This method returns true if the given package should be indexed. It decides
-#pod this by checking the C<package> and C<namespace> keys in the C<no_index>
-#pod property of the distmeta structure. Note that neither the version format nor
-#pod C<release_status> are considered.
-#pod
-#pod =cut
-
-sub should_index_package {
- my ($self, $package) = @_;
-
- for my $no_index_pkg (@{ $self->no_index->{package} || [] }) {
- return if $package eq $no_index_pkg;
- }
-
- for my $no_index_ns (@{ $self->no_index->{namespace} }) {
- return if index($package, "${no_index_ns}::") == 0;
- }
-
- return 1;
-}
-
-#pod =method features
-#pod
-#pod my @feature_objects = $meta->features;
-#pod
-#pod This method returns a list of L<CPAN::Meta::Feature> objects, one for each
-#pod optional feature described by the distribution's metadata.
-#pod
-#pod =cut
-
-sub features {
- my ($self) = @_;
-
- my $opt_f = $self->optional_features;
- my @features = map {; CPAN::Meta::Feature->new($_ => $opt_f->{ $_ }) }
- keys %$opt_f;
-
- return @features;
-}
-
-#pod =method feature
-#pod
-#pod my $feature_object = $meta->feature( $identifier );
-#pod
-#pod This method returns a L<CPAN::Meta::Feature> object for the optional feature
-#pod with the given identifier. If no feature with that identifier exists, an
-#pod exception will be raised.
-#pod
-#pod =cut
-
-sub feature {
- my ($self, $ident) = @_;
-
- croak "no feature named $ident"
- unless my $f = $self->optional_features->{ $ident };
-
- return CPAN::Meta::Feature->new($ident, $f);
-}
-
-#pod =method as_struct
-#pod
-#pod my $copy = $meta->as_struct( \%options );
-#pod
-#pod This method returns a deep copy of the object's metadata as an unblessed hash
-#pod reference. It takes an optional hashref of options. If the hashref contains
-#pod a C<version> argument, the copied metadata will be converted to the version
-#pod of the specification and returned. For example:
-#pod
-#pod my $old_spec = $meta->as_struct( {version => "1.4"} );
-#pod
-#pod =cut
-
-sub as_struct {
- my ($self, $options) = @_;
- my $struct = _dclone($self);
- if ( $options->{version} ) {
- my $cmc = CPAN::Meta::Converter->new( $struct );
- $struct = $cmc->convert( version => $options->{version} );
- }
- return $struct;
-}
-
-#pod =method as_string
-#pod
-#pod my $string = $meta->as_string( \%options );
-#pod
-#pod This method returns a serialized copy of the object's metadata as a character
-#pod string. (The strings are B<not> UTF-8 encoded.) It takes an optional hashref
-#pod of options. If the hashref contains a C<version> argument, the copied metadata
-#pod will be converted to the version of the specification and returned. For
-#pod example:
-#pod
-#pod my $string = $meta->as_string( {version => "1.4"} );
-#pod
-#pod For C<version> greater than or equal to 2, the string will be serialized as
-#pod JSON. For C<version> less than 2, the string will be serialized as YAML. In
-#pod both cases, the same rules are followed as in the C<save()> method for choosing
-#pod a serialization backend.
-#pod
-#pod The serialized structure will include a C<x_serialization_backend> entry giving
-#pod the package and version used to serialize. Any existing key in the given
-#pod C<$meta> object will be clobbered.
-#pod
-#pod =cut
-
-sub as_string {
- my ($self, $options) = @_;
-
- my $version = $options->{version} || '2';
-
- my $struct;
- if ( $self->meta_spec_version ne $version ) {
- my $cmc = CPAN::Meta::Converter->new( $self->as_struct );
- $struct = $cmc->convert( version => $version );
- }
- else {
- $struct = $self->as_struct;
- }
-
- my ($data, $backend);
- if ( $version ge '2' ) {
- $backend = Parse::CPAN::Meta->json_backend();
- local $struct->{x_serialization_backend} = sprintf '%s version %s',
- $backend, $backend->VERSION;
- $data = $backend->new->pretty->canonical->encode($struct);
- }
- else {
- $backend = Parse::CPAN::Meta->yaml_backend();
- local $struct->{x_serialization_backend} = sprintf '%s version %s',
- $backend, $backend->VERSION;
- $data = eval { no strict 'refs'; &{"$backend\::Dump"}($struct) };
- if ( $@ ) {
- croak $backend->can('errstr') ? $backend->errstr : $@
- }
- }
-
- return $data;
-}
-
-# Used by JSON::PP, etc. for "convert_blessed"
-sub TO_JSON {
- return { %{ $_[0] } };
-}
-
-1;
-
-# ABSTRACT: the distribution metadata for a CPAN dist
-
-=pod
-
-=encoding UTF-8
-
-=head1 NAME
-
-CPAN::Meta - the distribution metadata for a CPAN dist
-
-=head1 VERSION
-
-version 2.150005
-
-=head1 SYNOPSIS
-
- use v5.10;
- use strict;
- use warnings;
- use CPAN::Meta;
- use Module::Load;
-
- my $meta = CPAN::Meta->load_file('META.json');
-
- printf "testing requirements for %s version %s\n",
- $meta->name,
- $meta->version;
-
- my $prereqs = $meta->effective_prereqs;
-
- for my $phase ( qw/configure runtime build test/ ) {
- say "Requirements for $phase:";
- my $reqs = $prereqs->requirements_for($phase, "requires");
- for my $module ( sort $reqs->required_modules ) {
- my $status;
- if ( eval { load $module unless $module eq 'perl'; 1 } ) {
- my $version = $module eq 'perl' ? $] : $module->VERSION;
- $status = $reqs->accepts_module($module, $version)
- ? "$version ok" : "$version not ok";
- } else {
- $status = "missing"
- };
- say " $module ($status)";
- }
- }
-
-=head1 DESCRIPTION
-
-Software distributions released to the CPAN include a F<META.json> or, for
-older distributions, F<META.yml>, which describes the distribution, its
-contents, and the requirements for building and installing the distribution.
-The data structure stored in the F<META.json> file is described in
-L<CPAN::Meta::Spec>.
-
-CPAN::Meta provides a simple class to represent this distribution metadata (or
-I<distmeta>), along with some helpful methods for interrogating that data.
-
-The documentation below is only for the methods of the CPAN::Meta object. For
-information on the meaning of individual fields, consult the spec.
-
-=head1 METHODS
-
-=head2 new
-
- my $meta = CPAN::Meta->new($distmeta_struct, \%options);
-
-Returns a valid CPAN::Meta object or dies if the supplied metadata hash
-reference fails to validate. Older-format metadata will be up-converted to
-version 2 if they validate against the original stated specification.
-
-It takes an optional hashref of options. Valid options include:
-
-=over
-
-=item *
-
-lazy_validation -- if true, new will attempt to convert the given metadata
-to version 2 before attempting to validate it. This means than any
-fixable errors will be handled by CPAN::Meta::Converter before validation.
-(Note that this might result in invalid optional data being silently
-dropped.) The default is false.
-
-=back
-
-=head2 create
-
- my $meta = CPAN::Meta->create($distmeta_struct, \%options);
-
-This is same as C<new()>, except that C<generated_by> and C<meta-spec> fields
-will be generated if not provided. This means the metadata structure is
-assumed to otherwise follow the latest L<CPAN::Meta::Spec>.
-
-=head2 load_file
-
- my $meta = CPAN::Meta->load_file($distmeta_file, \%options);
-
-Given a pathname to a file containing metadata, this deserializes the file
-according to its file suffix and constructs a new C<CPAN::Meta> object, just
-like C<new()>. It will die if the deserialized version fails to validate
-against its stated specification version.
-
-It takes the same options as C<new()> but C<lazy_validation> defaults to
-true.
-
-=head2 load_yaml_string
-
- my $meta = CPAN::Meta->load_yaml_string($yaml, \%options);
-
-This method returns a new CPAN::Meta object using the first document in the
-given YAML string. In other respects it is identical to C<load_file()>.
-
-=head2 load_json_string
-
- my $meta = CPAN::Meta->load_json_string($json, \%options);
-
-This method returns a new CPAN::Meta object using the structure represented by
-the given JSON string. In other respects it is identical to C<load_file()>.
-
-=head2 load_string
-
- my $meta = CPAN::Meta->load_string($string, \%options);
-
-If you don't know if a string contains YAML or JSON, this method will use
-L<Parse::CPAN::Meta> to guess. In other respects it is identical to
-C<load_file()>.
-
-=head2 save
-
- $meta->save($distmeta_file, \%options);
-
-Serializes the object as JSON and writes it to the given file. The only valid
-option is C<version>, which defaults to '2'. On Perl 5.8.1 or later, the file
-is saved with UTF-8 encoding.
-
-For C<version> 2 (or higher), the filename should end in '.json'. L<JSON::PP>
-is the default JSON backend. Using another JSON backend requires L<JSON> 2.5 or
-later and you must set the C<$ENV{PERL_JSON_BACKEND}> to a supported alternate
-backend like L<JSON::XS>.
-
-For C<version> less than 2, the filename should end in '.yml'.
-L<CPAN::Meta::Converter> is used to generate an older metadata structure, which
-is serialized to YAML. CPAN::Meta::YAML is the default YAML backend. You may
-set the C<$ENV{PERL_YAML_BACKEND}> to a supported alternative backend, though
-this is not recommended due to subtle incompatibilities between YAML parsers on
-CPAN.
-
-=head2 meta_spec_version
-
-This method returns the version part of the C<meta_spec> entry in the distmeta
-structure. It is equivalent to:
-
- $meta->meta_spec->{version};
-
-=head2 effective_prereqs
-
- my $prereqs = $meta->effective_prereqs;
-
- my $prereqs = $meta->effective_prereqs( \@feature_identifiers );
-
-This method returns a L<CPAN::Meta::Prereqs> object describing all the
-prereqs for the distribution. If an arrayref of feature identifiers is given,
-the prereqs for the identified features are merged together with the
-distribution's core prereqs before the CPAN::Meta::Prereqs object is returned.
-
-=head2 should_index_file
-
- ... if $meta->should_index_file( $filename );
-
-This method returns true if the given file should be indexed. It decides this
-by checking the C<file> and C<directory> keys in the C<no_index> property of
-the distmeta structure. Note that neither the version format nor
-C<release_status> are considered.
-
-C<$filename> should be given in unix format.
-
-=head2 should_index_package
-
- ... if $meta->should_index_package( $package );
-
-This method returns true if the given package should be indexed. It decides
-this by checking the C<package> and C<namespace> keys in the C<no_index>
-property of the distmeta structure. Note that neither the version format nor
-C<release_status> are considered.
-
-=head2 features
-
- my @feature_objects = $meta->features;
-
-This method returns a list of L<CPAN::Meta::Feature> objects, one for each
-optional feature described by the distribution's metadata.
-
-=head2 feature
-
- my $feature_object = $meta->feature( $identifier );
-
-This method returns a L<CPAN::Meta::Feature> object for the optional feature
-with the given identifier. If no feature with that identifier exists, an
-exception will be raised.
-
-=head2 as_struct
-
- my $copy = $meta->as_struct( \%options );
-
-This method returns a deep copy of the object's metadata as an unblessed hash
-reference. It takes an optional hashref of options. If the hashref contains
-a C<version> argument, the copied metadata will be converted to the version
-of the specification and returned. For example:
-
- my $old_spec = $meta->as_struct( {version => "1.4"} );
-
-=head2 as_string
-
- my $string = $meta->as_string( \%options );
-
-This method returns a serialized copy of the object's metadata as a character
-string. (The strings are B<not> UTF-8 encoded.) It takes an optional hashref
-of options. If the hashref contains a C<version> argument, the copied metadata
-will be converted to the version of the specification and returned. For
-example:
-
- my $string = $meta->as_string( {version => "1.4"} );
-
-For C<version> greater than or equal to 2, the string will be serialized as
-JSON. For C<version> less than 2, the string will be serialized as YAML. In
-both cases, the same rules are followed as in the C<save()> method for choosing
-a serialization backend.
-
-The serialized structure will include a C<x_serialization_backend> entry giving
-the package and version used to serialize. Any existing key in the given
-C<$meta> object will be clobbered.
-
-=head1 STRING DATA
-
-The following methods return a single value, which is the value for the
-corresponding entry in the distmeta structure. Values should be either undef
-or strings.
-
-=over 4
-
-=item *
-
-abstract
-
-=item *
-
-description
-
-=item *
-
-dynamic_config
-
-=item *
-
-generated_by
-
-=item *
-
-name
-
-=item *
-
-release_status
-
-=item *
-
-version
-
-=back
-
-=head1 LIST DATA
-
-These methods return lists of string values, which might be represented in the
-distmeta structure as arrayrefs or scalars:
-
-=over 4
-
-=item *
-
-authors
-
-=item *
-
-keywords
-
-=item *
-
-licenses
-
-=back
-
-The C<authors> and C<licenses> methods may also be called as C<author> and
-C<license>, respectively, to match the field name in the distmeta structure.
-
-=head1 MAP DATA
-
-These readers return hashrefs of arbitrary unblessed data structures, each
-described more fully in the specification:
-
-=over 4
-
-=item *
-
-meta_spec
-
-=item *
-
-resources
-
-=item *
-
-provides
-
-=item *
-
-no_index
-
-=item *
-
-prereqs
-
-=item *
-
-optional_features
-
-=back
-
-=head1 CUSTOM DATA
-
-A list of custom keys are available from the C<custom_keys> method and
-particular keys may be retrieved with the C<custom> method.
-
- say $meta->custom($_) for $meta->custom_keys;
-
-If a custom key refers to a data structure, a deep clone is returned.
-
-=for Pod::Coverage TO_JSON abstract author authors custom custom_keys description dynamic_config
-generated_by keywords license licenses meta_spec name no_index
-optional_features prereqs provides release_status resources version
-
-=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 SEE ALSO
-
-=over 4
-
-=item *
-
-L<CPAN::Meta::Converter>
-
-=item *
-
-L<CPAN::Meta::Validator>
-
-=back
-
-=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
-
-=head1 SUPPORT
-
-=head2 Bugs / Feature Requests
-
-Please report any bugs or feature requests through the issue tracker
-at L<https://github.com/Perl-Toolchain-Gang/CPAN-Meta/issues>.
-You will be notified automatically of any progress on your issue.
-
-=head2 Source Code
-
-This is open source software. The code repository is available for
-public review and contribution under the terms of the license.
-
-L<https://github.com/Perl-Toolchain-Gang/CPAN-Meta>
-
- git clone https://github.com/Perl-Toolchain-Gang/CPAN-Meta.git
-
-=head1 AUTHORS
-
-=over 4
-
-=item *
-
-David Golden <dagolden@cpan.org>
-
-=item *
-
-Ricardo Signes <rjbs@cpan.org>
-
-=back
-
-=head1 CONTRIBUTORS
-
-=for stopwords Ansgar Burchardt Avar Arnfjord Bjarmason Christopher J. Madsen Chuck Adams Cory G Watson Damyan Ivanov Eric Wilhelm Graham Knop Gregor Hermann Karen Etheridge Kenichi Ishigaki Ken Williams Lars Dieckow Leon Timmermans majensen Mark Fowler Matt S Trout Michael G. Schwern mohawk2 moznion Niko Tyni Olaf Alders Olivier Mengué Randy Sims Tomohiro Hosaka
-
-=over 4
-
-=item *
-
-Ansgar Burchardt <ansgar@cpan.org>
-
-=item *
-
-Avar Arnfjord Bjarmason <avar@cpan.org>
-
-=item *
-
-Christopher J. Madsen <cjm@cpan.org>
-
-=item *
-
-Chuck Adams <cja987@gmail.com>
-
-=item *
-
-Cory G Watson <gphat@cpan.org>
-
-=item *
-
-Damyan Ivanov <dam@cpan.org>
-
-=item *
-
-Eric Wilhelm <ewilhelm@cpan.org>
-
-=item *
-
-Graham Knop <haarg@haarg.org>
-
-=item *
-
-Gregor Hermann <gregoa@debian.org>
-
-=item *
-
-Karen Etheridge <ether@cpan.org>
-
-=item *
-
-Kenichi Ishigaki <ishigaki@cpan.org>
-
-=item *
-
-Ken Williams <kwilliams@cpan.org>
-
-=item *
-
-Lars Dieckow <daxim@cpan.org>
-
-=item *
-
-Leon Timmermans <leont@cpan.org>
-
-=item *
-
-majensen <maj@fortinbras.us>
-
-=item *
-
-Mark Fowler <markf@cpan.org>
-
-=item *
-
-Matt S Trout <mst@shadowcat.co.uk>
-
-=item *
-
-Michael G. Schwern <mschwern@cpan.org>
-
-=item *
-
-mohawk2 <mohawk2@users.noreply.github.com>
-
-=item *
-
-moznion <moznion@gmail.com>
-
-=item *
-
-Niko Tyni <ntyni@debian.org>
-
-=item *
-
-Olaf Alders <olaf@wundersolutions.com>
-
-=item *
-
-Olivier Mengué <dolmen@cpan.org>
-
-=item *
-
-Randy Sims <randys@thepierianspring.org>
-
-=item *
-
-Tomohiro Hosaka <bokutin@bokut.in>
-
-=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 :
+++ /dev/null
-use 5.006;
-use strict;
-use warnings;
-package CPAN::Meta::Converter;
-
-our $VERSION = '2.150005';
-
-#pod =head1 SYNOPSIS
-#pod
-#pod my $struct = decode_json_file('META.json');
-#pod
-#pod my $cmc = CPAN::Meta::Converter->new( $struct );
-#pod
-#pod my $new_struct = $cmc->convert( version => "2" );
-#pod
-#pod =head1 DESCRIPTION
-#pod
-#pod This module converts CPAN Meta structures from one form to another. The
-#pod primary use is to convert older structures to the most modern version of
-#pod the specification, but other transformations may be implemented in the
-#pod future as needed. (E.g. stripping all custom fields or stripping all
-#pod optional fields.)
-#pod
-#pod =cut
-
-use CPAN::Meta::Validator;
-use CPAN::Meta::Requirements;
-use Parse::CPAN::Meta 1.4400 ();
-
-# To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls
-# before 5.10, we fall back to the EUMM bundled compatibility version module if
-# that's the only thing available. This shouldn't ever happen in a normal CPAN
-# install of CPAN::Meta::Requirements, as version.pm will be picked up from
-# prereqs and be available at runtime.
-
-BEGIN {
- eval "use version ()"; ## no critic
- if ( my $err = $@ ) {
- eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic
- }
-}
-
-# Perl 5.10.0 didn't have "is_qv" in version.pm
-*_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} };
-
-sub _dclone {
- my $ref = shift;
-
- # if an object is in the data structure and doesn't specify how to
- # turn itself into JSON, we just stringify the object. That does the
- # right thing for typical things that might be there, like version objects,
- # Path::Class objects, etc.
- no warnings 'once';
- no warnings 'redefine';
- local *UNIVERSAL::TO_JSON = sub { "$_[0]" };
-
- my $json = Parse::CPAN::Meta->json_backend()->new
- ->utf8
- ->allow_blessed
- ->convert_blessed;
- $json->decode($json->encode($ref))
-}
-
-my %known_specs = (
- '2' => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
- '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
- '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html',
- '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
- '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html',
- '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html'
-);
-
-my @spec_list = sort { $a <=> $b } keys %known_specs;
-my ($LOWEST, $HIGHEST) = @spec_list[0,-1];
-
-#--------------------------------------------------------------------------#
-# converters
-#
-# called as $converter->($element, $field_name, $full_meta, $to_version)
-#
-# defined return value used for field
-# undef return value means field is skipped
-#--------------------------------------------------------------------------#
-
-sub _keep { $_[0] }
-
-sub _keep_or_one { defined($_[0]) ? $_[0] : 1 }
-
-sub _keep_or_zero { defined($_[0]) ? $_[0] : 0 }
-
-sub _keep_or_unknown { defined($_[0]) && length($_[0]) ? $_[0] : "unknown" }
-
-sub _generated_by {
- my $gen = shift;
- my $sig = __PACKAGE__ . " version " . (__PACKAGE__->VERSION || "<dev>");
-
- return $sig unless defined $gen and length $gen;
- return $gen if $gen =~ /\Q$sig/;
- return "$gen, $sig";
-}
-
-sub _listify { ! defined $_[0] ? undef : ref $_[0] eq 'ARRAY' ? $_[0] : [$_[0]] }
-
-sub _prefix_custom {
- my $key = shift;
- $key =~ s/^(?!x_) # Unless it already starts with x_
- (?:x-?)? # Remove leading x- or x (if present)
- /x_/ix; # and prepend x_
- return $key;
-}
-
-sub _ucfirst_custom {
- my $key = shift;
- $key = ucfirst $key unless $key =~ /[A-Z]/;
- return $key;
-}
-
-sub _no_prefix_ucfirst_custom {
- my $key = shift;
- $key =~ s/^x_//;
- return _ucfirst_custom($key);
-}
-
-sub _change_meta_spec {
- my ($element, undef, undef, $version) = @_;
- return {
- version => $version,
- url => $known_specs{$version},
- };
-}
-
-my @open_source = (
- 'perl',
- 'gpl',
- 'apache',
- 'artistic',
- 'artistic_2',
- 'lgpl',
- 'bsd',
- 'gpl',
- 'mit',
- 'mozilla',
- 'open_source',
-);
-
-my %is_open_source = map {; $_ => 1 } @open_source;
-
-my @valid_licenses_1 = (
- @open_source,
- 'unrestricted',
- 'restrictive',
- 'unknown',
-);
-
-my %license_map_1 = (
- ( map { $_ => $_ } @valid_licenses_1 ),
- artistic2 => 'artistic_2',
-);
-
-sub _license_1 {
- my ($element) = @_;
- return 'unknown' unless defined $element;
- if ( $license_map_1{lc $element} ) {
- return $license_map_1{lc $element};
- }
- else {
- return 'unknown';
- }
-}
-
-my @valid_licenses_2 = qw(
- agpl_3
- apache_1_1
- apache_2_0
- artistic_1
- artistic_2
- bsd
- freebsd
- gfdl_1_2
- gfdl_1_3
- gpl_1
- gpl_2
- gpl_3
- lgpl_2_1
- lgpl_3_0
- mit
- mozilla_1_0
- mozilla_1_1
- openssl
- perl_5
- qpl_1_0
- ssleay
- sun
- zlib
- open_source
- restricted
- unrestricted
- unknown
-);
-
-# The "old" values were defined by Module::Build, and were often vague. I have
-# made the decisions below based on reading Module::Build::API and how clearly
-# it specifies the version of the license.
-my %license_map_2 = (
- (map { $_ => $_ } @valid_licenses_2),
- apache => 'apache_2_0', # clearly stated as 2.0
- artistic => 'artistic_1', # clearly stated as 1
- artistic2 => 'artistic_2', # clearly stated as 2
- gpl => 'open_source', # we don't know which GPL; punt
- lgpl => 'open_source', # we don't know which LGPL; punt
- mozilla => 'open_source', # we don't know which MPL; punt
- perl => 'perl_5', # clearly Perl 5
- restrictive => 'restricted',
-);
-
-sub _license_2 {
- my ($element) = @_;
- return [ 'unknown' ] unless defined $element;
- $element = [ $element ] unless ref $element eq 'ARRAY';
- my @new_list;
- for my $lic ( @$element ) {
- next unless defined $lic;
- if ( my $new = $license_map_2{lc $lic} ) {
- push @new_list, $new;
- }
- }
- return @new_list ? \@new_list : [ 'unknown' ];
-}
-
-my %license_downgrade_map = qw(
- agpl_3 open_source
- apache_1_1 apache
- apache_2_0 apache
- artistic_1 artistic
- artistic_2 artistic_2
- bsd bsd
- freebsd open_source
- gfdl_1_2 open_source
- gfdl_1_3 open_source
- gpl_1 gpl
- gpl_2 gpl
- gpl_3 gpl
- lgpl_2_1 lgpl
- lgpl_3_0 lgpl
- mit mit
- mozilla_1_0 mozilla
- mozilla_1_1 mozilla
- openssl open_source
- perl_5 perl
- qpl_1_0 open_source
- ssleay open_source
- sun open_source
- zlib open_source
- open_source open_source
- restricted restrictive
- unrestricted unrestricted
- unknown unknown
-);
-
-sub _downgrade_license {
- my ($element) = @_;
- if ( ! defined $element ) {
- return "unknown";
- }
- elsif( ref $element eq 'ARRAY' ) {
- if ( @$element > 1) {
- if (grep { !$is_open_source{ $license_downgrade_map{lc $_} || 'unknown' } } @$element) {
- return 'unknown';
- }
- else {
- return 'open_source';
- }
- }
- elsif ( @$element == 1 ) {
- return $license_downgrade_map{lc $element->[0]} || "unknown";
- }
- }
- elsif ( ! ref $element ) {
- return $license_downgrade_map{lc $element} || "unknown";
- }
- return "unknown";
-}
-
-my $no_index_spec_1_2 = {
- 'file' => \&_listify,
- 'dir' => \&_listify,
- 'package' => \&_listify,
- 'namespace' => \&_listify,
-};
-
-my $no_index_spec_1_3 = {
- 'file' => \&_listify,
- 'directory' => \&_listify,
- 'package' => \&_listify,
- 'namespace' => \&_listify,
-};
-
-my $no_index_spec_2 = {
- 'file' => \&_listify,
- 'directory' => \&_listify,
- 'package' => \&_listify,
- 'namespace' => \&_listify,
- ':custom' => \&_prefix_custom,
-};
-
-sub _no_index_1_2 {
- my (undef, undef, $meta) = @_;
- my $no_index = $meta->{no_index} || $meta->{private};
- return unless $no_index;
-
- # cleanup wrong format
- if ( ! ref $no_index ) {
- my $item = $no_index;
- $no_index = { dir => [ $item ], file => [ $item ] };
- }
- elsif ( ref $no_index eq 'ARRAY' ) {
- my $list = $no_index;
- $no_index = { dir => [ @$list ], file => [ @$list ] };
- }
-
- # common mistake: files -> file
- if ( exists $no_index->{files} ) {
- $no_index->{file} = delete $no_index->{files};
- }
- # common mistake: modules -> module
- if ( exists $no_index->{modules} ) {
- $no_index->{module} = delete $no_index->{modules};
- }
- return _convert($no_index, $no_index_spec_1_2);
-}
-
-sub _no_index_directory {
- my ($element, $key, $meta, $version) = @_;
- return unless $element;
-
- # cleanup wrong format
- if ( ! ref $element ) {
- my $item = $element;
- $element = { directory => [ $item ], file => [ $item ] };
- }
- elsif ( ref $element eq 'ARRAY' ) {
- my $list = $element;
- $element = { directory => [ @$list ], file => [ @$list ] };
- }
-
- if ( exists $element->{dir} ) {
- $element->{directory} = delete $element->{dir};
- }
- # common mistake: files -> file
- if ( exists $element->{files} ) {
- $element->{file} = delete $element->{files};
- }
- # common mistake: modules -> module
- if ( exists $element->{modules} ) {
- $element->{module} = delete $element->{modules};
- }
- my $spec = $version == 2 ? $no_index_spec_2 : $no_index_spec_1_3;
- return _convert($element, $spec);
-}
-
-sub _is_module_name {
- my $mod = shift;
- return unless defined $mod && length $mod;
- return $mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$};
-}
-
-sub _clean_version {
- my ($element) = @_;
- return 0 if ! defined $element;
-
- $element =~ s{^\s*}{};
- $element =~ s{\s*$}{};
- $element =~ s{^\.}{0.};
-
- return 0 if ! length $element;
- return 0 if ( $element eq 'undef' || $element eq '<undef>' );
-
- my $v = eval { version->new($element) };
- # XXX check defined $v and not just $v because version objects leak memory
- # in boolean context -- dagolden, 2012-02-03
- if ( defined $v ) {
- return _is_qv($v) ? $v->normal : $element;
- }
- else {
- return 0;
- }
-}
-
-sub _bad_version_hook {
- my ($v) = @_;
- $v =~ s{^\s*}{};
- $v =~ s{\s*$}{};
- $v =~ s{[a-z]+$}{}; # strip trailing alphabetics
- my $vobj = eval { version->new($v) };
- return defined($vobj) ? $vobj : version->new(0); # or give up
-}
-
-sub _version_map {
- my ($element) = @_;
- return unless defined $element;
- if ( ref $element eq 'HASH' ) {
- # XXX turn this into CPAN::Meta::Requirements with bad version hook
- # and then turn it back into a hash
- my $new_map = CPAN::Meta::Requirements->new(
- { bad_version_hook => \&_bad_version_hook } # punt
- );
- while ( my ($k,$v) = each %$element ) {
- next unless _is_module_name($k);
- if ( !defined($v) || !length($v) || $v eq 'undef' || $v eq '<undef>' ) {
- $v = 0;
- }
- # some weird, old META have bad yml with module => module
- # so check if value is like a module name and not like a version
- if ( _is_module_name($v) && ! version::is_lax($v) ) {
- $new_map->add_minimum($k => 0);
- $new_map->add_minimum($v => 0);
- }
- $new_map->add_string_requirement($k => $v);
- }
- return $new_map->as_string_hash;
- }
- elsif ( ref $element eq 'ARRAY' ) {
- my $hashref = { map { $_ => 0 } @$element };
- return _version_map($hashref); # cleanup any weird stuff
- }
- elsif ( ref $element eq '' && length $element ) {
- return { $element => 0 }
- }
- return;
-}
-
-sub _prereqs_from_1 {
- my (undef, undef, $meta) = @_;
- my $prereqs = {};
- for my $phase ( qw/build configure/ ) {
- my $key = "${phase}_requires";
- $prereqs->{$phase}{requires} = _version_map($meta->{$key})
- if $meta->{$key};
- }
- for my $rel ( qw/requires recommends conflicts/ ) {
- $prereqs->{runtime}{$rel} = _version_map($meta->{$rel})
- if $meta->{$rel};
- }
- return $prereqs;
-}
-
-my $prereqs_spec = {
- configure => \&_prereqs_rel,
- build => \&_prereqs_rel,
- test => \&_prereqs_rel,
- runtime => \&_prereqs_rel,
- develop => \&_prereqs_rel,
- ':custom' => \&_prefix_custom,
-};
-
-my $relation_spec = {
- requires => \&_version_map,
- recommends => \&_version_map,
- suggests => \&_version_map,
- conflicts => \&_version_map,
- ':custom' => \&_prefix_custom,
-};
-
-sub _cleanup_prereqs {
- my ($prereqs, $key, $meta, $to_version) = @_;
- return unless $prereqs && ref $prereqs eq 'HASH';
- return _convert( $prereqs, $prereqs_spec, $to_version );
-}
-
-sub _prereqs_rel {
- my ($relation, $key, $meta, $to_version) = @_;
- return unless $relation && ref $relation eq 'HASH';
- return _convert( $relation, $relation_spec, $to_version );
-}
-
-
-BEGIN {
- my @old_prereqs = qw(
- requires
- configure_requires
- recommends
- conflicts
- );
-
- for ( @old_prereqs ) {
- my $sub = "_get_$_";
- my ($phase,$type) = split qr/_/, $_;
- if ( ! defined $type ) {
- $type = $phase;
- $phase = 'runtime';
- }
- no strict 'refs';
- *{$sub} = sub { _extract_prereqs($_[2]->{prereqs},$phase,$type) };
- }
-}
-
-sub _get_build_requires {
- my ($data, $key, $meta) = @_;
-
- my $test_h = _extract_prereqs($_[2]->{prereqs}, qw(test requires)) || {};
- my $build_h = _extract_prereqs($_[2]->{prereqs}, qw(build requires)) || {};
-
- my $test_req = CPAN::Meta::Requirements->from_string_hash($test_h);
- my $build_req = CPAN::Meta::Requirements->from_string_hash($build_h);
-
- $test_req->add_requirements($build_req)->as_string_hash;
-}
-
-sub _extract_prereqs {
- my ($prereqs, $phase, $type) = @_;
- return unless ref $prereqs eq 'HASH';
- return scalar _version_map($prereqs->{$phase}{$type});
-}
-
-sub _downgrade_optional_features {
- my (undef, undef, $meta) = @_;
- return unless exists $meta->{optional_features};
- my $origin = $meta->{optional_features};
- my $features = {};
- for my $name ( keys %$origin ) {
- $features->{$name} = {
- description => $origin->{$name}{description},
- requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','requires'),
- configure_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','configure_requires'),
- build_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','build_requires'),
- recommends => _extract_prereqs($origin->{$name}{prereqs},'runtime','recommends'),
- conflicts => _extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'),
- };
- for my $k (keys %{$features->{$name}} ) {
- delete $features->{$name}{$k} unless defined $features->{$name}{$k};
- }
- }
- return $features;
-}
-
-sub _upgrade_optional_features {
- my (undef, undef, $meta) = @_;
- return unless exists $meta->{optional_features};
- my $origin = $meta->{optional_features};
- my $features = {};
- for my $name ( keys %$origin ) {
- $features->{$name} = {
- description => $origin->{$name}{description},
- prereqs => _prereqs_from_1(undef, undef, $origin->{$name}),
- };
- delete $features->{$name}{prereqs}{configure};
- }
- return $features;
-}
-
-my $optional_features_2_spec = {
- description => \&_keep,
- prereqs => \&_cleanup_prereqs,
- ':custom' => \&_prefix_custom,
-};
-
-sub _feature_2 {
- my ($element, $key, $meta, $to_version) = @_;
- return unless $element && ref $element eq 'HASH';
- _convert( $element, $optional_features_2_spec, $to_version );
-}
-
-sub _cleanup_optional_features_2 {
- my ($element, $key, $meta, $to_version) = @_;
- return unless $element && ref $element eq 'HASH';
- my $new_data = {};
- for my $k ( keys %$element ) {
- $new_data->{$k} = _feature_2( $element->{$k}, $k, $meta, $to_version );
- }
- return unless keys %$new_data;
- return $new_data;
-}
-
-sub _optional_features_1_4 {
- my ($element) = @_;
- return unless $element;
- $element = _optional_features_as_map($element);
- for my $name ( keys %$element ) {
- for my $drop ( qw/requires_packages requires_os excluded_os/ ) {
- delete $element->{$name}{$drop};
- }
- }
- return $element;
-}
-
-sub _optional_features_as_map {
- my ($element) = @_;
- return unless $element;
- if ( ref $element eq 'ARRAY' ) {
- my %map;
- for my $feature ( @$element ) {
- my (@parts) = %$feature;
- $map{$parts[0]} = $parts[1];
- }
- $element = \%map;
- }
- return $element;
-}
-
-sub _is_urlish { defined $_[0] && $_[0] =~ m{\A[-+.a-z0-9]+:.+}i }
-
-sub _url_or_drop {
- my ($element) = @_;
- return $element if _is_urlish($element);
- return;
-}
-
-sub _url_list {
- my ($element) = @_;
- return unless $element;
- $element = _listify( $element );
- $element = [ grep { _is_urlish($_) } @$element ];
- return unless @$element;
- return $element;
-}
-
-sub _author_list {
- my ($element) = @_;
- return [ 'unknown' ] unless $element;
- $element = _listify( $element );
- $element = [ map { defined $_ && length $_ ? $_ : 'unknown' } @$element ];
- return [ 'unknown' ] unless @$element;
- return $element;
-}
-
-my $resource2_upgrade = {
- license => sub { return _is_urlish($_[0]) ? _listify( $_[0] ) : undef },
- homepage => \&_url_or_drop,
- bugtracker => sub {
- my ($item) = @_;
- return unless $item;
- if ( $item =~ m{^mailto:(.*)$} ) { return { mailto => $1 } }
- elsif( _is_urlish($item) ) { return { web => $item } }
- else { return }
- },
- repository => sub { return _is_urlish($_[0]) ? { url => $_[0] } : undef },
- ':custom' => \&_prefix_custom,
-};
-
-sub _upgrade_resources_2 {
- my (undef, undef, $meta, $version) = @_;
- return unless exists $meta->{resources};
- return _convert($meta->{resources}, $resource2_upgrade);
-}
-
-my $bugtracker2_spec = {
- web => \&_url_or_drop,
- mailto => \&_keep,
- ':custom' => \&_prefix_custom,
-};
-
-sub _repo_type {
- my ($element, $key, $meta, $to_version) = @_;
- return $element if defined $element;
- return unless exists $meta->{url};
- my $repo_url = $meta->{url};
- for my $type ( qw/git svn/ ) {
- return $type if $repo_url =~ m{\A$type};
- }
- return;
-}
-
-my $repository2_spec = {
- web => \&_url_or_drop,
- url => \&_url_or_drop,
- type => \&_repo_type,
- ':custom' => \&_prefix_custom,
-};
-
-my $resources2_cleanup = {
- license => \&_url_list,
- homepage => \&_url_or_drop,
- bugtracker => sub { ref $_[0] ? _convert( $_[0], $bugtracker2_spec ) : undef },
- repository => sub { my $data = shift; ref $data ? _convert( $data, $repository2_spec ) : undef },
- ':custom' => \&_prefix_custom,
-};
-
-sub _cleanup_resources_2 {
- my ($resources, $key, $meta, $to_version) = @_;
- return unless $resources && ref $resources eq 'HASH';
- return _convert($resources, $resources2_cleanup, $to_version);
-}
-
-my $resource1_spec = {
- license => \&_url_or_drop,
- homepage => \&_url_or_drop,
- bugtracker => \&_url_or_drop,
- repository => \&_url_or_drop,
- ':custom' => \&_keep,
-};
-
-sub _resources_1_3 {
- my (undef, undef, $meta, $version) = @_;
- return unless exists $meta->{resources};
- return _convert($meta->{resources}, $resource1_spec);
-}
-
-*_resources_1_4 = *_resources_1_3;
-
-sub _resources_1_2 {
- my (undef, undef, $meta) = @_;
- 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
- ) ],
-
- # other random keys need x_ prefixing
- ':custom' => \&_prefix_custom,
- },
- '1.4-from-1.3' => {
- # PRIOR MANDATORY
- 'abstract' => \&_keep_or_unknown,
- 'author' => \&_author_list,
- 'generated_by' => \&_generated_by,
- 'license' => \&_license_1,
- 'meta-spec' => \&_change_meta_spec,
- 'name' => \&_keep,
- 'version' => \&_keep,
- # PRIOR OPTIONAL
- 'build_requires' => \&_version_map,
- 'conflicts' => \&_version_map,
- 'distribution_type' => \&_keep,
- 'dynamic_config' => \&_keep_or_one,
- 'keywords' => \&_keep,
- 'no_index' => \&_no_index_directory,
- 'optional_features' => \&_optional_features_1_4,
- 'provides' => \&_provides,
- 'recommends' => \&_version_map,
- 'requires' => \&_version_map,
- 'resources' => \&_resources_1_4,
- # ADDED OPTIONAL
- 'configure_requires' => \&_keep,
-
- # drop these deprecated fields, but only after we convert
- ':drop' => [ qw(
- license_url
- private
- )],
-
- # other random keys are OK if already valid
- ':custom' => \&_keep
- },
- '1.3-from-1.2' => {
- # PRIOR MANDATORY
- 'abstract' => \&_keep_or_unknown,
- 'author' => \&_author_list,
- 'generated_by' => \&_generated_by,
- 'license' => \&_license_1,
- 'meta-spec' => \&_change_meta_spec,
- 'name' => \&_keep,
- 'version' => \&_keep,
- # PRIOR OPTIONAL
- 'build_requires' => \&_version_map,
- 'conflicts' => \&_version_map,
- 'distribution_type' => \&_keep,
- 'dynamic_config' => \&_keep_or_one,
- 'keywords' => \&_keep,
- 'no_index' => \&_no_index_directory,
- 'optional_features' => \&_optional_features_as_map,
- 'provides' => \&_provides,
- 'recommends' => \&_version_map,
- 'requires' => \&_version_map,
- 'resources' => \&_resources_1_3,
-
- # drop these deprecated fields, but only after we convert
- ':drop' => [ qw(
- license_url
- private
- )],
-
- # other random keys are OK if already valid
- ':custom' => \&_keep
- },
- '1.2-from-1.1' => {
- # PRIOR MANDATORY
- 'version' => \&_keep,
- # CHANGED TO MANDATORY
- 'license' => \&_license_1,
- 'name' => \&_keep,
- 'generated_by' => \&_generated_by,
- # ADDED MANDATORY
- 'abstract' => \&_keep_or_unknown,
- 'author' => \&_author_list,
- 'meta-spec' => \&_change_meta_spec,
- # PRIOR OPTIONAL
- 'build_requires' => \&_version_map,
- '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,
-
- # drop these deprecated fields, but only after we convert
- ':drop' => [ qw(
- license_url
- private
- )],
-
- # other random keys are OK if already valid
- ':custom' => \&_keep
- },
- '1.1-from-1.0' => {
- # CHANGED TO MANDATORY
- 'version' => \&_keep,
- # IMPLIED MANDATORY
- 'name' => \&_keep,
- # 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
- },
-);
-
-my %down_convert = (
- '1.4-from-2' => {
- # MANDATORY
- 'abstract' => \&_keep_or_unknown,
- 'author' => \&_author_list,
- 'generated_by' => \&_generated_by,
- 'license' => \&_downgrade_license,
- 'meta-spec' => \&_change_meta_spec,
- 'name' => \&_keep,
- 'version' => \&_keep,
- # OPTIONAL
- 'build_requires' => \&_get_build_requires,
- 'configure_requires' => \&_get_configure_requires,
- 'conflicts' => \&_get_conflicts,
- 'distribution_type' => \&_keep,
- 'dynamic_config' => \&_keep_or_one,
- 'keywords' => \&_keep,
- 'no_index' => \&_no_index_directory,
- 'optional_features' => \&_downgrade_optional_features,
- 'provides' => \&_provides,
- 'recommends' => \&_get_recommends,
- 'requires' => \&_get_requires,
- 'resources' => \&_downgrade_resources,
-
- # drop these unsupported fields (after conversion)
- ':drop' => [ qw(
- description
- prereqs
- release_status
- )],
-
- # custom keys will be left unchanged
- ':custom' => \&_keep
- },
- '1.3-from-1.4' => {
- # MANDATORY
- 'abstract' => \&_keep_or_unknown,
- 'author' => \&_author_list,
- 'generated_by' => \&_generated_by,
- 'license' => \&_license_1,
- 'meta-spec' => \&_change_meta_spec,
- 'name' => \&_keep,
- 'version' => \&_keep,
- # OPTIONAL
- 'build_requires' => \&_version_map,
- 'conflicts' => \&_version_map,
- 'distribution_type' => \&_keep,
- 'dynamic_config' => \&_keep_or_one,
- 'keywords' => \&_keep,
- 'no_index' => \&_no_index_directory,
- 'optional_features' => \&_optional_features_as_map,
- 'provides' => \&_provides,
- 'recommends' => \&_version_map,
- 'requires' => \&_version_map,
- 'resources' => \&_resources_1_3,
-
- # drop these unsupported fields, but only after we convert
- ':drop' => [ qw(
- configure_requires
- )],
-
- # other random keys are OK if already valid
- ':custom' => \&_keep,
- },
- '1.2-from-1.3' => {
- # MANDATORY
- 'abstract' => \&_keep_or_unknown,
- 'author' => \&_author_list,
- 'generated_by' => \&_generated_by,
- 'license' => \&_license_1,
- 'meta-spec' => \&_change_meta_spec,
- 'name' => \&_keep,
- 'version' => \&_keep,
- # OPTIONAL
- 'build_requires' => \&_version_map,
- 'conflicts' => \&_version_map,
- 'distribution_type' => \&_keep,
- 'dynamic_config' => \&_keep_or_one,
- 'keywords' => \&_keep,
- 'no_index' => \&_no_index_1_2,
- 'optional_features' => \&_optional_features_as_map,
- 'provides' => \&_provides,
- 'recommends' => \&_version_map,
- 'requires' => \&_version_map,
- 'resources' => \&_resources_1_3,
-
- # other random keys are OK if already valid
- ':custom' => \&_keep,
- },
- '1.1-from-1.2' => {
- # MANDATORY
- 'version' => \&_keep,
- # IMPLIED MANDATORY
- 'name' => \&_keep,
- 'meta-spec' => \&_change_meta_spec,
- # OPTIONAL
- 'build_requires' => \&_version_map,
- 'conflicts' => \&_version_map,
- 'distribution_type' => \&_keep,
- 'dynamic_config' => \&_keep_or_one,
- 'generated_by' => \&_generated_by,
- 'license' => \&_license_1,
- 'private' => \&_keep,
- 'recommends' => \&_version_map,
- 'requires' => \&_version_map,
-
- # drop unsupported fields
- ':drop' => [ qw(
- abstract
- author
- provides
- no_index
- keywords
- resources
- )],
-
- # other random keys are OK if already valid
- ':custom' => \&_keep,
- },
- '1.0-from-1.1' => {
- # IMPLIED MANDATORY
- 'name' => \&_keep,
- 'meta-spec' => \&_change_meta_spec,
- 'version' => \&_keep,
- # 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,
-
- # other random keys are OK if already valid
- ':custom' => \&_keep,
- },
-);
-
-my %cleanup = (
- '2' => {
- # 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' => \&_cleanup_optional_features_2,
- 'provides' => \&_provides,
- 'resources' => \&_cleanup_resources_2,
- # ADDED OPTIONAL
- 'description' => \&_keep,
- 'prereqs' => \&_cleanup_prereqs,
-
- # drop these deprecated fields, but only after we convert
- ':drop' => [ qw(
- build_requires
- configure_requires
- conflicts
- distribution_type
- license_url
- private
- recommends
- requires
- ) ],
-
- # other random keys need x_ prefixing
- ':custom' => \&_prefix_custom,
- },
- '1.4' => {
- # PRIOR MANDATORY
- 'abstract' => \&_keep_or_unknown,
- 'author' => \&_author_list,
- 'generated_by' => \&_generated_by,
- 'license' => \&_license_1,
- 'meta-spec' => \&_change_meta_spec,
- 'name' => \&_keep,
- 'version' => \&_keep,
- # PRIOR OPTIONAL
- 'build_requires' => \&_version_map,
- 'conflicts' => \&_version_map,
- 'distribution_type' => \&_keep,
- 'dynamic_config' => \&_keep_or_one,
- 'keywords' => \&_keep,
- 'no_index' => \&_no_index_directory,
- 'optional_features' => \&_optional_features_1_4,
- 'provides' => \&_provides,
- 'recommends' => \&_version_map,
- 'requires' => \&_version_map,
- 'resources' => \&_resources_1_4,
- # ADDED OPTIONAL
- 'configure_requires' => \&_keep,
-
- # other random keys are OK if already valid
- ':custom' => \&_keep
- },
- '1.3' => {
- # PRIOR MANDATORY
- 'abstract' => \&_keep_or_unknown,
- 'author' => \&_author_list,
- 'generated_by' => \&_generated_by,
- 'license' => \&_license_1,
- 'meta-spec' => \&_change_meta_spec,
- 'name' => \&_keep,
- 'version' => \&_keep,
- # PRIOR OPTIONAL
- 'build_requires' => \&_version_map,
- 'conflicts' => \&_version_map,
- 'distribution_type' => \&_keep,
- 'dynamic_config' => \&_keep_or_one,
- 'keywords' => \&_keep,
- 'no_index' => \&_no_index_directory,
- 'optional_features' => \&_optional_features_as_map,
- 'provides' => \&_provides,
- 'recommends' => \&_version_map,
- 'requires' => \&_version_map,
- 'resources' => \&_resources_1_3,
-
- # other random keys are OK if already valid
- ':custom' => \&_keep
- },
- '1.2' => {
- # PRIOR MANDATORY
- 'version' => \&_keep,
- # CHANGED TO MANDATORY
- 'license' => \&_license_1,
- 'name' => \&_keep,
- 'generated_by' => \&_generated_by,
- # ADDED MANDATORY
- 'abstract' => \&_keep_or_unknown,
- 'author' => \&_author_list,
- 'meta-spec' => \&_change_meta_spec,
- # PRIOR OPTIONAL
- 'build_requires' => \&_version_map,
- '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 :
+++ /dev/null
-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
-#pod =method new
-#pod
-#pod my $feature = CPAN::Meta::Feature->new( $identifier => \%spec );
-#pod
-#pod This returns a new Feature object. The C<%spec> argument to the constructor
-#pod should be the same as the value of the C<optional_feature> entry in the
-#pod distmeta. It must contain entries for C<description> and C<prereqs>.
-#pod
-#pod =cut
-
-sub new {
- my ($class, $identifier, $spec) = @_;
-
- my %guts = (
- identifier => $identifier,
- description => $spec->{description},
- prereqs => CPAN::Meta::Prereqs->new($spec->{prereqs}),
- );
-
- bless \%guts => $class;
-}
-
-#pod =method identifier
-#pod
-#pod This method returns the feature's identifier.
-#pod
-#pod =cut
-
-sub identifier { $_[0]{identifier} }
-
-#pod =method description
-#pod
-#pod This method returns the feature's long description.
-#pod
-#pod =cut
-
-sub description { $_[0]{description} }
-
-#pod =method prereqs
-#pod
-#pod This method returns the feature's prerequisites as a L<CPAN::Meta::Prereqs>
-#pod object.
-#pod
-#pod =cut
-
-sub prereqs { $_[0]{prereqs} }
-
-1;
-
-# ABSTRACT: an optional feature provided by a CPAN distribution
-
-=pod
-
-=encoding UTF-8
-
-=head1 NAME
-
-CPAN::Meta::Feature - an optional feature provided by a CPAN distribution
-
-=head1 VERSION
-
-version 2.150005
-
-=head1 DESCRIPTION
-
-A CPAN::Meta::Feature object describes an optional feature offered by a CPAN
-distribution and specified in the distribution's F<META.json> (or F<META.yml>)
-file.
-
-For the most part, this class will only be used when operating on the result of
-the C<feature> or C<features> methods on a L<CPAN::Meta> object.
-
-=head1 METHODS
-
-=head2 new
-
- my $feature = CPAN::Meta::Feature->new( $identifier => \%spec );
-
-This returns a new Feature object. The C<%spec> argument to the constructor
-should be the same as the value of the C<optional_feature> entry in the
-distmeta. It must contain entries for C<description> and C<prereqs>.
-
-=head2 identifier
-
-This method returns the feature's identifier.
-
-=head2 description
-
-This method returns the feature's long description.
-
-=head2 prereqs
-
-This method returns the feature's prerequisites as a L<CPAN::Meta::Prereqs>
-object.
-
-=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 :
+++ /dev/null
-# vi:tw=72
-use 5.006;
-use strict;
-use warnings;
-package CPAN::Meta::History;
-
-our $VERSION = '2.150005';
-
-1;
-
-# ABSTRACT: history of CPAN Meta Spec changes
-
-__END__
-
-=pod
-
-=encoding UTF-8
-
-=head1 NAME
-
-CPAN::Meta::History - history of CPAN Meta Spec changes
-
-=head1 VERSION
-
-version 2.150005
-
-=head1 DESCRIPTION
-
-The CPAN Meta Spec has gone through several iterations. It was
-originally written in HTML and later revised into POD (though published
-in HTML generated from the POD). Fields were added, removed or changed,
-sometimes by design and sometimes to reflect real-world usage after the
-fact.
-
-This document reconstructs the history of the CPAN Meta Spec based on
-change logs, repository commit messages and the published HTML files.
-In some cases, particularly prior to version 1.2, the exact version
-when certain fields were introduced or changed is inconsistent between
-sources. When in doubt, the published HTML files for versions 1.0 to
-1.4 as they existed when version 2 was developed are used as the
-definitive source.
-
-Starting with version 2, the specification document is part of the
-CPAN-Meta distribution and will be published on CPAN as
-L<CPAN::Meta::Spec>.
-
-Going forward, specification version numbers will be integers and
-decimal portions will correspond to a release date for the CPAN::Meta
-library.
-
-=head1 HISTORY
-
-=head2 Version 2
-
-April 2010
-
-=over
-
-=item *
-
-Revised spec examples as perl data structures rather than YAML
-
-=item *
-
-Switched to JSON serialization from YAML
-
-=item *
-
-Specified allowed version number formats
-
-=item *
-
-Replaced 'requires', 'build_requires', 'configure_requires',
-'recommends' and 'conflicts' with new 'prereqs' data structure divided
-by I<phase> (configure, build, test, runtime, etc.) and I<relationship>
-(requires, recommends, suggests, conflicts)
-
-=item *
-
-Added support for 'develop' phase for requirements for maintaining
-a list of authoring tools
-
-=item *
-
-Changed 'license' to a list and revised the set of valid licenses
-
-=item *
-
-Made 'dynamic_config' mandatory to reduce confusion
-
-=item *
-
-Changed 'resources' subkey 'repository' to a hash that clarifies
-repository type, url for browsing and url for checkout
-
-=item *
-
-Changed 'resources' subkey 'bugtracker' to a hash for either web
-or mailto resource
-
-=item *
-
-Changed specification of 'optional_features':
-
-=over
-
-=item *
-
-Added formal specification and usage guide instead of just example
-
-=item *
-
-Changed to use new prereqs data structure instead of individual keys
-
-=back
-
-=item *
-
-Clarified intended use of 'author' as generalized contact list
-
-=item *
-
-Added 'release_status' field to indicate stable, testing or unstable
-status to provide hints to indexers
-
-=item *
-
-Added 'description' field for a longer description of the distribution
-
-=item *
-
-Formalized use of "x_" or "X_" for all custom keys not listed in the
-official spec
-
-=back
-
-=head2 Version 1.4
-
-June 2008
-
-=over
-
-=item *
-
-Noted explicit support for 'perl' in prerequisites
-
-=item *
-
-Added 'configure_requires' prerequisite type
-
-=item *
-
-Changed 'optional_features'
-
-=over
-
-=item *
-
-Example corrected to show map of maps instead of list of maps
-(though descriptive text said 'map' even in v1.3)
-
-=item *
-
-Removed 'requires_packages', 'requires_os' and 'excluded_os'
-as valid subkeys
-
-=back
-
-=back
-
-=head2 Version 1.3
-
-November 2006
-
-=over
-
-=item *
-
-Added 'no_index' subkey 'directory' and removed 'dir' to match actual
-usage in the wild
-
-=item *
-
-Added a 'repository' subkey to 'resources'
-
-=back
-
-=head2 Version 1.2
-
-August 2005
-
-=over
-
-=item *
-
-Re-wrote and restructured spec in POD syntax
-
-=item *
-
-Changed 'name' to be mandatory
-
-=item *
-
-Changed 'generated_by' to be mandatory
-
-=item *
-
-Changed 'license' to be mandatory
-
-=item *
-
-Added version range specifications for prerequisites
-
-=item *
-
-Added required 'abstract' field
-
-=item *
-
-Added required 'author' field
-
-=item *
-
-Added required 'meta-spec' field to define 'version' (and 'url') of the
-CPAN Meta Spec used for metadata
-
-=item *
-
-Added 'provides' field
-
-=item *
-
-Added 'no_index' field and deprecated 'private' field. 'no_index'
-subkeys include 'file', 'dir', 'package' and 'namespace'
-
-=item *
-
-Added 'keywords' field
-
-=item *
-
-Added 'resources' field with subkeys 'homepage', 'license', and
-'bugtracker'
-
-=item *
-
-Added 'optional_features' field as an alternate under 'recommends'.
-Includes 'description', 'requires', 'build_requires', 'conflicts',
-'requires_packages', 'requires_os' and 'excluded_os' as valid subkeys
-
-=item *
-
-Removed 'license_uri' field
-
-=back
-
-=head2 Version 1.1
-
-May 2003
-
-=over
-
-=item *
-
-Changed 'version' to be mandatory
-
-=item *
-
-Added 'private' field
-
-=item *
-
-Added 'license_uri' field
-
-=back
-
-=head2 Version 1.0
-
-March 2003
-
-=over
-
-=item *
-
-Original release (in HTML format only)
-
-=item *
-
-Included 'name', 'version', 'license', 'distribution_type', 'requires',
-'recommends', 'build_requires', 'conflicts', 'dynamic_config',
-'generated_by'
-
-=back
-
-=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
+++ /dev/null
-use strict;
-use warnings;
-
-package CPAN::Meta::Merge;
-
-our $VERSION = '2.150005';
-
-use Carp qw/croak/;
-use Scalar::Util qw/blessed/;
-use CPAN::Meta::Converter 2.141170;
-
-sub _is_identical {
- my ($left, $right) = @_;
- return
- (not defined $left and not defined $right)
- # if either of these are references, we compare the serialized value
- || (defined $left and defined $right and $left eq $right);
-}
-
-sub _identical {
- my ($left, $right, $path) = @_;
- croak sprintf "Can't merge attribute %s: '%s' does not equal '%s'", join('.', @{$path}), $left, $right
- unless _is_identical($left, $right);
- return $left;
-}
-
-sub _merge {
- my ($current, $next, $mergers, $path) = @_;
- for my $key (keys %{$next}) {
- if (not exists $current->{$key}) {
- $current->{$key} = $next->{$key};
- }
- elsif (my $merger = $mergers->{$key}) {
- $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]);
- }
- elsif ($merger = $mergers->{':default'}) {
- $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]);
- }
- else {
- croak sprintf "Can't merge unknown attribute '%s'", join '.', @{$path}, $key;
- }
- }
- return $current;
-}
-
-sub _uniq {
- my %seen = ();
- return grep { not $seen{$_}++ } @_;
-}
-
-sub _set_addition {
- my ($left, $right) = @_;
- return [ +_uniq(@{$left}, @{$right}) ];
-}
-
-sub _uniq_map {
- my ($left, $right, $path) = @_;
- for my $key (keys %{$right}) {
- if (not exists $left->{$key}) {
- $left->{$key} = $right->{$key};
- }
- # identical strings or references are merged identically
- elsif (_is_identical($left->{$key}, $right->{$key})) {
- 1; # do nothing - keep left
- }
- elsif (ref $left->{$key} eq 'HASH' and ref $right->{$key} eq 'HASH') {
- $left->{$key} = _uniq_map($left->{$key}, $right->{$key}, [ @{$path}, $key ]);
- }
- else {
- croak 'Duplication of element ' . join '.', @{$path}, $key;
- }
- }
- return $left;
-}
-
-sub _improvize {
- my ($left, $right, $path) = @_;
- my ($name) = reverse @{$path};
- if ($name =~ /^x_/) {
- if (ref($left) eq 'ARRAY') {
- return _set_addition($left, $right, $path);
- }
- elsif (ref($left) eq 'HASH') {
- return _uniq_map($left, $right, $path);
- }
- else {
- return _identical($left, $right, $path);
- }
- }
- croak sprintf "Can't merge '%s'", join '.', @{$path};
-}
-
-sub _optional_features {
- my ($left, $right, $path) = @_;
-
- for my $key (keys %{$right}) {
- if (not exists $left->{$key}) {
- $left->{$key} = $right->{$key};
- }
- else {
- for my $subkey (keys %{ $right->{$key} }) {
- next if $subkey eq 'prereqs';
- if (not exists $left->{$key}{$subkey}) {
- $left->{$key}{$subkey} = $right->{$key}{$subkey};
- }
- else {
- Carp::croak "Cannot merge two optional_features named '$key' with different '$subkey' values"
- if do { no warnings 'uninitialized'; $left->{$key}{$subkey} ne $right->{$key}{$subkey} };
- }
- }
-
- require CPAN::Meta::Prereqs;
- $left->{$key}{prereqs} =
- CPAN::Meta::Prereqs->new($left->{$key}{prereqs})
- ->with_merged_prereqs(CPAN::Meta::Prereqs->new($right->{$key}{prereqs}))
- ->as_string_hash;
- }
- }
- return $left;
-}
-
-
-my %default = (
- abstract => \&_identical,
- author => \&_set_addition,
- dynamic_config => sub {
- my ($left, $right) = @_;
- return $left || $right;
- },
- generated_by => sub {
- my ($left, $right) = @_;
- return join ', ', _uniq(split(/, /, $left), split(/, /, $right));
- },
- license => \&_set_addition,
- 'meta-spec' => {
- version => \&_identical,
- url => \&_identical
- },
- name => \&_identical,
- release_status => \&_identical,
- version => \&_identical,
- description => \&_identical,
- keywords => \&_set_addition,
- no_index => { map { ($_ => \&_set_addition) } qw/file directory package namespace/ },
- optional_features => \&_optional_features,
- prereqs => sub {
- require CPAN::Meta::Prereqs;
- my ($left, $right) = map { CPAN::Meta::Prereqs->new($_) } @_[0,1];
- return $left->with_merged_prereqs($right)->as_string_hash;
- },
- provides => \&_uniq_map,
- resources => {
- license => \&_set_addition,
- homepage => \&_identical,
- bugtracker => \&_uniq_map,
- repository => \&_uniq_map,
- ':default' => \&_improvize,
- },
- ':default' => \&_improvize,
-);
-
-sub new {
- my ($class, %arguments) = @_;
- 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
+++ /dev/null
-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 },
-#pod ...,
-#pod },
-#pod ...,
-#pod });
-#pod
-#pod You can also construct an empty set of prereqs with:
-#pod
-#pod my $prereqs = CPAN::Meta::Prereqs->new;
-#pod
-#pod This empty set of prereqs is useful for accumulating new prereqs before finally
-#pod dumping the whole set into a structure or string.
-#pod
-#pod =cut
-
-sub __legal_phases { qw(configure build test runtime develop) }
-sub __legal_types { qw(requires recommends suggests conflicts) }
-
-# expect a prereq spec from META.json -- rjbs, 2010-04-11
-sub new {
- my ($class, $prereq_spec) = @_;
- $prereq_spec ||= {};
-
- my %is_legal_phase = map {; $_ => 1 } $class->__legal_phases;
- my %is_legal_type = map {; $_ => 1 } $class->__legal_types;
-
- my %guts;
- PHASE: for my $phase (keys %$prereq_spec) {
- next PHASE unless $phase =~ /\Ax_/i or $is_legal_phase{$phase};
-
- my $phase_spec = $prereq_spec->{ $phase };
- next PHASE unless keys %$phase_spec;
-
- TYPE: for my $type (keys %$phase_spec) {
- next TYPE unless $type =~ /\Ax_/i or $is_legal_type{$type};
-
- my $spec = $phase_spec->{ $type };
-
- next TYPE unless keys %$spec;
-
- $guts{prereqs}{$phase}{$type} = CPAN::Meta::Requirements->from_string_hash(
- $spec
- );
- }
- }
-
- return bless \%guts => $class;
-}
-
-#pod =method requirements_for
-#pod
-#pod my $requirements = $prereqs->requirements_for( $phase, $type );
-#pod
-#pod This method returns a L<CPAN::Meta::Requirements> object for the given
-#pod phase/type combination. If no prerequisites are registered for that
-#pod combination, a new CPAN::Meta::Requirements object will be returned, and it may
-#pod be added to as needed.
-#pod
-#pod If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will
-#pod be raised.
-#pod
-#pod =cut
-
-sub requirements_for {
- my ($self, $phase, $type) = @_;
-
- confess "requirements_for called without phase" unless defined $phase;
- confess "requirements_for called without type" unless defined $type;
-
- unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) {
- confess "requested requirements for unknown phase: $phase";
- }
-
- unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) {
- confess "requested requirements for unknown type: $type";
- }
-
- my $req = ($self->{prereqs}{$phase}{$type} ||= CPAN::Meta::Requirements->new);
-
- $req->finalize if $self->is_finalized;
-
- return $req;
-}
-
-#pod =method with_merged_prereqs
-#pod
-#pod my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs );
-#pod
-#pod my $new_prereqs = $prereqs->with_merged_prereqs( \@other_prereqs );
-#pod
-#pod This method returns a new CPAN::Meta::Prereqs objects in which all the
-#pod other prerequisites given are merged into the current set. This is primarily
-#pod provided for combining a distribution's core prereqs with the prereqs of one of
-#pod its optional features.
-#pod
-#pod The new prereqs object has no ties to the originals, and altering it further
-#pod will not alter them.
-#pod
-#pod =cut
-
-sub with_merged_prereqs {
- my ($self, $other) = @_;
-
- my @other = blessed($other) ? $other : @$other;
-
- my @prereq_objs = ($self, @other);
-
- my %new_arg;
-
- for my $phase ($self->__legal_phases) {
- for my $type ($self->__legal_types) {
- my $req = CPAN::Meta::Requirements->new;
-
- for my $prereq (@prereq_objs) {
- my $this_req = $prereq->requirements_for($phase, $type);
- next unless $this_req->required_modules;
-
- $req->add_requirements($this_req);
- }
-
- next unless $req->required_modules;
-
- $new_arg{ $phase }{ $type } = $req->as_string_hash;
- }
- }
-
- return (ref $self)->new(\%new_arg);
-}
-
-#pod =method merged_requirements
-#pod
-#pod my $new_reqs = $prereqs->merged_requirements( \@phases, \@types );
-#pod my $new_reqs = $prereqs->merged_requirements( \@phases );
-#pod my $new_reqs = $prereqs->merged_requirements();
-#pod
-#pod This method joins together all requirements across a number of phases
-#pod and types into a new L<CPAN::Meta::Requirements> object. If arguments
-#pod are omitted, it defaults to "runtime", "build" and "test" for phases
-#pod and "requires" and "recommends" for types.
-#pod
-#pod =cut
-
-sub merged_requirements {
- my ($self, $phases, $types) = @_;
- $phases = [qw/runtime build test/] unless defined $phases;
- $types = [qw/requires recommends/] unless defined $types;
-
- confess "merged_requirements phases argument must be an arrayref"
- unless ref $phases eq 'ARRAY';
- confess "merged_requirements types argument must be an arrayref"
- unless ref $types eq 'ARRAY';
-
- my $req = CPAN::Meta::Requirements->new;
-
- for my $phase ( @$phases ) {
- unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) {
- confess "requested requirements for unknown phase: $phase";
- }
- for my $type ( @$types ) {
- unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) {
- confess "requested requirements for unknown type: $type";
- }
- $req->add_requirements( $self->requirements_for($phase, $type) );
- }
- }
-
- $req->finalize if $self->is_finalized;
-
- return $req;
-}
-
-
-#pod =method as_string_hash
-#pod
-#pod This method returns a hashref containing structures suitable for dumping into a
-#pod distmeta data structure. It is made up of hashes and strings, only; there will
-#pod be no Prereqs, CPAN::Meta::Requirements, or C<version> objects inside it.
-#pod
-#pod =cut
-
-sub as_string_hash {
- my ($self) = @_;
-
- my %hash;
-
- for my $phase ($self->__legal_phases) {
- for my $type ($self->__legal_types) {
- my $req = $self->requirements_for($phase, $type);
- next unless $req->required_modules;
-
- $hash{ $phase }{ $type } = $req->as_string_hash;
- }
- }
-
- return \%hash;
-}
-
-#pod =method is_finalized
-#pod
-#pod This method returns true if the set of prereqs has been marked "finalized," and
-#pod cannot be altered.
-#pod
-#pod =cut
-
-sub is_finalized { $_[0]{finalized} }
-
-#pod =method finalize
-#pod
-#pod Calling C<finalize> on a Prereqs object will close it for further modification.
-#pod Attempting to make any changes that would actually alter the prereqs will
-#pod result in an exception being thrown.
-#pod
-#pod =cut
-
-sub finalize {
- my ($self) = @_;
-
- $self->{finalized} = 1;
-
- for my $phase (keys %{ $self->{prereqs} }) {
- $_->finalize for values %{ $self->{prereqs}{$phase} };
- }
-}
-
-#pod =method clone
-#pod
-#pod my $cloned_prereqs = $prereqs->clone;
-#pod
-#pod This method returns a Prereqs object that is identical to the original object,
-#pod but can be altered without affecting the original object. Finalization does
-#pod not survive cloning, meaning that you may clone a finalized set of prereqs and
-#pod then modify the clone.
-#pod
-#pod =cut
-
-sub clone {
- my ($self) = @_;
-
- my $clone = (ref $self)->new( $self->as_string_hash );
-}
-
-1;
-
-# ABSTRACT: a set of distribution prerequisites by phase and type
-
-=pod
-
-=encoding UTF-8
-
-=head1 NAME
-
-CPAN::Meta::Prereqs - a set of distribution prerequisites by phase and type
-
-=head1 VERSION
-
-version 2.150005
-
-=head1 DESCRIPTION
-
-A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN
-distribution or one of its optional features. Each set of prereqs is
-organized by phase and type, as described in L<CPAN::Meta::Prereqs>.
-
-=head1 METHODS
-
-=head2 new
-
- my $prereq = CPAN::Meta::Prereqs->new( \%prereq_spec );
-
-This method returns a new set of Prereqs. The input should look like the
-contents of the C<prereqs> field described in L<CPAN::Meta::Spec>, meaning
-something more or less like this:
-
- my $prereq = CPAN::Meta::Prereqs->new({
- runtime => {
- requires => {
- 'Some::Module' => '1.234',
- ...,
- },
- ...,
- },
- ...,
- });
-
-You can also construct an empty set of prereqs with:
-
- my $prereqs = CPAN::Meta::Prereqs->new;
-
-This empty set of prereqs is useful for accumulating new prereqs before finally
-dumping the whole set into a structure or string.
-
-=head2 requirements_for
-
- my $requirements = $prereqs->requirements_for( $phase, $type );
-
-This method returns a L<CPAN::Meta::Requirements> object for the given
-phase/type combination. If no prerequisites are registered for that
-combination, a new CPAN::Meta::Requirements object will be returned, and it may
-be added to as needed.
-
-If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will
-be raised.
-
-=head2 with_merged_prereqs
-
- my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs );
-
- my $new_prereqs = $prereqs->with_merged_prereqs( \@other_prereqs );
-
-This method returns a new CPAN::Meta::Prereqs objects in which all the
-other prerequisites given are merged into the current set. This is primarily
-provided for combining a distribution's core prereqs with the prereqs of one of
-its optional features.
-
-The new prereqs object has no ties to the originals, and altering it further
-will not alter them.
-
-=head2 merged_requirements
-
- my $new_reqs = $prereqs->merged_requirements( \@phases, \@types );
- my $new_reqs = $prereqs->merged_requirements( \@phases );
- my $new_reqs = $prereqs->merged_requirements();
-
-This method joins together all requirements across a number of phases
-and types into a new L<CPAN::Meta::Requirements> object. If arguments
-are omitted, it defaults to "runtime", "build" and "test" for phases
-and "requires" and "recommends" for types.
-
-=head2 as_string_hash
-
-This method returns a hashref containing structures suitable for dumping into a
-distmeta data structure. It is made up of hashes and strings, only; there will
-be no Prereqs, CPAN::Meta::Requirements, or C<version> objects inside it.
-
-=head2 is_finalized
-
-This method returns true if the set of prereqs has been marked "finalized," and
-cannot be altered.
-
-=head2 finalize
-
-Calling C<finalize> on a Prereqs object will close it for further modification.
-Attempting to make any changes that would actually alter the prereqs will
-result in an exception being thrown.
-
-=head2 clone
-
- my $cloned_prereqs = $prereqs->clone;
-
-This method returns a Prereqs object that is identical to the original object,
-but can be altered without affecting the original object. Finalization does
-not survive cloning, meaning that you may clone a finalized set of prereqs and
-then modify the clone.
-
-=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 :
+++ /dev/null
-use 5.006; # keep at v5.6 for CPAN.pm
-use strict;
-use warnings;
-package CPAN::Meta::Requirements;
-# ABSTRACT: a set of version requirements for a CPAN dist
-
-our $VERSION = '2.140';
-
-#pod =head1 SYNOPSIS
-#pod
-#pod use CPAN::Meta::Requirements;
-#pod
-#pod my $build_requires = CPAN::Meta::Requirements->new;
-#pod
-#pod $build_requires->add_minimum('Library::Foo' => 1.208);
-#pod
-#pod $build_requires->add_minimum('Library::Foo' => 2.602);
-#pod
-#pod $build_requires->add_minimum('Module::Bar' => 'v1.2.3');
-#pod
-#pod $METAyml->{build_requires} = $build_requires->as_string_hash;
-#pod
-#pod =head1 DESCRIPTION
-#pod
-#pod A CPAN::Meta::Requirements object models a set of version constraints like
-#pod those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
-#pod and as defined by L<CPAN::Meta::Spec>;
-#pod It can be built up by adding more and more constraints, and it will reduce them
-#pod to the simplest representation.
-#pod
-#pod Logically impossible constraints will be identified immediately by thrown
-#pod exceptions.
-#pod
-#pod =cut
-
-use Carp ();
-
-# To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls
-# before 5.10, we fall back to the EUMM bundled compatibility version module if
-# that's the only thing available. This shouldn't ever happen in a normal CPAN
-# install of CPAN::Meta::Requirements, as version.pm will be picked up from
-# prereqs and be available at runtime.
-
-BEGIN {
- eval "use version ()"; ## no critic
- if ( my $err = $@ ) {
- eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic
- }
-}
-
-# Perl 5.10.0 didn't have "is_qv" in version.pm
-*_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} };
-
-# construct once, reuse many times
-my $V0 = version->new(0);
-
-#pod =method new
-#pod
-#pod my $req = CPAN::Meta::Requirements->new;
-#pod
-#pod This returns a new CPAN::Meta::Requirements object. It takes an optional
-#pod hash reference argument. Currently, only one key is supported:
-#pod
-#pod =for :list
-#pod * C<bad_version_hook> -- if provided, when a version cannot be parsed into
-#pod a version object, this code reference will be called with the invalid
-#pod version string as first argument, and the module name as second
-#pod argument. It must return a valid version object.
-#pod
-#pod All other keys are ignored.
-#pod
-#pod =cut
-
-my @valid_options = qw( bad_version_hook );
-
-sub new {
- my ($class, $options) = @_;
- $options ||= {};
- Carp::croak "Argument to $class\->new() must be a hash reference"
- unless ref $options eq 'HASH';
- my %self = map {; $_ => $options->{$_}} @valid_options;
-
- return bless \%self => $class;
-}
-
-# from version::vpp
-sub _find_magic_vstring {
- my $value = shift;
- my $tvalue = '';
- require B;
- my $sv = B::svref_2object(\$value);
- my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef;
- while ( $magic ) {
- if ( $magic->TYPE eq 'V' ) {
- $tvalue = $magic->PTR;
- $tvalue =~ s/^v?(.+)$/v$1/;
- last;
- }
- else {
- $magic = $magic->MOREMAGIC;
- }
- }
- return $tvalue;
-}
-
-# safe if given an unblessed reference
-sub _isa_version {
- UNIVERSAL::isa( $_[0], 'UNIVERSAL' ) && $_[0]->isa('version')
-}
-
-sub _version_object {
- my ($self, $module, $version) = @_;
-
- my ($vobj, $err);
-
- if (not defined $version or (!ref($version) && $version eq '0')) {
- return $V0;
- }
- elsif ( ref($version) eq 'version' || ( ref($version) && _isa_version($version) ) ) {
- $vobj = $version;
- }
- else {
- # hack around version::vpp not handling <3 character vstring literals
- if ( $INC{'version/vpp.pm'} || $INC{'ExtUtils/MakeMaker/version/vpp.pm'} ) {
- my $magic = _find_magic_vstring( $version );
- $version = $magic if length $magic;
- }
- # pad to 3 characters if before 5.8.1 and appears to be a v-string
- if ( $] < 5.008001 && $version !~ /\A[0-9]/ && substr($version,0,1) ne 'v' && length($version) < 3 ) {
- $version .= "\0" x (3 - length($version));
- }
- eval {
- local $SIG{__WARN__} = sub { die "Invalid version: $_[0]" };
- # avoid specific segfault on some older version.pm versions
- die "Invalid version: $version" if $version eq 'version';
- $vobj = version->new($version);
- };
- if ( my $err = $@ ) {
- my $hook = $self->{bad_version_hook};
- $vobj = eval { $hook->($version, $module) }
- if ref $hook eq 'CODE';
- unless (eval { $vobj->isa("version") }) {
- $err =~ s{ at .* line \d+.*$}{};
- die "Can't convert '$version': $err";
- }
- }
- }
-
- # ensure no leading '.'
- if ( $vobj =~ m{\A\.} ) {
- $vobj = version->new("0$vobj");
- }
-
- # ensure normal v-string form
- if ( _is_qv($vobj) ) {
- $vobj = version->new($vobj->normal);
- }
-
- return $vobj;
-}
-
-#pod =method add_minimum
-#pod
-#pod $req->add_minimum( $module => $version );
-#pod
-#pod This adds a new minimum version requirement. If the new requirement is
-#pod redundant to the existing specification, this has no effect.
-#pod
-#pod Minimum requirements are inclusive. C<$version> is required, along with any
-#pod greater version number.
-#pod
-#pod This method returns the requirements object.
-#pod
-#pod =method add_maximum
-#pod
-#pod $req->add_maximum( $module => $version );
-#pod
-#pod This adds a new maximum version requirement. If the new requirement is
-#pod redundant to the existing specification, this has no effect.
-#pod
-#pod Maximum requirements are inclusive. No version strictly greater than the given
-#pod version is allowed.
-#pod
-#pod This method returns the requirements object.
-#pod
-#pod =method add_exclusion
-#pod
-#pod $req->add_exclusion( $module => $version );
-#pod
-#pod This adds a new excluded version. For example, you might use these three
-#pod method calls:
-#pod
-#pod $req->add_minimum( $module => '1.00' );
-#pod $req->add_maximum( $module => '1.82' );
-#pod
-#pod $req->add_exclusion( $module => '1.75' );
-#pod
-#pod Any version between 1.00 and 1.82 inclusive would be acceptable, except for
-#pod 1.75.
-#pod
-#pod This method returns the requirements object.
-#pod
-#pod =method exact_version
-#pod
-#pod $req->exact_version( $module => $version );
-#pod
-#pod This sets the version required for the given module to I<exactly> the given
-#pod version. No other version would be considered acceptable.
-#pod
-#pod This method returns the requirements object.
-#pod
-#pod =cut
-
-BEGIN {
- for my $type (qw(maximum exclusion exact_version)) {
- my $method = "with_$type";
- my $to_add = $type eq 'exact_version' ? $type : "add_$type";
-
- my $code = sub {
- my ($self, $name, $version) = @_;
-
- $version = $self->_version_object( $name, $version );
-
- $self->__modify_entry_for($name, $method, $version);
-
- return $self;
- };
-
- no strict 'refs';
- *$to_add = $code;
- }
-}
-
-# add_minimum is optimized compared to generated subs above because
-# it is called frequently and with "0" or equivalent input
-sub add_minimum {
- my ($self, $name, $version) = @_;
-
- # stringify $version so that version->new("0.00")->stringify ne "0"
- # which preserves the user's choice of "0.00" as the requirement
- if (not defined $version or "$version" eq '0') {
- return $self if $self->__entry_for($name);
- Carp::confess("can't add new requirements to finalized requirements")
- if $self->is_finalized;
-
- $self->{requirements}{ $name } =
- CPAN::Meta::Requirements::_Range::Range->with_minimum($V0, $name);
- }
- else {
- $version = $self->_version_object( $name, $version );
-
- $self->__modify_entry_for($name, 'with_minimum', $version);
- }
- return $self;
-}
-
-#pod =method add_requirements
-#pod
-#pod $req->add_requirements( $another_req_object );
-#pod
-#pod This method adds all the requirements in the given CPAN::Meta::Requirements
-#pod object to the requirements object on which it was called. If there are any
-#pod conflicts, an exception is thrown.
-#pod
-#pod This method returns the requirements object.
-#pod
-#pod =cut
-
-sub add_requirements {
- my ($self, $req) = @_;
-
- for my $module ($req->required_modules) {
- my $modifiers = $req->__entry_for($module)->as_modifiers;
- for my $modifier (@$modifiers) {
- my ($method, @args) = @$modifier;
- $self->$method($module => @args);
- };
- }
-
- return $self;
-}
-
-#pod =method accepts_module
-#pod
-#pod my $bool = $req->accepts_module($module => $version);
-#pod
-#pod Given an module and version, this method returns true if the version
-#pod specification for the module accepts the provided version. In other words,
-#pod given:
-#pod
-#pod Module => '>= 1.00, < 2.00'
-#pod
-#pod We will accept 1.00 and 1.75 but not 0.50 or 2.00.
-#pod
-#pod For modules that do not appear in the requirements, this method will return
-#pod true.
-#pod
-#pod =cut
-
-sub accepts_module {
- my ($self, $module, $version) = @_;
-
- $version = $self->_version_object( $module, $version );
-
- return 1 unless my $range = $self->__entry_for($module);
- return $range->_accepts($version);
-}
-
-#pod =method clear_requirement
-#pod
-#pod $req->clear_requirement( $module );
-#pod
-#pod This removes the requirement for a given module from the object.
-#pod
-#pod This method returns the requirements object.
-#pod
-#pod =cut
-
-sub clear_requirement {
- my ($self, $module) = @_;
-
- return $self unless $self->__entry_for($module);
-
- Carp::confess("can't clear requirements on finalized requirements")
- if $self->is_finalized;
-
- delete $self->{requirements}{ $module };
-
- return $self;
-}
-
-#pod =method requirements_for_module
-#pod
-#pod $req->requirements_for_module( $module );
-#pod
-#pod This returns a string containing the version requirements for a given module in
-#pod the format described in L<CPAN::Meta::Spec> or undef if the given module has no
-#pod requirements. This should only be used for informational purposes such as error
-#pod messages and should not be interpreted or used for comparison (see
-#pod L</accepts_module> instead).
-#pod
-#pod =cut
-
-sub requirements_for_module {
- my ($self, $module) = @_;
- my $entry = $self->__entry_for($module);
- return unless $entry;
- return $entry->as_string;
-}
-
-#pod =method structured_requirements_for_module
-#pod
-#pod $req->structured_requirements_for_module( $module );
-#pod
-#pod This returns a data structure containing the version requirements for a given
-#pod module or undef if the given module has no requirements. This should
-#pod not be used for version checks (see L</accepts_module> instead).
-#pod
-#pod Added in version 2.134.
-#pod
-#pod =cut
-
-sub structured_requirements_for_module {
- my ($self, $module) = @_;
- my $entry = $self->__entry_for($module);
- return unless $entry;
- return $entry->as_struct;
-}
-
-#pod =method required_modules
-#pod
-#pod This method returns a list of all the modules for which requirements have been
-#pod specified.
-#pod
-#pod =cut
-
-sub required_modules { keys %{ $_[0]{requirements} } }
-
-#pod =method clone
-#pod
-#pod $req->clone;
-#pod
-#pod This method returns a clone of the invocant. The clone and the original object
-#pod can then be changed independent of one another.
-#pod
-#pod =cut
-
-sub clone {
- my ($self) = @_;
- my $new = (ref $self)->new;
-
- return $new->add_requirements($self);
-}
-
-sub __entry_for { $_[0]{requirements}{ $_[1] } }
-
-sub __modify_entry_for {
- my ($self, $name, $method, $version) = @_;
-
- my $fin = $self->is_finalized;
- my $old = $self->__entry_for($name);
-
- Carp::confess("can't add new requirements to finalized requirements")
- if $fin and not $old;
-
- my $new = ($old || 'CPAN::Meta::Requirements::_Range::Range')
- ->$method($version, $name);
-
- Carp::confess("can't modify finalized requirements")
- if $fin and $old->as_string ne $new->as_string;
-
- $self->{requirements}{ $name } = $new;
-}
-
-#pod =method is_simple
-#pod
-#pod This method returns true if and only if all requirements are inclusive minimums
-#pod -- that is, if their string expression is just the version number.
-#pod
-#pod =cut
-
-sub is_simple {
- my ($self) = @_;
- for my $module ($self->required_modules) {
- # XXX: This is a complete hack, but also entirely correct.
- return if $self->__entry_for($module)->as_string =~ /\s/;
- }
-
- return 1;
-}
-
-#pod =method is_finalized
-#pod
-#pod This method returns true if the requirements have been finalized by having the
-#pod C<finalize> method called on them.
-#pod
-#pod =cut
-
-sub is_finalized { $_[0]{finalized} }
-
-#pod =method finalize
-#pod
-#pod This method marks the requirements finalized. Subsequent attempts to change
-#pod the requirements will be fatal, I<if> they would result in a change. If they
-#pod would not alter the requirements, they have no effect.
-#pod
-#pod If a finalized set of requirements is cloned, the cloned requirements are not
-#pod also finalized.
-#pod
-#pod =cut
-
-sub finalize { $_[0]{finalized} = 1 }
-
-#pod =method as_string_hash
-#pod
-#pod This returns a reference to a hash describing the requirements using the
-#pod strings in the L<CPAN::Meta::Spec> specification.
-#pod
-#pod For example after the following program:
-#pod
-#pod my $req = CPAN::Meta::Requirements->new;
-#pod
-#pod $req->add_minimum('CPAN::Meta::Requirements' => 0.102);
-#pod
-#pod $req->add_minimum('Library::Foo' => 1.208);
-#pod
-#pod $req->add_maximum('Library::Foo' => 2.602);
-#pod
-#pod $req->add_minimum('Module::Bar' => 'v1.2.3');
-#pod
-#pod $req->add_exclusion('Module::Bar' => 'v1.2.8');
-#pod
-#pod $req->exact_version('Xyzzy' => '6.01');
-#pod
-#pod my $hashref = $req->as_string_hash;
-#pod
-#pod C<$hashref> would contain:
-#pod
-#pod {
-#pod 'CPAN::Meta::Requirements' => '0.102',
-#pod 'Library::Foo' => '>= 1.208, <= 2.206',
-#pod 'Module::Bar' => '>= v1.2.3, != v1.2.8',
-#pod 'Xyzzy' => '== 6.01',
-#pod }
-#pod
-#pod =cut
-
-sub as_string_hash {
- my ($self) = @_;
-
- my %hash = map {; $_ => $self->{requirements}{$_}->as_string }
- $self->required_modules;
-
- return \%hash;
-}
-
-#pod =method add_string_requirement
-#pod
-#pod $req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206');
-#pod $req->add_string_requirement('Library::Foo' => v1.208);
-#pod
-#pod This method parses the passed in string and adds the appropriate requirement
-#pod for the given module. A version can be a Perl "v-string". It understands
-#pod version ranges as described in the L<CPAN::Meta::Spec/Version Ranges>. For
-#pod example:
-#pod
-#pod =over 4
-#pod
-#pod =item 1.3
-#pod
-#pod =item >= 1.3
-#pod
-#pod =item <= 1.3
-#pod
-#pod =item == 1.3
-#pod
-#pod =item != 1.3
-#pod
-#pod =item > 1.3
-#pod
-#pod =item < 1.3
-#pod
-#pod =item >= 1.3, != 1.5, <= 2.0
-#pod
-#pod A version number without an operator is equivalent to specifying a minimum
-#pod (C<E<gt>=>). Extra whitespace is allowed.
-#pod
-#pod =back
-#pod
-#pod =cut
-
-my %methods_for_op = (
- '==' => [ qw(exact_version) ],
- '!=' => [ qw(add_exclusion) ],
- '>=' => [ qw(add_minimum) ],
- '<=' => [ qw(add_maximum) ],
- '>' => [ qw(add_minimum add_exclusion) ],
- '<' => [ qw(add_maximum add_exclusion) ],
-);
-
-sub add_string_requirement {
- my ($self, $module, $req) = @_;
-
- unless ( defined $req && length $req ) {
- $req = 0;
- $self->_blank_carp($module);
- }
-
- my $magic = _find_magic_vstring( $req );
- if (length $magic) {
- $self->add_minimum($module => $magic);
- return;
- }
-
- my @parts = split qr{\s*,\s*}, $req;
-
- for my $part (@parts) {
- my ($op, $ver) = $part =~ m{\A\s*(==|>=|>|<=|<|!=)\s*(.*)\z};
-
- if (! defined $op) {
- $self->add_minimum($module => $part);
- } else {
- Carp::confess("illegal requirement string: $req")
- unless my $methods = $methods_for_op{ $op };
-
- $self->$_($module => $ver) for @$methods;
- }
- }
-}
-
-#pod =method from_string_hash
-#pod
-#pod my $req = CPAN::Meta::Requirements->from_string_hash( \%hash );
-#pod my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts );
-#pod
-#pod This is an alternate constructor for a CPAN::Meta::Requirements
-#pod object. It takes a hash of module names and version requirement
-#pod strings and returns a new CPAN::Meta::Requirements object. As with
-#pod add_string_requirement, a version can be a Perl "v-string". Optionally,
-#pod you can supply a hash-reference of options, exactly as with the L</new>
-#pod method.
-#pod
-#pod =cut
-
-sub _blank_carp {
- my ($self, $module) = @_;
- Carp::carp("Undefined requirement for $module treated as '0'");
-}
-
-sub from_string_hash {
- my ($class, $hash, $options) = @_;
-
- my $self = $class->new($options);
-
- for my $module (keys %$hash) {
- my $req = $hash->{$module};
- unless ( defined $req && length $req ) {
- $req = 0;
- $class->_blank_carp($module);
- }
- $self->add_string_requirement($module, $req);
- }
-
- return $self;
-}
-
-##############################################################
-
-{
- package
- CPAN::Meta::Requirements::_Range::Exact;
- sub _new { bless { version => $_[1] } => $_[0] }
-
- sub _accepts { return $_[0]{version} == $_[1] }
-
- sub as_string { return "== $_[0]{version}" }
-
- sub as_struct { return [ [ '==', "$_[0]{version}" ] ] }
-
- sub as_modifiers { return [ [ exact_version => $_[0]{version} ] ] }
-
- sub _reject_requirements {
- my ($self, $module, $error) = @_;
- Carp::confess("illegal requirements for $module: $error")
- }
-
- sub _clone {
- (ref $_[0])->_new( version->new( $_[0]{version} ) )
- }
-
- sub with_exact_version {
- my ($self, $version, $module) = @_;
- $module = 'module' unless defined $module;
-
- return $self->_clone if $self->_accepts($version);
-
- $self->_reject_requirements(
- $module,
- "can't be exactly $version when exact requirement is already $self->{version}",
- );
- }
-
- sub with_minimum {
- my ($self, $minimum, $module) = @_;
- $module = 'module' unless defined $module;
-
- return $self->_clone if $self->{version} >= $minimum;
- $self->_reject_requirements(
- $module,
- "minimum $minimum exceeds exact specification $self->{version}",
- );
- }
-
- sub with_maximum {
- my ($self, $maximum, $module) = @_;
- $module = 'module' unless defined $module;
-
- return $self->_clone if $self->{version} <= $maximum;
- $self->_reject_requirements(
- $module,
- "maximum $maximum below exact specification $self->{version}",
- );
- }
-
- sub with_exclusion {
- my ($self, $exclusion, $module) = @_;
- $module = 'module' unless defined $module;
-
- return $self->_clone unless $exclusion == $self->{version};
- $self->_reject_requirements(
- $module,
- "tried to exclude $exclusion, which is already exactly specified",
- );
- }
-}
-
-##############################################################
-
-{
- package
- CPAN::Meta::Requirements::_Range::Range;
-
- sub _self { ref($_[0]) ? $_[0] : (bless { } => $_[0]) }
-
- sub _clone {
- return (bless { } => $_[0]) unless ref $_[0];
-
- my ($s) = @_;
- my %guts = (
- (exists $s->{minimum} ? (minimum => version->new($s->{minimum})) : ()),
- (exists $s->{maximum} ? (maximum => version->new($s->{maximum})) : ()),
-
- (exists $s->{exclusions}
- ? (exclusions => [ map { version->new($_) } @{ $s->{exclusions} } ])
- : ()),
- );
-
- bless \%guts => ref($s);
- }
-
- sub as_modifiers {
- my ($self) = @_;
- my @mods;
- push @mods, [ add_minimum => $self->{minimum} ] if exists $self->{minimum};
- push @mods, [ add_maximum => $self->{maximum} ] if exists $self->{maximum};
- push @mods, map {; [ add_exclusion => $_ ] } @{$self->{exclusions} || []};
- return \@mods;
- }
-
- sub as_struct {
- my ($self) = @_;
-
- return 0 if ! keys %$self;
-
- my @exclusions = @{ $self->{exclusions} || [] };
-
- my @parts;
-
- for my $tuple (
- [ qw( >= > minimum ) ],
- [ qw( <= < maximum ) ],
- ) {
- my ($op, $e_op, $k) = @$tuple;
- if (exists $self->{$k}) {
- my @new_exclusions = grep { $_ != $self->{ $k } } @exclusions;
- if (@new_exclusions == @exclusions) {
- push @parts, [ $op, "$self->{ $k }" ];
- } else {
- push @parts, [ $e_op, "$self->{ $k }" ];
- @exclusions = @new_exclusions;
- }
- }
- }
-
- push @parts, map {; [ "!=", "$_" ] } @exclusions;
-
- return \@parts;
- }
-
- sub as_string {
- my ($self) = @_;
-
- my @parts = @{ $self->as_struct };
-
- return $parts[0][1] if @parts == 1 and $parts[0][0] eq '>=';
-
- return join q{, }, map {; join q{ }, @$_ } @parts;
- }
-
- sub _reject_requirements {
- my ($self, $module, $error) = @_;
- Carp::confess("illegal requirements for $module: $error")
- }
-
- sub with_exact_version {
- my ($self, $version, $module) = @_;
- $module = 'module' unless defined $module;
- $self = $self->_clone;
-
- unless ($self->_accepts($version)) {
- $self->_reject_requirements(
- $module,
- "exact specification $version outside of range " . $self->as_string
- );
- }
-
- return CPAN::Meta::Requirements::_Range::Exact->_new($version);
- }
-
- sub _simplify {
- my ($self, $module) = @_;
-
- if (defined $self->{minimum} and defined $self->{maximum}) {
- if ($self->{minimum} == $self->{maximum}) {
- if (grep { $_ == $self->{minimum} } @{ $self->{exclusions} || [] }) {
- $self->_reject_requirements(
- $module,
- "minimum and maximum are both $self->{minimum}, which is excluded",
- );
- }
-
- return CPAN::Meta::Requirements::_Range::Exact->_new($self->{minimum})
- }
-
- if ($self->{minimum} > $self->{maximum}) {
- $self->_reject_requirements(
- $module,
- "minimum $self->{minimum} exceeds maximum $self->{maximum}",
- );
- }
- }
-
- # eliminate irrelevant exclusions
- if ($self->{exclusions}) {
- my %seen;
- @{ $self->{exclusions} } = grep {
- (! defined $self->{minimum} or $_ >= $self->{minimum})
- and
- (! defined $self->{maximum} or $_ <= $self->{maximum})
- and
- ! $seen{$_}++
- } @{ $self->{exclusions} };
- }
-
- return $self;
- }
-
- sub with_minimum {
- my ($self, $minimum, $module) = @_;
- $module = 'module' unless defined $module;
- $self = $self->_clone;
-
- if (defined (my $old_min = $self->{minimum})) {
- $self->{minimum} = (sort { $b cmp $a } ($minimum, $old_min))[0];
- } else {
- $self->{minimum} = $minimum;
- }
-
- return $self->_simplify($module);
- }
-
- sub with_maximum {
- my ($self, $maximum, $module) = @_;
- $module = 'module' unless defined $module;
- $self = $self->_clone;
-
- if (defined (my $old_max = $self->{maximum})) {
- $self->{maximum} = (sort { $a cmp $b } ($maximum, $old_max))[0];
- } else {
- $self->{maximum} = $maximum;
- }
-
- return $self->_simplify($module);
- }
-
- sub with_exclusion {
- my ($self, $exclusion, $module) = @_;
- $module = 'module' unless defined $module;
- $self = $self->_clone;
-
- push @{ $self->{exclusions} ||= [] }, $exclusion;
-
- return $self->_simplify($module);
- }
-
- sub _accepts {
- my ($self, $version) = @_;
-
- return if defined $self->{minimum} and $version < $self->{minimum};
- return if defined $self->{maximum} and $version > $self->{maximum};
- return if defined $self->{exclusions}
- and grep { $version == $_ } @{ $self->{exclusions} };
-
- return 1;
- }
-}
-
-1;
-# vim: ts=2 sts=2 sw=2 et:
-
-__END__
-
-=pod
-
-=encoding UTF-8
-
-=head1 NAME
-
-CPAN::Meta::Requirements - a set of version requirements for a CPAN dist
-
-=head1 VERSION
-
-version 2.140
-
-=head1 SYNOPSIS
-
- use CPAN::Meta::Requirements;
-
- my $build_requires = CPAN::Meta::Requirements->new;
-
- $build_requires->add_minimum('Library::Foo' => 1.208);
-
- $build_requires->add_minimum('Library::Foo' => 2.602);
-
- $build_requires->add_minimum('Module::Bar' => 'v1.2.3');
-
- $METAyml->{build_requires} = $build_requires->as_string_hash;
-
-=head1 DESCRIPTION
-
-A CPAN::Meta::Requirements object models a set of version constraints like
-those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
-and as defined by L<CPAN::Meta::Spec>;
-It can be built up by adding more and more constraints, and it will reduce them
-to the simplest representation.
-
-Logically impossible constraints will be identified immediately by thrown
-exceptions.
-
-=head1 METHODS
-
-=head2 new
-
- my $req = CPAN::Meta::Requirements->new;
-
-This returns a new CPAN::Meta::Requirements object. It takes an optional
-hash reference argument. Currently, only one key is supported:
-
-=over 4
-
-=item *
-
-C<bad_version_hook> -- if provided, when a version cannot be parsed into a version object, this code reference will be called with the invalid version string as first argument, and the module name as second argument. It must return a valid version object.
-
-=back
-
-All other keys are ignored.
-
-=head2 add_minimum
-
- $req->add_minimum( $module => $version );
-
-This adds a new minimum version requirement. If the new requirement is
-redundant to the existing specification, this has no effect.
-
-Minimum requirements are inclusive. C<$version> is required, along with any
-greater version number.
-
-This method returns the requirements object.
-
-=head2 add_maximum
-
- $req->add_maximum( $module => $version );
-
-This adds a new maximum version requirement. If the new requirement is
-redundant to the existing specification, this has no effect.
-
-Maximum requirements are inclusive. No version strictly greater than the given
-version is allowed.
-
-This method returns the requirements object.
-
-=head2 add_exclusion
-
- $req->add_exclusion( $module => $version );
-
-This adds a new excluded version. For example, you might use these three
-method calls:
-
- $req->add_minimum( $module => '1.00' );
- $req->add_maximum( $module => '1.82' );
-
- $req->add_exclusion( $module => '1.75' );
-
-Any version between 1.00 and 1.82 inclusive would be acceptable, except for
-1.75.
-
-This method returns the requirements object.
-
-=head2 exact_version
-
- $req->exact_version( $module => $version );
-
-This sets the version required for the given module to I<exactly> the given
-version. No other version would be considered acceptable.
-
-This method returns the requirements object.
-
-=head2 add_requirements
-
- $req->add_requirements( $another_req_object );
-
-This method adds all the requirements in the given CPAN::Meta::Requirements
-object to the requirements object on which it was called. If there are any
-conflicts, an exception is thrown.
-
-This method returns the requirements object.
-
-=head2 accepts_module
-
- my $bool = $req->accepts_module($module => $version);
-
-Given an module and version, this method returns true if the version
-specification for the module accepts the provided version. In other words,
-given:
-
- Module => '>= 1.00, < 2.00'
-
-We will accept 1.00 and 1.75 but not 0.50 or 2.00.
-
-For modules that do not appear in the requirements, this method will return
-true.
-
-=head2 clear_requirement
-
- $req->clear_requirement( $module );
-
-This removes the requirement for a given module from the object.
-
-This method returns the requirements object.
-
-=head2 requirements_for_module
-
- $req->requirements_for_module( $module );
-
-This returns a string containing the version requirements for a given module in
-the format described in L<CPAN::Meta::Spec> or undef if the given module has no
-requirements. This should only be used for informational purposes such as error
-messages and should not be interpreted or used for comparison (see
-L</accepts_module> instead).
-
-=head2 structured_requirements_for_module
-
- $req->structured_requirements_for_module( $module );
-
-This returns a data structure containing the version requirements for a given
-module or undef if the given module has no requirements. This should
-not be used for version checks (see L</accepts_module> instead).
-
-Added in version 2.134.
-
-=head2 required_modules
-
-This method returns a list of all the modules for which requirements have been
-specified.
-
-=head2 clone
-
- $req->clone;
-
-This method returns a clone of the invocant. The clone and the original object
-can then be changed independent of one another.
-
-=head2 is_simple
-
-This method returns true if and only if all requirements are inclusive minimums
--- that is, if their string expression is just the version number.
-
-=head2 is_finalized
-
-This method returns true if the requirements have been finalized by having the
-C<finalize> method called on them.
-
-=head2 finalize
-
-This method marks the requirements finalized. Subsequent attempts to change
-the requirements will be fatal, I<if> they would result in a change. If they
-would not alter the requirements, they have no effect.
-
-If a finalized set of requirements is cloned, the cloned requirements are not
-also finalized.
-
-=head2 as_string_hash
-
-This returns a reference to a hash describing the requirements using the
-strings in the L<CPAN::Meta::Spec> specification.
-
-For example after the following program:
-
- my $req = CPAN::Meta::Requirements->new;
-
- $req->add_minimum('CPAN::Meta::Requirements' => 0.102);
-
- $req->add_minimum('Library::Foo' => 1.208);
-
- $req->add_maximum('Library::Foo' => 2.602);
-
- $req->add_minimum('Module::Bar' => 'v1.2.3');
-
- $req->add_exclusion('Module::Bar' => 'v1.2.8');
-
- $req->exact_version('Xyzzy' => '6.01');
-
- my $hashref = $req->as_string_hash;
-
-C<$hashref> would contain:
-
- {
- 'CPAN::Meta::Requirements' => '0.102',
- 'Library::Foo' => '>= 1.208, <= 2.206',
- 'Module::Bar' => '>= v1.2.3, != v1.2.8',
- 'Xyzzy' => '== 6.01',
- }
-
-=head2 add_string_requirement
-
- $req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206');
- $req->add_string_requirement('Library::Foo' => v1.208);
-
-This method parses the passed in string and adds the appropriate requirement
-for the given module. A version can be a Perl "v-string". It understands
-version ranges as described in the L<CPAN::Meta::Spec/Version Ranges>. For
-example:
-
-=over 4
-
-=item 1.3
-
-=item >= 1.3
-
-=item <= 1.3
-
-=item == 1.3
-
-=item != 1.3
-
-=item > 1.3
-
-=item < 1.3
-
-=item >= 1.3, != 1.5, <= 2.0
-
-A version number without an operator is equivalent to specifying a minimum
-(C<E<gt>=>). Extra whitespace is allowed.
-
-=back
-
-=head2 from_string_hash
-
- my $req = CPAN::Meta::Requirements->from_string_hash( \%hash );
- my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts );
-
-This is an alternate constructor for a CPAN::Meta::Requirements
-object. It takes a hash of module names and version requirement
-strings and returns a new CPAN::Meta::Requirements object. As with
-add_string_requirement, a version can be a Perl "v-string". Optionally,
-you can supply a hash-reference of options, exactly as with the L</new>
-method.
-
-=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
-
-=head1 SUPPORT
-
-=head2 Bugs / Feature Requests
-
-Please report any bugs or feature requests through the issue tracker
-at L<https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements/issues>.
-You will be notified automatically of any progress on your issue.
-
-=head2 Source Code
-
-This is open source software. The code repository is available for
-public review and contribution under the terms of the license.
-
-L<https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements>
-
- git clone https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements.git
-
-=head1 AUTHORS
-
-=over 4
-
-=item *
-
-David Golden <dagolden@cpan.org>
-
-=item *
-
-Ricardo Signes <rjbs@cpan.org>
-
-=back
-
-=head1 CONTRIBUTORS
-
-=for stopwords Ed J Karen Etheridge Leon Timmermans robario
-
-=over 4
-
-=item *
-
-Ed J <mohawk2@users.noreply.github.com>
-
-=item *
-
-Karen Etheridge <ether@cpan.org>
-
-=item *
-
-Leon Timmermans <fawaka@gmail.com>
-
-=item *
-
-robario <webmaster@robario.com>
-
-=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
+++ /dev/null
-# XXX RULES FOR PATCHING THIS FILE XXX
-# Patches that fix typos or formatting are acceptable. Patches
-# that change semantics are not acceptable without prior approval
-# by David Golden or Ricardo Signes.
-
-use 5.006;
-use strict;
-use warnings;
-package CPAN::Meta::Spec;
-
-our $VERSION = '2.150005';
-
-1;
-
-# ABSTRACT: specification for CPAN distribution metadata
-
-
-# vi:tw=72
-
-__END__
-
-=pod
-
-=encoding UTF-8
-
-=head1 NAME
-
-CPAN::Meta::Spec - specification for CPAN distribution metadata
-
-=head1 VERSION
-
-version 2.150005
-
-=head1 SYNOPSIS
-
- my $distmeta = {
- name => 'Module-Build',
- abstract => 'Build and install Perl modules',
- description => "Module::Build is a system for "
- . "building, testing, and installing Perl modules. "
- . "It is meant to ... blah blah blah ...",
- version => '0.36',
- release_status => 'stable',
- author => [
- 'Ken Williams <kwilliams@cpan.org>',
- 'Module-Build List <module-build@perl.org>', # additional contact
- ],
- license => [ 'perl_5' ],
- prereqs => {
- runtime => {
- requires => {
- 'perl' => '5.006',
- 'ExtUtils::Install' => '0',
- 'File::Basename' => '0',
- 'File::Compare' => '0',
- 'IO::File' => '0',
- },
- recommends => {
- 'Archive::Tar' => '1.00',
- 'ExtUtils::Install' => '0.3',
- 'ExtUtils::ParseXS' => '2.02',
- },
- },
- build => {
- requires => {
- 'Test::More' => '0',
- },
- }
- },
- resources => {
- license => ['http://dev.perl.org/licenses/'],
- },
- optional_features => {
- domination => {
- description => 'Take over the world',
- prereqs => {
- develop => { requires => { 'Genius::Evil' => '1.234' } },
- runtime => { requires => { 'Machine::Weather' => '2.0' } },
- },
- },
- },
- dynamic_config => 1,
- keywords => [ qw/ toolchain cpan dual-life / ],
- 'meta-spec' => {
- version => '2',
- url => 'https://metacpan.org/pod/CPAN::Meta::Spec',
- },
- generated_by => 'Module::Build version 0.36',
- };
-
-=head1 DESCRIPTION
-
-This document describes version 2 of the CPAN distribution metadata
-specification, also known as the "CPAN Meta Spec".
-
-Revisions of this specification for typo corrections and prose
-clarifications may be issued as CPAN::Meta::Spec 2.I<x>. These
-revisions will never change semantics or add or remove specified
-behavior.
-
-Distribution metadata describe important properties of Perl
-distributions. Distribution building tools like Module::Build,
-Module::Install, ExtUtils::MakeMaker or Dist::Zilla should create a
-metadata file in accordance with this specification and include it with
-the distribution for use by automated tools that index, examine, package
-or install Perl distributions.
-
-=head1 TERMINOLOGY
-
-=over 4
-
-=item distribution
-
-This is the primary object described by the metadata. In the context of
-this document it usually refers to a collection of modules, scripts,
-and/or documents that are distributed together for other developers to
-use. Examples of distributions are C<Class-Container>, C<libwww-perl>,
-or C<DBI>.
-
-=item module
-
-This refers to a reusable library of code contained in a single file.
-Modules usually contain one or more packages and are often referred
-to by the name of a primary package that can be mapped to the file
-name. For example, one might refer to C<File::Spec> instead of
-F<File/Spec.pm>
-
-=item package
-
-This refers to a namespace declared with the Perl C<package> statement.
-In Perl, packages often have a version number property given by the
-C<$VERSION> variable in the namespace.
-
-=item consumer
-
-This refers to code that reads a metadata file, deserializes it into a
-data structure in memory, or interprets a data structure of metadata
-elements.
-
-=item producer
-
-This refers to code that constructs a metadata data structure,
-serializes into a bytestream and/or writes it to disk.
-
-=item must, should, may, etc.
-
-These terms are interpreted as described in IETF RFC 2119.
-
-=back
-
-=head1 DATA TYPES
-
-Fields in the L</STRUCTURE> section describe data elements, each of
-which has an associated data type as described herein. There are four
-primitive types: Boolean, String, List and Map. Other types are
-subtypes of primitives and define compound data structures or define
-constraints on the values of a data element.
-
-=head2 Boolean
-
-A I<Boolean> is used to provide a true or false value. It B<must> be
-represented as a defined value.
-
-=head2 String
-
-A I<String> is data element containing a non-zero length sequence of
-Unicode characters, such as an ordinary Perl scalar that is not a
-reference.
-
-=head2 List
-
-A I<List> is an ordered collection of zero or more data elements.
-Elements of a List may be of mixed types.
-
-Producers B<must> represent List elements using a data structure which
-unambiguously indicates that multiple values are possible, such as a
-reference to a Perl array (an "arrayref").
-
-Consumers expecting a List B<must> consider a String as equivalent to a
-List of length 1.
-
-=head2 Map
-
-A I<Map> is an unordered collection of zero or more data elements
-("values"), indexed by associated String elements ("keys"). The Map's
-value elements may be of mixed types.
-
-=head2 License String
-
-A I<License String> is a subtype of String with a restricted set of
-values. Valid values are described in detail in the description of
-the L</license> field.
-
-=head2 URL
-
-I<URL> is a subtype of String containing a Uniform Resource Locator or
-Identifier. [ This type is called URL and not URI for historical reasons. ]
-
-=head2 Version
-
-A I<Version> is a subtype of String containing a value that describes
-the version number of packages or distributions. Restrictions on format
-are described in detail in the L</Version Formats> section.
-
-=head2 Version Range
-
-The I<Version Range> type is a subtype of String. It describes a range
-of Versions that may be present or installed to fulfill prerequisites.
-It is specified in detail in the L</Version Ranges> section.
-
-=head1 STRUCTURE
-
-The metadata structure is a data element of type Map. This section
-describes valid keys within the Map.
-
-Any keys not described in this specification document (whether top-level
-or within compound data structures described herein) are considered
-I<custom keys> and B<must> begin with an "x" or "X" and be followed by an
-underscore; i.e. they must match the pattern: C<< qr{\Ax_}i >>. If a
-custom key refers to a compound data structure, subkeys within it do not
-need an "x_" or "X_" prefix.
-
-Consumers of metadata may ignore any or all custom keys. All other keys
-not described herein are invalid and should be ignored by consumers.
-Producers must not generate or output invalid keys.
-
-For each key, an example is provided followed by a description. The
-description begins with the version of spec in which the key was added
-or in which the definition was modified, whether the key is I<required>
-or I<optional> and the data type of the corresponding data element.
-These items are in parentheses, brackets and braces, respectively.
-
-If a data type is a Map or Map subtype, valid subkeys will be described
-as well.
-
-Some fields are marked I<Deprecated>. These are shown for historical
-context and must not be produced in or consumed from any metadata structure
-of version 2 or higher.
-
-=head2 REQUIRED FIELDS
-
-=head3 abstract
-
-Example:
-
- abstract => 'Build and install Perl modules'
-
-(Spec 1.2) [required] {String}
-
-This is a short description of the purpose of the distribution.
-
-=head3 author
-
-Example:
-
- author => [ 'Ken Williams <kwilliams@cpan.org>' ]
-
-(Spec 1.2) [required] {List of one or more Strings}
-
-This List indicates the person(s) to contact concerning the
-distribution. The preferred form of the contact string is:
-
- contact-name <email-address>
-
-This field provides a general contact list independent of other
-structured fields provided within the L</resources> field, such as
-C<bugtracker>. The addressee(s) can be contacted for any purpose
-including but not limited to (security) problems with the distribution,
-questions about the distribution or bugs in the distribution.
-
-A distribution's original author is usually the contact listed within
-this field. Co-maintainers, successor maintainers or mailing lists
-devoted to the distribution may also be listed in addition to or instead
-of the original author.
-
-=head3 dynamic_config
-
-Example:
-
- dynamic_config => 1
-
-(Spec 2) [required] {Boolean}
-
-A boolean flag indicating whether a F<Build.PL> or F<Makefile.PL> (or
-similar) must be executed to determine prerequisites.
-
-This field should be set to a true value if the distribution performs
-some dynamic configuration (asking questions, sensing the environment,
-etc.) as part of its configuration. This field should be set to a false
-value to indicate that prerequisites included in metadata may be
-considered final and valid for static analysis.
-
-Note: when this field is true, post-configuration prerequisites are not
-guaranteed to bear any relation whatsoever to those stated in the metadata,
-and relying on them doing so is an error. See also
-L</Prerequisites for dynamically configured distributions> in the implementors'
-notes.
-
-This field explicitly B<does not> indicate whether installation may be
-safely performed without using a Makefile or Build file, as there may be
-special files to install or custom installation targets (e.g. for
-dual-life modules that exist on CPAN as well as in the Perl core). This
-field only defines whether or not prerequisites are exactly as given in the
-metadata.
-
-=head3 generated_by
-
-Example:
-
- generated_by => 'Module::Build version 0.36'
-
-(Spec 1.0) [required] {String}
-
-This field indicates the tool that was used to create this metadata.
-There are no defined semantics for this field, but it is traditional to
-use a string in the form "Generating::Package version 1.23" or the
-author's name, if the file was generated by hand.
-
-=head3 license
-
-Example:
-
- license => [ 'perl_5' ]
-
- license => [ 'apache_2_0', 'mozilla_1_0' ]
-
-(Spec 2) [required] {List of one or more License Strings}
-
-One or more licenses that apply to some or all of the files in the
-distribution. If multiple licenses are listed, the distribution
-documentation should be consulted to clarify the interpretation of
-multiple licenses.
-
-The following list of license strings are valid:
-
- string description
- ------------- -----------------------------------------------
- agpl_3 GNU Affero General Public License, Version 3
- apache_1_1 Apache Software License, Version 1.1
- apache_2_0 Apache License, Version 2.0
- artistic_1 Artistic License, (Version 1)
- artistic_2 Artistic License, Version 2.0
- bsd BSD License (three-clause)
- freebsd FreeBSD License (two-clause)
- gfdl_1_2 GNU Free Documentation License, Version 1.2
- gfdl_1_3 GNU Free Documentation License, Version 1.3
- gpl_1 GNU General Public License, Version 1
- gpl_2 GNU General Public License, Version 2
- gpl_3 GNU General Public License, Version 3
- lgpl_2_1 GNU Lesser General Public License, Version 2.1
- lgpl_3_0 GNU Lesser General Public License, Version 3.0
- mit MIT (aka X11) License
- mozilla_1_0 Mozilla Public License, Version 1.0
- mozilla_1_1 Mozilla Public License, Version 1.1
- openssl OpenSSL License
- perl_5 The Perl 5 License (Artistic 1 & GPL 1 or later)
- qpl_1_0 Q Public License, Version 1.0
- ssleay Original SSLeay License
- sun Sun Internet Standards Source License (SISSL)
- zlib zlib License
-
-The following license strings are also valid and indicate other
-licensing not described above:
-
- string description
- ------------- -----------------------------------------------
- open_source Other Open Source Initiative (OSI) approved license
- restricted Requires special permission from copyright holder
- unrestricted Not an OSI approved license, but not restricted
- unknown License not provided in metadata
-
-All other strings are invalid in the license field.
-
-=head3 meta-spec
-
-Example:
-
- 'meta-spec' => {
- version => '2',
- url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
- }
-
-(Spec 1.2) [required] {Map}
-
-This field indicates the version of the CPAN Meta Spec that should be
-used to interpret the metadata. Consumers must check this key as soon
-as possible and abort further metadata processing if the meta-spec
-version is not supported by the consumer.
-
-The following keys are valid, but only C<version> is required.
-
-=over
-
-=item version
-
-This subkey gives the integer I<Version> of the CPAN Meta Spec against
-which the document was generated.
-
-=item url
-
-This is a I<URL> of the metadata specification document corresponding to
-the given version. This is strictly for human-consumption and should
-not impact the interpretation of the document.
-
-For the version 2 spec, either of these are recommended:
-
-=over 4
-
-=item *
-
-C<https://metacpan.org/pod/CPAN::Meta::Spec>
-
-=item *
-
-C<http://search.cpan.org/perldoc?CPAN::Meta::Spec>
-
-=back
-
-=back
-
-=head3 name
-
-Example:
-
- name => 'Module-Build'
-
-(Spec 1.0) [required] {String}
-
-This field is the name of the distribution. This is often created by
-taking the "main package" in the distribution and changing C<::> to
-C<->, but the name may be completely unrelated to the packages within
-the distribution. For example, L<LWP::UserAgent> is distributed as part
-of the distribution name "libwww-perl".
-
-=head3 release_status
-
-Example:
-
- release_status => 'stable'
-
-(Spec 2) [required] {String}
-
-This field provides the release status of this distribution. If the
-C<version> field contains an underscore character, then
-C<release_status> B<must not> be "stable."
-
-The C<release_status> field B<must> have one of the following values:
-
-=over
-
-=item stable
-
-This indicates an ordinary, "final" release that should be indexed by PAUSE
-or other indexers.
-
-=item testing
-
-This indicates a "beta" release that is substantially complete, but has an
-elevated risk of bugs and requires additional testing. The distribution
-should not be installed over a stable release without an explicit request
-or other confirmation from a user. This release status may also be used
-for "release candidate" versions of a distribution.
-
-=item unstable
-
-This indicates an "alpha" release that is under active development, but has
-been released for early feedback or testing and may be missing features or
-may have serious bugs. The distribution should not be installed over a
-stable release without an explicit request or other confirmation from a
-user.
-
-=back
-
-Consumers B<may> use this field to determine how to index the
-distribution for CPAN or other repositories in addition to or in
-replacement of heuristics based on version number or file name.
-
-=head3 version
-
-Example:
-
- version => '0.36'
-
-(Spec 1.0) [required] {Version}
-
-This field gives the version of the distribution to which the metadata
-structure refers.
-
-=head2 OPTIONAL FIELDS
-
-=head3 description
-
-Example:
-
- description => "Module::Build is a system for "
- . "building, testing, and installing Perl modules. "
- . "It is meant to ... blah blah blah ...",
-
-(Spec 2) [optional] {String}
-
-A longer, more complete description of the purpose or intended use of
-the distribution than the one provided by the C<abstract> key.
-
-=head3 keywords
-
-Example:
-
- keywords => [ qw/ toolchain cpan dual-life / ]
-
-(Spec 1.1) [optional] {List of zero or more Strings}
-
-A List of keywords that describe this distribution. Keywords
-B<must not> include whitespace.
-
-=head3 no_index
-
-Example:
-
- no_index => {
- file => [ 'My/Module.pm' ],
- directory => [ 'My/Private' ],
- package => [ 'My::Module::Secret' ],
- namespace => [ 'My::Module::Sample' ],
- }
-
-(Spec 1.2) [optional] {Map}
-
-This Map describes any files, directories, packages, and namespaces that
-are private to the packaging or implementation of the distribution and
-should be ignored by indexing or search tools. Note that this is a list of
-exclusions, and the spec does not define what to I<include> - see
-L</Indexing distributions a la PAUSE> in the implementors notes for more
-information.
-
-Valid subkeys are as follows:
-
-=over
-
-=item file
-
-A I<List> of relative paths to files. Paths B<must be> specified with
-unix conventions.
-
-=item directory
-
-A I<List> of relative paths to directories. Paths B<must be> specified
-with unix conventions.
-
-[ Note: previous editions of the spec had C<dir> instead of C<directory> ]
-
-=item package
-
-A I<List> of package names.
-
-=item namespace
-
-A I<List> of package namespaces, where anything below the namespace
-must be ignored, but I<not> the namespace itself.
-
-In the example above for C<no_index>, C<My::Module::Sample::Foo> would
-be ignored, but C<My::Module::Sample> would not.
-
-=back
-
-=head3 optional_features
-
-Example:
-
- optional_features => {
- sqlite => {
- description => 'Provides SQLite support',
- prereqs => {
- runtime => {
- requires => {
- 'DBD::SQLite' => '1.25'
- }
- }
- }
- }
- }
-
-(Spec 2) [optional] {Map}
-
-This Map describes optional features with incremental prerequisites.
-Each key of the C<optional_features> Map is a String used to identify
-the feature and each value is a Map with additional information about
-the feature. Valid subkeys include:
-
-=over
-
-=item description
-
-This is a String describing the feature. Every optional feature
-should provide a description
-
-=item prereqs
-
-This entry is required and has the same structure as that of the
-C<L</prereqs>> key. It provides a list of package requirements
-that must be satisfied for the feature to be supported or enabled.
-
-There is one crucial restriction: the prereqs of an optional feature
-B<must not> include C<configure> phase prereqs.
-
-=back
-
-Consumers B<must not> include optional features as prerequisites without
-explicit instruction from users (whether via interactive prompting,
-a function parameter or a configuration value, etc. ).
-
-If an optional feature is used by a consumer to add additional
-prerequisites, the consumer should merge the optional feature
-prerequisites into those given by the C<prereqs> key using the same
-semantics. See L</Merging and Resolving Prerequisites> for details on
-merging prerequisites.
-
-I<Suggestion for disuse:> Because there is currently no way for a
-distribution to specify a dependency on an optional feature of another
-dependency, the use of C<optional_feature> is discouraged. Instead,
-create a separate, installable distribution that ensures the desired
-feature is available. For example, if C<Foo::Bar> has a C<Baz> feature,
-release a separate C<Foo-Bar-Baz> distribution that satisfies
-requirements for the feature.
-
-=head3 prereqs
-
-Example:
-
- prereqs => {
- runtime => {
- requires => {
- 'perl' => '5.006',
- 'File::Spec' => '0.86',
- 'JSON' => '2.16',
- },
- recommends => {
- 'JSON::XS' => '2.26',
- },
- suggests => {
- 'Archive::Tar' => '0',
- },
- },
- build => {
- requires => {
- 'Alien::SDL' => '1.00',
- },
- },
- test => {
- recommends => {
- 'Test::Deep' => '0.10',
- },
- }
- }
-
-(Spec 2) [optional] {Map}
-
-This is a Map that describes all the prerequisites of the distribution.
-The keys are phases of activity, such as C<configure>, C<build>, C<test>
-or C<runtime>. Values are Maps in which the keys name the type of
-prerequisite relationship such as C<requires>, C<recommends>, or
-C<suggests> and the value provides a set of prerequisite relations. The
-set of relations B<must> be specified as a Map of package names to
-version ranges.
-
-The full definition for this field is given in the L</Prereq Spec>
-section.
-
-=head3 provides
-
-Example:
-
- provides => {
- 'Foo::Bar' => {
- file => 'lib/Foo/Bar.pm',
- version => '0.27_02',
- },
- 'Foo::Bar::Blah' => {
- file => 'lib/Foo/Bar/Blah.pm',
- },
- 'Foo::Bar::Baz' => {
- file => 'lib/Foo/Bar/Baz.pm',
- version => '0.3',
- },
- }
-
-(Spec 1.2) [optional] {Map}
-
-This describes all packages provided by this distribution. This
-information is used by distribution and automation mechanisms like
-PAUSE, CPAN, metacpan.org and search.cpan.org to build indexes saying in
-which distribution various packages can be found.
-
-The keys of C<provides> are package names that can be found within
-the distribution. If a package name key is provided, it must
-have a Map with the following valid subkeys:
-
-=over
-
-=item file
-
-This field is required. It must contain a Unix-style relative file path
-from the root of the distribution directory to a file that contains or
-generates the package. It may be given as C<META.yml> or C<META.json>
-to claim a package for indexing without needing a C<*.pm>.
-
-=item version
-
-If it exists, this field must contains a I<Version> String for the
-package. If the package does not have a C<$VERSION>, this field must
-be omitted.
-
-=back
-
-=head3 resources
-
-Example:
-
- resources => {
- license => [ 'http://dev.perl.org/licenses/' ],
- homepage => 'http://sourceforge.net/projects/module-build',
- bugtracker => {
- web => 'http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Meta',
- mailto => 'meta-bugs@example.com',
- },
- repository => {
- url => 'git://github.com/dagolden/cpan-meta.git',
- web => 'http://github.com/dagolden/cpan-meta',
- type => 'git',
- },
- x_twitter => 'http://twitter.com/cpan_linked/',
- }
-
-(Spec 2) [optional] {Map}
-
-This field describes resources related to this distribution.
-
-Valid subkeys include:
-
-=over
-
-=item homepage
-
-The official home of this project on the web.
-
-=item license
-
-A List of I<URL>'s that relate to this distribution's license. As with the
-top-level C<license> field, distribution documentation should be consulted
-to clarify the interpretation of multiple licenses provided here.
-
-=item bugtracker
-
-This entry describes the bug tracking system for this distribution. It
-is a Map with the following valid keys:
-
- web - a URL pointing to a web front-end for the bug tracker
- mailto - an email address to which bugs can be sent
-
-=item repository
-
-This entry describes the source control repository for this distribution. It
-is a Map with the following valid keys:
-
- url - a URL pointing to the repository itself
- web - a URL pointing to a web front-end for the repository
- type - a lowercase string indicating the VCS used
-
-Because a url like C<http://myrepo.example.com/> is ambiguous as to
-type, producers should provide a C<type> whenever a C<url> key is given.
-The C<type> field should be the name of the most common program used
-to work with the repository, e.g. C<git>, C<svn>, C<cvs>, C<darcs>,
-C<bzr> or C<hg>.
-
-=back
-
-=head2 DEPRECATED FIELDS
-
-=head3 build_requires
-
-I<(Deprecated in Spec 2)> [optional] {String}
-
-Replaced by C<prereqs>
-
-=head3 configure_requires
-
-I<(Deprecated in Spec 2)> [optional] {String}
-
-Replaced by C<prereqs>
-
-=head3 conflicts
-
-I<(Deprecated in Spec 2)> [optional] {String}
-
-Replaced by C<prereqs>
-
-=head3 distribution_type
-
-I<(Deprecated in Spec 2)> [optional] {String}
-
-This field indicated 'module' or 'script' but was considered
-meaningless, since many distributions are hybrids of several kinds of
-things.
-
-=head3 license_uri
-
-I<(Deprecated in Spec 1.2)> [optional] {URL}
-
-Replaced by C<license> in C<resources>
-
-=head3 private
-
-I<(Deprecated in Spec 1.2)> [optional] {Map}
-
-This field has been renamed to L</"no_index">.
-
-=head3 recommends
-
-I<(Deprecated in Spec 2)> [optional] {String}
-
-Replaced by C<prereqs>
-
-=head3 requires
-
-I<(Deprecated in Spec 2)> [optional] {String}
-
-Replaced by C<prereqs>
-
-=head1 VERSION NUMBERS
-
-=head2 Version Formats
-
-This section defines the Version type, used by several fields in the
-CPAN Meta Spec.
-
-Version numbers must be treated as strings, not numbers. For
-example, C<1.200> B<must not> be serialized as C<1.2>. Version
-comparison should be delegated to the Perl L<version> module, version
-0.80 or newer.
-
-Unless otherwise specified, version numbers B<must> appear in one of two
-formats:
-
-=over
-
-=item Decimal versions
-
-Decimal versions are regular "decimal numbers", with some limitations.
-They B<must> be non-negative and B<must> begin and end with a digit. A
-single underscore B<may> be included, but B<must> be between two digits.
-They B<must not> use exponential notation ("1.23e-2").
-
- version => '1.234' # OK
- version => '1.23_04' # OK
-
- version => '1.23_04_05' # Illegal
- version => '1.' # Illegal
- version => '.1' # Illegal
-
-=item Dotted-integer versions
-
-Dotted-integer (also known as dotted-decimal) versions consist of
-positive integers separated by full stop characters (i.e. "dots",
-"periods" or "decimal points"). This are equivalent in format to Perl
-"v-strings", with some additional restrictions on form. They must be
-given in "normal" form, which has a leading "v" character and at least
-three integer components. To retain a one-to-one mapping with decimal
-versions, all components after the first B<should> be restricted to the
-range 0 to 999. The final component B<may> be separated by an
-underscore character instead of a period.
-
- version => 'v1.2.3' # OK
- version => 'v1.2_3' # OK
- version => 'v1.2.3.4' # OK
- version => 'v1.2.3_4' # OK
- version => 'v2009.10.31' # OK
-
- version => 'v1.2' # Illegal
- version => '1.2.3' # Illegal
- version => 'v1.2_3_4' # Illegal
- version => 'v1.2009.10.31' # Not recommended
-
-=back
-
-=head2 Version Ranges
-
-Some fields (prereq, optional_features) indicate the particular
-version(s) of some other module that may be required as a prerequisite.
-This section details the Version Range type used to provide this
-information.
-
-The simplest format for a Version Range is just the version
-number itself, e.g. C<2.4>. This means that B<at least> version 2.4
-must be present. To indicate that B<any> version of a prerequisite is
-okay, even if the prerequisite doesn't define a version at all, use
-the version C<0>.
-
-Alternatively, a version range B<may> use the operators E<lt> (less than),
-E<lt>= (less than or equal), E<gt> (greater than), E<gt>= (greater than
-or equal), == (equal), and != (not equal). For example, the
-specification C<E<lt> 2.0> means that any version of the prerequisite
-less than 2.0 is suitable.
-
-For more complicated situations, version specifications B<may> be AND-ed
-together using commas. The specification C<E<gt>= 1.2, != 1.5, E<lt>
-2.0> indicates a version that must be B<at least> 1.2, B<less than> 2.0,
-and B<not equal to> 1.5.
-
-=head1 PREREQUISITES
-
-=head2 Prereq Spec
-
-The C<prereqs> key in the top-level metadata and within
-C<optional_features> define the relationship between a distribution and
-other packages. The prereq spec structure is a hierarchical data
-structure which divides prerequisites into I<Phases> of activity in the
-installation process and I<Relationships> that indicate how
-prerequisites should be resolved.
-
-For example, to specify that C<Data::Dumper> is C<required> during the
-C<test> phase, this entry would appear in the distribution metadata:
-
- prereqs => {
- test => {
- requires => {
- 'Data::Dumper' => '2.00'
- }
- }
- }
-
-=head3 Phases
-
-Requirements for regular use must be listed in the C<runtime> phase.
-Other requirements should be listed in the earliest stage in which they
-are required and consumers must accumulate and satisfy requirements
-across phases before executing the activity. For example, C<build>
-requirements must also be available during the C<test> phase.
-
- before action requirements that must be met
- ---------------- --------------------------------
- perl Build.PL configure
- perl Makefile.PL
-
- make configure, runtime, build
- Build
-
- make test configure, runtime, build, test
- Build test
-
-Consumers that install the distribution must ensure that
-I<runtime> requirements are also installed and may install
-dependencies from other phases.
-
- after action requirements that must be met
- ---------------- --------------------------------
- make install runtime
- Build install
-
-=over
-
-=item configure
-
-The configure phase occurs before any dynamic configuration has been
-attempted. Libraries required by the configure phase B<must> be
-available for use before the distribution building tool has been
-executed.
-
-=item build
-
-The build phase is when the distribution's source code is compiled (if
-necessary) and otherwise made ready for installation.
-
-=item test
-
-The test phase is when the distribution's automated test suite is run.
-Any library that is needed only for testing and not for subsequent use
-should be listed here.
-
-=item runtime
-
-The runtime phase refers not only to when the distribution's contents
-are installed, but also to its continued use. Any library that is a
-prerequisite for regular use of this distribution should be indicated
-here.
-
-=item develop
-
-The develop phase's prereqs are libraries needed to work on the
-distribution's source code as its author does. These tools might be
-needed to build a release tarball, to run author-only tests, or to
-perform other tasks related to developing new versions of the
-distribution.
-
-=back
-
-=head3 Relationships
-
-=over
-
-=item requires
-
-These dependencies B<must> be installed for proper completion of the
-phase.
-
-=item recommends
-
-Recommended dependencies are I<strongly> encouraged and should be
-satisfied except in resource constrained environments.
-
-=item suggests
-
-These dependencies are optional, but are suggested for enhanced operation
-of the described distribution.
-
-=item conflicts
-
-These libraries cannot be installed when the phase is in operation.
-This is a very rare situation, and the C<conflicts> relationship should
-be used with great caution, or not at all.
-
-=back
-
-=head2 Merging and Resolving Prerequisites
-
-Whenever metadata consumers merge prerequisites, either from different
-phases or from C<optional_features>, they should merged in a way which
-preserves the intended semantics of the prerequisite structure. Generally,
-this means concatenating the version specifications using commas, as
-described in the L<Version Ranges> section.
-
-Another subtle error that can occur in resolving prerequisites comes from
-the way that modules in prerequisites are indexed to distribution files on
-CPAN. When a module is deleted from a distribution, prerequisites calling
-for that module could indicate an older distribution should be installed,
-potentially overwriting files from a newer distribution.
-
-For example, as of Oct 31, 2009, the CPAN index file contained these
-module-distribution mappings:
-
- Class::MOP 0.94 D/DR/DROLSKY/Class-MOP-0.94.tar.gz
- Class::MOP::Class 0.94 D/DR/DROLSKY/Class-MOP-0.94.tar.gz
- Class::MOP::Class::Immutable 0.04 S/ST/STEVAN/Class-MOP-0.36.tar.gz
-
-Consider the case where "Class::MOP" 0.94 is installed. If a
-distribution specified "Class::MOP::Class::Immutable" as a prerequisite,
-it could result in Class-MOP-0.36.tar.gz being installed, overwriting
-any files from Class-MOP-0.94.tar.gz.
-
-Consumers of metadata B<should> test whether prerequisites would result
-in installed module files being "downgraded" to an older version and
-B<may> warn users or ignore the prerequisite that would cause such a
-result.
-
-=head1 SERIALIZATION
-
-Distribution metadata should be serialized (as a hashref) as
-JSON-encoded data and packaged with distributions as the file
-F<META.json>.
-
-In the past, the distribution metadata structure had been packed with
-distributions as F<META.yml>, a file in the YAML Tiny format (for which,
-see L<YAML::Tiny>). Tools that consume distribution metadata from disk
-should be capable of loading F<META.yml>, but should prefer F<META.json>
-if both are found.
-
-=head1 NOTES FOR IMPLEMENTORS
-
-=head2 Extracting Version Numbers from Perl Modules
-
-To get the version number from a Perl module, consumers should use the
-C<< MM->parse_version($file) >> method provided by
-L<ExtUtils::MakeMaker> or L<Module::Metadata>. For example, for the
-module given by C<$mod>, the version may be retrieved in one of the
-following ways:
-
- # via ExtUtils::MakeMaker
- my $file = MM->_installed_file_for_module($mod);
- my $version = MM->parse_version($file)
-
-The private C<_installed_file_for_module> method may be replaced with
-other methods for locating a module in C<@INC>.
-
- # via Module::Metadata
- my $info = Module::Metadata->new_from_module($mod);
- my $version = $info->version;
-
-If only a filename is available, the following approach may be used:
-
- # via Module::Build
- my $info = Module::Metadata->new_from_file($file);
- my $version = $info->version;
-
-=head2 Comparing Version Numbers
-
-The L<version> module provides the most reliable way to compare version
-numbers in all the various ways they might be provided or might exist
-within modules. Given two strings containing version numbers, C<$v1> and
-C<$v2>, they should be converted to C<version> objects before using
-ordinary comparison operators. For example:
-
- use version;
- if ( version->new($v1) <=> version->new($v2) ) {
- print "Versions are not equal\n";
- }
-
-If the only comparison needed is whether an installed module is of a
-sufficiently high version, a direct test may be done using the string
-form of C<eval> and the C<use> function. For example, for module C<$mod>
-and version prerequisite C<$prereq>:
-
- if ( eval "use $mod $prereq (); 1" ) {
- print "Module $mod version is OK.\n";
- }
-
-If the values of C<$mod> and C<$prereq> have not been scrubbed, however,
-this presents security implications.
-
-=head2 Prerequisites for dynamically configured distributions
-
-When C<dynamic_config> is true, it is an error to presume that the
-prerequisites given in distribution metadata will have any relationship
-whatsoever to the actual prerequisites of the distribution.
-
-In practice, however, one can generally expect such prerequisites to be
-one of two things:
-
-=over 4
-
-=item *
-
-The minimum prerequisites for the distribution, to which dynamic configuration will only add items
-
-=item *
-
-Whatever the distribution configured with on the releaser's machine at release time
-
-=back
-
-The second case often turns out to have identical results to the first case,
-albeit only by accident.
-
-As such, consumers may use this data for informational analysis, but
-presenting it to the user as canonical or relying on it as such is
-invariably the height of folly.
-
-=head2 Indexing distributions a la PAUSE
-
-While no_index tells you what must be ignored when indexing, this spec holds
-no opinion on how you should get your initial candidate list of things to
-possibly index. For "normal" distributions you might consider simply indexing
-the contents of lib/, but there are many fascinating oddities on CPAN and
-many dists from the days when it was normal to put the main .pm file in the
-root of the distribution archive - so PAUSE currently indexes all .pm and .PL
-files that are not either (a) specifically excluded by no_index (b) in
-C<inc>, C<xt>, or C<t> directories, or common 'mistake' directories such as
-C<perl5>.
-
-Or: If you're trying to be PAUSE-like, make sure you skip C<inc>, C<xt> and
-C<t> as well as anything marked as no_index.
-
-Also remember: If the META file contains a provides field, you shouldn't be
-indexing anything in the first place - just use that.
-
-=head1 SEE ALSO
-
-=over 4
-
-=item *
-
-CPAN, L<http://www.cpan.org/>
-
-=item *
-
-JSON, L<http://json.org/>
-
-=item *
-
-YAML, L<http://www.yaml.org/>
-
-=item *
-
-L<CPAN>
-
-=item *
-
-L<CPANPLUS>
-
-=item *
-
-L<ExtUtils::MakeMaker>
-
-=item *
-
-L<Module::Build>
-
-=item *
-
-L<Module::Install>
-
-=back
-
-=head1 HISTORY
-
-Ken Williams wrote the original CPAN Meta Spec (also known as the
-"META.yml spec") in 2003 and maintained it through several revisions
-with input from various members of the community. In 2005, Randy
-Sims redrafted it from HTML to POD for the version 1.2 release. Ken
-continued to maintain the spec through version 1.4.
-
-In late 2009, David Golden organized the version 2 proposal review
-process. David and Ricardo Signes drafted the final version 2 spec
-in April 2010 based on the version 1.4 spec and patches contributed
-during the proposal process.
-
-=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
+++ /dev/null
-use 5.006;
-use strict;
-use warnings;
-package CPAN::Meta::Validator;
-
-our $VERSION = '2.150005';
-
-#pod =head1 SYNOPSIS
-#pod
-#pod my $struct = decode_json_file('META.json');
-#pod
-#pod my $cmv = CPAN::Meta::Validator->new( $struct );
-#pod
-#pod unless ( $cmv->is_valid ) {
-#pod my $msg = "Invalid META structure. Errors found:\n";
-#pod $msg .= join( "\n", $cmv->errors );
-#pod die $msg;
-#pod }
-#pod
-#pod =head1 DESCRIPTION
-#pod
-#pod This module validates a CPAN Meta structure against the version of the
-#pod the specification claimed in the C<meta-spec> field of the structure.
-#pod
-#pod =cut
-
-#--------------------------------------------------------------------------#
-# This code copied and adapted from Test::CPAN::Meta
-# by Barbie, <barbie@cpan.org> for Miss Barbell Productions,
-# L<http://www.missbarbell.co.uk>
-#--------------------------------------------------------------------------#
-
-#--------------------------------------------------------------------------#
-# Specification Definitions
-#--------------------------------------------------------------------------#
-
-my %known_specs = (
- '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
- '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html',
- '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
- '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html',
- '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html'
-);
-my %known_urls = map {$known_specs{$_} => $_} keys %known_specs;
-
-my $module_map1 = { 'map' => { ':key' => { name => \&module, value => \&exversion } } };
-
-my $module_map2 = { 'map' => { ':key' => { name => \&module, value => \&version } } };
-
-my $no_index_2 = {
- 'map' => { file => { list => { value => \&string } },
- directory => { list => { value => \&string } },
- 'package' => { list => { value => \&string } },
- namespace => { list => { value => \&string } },
- ':key' => { name => \&custom_2, value => \&anything },
- }
-};
-
-my $no_index_1_3 = {
- 'map' => { file => { list => { value => \&string } },
- directory => { list => { value => \&string } },
- 'package' => { list => { value => \&string } },
- namespace => { list => { value => \&string } },
- ':key' => { name => \&string, value => \&anything },
- }
-};
-
-my $no_index_1_2 = {
- 'map' => { file => { list => { value => \&string } },
- dir => { list => { value => \&string } },
- 'package' => { list => { value => \&string } },
- namespace => { list => { value => \&string } },
- ':key' => { name => \&string, value => \&anything },
- }
-};
-
-my $no_index_1_1 = {
- 'map' => { ':key' => { name => \&string, list => { value => \&string } },
- }
-};
-
-my $prereq_map = {
- map => {
- ':key' => {
- name => \&phase,
- 'map' => {
- ':key' => {
- name => \&relation,
- %$module_map1,
- },
- },
- }
- },
-};
-
-my %definitions = (
- '2' => {
- # REQUIRED
- 'abstract' => { mandatory => 1, value => \&string },
- 'author' => { mandatory => 1, list => { value => \&string } },
- 'dynamic_config' => { mandatory => 1, value => \&boolean },
- 'generated_by' => { mandatory => 1, value => \&string },
- 'license' => { mandatory => 1, list => { value => \&license } },
- 'meta-spec' => {
- mandatory => 1,
- 'map' => {
- version => { mandatory => 1, value => \&version},
- url => { value => \&url },
- ':key' => { name => \&custom_2, value => \&anything },
- }
- },
- 'name' => { mandatory => 1, value => \&string },
- 'release_status' => { mandatory => 1, value => \&release_status },
- 'version' => { mandatory => 1, value => \&version },
-
- # OPTIONAL
- 'description' => { value => \&string },
- 'keywords' => { list => { value => \&string } },
- 'no_index' => $no_index_2,
- 'optional_features' => {
- 'map' => {
- ':key' => {
- name => \&string,
- 'map' => {
- description => { value => \&string },
- prereqs => $prereq_map,
- ':key' => { name => \&custom_2, value => \&anything },
- }
- }
- }
- },
- 'prereqs' => $prereq_map,
- 'provides' => {
- 'map' => {
- ':key' => {
- name => \&module,
- 'map' => {
- file => { mandatory => 1, value => \&file },
- version => { value => \&version },
- ':key' => { name => \&custom_2, value => \&anything },
- }
- }
- }
- },
- 'resources' => {
- 'map' => {
- license => { list => { value => \&url } },
- homepage => { value => \&url },
- bugtracker => {
- 'map' => {
- web => { value => \&url },
- mailto => { value => \&string},
- ':key' => { name => \&custom_2, value => \&anything },
- }
- },
- repository => {
- 'map' => {
- web => { value => \&url },
- url => { value => \&url },
- type => { value => \&string },
- ':key' => { name => \&custom_2, value => \&anything },
- }
- },
- ':key' => { value => \&string, name => \&custom_2 },
- }
- },
-
- # CUSTOM -- additional user defined key/value pairs
- # note we can only validate the key name, as the structure is user defined
- ':key' => { name => \&custom_2, value => \&anything },
- },
-
-'1.4' => {
- 'meta-spec' => {
- mandatory => 1,
- 'map' => {
- version => { mandatory => 1, value => \&version},
- url => { mandatory => 1, value => \&urlspec },
- ':key' => { name => \&string, value => \&anything },
- },
- },
-
- 'name' => { mandatory => 1, value => \&string },
- 'version' => { mandatory => 1, value => \&version },
- 'abstract' => { mandatory => 1, value => \&string },
- 'author' => { mandatory => 1, list => { value => \&string } },
- 'license' => { mandatory => 1, value => \&license },
- 'generated_by' => { mandatory => 1, value => \&string },
-
- 'distribution_type' => { value => \&string },
- 'dynamic_config' => { value => \&boolean },
-
- 'requires' => $module_map1,
- 'recommends' => $module_map1,
- 'build_requires' => $module_map1,
- 'configure_requires' => $module_map1,
- 'conflicts' => $module_map2,
-
- 'optional_features' => {
- 'map' => {
- ':key' => { name => \&string,
- 'map' => { description => { value => \&string },
- requires => $module_map1,
- recommends => $module_map1,
- build_requires => $module_map1,
- conflicts => $module_map2,
- ':key' => { name => \&string, value => \&anything },
- }
- }
- }
- },
-
- 'provides' => {
- 'map' => {
- ':key' => { name => \&module,
- 'map' => {
- file => { mandatory => 1, value => \&file },
- version => { value => \&version },
- ':key' => { name => \&string, value => \&anything },
- }
- }
- }
- },
-
- 'no_index' => $no_index_1_3,
- 'private' => $no_index_1_3,
-
- 'keywords' => { list => { value => \&string } },
-
- 'resources' => {
- 'map' => { license => { value => \&url },
- homepage => { value => \&url },
- bugtracker => { value => \&url },
- repository => { value => \&url },
- ':key' => { value => \&string, name => \&custom_1 },
- }
- },
-
- # additional user defined key/value pairs
- # note we can only validate the key name, as the structure is user defined
- ':key' => { name => \&string, value => \&anything },
-},
-
-'1.3' => {
- 'meta-spec' => {
- mandatory => 1,
- 'map' => {
- version => { mandatory => 1, value => \&version},
- url => { mandatory => 1, value => \&urlspec },
- ':key' => { name => \&string, value => \&anything },
- },
- },
-
- 'name' => { mandatory => 1, value => \&string },
- 'version' => { mandatory => 1, value => \&version },
- 'abstract' => { mandatory => 1, value => \&string },
- 'author' => { mandatory => 1, list => { value => \&string } },
- 'license' => { mandatory => 1, value => \&license },
- 'generated_by' => { mandatory => 1, value => \&string },
-
- 'distribution_type' => { value => \&string },
- 'dynamic_config' => { value => \&boolean },
-
- 'requires' => $module_map1,
- 'recommends' => $module_map1,
- 'build_requires' => $module_map1,
- 'conflicts' => $module_map2,
-
- 'optional_features' => {
- 'map' => {
- ':key' => { name => \&string,
- 'map' => { description => { value => \&string },
- requires => $module_map1,
- recommends => $module_map1,
- build_requires => $module_map1,
- conflicts => $module_map2,
- ':key' => { name => \&string, value => \&anything },
- }
- }
- }
- },
-
- 'provides' => {
- 'map' => {
- ':key' => { name => \&module,
- 'map' => {
- file => { mandatory => 1, value => \&file },
- version => { value => \&version },
- ':key' => { name => \&string, value => \&anything },
- }
- }
- }
- },
-
-
- 'no_index' => $no_index_1_3,
- 'private' => $no_index_1_3,
-
- 'keywords' => { list => { value => \&string } },
-
- 'resources' => {
- 'map' => { license => { value => \&url },
- homepage => { value => \&url },
- bugtracker => { value => \&url },
- repository => { value => \&url },
- ':key' => { value => \&string, name => \&custom_1 },
- }
- },
-
- # additional user defined key/value pairs
- # note we can only validate the key name, as the structure is user defined
- ':key' => { name => \&string, value => \&anything },
-},
-
-# v1.2 is misleading, it seems to assume that a number of fields where created
-# within v1.1, when they were created within v1.2. This may have been an
-# original mistake, and that a v1.1 was retro fitted into the timeline, when
-# v1.2 was originally slated as v1.1. But I could be wrong ;)
-'1.2' => {
- 'meta-spec' => {
- mandatory => 1,
- 'map' => {
- version => { mandatory => 1, value => \&version},
- url => { mandatory => 1, value => \&urlspec },
- ':key' => { name => \&string, value => \&anything },
- },
- },
-
-
- 'name' => { mandatory => 1, value => \&string },
- 'version' => { mandatory => 1, value => \&version },
- 'license' => { mandatory => 1, value => \&license },
- 'generated_by' => { mandatory => 1, value => \&string },
- 'author' => { mandatory => 1, list => { value => \&string } },
- 'abstract' => { mandatory => 1, value => \&string },
-
- 'distribution_type' => { value => \&string },
- 'dynamic_config' => { value => \&boolean },
-
- 'keywords' => { list => { value => \&string } },
-
- 'private' => $no_index_1_2,
- '$no_index' => $no_index_1_2,
-
- 'requires' => $module_map1,
- 'recommends' => $module_map1,
- 'build_requires' => $module_map1,
- 'conflicts' => $module_map2,
-
- 'optional_features' => {
- 'map' => {
- ':key' => { name => \&string,
- 'map' => { description => { value => \&string },
- requires => $module_map1,
- recommends => $module_map1,
- build_requires => $module_map1,
- conflicts => $module_map2,
- ':key' => { name => \&string, value => \&anything },
- }
- }
- }
- },
-
- 'provides' => {
- 'map' => {
- ':key' => { name => \&module,
- 'map' => {
- file => { mandatory => 1, value => \&file },
- version => { value => \&version },
- ':key' => { name => \&string, value => \&anything },
- }
- }
- }
- },
-
- 'resources' => {
- 'map' => { license => { value => \&url },
- homepage => { value => \&url },
- bugtracker => { value => \&url },
- repository => { value => \&url },
- ':key' => { value => \&string, name => \&custom_1 },
- }
- },
-
- # additional user defined key/value pairs
- # note we can only validate the key name, as the structure is user defined
- ':key' => { name => \&string, value => \&anything },
-},
-
-# note that the 1.1 spec only specifies 'version' as mandatory
-'1.1' => {
- 'name' => { value => \&string },
- 'version' => { mandatory => 1, value => \&version },
- 'license' => { value => \&license },
- 'generated_by' => { value => \&string },
-
- 'license_uri' => { value => \&url },
- 'distribution_type' => { value => \&string },
- 'dynamic_config' => { value => \&boolean },
-
- 'private' => $no_index_1_1,
-
- 'requires' => $module_map1,
- 'recommends' => $module_map1,
- 'build_requires' => $module_map1,
- 'conflicts' => $module_map2,
-
- # additional user defined key/value pairs
- # note we can only validate the key name, as the structure is user defined
- ':key' => { name => \&string, value => \&anything },
-},
-
-# note that the 1.0 spec doesn't specify optional or mandatory fields
-# but we will treat version as mandatory since otherwise META 1.0 is
-# completely arbitrary and pointless
-'1.0' => {
- 'name' => { value => \&string },
- 'version' => { mandatory => 1, value => \&version },
- 'license' => { value => \&license },
- 'generated_by' => { value => \&string },
-
- 'license_uri' => { value => \&url },
- 'distribution_type' => { value => \&string },
- 'dynamic_config' => { value => \&boolean },
-
- 'requires' => $module_map1,
- 'recommends' => $module_map1,
- 'build_requires' => $module_map1,
- 'conflicts' => $module_map2,
-
- # additional user defined key/value pairs
- # note we can only validate the key name, as the structure is user defined
- ':key' => { name => \&string, value => \&anything },
-},
-);
-
-#--------------------------------------------------------------------------#
-# Code
-#--------------------------------------------------------------------------#
-
-#pod =method new
-#pod
-#pod my $cmv = CPAN::Meta::Validator->new( $struct )
-#pod
-#pod The constructor must be passed a metadata structure.
-#pod
-#pod =cut
-
-sub new {
- my ($class,$data) = @_;
-
- # create an attributes hash
- my $self = {
- 'data' => $data,
- 'spec' => eval { $data->{'meta-spec'}{'version'} } || "1.0",
- 'errors' => undef,
- };
-
- # create the object
- return bless $self, $class;
-}
-
-#pod =method is_valid
-#pod
-#pod if ( $cmv->is_valid ) {
-#pod ...
-#pod }
-#pod
-#pod Returns a boolean value indicating whether the metadata provided
-#pod is valid.
-#pod
-#pod =cut
-
-sub is_valid {
- my $self = shift;
- my $data = $self->{data};
- my $spec_version = $self->{spec};
- $self->check_map($definitions{$spec_version},$data);
- return ! $self->errors;
-}
-
-#pod =method errors
-#pod
-#pod warn( join "\n", $cmv->errors );
-#pod
-#pod Returns a list of errors seen during validation.
-#pod
-#pod =cut
-
-sub errors {
- my $self = shift;
- return () unless(defined $self->{errors});
- return @{$self->{errors}};
-}
-
-#pod =begin :internals
-#pod
-#pod =head2 Check Methods
-#pod
-#pod =over
-#pod
-#pod =item *
-#pod
-#pod check_map($spec,$data)
-#pod
-#pod Checks whether a map (or hash) part of the data structure conforms to the
-#pod appropriate specification definition.
-#pod
-#pod =item *
-#pod
-#pod check_list($spec,$data)
-#pod
-#pod Checks whether a list (or array) part of the data structure conforms to
-#pod the appropriate specification definition.
-#pod
-#pod =item *
-#pod
-#pod =back
-#pod
-#pod =cut
-
-my $spec_error = "Missing validation action in specification. "
- . "Must be one of 'map', 'list', or 'value'";
-
-sub check_map {
- my ($self,$spec,$data) = @_;
-
- if(ref($spec) ne 'HASH') {
- $self->_error( "Unknown META specification, cannot validate." );
- return;
- }
-
- if(ref($data) ne 'HASH') {
- $self->_error( "Expected a map structure from string or file." );
- return;
- }
-
- for my $key (keys %$spec) {
- next unless($spec->{$key}->{mandatory});
- next if(defined $data->{$key});
- push @{$self->{stack}}, $key;
- $self->_error( "Missing mandatory field, '$key'" );
- pop @{$self->{stack}};
- }
-
- for my $key (keys %$data) {
- push @{$self->{stack}}, $key;
- if($spec->{$key}) {
- if($spec->{$key}{value}) {
- $spec->{$key}{value}->($self,$key,$data->{$key});
- } elsif($spec->{$key}{'map'}) {
- $self->check_map($spec->{$key}{'map'},$data->{$key});
- } elsif($spec->{$key}{'list'}) {
- $self->check_list($spec->{$key}{'list'},$data->{$key});
- } else {
- $self->_error( "$spec_error for '$key'" );
- }
-
- } elsif ($spec->{':key'}) {
- $spec->{':key'}{name}->($self,$key,$key);
- if($spec->{':key'}{value}) {
- $spec->{':key'}{value}->($self,$key,$data->{$key});
- } elsif($spec->{':key'}{'map'}) {
- $self->check_map($spec->{':key'}{'map'},$data->{$key});
- } elsif($spec->{':key'}{'list'}) {
- $self->check_list($spec->{':key'}{'list'},$data->{$key});
- } else {
- $self->_error( "$spec_error for ':key'" );
- }
-
-
- } else {
- $self->_error( "Unknown key, '$key', found in map structure" );
- }
- pop @{$self->{stack}};
- }
-}
-
-sub check_list {
- my ($self,$spec,$data) = @_;
-
- if(ref($data) ne 'ARRAY') {
- $self->_error( "Expected a list structure" );
- return;
- }
-
- if(defined $spec->{mandatory}) {
- if(!defined $data->[0]) {
- $self->_error( "Missing entries from mandatory list" );
- }
- }
-
- for my $value (@$data) {
- push @{$self->{stack}}, $value || "<undef>";
- if(defined $spec->{value}) {
- $spec->{value}->($self,'list',$value);
- } elsif(defined $spec->{'map'}) {
- $self->check_map($spec->{'map'},$value);
- } elsif(defined $spec->{'list'}) {
- $self->check_list($spec->{'list'},$value);
- } elsif ($spec->{':key'}) {
- $self->check_map($spec,$value);
- } else {
- $self->_error( "$spec_error associated with '$self->{stack}[-2]'" );
- }
- pop @{$self->{stack}};
- }
-}
-
-#pod =head2 Validator Methods
-#pod
-#pod =over
-#pod
-#pod =item *
-#pod
-#pod header($self,$key,$value)
-#pod
-#pod Validates that the header is valid.
-#pod
-#pod Note: No longer used as we now read the data structure, not the file.
-#pod
-#pod =item *
-#pod
-#pod url($self,$key,$value)
-#pod
-#pod Validates that a given value is in an acceptable URL format
-#pod
-#pod =item *
-#pod
-#pod urlspec($self,$key,$value)
-#pod
-#pod Validates that the URL to a META specification is a known one.
-#pod
-#pod =item *
-#pod
-#pod string_or_undef($self,$key,$value)
-#pod
-#pod Validates that the value is either a string or an undef value. Bit of a
-#pod catchall function for parts of the data structure that are completely user
-#pod defined.
-#pod
-#pod =item *
-#pod
-#pod string($self,$key,$value)
-#pod
-#pod Validates that a string exists for the given key.
-#pod
-#pod =item *
-#pod
-#pod file($self,$key,$value)
-#pod
-#pod Validate that a file is passed for the given key. This may be made more
-#pod thorough in the future. For now it acts like \&string.
-#pod
-#pod =item *
-#pod
-#pod exversion($self,$key,$value)
-#pod
-#pod Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'.
-#pod
-#pod =item *
-#pod
-#pod version($self,$key,$value)
-#pod
-#pod Validates a single version string. Versions of the type '5.8.8' and '0.00_00'
-#pod are both valid. A leading 'v' like 'v1.2.3' is also valid.
-#pod
-#pod =item *
-#pod
-#pod boolean($self,$key,$value)
-#pod
-#pod Validates for a boolean value. Currently these values are '1', '0', 'true',
-#pod 'false', however the latter 2 may be removed.
-#pod
-#pod =item *
-#pod
-#pod license($self,$key,$value)
-#pod
-#pod Validates that a value is given for the license. Returns 1 if an known license
-#pod type, or 2 if a value is given but the license type is not a recommended one.
-#pod
-#pod =item *
-#pod
-#pod custom_1($self,$key,$value)
-#pod
-#pod Validates that the given key is in CamelCase, to indicate a user defined
-#pod keyword and only has characters in the class [-_a-zA-Z]. In version 1.X
-#pod of the spec, this was only explicitly stated for 'resources'.
-#pod
-#pod =item *
-#pod
-#pod custom_2($self,$key,$value)
-#pod
-#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;
- }
- $value = '<undef>' unless(defined $value);
- $self->_error( "'$value' for '$key' is not a valid version." );
- return 0;
-}
-
-sub version {
- my ($self,$key,$value) = @_;
- if(defined $value) {
- return 0 unless($value || $value =~ /0/);
- return 1 if($value =~ /^\s*((<|<=|>=|>|!=|==)\s*)?v?\d+((\.\d+((_|\.)\d+)?)?)/);
- } else {
- $value = '<undef>';
- }
- $self->_error( "'$value' for '$key' is not a valid version." );
- return 0;
-}
-
-sub boolean {
- my ($self,$key,$value) = @_;
- if(defined $value) {
- return 1 if($value =~ /^(0|1|true|false)$/);
- } else {
- $value = '<undef>';
- }
- $self->_error( "'$value' for '$key' is not a boolean value." );
- return 0;
-}
-
-my %v1_licenses = (
- 'perl' => 'http://dev.perl.org/licenses/',
- 'gpl' => 'http://www.opensource.org/licenses/gpl-license.php',
- 'apache' => 'http://apache.org/licenses/LICENSE-2.0',
- 'artistic' => 'http://opensource.org/licenses/artistic-license.php',
- 'artistic_2' => 'http://opensource.org/licenses/artistic-license-2.0.php',
- 'lgpl' => 'http://www.opensource.org/licenses/lgpl-license.php',
- 'bsd' => 'http://www.opensource.org/licenses/bsd-license.php',
- 'gpl' => 'http://www.opensource.org/licenses/gpl-license.php',
- 'mit' => 'http://opensource.org/licenses/mit-license.php',
- 'mozilla' => 'http://opensource.org/licenses/mozilla1.1.php',
- 'open_source' => undef,
- 'unrestricted' => undef,
- 'restrictive' => undef,
- 'unknown' => undef,
-);
-
-my %v2_licenses = map { $_ => 1 } qw(
- agpl_3
- apache_1_1
- apache_2_0
- artistic_1
- artistic_2
- bsd
- freebsd
- gfdl_1_2
- gfdl_1_3
- gpl_1
- gpl_2
- gpl_3
- lgpl_2_1
- lgpl_3_0
- mit
- mozilla_1_0
- mozilla_1_1
- openssl
- perl_5
- qpl_1_0
- ssleay
- sun
- zlib
- open_source
- restricted
- unrestricted
- unknown
-);
-
-sub license {
- my ($self,$key,$value) = @_;
- my $licenses = $self->{spec} < 2 ? \%v1_licenses : \%v2_licenses;
- if(defined $value) {
- return 1 if($value && exists $licenses->{$value});
- } else {
- $value = '<undef>';
- }
- $self->_error( "License '$value' is invalid" );
- return 0;
-}
-
-sub custom_1 {
- my ($self,$key) = @_;
- if(defined $key) {
- # a valid user defined key should be alphabetic
- # and contain at least one capital case letter.
- return 1 if($key && $key =~ /^[_a-z]+$/i && $key =~ /[A-Z]/);
- } else {
- $key = '<undef>';
- }
- $self->_error( "Custom resource '$key' must be in CamelCase." );
- return 0;
-}
-
-sub custom_2 {
- my ($self,$key) = @_;
- if(defined $key) {
- return 1 if($key && $key =~ /^x_/i); # user defined
- } else {
- $key = '<undef>';
- }
- $self->_error( "Custom key '$key' must begin with 'x_' or 'X_'." );
- return 0;
-}
-
-sub identifier {
- my ($self,$key) = @_;
- if(defined $key) {
- return 1 if($key && $key =~ /^([a-z][_a-z]+)$/i); # spec 2.0 defined
- } else {
- $key = '<undef>';
- }
- $self->_error( "Key '$key' is not a legal identifier." );
- return 0;
-}
-
-sub module {
- my ($self,$key) = @_;
- if(defined $key) {
- return 1 if($key && $key =~ /^[A-Za-z0-9_]+(::[A-Za-z0-9_]+)*$/);
- } else {
- $key = '<undef>';
- }
- $self->_error( "Key '$key' is not a legal module name." );
- return 0;
-}
-
-my @valid_phases = qw/ configure build test runtime develop /;
-sub phase {
- my ($self,$key) = @_;
- if(defined $key) {
- return 1 if( length $key && grep { $key eq $_ } @valid_phases );
- return 1 if $key =~ /x_/i;
- } else {
- $key = '<undef>';
- }
- $self->_error( "Key '$key' is not a legal phase." );
- return 0;
-}
-
-my @valid_relations = qw/ requires recommends suggests conflicts /;
-sub relation {
- my ($self,$key) = @_;
- if(defined $key) {
- return 1 if( length $key && grep { $key eq $_ } @valid_relations );
- return 1 if $key =~ /x_/i;
- } else {
- $key = '<undef>';
- }
- $self->_error( "Key '$key' is not a legal prereq relationship." );
- return 0;
-}
-
-sub _error {
- my $self = shift;
- my $mess = shift;
-
- $mess .= ' ('.join(' -> ',@{$self->{stack}}).')' if($self->{stack});
- $mess .= " [Validation: $self->{spec}]";
-
- push @{$self->{errors}}, $mess;
-}
-
-1;
-
-# ABSTRACT: validate CPAN distribution metadata structures
-
-=pod
-
-=encoding UTF-8
-
-=head1 NAME
-
-CPAN::Meta::Validator - validate CPAN distribution metadata structures
-
-=head1 VERSION
-
-version 2.150005
-
-=head1 SYNOPSIS
-
- my $struct = decode_json_file('META.json');
-
- my $cmv = CPAN::Meta::Validator->new( $struct );
-
- unless ( $cmv->is_valid ) {
- my $msg = "Invalid META structure. Errors found:\n";
- $msg .= join( "\n", $cmv->errors );
- die $msg;
- }
-
-=head1 DESCRIPTION
-
-This module validates a CPAN Meta structure against the version of the
-the specification claimed in the C<meta-spec> field of the structure.
-
-=head1 METHODS
-
-=head2 new
-
- my $cmv = CPAN::Meta::Validator->new( $struct )
-
-The constructor must be passed a metadata structure.
-
-=head2 is_valid
-
- if ( $cmv->is_valid ) {
- ...
- }
-
-Returns a boolean value indicating whether the metadata provided
-is valid.
-
-=head2 errors
-
- warn( join "\n", $cmv->errors );
-
-Returns a list of errors seen during validation.
-
-=begin :internals
-
-=head2 Check Methods
-
-=over
-
-=item *
-
-check_map($spec,$data)
-
-Checks whether a map (or hash) part of the data structure conforms to the
-appropriate specification definition.
-
-=item *
-
-check_list($spec,$data)
-
-Checks whether a list (or array) part of the data structure conforms to
-the appropriate specification definition.
-
-=item *
-
-=back
-
-=head2 Validator Methods
-
-=over
-
-=item *
-
-header($self,$key,$value)
-
-Validates that the header is valid.
-
-Note: No longer used as we now read the data structure, not the file.
-
-=item *
-
-url($self,$key,$value)
-
-Validates that a given value is in an acceptable URL format
-
-=item *
-
-urlspec($self,$key,$value)
-
-Validates that the URL to a META specification is a known one.
-
-=item *
-
-string_or_undef($self,$key,$value)
-
-Validates that the value is either a string or an undef value. Bit of a
-catchall function for parts of the data structure that are completely user
-defined.
-
-=item *
-
-string($self,$key,$value)
-
-Validates that a string exists for the given key.
-
-=item *
-
-file($self,$key,$value)
-
-Validate that a file is passed for the given key. This may be made more
-thorough in the future. For now it acts like \&string.
-
-=item *
-
-exversion($self,$key,$value)
-
-Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'.
-
-=item *
-
-version($self,$key,$value)
-
-Validates a single version string. Versions of the type '5.8.8' and '0.00_00'
-are both valid. A leading 'v' like 'v1.2.3' is also valid.
-
-=item *
-
-boolean($self,$key,$value)
-
-Validates for a boolean value. Currently these values are '1', '0', 'true',
-'false', however the latter 2 may be removed.
-
-=item *
-
-license($self,$key,$value)
-
-Validates that a value is given for the license. Returns 1 if an known license
-type, or 2 if a value is given but the license type is not a recommended one.
-
-=item *
-
-custom_1($self,$key,$value)
-
-Validates that the given key is in CamelCase, to indicate a user defined
-keyword and only has characters in the class [-_a-zA-Z]. In version 1.X
-of the spec, this was only explicitly stated for 'resources'.
-
-=item *
-
-custom_2($self,$key,$value)
-
-Validates that the given key begins with 'x_' or 'X_', to indicate a user
-defined keyword and only has characters in the class [-_a-zA-Z]
-
-=item *
-
-identifier($self,$key,$value)
-
-Validates that key is in an acceptable format for the META specification,
-for an identifier, i.e. any that matches the regular expression
-qr/[a-z][a-z_]/i.
-
-=item *
-
-module($self,$key,$value)
-
-Validates that a given key is in an acceptable module name format, e.g.
-'Test::CPAN::Meta::Version'.
-
-=back
-
-=end :internals
-
-=for Pod::Coverage anything boolean check_list custom_1 custom_2 exversion file
-identifier license module phase relation release_status string string_or_undef
-url urlspec version header check_map
-
-=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 :
+++ /dev/null
-use 5.008001; # sane UTF-8 support
-use strict;
-use warnings;
-package CPAN::Meta::YAML; # git description: v1.68-2-gcc5324e
-# XXX-INGY is 5.8.1 too old/broken for utf8?
-# XXX-XDG Lancaster consensus was that it was sufficient until
-# proven otherwise
-$CPAN::Meta::YAML::VERSION = '0.018';
-; # original $VERSION removed by Doppelgaenger
-
-#####################################################################
-# The CPAN::Meta::YAML API.
-#
-# These are the currently documented API functions/methods and
-# exports:
-
-use Exporter;
-our @ISA = qw{ Exporter };
-our @EXPORT = qw{ Load Dump };
-our @EXPORT_OK = qw{ LoadFile DumpFile freeze thaw };
-
-###
-# Functional/Export API:
-
-sub Dump {
- return CPAN::Meta::YAML->new(@_)->_dump_string;
-}
-
-# XXX-INGY Returning last document seems a bad behavior.
-# XXX-XDG I think first would seem more natural, but I don't know
-# that it's worth changing now
-sub Load {
- my $self = CPAN::Meta::YAML->_load_string(@_);
- if ( wantarray ) {
- return @$self;
- } else {
- # To match YAML.pm, return the last document
- return $self->[-1];
- }
-}
-
-# XXX-INGY Do we really need freeze and thaw?
-# XXX-XDG I don't think so. I'd support deprecating them.
-BEGIN {
- *freeze = \&Dump;
- *thaw = \&Load;
-}
-
-sub DumpFile {
- my $file = shift;
- return CPAN::Meta::YAML->new(@_)->_dump_file($file);
-}
-
-sub LoadFile {
- my $file = shift;
- my $self = CPAN::Meta::YAML->_load_file($file);
- if ( wantarray ) {
- return @$self;
- } else {
- # Return only the last document to match YAML.pm,
- return $self->[-1];
- }
-}
-
-
-###
-# Object Oriented API:
-
-# Create an empty CPAN::Meta::YAML object
-# XXX-INGY Why do we use ARRAY object?
-# NOTE: I get it now, but I think it's confusing and not needed.
-# Will change it on a branch later, for review.
-#
-# XXX-XDG I don't support changing it yet. It's a very well-documented
-# "API" of CPAN::Meta::YAML. I'd support deprecating it, but Adam suggested
-# we not change it until YAML.pm's own OO API is established so that
-# users only have one API change to digest, not two
-sub new {
- my $class = shift;
- bless [ @_ ], $class;
-}
-
-# XXX-INGY It probably doesn't matter, and it's probably too late to
-# change, but 'read/write' are the wrong names. Read and Write
-# are actions that take data from storage to memory
-# characters/strings. These take the data to/from storage to native
-# Perl objects, which the terms dump and load are meant. As long as
-# this is a legacy quirk to CPAN::Meta::YAML it's ok, but I'd prefer not
-# to add new {read,write}_* methods to this API.
-
-sub read_string {
- my $self = shift;
- $self->_load_string(@_);
-}
-
-sub write_string {
- my $self = shift;
- $self->_dump_string(@_);
-}
-
-sub read {
- my $self = shift;
- $self->_load_file(@_);
-}
-
-sub write {
- my $self = shift;
- $self->_dump_file(@_);
-}
-
-
-
-
-#####################################################################
-# Constants
-
-# Printed form of the unprintable characters in the lowest range
-# of ASCII characters, listed by ASCII ordinal position.
-my @UNPRINTABLE = qw(
- 0 x01 x02 x03 x04 x05 x06 a
- b t n v f r x0E x0F
- x10 x11 x12 x13 x14 x15 x16 x17
- x18 x19 x1A e x1C x1D x1E x1F
-);
-
-# Printable characters for escapes
-my %UNESCAPES = (
- 0 => "\x00", z => "\x00", N => "\x85",
- a => "\x07", b => "\x08", t => "\x09",
- n => "\x0a", v => "\x0b", f => "\x0c",
- r => "\x0d", e => "\x1b", '\\' => '\\',
-);
-
-# XXX-INGY
-# I(ngy) need to decide if these values should be quoted in
-# CPAN::Meta::YAML or not. Probably yes.
-
-# These 3 values have special meaning when unquoted and using the
-# default YAML schema. They need quotes if they are strings.
-my %QUOTE = map { $_ => 1 } qw{
- null true false
-};
-
-# The commented out form is simpler, but overloaded the Perl regex
-# engine due to recursion and backtracking problems on strings
-# larger than 32,000ish characters. Keep it for reference purposes.
-# qr/\"((?:\\.|[^\"])*)\"/
-my $re_capture_double_quoted = qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/;
-my $re_capture_single_quoted = qr/\'([^\']*(?:\'\'[^\']*)*)\'/;
-# unquoted re gets trailing space that needs to be stripped
-my $re_capture_unquoted_key = qr/([^:]+(?::+\S(?:[^:]*|.*?(?=:)))*)(?=\s*\:(?:\s+|$))/;
-my $re_trailing_comment = qr/(?:\s+\#.*)?/;
-my $re_key_value_separator = qr/\s*:(?:\s+(?:\#.*)?|$)/;
-
-
-
-
-
-#####################################################################
-# CPAN::Meta::YAML Implementation.
-#
-# These are the private methods that do all the work. They may change
-# at any time.
-
-
-###
-# Loader functions:
-
-# Create an object from a file
-sub _load_file {
- my $class = ref $_[0] ? ref shift : shift;
-
- # Check the file
- my $file = shift or $class->_error( 'You did not specify a file name' );
- $class->_error( "File '$file' does not exist" )
- unless -e $file;
- $class->_error( "'$file' is a directory, not a file" )
- unless -f _;
- $class->_error( "Insufficient permissions to read '$file'" )
- unless -r _;
-
- # Open unbuffered with strict UTF-8 decoding and no translation layers
- open( my $fh, "<:unix:encoding(UTF-8)", $file );
- unless ( $fh ) {
- $class->_error("Failed to open file '$file': $!");
- }
-
- # flock if available (or warn if not possible for OS-specific reasons)
- if ( _can_flock() ) {
- flock( $fh, Fcntl::LOCK_SH() )
- or warn "Couldn't lock '$file' for reading: $!";
- }
-
- # slurp the contents
- my $contents = eval {
- use warnings FATAL => 'utf8';
- local $/;
- <$fh>
- };
- if ( my $err = $@ ) {
- $class->_error("Error reading from file '$file': $err");
- }
-
- # close the file (release the lock)
- unless ( close $fh ) {
- $class->_error("Failed to close file '$file': $!");
- }
-
- $class->_load_string( $contents );
-}
-
-# Create an object from a string
-sub _load_string {
- my $class = ref $_[0] ? ref shift : shift;
- my $self = bless [], $class;
- my $string = $_[0];
- eval {
- unless ( defined $string ) {
- die \"Did not provide a string to load";
- }
-
- # Check if Perl has it marked as characters, but it's internally
- # inconsistent. E.g. maybe latin1 got read on a :utf8 layer
- if ( utf8::is_utf8($string) && ! utf8::valid($string) ) {
- die \<<'...';
-Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set).
-Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"?
-...
- }
-
- # Ensure Unicode character semantics, even for 0x80-0xff
- utf8::upgrade($string);
-
- # Check for and strip any leading UTF-8 BOM
- $string =~ s/^\x{FEFF}//;
-
- # Check for some special cases
- return $self unless length $string;
-
- # Split the file into lines
- my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
- split /(?:\015{1,2}\012|\015|\012)/, $string;
-
- # Strip the initial YAML header
- @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;
-
- # A nibbling parser
- my $in_document = 0;
- while ( @lines ) {
- # Do we have a document header?
- if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
- # Handle scalar documents
- shift @lines;
- if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
- push @$self,
- $self->_load_scalar( "$1", [ undef ], \@lines );
- next;
- }
- $in_document = 1;
- }
-
- if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
- # A naked document
- push @$self, undef;
- while ( @lines and $lines[0] !~ /^---/ ) {
- shift @lines;
- }
- $in_document = 0;
-
- # XXX The final '-+$' is to look for -- which ends up being an
- # error later.
- } elsif ( ! $in_document && @$self ) {
- # only the first document can be explicit
- die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
- } elsif ( $lines[0] =~ /^\s*\-(?:\s|$|-+$)/ ) {
- # An array at the root
- my $document = [ ];
- push @$self, $document;
- $self->_load_array( $document, [ 0 ], \@lines );
-
- } elsif ( $lines[0] =~ /^(\s*)\S/ ) {
- # A hash at the root
- my $document = { };
- push @$self, $document;
- $self->_load_hash( $document, [ length($1) ], \@lines );
-
- } else {
- # Shouldn't get here. @lines have whitespace-only lines
- # stripped, and previous match is a line with any
- # non-whitespace. So this clause should only be reachable via
- # a perlbug where \s is not symmetric with \S
-
- # uncoverable statement
- die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
- }
- }
- };
- my $err = $@;
- if ( ref $err eq 'SCALAR' ) {
- $self->_error(${$err});
- } elsif ( $err ) {
- $self->_error($err);
- }
-
- return $self;
-}
-
-sub _unquote_single {
- my ($self, $string) = @_;
- return '' unless length $string;
- $string =~ s/\'\'/\'/g;
- return $string;
-}
-
-sub _unquote_double {
- my ($self, $string) = @_;
- return '' unless length $string;
- $string =~ s/\\"/"/g;
- $string =~
- s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))}
- {(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex;
- return $string;
-}
-
-# Load a YAML scalar string to the actual Perl scalar
-sub _load_scalar {
- my ($self, $string, $indent, $lines) = @_;
-
- # Trim trailing whitespace
- $string =~ s/\s*\z//;
-
- # Explitic null/undef
- return undef if $string eq '~';
-
- # Single quote
- if ( $string =~ /^$re_capture_single_quoted$re_trailing_comment\z/ ) {
- return $self->_unquote_single($1);
- }
-
- # Double quote.
- if ( $string =~ /^$re_capture_double_quoted$re_trailing_comment\z/ ) {
- return $self->_unquote_double($1);
- }
-
- # Special cases
- if ( $string =~ /^[\'\"!&]/ ) {
- die \"CPAN::Meta::YAML does not support a feature in line '$string'";
- }
- return {} if $string =~ /^{}(?:\s+\#.*)?\z/;
- return [] if $string =~ /^\[\](?:\s+\#.*)?\z/;
-
- # Regular unquoted string
- if ( $string !~ /^[>|]/ ) {
- die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'"
- if $string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or
- $string =~ /:(?:\s|$)/;
- $string =~ s/\s+#.*\z//;
- return $string;
- }
-
- # Error
- die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines;
-
- # Check the indent depth
- $lines->[0] =~ /^(\s*)/;
- $indent->[-1] = length("$1");
- if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
- die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
- }
-
- # Pull the lines
- my @multiline = ();
- while ( @$lines ) {
- $lines->[0] =~ /^(\s*)/;
- last unless length($1) >= $indent->[-1];
- push @multiline, substr(shift(@$lines), length($1));
- }
-
- my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
- my $t = (substr($string, 1, 1) eq '-') ? '' : "\n";
- return join( $j, @multiline ) . $t;
-}
-
-# Load an array
-sub _load_array {
- my ($self, $array, $indent, $lines) = @_;
-
- while ( @$lines ) {
- # Check for a new document
- if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
- while ( @$lines and $lines->[0] !~ /^---/ ) {
- shift @$lines;
- }
- return 1;
- }
-
- # Check the indent level
- $lines->[0] =~ /^(\s*)/;
- if ( length($1) < $indent->[-1] ) {
- return 1;
- } elsif ( length($1) > $indent->[-1] ) {
- die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
- }
-
- if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
- # Inline nested hash
- my $indent2 = length("$1");
- $lines->[0] =~ s/-/ /;
- push @$array, { };
- $self->_load_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
-
- } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
- shift @$lines;
- unless ( @$lines ) {
- push @$array, undef;
- return 1;
- }
- if ( $lines->[0] =~ /^(\s*)\-/ ) {
- my $indent2 = length("$1");
- if ( $indent->[-1] == $indent2 ) {
- # Null array entry
- push @$array, undef;
- } else {
- # Naked indenter
- push @$array, [ ];
- $self->_load_array(
- $array->[-1], [ @$indent, $indent2 ], $lines
- );
- }
-
- } elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
- push @$array, { };
- $self->_load_hash(
- $array->[-1], [ @$indent, length("$1") ], $lines
- );
-
- } else {
- die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
- }
-
- } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
- # Array entry with a value
- shift @$lines;
- push @$array, $self->_load_scalar(
- "$2", [ @$indent, undef ], $lines
- );
-
- } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
- # This is probably a structure like the following...
- # ---
- # foo:
- # - list
- # bar: value
- #
- # ... so lets return and let the hash parser handle it
- return 1;
-
- } else {
- die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
- }
- }
-
- return 1;
-}
-
-# Load a hash
-sub _load_hash {
- my ($self, $hash, $indent, $lines) = @_;
-
- while ( @$lines ) {
- # Check for a new document
- if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
- while ( @$lines and $lines->[0] !~ /^---/ ) {
- shift @$lines;
- }
- return 1;
- }
-
- # Check the indent level
- $lines->[0] =~ /^(\s*)/;
- if ( length($1) < $indent->[-1] ) {
- return 1;
- } elsif ( length($1) > $indent->[-1] ) {
- die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
- }
-
- # Find the key
- my $key;
-
- # Quoted keys
- if ( $lines->[0] =~
- s/^\s*$re_capture_single_quoted$re_key_value_separator//
- ) {
- $key = $self->_unquote_single($1);
- }
- elsif ( $lines->[0] =~
- s/^\s*$re_capture_double_quoted$re_key_value_separator//
- ) {
- $key = $self->_unquote_double($1);
- }
- elsif ( $lines->[0] =~
- s/^\s*$re_capture_unquoted_key$re_key_value_separator//
- ) {
- $key = $1;
- $key =~ s/\s+$//;
- }
- elsif ( $lines->[0] =~ /^\s*\?/ ) {
- die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'";
- }
- else {
- die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
- }
-
- if ( exists $hash->{$key} ) {
- warn "CPAN::Meta::YAML found a duplicate key '$key' in line '$lines->[0]'";
- }
-
- # Do we have a value?
- if ( length $lines->[0] ) {
- # Yes
- $hash->{$key} = $self->_load_scalar(
- shift(@$lines), [ @$indent, undef ], $lines
- );
- } else {
- # An indent
- shift @$lines;
- unless ( @$lines ) {
- $hash->{$key} = undef;
- return 1;
- }
- if ( $lines->[0] =~ /^(\s*)-/ ) {
- $hash->{$key} = [];
- $self->_load_array(
- $hash->{$key}, [ @$indent, length($1) ], $lines
- );
- } elsif ( $lines->[0] =~ /^(\s*)./ ) {
- my $indent2 = length("$1");
- if ( $indent->[-1] >= $indent2 ) {
- # Null hash entry
- $hash->{$key} = undef;
- } else {
- $hash->{$key} = {};
- $self->_load_hash(
- $hash->{$key}, [ @$indent, length($1) ], $lines
- );
- }
- }
- }
- }
-
- return 1;
-}
-
-
-###
-# Dumper functions:
-
-# Save an object to a file
-sub _dump_file {
- my $self = shift;
-
- require Fcntl;
-
- # Check the file
- my $file = shift or $self->_error( 'You did not specify a file name' );
-
- my $fh;
- # flock if available (or warn if not possible for OS-specific reasons)
- if ( _can_flock() ) {
- # Open without truncation (truncate comes after lock)
- my $flags = Fcntl::O_WRONLY()|Fcntl::O_CREAT();
- sysopen( $fh, $file, $flags );
- unless ( $fh ) {
- $self->_error("Failed to open file '$file' for writing: $!");
- }
-
- # Use no translation and strict UTF-8
- binmode( $fh, ":raw:encoding(UTF-8)");
-
- flock( $fh, Fcntl::LOCK_EX() )
- or warn "Couldn't lock '$file' for reading: $!";
-
- # truncate and spew contents
- truncate $fh, 0;
- seek $fh, 0, 0;
- }
- else {
- open $fh, ">:unix:encoding(UTF-8)", $file;
- }
-
- # serialize and spew to the handle
- print {$fh} $self->_dump_string;
-
- # close the file (release the lock)
- unless ( close $fh ) {
- $self->_error("Failed to close file '$file': $!");
- }
-
- return 1;
-}
-
-# Save an object to a string
-sub _dump_string {
- my $self = shift;
- return '' unless ref $self && @$self;
-
- # Iterate over the documents
- my $indent = 0;
- my @lines = ();
-
- eval {
- foreach my $cursor ( @$self ) {
- push @lines, '---';
-
- # An empty document
- if ( ! defined $cursor ) {
- # Do nothing
-
- # A scalar document
- } elsif ( ! ref $cursor ) {
- $lines[-1] .= ' ' . $self->_dump_scalar( $cursor );
-
- # A list at the root
- } elsif ( ref $cursor eq 'ARRAY' ) {
- unless ( @$cursor ) {
- $lines[-1] .= ' []';
- next;
- }
- push @lines, $self->_dump_array( $cursor, $indent, {} );
-
- # A hash at the root
- } elsif ( ref $cursor eq 'HASH' ) {
- unless ( %$cursor ) {
- $lines[-1] .= ' {}';
- next;
- }
- push @lines, $self->_dump_hash( $cursor, $indent, {} );
-
- } else {
- die \("Cannot serialize " . ref($cursor));
- }
- }
- };
- if ( ref $@ eq 'SCALAR' ) {
- $self->_error(${$@});
- } elsif ( $@ ) {
- $self->_error($@);
- }
-
- join '', map { "$_\n" } @lines;
-}
-
-sub _has_internal_string_value {
- my $value = shift;
- my $b_obj = B::svref_2object(\$value); # for round trip problem
- return $b_obj->FLAGS & B::SVf_POK();
-}
-
-sub _dump_scalar {
- my $string = $_[1];
- my $is_key = $_[2];
- # Check this before checking length or it winds up looking like a string!
- my $has_string_flag = _has_internal_string_value($string);
- return '~' unless defined $string;
- return "''" unless length $string;
- if (Scalar::Util::looks_like_number($string)) {
- # keys and values that have been used as strings get quoted
- if ( $is_key || $has_string_flag ) {
- return qq['$string'];
- }
- else {
- return $string;
- }
- }
- if ( $string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/ ) {
- $string =~ s/\\/\\\\/g;
- $string =~ s/"/\\"/g;
- $string =~ s/\n/\\n/g;
- $string =~ s/[\x85]/\\N/g;
- $string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
- $string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge;
- return qq|"$string"|;
- }
- if ( $string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or
- $QUOTE{$string}
- ) {
- return "'$string'";
- }
- return $string;
-}
-
-sub _dump_array {
- my ($self, $array, $indent, $seen) = @_;
- if ( $seen->{refaddr($array)}++ ) {
- die \"CPAN::Meta::YAML does not support circular references";
- }
- my @lines = ();
- foreach my $el ( @$array ) {
- my $line = (' ' x $indent) . '-';
- my $type = ref $el;
- if ( ! $type ) {
- $line .= ' ' . $self->_dump_scalar( $el );
- push @lines, $line;
-
- } elsif ( $type eq 'ARRAY' ) {
- if ( @$el ) {
- push @lines, $line;
- push @lines, $self->_dump_array( $el, $indent + 1, $seen );
- } else {
- $line .= ' []';
- push @lines, $line;
- }
-
- } elsif ( $type eq 'HASH' ) {
- if ( keys %$el ) {
- push @lines, $line;
- push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
- } else {
- $line .= ' {}';
- push @lines, $line;
- }
-
- } else {
- die \"CPAN::Meta::YAML does not support $type references";
- }
- }
-
- @lines;
-}
-
-sub _dump_hash {
- my ($self, $hash, $indent, $seen) = @_;
- if ( $seen->{refaddr($hash)}++ ) {
- die \"CPAN::Meta::YAML does not support circular references";
- }
- my @lines = ();
- foreach my $name ( sort keys %$hash ) {
- my $el = $hash->{$name};
- my $line = (' ' x $indent) . $self->_dump_scalar($name, 1) . ":";
- my $type = ref $el;
- if ( ! $type ) {
- $line .= ' ' . $self->_dump_scalar( $el );
- push @lines, $line;
-
- } elsif ( $type eq 'ARRAY' ) {
- if ( @$el ) {
- push @lines, $line;
- push @lines, $self->_dump_array( $el, $indent + 1, $seen );
- } else {
- $line .= ' []';
- push @lines, $line;
- }
-
- } elsif ( $type eq 'HASH' ) {
- if ( keys %$el ) {
- push @lines, $line;
- push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
- } else {
- $line .= ' {}';
- push @lines, $line;
- }
-
- } else {
- die \"CPAN::Meta::YAML does not support $type references";
- }
- }
-
- @lines;
-}
-
-
-
-#####################################################################
-# DEPRECATED API methods:
-
-# Error storage (DEPRECATED as of 1.57)
-our $errstr = '';
-
-# Set error
-sub _error {
- require Carp;
- $errstr = $_[1];
- $errstr =~ s/ at \S+ line \d+.*//;
- Carp::croak( $errstr );
-}
-
-# Retrieve error
-my $errstr_warned;
-sub errstr {
- require Carp;
- Carp::carp( "CPAN::Meta::YAML->errstr and \$CPAN::Meta::YAML::errstr is deprecated" )
- unless $errstr_warned++;
- $errstr;
-}
-
-
-
-
-#####################################################################
-# Helper functions. Possibly not needed.
-
-
-# Use to detect nv or iv
-use B;
-
-# XXX-INGY Is flock CPAN::Meta::YAML's responsibility?
-# Some platforms can't flock :-(
-# XXX-XDG I think it is. When reading and writing files, we ought
-# to be locking whenever possible. People (foolishly) use YAML
-# files for things like session storage, which has race issues.
-my $HAS_FLOCK;
-sub _can_flock {
- if ( defined $HAS_FLOCK ) {
- return $HAS_FLOCK;
- }
- else {
- require Config;
- my $c = \%Config::Config;
- $HAS_FLOCK = grep { $c->{$_} } qw/d_flock d_fcntl_can_lock d_lockf/;
- require Fcntl if $HAS_FLOCK;
- return $HAS_FLOCK;
- }
-}
-
-
-# XXX-INGY Is this core in 5.8.1? Can we remove this?
-# XXX-XDG Scalar::Util 1.18 didn't land until 5.8.8, so we need this
-#####################################################################
-# Use Scalar::Util if possible, otherwise emulate it
-
-use Scalar::Util ();
-BEGIN {
- local $@;
- if ( eval { Scalar::Util->VERSION(1.18); } ) {
- *refaddr = *Scalar::Util::refaddr;
- }
- else {
- eval <<'END_PERL';
-# Scalar::Util failed to load or too old
-sub refaddr {
- my $pkg = ref($_[0]) or return undef;
- if ( !! UNIVERSAL::can($_[0], 'can') ) {
- bless $_[0], 'Scalar::Util::Fake';
- } else {
- $pkg = undef;
- }
- "$_[0]" =~ /0x(\w+)/;
- my $i = do { no warnings 'portable'; hex $1 };
- bless $_[0], $pkg if defined $pkg;
- $i;
-}
-END_PERL
- }
-}
-
-delete $CPAN::Meta::YAML::{refaddr};
-
-1;
-
-# XXX-INGY Doc notes I'm putting up here. Changing the doc when it's wrong
-# but leaving grey area stuff up here.
-#
-# I would like to change Read/Write to Load/Dump below without
-# changing the actual API names.
-#
-# It might be better to put Load/Dump API in the SYNOPSIS instead of the
-# dubious OO API.
-#
-# null and bool explanations may be outdated.
-
-=pod
-
-=encoding UTF-8
-
-=head1 NAME
-
-CPAN::Meta::YAML - Read and write a subset of YAML for CPAN Meta files
-
-=head1 VERSION
-
-version 0.018
-
-=head1 SYNOPSIS
-
- use CPAN::Meta::YAML;
-
- # reading a META file
- open $fh, "<:utf8", "META.yml";
- $yaml_text = do { local $/; <$fh> };
- $yaml = CPAN::Meta::YAML->read_string($yaml_text)
- or die CPAN::Meta::YAML->errstr;
-
- # finding the metadata
- $meta = $yaml->[0];
-
- # writing a META file
- $yaml_text = $yaml->write_string
- or die CPAN::Meta::YAML->errstr;
- open $fh, ">:utf8", "META.yml";
- print $fh $yaml_text;
-
-=head1 DESCRIPTION
-
-This module implements a subset of the YAML specification for use in reading
-and writing CPAN metadata files like F<META.yml> and F<MYMETA.yml>. It should
-not be used for any other general YAML parsing or generation task.
-
-NOTE: F<META.yml> (and F<MYMETA.yml>) files should be UTF-8 encoded. Users are
-responsible for proper encoding and decoding. In particular, the C<read> and
-C<write> methods do B<not> support UTF-8 and should not be used.
-
-=head1 SUPPORT
-
-This module is currently derived from L<YAML::Tiny> by Adam Kennedy. If
-there are bugs in how it parses a particular META.yml file, please file
-a bug report in the YAML::Tiny bugtracker:
-L<https://github.com/Perl-Toolchain-Gang/YAML-Tiny/issues>
-
-=head1 SEE ALSO
-
-L<YAML::Tiny>, L<YAML>, L<YAML::XS>
-
-=head1 AUTHORS
-
-=over 4
-
-=item *
-
-Adam Kennedy <adamk@cpan.org>
-
-=item *
-
-David Golden <dagolden@cpan.org>
-
-=back
-
-=head1 COPYRIGHT AND LICENSE
-
-This software is copyright (c) 2010 by Adam Kennedy.
-
-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__
-
-
-# ABSTRACT: Read and write a subset of YAML for CPAN Meta files
-
-
+++ /dev/null
-package JSON::PP;
-
-# JSON-2.0
-
-use 5.005;
-use strict;
-use base qw(Exporter);
-use overload ();
-
-use Carp ();
-use B ();
-#use Devel::Peek;
-
-$JSON::PP::VERSION = '2.27400';
-
-@JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);
-
-# instead of hash-access, i tried index-access for speed.
-# but this method is not faster than what i expected. so it will be changed.
-
-use constant P_ASCII => 0;
-use constant P_LATIN1 => 1;
-use constant P_UTF8 => 2;
-use constant P_INDENT => 3;
-use constant P_CANONICAL => 4;
-use constant P_SPACE_BEFORE => 5;
-use constant P_SPACE_AFTER => 6;
-use constant P_ALLOW_NONREF => 7;
-use constant P_SHRINK => 8;
-use constant P_ALLOW_BLESSED => 9;
-use constant P_CONVERT_BLESSED => 10;
-use constant P_RELAXED => 11;
-
-use constant P_LOOSE => 12;
-use constant P_ALLOW_BIGNUM => 13;
-use constant P_ALLOW_BAREKEY => 14;
-use constant P_ALLOW_SINGLEQUOTE => 15;
-use constant P_ESCAPE_SLASH => 16;
-use constant P_AS_NONBLESSED => 17;
-
-use constant P_ALLOW_UNKNOWN => 18;
-
-use constant OLD_PERL => $] < 5.008 ? 1 : 0;
-
-BEGIN {
- my @xs_compati_bit_properties = qw(
- latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink
- allow_blessed convert_blessed relaxed allow_unknown
- );
- my @pp_bit_properties = qw(
- allow_singlequote allow_bignum loose
- allow_barekey escape_slash as_nonblessed
- );
-
- # Perl version check, Unicode handling is enabled?
- # Helper module sets @JSON::PP::_properties.
- if ($] < 5.008 ) {
- my $helper = $] >= 5.006 ? 'JSON::PP::Compat5006' : 'JSON::PP::Compat5005';
- eval qq| require $helper |;
- if ($@) { Carp::croak $@; }
- }
-
- for my $name (@xs_compati_bit_properties, @pp_bit_properties) {
- my $flag_name = 'P_' . uc($name);
-
- eval qq/
- sub $name {
- my \$enable = defined \$_[1] ? \$_[1] : 1;
-
- if (\$enable) {
- \$_[0]->{PROPS}->[$flag_name] = 1;
- }
- else {
- \$_[0]->{PROPS}->[$flag_name] = 0;
- }
-
- \$_[0];
- }
-
- sub get_$name {
- \$_[0]->{PROPS}->[$flag_name] ? 1 : '';
- }
- /;
- }
-
-}
-
-
-
-# Functions
-
-my %encode_allow_method
- = map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash
- allow_blessed convert_blessed indent indent_length allow_bignum
- as_nonblessed
- /;
-my %decode_allow_method
- = map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum
- allow_barekey max_size relaxed/;
-
-
-my $JSON; # cache
-
-sub encode_json ($) { # encode
- ($JSON ||= __PACKAGE__->new->utf8)->encode(@_);
-}
-
-
-sub decode_json { # decode
- ($JSON ||= __PACKAGE__->new->utf8)->decode(@_);
-}
-
-# Obsoleted
-
-sub to_json($) {
- Carp::croak ("JSON::PP::to_json has been renamed to encode_json.");
-}
-
-
-sub from_json($) {
- Carp::croak ("JSON::PP::from_json has been renamed to decode_json.");
-}
-
-
-# Methods
-
-sub new {
- my $class = shift;
- my $self = {
- max_depth => 512,
- max_size => 0,
- indent => 0,
- FLAGS => 0,
- fallback => sub { encode_error('Invalid value. JSON can only reference.') },
- indent_length => 3,
- };
-
- bless $self, $class;
-}
-
-
-sub encode {
- return $_[0]->PP_encode_json($_[1]);
-}
-
-
-sub decode {
- return $_[0]->PP_decode_json($_[1], 0x00000000);
-}
-
-
-sub decode_prefix {
- return $_[0]->PP_decode_json($_[1], 0x00000001);
-}
-
-
-# accessor
-
-
-# pretty printing
-
-sub pretty {
- my ($self, $v) = @_;
- my $enable = defined $v ? $v : 1;
-
- if ($enable) { # indent_length(3) for JSON::XS compatibility
- $self->indent(1)->indent_length(3)->space_before(1)->space_after(1);
- }
- else {
- $self->indent(0)->space_before(0)->space_after(0);
- }
-
- $self;
-}
-
-# etc
-
-sub max_depth {
- my $max = defined $_[1] ? $_[1] : 0x80000000;
- $_[0]->{max_depth} = $max;
- $_[0];
-}
-
-
-sub get_max_depth { $_[0]->{max_depth}; }
-
-
-sub max_size {
- my $max = defined $_[1] ? $_[1] : 0;
- $_[0]->{max_size} = $max;
- $_[0];
-}
-
-
-sub get_max_size { $_[0]->{max_size}; }
-
-
-sub filter_json_object {
- $_[0]->{cb_object} = defined $_[1] ? $_[1] : 0;
- $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
- $_[0];
-}
-
-sub filter_json_single_key_object {
- if (@_ > 1) {
- $_[0]->{cb_sk_object}->{$_[1]} = $_[2];
- }
- $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
- $_[0];
-}
-
-sub indent_length {
- if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) {
- Carp::carp "The acceptable range of indent_length() is 0 to 15.";
- }
- else {
- $_[0]->{indent_length} = $_[1];
- }
- $_[0];
-}
-
-sub get_indent_length {
- $_[0]->{indent_length};
-}
-
-sub sort_by {
- $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1;
- $_[0];
-}
-
-sub allow_bigint {
- Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted.");
-}
-
-###############################
-
-###
-### Perl => JSON
-###
-
-
-{ # Convert
-
- my $max_depth;
- my $indent;
- my $ascii;
- my $latin1;
- my $utf8;
- my $space_before;
- my $space_after;
- my $canonical;
- my $allow_blessed;
- my $convert_blessed;
-
- my $indent_length;
- my $escape_slash;
- my $bignum;
- my $as_nonblessed;
-
- my $depth;
- my $indent_count;
- my $keysort;
-
-
- sub PP_encode_json {
- my $self = shift;
- my $obj = shift;
-
- $indent_count = 0;
- $depth = 0;
-
- my $idx = $self->{PROPS};
-
- ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed,
- $convert_blessed, $escape_slash, $bignum, $as_nonblessed)
- = @{$idx}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED,
- P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED];
-
- ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/};
-
- $keysort = $canonical ? sub { $a cmp $b } : undef;
-
- if ($self->{sort_by}) {
- $keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by}
- : $self->{sort_by} =~ /\D+/ ? $self->{sort_by}
- : sub { $a cmp $b };
- }
-
- encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")
- if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]);
-
- my $str = $self->object_to_json($obj);
-
- $str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible
-
- unless ($ascii or $latin1 or $utf8) {
- utf8::upgrade($str);
- }
-
- if ($idx->[ P_SHRINK ]) {
- utf8::downgrade($str, 1);
- }
-
- return $str;
- }
-
-
- sub object_to_json {
- my ($self, $obj) = @_;
- my $type = ref($obj);
-
- if($type eq 'HASH'){
- return $self->hash_to_json($obj);
- }
- elsif($type eq 'ARRAY'){
- return $self->array_to_json($obj);
- }
- elsif ($type) { # blessed object?
- if (blessed($obj)) {
-
- return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') );
-
- if ( $convert_blessed and $obj->can('TO_JSON') ) {
- my $result = $obj->TO_JSON();
- if ( defined $result and ref( $result ) ) {
- if ( refaddr( $obj ) eq refaddr( $result ) ) {
- encode_error( sprintf(
- "%s::TO_JSON method returned same object as was passed instead of a new one",
- ref $obj
- ) );
- }
- }
-
- return $self->object_to_json( $result );
- }
-
- return "$obj" if ( $bignum and _is_bignum($obj) );
- return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed.
-
- encode_error( sprintf("encountered object '%s', but neither allow_blessed "
- . "nor convert_blessed settings are enabled", $obj)
- ) unless ($allow_blessed);
-
- return 'null';
- }
- else {
- return $self->value_to_json($obj);
- }
- }
- else{
- return $self->value_to_json($obj);
- }
- }
-
-
- sub hash_to_json {
- my ($self, $obj) = @_;
- my @res;
-
- encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
- if (++$depth > $max_depth);
-
- my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
- my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : '');
-
- for my $k ( _sort( $obj ) ) {
- if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized
- push @res, string_to_json( $self, $k )
- . $del
- . ( $self->object_to_json( $obj->{$k} ) || $self->value_to_json( $obj->{$k} ) );
- }
-
- --$depth;
- $self->_down_indent() if ($indent);
-
- return '{' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . '}';
- }
-
-
- sub array_to_json {
- my ($self, $obj) = @_;
- my @res;
-
- encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
- if (++$depth > $max_depth);
-
- my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
-
- for my $v (@$obj){
- push @res, $self->object_to_json($v) || $self->value_to_json($v);
- }
-
- --$depth;
- $self->_down_indent() if ($indent);
-
- return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']';
- }
-
-
- sub value_to_json {
- my ($self, $value) = @_;
-
- return 'null' if(!defined $value);
-
- my $b_obj = B::svref_2object(\$value); # for round trip problem
- my $flags = $b_obj->FLAGS;
-
- return $value # as is
- if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV?
-
- my $type = ref($value);
-
- if(!$type){
- return string_to_json($self, $value);
- }
- elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){
- return $$value == 1 ? 'true' : 'false';
- }
- elsif ($type) {
- if ((overload::StrVal($value) =~ /=(\w+)/)[0]) {
- return $self->value_to_json("$value");
- }
-
- if ($type eq 'SCALAR' and defined $$value) {
- return $$value eq '1' ? 'true'
- : $$value eq '0' ? 'false'
- : $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null'
- : encode_error("cannot encode reference to scalar");
- }
-
- if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) {
- return 'null';
- }
- else {
- if ( $type eq 'SCALAR' or $type eq 'REF' ) {
- encode_error("cannot encode reference to scalar");
- }
- else {
- encode_error("encountered $value, but JSON can only represent references to arrays or hashes");
- }
- }
-
- }
- else {
- return $self->{fallback}->($value)
- if ($self->{fallback} and ref($self->{fallback}) eq 'CODE');
- return 'null';
- }
-
- }
-
-
- my %esc = (
- "\n" => '\n',
- "\r" => '\r',
- "\t" => '\t',
- "\f" => '\f',
- "\b" => '\b',
- "\"" => '\"',
- "\\" => '\\\\',
- "\'" => '\\\'',
- );
-
-
- sub string_to_json {
- my ($self, $arg) = @_;
-
- $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
- $arg =~ s/\//\\\//g if ($escape_slash);
- $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;
-
- if ($ascii) {
- $arg = JSON_PP_encode_ascii($arg);
- }
-
- if ($latin1) {
- $arg = JSON_PP_encode_latin1($arg);
- }
-
- if ($utf8) {
- utf8::encode($arg);
- }
-
- return '"' . $arg . '"';
- }
-
-
- sub blessed_to_json {
- my $reftype = reftype($_[1]) || '';
- if ($reftype eq 'HASH') {
- return $_[0]->hash_to_json($_[1]);
- }
- elsif ($reftype eq 'ARRAY') {
- return $_[0]->array_to_json($_[1]);
- }
- else {
- return 'null';
- }
- }
-
-
- sub encode_error {
- my $error = shift;
- Carp::croak "$error";
- }
-
-
- sub _sort {
- defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]};
- }
-
-
- sub _up_indent {
- my $self = shift;
- my $space = ' ' x $indent_length;
-
- my ($pre,$post) = ('','');
-
- $post = "\n" . $space x $indent_count;
-
- $indent_count++;
-
- $pre = "\n" . $space x $indent_count;
-
- return ($pre,$post);
- }
-
-
- sub _down_indent { $indent_count--; }
-
-
- sub PP_encode_box {
- {
- depth => $depth,
- indent_count => $indent_count,
- };
- }
-
-} # Convert
-
-
-sub _encode_ascii {
- join('',
- map {
- $_ <= 127 ?
- chr($_) :
- $_ <= 65535 ?
- sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
- } unpack('U*', $_[0])
- );
-}
-
-
-sub _encode_latin1 {
- join('',
- map {
- $_ <= 255 ?
- chr($_) :
- $_ <= 65535 ?
- sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
- } unpack('U*', $_[0])
- );
-}
-
-
-sub _encode_surrogates { # from perlunicode
- my $uni = $_[0] - 0x10000;
- return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
-}
-
-
-sub _is_bignum {
- $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat');
-}
-
-
-
-#
-# JSON => Perl
-#
-
-my $max_intsize;
-
-BEGIN {
- my $checkint = 1111;
- for my $d (5..64) {
- $checkint .= 1;
- my $int = eval qq| $checkint |;
- if ($int =~ /[eE]/) {
- $max_intsize = $d - 1;
- last;
- }
- }
-}
-
-{ # PARSE
-
- my %escapes = ( # by Jeremy Muhlich <jmuhlich [at] bitflood.org>
- b => "\x8",
- t => "\x9",
- n => "\xA",
- f => "\xC",
- r => "\xD",
- '\\' => '\\',
- '"' => '"',
- '/' => '/',
- );
-
- my $text; # json data
- my $at; # offset
- my $ch; # first character
- my $len; # text length (changed according to UTF8 or NON UTF8)
- # INTERNAL
- my $depth; # nest counter
- my $encoding; # json text encoding
- my $is_valid_utf8; # temp variable
- my $utf8_len; # utf8 byte length
- # FLAGS
- my $utf8; # must be utf8
- my $max_depth; # max nest number of objects and arrays
- my $max_size;
- my $relaxed;
- my $cb_object;
- my $cb_sk_object;
-
- my $F_HOOK;
-
- my $allow_bigint; # using Math::BigInt
- my $singlequote; # loosely quoting
- my $loose; #
- my $allow_barekey; # bareKey
-
- # $opt flag
- # 0x00000001 .... decode_prefix
- # 0x10000000 .... incr_parse
-
- sub PP_decode_json {
- my ($self, $opt); # $opt is an effective flag during this decode_json.
-
- ($self, $text, $opt) = @_;
-
- ($at, $ch, $depth) = (0, '', 0);
-
- if ( !defined $text or ref $text ) {
- decode_error("malformed JSON string, neither array, object, number, string or atom");
- }
-
- my $idx = $self->{PROPS};
-
- ($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote)
- = @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE];
-
- if ( $utf8 ) {
- utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry");
- }
- else {
- utf8::upgrade( $text );
- utf8::encode( $text );
- }
-
- $len = length $text;
-
- ($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK)
- = @{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/};
-
- if ($max_size > 1) {
- use bytes;
- my $bytes = length $text;
- decode_error(
- sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s"
- , $bytes, $max_size), 1
- ) if ($bytes > $max_size);
- }
-
- # Currently no effect
- # should use regexp
- my @octets = unpack('C4', $text);
- $encoding = ( $octets[0] and $octets[1]) ? 'UTF-8'
- : (!$octets[0] and $octets[1]) ? 'UTF-16BE'
- : (!$octets[0] and !$octets[1]) ? 'UTF-32BE'
- : ( $octets[2] ) ? 'UTF-16LE'
- : (!$octets[2] ) ? 'UTF-32LE'
- : 'unknown';
-
- white(); # remove head white space
-
- my $valid_start = defined $ch; # Is there a first character for JSON structure?
-
- my $result = value();
-
- return undef if ( !$result && ( $opt & 0x10000000 ) ); # for incr_parse
-
- decode_error("malformed JSON string, neither array, object, number, string or atom") unless $valid_start;
-
- if ( !$idx->[ P_ALLOW_NONREF ] and !ref $result ) {
- decode_error(
- 'JSON text must be an object or array (but found number, string, true, false or null,'
- . ' use allow_nonref to allow this)', 1);
- }
-
- Carp::croak('something wrong.') if $len < $at; # we won't arrive here.
-
- my $consumed = defined $ch ? $at - 1 : $at; # consumed JSON text length
-
- white(); # remove tail white space
-
- if ( $ch ) {
- return ( $result, $consumed ) if ($opt & 0x00000001); # all right if decode_prefix
- decode_error("garbage after JSON object");
- }
-
- ( $opt & 0x00000001 ) ? ( $result, $consumed ) : $result;
- }
-
-
- sub next_chr {
- return $ch = undef if($at >= $len);
- $ch = substr($text, $at++, 1);
- }
-
-
- sub value {
- white();
- return if(!defined $ch);
- return object() if($ch eq '{');
- return array() if($ch eq '[');
- return string() if($ch eq '"' or ($singlequote and $ch eq "'"));
- return number() if($ch =~ /[0-9]/ or $ch eq '-');
- return word();
- }
-
- sub string {
- my ($i, $s, $t, $u);
- my $utf16;
- my $is_utf8;
-
- ($is_valid_utf8, $utf8_len) = ('', 0);
-
- $s = ''; # basically UTF8 flag on
-
- if($ch eq '"' or ($singlequote and $ch eq "'")){
- my $boundChar = $ch;
-
- OUTER: while( defined(next_chr()) ){
-
- if($ch eq $boundChar){
- next_chr();
-
- if ($utf16) {
- decode_error("missing low surrogate character in surrogate pair");
- }
-
- utf8::decode($s) if($is_utf8);
-
- return $s;
- }
- elsif($ch eq '\\'){
- next_chr();
- if(exists $escapes{$ch}){
- $s .= $escapes{$ch};
- }
- elsif($ch eq 'u'){ # UNICODE handling
- my $u = '';
-
- for(1..4){
- $ch = next_chr();
- last OUTER if($ch !~ /[0-9a-fA-F]/);
- $u .= $ch;
- }
-
- # U+D800 - U+DBFF
- if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate?
- $utf16 = $u;
- }
- # U+DC00 - U+DFFF
- elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate?
- unless (defined $utf16) {
- decode_error("missing high surrogate character in surrogate pair");
- }
- $is_utf8 = 1;
- $s .= JSON_PP_decode_surrogates($utf16, $u) || next;
- $utf16 = undef;
- }
- else {
- if (defined $utf16) {
- decode_error("surrogate pair expected");
- }
-
- if ( ( my $hex = hex( $u ) ) > 127 ) {
- $is_utf8 = 1;
- $s .= JSON_PP_decode_unicode($u) || next;
- }
- else {
- $s .= chr $hex;
- }
- }
-
- }
- else{
- unless ($loose) {
- $at -= 2;
- decode_error('illegal backslash escape sequence in string');
- }
- $s .= $ch;
- }
- }
- else{
-
- if ( ord $ch > 127 ) {
- unless( $ch = is_valid_utf8($ch) ) {
- $at -= 1;
- decode_error("malformed UTF-8 character in JSON string");
- }
- else {
- $at += $utf8_len - 1;
- }
-
- $is_utf8 = 1;
- }
-
- if (!$loose) {
- if ($ch =~ /[\x00-\x1f\x22\x5c]/) { # '/' ok
- $at--;
- decode_error('invalid character encountered while parsing JSON string');
- }
- }
-
- $s .= $ch;
- }
- }
- }
-
- decode_error("unexpected end of string while parsing JSON string");
- }
-
-
- sub white {
- while( defined $ch ){
- if($ch le ' '){
- next_chr();
- }
- elsif($ch eq '/'){
- next_chr();
- if(defined $ch and $ch eq '/'){
- 1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r");
- }
- elsif(defined $ch and $ch eq '*'){
- next_chr();
- while(1){
- if(defined $ch){
- if($ch eq '*'){
- if(defined(next_chr()) and $ch eq '/'){
- next_chr();
- last;
- }
- }
- else{
- next_chr();
- }
- }
- else{
- decode_error("Unterminated comment");
- }
- }
- next;
- }
- else{
- $at--;
- decode_error("malformed JSON string, neither array, object, number, string or atom");
- }
- }
- else{
- if ($relaxed and $ch eq '#') { # correctly?
- pos($text) = $at;
- $text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g;
- $at = pos($text);
- next_chr;
- next;
- }
-
- last;
- }
- }
- }
-
-
- sub array {
- my $a = $_[0] || []; # you can use this code to use another array ref object.
-
- decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
- if (++$depth > $max_depth);
-
- next_chr();
- white();
-
- if(defined $ch and $ch eq ']'){
- --$depth;
- next_chr();
- return $a;
- }
- else {
- while(defined($ch)){
- push @$a, value();
-
- white();
-
- if (!defined $ch) {
- last;
- }
-
- if($ch eq ']'){
- --$depth;
- next_chr();
- return $a;
- }
-
- if($ch ne ','){
- last;
- }
-
- next_chr();
- white();
-
- if ($relaxed and $ch eq ']') {
- --$depth;
- next_chr();
- return $a;
- }
-
- }
- }
-
- decode_error(", or ] expected while parsing array");
- }
-
-
- sub object {
- my $o = $_[0] || {}; # you can use this code to use another hash ref object.
- my $k;
-
- decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
- if (++$depth > $max_depth);
- next_chr();
- white();
-
- if(defined $ch and $ch eq '}'){
- --$depth;
- next_chr();
- if ($F_HOOK) {
- return _json_object_hook($o);
- }
- return $o;
- }
- else {
- while (defined $ch) {
- $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string();
- white();
-
- if(!defined $ch or $ch ne ':'){
- $at--;
- decode_error("':' expected");
- }
-
- next_chr();
- $o->{$k} = value();
- white();
-
- last if (!defined $ch);
-
- if($ch eq '}'){
- --$depth;
- next_chr();
- if ($F_HOOK) {
- return _json_object_hook($o);
- }
- return $o;
- }
-
- if($ch ne ','){
- last;
- }
-
- next_chr();
- white();
-
- if ($relaxed and $ch eq '}') {
- --$depth;
- next_chr();
- if ($F_HOOK) {
- return _json_object_hook($o);
- }
- return $o;
- }
-
- }
-
- }
-
- $at--;
- decode_error(", or } expected while parsing object/hash");
- }
-
-
- sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition
- my $key;
- while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){
- $key .= $ch;
- next_chr();
- }
- return $key;
- }
-
-
- sub word {
- my $word = substr($text,$at-1,4);
-
- if($word eq 'true'){
- $at += 3;
- next_chr;
- return $JSON::PP::true;
- }
- elsif($word eq 'null'){
- $at += 3;
- next_chr;
- return undef;
- }
- elsif($word eq 'fals'){
- $at += 3;
- if(substr($text,$at,1) eq 'e'){
- $at++;
- next_chr;
- return $JSON::PP::false;
- }
- }
-
- $at--; # for decode_error report
-
- decode_error("'null' expected") if ($word =~ /^n/);
- decode_error("'true' expected") if ($word =~ /^t/);
- decode_error("'false' expected") if ($word =~ /^f/);
- decode_error("malformed JSON string, neither array, object, number, string or atom");
- }
-
-
- sub number {
- my $n = '';
- my $v;
- my $is_dec;
-
- # According to RFC4627, hex or oct digits are invalid.
- if($ch eq '0'){
- my $peek = substr($text,$at,1);
- my $hex = $peek =~ /[xX]/; # 0 or 1
-
- if($hex){
- decode_error("malformed number (leading zero must not be followed by another digit)");
- ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/);
- }
- else{ # oct
- ($n) = ( substr($text, $at) =~ /^([0-7]+)/);
- if (defined $n and length $n > 1) {
- decode_error("malformed number (leading zero must not be followed by another digit)");
- }
- }
-
- if(defined $n and length($n)){
- if (!$hex and length($n) == 1) {
- decode_error("malformed number (leading zero must not be followed by another digit)");
- }
- $at += length($n) + $hex;
- next_chr;
- return $hex ? hex($n) : oct($n);
- }
- }
-
- if($ch eq '-'){
- $n = '-';
- next_chr;
- if (!defined $ch or $ch !~ /\d/) {
- decode_error("malformed number (no digits after initial minus)");
- }
- }
-
- while(defined $ch and $ch =~ /\d/){
- $n .= $ch;
- next_chr;
- }
-
- if(defined $ch and $ch eq '.'){
- $n .= '.';
- $is_dec = 1;
-
- next_chr;
- if (!defined $ch or $ch !~ /\d/) {
- decode_error("malformed number (no digits after decimal point)");
- }
- else {
- $n .= $ch;
- }
-
- while(defined(next_chr) and $ch =~ /\d/){
- $n .= $ch;
- }
- }
-
- if(defined $ch and ($ch eq 'e' or $ch eq 'E')){
- $n .= $ch;
- next_chr;
-
- if(defined($ch) and ($ch eq '+' or $ch eq '-')){
- $n .= $ch;
- next_chr;
- if (!defined $ch or $ch =~ /\D/) {
- decode_error("malformed number (no digits after exp sign)");
- }
- $n .= $ch;
- }
- elsif(defined($ch) and $ch =~ /\d/){
- $n .= $ch;
- }
- else {
- decode_error("malformed number (no digits after exp sign)");
- }
-
- while(defined(next_chr) and $ch =~ /\d/){
- $n .= $ch;
- }
-
- }
-
- $v .= $n;
-
- if ($v !~ /[.eE]/ and length $v > $max_intsize) {
- if ($allow_bigint) { # from Adam Sussman
- require Math::BigInt;
- return Math::BigInt->new($v);
- }
- else {
- return "$v";
- }
- }
- elsif ($allow_bigint) {
- require Math::BigFloat;
- return Math::BigFloat->new($v);
- }
-
- return $is_dec ? $v/1.0 : 0+$v;
- }
-
-
- sub is_valid_utf8 {
-
- $utf8_len = $_[0] =~ /[\x00-\x7F]/ ? 1
- : $_[0] =~ /[\xC2-\xDF]/ ? 2
- : $_[0] =~ /[\xE0-\xEF]/ ? 3
- : $_[0] =~ /[\xF0-\xF4]/ ? 4
- : 0
- ;
-
- return unless $utf8_len;
-
- my $is_valid_utf8 = substr($text, $at - 1, $utf8_len);
-
- return ( $is_valid_utf8 =~ /^(?:
- [\x00-\x7F]
- |[\xC2-\xDF][\x80-\xBF]
- |[\xE0][\xA0-\xBF][\x80-\xBF]
- |[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
- |[\xED][\x80-\x9F][\x80-\xBF]
- |[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
- |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
- |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
- |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
- )$/x ) ? $is_valid_utf8 : '';
- }
-
-
- sub decode_error {
- my $error = shift;
- my $no_rep = shift;
- my $str = defined $text ? substr($text, $at) : '';
- my $mess = '';
- my $type = $] >= 5.008 ? 'U*'
- : $] < 5.006 ? 'C*'
- : utf8::is_utf8( $str ) ? 'U*' # 5.6
- : 'C*'
- ;
-
- for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ?
- $mess .= $c == 0x07 ? '\a'
- : $c == 0x09 ? '\t'
- : $c == 0x0a ? '\n'
- : $c == 0x0d ? '\r'
- : $c == 0x0c ? '\f'
- : $c < 0x20 ? sprintf('\x{%x}', $c)
- : $c == 0x5c ? '\\\\'
- : $c < 0x80 ? chr($c)
- : sprintf('\x{%x}', $c)
- ;
- if ( length $mess >= 20 ) {
- $mess .= '...';
- last;
- }
- }
-
- unless ( length $mess ) {
- $mess = '(end of string)';
- }
-
- Carp::croak (
- $no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")"
- );
-
- }
-
-
- sub _json_object_hook {
- my $o = $_[0];
- my @ks = keys %{$o};
-
- if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) {
- my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} );
- if (@val == 1) {
- return $val[0];
- }
- }
-
- my @val = $cb_object->($o) if ($cb_object);
- if (@val == 0 or @val > 1) {
- return $o;
- }
- else {
- return $val[0];
- }
- }
-
-
- sub PP_decode_box {
- {
- text => $text,
- at => $at,
- ch => $ch,
- len => $len,
- depth => $depth,
- encoding => $encoding,
- is_valid_utf8 => $is_valid_utf8,
- };
- }
-
-} # PARSE
-
-
-sub _decode_surrogates { # from perlunicode
- my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00);
- my $un = pack('U*', $uni);
- utf8::encode( $un );
- return $un;
-}
-
-
-sub _decode_unicode {
- my $un = pack('U', hex shift);
- utf8::encode( $un );
- return $un;
-}
-
-#
-# Setup for various Perl versions (the code from JSON::PP58)
-#
-
-BEGIN {
-
- unless ( defined &utf8::is_utf8 ) {
- require Encode;
- *utf8::is_utf8 = *Encode::is_utf8;
- }
-
- if ( $] >= 5.008 ) {
- *JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii;
- *JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1;
- *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates;
- *JSON::PP::JSON_PP_decode_unicode = \&_decode_unicode;
- }
-
- if ($] >= 5.008 and $] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken.
- package JSON::PP;
- require subs;
- subs->import('join');
- eval q|
- sub join {
- return '' if (@_ < 2);
- my $j = shift;
- my $str = shift;
- for (@_) { $str .= $j . $_; }
- return $str;
- }
- |;
- }
-
-
- sub JSON::PP::incr_parse {
- local $Carp::CarpLevel = 1;
- ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
- }
-
-
- sub JSON::PP::incr_skip {
- ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
- }
-
-
- sub JSON::PP::incr_reset {
- ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
- }
-
- eval q{
- sub JSON::PP::incr_text : lvalue {
- $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
-
- if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
- Carp::croak("incr_text cannot be called when the incremental parser already started parsing");
- }
- $_[0]->{_incr_parser}->{incr_text};
- }
- } if ( $] >= 5.006 );
-
-} # Setup for various Perl versions (the code from JSON::PP58)
-
-
-###############################
-# Utilities
-#
-
-BEGIN {
- eval 'require Scalar::Util';
- unless($@){
- *JSON::PP::blessed = \&Scalar::Util::blessed;
- *JSON::PP::reftype = \&Scalar::Util::reftype;
- *JSON::PP::refaddr = \&Scalar::Util::refaddr;
- }
- else{ # This code is from Sclar::Util.
- # warn $@;
- eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';
- *JSON::PP::blessed = sub {
- local($@, $SIG{__DIE__}, $SIG{__WARN__});
- ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef;
- };
- my %tmap = qw(
- B::NULL SCALAR
- B::HV HASH
- B::AV ARRAY
- B::CV CODE
- B::IO IO
- B::GV GLOB
- B::REGEXP REGEXP
- );
- *JSON::PP::reftype = sub {
- my $r = shift;
-
- return undef unless length(ref($r));
-
- my $t = ref(B::svref_2object($r));
-
- return
- exists $tmap{$t} ? $tmap{$t}
- : length(ref($$r)) ? 'REF'
- : 'SCALAR';
- };
- *JSON::PP::refaddr = sub {
- return undef unless length(ref($_[0]));
-
- my $addr;
- if(defined(my $pkg = blessed($_[0]))) {
- $addr .= bless $_[0], 'Scalar::Util::Fake';
- bless $_[0], $pkg;
- }
- else {
- $addr .= $_[0]
- }
-
- $addr =~ /0x(\w+)/;
- local $^W;
- #no warnings 'portable';
- hex($1);
- }
- }
-}
-
-
-# shamelessly copied and modified from JSON::XS code.
-
-$JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
-$JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };
-
-sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); }
-
-sub true { $JSON::PP::true }
-sub false { $JSON::PP::false }
-sub null { undef; }
-
-###############################
-
-package JSON::PP::Boolean;
-
-use overload (
- "0+" => sub { ${$_[0]} },
- "++" => sub { $_[0] = ${$_[0]} + 1 },
- "--" => sub { $_[0] = ${$_[0]} - 1 },
- fallback => 1,
-);
-
-
-###############################
-
-package JSON::PP::IncrParser;
-
-use strict;
-
-use constant INCR_M_WS => 0; # initial whitespace skipping
-use constant INCR_M_STR => 1; # inside string
-use constant INCR_M_BS => 2; # inside backslash
-use constant INCR_M_JSON => 3; # outside anything, count nesting
-use constant INCR_M_C0 => 4;
-use constant INCR_M_C1 => 5;
-
-$JSON::PP::IncrParser::VERSION = '1.01';
-
-my $unpack_format = $] < 5.006 ? 'C*' : 'U*';
-
-sub new {
- my ( $class ) = @_;
-
- bless {
- incr_nest => 0,
- incr_text => undef,
- incr_parsing => 0,
- incr_p => 0,
- }, $class;
-}
-
-
-sub incr_parse {
- my ( $self, $coder, $text ) = @_;
-
- $self->{incr_text} = '' unless ( defined $self->{incr_text} );
-
- if ( defined $text ) {
- if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) {
- utf8::upgrade( $self->{incr_text} ) ;
- utf8::decode( $self->{incr_text} ) ;
- }
- $self->{incr_text} .= $text;
- }
-
-
- my $max_size = $coder->get_max_size;
-
- if ( defined wantarray ) {
-
- $self->{incr_mode} = INCR_M_WS unless defined $self->{incr_mode};
-
- if ( wantarray ) {
- my @ret;
-
- $self->{incr_parsing} = 1;
-
- do {
- push @ret, $self->_incr_parse( $coder, $self->{incr_text} );
-
- unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) {
- $self->{incr_mode} = INCR_M_WS if $self->{incr_mode} != INCR_M_STR;
- }
-
- } until ( length $self->{incr_text} >= $self->{incr_p} );
-
- $self->{incr_parsing} = 0;
-
- return @ret;
- }
- else { # in scalar context
- $self->{incr_parsing} = 1;
- my $obj = $self->_incr_parse( $coder, $self->{incr_text} );
- $self->{incr_parsing} = 0 if defined $obj; # pointed by Martin J. Evans
- return $obj ? $obj : undef; # $obj is an empty string, parsing was completed.
- }
-
- }
-
-}
-
-
-sub _incr_parse {
- my ( $self, $coder, $text, $skip ) = @_;
- my $p = $self->{incr_p};
- my $restore = $p;
-
- my @obj;
- my $len = length $text;
-
- if ( $self->{incr_mode} == INCR_M_WS ) {
- while ( $len > $p ) {
- my $s = substr( $text, $p, 1 );
- $p++ and next if ( 0x20 >= unpack($unpack_format, $s) );
- $self->{incr_mode} = INCR_M_JSON;
- last;
- }
- }
-
- while ( $len > $p ) {
- my $s = substr( $text, $p++, 1 );
-
- if ( $s eq '"' ) {
- if (substr( $text, $p - 2, 1 ) eq '\\' ) {
- next;
- }
-
- if ( $self->{incr_mode} != INCR_M_STR ) {
- $self->{incr_mode} = INCR_M_STR;
- }
- else {
- $self->{incr_mode} = INCR_M_JSON;
- unless ( $self->{incr_nest} ) {
- last;
- }
- }
- }
-
- if ( $self->{incr_mode} == INCR_M_JSON ) {
-
- if ( $s eq '[' or $s eq '{' ) {
- if ( ++$self->{incr_nest} > $coder->get_max_depth ) {
- Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)');
- }
- }
- elsif ( $s eq ']' or $s eq '}' ) {
- last if ( --$self->{incr_nest} <= 0 );
- }
- elsif ( $s eq '#' ) {
- while ( $len > $p ) {
- last if substr( $text, $p++, 1 ) eq "\n";
- }
- }
-
- }
-
- }
-
- $self->{incr_p} = $p;
-
- return if ( $self->{incr_mode} == INCR_M_STR and not $self->{incr_nest} );
- return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 );
-
- return '' unless ( length substr( $self->{incr_text}, 0, $p ) );
-
- local $Carp::CarpLevel = 2;
-
- $self->{incr_p} = $restore;
- $self->{incr_c} = $p;
-
- my ( $obj, $tail ) = $coder->PP_decode_json( substr( $self->{incr_text}, 0, $p ), 0x10000001 );
-
- $self->{incr_text} = substr( $self->{incr_text}, $p );
- $self->{incr_p} = 0;
-
- return $obj || '';
-}
-
-
-sub incr_text {
- if ( $_[0]->{incr_parsing} ) {
- Carp::croak("incr_text cannot be called when the incremental parser already started parsing");
- }
- $_[0]->{incr_text};
-}
-
-
-sub incr_skip {
- my $self = shift;
- $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} );
- $self->{incr_p} = 0;
-}
-
-
-sub incr_reset {
- my $self = shift;
- $self->{incr_text} = undef;
- $self->{incr_p} = 0;
- $self->{incr_mode} = 0;
- $self->{incr_nest} = 0;
- $self->{incr_parsing} = 0;
-}
-
-###############################
-
-
-1;
-__END__
-=pod
-
-=head1 NAME
-
-JSON::PP - JSON::XS compatible pure-Perl module.
-
-=head1 SYNOPSIS
-
- use JSON::PP;
-
- # exported functions, they croak on error
- # and expect/generate UTF-8
-
- $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref;
- $perl_hash_or_arrayref = decode_json $utf8_encoded_json_text;
-
- # OO-interface
-
- $coder = JSON::PP->new->ascii->pretty->allow_nonref;
-
- $json_text = $json->encode( $perl_scalar );
- $perl_scalar = $json->decode( $json_text );
-
- $pretty_printed = $json->pretty->encode( $perl_scalar ); # pretty-printing
-
- # Note that JSON version 2.0 and above will automatically use
- # JSON::XS or JSON::PP, so you should be able to just:
-
- use JSON;
-
-
-=head1 VERSION
-
- 2.27400
-
-L<JSON::XS> 2.27 (~2.30) compatible.
-
-=head1 NOTE
-
-JSON::PP had been included in JSON distribution (CPAN module).
-It was a perl core module in Perl 5.14.
-
-=head1 DESCRIPTION
-
-This module is L<JSON::XS> compatible pure Perl module.
-(Perl 5.8 or later is recommended)
-
-JSON::XS is the fastest and most proper JSON module on CPAN.
-It is written by Marc Lehmann in C, so must be compiled and
-installed in the used environment.
-
-JSON::PP is a pure-Perl module and has compatibility to JSON::XS.
-
-
-=head2 FEATURES
-
-=over
-
-=item * correct unicode handling
-
-This module knows how to handle Unicode (depending on Perl version).
-
-See to L<JSON::XS/A FEW NOTES ON UNICODE AND PERL> and L<UNICODE HANDLING ON PERLS>.
-
-
-=item * round-trip integrity
-
-When you serialise a perl data structure using only data types supported
-by JSON and Perl, the deserialised data structure is identical on the Perl
-level. (e.g. the string "2.0" doesn't suddenly become "2" just because
-it looks like a number). There I<are> minor exceptions to this, read the
-MAPPING section below to learn about those.
-
-
-=item * strict checking of JSON correctness
-
-There is no guessing, no generating of illegal JSON texts by default,
-and only JSON is accepted as input by default (the latter is a security feature).
-But when some options are set, loose checking features are available.
-
-=back
-
-=head1 FUNCTIONAL INTERFACE
-
-Some documents are copied and modified from L<JSON::XS/FUNCTIONAL INTERFACE>.
-
-=head2 encode_json
-
- $json_text = encode_json $perl_scalar
-
-Converts the given Perl data structure to a UTF-8 encoded, binary string.
-
-This function call is functionally identical to:
-
- $json_text = JSON::PP->new->utf8->encode($perl_scalar)
-
-=head2 decode_json
-
- $perl_scalar = decode_json $json_text
-
-The opposite of C<encode_json>: expects an UTF-8 (binary) string and tries
-to parse that as an UTF-8 encoded JSON text, returning the resulting
-reference.
-
-This function call is functionally identical to:
-
- $perl_scalar = JSON::PP->new->utf8->decode($json_text)
-
-=head2 JSON::PP::is_bool
-
- $is_boolean = JSON::PP::is_bool($scalar)
-
-Returns true if the passed scalar represents either JSON::PP::true or
-JSON::PP::false, two constants that act like C<1> and C<0> respectively
-and are also used to represent JSON C<true> and C<false> in Perl strings.
-
-=head2 JSON::PP::true
-
-Returns JSON true value which is blessed object.
-It C<isa> JSON::PP::Boolean object.
-
-=head2 JSON::PP::false
-
-Returns JSON false value which is blessed object.
-It C<isa> JSON::PP::Boolean object.
-
-=head2 JSON::PP::null
-
-Returns C<undef>.
-
-See L<MAPPING>, below, for more information on how JSON values are mapped to
-Perl.
-
-
-=head1 HOW DO I DECODE A DATA FROM OUTER AND ENCODE TO OUTER
-
-This section supposes that your perl version is 5.8 or later.
-
-If you know a JSON text from an outer world - a network, a file content, and so on,
-is encoded in UTF-8, you should use C<decode_json> or C<JSON> module object
-with C<utf8> enabled. And the decoded result will contain UNICODE characters.
-
- # from network
- my $json = JSON::PP->new->utf8;
- my $json_text = CGI->new->param( 'json_data' );
- my $perl_scalar = $json->decode( $json_text );
-
- # from file content
- local $/;
- open( my $fh, '<', 'json.data' );
- $json_text = <$fh>;
- $perl_scalar = decode_json( $json_text );
-
-If an outer data is not encoded in UTF-8, firstly you should C<decode> it.
-
- use Encode;
- local $/;
- open( my $fh, '<', 'json.data' );
- my $encoding = 'cp932';
- my $unicode_json_text = decode( $encoding, <$fh> ); # UNICODE
-
- # or you can write the below code.
- #
- # open( my $fh, "<:encoding($encoding)", 'json.data' );
- # $unicode_json_text = <$fh>;
-
-In this case, C<$unicode_json_text> is of course UNICODE string.
-So you B<cannot> use C<decode_json> nor C<JSON> module object with C<utf8> enabled.
-Instead of them, you use C<JSON> module object with C<utf8> disable.
-
- $perl_scalar = $json->utf8(0)->decode( $unicode_json_text );
-
-Or C<encode 'utf8'> and C<decode_json>:
-
- $perl_scalar = decode_json( encode( 'utf8', $unicode_json_text ) );
- # this way is not efficient.
-
-And now, you want to convert your C<$perl_scalar> into JSON data and
-send it to an outer world - a network or a file content, and so on.
-
-Your data usually contains UNICODE strings and you want the converted data to be encoded
-in UTF-8, you should use C<encode_json> or C<JSON> module object with C<utf8> enabled.
-
- print encode_json( $perl_scalar ); # to a network? file? or display?
- # or
- print $json->utf8->encode( $perl_scalar );
-
-If C<$perl_scalar> does not contain UNICODE but C<$encoding>-encoded strings
-for some reason, then its characters are regarded as B<latin1> for perl
-(because it does not concern with your $encoding).
-You B<cannot> use C<encode_json> nor C<JSON> module object with C<utf8> enabled.
-Instead of them, you use C<JSON> module object with C<utf8> disable.
-Note that the resulted text is a UNICODE string but no problem to print it.
-
- # $perl_scalar contains $encoding encoded string values
- $unicode_json_text = $json->utf8(0)->encode( $perl_scalar );
- # $unicode_json_text consists of characters less than 0x100
- print $unicode_json_text;
-
-Or C<decode $encoding> all string values and C<encode_json>:
-
- $perl_scalar->{ foo } = decode( $encoding, $perl_scalar->{ foo } );
- # ... do it to each string values, then encode_json
- $json_text = encode_json( $perl_scalar );
-
-This method is a proper way but probably not efficient.
-
-See to L<Encode>, L<perluniintro>.
-
-
-=head1 METHODS
-
-Basically, check to L<JSON> or L<JSON::XS>.
-
-=head2 new
-
- $json = JSON::PP->new
-
-Returns a new JSON::PP object that can be used to de/encode JSON
-strings.
-
-All boolean flags described below are by default I<disabled>.
-
-The mutators for flags all return the JSON object again and thus calls can
-be chained:
-
- my $json = JSON::PP->new->utf8->space_after->encode({a => [1,2]})
- => {"a": [1, 2]}
-
-=head2 ascii
-
- $json = $json->ascii([$enable])
-
- $enabled = $json->get_ascii
-
-If $enable is true (or missing), then the encode method will not generate characters outside
-the code range 0..127. Any Unicode characters outside that range will be escaped using either
-a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627.
-(See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>).
-
-In Perl 5.005, there is no character having high value (more than 255).
-See to L<UNICODE HANDLING ON PERLS>.
-
-If $enable is false, then the encode method will not escape Unicode characters unless
-required by the JSON syntax or other flags. This results in a faster and more compact format.
-
- JSON::PP->new->ascii(1)->encode([chr 0x10401])
- => ["\ud801\udc01"]
-
-=head2 latin1
-
- $json = $json->latin1([$enable])
-
- $enabled = $json->get_latin1
-
-If $enable is true (or missing), then the encode method will encode the resulting JSON
-text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255.
-
-If $enable is false, then the encode method will not escape Unicode characters
-unless required by the JSON syntax or other flags.
-
- JSON::XS->new->latin1->encode (["\x{89}\x{abc}"]
- => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not)
-
-See to L<UNICODE HANDLING ON PERLS>.
-
-=head2 utf8
-
- $json = $json->utf8([$enable])
-
- $enabled = $json->get_utf8
-
-If $enable is true (or missing), then the encode method will encode the JSON result
-into UTF-8, as required by many protocols, while the decode method expects to be handled
-an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any
-characters outside the range 0..255, they are thus useful for bytewise/binary I/O.
-
-(In Perl 5.005, any character outside the range 0..255 does not exist.
-See to L<UNICODE HANDLING ON PERLS>.)
-
-In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32
-encoding families, as described in RFC4627.
-
-If $enable is false, then the encode method will return the JSON string as a (non-encoded)
-Unicode string, while decode expects thus a Unicode string. Any decoding or encoding
-(e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module.
-
-Example, output UTF-16BE-encoded JSON:
-
- use Encode;
- $jsontext = encode "UTF-16BE", JSON::PP->new->encode ($object);
-
-Example, decode UTF-32LE-encoded JSON:
-
- use Encode;
- $object = JSON::PP->new->decode (decode "UTF-32LE", $jsontext);
-
-
-=head2 pretty
-
- $json = $json->pretty([$enable])
-
-This enables (or disables) all of the C<indent>, C<space_before> and
-C<space_after> flags in one call to generate the most readable
-(or most compact) form possible.
-
-Equivalent to:
-
- $json->indent->space_before->space_after
-
-=head2 indent
-
- $json = $json->indent([$enable])
-
- $enabled = $json->get_indent
-
-The default indent space length is three.
-You can use C<indent_length> to change the length.
-
-=head2 space_before
-
- $json = $json->space_before([$enable])
-
- $enabled = $json->get_space_before
-
-If C<$enable> is true (or missing), then the C<encode> method will add an extra
-optional space before the C<:> separating keys from values in JSON objects.
-
-If C<$enable> is false, then the C<encode> method will not add any extra
-space at those places.
-
-This setting has no effect when decoding JSON texts.
-
-Example, space_before enabled, space_after and indent disabled:
-
- {"key" :"value"}
-
-=head2 space_after
-
- $json = $json->space_after([$enable])
-
- $enabled = $json->get_space_after
-
-If C<$enable> is true (or missing), then the C<encode> method will add an extra
-optional space after the C<:> separating keys from values in JSON objects
-and extra whitespace after the C<,> separating key-value pairs and array
-members.
-
-If C<$enable> is false, then the C<encode> method will not add any extra
-space at those places.
-
-This setting has no effect when decoding JSON texts.
-
-Example, space_before and indent disabled, space_after enabled:
-
- {"key": "value"}
-
-=head2 relaxed
-
- $json = $json->relaxed([$enable])
-
- $enabled = $json->get_relaxed
-
-If C<$enable> is true (or missing), then C<decode> will accept some
-extensions to normal JSON syntax (see below). C<encode> will not be
-affected in anyway. I<Be aware that this option makes you accept invalid
-JSON texts as if they were valid!>. I suggest only to use this option to
-parse application-specific files written by humans (configuration files,
-resource files etc.)
-
-If C<$enable> is false (the default), then C<decode> will only accept
-valid JSON texts.
-
-Currently accepted extensions are:
-
-=over 4
-
-=item * list items can have an end-comma
-
-JSON I<separates> array elements and key-value pairs with commas. This
-can be annoying if you write JSON texts manually and want to be able to
-quickly append elements, so this extension accepts comma at the end of
-such items not just between them:
-
- [
- 1,
- 2, <- this comma not normally allowed
- ]
- {
- "k1": "v1",
- "k2": "v2", <- this comma not normally allowed
- }
-
-=item * shell-style '#'-comments
-
-Whenever JSON allows whitespace, shell-style comments are additionally
-allowed. They are terminated by the first carriage-return or line-feed
-character, after which more white-space and comments are allowed.
-
- [
- 1, # this comment not allowed in JSON
- # neither this one...
- ]
-
-=back
-
-=head2 canonical
-
- $json = $json->canonical([$enable])
-
- $enabled = $json->get_canonical
-
-If C<$enable> is true (or missing), then the C<encode> method will output JSON objects
-by sorting their keys. This is adding a comparatively high overhead.
-
-If C<$enable> is false, then the C<encode> method will output key-value
-pairs in the order Perl stores them (which will likely change between runs
-of the same script).
-
-This option is useful if you want the same data structure to be encoded as
-the same JSON text (given the same overall settings). If it is disabled,
-the same hash might be encoded differently even if contains the same data,
-as key-value pairs have no inherent ordering in Perl.
-
-This setting has no effect when decoding JSON texts.
-
-If you want your own sorting routine, you can give a code reference
-or a subroutine name to C<sort_by>. See to C<JSON::PP OWN METHODS>.
-
-=head2 allow_nonref
-
- $json = $json->allow_nonref([$enable])
-
- $enabled = $json->get_allow_nonref
-
-If C<$enable> is true (or missing), then the C<encode> method can convert a
-non-reference into its corresponding string, number or null JSON value,
-which is an extension to RFC4627. Likewise, C<decode> will accept those JSON
-values instead of croaking.
-
-If C<$enable> is false, then the C<encode> method will croak if it isn't
-passed an arrayref or hashref, as JSON texts must either be an object
-or array. Likewise, C<decode> will croak if given something that is not a
-JSON object or array.
-
- JSON::PP->new->allow_nonref->encode ("Hello, World!")
- => "Hello, World!"
-
-=head2 allow_unknown
-
- $json = $json->allow_unknown ([$enable])
-
- $enabled = $json->get_allow_unknown
-
-If $enable is true (or missing), then "encode" will *not* throw an
-exception when it encounters values it cannot represent in JSON (for
-example, filehandles) but instead will encode a JSON "null" value.
-Note that blessed objects are not included here and are handled
-separately by c<allow_nonref>.
-
-If $enable is false (the default), then "encode" will throw an
-exception when it encounters anything it cannot encode as JSON.
-
-This option does not affect "decode" in any way, and it is
-recommended to leave it off unless you know your communications
-partner.
-
-=head2 allow_blessed
-
- $json = $json->allow_blessed([$enable])
-
- $enabled = $json->get_allow_blessed
-
-If C<$enable> is true (or missing), then the C<encode> method will not
-barf when it encounters a blessed reference. Instead, the value of the
-B<convert_blessed> option will decide whether C<null> (C<convert_blessed>
-disabled or no C<TO_JSON> method found) or a representation of the
-object (C<convert_blessed> enabled and C<TO_JSON> method found) is being
-encoded. Has no effect on C<decode>.
-
-If C<$enable> is false (the default), then C<encode> will throw an
-exception when it encounters a blessed object.
-
-=head2 convert_blessed
-
- $json = $json->convert_blessed([$enable])
-
- $enabled = $json->get_convert_blessed
-
-If C<$enable> is true (or missing), then C<encode>, upon encountering a
-blessed object, will check for the availability of the C<TO_JSON> method
-on the object's class. If found, it will be called in scalar context
-and the resulting scalar will be encoded instead of the object. If no
-C<TO_JSON> method is found, the value of C<allow_blessed> will decide what
-to do.
-
-The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON>
-returns other blessed objects, those will be handled in the same
-way. C<TO_JSON> must take care of not causing an endless recursion cycle
-(== crash) in this case. The name of C<TO_JSON> was chosen because other
-methods called by the Perl core (== not by the user of the object) are
-usually in upper case letters and to avoid collisions with the C<to_json>
-function or method.
-
-This setting does not yet influence C<decode> in any way.
-
-If C<$enable> is false, then the C<allow_blessed> setting will decide what
-to do when a blessed object is found.
-
-=head2 filter_json_object
-
- $json = $json->filter_json_object([$coderef])
-
-When C<$coderef> is specified, it will be called from C<decode> each
-time it decodes a JSON object. The only argument passed to the coderef
-is a reference to the newly-created hash. If the code references returns
-a single scalar (which need not be a reference), this value
-(i.e. a copy of that scalar to avoid aliasing) is inserted into the
-deserialised data structure. If it returns an empty list
-(NOTE: I<not> C<undef>, which is a valid scalar), the original deserialised
-hash will be inserted. This setting can slow down decoding considerably.
-
-When C<$coderef> is omitted or undefined, any existing callback will
-be removed and C<decode> will not change the deserialised hash in any
-way.
-
-Example, convert all JSON objects into the integer 5:
-
- my $js = JSON::PP->new->filter_json_object (sub { 5 });
- # returns [5]
- $js->decode ('[{}]'); # the given subroutine takes a hash reference.
- # throw an exception because allow_nonref is not enabled
- # so a lone 5 is not allowed.
- $js->decode ('{"a":1, "b":2}');
-
-=head2 filter_json_single_key_object
-
- $json = $json->filter_json_single_key_object($key [=> $coderef])
-
-Works remotely similar to C<filter_json_object>, but is only called for
-JSON objects having a single key named C<$key>.
-
-This C<$coderef> is called before the one specified via
-C<filter_json_object>, if any. It gets passed the single value in the JSON
-object. If it returns a single value, it will be inserted into the data
-structure. If it returns nothing (not even C<undef> but the empty list),
-the callback from C<filter_json_object> will be called next, as if no
-single-key callback were specified.
-
-If C<$coderef> is omitted or undefined, the corresponding callback will be
-disabled. There can only ever be one callback for a given key.
-
-As this callback gets called less often then the C<filter_json_object>
-one, decoding speed will not usually suffer as much. Therefore, single-key
-objects make excellent targets to serialise Perl objects into, especially
-as single-key JSON objects are as close to the type-tagged value concept
-as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not
-support this in any way, so you need to make sure your data never looks
-like a serialised Perl hash.
-
-Typical names for the single object key are C<__class_whatever__>, or
-C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even
-things like C<__class_md5sum(classname)__>, to reduce the risk of clashing
-with real hashes.
-
-Example, decode JSON objects of the form C<< { "__widget__" => <id> } >>
-into the corresponding C<< $WIDGET{<id>} >> object:
-
- # return whatever is in $WIDGET{5}:
- JSON::PP
- ->new
- ->filter_json_single_key_object (__widget__ => sub {
- $WIDGET{ $_[0] }
- })
- ->decode ('{"__widget__": 5')
-
- # this can be used with a TO_JSON method in some "widget" class
- # for serialisation to json:
- sub WidgetBase::TO_JSON {
- my ($self) = @_;
-
- unless ($self->{id}) {
- $self->{id} = ..get..some..id..;
- $WIDGET{$self->{id}} = $self;
- }
-
- { __widget__ => $self->{id} }
- }
-
-=head2 shrink
-
- $json = $json->shrink([$enable])
-
- $enabled = $json->get_shrink
-
-In JSON::XS, this flag resizes strings generated by either
-C<encode> or C<decode> to their minimum size possible.
-It will also try to downgrade any strings to octet-form if possible.
-
-In JSON::PP, it is noop about resizing strings but tries
-C<utf8::downgrade> to the returned string by C<encode>.
-See to L<utf8>.
-
-See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>
-
-=head2 max_depth
-
- $json = $json->max_depth([$maximum_nesting_depth])
-
- $max_depth = $json->get_max_depth
-
-Sets the maximum nesting level (default C<512>) accepted while encoding
-or decoding. If a higher nesting level is detected in JSON text or a Perl
-data structure, then the encoder and decoder will stop and croak at that
-point.
-
-Nesting level is defined by number of hash- or arrayrefs that the encoder
-needs to traverse to reach a given point or the number of C<{> or C<[>
-characters without their matching closing parenthesis crossed to reach a
-given character in a string.
-
-If no argument is given, the highest possible setting will be used, which
-is rarely useful.
-
-See L<JSON::XS/SECURITY CONSIDERATIONS> for more info on why this is useful.
-
-When a large value (100 or more) was set and it de/encodes a deep nested object/text,
-it may raise a warning 'Deep recursion on subroutine' at the perl runtime phase.
-
-=head2 max_size
-
- $json = $json->max_size([$maximum_string_size])
-
- $max_size = $json->get_max_size
-
-Set the maximum length a JSON text may have (in bytes) where decoding is
-being attempted. The default is C<0>, meaning no limit. When C<decode>
-is called on a string that is longer then this many bytes, it will not
-attempt to decode the string but throw an exception. This setting has no
-effect on C<encode> (yet).
-
-If no argument is given, the limit check will be deactivated (same as when
-C<0> is specified).
-
-See L<JSON::XS/SECURITY CONSIDERATIONS> for more info on why this is useful.
-
-=head2 encode
-
- $json_text = $json->encode($perl_scalar)
-
-Converts the given Perl data structure (a simple scalar or a reference
-to a hash or array) to its JSON representation. Simple scalars will be
-converted into JSON string or number sequences, while references to arrays
-become JSON arrays and references to hashes become JSON objects. Undefined
-Perl values (e.g. C<undef>) become JSON C<null> values.
-References to the integers C<0> and C<1> are converted into C<true> and C<false>.
-
-=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 parentheses
-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 erroneous 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 to 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.
-
-
-=head2 allow_barekey
-
- $json = $json->allow_barekey([$enable])
-
-If C<$enable> is true (or missing), then C<decode> will accept
-bare keys of JSON object that are invalid JSON format.
-
-As same as the C<relaxed> option, this option may be used to parse
-application-specific files written by humans.
-
- $json->allow_barekey->decode('{foo:"bar"}');
-
-=head2 allow_bignum
-
- $json = $json->allow_bignum([$enable])
-
-If C<$enable> is true (or missing), then C<decode> will convert
-the big integer Perl cannot handle as integer into a L<Math::BigInt>
-object and convert a floating number (any) into a L<Math::BigFloat>.
-
-On the contrary, C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
-objects into JSON numbers with C<allow_blessed> enabled.
-
- $json->allow_nonref->allow_blessed->allow_bignum;
- $bigfloat = $json->decode('2.000000000000000000000000001');
- print $json->encode($bigfloat);
- # => 2.000000000000000000000000001
-
-See to L<JSON::XS/MAPPING> about the normal conversion of JSON number.
-
-=head2 loose
-
- $json = $json->loose([$enable])
-
-The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings
-and the module doesn't allow you to C<decode> to these (except for \x2f).
-If C<$enable> is true (or missing), then C<decode> will accept these
-unescaped strings.
-
- $json->loose->decode(qq|["abc
- def"]|);
-
-See L<JSON::XS/SECURITY CONSIDERATIONS>.
-
-=head2 escape_slash
-
- $json = $json->escape_slash([$enable])
-
-According to JSON Grammar, I<slash> (U+002F) is escaped. But default
-JSON::PP (as same as JSON::XS) encodes strings without escaping slash.
-
-If C<$enable> is true (or missing), then C<encode> will escape slashes.
-
-=head2 indent_length
-
- $json = $json->indent_length($length)
-
-JSON::XS indent space length is 3 and cannot be changed.
-JSON::PP set the indent space length with the given $length.
-The default is 3. The acceptable range is 0 to 15.
-
-=head2 sort_by
-
- $json = $json->sort_by($function_name)
- $json = $json->sort_by($subroutine_ref)
-
-If $function_name or $subroutine_ref are set, its sort routine are used
-in encoding JSON objects.
-
- $js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj);
- # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
-
- $js = $pc->sort_by('own_sort')->encode($obj);
- # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
-
- sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b }
-
-As the sorting routine runs in the JSON::PP scope, the given
-subroutine name and the special variables C<$a>, C<$b> will begin
-'JSON::PP::'.
-
-If $integer is set, then the effect is same as C<canonical> on.
-
-=head1 INTERNAL
-
-For developers.
-
-=over
-
-=item PP_encode_box
-
-Returns
-
- {
- depth => $depth,
- indent_count => $indent_count,
- }
-
-
-=item PP_decode_box
-
-Returns
-
- {
- text => $text,
- at => $at,
- ch => $ch,
- len => $len,
- depth => $depth,
- encoding => $encoding,
- is_valid_utf8 => $is_valid_utf8,
- };
-
-=back
-
-=head1 MAPPING
-
-This section is copied from JSON::XS and modified to C<JSON::PP>.
-JSON::XS and JSON::PP mapping mechanisms are almost equivalent.
-
-See to L<JSON::XS/MAPPING>.
-
-=head2 JSON -> PERL
-
-=over 4
-
-=item object
-
-A JSON object becomes a reference to a hash in Perl. No ordering of object
-keys is preserved (JSON does not preserver object key ordering itself).
-
-=item array
-
-A JSON array becomes a reference to an array in Perl.
-
-=item string
-
-A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON
-are represented by the same codepoints in the Perl string, so no manual
-decoding is necessary.
-
-=item number
-
-A JSON number becomes either an integer, numeric (floating point) or
-string scalar in perl, depending on its range and any fractional parts. On
-the Perl level, there is no difference between those as Perl handles all
-the conversion details, but an integer may take slightly less memory and
-might represent more values exactly than floating point numbers.
-
-If the number consists of digits only, C<JSON> will try to represent
-it as an integer value. If that fails, it will try to represent it as
-a numeric (floating point) value if that is possible without loss of
-precision. Otherwise it will preserve the number as a string value (in
-which case you lose roundtripping ability, as the JSON number will be
-re-encoded to a JSON string).
-
-Numbers containing a fractional or exponential part will always be
-represented as numeric (floating point) values, possibly at a loss of
-precision (in which case you might lose perfect roundtripping ability, but
-the JSON number will still be re-encoded as a JSON number).
-
-Note that precision is not accuracy - binary floating point values cannot
-represent most decimal fractions exactly, and when converting from and to
-floating point, C<JSON> only guarantees precision up to but not including
-the least significant bit.
-
-When C<allow_bignum> is enabled, the big integers
-and the numeric can be optionally converted into L<Math::BigInt> and
-L<Math::BigFloat> objects.
-
-=item true, false
-
-These JSON atoms become C<JSON::PP::true> and C<JSON::PP::false>,
-respectively. They are overloaded to act almost exactly like the numbers
-C<1> and C<0>. You can check whether a scalar is a JSON boolean by using
-the C<JSON::is_bool> function.
-
- print JSON::PP::true . "\n";
- => true
- print JSON::PP::true + 1;
- => 1
-
- ok(JSON::true eq '1');
- ok(JSON::true == 1);
-
-C<JSON> will install these missing overloading features to the backend modules.
-
-
-=item null
-
-A JSON null atom becomes C<undef> in Perl.
-
-C<JSON::PP::null> returns C<undef>.
-
-=back
-
-
-=head2 PERL -> JSON
-
-The mapping from Perl to JSON is slightly more difficult, as Perl is a
-truly typeless language, so we can only guess which JSON type is meant by
-a Perl value.
-
-=over 4
-
-=item hash references
-
-Perl hash references become JSON objects. As there is no inherent ordering
-in hash keys (or JSON objects), they will usually be encoded in a
-pseudo-random order that can change between runs of the same program but
-stays generally the same within a single run of a program. C<JSON>
-optionally sort the hash keys (determined by the I<canonical> flag), so
-the same datastructure will serialise to the same JSON text (given same
-settings and version of JSON::XS), but this incurs a runtime overhead
-and is only rarely useful, e.g. when you want to compare some JSON text
-against another for equality.
-
-
-=item array references
-
-Perl array references become JSON arrays.
-
-=item other references
-
-Other unblessed references are generally not allowed and will cause an
-exception to be thrown, except for references to the integers C<0> and
-C<1>, which get turned into C<false> and C<true> atoms in JSON. You can
-also use C<JSON::false> and C<JSON::true> to improve readability.
-
- to_json [\0,JSON::PP::true] # yields [false,true]
-
-=item JSON::PP::true, JSON::PP::false, JSON::PP::null
-
-These special values become JSON true and JSON false values,
-respectively. You can also use C<\1> and C<\0> directly if you want.
-
-JSON::PP::null returns C<undef>.
-
-=item blessed objects
-
-Blessed objects are not directly representable in JSON. See the
-C<allow_blessed> and C<convert_blessed> methods on various options on
-how to deal with this: basically, you can choose between throwing an
-exception, encoding the reference as if it weren't blessed, or provide
-your own serialiser method.
-
-See to L<convert_blessed>.
-
-=item simple scalars
-
-Simple Perl scalars (any scalar that is not a reference) are the most
-difficult objects to encode: JSON::XS and JSON::PP will encode undefined scalars as
-JSON C<null> values, scalars that have last been used in a string context
-before encoding as JSON strings, and anything else as number value:
-
- # dump as number
- encode_json [2] # yields [2]
- encode_json [-3.0e17] # yields [-3e+17]
- my $value = 5; encode_json [$value] # yields [5]
-
- # used as string, so dump as string
- print $value;
- encode_json [$value] # yields ["5"]
-
- # undef becomes null
- encode_json [undef] # yields [null]
-
-You can force the type to be a string by stringifying it:
-
- my $x = 3.1; # some variable containing a number
- "$x"; # stringified
- $x .= ""; # another, more awkward way to stringify
- print $x; # perl does it for you, too, quite often
-
-You can force the type to be a number by numifying it:
-
- my $x = "3"; # some variable containing a string
- $x += 0; # numify it, ensuring it will be dumped as a number
- $x *= 1; # same thing, the choice is yours.
-
-You cannot currently force the type in other, less obscure, ways.
-
-Note that numerical precision has the same meaning as under Perl (so
-binary to decimal conversion follows the same rules as in Perl, which
-can differ to other languages). Also, your perl interpreter might expose
-extensions to the floating point numbers of your platform, such as
-infinities or NaN's - these cannot be represented in JSON, and it is an
-error to pass those in.
-
-=item Big Number
-
-When C<allow_bignum> is enabled,
-C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
-objects into JSON numbers.
-
-
-=back
-
-=head1 UNICODE HANDLING ON PERLS
-
-If you do not know about Unicode on Perl well,
-please check L<JSON::XS/A FEW NOTES ON UNICODE AND PERL>.
-
-=head2 Perl 5.8 and later
-
-Perl can handle Unicode and the JSON::PP de/encode methods also work properly.
-
- $json->allow_nonref->encode(chr hex 3042);
- $json->allow_nonref->encode(chr hex 12345);
-
-Returns C<"\u3042"> and C<"\ud808\udf45"> respectively.
-
- $json->allow_nonref->decode('"\u3042"');
- $json->allow_nonref->decode('"\ud808\udf45"');
-
-Returns UTF-8 encoded strings with UTF8 flag, regarded as C<U+3042> and C<U+12345>.
-
-Note that the versions from Perl 5.8.0 to 5.8.2, Perl built-in C<join> was broken,
-so JSON::PP wraps the C<join> with a subroutine. Thus JSON::PP works slow in the versions.
-
-
-=head2 Perl 5.6
-
-Perl can handle Unicode and the JSON::PP de/encode methods also work.
-
-=head2 Perl 5.005
-
-Perl 5.005 is a byte semantics world -- all strings are sequences of bytes.
-That means the unicode handling is not available.
-
-In encoding,
-
- $json->allow_nonref->encode(chr hex 3042); # hex 3042 is 12354.
- $json->allow_nonref->encode(chr hex 12345); # hex 12345 is 74565.
-
-Returns C<B> and C<E>, as C<chr> takes a value more than 255, it treats
-as C<$value % 256>, so the above codes are equivalent to :
-
- $json->allow_nonref->encode(chr 66);
- $json->allow_nonref->encode(chr 69);
-
-In decoding,
-
- $json->decode('"\u00e3\u0081\u0082"');
-
-The returned is a byte sequence C<0xE3 0x81 0x82> for UTF-8 encoded
-Japanese character (C<HIRAGANA LETTER A>).
-And if it is represented in Unicode code point, C<U+3042>.
-
-Next,
-
- $json->decode('"\u3042"');
-
-We ordinary expect the returned value is a Unicode character C<U+3042>.
-But here is 5.005 world. This is C<0xE3 0x81 0x82>.
-
- $json->decode('"\ud808\udf45"');
-
-This is not a character C<U+12345> but bytes - C<0xf0 0x92 0x8d 0x85>.
-
-
-=head1 TODO
-
-=over
-
-=item speed
-
-=item memory saving
-
-=back
-
-
-=head1 SEE ALSO
-
-Most of the document are copied and modified from JSON::XS doc.
-
-L<JSON::XS>
-
-RFC4627 (L<http://www.ietf.org/rfc/rfc4627.txt>)
-
-=head1 AUTHOR
-
-Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
-
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 2007-2016 by Makamaka Hannyaharamitu
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
+++ /dev/null
-=head1 NAME
-
-JSON::PP::Boolean - dummy module providing JSON::PP::Boolean
-
-=head1 SYNOPSIS
-
- # do not "use" yourself
-
-=head1 DESCRIPTION
-
-This module exists only to provide overload resolution for Storable and similar modules. See
-L<JSON::PP> for more info about this class.
-
-=cut
-
-use JSON::PP ();
-use strict;
-
-1;
-
-=head1 AUTHOR
-
-This idea is from L<JSON::XS::Boolean> written by Marc Lehmann <schmorp[at]schmorp.de>
-
-=cut
-
+++ /dev/null
-# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
-# vim:ts=8:sw=2:et:sta:sts=2
-package Module::Metadata;
-
-# Adapted from Perl-licensed code originally distributed with
-# Module-Build by Ken Williams
-
-# This module provides routines to gather information about
-# perl modules (assuming this may be expanded in the distant
-# parrot future to look at other types of modules).
-
-use strict;
-use warnings;
-
-our $VERSION = '1.000019';
-$VERSION = eval $VERSION;
-
-use Carp qw/croak/;
-use File::Spec;
-use IO::File;
-use version 0.87;
-BEGIN {
- if ($INC{'Log/Contextual.pm'}) {
- Log::Contextual->import('log_info');
- } else {
- *log_info = sub (&) { warn $_[0]->() };
- }
-}
-use File::Find qw(find);
-
-my $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal
-
-my $PKG_FIRST_WORD_REGEXP = qr{ # the FIRST word in a package name
- [a-zA-Z_] # the first word CANNOT start with a digit
- (?:
- [\w']? # can contain letters, digits, _, or ticks
- \w # But, NO multi-ticks or trailing ticks
- )*
-}x;
-
-my $PKG_ADDL_WORD_REGEXP = qr{ # the 2nd+ word in a package name
- \w # the 2nd+ word CAN start with digits
- (?:
- [\w']? # and can contain letters or ticks
- \w # But, NO multi-ticks or trailing ticks
- )*
-}x;
-
-my $PKG_NAME_REGEXP = qr{ # match a package name
- (?: :: )? # a pkg name can start with aristotle
- $PKG_FIRST_WORD_REGEXP # a package word
- (?:
- (?: :: )+ ### aristotle (allow one or many times)
- $PKG_ADDL_WORD_REGEXP ### a package word
- )* # ^ zero, one or many times
- (?:
- :: # allow trailing aristotle
- )?
-}x;
-
-my $PKG_REGEXP = qr{ # match a package declaration
- ^[\s\{;]* # intro chars on a line
- package # the word 'package'
- \s+ # whitespace
- ($PKG_NAME_REGEXP) # a package name
- \s* # optional whitespace
- ($V_NUM_REGEXP)? # optional version number
- \s* # optional whitesapce
- [;\{] # semicolon line terminator or block start (since 5.16)
-}x;
-
-my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
- ([\$*]) # sigil - $ or *
- (
- ( # optional leading package name
- (?:::|\')? # possibly starting like just :: (Ì la $::VERSION)
- (?:\w+(?:::|\'))* # Foo::Bar:: ...
- )?
- VERSION
- )\b
-}x;
-
-my $VERS_REGEXP = qr{ # match a VERSION definition
- (?:
- \(\s*$VARNAME_REGEXP\s*\) # with parens
- |
- $VARNAME_REGEXP # without parens
- )
- \s*
- =[^=~] # = but not ==, nor =~
-}x;
-
-sub new_from_file {
- my $class = shift;
- my $filename = File::Spec->rel2abs( shift );
-
- return undef unless defined( $filename ) && -f $filename;
- return $class->_init(undef, $filename, @_);
-}
-
-sub new_from_handle {
- my $class = shift;
- my $handle = shift;
- my $filename = shift;
- return undef unless defined($handle) && defined($filename);
- $filename = File::Spec->rel2abs( $filename );
-
- return $class->_init(undef, $filename, @_, handle => $handle);
-
-}
-
-
-sub new_from_module {
- my $class = shift;
- my $module = shift;
- my %props = @_;
-
- $props{inc} ||= \@INC;
- my $filename = $class->find_module_by_name( $module, $props{inc} );
- return undef unless defined( $filename ) && -f $filename;
- return $class->_init($module, $filename, %props);
-}
-
-{
-
- my $compare_versions = sub {
- my ($v1, $op, $v2) = @_;
- $v1 = version->new($v1)
- unless UNIVERSAL::isa($v1,'version');
-
- my $eval_str = "\$v1 $op \$v2";
- my $result = eval $eval_str;
- log_info { "error comparing versions: '$eval_str' $@" } if $@;
-
- return $result;
- };
-
- my $normalize_version = sub {
- my ($version) = @_;
- if ( $version =~ /[=<>!,]/ ) { # logic, not just version
- # take as is without modification
- }
- elsif ( ref $version eq 'version' ) { # version objects
- $version = $version->is_qv ? $version->normal : $version->stringify;
- }
- elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
- # normalize string tuples without "v": "1.2.3" -> "v1.2.3"
- $version = "v$version";
- }
- else {
- # leave alone
- }
- return $version;
- };
-
- # separate out some of the conflict resolution logic
-
- my $resolve_module_versions = sub {
- my $packages = shift;
-
- my( $file, $version );
- my $err = '';
- foreach my $p ( @$packages ) {
- if ( defined( $p->{version} ) ) {
- if ( defined( $version ) ) {
- if ( $compare_versions->( $version, '!=', $p->{version} ) ) {
- $err .= " $p->{file} ($p->{version})\n";
- } else {
- # same version declared multiple times, ignore
- }
- } else {
- $file = $p->{file};
- $version = $p->{version};
- }
- }
- $file ||= $p->{file} if defined( $p->{file} );
- }
-
- if ( $err ) {
- $err = " $file ($version)\n" . $err;
- }
-
- my %result = (
- file => $file,
- version => $version,
- err => $err
- );
-
- return \%result;
- };
-
- sub provides {
- my $class = shift;
-
- croak "provides() requires key/value pairs \n" if @_ % 2;
- my %args = @_;
-
- croak "provides() takes only one of 'dir' or 'files'\n"
- if $args{dir} && $args{files};
-
- croak "provides() requires a 'version' argument"
- unless defined $args{version};
-
- croak "provides() does not support version '$args{version}' metadata"
- unless grep { $args{version} eq $_ } qw/1.4 2/;
-
- $args{prefix} = 'lib' unless defined $args{prefix};
-
- my $p;
- if ( $args{dir} ) {
- $p = $class->package_versions_from_directory($args{dir});
- }
- else {
- croak "provides() requires 'files' to be an array reference\n"
- unless ref $args{files} eq 'ARRAY';
- $p = $class->package_versions_from_directory($args{files});
- }
-
- # Now, fix up files with prefix
- if ( length $args{prefix} ) { # check in case disabled with q{}
- $args{prefix} =~ s{/$}{};
- for my $v ( values %$p ) {
- $v->{file} = "$args{prefix}/$v->{file}";
- }
- }
-
- return $p
- }
-
- sub package_versions_from_directory {
- my ( $class, $dir, $files ) = @_;
-
- my @files;
-
- if ( $files ) {
- @files = @$files;
- } else {
- find( {
- wanted => sub {
- push @files, $_ if -f $_ && /\.pm$/;
- },
- no_chdir => 1,
- }, $dir );
- }
-
- # First, we enumerate all packages & versions,
- # separating into primary & alternative candidates
- my( %prime, %alt );
- foreach my $file (@files) {
- my $mapped_filename = File::Spec::Unix->abs2rel( $file, $dir );
- my @path = split( /\//, $mapped_filename );
- (my $prime_package = join( '::', @path )) =~ s/\.pm$//;
-
- my $pm_info = $class->new_from_file( $file );
-
- foreach my $package ( $pm_info->packages_inside ) {
- next if $package eq 'main'; # main can appear numerous times, ignore
- next if $package eq 'DB'; # special debugging package, ignore
- next if grep /^_/, split( /::/, $package ); # private package, ignore
-
- my $version = $pm_info->version( $package );
-
- $prime_package = $package if lc($prime_package) eq lc($package);
- if ( $package eq $prime_package ) {
- if ( exists( $prime{$package} ) ) {
- croak "Unexpected conflict in '$package'; multiple versions found.\n";
- } else {
- $mapped_filename = "$package.pm" if lc("$package.pm") eq lc($mapped_filename);
- $prime{$package}{file} = $mapped_filename;
- $prime{$package}{version} = $version if defined( $version );
- }
- } else {
- push( @{$alt{$package}}, {
- file => $mapped_filename,
- version => $version,
- } );
- }
- }
- }
-
- # Then we iterate over all the packages found above, identifying conflicts
- # and selecting the "best" candidate for recording the file & version
- # for each package.
- foreach my $package ( keys( %alt ) ) {
- my $result = $resolve_module_versions->( $alt{$package} );
-
- if ( exists( $prime{$package} ) ) { # primary package selected
-
- if ( $result->{err} ) {
- # Use the selected primary package, but there are conflicting
- # errors among multiple alternative packages that need to be
- # reported
- log_info {
- "Found conflicting versions for package '$package'\n" .
- " $prime{$package}{file} ($prime{$package}{version})\n" .
- $result->{err}
- };
-
- } elsif ( defined( $result->{version} ) ) {
- # There is a primary package selected, and exactly one
- # alternative package
-
- if ( exists( $prime{$package}{version} ) &&
- defined( $prime{$package}{version} ) ) {
- # Unless the version of the primary package agrees with the
- # version of the alternative package, report a conflict
- if ( $compare_versions->(
- $prime{$package}{version}, '!=', $result->{version}
- )
- ) {
-
- log_info {
- "Found conflicting versions for package '$package'\n" .
- " $prime{$package}{file} ($prime{$package}{version})\n" .
- " $result->{file} ($result->{version})\n"
- };
- }
-
- } else {
- # The prime package selected has no version so, we choose to
- # use any alternative package that does have a version
- $prime{$package}{file} = $result->{file};
- $prime{$package}{version} = $result->{version};
- }
-
- } else {
- # no alt package found with a version, but we have a prime
- # package so we use it whether it has a version or not
- }
-
- } else { # No primary package was selected, use the best alternative
-
- if ( $result->{err} ) {
- log_info {
- "Found conflicting versions for package '$package'\n" .
- $result->{err}
- };
- }
-
- # Despite possible conflicting versions, we choose to record
- # something rather than nothing
- $prime{$package}{file} = $result->{file};
- $prime{$package}{version} = $result->{version}
- if defined( $result->{version} );
- }
- }
-
- # Normalize versions. Can't use exists() here because of bug in YAML::Node.
- # XXX "bug in YAML::Node" comment seems irrelevant -- dagolden, 2009-05-18
- for (grep defined $_->{version}, values %prime) {
- $_->{version} = $normalize_version->( $_->{version} );
- }
-
- return \%prime;
- }
-}
-
-
-sub _init {
- my $class = shift;
- my $module = shift;
- my $filename = shift;
- my %props = @_;
-
- my $handle = delete $props{handle};
- my( %valid_props, @valid_props );
- @valid_props = qw( collect_pod inc );
- @valid_props{@valid_props} = delete( @props{@valid_props} );
- warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
-
- my %data = (
- module => $module,
- filename => $filename,
- version => undef,
- packages => [],
- versions => {},
- pod => {},
- pod_headings => [],
- collect_pod => 0,
-
- %valid_props,
- );
-
- my $self = bless(\%data, $class);
-
- if ( $handle ) {
- $self->_parse_fh($handle);
- }
- else {
- $self->_parse_file();
- }
-
- unless($self->{module} and length($self->{module})) {
- my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
- if($f =~ /\.pm$/) {
- $f =~ s/\..+$//;
- my @candidates = grep /$f$/, @{$self->{packages}};
- $self->{module} = shift(@candidates); # punt
- }
- else {
- if(grep /main/, @{$self->{packages}}) {
- $self->{module} = 'main';
- }
- else {
- $self->{module} = $self->{packages}[0] || '';
- }
- }
- }
-
- $self->{version} = $self->{versions}{$self->{module}}
- if defined( $self->{module} );
-
- return $self;
-}
-
-# class method
-sub _do_find_module {
- my $class = shift;
- my $module = shift || croak 'find_module_by_name() requires a package name';
- my $dirs = shift || \@INC;
-
- my $file = File::Spec->catfile(split( /::/, $module));
- foreach my $dir ( @$dirs ) {
- my $testfile = File::Spec->catfile($dir, $file);
- return [ File::Spec->rel2abs( $testfile ), $dir ]
- if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp
- return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
- if -e "$testfile.pm";
- }
- return;
-}
-
-# class method
-sub find_module_by_name {
- my $found = shift()->_do_find_module(@_) or return;
- return $found->[0];
-}
-
-# class method
-sub find_module_dir_by_name {
- my $found = shift()->_do_find_module(@_) or return;
- return $found->[1];
-}
-
-
-# given a line of perl code, attempt to parse it if it looks like a
-# $VERSION assignment, returning sigil, full name, & package name
-sub _parse_version_expression {
- my $self = shift;
- my $line = shift;
-
- my( $sig, $var, $pkg );
- if ( $line =~ /$VERS_REGEXP/o ) {
- ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
- if ( $pkg ) {
- $pkg = ($pkg eq '::') ? 'main' : $pkg;
- $pkg =~ s/::$//;
- }
- }
-
- return ( $sig, $var, $pkg );
-}
-
-sub _parse_file {
- my $self = shift;
-
- my $filename = $self->{filename};
- my $fh = IO::File->new( $filename )
- or croak( "Can't open '$filename': $!" );
-
- $self->_handle_bom($fh, $filename);
-
- $self->_parse_fh($fh);
-}
-
-# Look for a UTF-8/UTF-16BE/UTF-16LE BOM at the beginning of the stream.
-# If there's one, then skip it and set the :encoding layer appropriately.
-sub _handle_bom {
- my ($self, $fh, $filename) = @_;
-
- my $pos = $fh->getpos;
- return unless defined $pos;
-
- my $buf = ' ' x 2;
- my $count = $fh->read( $buf, length $buf );
- return unless defined $count and $count >= 2;
-
- my $encoding;
- if ( $buf eq "\x{FE}\x{FF}" ) {
- $encoding = 'UTF-16BE';
- } elsif ( $buf eq "\x{FF}\x{FE}" ) {
- $encoding = 'UTF-16LE';
- } elsif ( $buf eq "\x{EF}\x{BB}" ) {
- $buf = ' ';
- $count = $fh->read( $buf, length $buf );
- if ( defined $count and $count >= 1 and $buf eq "\x{BF}" ) {
- $encoding = 'UTF-8';
- }
- }
-
- if ( defined $encoding ) {
- if ( "$]" >= 5.008 ) {
- # $fh->binmode requires perl 5.10
- binmode( $fh, ":encoding($encoding)" );
- }
- } else {
- $fh->setpos($pos)
- or croak( sprintf "Can't reset position to the top of '$filename'" );
- }
-
- return $encoding;
-}
-
-sub _parse_fh {
- my ($self, $fh) = @_;
-
- my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
- my( @pkgs, %vers, %pod, @pod );
- my $pkg = 'main';
- my $pod_sect = '';
- my $pod_data = '';
- my $in_end = 0;
-
- while (defined( my $line = <$fh> )) {
- my $line_num = $.;
-
- chomp( $line );
-
- # From toke.c : any line that begins by "=X", where X is an alphabetic
- # character, introduces a POD segment.
- my $is_cut;
- if ( $line =~ /^=([a-zA-Z].*)/ ) {
- my $cmd = $1;
- # Then it goes back to Perl code for "=cutX" where X is a non-alphabetic
- # character (which includes the newline, but here we chomped it away).
- $is_cut = $cmd =~ /^cut(?:[^a-zA-Z]|$)/;
- $in_pod = !$is_cut;
- }
-
- if ( $in_pod ) {
-
- if ( $line =~ /^=head[1-4]\s+(.+)\s*$/ ) {
- push( @pod, $1 );
- if ( $self->{collect_pod} && length( $pod_data ) ) {
- $pod{$pod_sect} = $pod_data;
- $pod_data = '';
- }
- $pod_sect = $1;
-
- } elsif ( $self->{collect_pod} ) {
- $pod_data .= "$line\n";
-
- }
-
- } elsif ( $is_cut ) {
-
- if ( $self->{collect_pod} && length( $pod_data ) ) {
- $pod{$pod_sect} = $pod_data;
- $pod_data = '';
- }
- $pod_sect = '';
-
- } else {
-
- # Skip after __END__
- next if $in_end;
-
- # Skip comments in code
- next if $line =~ /^\s*#/;
-
- # Would be nice if we could also check $in_string or something too
- if ($line eq '__END__') {
- $in_end++;
- next;
- }
- last if $line eq '__DATA__';
-
- # parse $line to see if it's a $VERSION declaration
- my( $vers_sig, $vers_fullname, $vers_pkg ) =
- ($line =~ /VERSION/)
- ? $self->_parse_version_expression( $line )
- : ();
-
- if ( $line =~ /$PKG_REGEXP/o ) {
- $pkg = $1;
- push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
- $vers{$pkg} = $2 unless exists( $vers{$pkg} );
- $need_vers = defined $2 ? 0 : 1;
-
- # VERSION defined with full package spec, i.e. $Module::VERSION
- } elsif ( $vers_fullname && $vers_pkg ) {
- push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
- $need_vers = 0 if $vers_pkg eq $pkg;
-
- unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
- $vers{$vers_pkg} =
- $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
- }
-
- # first non-comment line in undeclared package main is VERSION
- } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
- $need_vers = 0;
- my $v =
- $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
- $vers{$pkg} = $v;
- push( @pkgs, 'main' );
-
- # first non-comment line in undeclared package defines package main
- } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
- $need_vers = 1;
- $vers{main} = '';
- push( @pkgs, 'main' );
-
- # only keep if this is the first $VERSION seen
- } elsif ( $vers_fullname && $need_vers ) {
- $need_vers = 0;
- my $v =
- $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
-
-
- unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
- $vers{$pkg} = $v;
- }
-
- }
-
- }
-
- }
-
- if ( $self->{collect_pod} && length($pod_data) ) {
- $pod{$pod_sect} = $pod_data;
- }
-
- $self->{versions} = \%vers;
- $self->{packages} = \@pkgs;
- $self->{pod} = \%pod;
- $self->{pod_headings} = \@pod;
-}
-
-{
-my $pn = 0;
-sub _evaluate_version_line {
- my $self = shift;
- my( $sigil, $var, $line ) = @_;
-
- # Some of this code came from the ExtUtils:: hierarchy.
-
- # We compile into $vsub because 'use version' would cause
- # compiletime/runtime issues with local()
- my $vsub;
- $pn++; # everybody gets their own package
- my $eval = qq{BEGIN { my \$dummy = q# Hide from _packages_inside()
- #; package Module::Metadata::_version::p$pn;
- use version;
- no strict;
- no warnings;
-
- \$vsub = sub {
- local $sigil$var;
- \$$var=undef;
- $line;
- \$$var
- };
- }};
-
- $eval = $1 if $eval =~ m{^(.+)}s;
-
- local $^W;
- # Try to get the $VERSION
- eval $eval;
- # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
- # installed, so we need to hunt in ./lib for it
- if ( $@ =~ /Can't locate/ && -d 'lib' ) {
- local @INC = ('lib',@INC);
- eval $eval;
- }
- warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
- if $@;
- (ref($vsub) eq 'CODE') or
- croak "failed to build version sub for $self->{filename}";
- my $result = eval { $vsub->() };
- croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
- if $@;
-
- # Upgrade it into a version object
- my $version = eval { _dwim_version($result) };
-
- croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
- unless defined $version; # "0" is OK!
-
- return $version;
-}
-}
-
-# Try to DWIM when things fail the lax version test in obvious ways
-{
- my @version_prep = (
- # Best case, it just works
- sub { return shift },
-
- # If we still don't have a version, try stripping any
- # trailing junk that is prohibited by lax rules
- sub {
- my $v = shift;
- $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
- return $v;
- },
-
- # Activestate apparently creates custom versions like '1.23_45_01', which
- # cause version.pm to think it's an invalid alpha. So check for that
- # and strip them
- sub {
- my $v = shift;
- my $num_dots = () = $v =~ m{(\.)}g;
- my $num_unders = () = $v =~ m{(_)}g;
- my $leading_v = substr($v,0,1) eq 'v';
- if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
- $v =~ s{_}{}g;
- $num_unders = () = $v =~ m{(_)}g;
- }
- return $v;
- },
-
- # Worst case, try numifying it like we would have before version objects
- sub {
- my $v = shift;
- no warnings 'numeric';
- return 0 + $v;
- },
-
- );
-
- sub _dwim_version {
- my ($result) = shift;
-
- return $result if ref($result) eq 'version';
-
- my ($version, $error);
- for my $f (@version_prep) {
- $result = $f->($result);
- $version = eval { version->new($result) };
- $error ||= $@ if $@; # capture first failure
- last if defined $version;
- }
-
- croak $error unless defined $version;
-
- return $version;
- }
-}
-
-############################################################
-
-# accessors
-sub name { $_[0]->{module} }
-
-sub filename { $_[0]->{filename} }
-sub packages_inside { @{$_[0]->{packages}} }
-sub pod_inside { @{$_[0]->{pod_headings}} }
-sub contains_pod { 0+@{$_[0]->{pod_headings}} }
-
-sub version {
- my $self = shift;
- my $mod = shift || $self->{module};
- my $vers;
- if ( defined( $mod ) && length( $mod ) &&
- exists( $self->{versions}{$mod} ) ) {
- return $self->{versions}{$mod};
- } else {
- return undef;
- }
-}
-
-sub pod {
- my $self = shift;
- my $sect = shift;
- if ( defined( $sect ) && length( $sect ) &&
- exists( $self->{pod}{$sect} ) ) {
- return $self->{pod}{$sect};
- } else {
- return undef;
- }
-}
-
-1;
-
-=head1 NAME
-
-Module::Metadata - Gather package and POD information from perl module files
-
-=head1 SYNOPSIS
-
- use Module::Metadata;
-
- # information about a .pm file
- my $info = Module::Metadata->new_from_file( $file );
- my $version = $info->version;
-
- # CPAN META 'provides' field for .pm files in a directory
- my $provides = Module::Metadata->provides(
- dir => 'lib', version => 2
- );
-
-=head1 DESCRIPTION
-
-This module provides a standard way to gather metadata about a .pm file through
-(mostly) static analysis and (some) code execution. When determining the
-version of a module, the C<$VERSION> assignment is C<eval>ed, as is traditional
-in the CPAN toolchain.
-
-=head1 USAGE
-
-=head2 Class methods
-
-=over 4
-
-=item C<< new_from_file($filename, collect_pod => 1) >>
-
-Constructs a C<Module::Metadata> object given the path to a file. Returns
-undef if the filename does not exist.
-
-C<collect_pod> is a optional boolean argument that determines whether POD
-data is collected and stored for reference. POD data is not collected by
-default. POD headings are always collected.
-
-If the file begins by an UTF-8, UTF-16BE or UTF-16LE byte-order mark, then
-it is skipped before processing, and the content of the file is also decoded
-appropriately starting from perl 5.8.
-
-=item C<< new_from_handle($handle, $filename, collect_pod => 1) >>
-
-This works just like C<new_from_file>, except that a handle can be provided
-as the first argument.
-
-Note that there is no validation to confirm that the handle is a handle or
-something that can act like one. Passing something that isn't a handle will
-cause a exception when trying to read from it. The C<filename> argument is
-mandatory or undef will be returned.
-
-You are responsible for setting the decoding layers on C<$handle> if
-required.
-
-=item C<< new_from_module($module, collect_pod => 1, inc => \@dirs) >>
-
-Constructs a C<Module::Metadata> object given a module or package name.
-Returns undef if the module cannot be found.
-
-In addition to accepting the C<collect_pod> argument as described above,
-this method accepts a C<inc> argument which is a reference to an array of
-directories to search for the module. If none are given, the default is
-@INC.
-
-If the file that contains the module begins by an UTF-8, UTF-16BE or
-UTF-16LE byte-order mark, then it is skipped before processing, and the
-content of the file is also decoded appropriately starting from perl 5.8.
-
-=item C<< find_module_by_name($module, \@dirs) >>
-
-Returns the path to a module given the module or package name. A list
-of directories can be passed in as an optional parameter, otherwise
-@INC is searched.
-
-Can be called as either an object or a class method.
-
-=item C<< find_module_dir_by_name($module, \@dirs) >>
-
-Returns the entry in C<@dirs> (or C<@INC> by default) that contains
-the module C<$module>. A list of directories can be passed in as an
-optional parameter, otherwise @INC is searched.
-
-Can be called as either an object or a class method.
-
-=item C<< provides( %options ) >>
-
-This is a convenience wrapper around C<package_versions_from_directory>
-to generate a CPAN META C<provides> data structure. It takes key/value
-pairs. Valid option keys include:
-
-=over
-
-=item version B<(required)>
-
-Specifies which version of the L<CPAN::Meta::Spec> should be used as
-the format of the C<provides> output. Currently only '1.4' and '2'
-are supported (and their format is identical). This may change in
-the future as the definition of C<provides> changes.
-
-The C<version> option is required. If it is omitted or if
-an unsupported version is given, then C<provides> will throw an error.
-
-=item dir
-
-Directory to search recursively for F<.pm> files. May not be specified with
-C<files>.
-
-=item files
-
-Array reference of files to examine. May not be specified with C<dir>.
-
-=item prefix
-
-String to prepend to the C<file> field of the resulting output. This defaults
-to F<lib>, which is the common case for most CPAN distributions with their
-F<.pm> files in F<lib>. This option ensures the META information has the
-correct relative path even when the C<dir> or C<files> arguments are
-absolute or have relative paths from a location other than the distribution
-root.
-
-=back
-
-For example, given C<dir> of 'lib' and C<prefix> of 'lib', the return value
-is a hashref of the form:
-
- {
- 'Package::Name' => {
- version => '0.123',
- file => 'lib/Package/Name.pm'
- },
- 'OtherPackage::Name' => ...
- }
-
-=item C<< package_versions_from_directory($dir, \@files?) >>
-
-Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
-for those files in C<$dir> - and reads each file for packages and versions,
-returning a hashref of the form:
-
- {
- 'Package::Name' => {
- version => '0.123',
- file => 'Package/Name.pm'
- },
- 'OtherPackage::Name' => ...
- }
-
-The C<DB> and C<main> packages are always omitted, as are any "private"
-packages that have leading underscores in the namespace (e.g.
-C<Foo::_private>)
-
-Note that the file path is relative to C<$dir> if that is specified.
-This B<must not> be used directly for CPAN META C<provides>. See
-the C<provides> method instead.
-
-=item C<< log_info (internal) >>
-
-Used internally to perform logging; imported from Log::Contextual if
-Log::Contextual has already been loaded, otherwise simply calls warn.
-
-=back
-
-=head2 Object methods
-
-=over 4
-
-=item C<< name() >>
-
-Returns the name of the package represented by this module. If there
-are more than one packages, it makes a best guess based on the
-filename. If it's a script (i.e. not a *.pm) the package name is
-'main'.
-
-=item C<< version($package) >>
-
-Returns the version as defined by the $VERSION variable for the
-package as returned by the C<name> method if no arguments are
-given. If given the name of a package it will attempt to return the
-version of that package if it is specified in the file.
-
-=item C<< filename() >>
-
-Returns the absolute path to the file.
-
-=item C<< packages_inside() >>
-
-Returns a list of packages. Note: this is a raw list of packages
-discovered (or assumed, in the case of C<main>). It is not
-filtered for C<DB>, C<main> or private packages the way the
-C<provides> method does. Invalid package names are not returned,
-for example "Foo:Bar". Strange but valid package names are
-returned, for example "Foo::Bar::", and are left up to the caller
-on how to handle.
-
-=item C<< pod_inside() >>
-
-Returns a list of POD sections.
-
-=item C<< contains_pod() >>
-
-Returns true if there is any POD in the file.
-
-=item C<< pod($section) >>
-
-Returns the POD data in the given section.
-
-=back
-
-=head1 AUTHOR
-
-Original code from Module::Build::ModuleInfo by Ken Williams
-<kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
-
-Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
-assistance from David Golden (xdg) <dagolden@cpan.org>.
-
-=head1 COPYRIGHT & LICENSE
-
-Original code Copyright (c) 2001-2011 Ken Williams.
-Additional code Copyright (c) 2010-2011 Matt Trout and David Golden.
-All rights reserved.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=cut
-
+++ /dev/null
-use 5.008001;
-use strict;
-package Parse::CPAN::Meta;
-# ABSTRACT: Parse META.yml and META.json CPAN metadata files
-
-our $VERSION = '1.4417';
-
-use Exporter;
-use Carp 'croak';
-
-our @ISA = qw/Exporter/;
-our @EXPORT_OK = qw/Load LoadFile/;
-
-sub load_file {
- my ($class, $filename) = @_;
-
- my $meta = _slurp($filename);
-
- if ($filename =~ /\.ya?ml$/) {
- return $class->load_yaml_string($meta);
- }
- elsif ($filename =~ /\.json$/) {
- return $class->load_json_string($meta);
- }
- else {
- $class->load_string($meta); # try to detect yaml/json
- }
-}
-
-sub load_string {
- my ($class, $string) = @_;
- if ( $string =~ /^---/ ) { # looks like YAML
- return $class->load_yaml_string($string);
- }
- elsif ( $string =~ /^\s*\{/ ) { # looks like JSON
- return $class->load_json_string($string);
- }
- else { # maybe doc-marker-free YAML
- return $class->load_yaml_string($string);
- }
-}
-
-sub load_yaml_string {
- my ($class, $string) = @_;
- my $backend = $class->yaml_backend();
- my $data = eval { no strict 'refs'; &{"$backend\::Load"}($string) };
- croak $@ if $@;
- return $data || {}; # in case document was valid but empty
-}
-
-sub load_json_string {
- my ($class, $string) = @_;
- my $data = eval { $class->json_backend()->new->decode($string) };
- croak $@ if $@;
- return $data || {};
-}
-
-sub yaml_backend {
- if (! defined $ENV{PERL_YAML_BACKEND} ) {
- _can_load( 'CPAN::Meta::YAML', 0.011 )
- or croak "CPAN::Meta::YAML 0.011 is not available\n";
- return "CPAN::Meta::YAML";
- }
- else {
- my $backend = $ENV{PERL_YAML_BACKEND};
- _can_load( $backend )
- or croak "Could not load PERL_YAML_BACKEND '$backend'\n";
- $backend->can("Load")
- or croak "PERL_YAML_BACKEND '$backend' does not implement Load()\n";
- return $backend;
- }
-}
-
-sub json_backend {
- if (! $ENV{PERL_JSON_BACKEND} or $ENV{PERL_JSON_BACKEND} eq 'JSON::PP') {
- _can_load( 'JSON::PP' => 2.27103 )
- or croak "JSON::PP 2.27103 is not available\n";
- return 'JSON::PP';
- }
- else {
- _can_load( 'JSON' => 2.5 )
- or croak "JSON 2.5 is required for " .
- "\$ENV{PERL_JSON_BACKEND} = '$ENV{PERL_JSON_BACKEND}'\n";
- return "JSON";
- }
-}
-
-sub _slurp {
- require Encode;
- open my $fh, "<:raw", "$_[0]" ## no critic
- or die "can't open $_[0] for reading: $!";
- my $content = do { local $/; <$fh> };
- $content = Encode::decode('UTF-8', $content, Encode::PERLQQ());
- return $content;
-}
-
-sub _can_load {
- my ($module, $version) = @_;
- (my $file = $module) =~ s{::}{/}g;
- $file .= ".pm";
- return 1 if $INC{$file};
- return 0 if exists $INC{$file}; # prior load failed
- eval { require $file; 1 }
- or return 0;
- if ( defined $version ) {
- eval { $module->VERSION($version); 1 }
- or return 0;
- }
- return 1;
-}
-
-# Kept for backwards compatibility only
-# Create an object from a file
-sub LoadFile ($) { ## no critic
- return Load(_slurp(shift));
-}
-
-# Parse a document from a string.
-sub Load ($) { ## no critic
- require CPAN::Meta::YAML;
- my $object = eval { CPAN::Meta::YAML::Load(shift) };
- croak $@ if $@;
- return $object;
-}
-
-1;
-
-__END__
-
-=pod
-
-=encoding UTF-8
-
-=head1 NAME
-
-Parse::CPAN::Meta - Parse META.yml and META.json CPAN metadata files
-
-=head1 VERSION
-
-version 1.4417
-
-=head1 SYNOPSIS
-
- #############################################
- # In your file
-
- ---
- name: My-Distribution
- version: 1.23
- resources:
- homepage: "http://example.com/dist/My-Distribution"
-
-
- #############################################
- # In your program
-
- use Parse::CPAN::Meta;
-
- my $distmeta = Parse::CPAN::Meta->load_file('META.yml');
-
- # Reading properties
- my $name = $distmeta->{name};
- my $version = $distmeta->{version};
- my $homepage = $distmeta->{resources}{homepage};
-
-=head1 DESCRIPTION
-
-B<Parse::CPAN::Meta> is a parser for F<META.json> and F<META.yml> files, using
-L<JSON::PP> and/or L<CPAN::Meta::YAML>.
-
-B<Parse::CPAN::Meta> provides three methods: C<load_file>, C<load_json_string>,
-and C<load_yaml_string>. These will read and deserialize CPAN metafiles, and
-are described below in detail.
-
-B<Parse::CPAN::Meta> provides a legacy API of only two functions,
-based on the YAML functions of the same name. Wherever possible,
-identical calling semantics are used. These may only be used with YAML sources.
-
-All error reporting is done with exceptions (die'ing).
-
-Note that META files are expected to be in UTF-8 encoding, only. When
-converted string data, it must first be decoded from UTF-8.
-
-=begin Pod::Coverage
-
-
-
-
-=end Pod::Coverage
-
-=head1 METHODS
-
-=head2 load_file
-
- my $metadata_structure = Parse::CPAN::Meta->load_file('META.json');
-
- my $metadata_structure = Parse::CPAN::Meta->load_file('META.yml');
-
-This method will read the named file and deserialize it to a data structure,
-determining whether it should be JSON or YAML based on the filename.
-The file will be read using the ":utf8" IO layer.
-
-=head2 load_yaml_string
-
- my $metadata_structure = Parse::CPAN::Meta->load_yaml_string($yaml_string);
-
-This method deserializes the given string of YAML and returns the first
-document in it. (CPAN metadata files should always have only one document.)
-If the source was UTF-8 encoded, the string must be decoded before calling
-C<load_yaml_string>.
-
-=head2 load_json_string
-
- my $metadata_structure = Parse::CPAN::Meta->load_json_string($json_string);
-
-This method deserializes the given string of JSON and the result.
-If the source was UTF-8 encoded, the string must be decoded before calling
-C<load_json_string>.
-
-=head2 load_string
-
- my $metadata_structure = Parse::CPAN::Meta->load_string($some_string);
-
-If you don't know whether a string contains YAML or JSON data, this method
-will use some heuristics and guess. If it can't tell, it assumes YAML.
-
-=head2 yaml_backend
-
- my $backend = Parse::CPAN::Meta->yaml_backend;
-
-Returns the module name of the YAML serializer. See L</ENVIRONMENT>
-for details.
-
-=head2 json_backend
-
- my $backend = Parse::CPAN::Meta->json_backend;
-
-Returns the module name of the JSON serializer. This will either
-be L<JSON::PP> or L<JSON>. Even if C<PERL_JSON_BACKEND> is set,
-this will return L<JSON> as further delegation is handled by
-the L<JSON> module. See L</ENVIRONMENT> for details.
-
-=head1 FUNCTIONS
-
-For maintenance clarity, no functions are exported by default. These functions
-are available for backwards compatibility only and are best avoided in favor of
-C<load_file>.
-
-=head2 Load
-
- my @yaml = Parse::CPAN::Meta::Load( $string );
-
-Parses a string containing a valid YAML stream into a list of Perl data
-structures.
-
-=head2 LoadFile
-
- my @yaml = Parse::CPAN::Meta::LoadFile( 'META.yml' );
-
-Reads the YAML stream from a file instead of a string.
-
-=head1 ENVIRONMENT
-
-=head2 PERL_JSON_BACKEND
-
-By default, L<JSON::PP> will be used for deserializing JSON data. If the
-C<PERL_JSON_BACKEND> environment variable exists, is true and is not
-"JSON::PP", then the L<JSON> module (version 2.5 or greater) will be loaded and
-used to interpret C<PERL_JSON_BACKEND>. If L<JSON> is not installed or is too
-old, an exception will be thrown.
-
-=head2 PERL_YAML_BACKEND
-
-By default, L<CPAN::Meta::YAML> will be used for deserializing YAML data. If
-the C<PERL_YAML_BACKEND> environment variable is defined, then it is interpreted
-as a module to use for deserialization. The given module must be installed,
-must load correctly and must implement the C<Load()> function or an exception
-will be thrown.
-
-=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
-
-=head1 SUPPORT
-
-=head2 Bugs / Feature Requests
-
-Please report any bugs or feature requests through the issue tracker
-at L<https://github.com/Perl-Toolchain-Gang/Parse-CPAN-Meta/issues>.
-You will be notified automatically of any progress on your issue.
-
-=head2 Source Code
-
-This is open source software. The code repository is available for
-public review and contribution under the terms of the license.
-
-L<https://github.com/Perl-Toolchain-Gang/Parse-CPAN-Meta>
-
- git clone https://github.com/Perl-Toolchain-Gang/Parse-CPAN-Meta.git
-
-=head1 AUTHORS
-
-=over 4
-
-=item *
-
-Adam Kennedy <adamk@cpan.org>
-
-=item *
-
-David Golden <dagolden@cpan.org>
-
-=back
-
-=head1 CONTRIBUTORS
-
-=for stopwords Graham Knop Joshua ben Jore Karen Etheridge Neil Bowers Ricardo Signes Steffen Mueller
-
-=over 4
-
-=item *
-
-Graham Knop <haarg@haarg.org>
-
-=item *
-
-Joshua ben Jore <jjore@cpan.org>
-
-=item *
-
-Karen Etheridge <ether@cpan.org>
-
-=item *
-
-Neil Bowers <neil@bowers.com>
-
-=item *
-
-Ricardo Signes <rjbs@cpan.org>
-
-=item *
-
-Steffen Mueller <smueller@cpan.org>
-
-=back
-
-=head1 COPYRIGHT AND LICENSE
-
-This software is copyright (c) 2015 by Adam Kennedy and Contributors.
-
-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
sub load_cpan_meta {
my $dir = bz_locations()->{libpath};
- my @meta_json = map { File::Spec->catfile($dir, $_) } qw( MYMETA.json META.json );
- my ($file) = grep { -f $_ } @meta_json;
+ my $file = File::Spec->catfile($dir, 'MYMETA.json');
- if ($file) {
+ if (-f $file) {
open my $meta_fh, '<', $file or die "unable to open $file: $!";
my $str = do { local $/ = undef; scalar <$meta_fh> };
# detaint
=item C<load_cpan_meta>
-Load MYMETA.json or META.json from the bugzilla directory, and a return a L<CPAN::Meta> object.
+Load MYMETA.json from the bugzilla directory, and a return a L<CPAN::Meta> object.
=back
+++ /dev/null
-{
- "abstract" : "Bugzilla Bug Tracking System",
- "author" : [
- "Bugzilla Developers <developers@bugzilla.org>"
- ],
- "dynamic_config" : 1,
- "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150005",
- "license" : [
- "unknown"
- ],
- "meta-spec" : {
- "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
- "version" : "2"
- },
- "name" : "Bugzilla",
- "no_index" : {
- "directory" : [
- "t",
- "inc"
- ]
- },
- "optional_features" : {
- "auth_delegation" : {
- "description" : "Auth Delegation",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "LWP::UserAgent" : "0"
- }
- }
- }
- },
- "auth_ldap" : {
- "description" : "LDAP Authentication",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "Net::LDAP" : "0"
- }
- }
- }
- },
- "auth_radius" : {
- "description" : "RADIUS Authentication",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "Authen::Radius" : "0"
- }
- }
- }
- },
- "csp" : {
- "description" : "Content-Security-Policy support",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "MooX::StrictConstructor" : "0.008",
- "Type::Tiny" : "1"
- }
- }
- }
- },
- "db_from_env" : {
- "description" : "Support for using $ENV{DATABASE_URL}",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "URI::db" : "0.17"
- }
- }
- }
- },
- "detect_charset" : {
- "description" : "Automatic charset detection for text attachments",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "Encode" : "2.21",
- "Encode::Detect" : "0"
- }
- }
- }
- },
- "documentation" : {
- "description" : "Documentation",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "File::Copy::Recursive" : "0",
- "File::Which" : "0"
- }
- }
- }
- },
- "features" : {
- "description" : "Modules required to enable any feature",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "CPAN::Meta::Prereqs" : "2.132830",
- "CPAN::Meta::Requirements" : "2.121",
- "Module::Metadata" : "1.000019",
- "Module::Runtime" : "0"
- }
- }
- }
- },
- "graphical_reports" : {
- "description" : "Graphical Reports",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "GD" : "1.20",
- "GD::Graph" : "0",
- "GD::Text" : "0",
- "Template::Plugin::GD::Image" : "0"
- }
- }
- }
- },
- "html_desc" : {
- "description" : "More HTML in Product/Group Descriptions",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "HTML::Parser" : "3.67",
- "HTML::Scrubber" : "0"
- }
- }
- }
- },
- "inbound_email" : {
- "description" : "Inbound Email",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "Email::Reply" : "0",
- "HTML::FormatText::WithLinks" : "0.13"
- }
- }
- }
- },
- "jobqueue" : {
- "description" : "Mail Queueing",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "Daemon::Generic" : "0",
- "TheSchwartz" : "1.10"
- }
- }
- }
- },
- "jsonrpc" : {
- "description" : "JSON-RPC Interface",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "JSON::RPC" : "0"
- }
- }
- }
- },
- "markdown" : {
- "description" : "Markdown syntax support for comments",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "Text::MultiMarkdown" : "1.000034"
- }
- }
- }
- },
- "memcached" : {
- "description" : "Memcached Support",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "Cache::Memcached::Fast" : "0.17"
- }
- }
- }
- },
- "mod_perl" : {
- "description" : "mod_perl support under Apache",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "Apache2::SizeLimit" : "0.96",
- "mod_perl2" : "1.999022"
- }
- }
- }
- },
- "moving" : {
- "description" : "Move Bugs Between Installations",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "MIME::Parser" : "5.406",
- "XML::Twig" : "0"
- }
- }
- }
- },
- "mysql" : {
- "description" : "MySQL database support",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "DBD::mysql" : "4.001"
- }
- }
- }
- },
- "new_charts" : {
- "description" : "New Charts",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "Chart::Lines" : "v2.4.10",
- "GD" : "1.20"
- }
- }
- }
- },
- "old_charts" : {
- "description" : "Old Charts",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "Chart::Lines" : "v2.4.10",
- "GD" : "1.20"
- }
- }
- }
- },
- "oracle" : {
- "description" : "Oracle database support",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "DBD::Oracle" : "1.19"
- }
- }
- }
- },
- "patch_viewer" : {
- "description" : "Patch Viewer",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "PatchReader" : "v0.9.6"
- }
- }
- }
- },
- "pg" : {
- "description" : "Postgres database support",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "DBD::Pg" : "v2.19.3"
- }
- }
- }
- },
- "psgi" : {
- "description" : "Plack/PSGI support",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "CGI::Compile" : "0",
- "CGI::Emulate::PSGI" : "0",
- "Plack" : "1.0031"
- }
- }
- }
- },
- "smtp_auth" : {
- "description" : "SMTP Authentication",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "Authen::SASL" : "0"
- }
- }
- }
- },
- "smtp_ssl" : {
- "description" : "SSL Support for SMTP",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "Net::SMTP::SSL" : "1.01"
- }
- }
- }
- },
- "sqlite" : {
- "description" : "SQLite database support",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "DBD::SQLite" : "1.29"
- }
- }
- }
- },
- "typesniffer" : {
- "description" : "Sniff MIME type of attachments",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "File::MimeInfo::Magic" : "0",
- "IO::Scalar" : "0"
- }
- }
- }
- },
- "updates" : {
- "description" : "Automatic Update Notifications",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "LWP::UserAgent" : "0",
- "XML::Twig" : "0"
- }
- }
- }
- },
- "xmlrpc" : {
- "description" : "XML-RPC Interface",
- "prereqs" : {
- "runtime" : {
- "requires" : {
- "SOAP::Lite" : "0.712",
- "XMLRPC::Lite" : "0.712"
- }
- }
- }
- }
- },
- "prereqs" : {
- "build" : {
- "requires" : {
- "ExtUtils::MakeMaker" : "6.55"
- }
- },
- "configure" : {
- "requires" : {
- "ExtUtils::MakeMaker" : "6.55"
- }
- },
- "runtime" : {
- "recommends" : {
- "CPAN::Meta::Prereqs" : "2.132830",
- "CPAN::Meta::Requirements" : "2.121",
- "Module::Metadata" : "1.000019",
- "Module::Runtime" : "0",
- "Safe" : "2.30"
- },
- "requires" : {
- "CGI" : "4.09",
- "DBI" : "1.614",
- "Date::Format" : "2.23",
- "DateTime" : "0.75",
- "DateTime::TimeZone" : "1.64",
- "Digest::SHA" : "0",
- "Email::MIME" : "1.904",
- "Email::Sender" : "1.300011",
- "HTTP::Request" : "0",
- "HTTP::Response" : "0",
- "JSON::XS" : "2.01",
- "List::MoreUtils" : "0.32",
- "Math::Random::ISAAC" : "v1.0.1",
- "Module::Runtime" : "0",
- "Moo" : "2",
- "Template" : "2.24",
- "Test::Taint" : "1.06",
- "URI" : "1.55",
- "perl" : "5.014000"
- }
- },
- "test" : {
- "requires" : {
- "Pod::Checker" : "0",
- "Pod::Coverage" : "0",
- "Test2::Suite" : "0",
- "Test::More" : "0",
- "Test::Perl::Critic" : "0"
- }
- }
- },
- "release_status" : "stable",
- "version" : "v5.1.1+",
- "x_serialization_backend" : "JSON::PP version 2.27300"
-}
+++ /dev/null
----
-abstract: 'Bugzilla Bug Tracking System'
-author:
- - 'Bugzilla Developers <developers@bugzilla.org>'
-build_requires:
- ExtUtils::MakeMaker: '6.55'
- Pod::Checker: '0'
- Pod::Coverage: '0'
- Test2::Suite: '0'
- Test::More: '0'
- Test::Perl::Critic: '0'
-configure_requires:
- ExtUtils::MakeMaker: '6.55'
-dynamic_config: 1
-generated_by: 'ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150005'
-license: unknown
-meta-spec:
- url: http://module-build.sourceforge.net/META-spec-v1.4.html
- version: '1.4'
-name: Bugzilla
-no_index:
- directory:
- - t
- - inc
-optional_features:
- auth_delegation:
- description: 'Auth Delegation'
- requires:
- LWP::UserAgent: '0'
- auth_ldap:
- description: 'LDAP Authentication'
- requires:
- Net::LDAP: '0'
- auth_radius:
- description: 'RADIUS Authentication'
- requires:
- Authen::Radius: '0'
- csp:
- description: 'Content-Security-Policy support'
- requires:
- MooX::StrictConstructor: '0.008'
- Type::Tiny: '1'
- db_from_env:
- description: 'Support for using $ENV{DATABASE_URL}'
- requires:
- URI::db: '0.17'
- detect_charset:
- description: 'Automatic charset detection for text attachments'
- requires:
- Encode: '2.21'
- Encode::Detect: '0'
- documentation:
- description: Documentation
- requires:
- File::Copy::Recursive: '0'
- File::Which: '0'
- features:
- description: 'Modules required to enable any feature'
- requires:
- CPAN::Meta::Prereqs: '2.132830'
- CPAN::Meta::Requirements: '2.121'
- Module::Metadata: '1.000019'
- Module::Runtime: '0'
- graphical_reports:
- description: 'Graphical Reports'
- requires:
- GD: '1.20'
- GD::Graph: '0'
- GD::Text: '0'
- Template::Plugin::GD::Image: '0'
- html_desc:
- description: 'More HTML in Product/Group Descriptions'
- requires:
- HTML::Parser: '3.67'
- HTML::Scrubber: '0'
- inbound_email:
- description: 'Inbound Email'
- requires:
- Email::Reply: '0'
- HTML::FormatText::WithLinks: '0.13'
- jobqueue:
- description: 'Mail Queueing'
- requires:
- Daemon::Generic: '0'
- TheSchwartz: '1.10'
- jsonrpc:
- description: 'JSON-RPC Interface'
- requires:
- JSON::RPC: '0'
- markdown:
- description: 'Markdown syntax support for comments'
- requires:
- Text::MultiMarkdown: '1.000034'
- memcached:
- description: 'Memcached Support'
- requires:
- Cache::Memcached::Fast: '0.17'
- mod_perl:
- description: 'mod_perl support under Apache'
- requires:
- Apache2::SizeLimit: '0.96'
- mod_perl2: '1.999022'
- moving:
- description: 'Move Bugs Between Installations'
- requires:
- MIME::Parser: '5.406'
- XML::Twig: '0'
- mysql:
- description: 'MySQL database support'
- requires:
- DBD::mysql: '4.001'
- new_charts:
- description: 'New Charts'
- requires:
- Chart::Lines: v2.4.10
- GD: '1.20'
- old_charts:
- description: 'Old Charts'
- requires:
- Chart::Lines: v2.4.10
- GD: '1.20'
- oracle:
- description: 'Oracle database support'
- requires:
- DBD::Oracle: '1.19'
- patch_viewer:
- description: 'Patch Viewer'
- requires:
- PatchReader: v0.9.6
- pg:
- description: 'Postgres database support'
- requires:
- DBD::Pg: v2.19.3
- psgi:
- description: 'Plack/PSGI support'
- requires:
- CGI::Compile: '0'
- CGI::Emulate::PSGI: '0'
- Plack: '1.0031'
- smtp_auth:
- description: 'SMTP Authentication'
- requires:
- Authen::SASL: '0'
- smtp_ssl:
- description: 'SSL Support for SMTP'
- requires:
- Net::SMTP::SSL: '1.01'
- sqlite:
- description: 'SQLite database support'
- requires:
- DBD::SQLite: '1.29'
- typesniffer:
- description: 'Sniff MIME type of attachments'
- requires:
- File::MimeInfo::Magic: '0'
- IO::Scalar: '0'
- updates:
- description: 'Automatic Update Notifications'
- requires:
- LWP::UserAgent: '0'
- XML::Twig: '0'
- xmlrpc:
- description: 'XML-RPC Interface'
- requires:
- SOAP::Lite: '0.712'
- XMLRPC::Lite: '0.712'
-recommends:
- CPAN::Meta::Prereqs: '2.132830'
- CPAN::Meta::Requirements: '2.121'
- Module::Metadata: '1.000019'
- Module::Runtime: '0'
- Safe: '2.30'
-requires:
- CGI: '4.09'
- DBI: '1.614'
- Date::Format: '2.23'
- DateTime: '0.75'
- DateTime::TimeZone: '1.64'
- Digest::SHA: '0'
- Email::MIME: '1.904'
- Email::Sender: '1.300011'
- HTTP::Request: '0'
- HTTP::Response: '0'
- JSON::XS: '2.01'
- List::MoreUtils: '0.32'
- Math::Random::ISAAC: v1.0.1
- Module::Runtime: '0'
- Moo: '2'
- Template: '2.24'
- Test::Taint: '1.06'
- URI: '1.55'
- perl: '5.014000'
-version: v5.1.1+
-x_serialization_backend: 'CPAN::Meta::YAML version 0.018'
use strict;
use warnings;
-use lib qw(. lib local/lib/perl5);
+use File::Basename;
+use File::Spec;
+BEGIN {
+ require lib;
+ my $dir = File::Spec->rel2abs(dirname(__FILE__));
+ lib->import($dir, File::Spec->catdir($dir, "lib"), File::Spec->catdir($dir, qw(local lib perl5)));
+}
use ExtUtils::MakeMaker 6.55;
use Bugzilla::Constants qw(BUGZILLA_VERSION);
}
}
-# META.json and META.yml exist only for the benefit of older
-# installs where cpanm can't get the optional features out of Makefile.PL
-# Unfortunately having META.json and META.yml commited to the repo is weird
-# and MakeMaker always prefers their content to the internal data (unless CPAN::META
-# is not installed).
-# Since we (Bugzilla) require this cludge, we hide the files from MakeMaker.
-BEGIN {
- warn "Hiding META.{json,yml} from MakeMaker...\n";
- rename( 'META.json', 'META.json.hide' ) || unlink("META.json");
- rename( 'META.yml', 'META.yml.hide' ) || unlink("META.yml");
-
- if (!eval { ExtUtils::MakeMaker->VERSION('6.57_07') }) {
- warn "WARNING: ExtUtils::MakeMaker should be at least 6.57_07 in order to support updating META.json files\n";
- }
-}
-
-END {
- warn "Unhiding META.{json,yml}...\n";
- rename( 'META.json.hide', 'META.json' );
- rename( 'META.yml.hide', 'META.yml' );
-}
-
# PREREQ_PM
my %requires = (
'CGI' => '4.09',
GEN_CPANFILE_ARGS = -A -U mod_perl -U oracle
cpanfile: MYMETA.json
\t\$(PERLRUN) gen-cpanfile.pl \$(GEN_CPANFILE_ARGS)
-
-checksetup_lib: Makefile.PL
-\tcpanm -L .checksetup_lib --notest \\
- CPAN::Meta JSON::PP CPAN::Meta::Requirements \\
- Module::Metadata\@$all_features{'Module::Metadata'}
-\t-rm -fr .checksetup_lib/man
-\t-rm -fr .checksetup_lib/lib/perl5/*/.meta
-\t-rm -fr .checksetup_lib/lib/perl5/Test
-\t-rm -fr .checksetup_lib/lib/perl5/ok.pm
-\t-find .checksetup_lib '(' -name '*.pod' -or -name .packlist ')' -print0 | xargs -0 rm -f
-
-META.json: Makefile.PL
-\tmake distmeta 2>&1 /dev/null; mv */META.json .
-
-META.yml: Makefile.PL
-\tmake distmeta 2>&1 /dev/null; mv */META.yml .
MAKE
}
use warnings;
use File::Basename;
-BEGIN { chdir dirname($0); }
-use lib qw(. lib local/lib/perl5 .checksetup_lib/lib/perl5);
-
-# the @INC which checksetup needs to operate against.
-our @BUGZILLA_INC = grep { !/checksetup_lib/ } @INC;
+use File::Spec;
+BEGIN {
+ require lib;
+ my $dir = File::Spec->rel2abs(dirname(__FILE__));
+ lib->import($dir, File::Spec->catdir($dir, "lib"), File::Spec->catdir($dir, qw(local lib perl5)));
+ chdir($dir);
+}
use Getopt::Long qw(:config bundling);
use Pod::Usage;
$ENV{BZ_SILENT_MAKEFILE} = 1;
system($^X, "Makefile.PL");
+if (! -f "MYMETA.json") {
+ die "Makefile.PL failed to generate a MYMETA.json file.",
+ "Try upgrading ExtUtils::MakeMaker";
+}
+
my $meta = load_cpan_meta();
if (keys %{$meta->{optional_features}} < 1) {
- warn "Your version of ExtUtils::MakeMaker is probably too old\n";
- warn "Falling back to static (and wrong) META.json\n";
- unlink('MYMETA.json');
- $meta = load_cpan_meta();
+ die "Your version of ExtUtils::MakeMaker is too old or broken\n";
}
-my $requirements = check_cpan_requirements($meta, \@BUGZILLA_INC, !$silent);
+my $requirements = check_cpan_requirements($meta, [@INC], !$silent);
exit 1 unless $requirements->{ok};
-check_all_cpan_features($meta, \@BUGZILLA_INC, !$silent);
+check_all_cpan_features($meta, [@INC], !$silent);
exit 0 if $switch{'check-modules'};
###########################################################################
[% ELSIF error == "cookies_need_value" %]
Every cookie must have a value.
[% ELSIF error == "cpan_meta_missing" %]
- META.json/MYMETA.json file is missing.
+ MYMETA.json file is missing.
[% ELSIF error == "env_no_email" %]
Bugzilla did not receive an email address from the
environment.
projects / thirdparty / bugzilla.git / commitdiff
