view release on metacpan or  search on metacpan

bundled/CPAN-Meta-Requirements/CPAN/Meta/Requirements.pm  view on Meta::CPAN

#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 "require 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;

  # 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;
  }

  eval {
    if (not defined $version or $version eq '0') {
      $vobj = $V0;
    }
    elsif ( ref($version) eq 'version' || _isa_version($version) ) {
      $vobj = $version;
    }
    else {
      local $SIG{__WARN__} = sub { die "Invalid version: $_[0]" };
      $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";
    }
  }