BSON

 view release on metacpan or  search on metacpan

lib/BSON.pm  view on Meta::CPAN

#pod =method create_oid
#pod
#pod     $oid = BSON->create_oid;
#pod
#pod This class method returns a new L<BSON::OID>.  This abstracts OID
#pod generation away from any specific Object ID class and makes it an interface
#pod on a BSON codec.  Alternative BSON codecs should define a similar class
#pod method that returns an Object ID of whatever type is appropriate.
#pod
#pod =cut

sub create_oid { return BSON::OID->new }

#pod =method inflate_extjson (DEPRECATED)
#pod
#pod This legacy method does not follow the L<MongoDB Extended JSON|https://github.com/mongodb/specifications/blob/master/source/extended-json.rst>
#pod specification.
#pod
#pod Use L</extjson_to_perl> instead.
#pod
#pod =cut

sub inflate_extjson {
    my ( $self, $hash ) = @_;

    for my $k ( keys %$hash ) {
        my $v = $hash->{$k};
        if ( substr( $k, 0, 1 ) eq '$' ) {
            croak "Dollar-prefixed key '$k' is not legal in top-level hash";
        }
        my $type = ref($v);
        $hash->{$k} =
            $type eq 'HASH'    ? $self->_inflate_hash($v)
          : $type eq 'ARRAY'   ? $self->_inflate_array($v)
          : $type =~ $bools_re ? ( $v ? true : false )
          :                      $v;
    }

    return $hash;
}

#pod =method perl_to_extjson
#pod
#pod     use JSON::MaybeXS;
#pod     my $ext = BSON->perl_to_extjson($data, \%options);
#pod     my $json = encode_json($ext);
#pod
#pod Takes a perl data structure (i.e. hashref) and turns it into an
#pod L<MongoDB Extended JSON|https://github.com/mongodb/specifications/blob/master/source/extended-json.rst>
#pod structure. Note that the structure will still have to be serialized.
#pod
#pod Possible options are:
#pod
#pod =for :list
#pod * C<relaxed> A boolean indicating if "relaxed extended JSON" should
#pod be generated. If not set, the default value is taken from the
#pod C<BSON_EXTJSON_RELAXED> environment variable.
#pod
#pod =cut

my $use_win32_specials = ($^O eq 'MSWin32' && $] lt "5.022");

my $is_inf = $use_win32_specials ? qr/^1.\#INF/i : qr/^inf/i;
my $is_ninf = $use_win32_specials ? qr/^-1.\#INF/i : qr/^-inf/i;
my $is_nan = $use_win32_specials ? qr/^-?1.\#(?:IND|QNAN)/i : qr/^-?nan/i;

