view release on metacpan or  search on metacpan

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

use 5.010001;
use strict;
use warnings;
no warnings 'recursion';

package BSON::PP;
# ABSTRACT: Pure Perl BSON implementation

use version;
our $VERSION = 'v1.12.2';

use B;
use Carp;
use Config;
use Scalar::Util qw/blessed looks_like_number refaddr reftype/;
use List::Util qw/first/;
use Tie::IxHash;

use BSON::Types ();
use boolean;
use mro;

use re 'regexp_pattern';

use constant {
    HAS_INT64 => $Config{use64bitint},
};

use if !HAS_INT64, "Math::BigInt";

# Max integer sizes
my $max_int32 = 2147483647;
my $min_int32 = -2147483648;
my $max_int64 =
  HAS_INT64 ? 9223372036854775807 : Math::BigInt->new("9223372036854775807");
my $min_int64 =
  HAS_INT64 ? -9223372036854775808 : Math::BigInt->new("-9223372036854775808");

#<<<
my $int_re     = qr/^(?:(?:[+-]?)(?:[0123456789]+))$/;
my $doub_re    = qr/^(?:(?i)(?:NaN|-?Inf(?:inity)?)|(?:[+-]?)(?:(?=[0123456789]|[.])(?:[0123456789]*)(?:(?:[.])(?:[0123456789]{0,}))?)(?:(?:[E])(?:(?:[+-]?)(?:[0123456789]+))|))$/;
#>>>

my $bools_re = qr/::(?:Boolean|_Bool|Bool)\z/;

use constant {

    BSON_TYPE_NAME => "CZ*",
    BSON_DOUBLE => "d<",
    BSON_STRING => "V/Z*",
    BSON_BOOLEAN => "C",
    BSON_REGEX => "Z*Z*",
    BSON_JSCODE => "",
    BSON_INT32 => "l<",
    BSON_UINT32 => "L<",
    BSON_INT64 => "q<",
    BSON_8BYTES => "a8",
    BSON_16BYTES => "a16",
    BSON_TIMESTAMP => "L<L<",
    BSON_CODE_W_SCOPE => "l<",
    BSON_REMAINING => 'a*',
    BSON_SKIP_4_BYTES => 'x4',
    BSON_OBJECTID => 'a12',
    BSON_BINARY_TYPE => 'C',
    BSON_CSTRING => 'Z*',
    BSON_MAX_DEPTH => 100,
};

sub _printable {
    my $value = shift;
    $value =~ s/([^[:print:]])/sprintf("\\x%02x",ord($1))/ge;
    return $value;
}

