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 {
    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 {