sub perl_to_extjson {
    my ($class, $data, $options) = @_;

    local $ENV{BSON_EXTJSON} = 1;
    local $ENV{BSON_EXTJSON_RELAXED} = $ENV{BSON_EXTJSON_RELAXED};
    $ENV{BSON_EXTJSON_RELAXED} = $options->{relaxed};

    if (not defined $data) {
        return undef; ## no critic
    }

    if (blessed($data) and $data->can('TO_JSON')) {
        my $json_data = $data->TO_JSON;
        return $json_data;
    }

    if (not ref $data) {

        if (looks_like_number($data)) {
            if ($ENV{BSON_EXTJSON_RELAXED}) {
                return $data;
            }

            if ($data =~ m{\A-?[0-9_]+\z}) {
                if ($data <= $max_int32) {
                    return { '$numberInt' => "$data" };
                }
                else {
                    return { '$numberLong' => "$data" };
                }
            }
            else {
                return { '$numberDouble' => 'Infinity' }
                    if $data =~ $is_inf;
                return { '$numberDouble' => '-Infinity' }
                    if $data =~ $is_ninf;
                return { '$numberDouble' => 'NaN' }
                    if $data =~ $is_nan;
                my $value = "$data";
                $value = $value / 1.0;
                return { '$numberDouble' => "$value" };
            }
        }

        return $data;
    }

    if (boolean::isBoolean($data)) {
        return $data;
    }

    if (ref $data eq 'HASH') {
        for my $key (keys %$data) {
            my $value = $data->{$key};
            $data->{$key} = $class->perl_to_extjson($value, $options);

lib/BSON.pm  view on Meta::CPAN

            );
        }

        if ( exists $data->{'$regex'} and not ref $data->{'$regex'}) {
            return BSON::Regex->new(
                pattern => $data->{'$regex'},
                ( exists $data->{'$options'} ? ( flags => $data->{'$options'} ) : () ),
            );
        }

        if ( exists $data->{'$regularExpression'} ) {
            my $value = $data->{'$regularExpression'};
            return BSON::Regex->new(
                pattern => $value->{pattern},
                ( exists $value->{options} ? ( flags => $value->{options} ) : () ),
            );
        }

        if ( exists $data->{'$code'} ) {
            return BSON::Code->new(
                code => $data->{'$code'},
                ( exists $data->{'$scope'}
                    ? ( scope => $class->_extjson_to_perl($data->{'$scope'}) )
                    : ()
                ),
            );
        }

        if ( exists $data->{'$undefined'} ) {
            return undef; ## no critic
        }

        if ( exists $data->{'$dbPointer'} ) {
            my $data = $data->{'$dbPointer'};
            my $id = $data->{'$id'};
            $id = $class->_extjson_to_perl($id) if ref($id) eq 'HASH';
            return BSON::DBPointer->new(
                '$ref' => $data->{'$ref'},
                '$id' => $id,
            );
        }

        if ( exists $data->{'$ref'} ) {
            my $id = delete $data->{'$id'};
            $id = $class->_extjson_to_perl($id) if ref($id) eq 'HASH';
            return BSON::DBRef->new(
                '$ref' => delete $data->{'$ref'},
                '$id' => $id,
                '$db' => delete $data->{'$db'},
                %$data, # extra
            );
        }

        if ( exists $data->{'$numberDecimal'} ) {
            return BSON::Decimal128->new( value => $data->{'$numberDecimal'} );
        }

        # Following extended JSON is non-standard

        if ( exists $data->{'$numberDouble'} ) {
            if ( $data->{'$numberDouble'} eq '-0' && $] lt '5.014' && ! HAS_LD ) {
                $data->{'$numberDouble'} = '-0.0';
            }
            return BSON::Double->new( value => $data->{'$numberDouble'} );
        }

        if ( exists $data->{'$symbol'} ) {
            return BSON::Symbol->new(value => $data->{'$symbol'});
        }

        for my $key (keys %$data) {
            my $value = $data->{$key};
            $data->{$key} = $class->_extjson_to_perl($value);
        }
        return $data;
    }

    if (ref $data eq 'ARRAY') {
        for my $index (0 .. $#$data) {
            my $value = $data->[$index];
            $data->[$index] = ref($value)
                ? $class->_extjson_to_perl($value)
                : $value;
        }
        return $data;
    }

    return $data;
}

#--------------------------------------------------------------------------#
# legacy functional interface
#--------------------------------------------------------------------------#

#pod =func encode
#pod
#pod     my $bson = encode({ bar => 'foo' }, \%options);
#pod
#pod This is the legacy, functional interface and is only exported on demand.
#pod It takes a hashref and returns a BSON string.
#pod It uses an internal codec singleton with default attributes.
#pod
#pod =func decode
#pod
#pod     my $hash = decode( $bson, \%options );
#pod
#pod This is the legacy, functional interface and is only exported on demand.
#pod It takes a BSON string and returns a hashref.
#pod It uses an internal codec singleton with default attributes.
#pod
#pod =cut