sub _split_re {

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

                else {
                    $bson .= pack( BSON_TYPE_NAME, 0x0D, $utf8_key) . $code;
                }
            }

            # Boolean
            elsif ( $type eq 'boolean' || $type =~ $bools_re ) {
                $bson .= pack( BSON_TYPE_NAME.BSON_BOOLEAN, 0x08, $utf8_key, ( $value ? 1 : 0 ) );
            }

            # String (explicit)
            elsif ( $type eq 'BSON::String' || $type eq 'BSON::Symbol') {
                $value = $value->value;
                utf8::encode($value);
                $bson .= pack( BSON_TYPE_NAME.BSON_STRING, 0x02, $utf8_key, $value );
            }
            elsif ( $type eq 'MongoDB::BSON::String' ) {
                $value = $$value;
                utf8::encode($value);
                $bson .= pack( BSON_TYPE_NAME.BSON_STRING, 0x02, $utf8_key, $value );
            }

            # Int64 (XXX and eventually BigInt)
            elsif ( $type eq 'BSON::Int64' || $type eq 'Math::BigInt' || $type eq 'Math::Int64' )
            {
                if ( $value > $max_int64 || $value < $min_int64 ) {
                    croak("BSON can only handle 8-byte integers. Key '$key' is '$value'");
                }

                # unwrap BSON::Int64; it could be Math::BigInt, etc.
                if ( $type eq 'BSON::Int64' ) {
                    $value = $value->value;
                }

                $bson .= pack( BSON_TYPE_NAME, 0x12, $utf8_key ) . _pack_int64($value);
            }

            elsif ( $type eq 'BSON::Int32' ) {
                $bson .= pack( BSON_TYPE_NAME . BSON_INT32, 0x10, $utf8_key, $value->value );
            }

            # Double (explicit)
            elsif ( $type eq 'BSON::Double' ) {
                $bson .= pack( BSON_TYPE_NAME.BSON_DOUBLE, 0x01, $utf8_key, $value/1.0 );
            }

            # Decimal128
            elsif ( $type eq 'BSON::Decimal128' ) {
                $bson .= pack( BSON_TYPE_NAME.BSON_16BYTES, 0x13, $utf8_key, $value->bytes );
            }

            # Unsupported type
            else  {
                croak("For key '$key', can't encode value of type '$type'");
            }
        }

        # SCALAR
        else {
            # If a numeric value exists based on internal flags, use it;
            # otherwise, if prefer_numeric is true and it looks like a
            # number, then coerce to a number of the right type;
            # otherwise, leave it as a string

            my $flags = B::svref_2object(\$value)->FLAGS;

            if ( $flags & B::SVf_NOK() ) {
                $bson .= pack( BSON_TYPE_NAME.BSON_DOUBLE, 0x01, $utf8_key, $value );
            }
            elsif ( $flags & B::SVf_IOK() ) {
                # Force numeric; fixes dual-vars comparison bug on old Win32s
                $value = 0+$value;
                if ( $value > $max_int64 || $value < $min_int64 ) {
                    croak("BSON can only handle 8-byte integers. Key '$key' is '$value'");
                }
                elsif ( $value > $max_int32 || $value < $min_int32 ) {
                    $bson .= pack( BSON_TYPE_NAME, 0x12, $utf8_key ) . _pack_int64($value);
                }
                else {
                    $bson .= pack( BSON_TYPE_NAME . BSON_INT32, 0x10, $utf8_key, $value );
                }
            }
            elsif ( $opt->{prefer_numeric} && looks_like_number($value) ) {
                # Looks like int: type heuristic based on size
                if ( $value =~ $int_re ) {
                    if ( $value > $max_int64 || $value < $min_int64 ) {
                        croak("BSON can only handle 8-byte integers. Key '$key' is '$value'");
                    }
                    elsif ( $value > $max_int32 || $value < $min_int32 ) {
                        $bson .= pack( BSON_TYPE_NAME, 0x12, $utf8_key ) . _pack_int64($value);
                    }
                    else {
                        $bson .= pack( BSON_TYPE_NAME . BSON_INT32, 0x10, $utf8_key, $value );
                    }
                }

                # Looks like double
                elsif ( $value =~ $doub_re ) {
                    $bson .= pack( BSON_TYPE_NAME.BSON_DOUBLE, 0x01, $utf8_key, $value );
                }

                # looks_like_number true, but doesn't match int/double
                # regexes, so as a last resort we leave as string
                else {
                    utf8::encode($value);
                    $bson .= pack( BSON_TYPE_NAME.BSON_STRING, 0x02, $utf8_key, $value );
                }
            }
            else {
                # Not coercing or didn't look like a number
                utf8::encode($value);
                $bson .= pack( BSON_TYPE_NAME.BSON_STRING, 0x02, $utf8_key, $value );
            }
        }
    }

    delete $opt->{_circular}{$refaddr};
    $opt->{_depth}--;

    return pack( BSON_INT32, length($bson) + 5 ) . $bson . "\0";
}

my %FIELD_SIZES = (
    0x01 => 8,
    0x02 => 5,
    0x03 => 5,
    0x04 => 5,
    0x05 => 5,
    0x06 => 0,
    0x07 => 12,
    0x08 => 1,
    0x09 => 8,
    0x0A => 0,
    0x0B => 2,
    0x0C => 17,
    0x0D => 5,
    0x0E => 5,
    0x0F => 11,
    0x10 => 4,
    0x11 => 8,
    0x12 => 8,
    0x13 => 16,
    0x7F => 0,
    0xFF => 0,
);

my $ERR_UNSUPPORTED = "unsupported BSON type \\x%X for key '%s'.  Are you using the latest version of BSON.pm?";
my $ERR_TRUNCATED = "premature end of BSON field '%s' (type 0x%x)";
my $ERR_LENGTH = "BSON field '%s' (type 0x%x) has invalid length: wanted %d, got %d";
my $ERR_MISSING_NULL = "BSON field '%s' (type 0x%x) missing null terminator";
my $ERR_BAD_UTF8 = "BSON field '%s' (type 0x%x) contains invalid UTF-8";
my $ERR_NEG_LENGTH = "BSON field '%s' (type 0x%x) contains negative length";
my $ERR_BAD_OLDBINARY = "BSON field '%s' (type 0x%x, subtype 0x02) is invalid";

sub __dump_bson {
    my $bson = unpack("H*", shift);
    my @pairs = $bson=~ m/(..)/g;
    return join(" ", @pairs);
}

sub _decode_bson {
    my ($bson, $opt) = @_;