use 5.008001;
use strict;
use warnings;
package BSON;
# ABSTRACT: Pure Perl implementation of MongoDB's BSON serialization
use base 'Exporter';
our @EXPORT_OK = qw/encode decode/;
our $VERSION = '0.12';
use Carp;
use Tie::IxHash;
use Math::Int64 qw/:native_if_available int64 int64_to_native native_to_int64/;
use BSON::Time;
use BSON::Timestamp;
use BSON::MinKey;
use BSON::MaxKey;
use BSON::Binary;
use BSON::ObjectId;
use BSON::Code;
use BSON::Bool;
use BSON::String;
# Maximum size of a BSON record
our $MAX_SIZE = 16 * 1024 * 1024;
# Max integer sizes
our $min_int_32 = -(1<<31);
our $max_int_32 = (1<<31) - 1;
our $min_int_64 = -(int64(1)<<63);
our $max_int_64 = (int64(1)<<63) - 1;
#<<<
my $int_re = qr/^(?:(?:[+-]?)(?:[0123456789]+))$/;
my $doub_re = qr/^(?:(?i)(?:[+-]?)(?:(?=[0123456789]|[.])(?:[0123456789]*)(?:(?:[.])(?:[0123456789]{0,}))?)(?:(?:[E])(?:(?:[+-]?)(?:[0123456789]+))|))$/;
#>>>
use constant {
BSON_TYPE_NAME => "CZ*",
BSON_DOUBLE => "d",
BSON_STRING => "V/Z*",
BSON_BOOLEAN => "C",
BSON_REGEX => "Z*a*",
BSON_JSCODE => "",
BSON_INT32 => "l",
BSON_INT64 => "LL",
BSON_TIMESTAMP => "LL",
BSON_CODE_W_SCOPE => "l",
BSON_REMAINING => 'a*',
BSON_SKIP_4_BYTES => 'x4',
BSON_OBJECTID => 'a12',
BSON_BINARY_TYPE => 'C',
BSON_CSTRING => 'Z*',
};
sub _split_re {
my $value = shift;
$value =~ s/^\(\?\^?//;
$value =~ s/\)$//;
my ( $opt, $re ) = split( /:/, $value, 2 );
$opt =~ s/\-\w+$//;
return ( $re, $opt );
}
sub encode {
my $doc = shift;
my $bson = '';
while ( my ( $key, $value ) = each %$doc ) {
# Null
if ( !defined $value ) {
$bson .= pack( BSON_TYPE_NAME, 0x0A, $key );
}
# Array
elsif ( ref $value eq 'ARRAY' ) {
my $i = 0;
tie( my %h, 'Tie::IxHash' );
%h = map { $i++ => $_ } @$value;
$bson .= pack( BSON_TYPE_NAME, 0x04, $key ) . encode( \%h );
}
# Document
elsif ( ref $value eq 'HASH' ) {
$bson .= pack( BSON_TYPE_NAME, 0x03, $key ) . encode($value);
}
# Regex
elsif ( ref $value eq 'Regexp' ) {
my ( $re, $opt ) = _split_re($value);
$bson .= pack( BSON_TYPE_NAME.BSON_REGEX, 0x0B, $key, $re, sort grep /^(i|m|x|l|s|u)$/, split( //, $opt ) ) . "\0";
}
# ObjectId
elsif ( ref $value eq 'BSON::ObjectId' ) {
$bson .= pack( BSON_TYPE_NAME.BSON_OBJECTID, 0x07, $key, $value->value );
}
# Datetime
elsif ( ref $value eq 'BSON::Time' ) {
$bson .= pack( BSON_TYPE_NAME, 0x09, $key ) . int64_to_native( $value->value );
}
# Timestamp
elsif ( ref $value eq 'BSON::Timestamp' ) {
$bson .= pack( BSON_TYPE_NAME.BSON_TIMESTAMP, 0x11, $key, $value->increment, $value->seconds );
}
# MinKey
elsif ( ref $value eq 'BSON::MinKey' ) {
$bson .= pack( BSON_TYPE_NAME, 0xFF, $key );
}
# MaxKey
elsif ( ref $value eq 'BSON::MaxKey' ) {
$bson .= pack( BSON_TYPE_NAME, 0x7F, $key );
}
# Binary
elsif ( ref $value eq 'BSON::Binary' ) {
$bson .= pack( BSON_TYPE_NAME, 0x05, $key ) . $value;
}
# Code
elsif ( ref $value eq 'BSON::Code' ) {
if ( ref $value->scope eq 'HASH' ) {
my $scope = encode( $value->scope );
my $code = pack( BSON_STRING, $value->code );
$bson .=
pack( BSON_TYPE_NAME.BSON_CODE_W_SCOPE, 0x0F, $key, (4 + length($scope) + length($code)) ) . $code . $scope;
}
else {
$bson .= pack( BSON_TYPE_NAME.BSON_STRING, 0x0D, $key, $value->code );
}
}
# Boolean
elsif ( ref $value eq 'BSON::Bool' ) {
$bson .= pack( BSON_TYPE_NAME.BSON_BOOLEAN, 0x08, $key, ( $value ? 1 : 0 ) );
}
# String (explicit)
elsif ( ref $value eq 'BSON::String' ) {
$bson .= pack( BSON_TYPE_NAME.BSON_STRING, 0x02, $key, $value );
}
# Int (32 and 64)
elsif ( ref $value eq 'Math::Int64' || $value =~ $int_re ) {
if ( $value > $max_int_64 || $value < $min_int_64 ) {
croak("MongoDB can only handle 8-byte integers");
}
$bson .= $value > $max_int_32 || $value < $min_int_32 ? pack( BSON_TYPE_NAME.BSON_REMAINING, 0x12, $key, int64_to_native( $value ))
: pack( BSON_TYPE_NAME.BSON_INT32, 0x10, $key, $value );
}
# Double
elsif ( $value =~ $doub_re ) {
$bson .= pack( BSON_TYPE_NAME.BSON_DOUBLE, 0x01, $key, $value );
}
# String
else {
$bson .= pack( BSON_TYPE_NAME.BSON_STRING, 0x02, $key, $value );
}
}
return pack( BSON_INT32, length($bson) + 5 ) . $bson . "\0";
}
sub decode {
my $bson = shift;
my $len = unpack( BSON_INT32, $bson );
if ( length($bson) != $len ) {
croak("Incorrect length of the bson string");
}
my %opt = @_;
$bson = substr( $bson, 4, -1 );
my %hash = ();
tie( %hash, 'Tie::IxHash' ) if $opt{ixhash};
while ($bson) {
my $value;
( my $type, my $key, $bson ) = unpack( BSON_TYPE_NAME.BSON_REMAINING, $bson );
# Double
if ( $type == 0x01 ) {
( $value, $bson ) = unpack( BSON_DOUBLE.BSON_REMAINING, $bson );
}
# String and Symbol
elsif ( $type == 0x02 || $type == 0x0E ) {
( $value, $bson ) = unpack( BSON_SKIP_4_BYTES.BSON_CSTRING.BSON_REMAINING, $bson );
}
# Document and Array
elsif ( $type == 0x03 || $type == 0x04 ) {
my $len = unpack( BSON_INT32, $bson );
$value = decode( substr( $bson, 0, $len ), %opt );
if ( $type == 0x04 ) {
my @a =
map { $value->{$_} } ( 0 .. scalar( keys %$value ) - 1 );
$value = \@a;
}
$bson = substr( $bson, $len, length($bson) - $len );
}
# Binary
elsif ( $type == 0x05 ) {
my $len = unpack( BSON_INT32, $bson ) + 5;
my @a = unpack( BSON_SKIP_4_BYTES.BSON_BINARY_TYPE.BSON_REMAINING, substr( $bson, 0, $len ) );
$value = BSON::Binary->new( $a[1], $a[0] );
$bson = substr( $bson, $len, length($bson) - $len );
}
# Undef
elsif ( $type == 0x06 ) {
$value = undef;
}
# ObjectId
elsif ( $type == 0x07 ) {
( my $oid, $bson ) = unpack( BSON_OBJECTID.BSON_REMAINING, $bson );
$value = BSON::ObjectId->new($oid);
}
# Boolean
elsif ( $type == 0x08 ) {
( my $bool, $bson ) = unpack( BSON_BOOLEAN.BSON_REMAINING, $bson );
$value = BSON::Bool->new($bool);
}
# Datetime
elsif ( $type == 0x09 ) {
my ($l1, $l2) = @_;
($l1, $l2, $bson) = unpack(BSON_INT64.BSON_REMAINING,$bson);
my $dt = native_to_int64(pack(BSON_INT64,$l1, $l2));
$value = BSON::Time->new( int( $dt / 1000 ) );
}
# Null
elsif ( $type == 0x0A ) {
$value = undef;
}
# Regex
elsif ( $type == 0x0B ) {
( my $re, my $op, $bson ) = unpack( BSON_CSTRING.BSON_CSTRING.BSON_REMAINING, $bson );
$value = eval "qr/$re/$op"; ## no critic
}
# Code
elsif ( $type == 0x0D ) {
( my $len, my $code, $bson ) = unpack( BSON_INT32.BSON_CSTRING.BSON_REMAINING, $bson );
$value = BSON::Code->new($code);
}
# Code with scope
elsif ( $type == 0x0F ) {
my $len = unpack( BSON_INT32, $bson );
my @a = unpack( BSON_SKIP_4_BYTES.BSON_SKIP_4_BYTES.BSON_CSTRING.BSON_REMAINING, substr( $bson, 0, $len ) );
$value = BSON::Code->new( $a[0], decode( $a[1], %opt ) );
$bson = substr( $bson, $len, length($bson) - $len );
}
# Int32
elsif ( $type == 0x10 ) {
( $value, $bson ) = unpack( BSON_INT32.BSON_REMAINING, $bson );
}
# Timestamp
elsif ( $type == 0x11 ) {
( my $sec, my $inc, $bson ) = unpack( BSON_INT64.BSON_REMAINING, $bson );
$value = BSON::Timestamp->new( $inc, $sec );
}
# Int64
elsif ( $type == 0x12 ) {
my ($l1, $l2) = @_;
($l1, $l2, $bson) = unpack(BSON_INT64.BSON_REMAINING,$bson);
$value = native_to_int64(pack(BSON_INT64,$l1, $l2));
}
# MinKey
elsif ( $type == 0xFF ) {
$value = BSON::MinKey->new;
}
# MaxKey
elsif ( $type == 0x7F ) {
$value = BSON::MaxKey->new;
}
# ???
else {
croak "Unsupported type $type";
}
$hash{$key} = $value;
}
return \%hash;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
BSON - Pure Perl implementation of MongoDB's BSON serialization
=head1 VERSION
version 0.12
=head1 SYNOPSIS
use BSON qw/encode decode/;
my $document = {
_id => BSON::ObjectId->new,
date => BSON::Time->new,
name => 'James Bond',
age => 45,
amount => 24587.45,
badass => BSON::Bool->true,
password => BSON::String->new('12345')
};
my $bson = encode( $document );
my $doc2 = decode( $bson, %options );
=head1 DESCRIPTION
This module implements BSON serialization and deserialization as described at
L<http://bsonspec.org>. BSON is the primary data representation for MongoDB.
=head1 EXPORT
The module does not export anything. You have to request C<encode> and/or
C<decode> manually.
use BSON qw/encode decode/;
=head1 SUBROUTINES
=head2 encode
Takes a hashref and returns a BSON string.
my $bson = encode({ bar => 'foo' });
=head2 decode
Takes a BSON string and returns a hashref.
my $hash = decode( $bson, ixhash => 1 );
The options after C<$bson> are optional and they can be any of the following:
=head3 options
=over
=item 1
ixhash => 1|0
If set to 1 C<decode> will return a L<Tie::IxHash> ordered hash. Otherwise,
a regular unordered hash will be returned. Turning this option on entails a
significant speed penalty as Tie::IxHash is slower than a regular Perl hash.
The default value for this option is 0.
=back
=head1 THREADS
This module is thread safe.
=head1 LIMITATION
MongoDB sets a limit for any BSON record to 16MB. This module does not enforce this
limit and you can use it to C<encode> and C<decode> structures as large as you
please.
=head1 CAVEATS
BSON uses zero terminated strings and Perl allows the \0 character to be anywhere
in a string. If you expect your strings to contain \0 characters, use L<BSON::Binary>
instead.
=head1 HISTORY AND ROADMAP
This module was originally written by minimalist. In 2014, he graciously
transferred ongoing maintenance to MongoDB, Inc.
Going forward, work will focus on restoration of a pure-Perl dependency chain,
harmonization with L<MongoDB driver|MongoDB> BSON classes and some API
enhancements so this can provide a pure-Perl alternative serializer for the
MongoDB driver.
=head1 SEE ALSO
L<BSON::String>, L<BSON::Time>, L<BSON::ObjectId>, L<BSON::Code>,
L<BSON::Binary>, L<BSON::Bool>, L<BSON::MinKey>, L<BSON::MaxKey>,
L<BSON::Timestamp>, L<Tie::IxHash>, L<MongoDB>
=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
=head1 SUPPORT
=head2 Bugs / Feature Requests
Please report any bugs or feature requests through the issue tracker
at L<https://jira.mongodb.org/browse/PERL>.
You will be notified automatically of any progress on your issue.
=head2 Source Code
This is open source software. The code repository is available for
public review and contribution under the terms of the license.
L<https://github.com/mongodb/mongo-perl-bson>
git clone https://github.com/mongodb/mongo-perl-bson.git
=head1 AUTHORS
=over 4
=item *
minimalist <minimalist@lavabit.com>
=item *
David Golden <david@mongodb.com>
=back
=head1 CONTRIBUTORS
=for stopwords Eric Daniels Pat Gunn Yury Zavarin Oleg Kostyuk
=over 4
=item *
Eric Daniels <eric.daniels@mongodb.com>
=item *
Pat Gunn <pgunn@mongodb.com>
=item *
Yury Zavarin <yury.zavarin@gmail.com>
=item *
Oleg Kostyuk <cub@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is Copyright (c) 2015 by minimalist and MongoDB, Inc..
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut