File Coverage

blib/lib/MarpaX/ESLIF/ECMA404/ValueInterface.pm

Criterion	Covered	Total	%
statement	44	64	68.7
branch	5	18	27.7
condition	11	18	61.1
subroutine	15	19	78.9
pod	14	14	100.0
total	89	133	66.9

use strict;
use warnings FATAL => 'all';

package MarpaX::ESLIF::ECMA404::ValueInterface;
use Math::BigInt;
use Math::BigFloat;
use Carp qw/croak/;

our $FFFD = chr(0xFFFD);

# ABSTRACT: MarpaX::ESLIF::ECMA404 Value Interface

our $VERSION = '0.012'; # VERSION

our $AUTHORITY = 'cpan:JDDPAUSE'; # AUTHORITY


# -----------
# Constructor
# -----------


sub new {
    my ($pkg, %options) = @_;

    return bless { result => undef, %options }, $pkg
}

# ----------------
# Required methods
# ----------------


sub isWithHighRankOnly { return 1 }  # When there is the rank adverb: highest ranks only ?


sub isWithOrderByRank  { return 1 }  # When there is the rank adverb: order by rank ?


sub isWithAmbiguous    { return 0 }  # Allow ambiguous parse ?


sub isWithNull         { return 0 }  # Allow null parse ?


sub maxParses          { return 0 }  # Maximum number of parse tree values


sub getResult          { return $_[0]->{result} }


sub setResult          { return $_[0]->{result} = $_[1] }

# ----------------
# Specific actions
# ----------------


sub unicode {
  my ($self, $u) = @_;

  my @hex;
  while ($u =~ m/\\u([[:xdigit:]]{4})/g) {
    push(@hex, hex($1))
  }

  my $result;
  while (@hex) {
    if ($#hex > 0) {
      my ($high, $low) = @hex;
      #
      # An UTF-16 surrogate pair ?
      #
      if (($high >= 0xD800) && ($high <= 0xDBFF) && ($low >= 0xDC00) && ($low <= 0xDFFF)) {
        #
        # Yes.
        # This is evaled for one reason only: some old versions of perl may croak with special characters like
        # "Unicode character 0x10ffff is illegal"
        #
        $result .= eval {chr((($high - 0xD800) * 0x400) + ($low - 0xDC00) + 0x10000)} // $FFFD;
        splice(@hex, 0, 2)
      } else {
        #
        # No. Take first \uhhhh as a code point. Fallback to replacement character 0xFFFD if invalid.
        # Eval returns undef in scalar context if there is a failure.
        #
        $result .= eval {chr(shift @hex) } // $FFFD
      }
    } else {
      #
      # \uhhhh taken as a code point. Fallback to replacement character 0xFFFD if invalid.
      # Eval returns undef in scalar context if there is a failure.
      #
      $result .= eval {chr(shift @hex) } // $FFFD
    }
  }

  return $result
}


sub members {
    do { shift, return { map { $_->[0] => $_->[1] } @_ } } if !$_[0]->{disallow_dupkeys};

    my $self = shift;

    #
    # Arguments are: ($self, $pair1, $pair2, etc..., $pairn)
    #
    my %hash;
    foreach (@_) {
      my ($key, $value) = @{$_};
      if (exists $hash{$key}) {
        if ($self->{disallow_dupkeys}) {
          #
          # Just make sure the key printed out contains only printable things
          #
          my $ascii = $key;
          $ascii =~ s/[^[:print:]]/ /g;
          $ascii .= " (printable characters only)" unless $ascii eq $key;
          $self->{logger}->errorf('Duplicate key %s', $ascii) if $self->{logger};
          croak "Duplicate key $ascii"
        } else {
          $self->{logger}->warnf('Duplicate key %s', $key) if $self->{logger}
        }
      }
      $hash{$key} = $value
    }

    return \%hash
}


sub number {
  my ($self, $number) = @_;
  #
  # We are sure this is a float if there is the dot '.' or the exponent [eE]
  #
  return ($number =~ /[\.eE]/) ? Math::BigFloat->new($number) : Math::BigInt->new($number)
}


sub nan {
    return Math::BigInt->bnan()
}


sub negative_infinity {
    return Math::BigInt->binf('-')
}


sub positive_infinity {
    return Math::BigInt->binf()
}


1;

__END__