view release on metacpan or  search on metacpan

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

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 {
    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));
    }
}

# relying on Perl's each() is prone to action-at-a-distance effects we
# want to avoid, so we construct our own iterator for hashes
sub _hashlike_iterator {
    my $hashlike = shift;
    my @keys = keys %$hashlike;
    @keys = sort @keys
        if $ENV{BSON_TEST_SORT_HASH};
    return sub {
        my $k = shift @keys;
        return unless defined $k;
        return ($k, $hashlike->{$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);