{
    my $CODEC;

    sub encode {
        if ( defined $_[0] && ( $_[0] eq 'BSON' || ( blessed($_[0]) && $_[0]->isa('BSON') ) ) ) {
            Carp::croak("Error: 'encode' is a function, not a method");
        }
        my $doc = shift;
        $CODEC = BSON->new unless defined $CODEC;

lib/BSON.pm  view on Meta::CPAN

    if ( exists $hash->{'$binary'} ) {
        require MIME::Base64;
        return BSON::Bytes->new(
            data    => MIME::Base64::decode_base64($hash->{'$binary'}),
            subtype => hex( $hash->{'$type'} || 0 )
        );
    }

    if ( exists $hash->{'$date'} ) {
        my $v = $hash->{'$date'};
        $v = ref($v) eq 'HASH' ? BSON->_inflate_hash($v) : _iso8601_to_epochms($v);
        return BSON::Time->new( value => $v );
    }

    if ( exists $hash->{'$minKey'} ) {
        return BSON::MinKey->new;
    }

    if ( exists $hash->{'$maxKey'} ) {
        return BSON::MaxKey->new;
    }

    if ( exists $hash->{'$timestamp'} ) {
        return BSON::Timestamp->new(
            seconds   => $hash->{'$timestamp'}{t},
            increment => $hash->{'$timestamp'}{i},
        );
    }

    if ( exists $hash->{'$regex'} ) {
        return BSON::Regex->new(
            pattern => $hash->{'$regex'},
            ( exists $hash->{'$options'} ? ( flags => $hash->{'$options'} ) : () ),
        );
    }

    if ( exists $hash->{'$code'} ) {
        return BSON::Code->new(
            code => $hash->{'$code'},
            ( exists $hash->{'$scope'} ? ( scope => $hash->{'$scope'} ) : () ),
        );
    }

    if ( exists $hash->{'$undefined'} ) {
        return undef; ## no critic
    }

    if ( exists $hash->{'$ref'} ) {
        my $id = $hash->{'$id'};
        $id = BSON->_inflate_hash($id) if ref($id) eq 'HASH';
        return BSON::DBRef->new( '$ref' => $hash->{'$ref'}, '$id' => $id );
    }

    if ( exists $hash->{'$numberDecimal'} ) {
        return BSON::Decimal128->new( value => $hash->{'$numberDecimal'} );
    }

    # Following extended JSON is non-standard

    if ( exists $hash->{'$numberDouble'} ) {
        if ( $hash->{'$numberDouble'} eq '-0' && $] lt '5.014' && ! HAS_LD ) {
            $hash->{'$numberDouble'} = '-0.0';
        }
        return BSON::Double->new( value => $hash->{'$numberDouble'} );
    }

    if ( exists $hash->{'$symbol'} ) {
        return $hash->{'$symbol'};
    }

    return $hash;
}

sub _inflate_array {
    my ($class, $array) = @_;
    if (@$array) {
        for my $i ( 0 .. $#$array ) {
            my $v = $array->[$i];
            $array->[$i] =
                ref($v) eq 'HASH'  ? BSON->_inflate_hash($v)
              : ref($v) eq 'ARRAY' ? _inflate_array($v)
              :                       $v;
        }
    }
    return $array;
}

my $iso8601_re = qr{
    (\d{4}) - (\d{2}) - (\d{2}) T               # date
    (\d{2}) : (\d{2}) : ( \d+ (?:\. \d+ )? )    # time
    (?: Z | ([+-] \d{2} :? (?: \d{2} )? ) )?    # maybe TZ
}x;

sub _iso8601_to_epochms {
    my ($date) = shift;
    require Time::Local;

    my $zone_offset = 0;;
    if ( substr($date,-1,1) eq 'Z' ) {
        chop($date);
    }

    if ( $date =~ /\A$iso8601_re\z/ ) {
        my ($Y,$M,$D,$h,$m,$s,$z) = ($1,$2-1,$3,$4,$5,$6,$7);
        if (defined($z) && length($z))  {
            $z =~ tr[:][];
            $z .= "00" if length($z) < 5;
            my $zd = substr($z,0,1);
            my $zh = substr($z,1,2);
            my $zm = substr($z,3,2);
            $zone_offset = ($zd eq '-' ? -1 : 1 ) * (3600 * $zh + 60 * $zm);
        }
        my $frac = $s - int($s);
        my $epoch = Time::Local::timegm(int($s), $m, $h, $D, $M, $Y) - $zone_offset;
        $epoch = HAS_INT64 ? 1000 * $epoch : Math::BigInt->new($epoch) * 1000;
        $epoch += HAS_INT64 ? $frac * 1000 : Math::BigFloat->new($frac) * 1000;
        return $epoch;
    }
    else {
        Carp::croak("Couldn't parse '\$date' field: $date\n");
    }