File: Decimal128.pm

package info (click to toggle)
libbson-perl 1.10.2-1
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 1,152 kB
  • sloc: perl: 3,970; makefile: 2
file content (368 lines) | stat: -rw-r--r-- 9,768 bytes parent folder | download
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.10.2';

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://github.com/mongodb/specifications/blob/master/source/extended-json.rst>
#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.10.2

=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://github.com/mongodb/specifications/blob/master/source/extended-json.rst>
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) 2018 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: