use
5.008001;
our
@EXPORT
=
qw(
BSON_DATETIME
BSON_DOC
BSON_DOUBLE
BSON_INT32
BSON_INT64
BSON_NULL
BSON_OID
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
)
;
PERL58
=> $] lt
'5.010'
,
HAS_INT64
=>
$Config
{use64bitint}
};
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_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
(
"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
);
}
}
sub
_string {
my
(
$string
) =
shift
;
return
pack
( P_INT32, 1 +
length
(
$string
) ) .
$string
.
"\x00"
;
}
sub
_datetime {
my
$dt
=
shift
;
if
(HAS_INT64) {
return
pack
( P_INT64, 1000 *
$dt
->epoch +
$dt
->millisecond );
}
else
{
my
$big
= Math::BigInt->new(
$dt
->epoch );
$big
->bmul(1000);
$big
->badd(
$dt
->millisecond );
return
_pack_bigint(
$big
);
}
}
sub
_regexp {
my
(
$pattern
,
$flags
) =
@_
;
return
_cstring(
$pattern
) . _cstring(
$flags
);
}
sub
_dbref {
my
$dbref
=
shift
;
return
_doc(
BSON_STRING . _ename(
'$ref'
) . _string(
$dbref
->
ref
)
. BSON_STRING . _ename(
'$id'
) . _string(
$dbref
->id)
. BSON_STRING . _ename(
'$db'
) . _string(
$dbref
->db)
);
}
sub
_pack_bigint {
my
$bi
=
shift
;
my
$binary
=
$bi
->as_bin;
$binary
=~ s{^-?0b}{};
$binary
=
"0"
x(64-
length
(
$binary
)) .
$binary
if
length
(
$binary
) < 64;
if
(
$bi
->sign eq
'+'
) {
return
pack
(
"b*"
,
scalar
reverse
$binary
);
}
else
{
my
@lendian
=
split
//,
reverse
$binary
;
my
$saw_first_one
= 0;
for
(
@lendian
) {
if
( !
$saw_first_one
) {
$saw_first_one
=
$_
==
'1'
;
next
;
}
else
{
tr
[01][10];
}
}
return
pack
(
"b*"
,
join
(
""
,
@lendian
));
}
}
1;