view release on metacpan or  search on metacpan

t/lib/TestBSON.pm  view on Meta::CPAN

#  Copyright 2015 - present MongoDB, Inc.
#
#  Licensed under the Apache License, Version 2.0 (the "License");
#  you may not use this file except in compliance with the License.
#  You may obtain a copy of the License at
#
#  http://www.apache.org/licenses/LICENSE-2.0
#
#  Unless required by applicable law or agreed to in writing, software
#  distributed under the License is distributed on an "AS IS" BASIS,
#  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
#  See the License for the specific language governing permissions and
#  limitations under the License.

use strict;
use warnings;

package TestBSON;

use Config;
use Exporter 'import';
use Test::More;

our @EXPORT = qw(
    BSON_DATETIME
    BSON_DOC
    BSON_DOUBLE
    BSON_INT32
    BSON_INT64
    BSON_NULL
    BSON_OID
    BSON_BOOL
    BSON_REGEXP
    BSON_STRING
    HAS_INT64
    MAX_LONG
    MIN_LONG
    _cstring
    _datetime
    _dbref
    _doc
    _double
    _ename
    _hexdump
    _int32
    _int64
    _pack_bigint
    _regexp
    _string
    is_bin
);

use constant {
    PERL58    => $] lt '5.010',
    HAS_INT64 => $Config{use64bitint}
};

use constant {
    P_INT32 => PERL58 ? "l" : "l<",
    P_INT64 => PERL58 ? "q" : "q<",
    MAX_LONG      => 2147483647,
    MIN_LONG      => -2147483647,
    BSON_DOUBLE   => "\x01",
    BSON_STRING   => "\x02",
    BSON_DOC      => "\x03",
    BSON_OID      => "\x07",
    BSON_BOOL     => "\x08",
    BSON_DATETIME => "\x09",
    BSON_NULL     => "\x0A",
    BSON_REGEXP   => "\x0B",
    BSON_INT32    => "\x10",
    BSON_INT64    => "\x12",
};

sub _hexdump {
    my ($str) = @_;
    $str =~ s{([^[:graph:]])}{sprintf("\\x{%02x}",ord($1))}ge;
    return $str;
}

sub is_bin {
    my ( $got, $exp, $label ) = @_;
    $label ||= '';
    $got = _hexdump($got);
    $exp = _hexdump($exp);
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    is( $got, $exp, $label );
}

sub _doc {
    my ($string) = shift;
    return pack( P_INT32, 5 + length($string) ) . $string . "\x00";
}

sub _cstring { return $_[0] . "\x00" }
BEGIN { *_ename = \&_cstring }

sub _double { return pack( PERL58 ? "d" : "d<", shift ) }

sub _int32 { return pack( P_INT32, shift ) }

sub _int64 {
    my $val = shift;
    if ( ref($val) && eval { $val->isa("Math::BigInt") } ) {
        return _pack_bigint($val);
    }
    elsif (HAS_INT64) {
         return pack( P_INT64, $val );
    }
    else {
        my $big = Math::BigInt->new( $val );
        return _pack_bigint($big);
    }
}