/usr/share/perl5/BSON/Decimal128.pm is in libbson-perl 1.4.0-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 | use 5.010001;
use strict;
use warnings;
package BSON::Decimal128;
# ABSTRACT: BSON type wrapper for Decimal128
use version;
our $VERSION = 'v1.4.0';
use Carp;
use Math::BigInt;
use Moo;
#pod =attr value
#pod
#pod The Decimal128 value represented as string. If not provided, it will be
#pod generated from the C<bytes> attribute on demand.
#pod
#pod =cut
has 'value' => (
is => 'lazy',
);
#pod =attr bytes
#pod
#pod The Decimal128 value represented in L<Binary Integer
#pod Decimal|https://en.wikipedia.org/wiki/Binary_Integer_Decimal> (BID) format.
#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;
$coef =~ s/^0b//;
# Get 14-bit binary representation of biased exponent
my $biased_exp = unpack( "B*", pack( "n", $exp + BIAS ) );
substr( $biased_exp, 0, 2, "" );
# Choose representation based on coefficient length
my $coef_len = length($coef);
if ( $coef_len <= 113 ) {
substr( $coef, 0, 0, "0" x ( 113 - $coef_len ) );
return scalar reverse pack( "B*", $neg . $biased_exp . $coef );
}
elsif ( $coef_len <= 114 ) {
substr( $coef, 0, 3, "" );
return scalar reverse pack( "B*", $neg . "11" . $biased_exp . $coef );
}
else {
_erange($s);
}
}
#pod =method TO_JSON
#pod
#pod Returns the value as a string.
#pod
#pod If the C<BSON_EXTJSON> option is true, it will instead
#pod be compatible with MongoDB's L<extended JSON|https://docs.mongodb.org/manual/reference/mongodb-extended-json/>
#pod format, which represents it as a document as follows:
#pod
#pod {"$numberDecimal" : "2.23372036854775807E+57"}
#pod
#pod =cut
sub TO_JSON {
return "" . $_[0]->value unless $ENV{BSON_EXTJSON};
return { '$numberDecimal' => "" . ($_[0]->value) };
}
use overload (
q{""} => sub { $_[0]->value },
fallback => 1,
);
1;
=pod
=encoding UTF-8
=head1 NAME
BSON::Decimal128 - BSON type wrapper for Decimal128
=head1 VERSION
version v1.4.0
=head1 SYNOPSIS
use BSON::Types ':all';
# string representation
$decimal = bson_decimal128( "1.23456789E+1000" );
# binary representation in BID format
$decimal = BSON::Decimal128->new( bytes => $bid )
=head1 DESCRIPTION
This module provides a BSON type wrapper for Decimal128 values.
It may be initialized with either a numeric value in string form, or
with a binary Decimal128 representation (16 bytes), but not both.
Initialization from a string will throw an error if the string cannot be
parsed as a Decimal128 or if the resulting number would not fit into 128
bits. If required, clamping or exact rounding will be applied to try to
fit the value into 128 bits.
=head1 ATTRIBUTES
=head2 value
The Decimal128 value represented as string. If not provided, it will be
generated from the C<bytes> attribute on demand.
=head2 bytes
The Decimal128 value represented in L<Binary Integer
Decimal|https://en.wikipedia.org/wiki/Binary_Integer_Decimal> (BID) format.
If not provided, it will be generated from the C<value> attribute on
demand.
=head1 METHODS
=head2 TO_JSON
Returns the value as a string.
If the C<BSON_EXTJSON> option is true, it will instead
be compatible with MongoDB's L<extended JSON|https://docs.mongodb.org/manual/reference/mongodb-extended-json/>
format, which represents it as a document as follows:
{"$numberDecimal" : "2.23372036854775807E+57"}
=for Pod::Coverage BUILD
=head1 OVERLOADING
The stringification operator (C<"">) is overloaded to return a (normalized)
string representation. Fallback overloading is enabled.
=head1 AUTHORS
=over 4
=item *
David Golden <david@mongodb.com>
=item *
Stefan G. <minimalist@lavabit.com>
=back
=head1 COPYRIGHT AND LICENSE
This software is Copyright (c) 2017 by Stefan G. and MongoDB, Inc.
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut
__END__
# vim: set ts=4 sts=4 sw=4 et tw=75:
|