view release on metacpan or  search on metacpan

lib/BSON/Decimal128.pm  view on Meta::CPAN

#pod If not provided, it will be generated from the C<value> attribute on
#pod demand.
#pod
#pod =cut

has 'bytes' => (
    is => 'lazy',
);

use namespace::clean -except => 'meta';

use constant {
    PLIM  => 34,    # precision limit, i.e. max coefficient chars
    EMAX  => 6144,  # for 9.999999999999999999999999999999999E+6144
    EMIN  => -6143, # for 1.000000000000000000000000000000000E-6143
    AEMAX => 6111,  # EMAX - (PLIM - 1); largest encodable exponent
    AEMIN => -6176, # EMIN - (PLIM - 1); smallest encodable exponent
    BIAS  => 6176,  # offset for encoding exponents
};

my $digits     = qr/[0-9]+/;
my $decimal_re = qr{
    ( [-+]? )                                        # maybe a sign
    ( (?:$digits \. $digits? ) | (?: \.? $digits ) ) # decimal-part
    ( (?:e [-+]? $digits)? )                         # maybe exponent
}ix;

sub _build_value {
    return _bid_to_string( $_[0]->{bytes} );
}

sub _build_bytes {
    return _string_to_bid( $_[0]->{value} );
}

sub BUILD {
    my $self = shift;

    croak "One and only one of 'value' or 'bytes' must be provided"
        unless 1 == grep { exists $self->{$_} } qw/value bytes/;

    # must check for errors and canonicalize value if provided
    if (exists $self->{value}) {
        $self->{value} = _bid_to_string( $self->bytes );
    }

    return;
}

sub _bid_to_string {
    my $bid = shift;
    my $binary = unpack( "B*", scalar reverse($bid) );
    my ( $coef, $e );

    # sign bit
    my $pos = !substr( $binary, 0, 1 );

    # detect special values from first 5 bits after sign bit
    my $special = substr( $binary, 1, 5 );
    if ( $special eq "11111" ) {
        return "NaN";
    }
    if ( $special eq "11110" ) {
        return $pos ? "Infinity" : "-Infinity";
    }

    if ( substr( $binary, 1, 2 ) eq '11' ) {
        # Bits: 1*sign 2*ignored 14*exponent 111*significand.
        # Implicit 0b100 prefix in significand.
        $coef = "" . Math::BigInt->new( "0b100" . substr( $binary, 17 ) );
        $e = unpack( "n", pack( "B*", "00" . substr( $binary, 3, 14 ) ) ) - BIAS;
    }
    else {
        # Bits: 1*sign 14*exponent 113*significand
        $coef = "" . Math::BigInt->new( "0b" . substr( $binary, 15 ) );
        $e = unpack( "n", pack( "B*", "00" . substr( $binary, 1, 14 ) ) ) - BIAS;
    }

    # Out of range is treated as zero
    if ( length($coef) > PLIM ) {
        $coef = "0";
    }

    # Shortcut on zero
    if ( $coef == 0 && $e == 0 ) {
        return $pos ? "0" : "-0";
    }

    # convert to scientific form ( e.g. 123E+4 -> 1.23E6 )
    my $adj_exp = $e + length($coef) - 1;
    # warn "# XXX COEF: $coef; EXP: $e; AEXP: $adj_exp\n";

    # exponential notation
    if ( $e > 0 || $adj_exp < -6 ) {
        # insert decimal if more than one digit
        if ( length($coef) > 1 ) {
            substr( $coef, 1, 0, "." );
        }

        return (
            ( $pos ? "" : "-" ) . $coef . "E" . ( $adj_exp >= 0 ? "+" : "" ) . $adj_exp );
    }

    # not exponential notation (integers or small negative exponents)
    else {
        # e == 0 means integer
        return $pos ? $coef : "-$coef"
          if $e == 0;

        # pad with leading zeroes if coefficient is too short
        if ( length($coef) < abs($e) ) {
            substr( $coef, 0, 0, "0" x ( abs($e) - length($coef) ) );
        }

        # maybe coefficient is exact length?
        return $pos ? "0.$coef" : "-0.$coef"
          if length($coef) == abs($e);

        # otherwise length(coef) > abs($e), so insert dot after first digit
        substr( $coef, $e, 0, "." );
        return $pos ? $coef : "-$coef";
    }
}

my ( $bidNaN, $bidPosInf, $bidNegInf ) =
  map { scalar reverse pack( "B*", $_ . ( "0" x 118 ) ) } qw/ 011111 011110 111110 /;

sub _croak { croak("Couldn't parse '$_[0]' as valid Decimal128") }

sub _erange { croak("Value '$_[0]' is out of range for Decimal128") }

sub _erounding { croak("Value '$_[0]' can't be rounded to Decimal128") }

sub _string_to_bid {
    my $s = shift;

    # Check special values
    return $bidNaN    if $s =~ /\A -? NaN \z/ix;
    return $bidPosInf if $s =~ /\A \+?Inf(?:inity)? \z/ix;
    return $bidNegInf if $s =~ /\A -Inf(?:inity)? \z/ix;

    # Parse string
    my ( $sign, $mant, $exp ) = $s =~ /\A $decimal_re \z/x;
    $sign = "" unless defined $sign;
    $exp = 0 unless defined $exp && length($exp);
    $exp =~ s{^e}{}i;

    # Throw error if unparseable
    _croak($s) unless length $exp && defined $mant;

    # Extract sign bit
    my $neg = defined($sign) && $sign eq '-' ? "1" : "0";

    # Remove leading zeroes unless "0."
    $mant =~ s{^(?:0(?!\.))+}{};

    # Locate decimal, remove it and adjust the exponent
    my $dot = index( $mant, "." );
    $mant =~ s/\.//;
    $exp += $dot - length($mant) if $dot >= 0;

    # Remove leading zeros from mantissa (after decimal point removed)
    $mant =~ s/^0+//;
    $mant = "0" unless length $mant;

    # Apply exact rounding if necessary
    if ( length($mant) > PLIM ) {
        my $plim = PLIM;
        $mant =~ s{(.{$plim})(0+)$}{$1};
        $exp += length($2) if defined $2 && length $2;
    }
    elsif ( $exp < AEMIN ) {
        $mant =~ s{(.*[1-9])(0+)$}{$1};
        $exp += length($2) if defined $2 && length $2;
    }

    # Apply clamping if possible
    if ( $mant == 0 ) {
        if ( $exp > AEMAX ) {
            $mant = "0";
            $exp = AEMAX;
        }
        elsif ( $exp < AEMIN ) {
            $mant = "0";
            $exp = AEMIN;
        }
    }
    elsif ( $exp > AEMAX && $exp - AEMAX <= PLIM - length($mant) ) {
        $mant .= "0" x ( $exp - AEMAX );
        $exp = AEMAX;
    }

    # Throw errors if result won't fit in Decimal128
    _erounding($s) if length($mant) > PLIM;
    _erange($s) if $exp > AEMAX || $exp < AEMIN;

    # Get binary representation of coefficient
    my $coef = Math::BigInt->new($mant)->as_bin;