use 5.010001;
use strict;
use warnings;
package BSON::PP;
# ABSTRACT: Pure Perl BSON implementation
use version;
our $VERSION = 'v1.6.0';
use B;
use Carp;
use Config;
use Scalar::Util qw/blessed looks_like_number refaddr reftype/;
use Tie::IxHash;
use BSON::Types ();
use boolean;
use if $] ge '5.010000', '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_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*',
};
sub _printable {
my $value = shift;
$value =~ s/([^[:print:]])/sprintf("\\x%02x",ord($1))/ge;
return $value;
}
sub _split_re {
my $value = shift;
if ( $] ge 5.010 ) {
return re::regexp_pattern($value);
}
else {
$value =~ s/^\(\?\^?//;
$value =~ s/\)$//;
my ( $opt, $re ) = split( /:/, $value, 2 );
$opt =~ s/\-\w+$//;
return ( $re, $opt );
}
}
sub _ixhash_iterator {
my $ixhash = shift;
my $started = 0;
return sub {
my $k = $started ? $ixhash->NEXTKEY : do { $started++; $ixhash->FIRSTKEY };
return unless defined $k;
return ($k, $ixhash->FETCH($k));
}
}
# XXX could be optimized down to only one substr to trim/pad
sub _bigint_to_int64 {
my $bigint = shift;
my $neg = $bigint < 0;
if ( $neg ) {
if ( $bigint < $min_int64 ) {
return "\x80\x00\x00\x00\x00\x00\x00\x00";
}
$bigint = abs($bigint) - ($max_int64 + 1);
}
elsif ( $bigint > $max_int64 ) {
return "\x7f\xff\xff\xff\xff\xff\xff\xff";
}
my $as_hex = $bigint->as_hex; # big-endian hex
$as_hex =~ s{-?0x}{};
my $len = length($as_hex);
substr( $as_hex, 0, 0, "0" x ( 16 - $len ) ) if $len < 16; # pad to quad length
my $pack = pack( "H*", $as_hex );
$pack |= "\x80\x00\x00\x00\x00\x00\x00\x00" if $neg;
return scalar reverse $pack;
}
sub _int64_to_bigint {
my $bytes = reverse(shift);
return Math::BigInt->new() if $bytes eq "\x00\x00\x00\x00\x00\x00\x00\x00";
if ( unpack("c", $bytes) < 0 ) {
if ( $bytes eq "\x80\x00\x00\x00\x00\x00\x00\x00" ) {
return -1 * Math::BigInt->new( "0x" . unpack("H*",$bytes) );
}
else {
return -1 * Math::BigInt->new( "0x" . unpack( "H*", ~$bytes ) ) - 1;
}
}
else {
return Math::BigInt->new( "0x" . unpack( "H*", $bytes ) );
}
}
sub _pack_int64 {
my $value = shift;
my $type = ref($value);
# if no type, then on 64-big perl we can pack with 'q'; otherwise
# we need to convert scalars to Math::BigInt and pack them that way.
if ( ! $type ) {
return pack(BSON_INT64,$value ) if HAS_INT64;
$value = Math::BigInt->new($value);
$type = 'Math::BigInt';
}
if ( $type eq 'Math::BigInt' ) {
return _bigint_to_int64($value);
}
elsif ( $type eq 'Math::Int64' ) {
return Math::Int64::int64_to_native($value);
}
else {
croak "Don't know how to encode $type '$value' as an Int64.";
}
}
sub _reftype_check {
my $doc = shift;
my $type = ref($doc);
my $reftype = reftype($doc);
die "Can't encode non-container of type '$type'" unless $reftype eq 'HASH';
return;
}
sub _encode_bson {
my ($doc, $opt) = @_;
my $refaddr = refaddr($doc);
die "circular reference detected" if $opt->{_circular}{$refaddr}++;
my $doc_type = ref($doc);
return $doc->bson
if $doc_type eq 'BSON::Raw' || $doc_type eq 'MongoDB::BSON::_EncodedDoc';
return $$doc if $doc_type eq 'MongoDB::BSON::Raw';
my $iter =
$doc_type eq 'HASH' ? undef
: $doc_type eq 'BSON::Doc' ? $doc->_iterator
: $doc_type eq 'Tie::IxHash' ? _ixhash_iterator($doc)
: $doc_type eq 'BSON::DBRef' ? _ixhash_iterator( $doc->_ordered )
: $doc_type eq 'MongoDB::DBRef' ? _ixhash_iterator( $doc->_ordered )
: do { _reftype_check($doc); undef };
my $op_char = defined($opt->{op_char}) ? $opt->{op_char} : '';
my $invalid =
length( $opt->{invalid_chars} ) ? qr/[\Q$opt->{invalid_chars}\E]/ : undef;
# Set up first key bookkeeping
my $first_key_pending = !! defined($opt->{first_key});
my $first_key;
my $bson = '';
my ($key, $value);
while ( $first_key_pending or ( $key, $value ) = $iter ? $iter->() : (each %$doc) ) {
next if defined $first_key && $key eq $first_key;
if ( $first_key_pending ) {
$first_key = $key = delete $opt->{first_key};
$value = delete $opt->{first_value};
undef $first_key_pending;
}
last unless defined $key;
croak "Key '" . _printable($key) . "' contains null character"
unless -1 == index($key, "\0");
substr( $key, 0, 1 ) = '$'
if length($op_char) && substr( $key, 0, 1 ) eq $op_char;
if ( $invalid && $key =~ $invalid ) {
croak(
sprintf(
"key '%s' has invalid character(s) '%s'",
$key, $opt->{invalid_chars}
)
);
}
my $utf8_key = $key;
utf8::encode($utf8_key);
my $type = ref $value;
# Null
if ( !defined $value ) {
$bson .= pack( BSON_TYPE_NAME, 0x0A, $utf8_key );
}
# REFERENCES/OBJECTS
elsif ( length $type ) {
# Array
if ( $type eq 'ARRAY' ) {
my $i = 0;
tie( my %h, 'Tie::IxHash' );
%h = map { $i++ => $_ } @$value;
$bson .= pack( BSON_TYPE_NAME, 0x04, $utf8_key ) . _encode_bson( \%h, $opt );
}
# Document
elsif ($type eq 'HASH'
|| $type eq 'BSON::Doc'
|| $type eq 'BSON::Raw'
|| $type eq 'MongoDB::BSON::_EncodedDoc'
|| $type eq 'Tie::IxHash'
|| $type eq 'MongoDB::BSON::Raw'
|| $type eq 'BSON::DBRef'
|| $type eq 'MongoDB::DBRef')
{
$bson .= pack( BSON_TYPE_NAME, 0x03, $utf8_key ) . _encode_bson($value, $opt);
}
# Regex
elsif ( $type eq 'Regexp' ) {
my ( $re, $flags ) = _split_re($value);
$bson .= pack( BSON_TYPE_NAME.BSON_REGEX, 0x0B, $utf8_key, $re, join( "", sort grep /^(i|m|x|l|s|u)$/, split( //, $flags ) ));
}
elsif ( $type eq 'BSON::Regex' || $type eq 'MongoDB::BSON::Regexp' ) {
my ( $re, $flags ) = @{$value}{qw/pattern flags/};
$bson .= pack( BSON_TYPE_NAME.BSON_REGEX, 0x0B, $utf8_key, $re, $flags) ;
}
# ObjectId
elsif ( $type eq 'BSON::OID' || $type eq 'BSON::ObjectId' ) {
$bson .= pack( BSON_TYPE_NAME.BSON_OBJECTID, 0x07, $utf8_key, $value->oid );
}
elsif ( $type eq 'MongoDB::OID' ) {
$bson .= pack( BSON_TYPE_NAME."H*", 0x07, $utf8_key, $value->value );
}
# Datetime
elsif ( $type eq 'BSON::Time' ) {
$bson .= pack( BSON_TYPE_NAME, 0x09, $utf8_key ) . _pack_int64( $value->value );
}
elsif ( $type eq 'Time::Moment' ) {
$bson .= pack( BSON_TYPE_NAME, 0x09, $utf8_key ) . _pack_int64( int( $value->epoch * 1000 + $value->millisecond ) );
}
elsif ( $type eq 'DateTime' ) {
if ( $value->time_zone->name eq 'floating' ) {
warn("saving floating timezone as UTC");
}
$bson .= pack( BSON_TYPE_NAME, 0x09, $utf8_key ) . _pack_int64( int( $value->hires_epoch * 1000 ) );
}
elsif ( $type eq 'DateTime::Tiny' ) {
require Time::Local;
my $epoch = Time::Local::timegm(
$value->second, $value->minute, $value->hour,
$value->day, $value->month - 1, $value->year,
);
$bson .= pack( BSON_TYPE_NAME, 0x09, $utf8_key ) . _pack_int64( $epoch * 1000 );
}
elsif ( $type eq 'Mango::BSON::Time' ) {
$bson .= pack( BSON_TYPE_NAME, 0x09, $utf8_key ) . _pack_int64( $value->{time} );
}
# Timestamp
elsif ( $type eq 'BSON::Timestamp' ) {
$bson .= pack( BSON_TYPE_NAME.BSON_TIMESTAMP, 0x11, $utf8_key, $value->increment, $value->seconds );
}
elsif ( $type eq 'MongoDB::Timestamp' ){
$bson .= pack( BSON_TYPE_NAME.BSON_TIMESTAMP, 0x11, $utf8_key, $value->inc, $value->sec );
}
# MinKey
elsif ( $type eq 'BSON::MinKey' || $type eq 'MongoDB::MinKey' ) {
$bson .= pack( BSON_TYPE_NAME, 0xFF, $utf8_key );
}
# MaxKey
elsif ( $type eq 'BSON::MaxKey' || $type eq 'MongoDB::MaxKey' ) {
$bson .= pack( BSON_TYPE_NAME, 0x7F, $utf8_key );
}
# Binary (XXX need to add string ref support)
elsif ($type eq 'SCALAR'
|| $type eq 'BSON::Bytes'
|| $type eq 'BSON::Binary'
|| $type eq 'MongoDB::BSON::Binary' )
{
my $data =
$type eq 'SCALAR' ? $$value
: $type eq 'BSON::Bytes' ? $value->data
: $type eq 'MongoDB::BSON::Binary' ? $value->data
: pack( "C*", @{ $value->data } );
my $subtype = $type eq 'SCALAR' ? 0 : $value->subtype;
my $len = length($data);
if ( $subtype == 2 ) {
$bson .=
pack( BSON_TYPE_NAME . BSON_INT32 . BSON_BINARY_TYPE . BSON_INT32 . BSON_REMAINING,
0x05, $utf8_key, $len + 4, $subtype, $len, $data );
}
else {
$bson .= pack( BSON_TYPE_NAME . BSON_INT32 . BSON_BINARY_TYPE . BSON_REMAINING,
0x05, $utf8_key, $len, $subtype, $data );
}
}
# Code
elsif ( $type eq 'BSON::Code' || $type eq 'MongoDB::Code' ) {
my $code = $value->code;
utf8::encode($code);
$code = pack(BSON_STRING,$code);
if ( ref( $value->scope ) eq 'HASH' ) {
my $scope = _encode_bson( $value->scope, $opt );
$bson .=
pack( BSON_TYPE_NAME.BSON_CODE_W_SCOPE, 0x0F, $utf8_key, (4 + length($scope) + length($code)) ) . $code . $scope;
}
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' ) {
$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: numbers preferred
elsif ( $opt->{prefer_numeric} ) {
# Int 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 );
}
}
# Double
elsif ( $value =~ $doub_re ) {
$bson .= pack( BSON_TYPE_NAME.BSON_DOUBLE, 0x01, $utf8_key, $value );
}
# String
else {
utf8::encode($value);
$bson .= pack( BSON_TYPE_NAME.BSON_STRING, 0x02, $utf8_key, $value );
}
}
### SCALAR: strings preferred
else {
my $flags = B::svref_2object(\$value)->FLAGS;
if ( $flags & B::SVf_POK() ) {
utf8::encode($value);
$bson .= pack( BSON_TYPE_NAME.BSON_STRING, 0x02, $utf8_key, $value );
}
elsif ( $flags & B::SVf_NOK() ) {
$bson .= pack( BSON_TYPE_NAME.BSON_DOUBLE, 0x01, $utf8_key, $value );
}
elsif ( $flags & B::SVf_IOK() ) {
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 ( $] lt '5.010' && $flags & B::SVp_IOK() ) {
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 );
}
}
else {
# Last resort, string
utf8::encode($value);
$bson .= pack( BSON_TYPE_NAME.BSON_STRING, 0x02, $utf8_key, $value );
}
}
}
delete $opt->{_circular}{$refaddr};
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 0x%x for key '%s'. Are you using the latest driver version?";
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) = @_;
if ( !defined $bson ) {
croak("Decode argument must not be undef");
}
my $blen= length($bson);
my $len = unpack( BSON_INT32, $bson );
if ( length($bson) != $len ) {
croak("Incorrect length of the bson string (got $blen, wanted $len)");
}
if ( chop($bson) ne "\x00" ) {
croak("BSON document not null terminated");
}
$bson = substr $bson, 4;
my @array = ();
my %hash = ();
tie( %hash, 'Tie::IxHash' ) if $opt->{ordered};
my ($type, $key, $value);
while ($bson) {
( $type, $key, $bson ) = unpack( BSON_TYPE_NAME.BSON_REMAINING, $bson );
utf8::decode($key);
# Check type and truncation
my $min_size = $FIELD_SIZES{$type};
if ( !defined $min_size ) {
croak( sprintf( $ERR_UNSUPPORTED, $type, $key ) );
}
if ( length($bson) < $min_size ) {
croak( sprintf( $ERR_TRUNCATED, $key, $type ) );
}
# Double
if ( $type == 0x01 ) {
( $value, $bson ) = unpack( BSON_DOUBLE.BSON_REMAINING, $bson );
$value = BSON::Double->new( value => $value ) if $opt->{wrap_numbers};
}
# String and Symbol (deprecated); Symbol will be convert to String
elsif ( $type == 0x02 || $type == 0x0E ) {
( $len, $bson ) = unpack( BSON_INT32 . BSON_REMAINING, $bson );
if ( length($bson) < $len || substr( $bson, $len - 1, 1 ) ne "\x00" ) {
croak( sprintf( $ERR_MISSING_NULL, $key, $type ) );
}
( $value, $bson ) = unpack( "a$len" . BSON_REMAINING, $bson );
chop($value); # remove trailing \x00
if ( !utf8::decode($value) ) {
croak( sprintf( $ERR_BAD_UTF8, $key, $type ) );
}
$value = BSON::String->new( value => $value ) if $opt->{wrap_strings};
}
# Document and Array
elsif ( $type == 0x03 || $type == 0x04 ) {
my $len = unpack( BSON_INT32, $bson );
$value = _decode_bson( substr( $bson, 0, $len ), { %$opt, _decode_array => $type == 0x04} );
if ( $opt->{wrap_dbrefs} && $type == 0x03 && exists $value->{'$id'} && exists $value->{'$ref'} ) {
$value = BSON::DBRef->new( %$value );
}
$bson = substr( $bson, $len, length($bson) - $len );
}
# Binary
elsif ( $type == 0x05 ) {
my ( $len, $btype ) = unpack( BSON_INT32 . BSON_BINARY_TYPE, $bson );
substr( $bson, 0, 5, '' );
if ( $len < 0 ) {
croak( sprintf( $ERR_NEG_LENGTH, $key, $type ) );
}
if ( $len > length($bson) ) {
croak( sprintf( $ERR_TRUNCATED, $key, $type ) );
}
my $binary = substr( $bson, 0, $len, '' );
if ( $btype == 2 ) {
if ( $len < 4 ) {
croak( sprintf( $ERR_BAD_OLDBINARY, $key, $type ) );
}
my $sublen = unpack( BSON_INT32, $binary );
if ( $sublen != length($binary) - 4 ) {
croak( sprintf( $ERR_BAD_OLDBINARY, $key, $type ) );
}
substr( $binary, 0, 4, '' );
}
$value = BSON::Bytes->new( subtype => $btype, data => $binary );
}
# Undef (deprecated)
elsif ( $type == 0x06 ) {
$value = undef;
}
# ObjectId
elsif ( $type == 0x07 ) {
( my $oid, $bson ) = unpack( BSON_OBJECTID.BSON_REMAINING, $bson );
$value = BSON::OID->new(oid => $oid);
}
# Boolean
elsif ( $type == 0x08 ) {
( my $bool, $bson ) = unpack( BSON_BOOLEAN.BSON_REMAINING, $bson );
croak("BSON boolean must be 0 or 1. Key '$key' is $bool")
unless $bool == 0 || $bool == 1;
$value = boolean( $bool );
}
# Datetime
elsif ( $type == 0x09 ) {
if ( HAS_INT64 ) {
($value, $bson) = unpack(BSON_INT64.BSON_REMAINING,$bson);
}
else {
($value, $bson) = unpack(BSON_8BYTES.BSON_REMAINING,$bson);
$value = _int64_to_bigint($value);
}
$value = BSON::Time->new( value => $value );
my $dt_type = $opt->{dt_type};
if ( defined $dt_type && $dt_type ne 'BSON::Time' ) {
$value =
$dt_type eq 'Time::Moment' ? $value->as_time_moment
: $dt_type eq 'DateTime' ? $value->as_datetime
: $dt_type eq 'DateTime::Tiny' ? $value->as_datetime_tiny
: $dt_type eq 'Mango::BSON::Time' ? $value->as_mango_time
: croak("Unsupported dt_type '$dt_type'");
}
}
# Null
elsif ( $type == 0x0A ) {
$value = undef;
}
# Regex
elsif ( $type == 0x0B ) {
( my $re, my $op, $bson ) = unpack( BSON_CSTRING.BSON_CSTRING.BSON_REMAINING, $bson );
$value = BSON::Regex->new( pattern => $re, flags => $op );
}
# DBPointer (deprecated)
elsif ( $type == 0x0C ) {
( $len, $bson ) = unpack( BSON_INT32 . BSON_REMAINING, $bson );
if ( length($bson) < $len || substr( $bson, $len - 1, 1 ) ne "\x00" ) {
croak( sprintf( $ERR_MISSING_NULL, $key, $type ) );
}
( my ($ref), $bson ) = unpack( "a$len" . BSON_REMAINING, $bson );
chop($ref); # remove trailing \x00
if ( !utf8::decode($ref) ) {
croak( sprintf( $ERR_BAD_UTF8, $key, $type ) );
}
( my ($oid), $bson ) = unpack( BSON_OBJECTID . BSON_REMAINING, $bson );
$value = BSON::DBRef->new( '$ref' => $ref, '$id' => BSON::OID->new( oid => $oid ) );
}
# Code
elsif ( $type == 0x0D ) {
( $len, $bson ) = unpack( BSON_INT32 . BSON_REMAINING, $bson );
if ( length($bson) < $len || substr( $bson, $len - 1, 1 ) ne "\x00" ) {
croak( sprintf( $ERR_MISSING_NULL, $key, $type ) );
}
( $value, $bson ) = unpack( "a$len" . BSON_REMAINING, $bson );
chop($value); # remove trailing \x00
if ( !utf8::decode($value) ) {
croak( sprintf( $ERR_BAD_UTF8, $key, $type ) );
}
$value = BSON::Code->new( code => $value );
}
# Code with scope
elsif ( $type == 0x0F ) {
my $len = unpack( BSON_INT32, $bson );
# validate length
if ( $len < 0 ) {
croak( sprintf( $ERR_NEG_LENGTH, $key, $type ) );
}
if ( $len > length($bson) ) {
croak( sprintf( $ERR_TRUNCATED, $key, $type ) );
}
if ( $len < 5 ) {
croak( sprintf( $ERR_LENGTH, $key, $type, 5, $len ) );
}
# extract code and scope and chop off leading length
my $codewscope = substr( $bson, 0, $len, '' );
substr( $codewscope, 0, 4, '' );
# extract code ( i.e. string )
my $strlen = unpack( BSON_INT32, $codewscope );
substr( $codewscope, 0, 4, '' );
if ( length($codewscope) < $strlen || substr( $codewscope, -1, 1 ) ne "\x00" ) {
croak( sprintf( $ERR_MISSING_NULL, $key, $type ) );
}
my $code = substr($codewscope, 0, $strlen, '' );
chop($code); # remove trailing \x00
if ( !utf8::decode($code) ) {
croak( sprintf( $ERR_BAD_UTF8, $key, $type ) );
}
if ( length($codewscope) < 5 ) {
croak( sprintf( $ERR_TRUNCATED, $key, $type ) );
}
# extract scope
my $scopelen = unpack( BSON_INT32, $codewscope );
if ( length($codewscope) < $scopelen || substr( $codewscope, $scopelen - 1, 1 ) ne "\x00" ) {
croak( sprintf( $ERR_MISSING_NULL, $key, $type ) );
}
my $scope = _decode_bson( $codewscope, { %$opt, _decode_array => 0} );
$value = BSON::Code->new( code => $code, scope => $scope );
}
# Int32
elsif ( $type == 0x10 ) {
( $value, $bson ) = unpack( BSON_INT32.BSON_REMAINING, $bson );
$value = BSON::Int32->new( value => $value ) if $opt->{wrap_numbers};
}
# Timestamp
elsif ( $type == 0x11 ) {
( my $sec, my $inc, $bson ) = unpack( BSON_INT32.BSON_INT32.BSON_REMAINING, $bson );
$value = BSON::Timestamp->new( $inc, $sec );
}
# Int64
elsif ( $type == 0x12 ) {
if ( HAS_INT64 ) {
($value, $bson) = unpack(BSON_INT64.BSON_REMAINING,$bson);
}
else {
($value, $bson) = unpack(BSON_8BYTES.BSON_REMAINING,$bson);
$value = _int64_to_bigint($value);
}
$value = BSON::Int64->new( value => $value ) if $opt->{wrap_numbers};
}
# Decimal128
elsif ( $type == 0x13 ) {
( my $bytes, $bson ) = unpack( BSON_16BYTES.BSON_REMAINING, $bson );
$value = BSON::Decimal128->new( bytes => $bytes );
}
# MinKey
elsif ( $type == 0xFF ) {
$value = BSON::MinKey->new;
}
# MaxKey
elsif ( $type == 0x7F ) {
$value = BSON::MaxKey->new;
}
# ???
else {
croak "Unsupported type $type";
}
if ( $opt->{_decode_array} ) {
push @array, $value;
}
else {
$hash{$key} = $value;
}
}
return $opt->{_decode_array} ? \@array : \%hash;
}
1;
=pod
=encoding UTF-8
=head1 NAME
BSON::PP - Pure Perl BSON implementation
=head1 VERSION
version v1.6.0
=head1 DESCRIPTION
This module contains the pure-Perl implementation for BSON encoding and
decoding. There is no public API. Use the L<BSON> module and it will
choose the best implementation for you.
=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: