view release on metacpan or  search on metacpan

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

    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) = @_;
    if ( !defined $bson ) {
        croak("Decode argument must not be undef");
    }
    $opt->{_depth} = 0 unless defined $opt->{_depth};
    $opt->{_depth}++;
    if ($opt->{_depth} > BSON_MAX_DEPTH) {
        croak "Exceeded max object depth of ". BSON_MAX_DEPTH;
    }
    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 ) );
                }