line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
71
|
|
|
71
|
|
32311
|
use 5.010001; |
|
71
|
|
|
|
|
225
|
|
2
|
71
|
|
|
71
|
|
324
|
use strict; |
|
71
|
|
|
|
|
120
|
|
|
71
|
|
|
|
|
1669
|
|
3
|
71
|
|
|
71
|
|
346
|
use warnings; |
|
71
|
|
|
|
|
128
|
|
|
71
|
|
|
|
|
2232
|
|
4
|
71
|
|
|
71
|
|
334
|
no warnings 'recursion'; |
|
71
|
|
|
|
|
134
|
|
|
71
|
|
|
|
|
3797
|
|
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
package BSON::PP; |
7
|
|
|
|
|
|
|
# ABSTRACT: Pure Perl BSON implementation |
8
|
|
|
|
|
|
|
|
9
|
71
|
|
|
71
|
|
426
|
use version; |
|
71
|
|
|
|
|
153
|
|
|
71
|
|
|
|
|
451
|
|
10
|
|
|
|
|
|
|
our $VERSION = 'v1.12.2'; |
11
|
|
|
|
|
|
|
|
12
|
71
|
|
|
71
|
|
6352
|
use B; |
|
71
|
|
|
|
|
212
|
|
|
71
|
|
|
|
|
3627
|
|
13
|
71
|
|
|
71
|
|
434
|
use Carp; |
|
71
|
|
|
|
|
133
|
|
|
71
|
|
|
|
|
3621
|
|
14
|
71
|
|
|
71
|
|
435
|
use Config; |
|
71
|
|
|
|
|
126
|
|
|
71
|
|
|
|
|
3048
|
|
15
|
71
|
|
|
71
|
|
437
|
use Scalar::Util qw/blessed looks_like_number refaddr reftype/; |
|
71
|
|
|
|
|
150
|
|
|
71
|
|
|
|
|
4006
|
|
16
|
71
|
|
|
71
|
|
373
|
use List::Util qw/first/; |
|
71
|
|
|
|
|
139
|
|
|
71
|
|
|
|
|
7074
|
|
17
|
71
|
|
|
71
|
|
738
|
use Tie::IxHash; |
|
71
|
|
|
|
|
355297
|
|
|
71
|
|
|
|
|
11825
|
|
18
|
|
|
|
|
|
|
|
19
|
71
|
|
|
71
|
|
826
|
use BSON::Types (); |
|
71
|
|
|
|
|
250
|
|
|
71
|
|
|
|
|
1801
|
|
20
|
71
|
|
|
71
|
|
424
|
use boolean; |
|
71
|
|
|
|
|
153
|
|
|
71
|
|
|
|
|
406
|
|
21
|
71
|
|
|
71
|
|
4626
|
use mro; |
|
71
|
|
|
|
|
154
|
|
|
71
|
|
|
|
|
513
|
|
22
|
|
|
|
|
|
|
|
23
|
71
|
|
|
71
|
|
2246
|
use re 'regexp_pattern'; |
|
71
|
|
|
|
|
132
|
|
|
71
|
|
|
|
|
12254
|
|
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
use constant { |
26
|
|
|
|
|
|
|
HAS_INT64 => $Config{use64bitint}, |
27
|
71
|
|
|
71
|
|
445
|
}; |
|
71
|
|
|
|
|
145
|
|
|
71
|
|
|
|
|
5602
|
|
28
|
|
|
|
|
|
|
|
29
|
71
|
|
|
71
|
|
388
|
use if !HAS_INT64, "Math::BigInt"; |
|
71
|
|
|
|
|
122
|
|
|
71
|
|
|
|
|
453
|
|
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
# Max integer sizes |
32
|
|
|
|
|
|
|
my $max_int32 = 2147483647; |
33
|
|
|
|
|
|
|
my $min_int32 = -2147483648; |
34
|
|
|
|
|
|
|
my $max_int64 = |
35
|
|
|
|
|
|
|
HAS_INT64 ? 9223372036854775807 : Math::BigInt->new("9223372036854775807"); |
36
|
|
|
|
|
|
|
my $min_int64 = |
37
|
|
|
|
|
|
|
HAS_INT64 ? -9223372036854775808 : Math::BigInt->new("-9223372036854775808"); |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
#<<< |
40
|
|
|
|
|
|
|
my $int_re = qr/^(?:(?:[+-]?)(?:[0123456789]+))$/; |
41
|
|
|
|
|
|
|
my $doub_re = qr/^(?:(?i)(?:NaN|-?Inf(?:inity)?)|(?:[+-]?)(?:(?=[0123456789]|[.])(?:[0123456789]*)(?:(?:[.])(?:[0123456789]{0,}))?)(?:(?:[E])(?:(?:[+-]?)(?:[0123456789]+))|))$/; |
42
|
|
|
|
|
|
|
#>>> |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
my $bools_re = qr/::(?:Boolean|_Bool|Bool)\z/; |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
use constant { |
47
|
|
|
|
|
|
|
|
48
|
71
|
|
|
|
|
413647
|
BSON_TYPE_NAME => "CZ*", |
49
|
|
|
|
|
|
|
BSON_DOUBLE => "d<", |
50
|
|
|
|
|
|
|
BSON_STRING => "V/Z*", |
51
|
|
|
|
|
|
|
BSON_BOOLEAN => "C", |
52
|
|
|
|
|
|
|
BSON_REGEX => "Z*Z*", |
53
|
|
|
|
|
|
|
BSON_JSCODE => "", |
54
|
|
|
|
|
|
|
BSON_INT32 => "l<", |
55
|
|
|
|
|
|
|
BSON_UINT32 => "L<", |
56
|
|
|
|
|
|
|
BSON_INT64 => "q<", |
57
|
|
|
|
|
|
|
BSON_8BYTES => "a8", |
58
|
|
|
|
|
|
|
BSON_16BYTES => "a16", |
59
|
|
|
|
|
|
|
BSON_TIMESTAMP => "L
|
60
|
|
|
|
|
|
|
BSON_CODE_W_SCOPE => "l<", |
61
|
|
|
|
|
|
|
BSON_REMAINING => 'a*', |
62
|
|
|
|
|
|
|
BSON_SKIP_4_BYTES => 'x4', |
63
|
|
|
|
|
|
|
BSON_OBJECTID => 'a12', |
64
|
|
|
|
|
|
|
BSON_BINARY_TYPE => 'C', |
65
|
|
|
|
|
|
|
BSON_CSTRING => 'Z*', |
66
|
|
|
|
|
|
|
BSON_MAX_DEPTH => 100, |
67
|
71
|
|
|
71
|
|
19336
|
}; |
|
71
|
|
|
|
|
140
|
|
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
sub _printable { |
70
|
1
|
|
|
1
|
|
2
|
my $value = shift; |
71
|
1
|
|
|
|
|
6
|
$value =~ s/([^[:print:]])/sprintf("\\x%02x",ord($1))/ge; |
|
1
|
|
|
|
|
6
|
|
72
|
1
|
|
|
|
|
81
|
return $value; |
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
sub _split_re { |
76
|
5
|
|
|
5
|
|
4435
|
my $value = shift; |
77
|
5
|
50
|
|
|
|
39
|
if ( $] ge 5.010 ) { |
78
|
5
|
|
|
|
|
23
|
return re::regexp_pattern($value); |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
else { |
81
|
0
|
|
|
|
|
0
|
$value =~ s/^\(\?\^?//; |
82
|
0
|
|
|
|
|
0
|
$value =~ s/\)$//; |
83
|
0
|
|
|
|
|
0
|
my ( $opt, $re ) = split( /:/, $value, 2 ); |
84
|
0
|
|
|
|
|
0
|
$opt =~ s/\-\w+$//; |
85
|
0
|
|
|
|
|
0
|
return ( $re, $opt ); |
86
|
|
|
|
|
|
|
} |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
sub _ixhash_iterator { |
90
|
22
|
|
|
22
|
|
833
|
my $ixhash = shift; |
91
|
22
|
|
|
|
|
43
|
my $started = 0; |
92
|
|
|
|
|
|
|
return sub { |
93
|
70
|
100
|
|
70
|
|
167
|
my $k = $started ? $ixhash->NEXTKEY : do { $started++; $ixhash->FIRSTKEY }; |
|
22
|
|
|
|
|
31
|
|
|
22
|
|
|
|
|
62
|
|
94
|
70
|
100
|
|
|
|
488
|
return unless defined $k; |
95
|
49
|
|
|
|
|
102
|
return ($k, $ixhash->FETCH($k)); |
96
|
|
|
|
|
|
|
} |
97
|
22
|
|
|
|
|
110
|
} |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
# relying on Perl's each() is prone to action-at-a-distance effects we |
100
|
|
|
|
|
|
|
# want to avoid, so we construct our own iterator for hashes |
101
|
|
|
|
|
|
|
sub _hashlike_iterator { |
102
|
30576
|
|
|
30576
|
|
37332
|
my $hashlike = shift; |
103
|
30576
|
|
|
|
|
105079
|
my @keys = keys %$hashlike; |
104
|
|
|
|
|
|
|
@keys = sort @keys |
105
|
30576
|
50
|
|
|
|
228049
|
if $ENV{BSON_TEST_SORT_HASH}; |
106
|
|
|
|
|
|
|
return sub { |
107
|
179140
|
|
|
179140
|
|
335332
|
my $k = shift @keys; |
108
|
179140
|
100
|
|
|
|
314152
|
return unless defined $k; |
109
|
148773
|
|
|
|
|
476260
|
return ($k, $hashlike->{$k}); |
110
|
|
|
|
|
|
|
} |
111
|
30576
|
|
|
|
|
138099
|
} |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
# XXX could be optimized down to only one substr to trim/pad |
114
|
|
|
|
|
|
|
sub _bigint_to_int64 { |
115
|
10
|
|
|
10
|
|
15
|
my $bigint = shift; |
116
|
10
|
|
|
|
|
24
|
my $neg = $bigint < 0; |
117
|
10
|
100
|
|
|
|
1532
|
if ( $neg ) { |
|
|
50
|
|
|
|
|
|
118
|
1
|
50
|
|
|
|
4
|
if ( $bigint < $min_int64 ) { |
119
|
0
|
|
|
|
|
0
|
return "\x80\x00\x00\x00\x00\x00\x00\x00"; |
120
|
|
|
|
|
|
|
} |
121
|
1
|
|
|
|
|
110
|
$bigint = abs($bigint) - ($max_int64 + 1); |
122
|
|
|
|
|
|
|
} |
123
|
|
|
|
|
|
|
elsif ( $bigint > $max_int64 ) { |
124
|
0
|
|
|
|
|
0
|
return "\x7f\xff\xff\xff\xff\xff\xff\xff"; |
125
|
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
|
|
127
|
10
|
|
|
|
|
1192
|
my $as_hex = $bigint->as_hex; # big-endian hex |
128
|
10
|
|
|
|
|
945
|
$as_hex =~ s{-?0x}{}; |
129
|
10
|
|
|
|
|
19
|
my $len = length($as_hex); |
130
|
10
|
100
|
|
|
|
40
|
substr( $as_hex, 0, 0, "0" x ( 16 - $len ) ) if $len < 16; # pad to quad length |
131
|
10
|
|
|
|
|
33
|
my $pack = pack( "H*", $as_hex ); |
132
|
10
|
100
|
|
|
|
20
|
$pack |= "\x80\x00\x00\x00\x00\x00\x00\x00" if $neg; |
133
|
10
|
|
|
|
|
53
|
return scalar reverse $pack; |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
sub _int64_to_bigint { |
137
|
0
|
|
|
0
|
|
0
|
my $bytes = reverse(shift); |
138
|
0
|
0
|
|
|
|
0
|
return Math::BigInt->new() if $bytes eq "\x00\x00\x00\x00\x00\x00\x00\x00"; |
139
|
0
|
0
|
|
|
|
0
|
if ( unpack("c", $bytes) < 0 ) { |
140
|
0
|
0
|
|
|
|
0
|
if ( $bytes eq "\x80\x00\x00\x00\x00\x00\x00\x00" ) { |
141
|
0
|
|
|
|
|
0
|
return -1 * Math::BigInt->new( "0x" . unpack("H*",$bytes) ); |
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
else { |
144
|
0
|
|
|
|
|
0
|
return -1 * Math::BigInt->new( "0x" . unpack( "H*", ~$bytes ) ) - 1; |
145
|
|
|
|
|
|
|
} |
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
else { |
148
|
0
|
|
|
|
|
0
|
return Math::BigInt->new( "0x" . unpack( "H*", $bytes ) ); |
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
} |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
sub _pack_int64 { |
153
|
18253
|
|
|
18253
|
|
26274
|
my $value = shift; |
154
|
18253
|
|
|
|
|
23959
|
my $type = ref($value); |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
# if no type, then on 64-big perl we can pack with 'q'; otherwise |
157
|
|
|
|
|
|
|
# we need to convert scalars to Math::BigInt and pack them that way. |
158
|
18253
|
100
|
|
|
|
26889
|
if ( ! $type ) { |
159
|
18243
|
|
|
|
|
66945
|
return pack(BSON_INT64,$value ) if HAS_INT64; |
160
|
0
|
|
|
|
|
0
|
$value = Math::BigInt->new($value); |
161
|
0
|
|
|
|
|
0
|
$type = 'Math::BigInt'; |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
|
164
|
10
|
50
|
|
|
|
32
|
if ( $type eq 'Math::BigInt' ) { |
|
|
0
|
|
|
|
|
|
165
|
10
|
|
|
|
|
33
|
return _bigint_to_int64($value); |
166
|
|
|
|
|
|
|
} |
167
|
|
|
|
|
|
|
elsif ( $type eq 'Math::Int64' ) { |
168
|
0
|
|
|
|
|
0
|
return Math::Int64::int64_to_native($value); |
169
|
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
else { |
171
|
0
|
|
|
|
|
0
|
croak "Don't know how to encode $type '$value' as an Int64."; |
172
|
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
sub _reftype_check { |
176
|
1
|
|
|
1
|
|
2
|
my $doc = shift; |
177
|
1
|
|
|
|
|
3
|
my $type = ref($doc); |
178
|
1
|
|
|
|
|
3
|
my $reftype = reftype($doc); |
179
|
1
|
50
|
|
|
|
10
|
die "Can't encode non-container of type '$type'" unless $reftype eq 'HASH'; |
180
|
0
|
|
|
|
|
0
|
return; |
181
|
|
|
|
|
|
|
} |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
sub _encode_bson { |
184
|
30728
|
|
|
30728
|
|
50640
|
my ($doc, $opt) = @_; |
185
|
|
|
|
|
|
|
|
186
|
30728
|
|
|
|
|
55547
|
my $refaddr = refaddr($doc); |
187
|
30728
|
100
|
|
|
|
94716
|
die "circular reference detected" if $opt->{_circular}{$refaddr}++; |
188
|
|
|
|
|
|
|
|
189
|
30724
|
100
|
|
|
|
58915
|
$opt->{_depth} = 0 unless defined $opt->{_depth}; |
190
|
30724
|
|
|
|
|
33476
|
$opt->{_depth}++; |
191
|
30724
|
100
|
|
|
|
47723
|
if ($opt->{_depth} > BSON_MAX_DEPTH) { |
192
|
2
|
|
|
|
|
1157
|
croak "Exceeded max object depth of ". BSON_MAX_DEPTH; |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
|
195
|
30722
|
|
|
|
|
64866
|
my $doc_type = ref($doc); |
196
|
|
|
|
|
|
|
|
197
|
30722
|
100
|
66
|
|
|
84849
|
if ( $doc_type eq 'BSON::Raw' || $doc_type eq 'MongoDB::BSON::_EncodedDoc' ) { |
198
|
103
|
|
|
|
|
153
|
delete $opt->{_circular}{$refaddr}; |
199
|
103
|
|
|
|
|
106
|
$opt->{_depth}--; |
200
|
103
|
|
|
|
|
359
|
return $doc->bson; |
201
|
|
|
|
|
|
|
} |
202
|
|
|
|
|
|
|
|
203
|
30619
|
100
|
|
|
|
45380
|
if ( $doc_type eq 'MongoDB::BSON::Raw' ) { |
204
|
3
|
|
|
|
|
6
|
delete $opt->{_circular}{$refaddr}; |
205
|
3
|
|
|
|
|
4
|
$opt->{_depth}--; |
206
|
3
|
|
|
|
|
11
|
return $$doc; |
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
my $iter = |
210
|
|
|
|
|
|
|
$doc_type eq 'HASH' ? undef |
211
|
|
|
|
|
|
|
: $doc_type eq 'BSON::Doc' ? $doc->_iterator |
212
|
|
|
|
|
|
|
: $doc_type eq 'Tie::IxHash' ? _ixhash_iterator($doc) |
213
|
|
|
|
|
|
|
: $doc_type eq 'BSON::DBRef' ? _ixhash_iterator( $doc->_ordered ) |
214
|
|
|
|
|
|
|
: $doc_type eq 'MongoDB::DBRef' ? _ixhash_iterator( $doc->_ordered ) |
215
|
30616
|
100
|
|
|
|
45605
|
: do { _reftype_check($doc); undef }; |
|
1
|
100
|
|
|
|
4
|
|
|
0
|
100
|
|
|
|
0
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
216
|
|
|
|
|
|
|
|
217
|
30615
|
|
66
|
|
|
69630
|
$iter //= _hashlike_iterator($doc); |
218
|
|
|
|
|
|
|
|
219
|
30615
|
100
|
|
|
|
63341
|
my $op_char = defined($opt->{op_char}) ? $opt->{op_char} : ''; |
220
|
|
|
|
|
|
|
my $invalid = |
221
|
30615
|
100
|
|
|
|
49190
|
length( $opt->{invalid_chars} ) ? qr/[\Q$opt->{invalid_chars}\E]/ : undef; |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
# Set up first key bookkeeping |
224
|
30615
|
|
|
|
|
43916
|
my $first_key_pending = !! defined($opt->{first_key}); |
225
|
30615
|
|
|
|
|
31100
|
my $first_key; |
226
|
30615
|
|
|
|
|
36698
|
my $bson = ''; |
227
|
|
|
|
|
|
|
|
228
|
30615
|
|
|
|
|
36609
|
my ($key, $value); |
229
|
30615
|
|
100
|
|
|
62701
|
while ( $first_key_pending or ( $key, $value ) = $iter->() ) { |
230
|
148847
|
100
|
100
|
|
|
447165
|
next if defined $first_key && $key eq $first_key; |
231
|
|
|
|
|
|
|
|
232
|
148846
|
100
|
|
|
|
192852
|
if ( $first_key_pending ) { |
233
|
2
|
|
|
|
|
3
|
$first_key = $key = delete $opt->{first_key}; |
234
|
2
|
|
|
|
|
4
|
$value = delete $opt->{first_value}; |
235
|
2
|
|
|
|
|
4
|
undef $first_key_pending; |
236
|
|
|
|
|
|
|
} |
237
|
|
|
|
|
|
|
|
238
|
148846
|
50
|
|
|
|
219798
|
last unless defined $key; |
239
|
|
|
|
|
|
|
|
240
|
148846
|
100
|
|
|
|
243912
|
croak "Key '" . _printable($key) . "' contains null character" |
241
|
|
|
|
|
|
|
unless -1 == index($key, "\0"); |
242
|
|
|
|
|
|
|
|
243
|
148845
|
100
|
100
|
|
|
224396
|
substr( $key, 0, 1 ) = '$' |
244
|
|
|
|
|
|
|
if length($op_char) && substr( $key, 0, 1 ) eq $op_char; |
245
|
|
|
|
|
|
|
|
246
|
148845
|
100
|
66
|
|
|
206150
|
if ( $invalid && $key =~ $invalid ) { |
247
|
|
|
|
|
|
|
croak( |
248
|
|
|
|
|
|
|
sprintf( |
249
|
|
|
|
|
|
|
"key '%s' has invalid character(s) '%s'", |
250
|
|
|
|
|
|
|
$key, $opt->{invalid_chars} |
251
|
|
|
|
|
|
|
) |
252
|
2
|
|
|
|
|
243
|
); |
253
|
|
|
|
|
|
|
} |
254
|
|
|
|
|
|
|
|
255
|
148843
|
|
|
|
|
168025
|
my $utf8_key = $key; |
256
|
148843
|
|
|
|
|
276713
|
utf8::encode($utf8_key); |
257
|
148843
|
|
|
|
|
246510
|
my $type = ref $value; |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
# If the type is a subtype of BSON::*, use that instead |
260
|
148843
|
100
|
|
|
|
275132
|
if ( blessed $value ) { |
261
|
92955
|
100
|
|
|
|
255290
|
if ($type !~ /\ABSON::\w+\z/) { |
262
|
47
|
|
|
72
|
|
158
|
my $parent = first { /\ABSON::\w+\z/ } reverse @{mro::get_linear_isa($type)}; |
|
72
|
|
|
|
|
161
|
|
|
47
|
|
|
|
|
306
|
|
263
|
47
|
100
|
|
|
|
198
|
$type = $parent if defined $parent; |
264
|
|
|
|
|
|
|
} |
265
|
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
# Null |
268
|
148843
|
100
|
|
|
|
260796
|
if ( !defined $value ) { |
|
|
100
|
|
|
|
|
|
269
|
9098
|
|
|
|
|
22840
|
$bson .= pack( BSON_TYPE_NAME, 0x0A, $utf8_key ); |
270
|
|
|
|
|
|
|
} |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
# REFERENCES/OBJECTS |
273
|
|
|
|
|
|
|
elsif ( length $type ) { |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
# Array |
276
|
112176
|
100
|
100
|
|
|
1561407
|
if ( $type eq 'ARRAY' || $type eq 'BSON::Array' ) { |
|
|
100
|
100
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
100
|
66
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
50
|
100
|
|
|
|
|
|
|
100
|
66
|
|
|
|
|
|
|
100
|
66
|
|
|
|
|
|
|
50
|
100
|
|
|
|
|
|
|
50
|
100
|
|
|
|
|
|
|
50
|
100
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
50
|
100
|
|
|
|
|
|
|
100
|
66
|
|
|
|
|
|
|
100
|
66
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
100
|
66
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
277
|
9056
|
|
|
|
|
11620
|
my $i = 0; |
278
|
9056
|
|
|
|
|
31998
|
tie( my %h, 'Tie::IxHash' ); |
279
|
9056
|
|
|
|
|
148367
|
%h = map { $i++ => $_ } @$value; |
|
28141
|
|
|
|
|
50088
|
|
280
|
9056
|
|
|
|
|
467854
|
$bson .= pack( BSON_TYPE_NAME, 0x04, $utf8_key ) . _encode_bson( \%h, $opt ); |
281
|
|
|
|
|
|
|
} |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
# special-cased deprecated DBPointer |
284
|
|
|
|
|
|
|
elsif ($type eq 'BSON::DBPointer') { |
285
|
4
|
|
|
|
|
6
|
my %data; |
286
|
4
|
|
|
|
|
14
|
tie %data, 'Tie::IxHash'; |
287
|
4
|
|
|
|
|
57
|
$data{'$ref'} = $value->{'ref'}; |
288
|
4
|
|
|
|
|
54
|
$data{'$id'} = $value->{id}; |
289
|
4
|
|
|
|
|
55
|
$bson .= pack( BSON_TYPE_NAME, 0x03, $utf8_key ) |
290
|
|
|
|
|
|
|
. _encode_bson(\%data, $opt); |
291
|
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
# Document |
294
|
|
|
|
|
|
|
elsif ($type eq 'HASH' |
295
|
|
|
|
|
|
|
|| $type eq 'BSON::Doc' |
296
|
|
|
|
|
|
|
|| $type eq 'BSON::Raw' |
297
|
|
|
|
|
|
|
|| $type eq 'MongoDB::BSON::_EncodedDoc' |
298
|
|
|
|
|
|
|
|| $type eq 'Tie::IxHash' |
299
|
|
|
|
|
|
|
|| $type eq 'MongoDB::BSON::Raw' |
300
|
|
|
|
|
|
|
|| $type eq 'BSON::DBRef' |
301
|
|
|
|
|
|
|
|| $type eq 'MongoDB::DBRef') |
302
|
|
|
|
|
|
|
{ |
303
|
10290
|
|
|
|
|
26822
|
$bson .= pack( BSON_TYPE_NAME, 0x03, $utf8_key ) . _encode_bson($value, $opt); |
304
|
|
|
|
|
|
|
} |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
# Regex |
307
|
|
|
|
|
|
|
elsif ( $type eq 'Regexp' ) { |
308
|
4
|
|
|
|
|
13
|
my ( $re, $flags ) = _split_re($value); |
309
|
4
|
|
|
|
|
47
|
$bson .= pack( BSON_TYPE_NAME.BSON_REGEX, 0x0B, $utf8_key, $re, join( "", sort grep /^(i|m|x|l|s|u)$/, split( //, $flags ) )); |
310
|
|
|
|
|
|
|
} |
311
|
|
|
|
|
|
|
elsif ( $type eq 'BSON::Regex' || $type eq 'MongoDB::BSON::Regexp' ) { |
312
|
9223
|
|
|
|
|
11306
|
my ( $re, $flags ) = @{$value}{qw/pattern flags/}; |
|
9223
|
|
|
|
|
28072
|
|
313
|
9223
|
|
|
|
|
45261
|
$bson .= pack( BSON_TYPE_NAME.BSON_REGEX, 0x0B, $utf8_key, $re, $flags) ; |
314
|
|
|
|
|
|
|
} |
315
|
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
# ObjectId |
317
|
|
|
|
|
|
|
elsif ( $type eq 'BSON::OID' || $type eq 'BSON::ObjectId' ) { |
318
|
9142
|
|
|
|
|
41917
|
$bson .= pack( BSON_TYPE_NAME.BSON_OBJECTID, 0x07, $utf8_key, $value->oid ); |
319
|
|
|
|
|
|
|
} |
320
|
|
|
|
|
|
|
elsif ( $type eq 'MongoDB::OID' ) { |
321
|
0
|
|
|
|
|
0
|
$bson .= pack( BSON_TYPE_NAME."H*", 0x07, $utf8_key, $value->value ); |
322
|
|
|
|
|
|
|
} |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
# Datetime |
325
|
|
|
|
|
|
|
elsif ( $type eq 'BSON::Time' ) { |
326
|
9092
|
|
|
|
|
30761
|
$bson .= pack( BSON_TYPE_NAME, 0x09, $utf8_key ) . _pack_int64( $value->value ); |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
elsif ( $type eq 'Time::Moment' ) { |
329
|
1
|
|
|
|
|
11
|
$bson .= pack( BSON_TYPE_NAME, 0x09, $utf8_key ) . _pack_int64( int( $value->epoch * 1000 + $value->millisecond ) ); |
330
|
|
|
|
|
|
|
} |
331
|
|
|
|
|
|
|
elsif ( $type eq 'DateTime' ) { |
332
|
0
|
0
|
|
|
|
0
|
if ( $value->time_zone->name eq 'floating' ) { |
333
|
0
|
|
|
|
|
0
|
warn("saving floating timezone as UTC"); |
334
|
|
|
|
|
|
|
} |
335
|
0
|
|
|
|
|
0
|
$bson .= pack( BSON_TYPE_NAME, 0x09, $utf8_key ) . _pack_int64( int( $value->hires_epoch * 1000 ) ); |
336
|
|
|
|
|
|
|
} |
337
|
|
|
|
|
|
|
elsif ( $type eq 'DateTime::Tiny' ) { |
338
|
0
|
|
|
|
|
0
|
require Time::Local; |
339
|
0
|
|
|
|
|
0
|
my $epoch = Time::Local::timegm( |
340
|
|
|
|
|
|
|
$value->second, $value->minute, $value->hour, |
341
|
|
|
|
|
|
|
$value->day, $value->month - 1, $value->year, |
342
|
|
|
|
|
|
|
); |
343
|
0
|
|
|
|
|
0
|
$bson .= pack( BSON_TYPE_NAME, 0x09, $utf8_key ) . _pack_int64( $epoch * 1000 ); |
344
|
|
|
|
|
|
|
} |
345
|
|
|
|
|
|
|
elsif ( $type eq 'Mango::BSON::Time' ) { |
346
|
0
|
|
|
|
|
0
|
$bson .= pack( BSON_TYPE_NAME, 0x09, $utf8_key ) . _pack_int64( $value->{time} ); |
347
|
|
|
|
|
|
|
} |
348
|
|
|
|
|
|
|
|
349
|
|
|
|
|
|
|
# Timestamp |
350
|
|
|
|
|
|
|
elsif ( $type eq 'BSON::Timestamp' ) { |
351
|
9086
|
|
|
|
|
45472
|
$bson .= pack( BSON_TYPE_NAME.BSON_TIMESTAMP, 0x11, $utf8_key, $value->increment, $value->seconds ); |
352
|
|
|
|
|
|
|
} |
353
|
|
|
|
|
|
|
elsif ( $type eq 'MongoDB::Timestamp' ){ |
354
|
0
|
|
|
|
|
0
|
$bson .= pack( BSON_TYPE_NAME.BSON_TIMESTAMP, 0x11, $utf8_key, $value->inc, $value->sec ); |
355
|
|
|
|
|
|
|
} |
356
|
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
# MinKey |
358
|
|
|
|
|
|
|
elsif ( $type eq 'BSON::MinKey' || $type eq 'MongoDB::MinKey' ) { |
359
|
9085
|
|
|
|
|
40598
|
$bson .= pack( BSON_TYPE_NAME, 0xFF, $utf8_key ); |
360
|
|
|
|
|
|
|
} |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
# MaxKey |
363
|
|
|
|
|
|
|
elsif ( $type eq 'BSON::MaxKey' || $type eq 'MongoDB::MaxKey' ) { |
364
|
9144
|
|
|
|
|
29662
|
$bson .= pack( BSON_TYPE_NAME, 0x7F, $utf8_key ); |
365
|
|
|
|
|
|
|
} |
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
# Binary (XXX need to add string ref support) |
368
|
|
|
|
|
|
|
elsif ($type eq 'SCALAR' |
369
|
|
|
|
|
|
|
|| $type eq 'BSON::Bytes' |
370
|
|
|
|
|
|
|
|| $type eq 'BSON::Binary' |
371
|
|
|
|
|
|
|
|| $type eq 'MongoDB::BSON::Binary' ) |
372
|
|
|
|
|
|
|
{ |
373
|
|
|
|
|
|
|
my $data = |
374
|
|
|
|
|
|
|
$type eq 'SCALAR' ? $$value |
375
|
|
|
|
|
|
|
: $type eq 'BSON::Bytes' ? $value->data |
376
|
|
|
|
|
|
|
: $type eq 'MongoDB::BSON::Binary' ? $value->data |
377
|
9077
|
50
|
|
|
|
31220
|
: pack( "C*", @{ $value->data } ); |
|
4
|
100
|
|
|
|
12
|
|
|
|
100
|
|
|
|
|
|
378
|
9077
|
100
|
|
|
|
18404
|
my $subtype = $type eq 'SCALAR' ? 0 : $value->subtype; |
379
|
9077
|
|
|
|
|
10708
|
my $len = length($data); |
380
|
9077
|
100
|
|
|
|
12752
|
if ( $subtype == 2 ) { |
381
|
2
|
|
|
|
|
11
|
$bson .= |
382
|
|
|
|
|
|
|
pack( BSON_TYPE_NAME . BSON_INT32 . BSON_BINARY_TYPE . BSON_INT32 . BSON_REMAINING, |
383
|
|
|
|
|
|
|
0x05, $utf8_key, $len + 4, $subtype, $len, $data ); |
384
|
|
|
|
|
|
|
} |
385
|
|
|
|
|
|
|
else { |
386
|
9075
|
|
|
|
|
33199
|
$bson .= pack( BSON_TYPE_NAME . BSON_INT32 . BSON_BINARY_TYPE . BSON_REMAINING, |
387
|
|
|
|
|
|
|
0x05, $utf8_key, $len, $subtype, $data ); |
388
|
|
|
|
|
|
|
} |
389
|
|
|
|
|
|
|
} |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
# Code |
392
|
|
|
|
|
|
|
elsif ( $type eq 'BSON::Code' || $type eq 'MongoDB::Code' ) { |
393
|
9172
|
|
|
|
|
25003
|
my $code = $value->code; |
394
|
9172
|
|
|
|
|
31366
|
utf8::encode($code); |
395
|
9172
|
|
|
|
|
30165
|
$code = pack(BSON_STRING,$code); |
396
|
9172
|
100
|
|
|
|
26283
|
if ( ref( $value->scope ) eq 'HASH' ) { |
397
|
8887
|
|
|
|
|
16575
|
my $scope = _encode_bson( $value->scope, $opt ); |
398
|
8887
|
|
|
|
|
50305
|
$bson .= |
399
|
|
|
|
|
|
|
pack( BSON_TYPE_NAME.BSON_CODE_W_SCOPE, 0x0F, $utf8_key, (4 + length($scope) + length($code)) ) . $code . $scope; |
400
|
|
|
|
|
|
|
} |
401
|
|
|
|
|
|
|
else { |
402
|
285
|
|
|
|
|
1208
|
$bson .= pack( BSON_TYPE_NAME, 0x0D, $utf8_key) . $code; |
403
|
|
|
|
|
|
|
} |
404
|
|
|
|
|
|
|
} |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
# Boolean |
407
|
|
|
|
|
|
|
elsif ( $type eq 'boolean' || $type =~ $bools_re ) { |
408
|
9090
|
100
|
|
|
|
51464
|
$bson .= pack( BSON_TYPE_NAME.BSON_BOOLEAN, 0x08, $utf8_key, ( $value ? 1 : 0 ) ); |
409
|
|
|
|
|
|
|
} |
410
|
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
# String (explicit) |
412
|
|
|
|
|
|
|
elsif ( $type eq 'BSON::String' || $type eq 'BSON::Symbol') { |
413
|
9104
|
|
|
|
|
24653
|
$value = $value->value; |
414
|
9104
|
|
|
|
|
23305
|
utf8::encode($value); |
415
|
9104
|
|
|
|
|
35296
|
$bson .= pack( BSON_TYPE_NAME.BSON_STRING, 0x02, $utf8_key, $value ); |
416
|
|
|
|
|
|
|
} |
417
|
|
|
|
|
|
|
elsif ( $type eq 'MongoDB::BSON::String' ) { |
418
|
2
|
|
|
|
|
3
|
$value = $$value; |
419
|
2
|
|
|
|
|
5
|
utf8::encode($value); |
420
|
2
|
|
|
|
|
11
|
$bson .= pack( BSON_TYPE_NAME.BSON_STRING, 0x02, $utf8_key, $value ); |
421
|
|
|
|
|
|
|
} |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
# Int64 (XXX and eventually BigInt) |
424
|
|
|
|
|
|
|
elsif ( $type eq 'BSON::Int64' || $type eq 'Math::BigInt' || $type eq 'Math::Int64' ) |
425
|
|
|
|
|
|
|
{ |
426
|
24
|
50
|
33
|
|
|
375
|
if ( $value > $max_int64 || $value < $min_int64 ) { |
427
|
0
|
|
|
|
|
0
|
croak("BSON can only handle 8-byte integers. Key '$key' is '$value'"); |
428
|
|
|
|
|
|
|
} |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
# unwrap BSON::Int64; it could be Math::BigInt, etc. |
431
|
24
|
100
|
|
|
|
2193
|
if ( $type eq 'BSON::Int64' ) { |
432
|
16
|
|
|
|
|
43
|
$value = $value->value; |
433
|
|
|
|
|
|
|
} |
434
|
|
|
|
|
|
|
|
435
|
24
|
|
|
|
|
126
|
$bson .= pack( BSON_TYPE_NAME, 0x12, $utf8_key ) . _pack_int64($value); |
436
|
|
|
|
|
|
|
} |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
elsif ( $type eq 'BSON::Int32' ) { |
439
|
35
|
|
|
|
|
265
|
$bson .= pack( BSON_TYPE_NAME . BSON_INT32, 0x10, $utf8_key, $value->value ); |
440
|
|
|
|
|
|
|
} |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
# Double (explicit) |
443
|
|
|
|
|
|
|
elsif ( $type eq 'BSON::Double' ) { |
444
|
32
|
|
|
|
|
802
|
$bson .= pack( BSON_TYPE_NAME.BSON_DOUBLE, 0x01, $utf8_key, $value/1.0 ); |
445
|
|
|
|
|
|
|
} |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
# Decimal128 |
448
|
|
|
|
|
|
|
elsif ( $type eq 'BSON::Decimal128' ) { |
449
|
1512
|
|
|
|
|
38321
|
$bson .= pack( BSON_TYPE_NAME.BSON_16BYTES, 0x13, $utf8_key, $value->bytes ); |
450
|
|
|
|
|
|
|
} |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
# Unsupported type |
453
|
|
|
|
|
|
|
else { |
454
|
1
|
|
|
|
|
164
|
croak("For key '$key', can't encode value of type '$type'"); |
455
|
|
|
|
|
|
|
} |
456
|
|
|
|
|
|
|
} |
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
# SCALAR |
459
|
|
|
|
|
|
|
else { |
460
|
|
|
|
|
|
|
# If a numeric value exists based on internal flags, use it; |
461
|
|
|
|
|
|
|
# otherwise, if prefer_numeric is true and it looks like a |
462
|
|
|
|
|
|
|
# number, then coerce to a number of the right type; |
463
|
|
|
|
|
|
|
# otherwise, leave it as a string |
464
|
|
|
|
|
|
|
|
465
|
27569
|
|
|
|
|
80276
|
my $flags = B::svref_2object(\$value)->FLAGS; |
466
|
|
|
|
|
|
|
|
467
|
27569
|
100
|
100
|
|
|
57068
|
if ( $flags & B::SVf_NOK() ) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
468
|
9188
|
|
|
|
|
27997
|
$bson .= pack( BSON_TYPE_NAME.BSON_DOUBLE, 0x01, $utf8_key, $value ); |
469
|
|
|
|
|
|
|
} |
470
|
|
|
|
|
|
|
elsif ( $flags & B::SVf_IOK() ) { |
471
|
|
|
|
|
|
|
# Force numeric; fixes dual-vars comparison bug on old Win32s |
472
|
18255
|
|
|
|
|
21835
|
$value = 0+$value; |
473
|
18255
|
50
|
33
|
|
|
65351
|
if ( $value > $max_int64 || $value < $min_int64 ) { |
|
|
100
|
100
|
|
|
|
|
474
|
0
|
|
|
|
|
0
|
croak("BSON can only handle 8-byte integers. Key '$key' is '$value'"); |
475
|
|
|
|
|
|
|
} |
476
|
|
|
|
|
|
|
elsif ( $value > $max_int32 || $value < $min_int32 ) { |
477
|
9136
|
|
|
|
|
20103
|
$bson .= pack( BSON_TYPE_NAME, 0x12, $utf8_key ) . _pack_int64($value); |
478
|
|
|
|
|
|
|
} |
479
|
|
|
|
|
|
|
else { |
480
|
9119
|
|
|
|
|
28765
|
$bson .= pack( BSON_TYPE_NAME . BSON_INT32, 0x10, $utf8_key, $value ); |
481
|
|
|
|
|
|
|
} |
482
|
|
|
|
|
|
|
} |
483
|
|
|
|
|
|
|
elsif ( $opt->{prefer_numeric} && looks_like_number($value) ) { |
484
|
|
|
|
|
|
|
# Looks like int: type heuristic based on size |
485
|
3
|
100
|
|
|
|
33
|
if ( $value =~ $int_re ) { |
|
|
50
|
|
|
|
|
|
486
|
2
|
50
|
33
|
|
|
18
|
if ( $value > $max_int64 || $value < $min_int64 ) { |
|
|
50
|
33
|
|
|
|
|
487
|
0
|
|
|
|
|
0
|
croak("BSON can only handle 8-byte integers. Key '$key' is '$value'"); |
488
|
|
|
|
|
|
|
} |
489
|
|
|
|
|
|
|
elsif ( $value > $max_int32 || $value < $min_int32 ) { |
490
|
0
|
|
|
|
|
0
|
$bson .= pack( BSON_TYPE_NAME, 0x12, $utf8_key ) . _pack_int64($value); |
491
|
|
|
|
|
|
|
} |
492
|
|
|
|
|
|
|
else { |
493
|
2
|
|
|
|
|
16
|
$bson .= pack( BSON_TYPE_NAME . BSON_INT32, 0x10, $utf8_key, $value ); |
494
|
|
|
|
|
|
|
} |
495
|
|
|
|
|
|
|
} |
496
|
|
|
|
|
|
|
|
497
|
|
|
|
|
|
|
# Looks like double |
498
|
|
|
|
|
|
|
elsif ( $value =~ $doub_re ) { |
499
|
1
|
|
|
|
|
9
|
$bson .= pack( BSON_TYPE_NAME.BSON_DOUBLE, 0x01, $utf8_key, $value ); |
500
|
|
|
|
|
|
|
} |
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
# looks_like_number true, but doesn't match int/double |
503
|
|
|
|
|
|
|
# regexes, so as a last resort we leave as string |
504
|
|
|
|
|
|
|
else { |
505
|
0
|
|
|
|
|
0
|
utf8::encode($value); |
506
|
0
|
|
|
|
|
0
|
$bson .= pack( BSON_TYPE_NAME.BSON_STRING, 0x02, $utf8_key, $value ); |
507
|
|
|
|
|
|
|
} |
508
|
|
|
|
|
|
|
} |
509
|
|
|
|
|
|
|
else { |
510
|
|
|
|
|
|
|
# Not coercing or didn't look like a number |
511
|
123
|
|
|
|
|
260
|
utf8::encode($value); |
512
|
123
|
|
|
|
|
626
|
$bson .= pack( BSON_TYPE_NAME.BSON_STRING, 0x02, $utf8_key, $value ); |
513
|
|
|
|
|
|
|
} |
514
|
|
|
|
|
|
|
} |
515
|
|
|
|
|
|
|
} |
516
|
|
|
|
|
|
|
|
517
|
30405
|
|
|
|
|
76516
|
delete $opt->{_circular}{$refaddr}; |
518
|
30405
|
|
|
|
|
34629
|
$opt->{_depth}--; |
519
|
|
|
|
|
|
|
|
520
|
30405
|
|
|
|
|
225972
|
return pack( BSON_INT32, length($bson) + 5 ) . $bson . "\0"; |
521
|
|
|
|
|
|
|
} |
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
my %FIELD_SIZES = ( |
524
|
|
|
|
|
|
|
0x01 => 8, |
525
|
|
|
|
|
|
|
0x02 => 5, |
526
|
|
|
|
|
|
|
0x03 => 5, |
527
|
|
|
|
|
|
|
0x04 => 5, |
528
|
|
|
|
|
|
|
0x05 => 5, |
529
|
|
|
|
|
|
|
0x06 => 0, |
530
|
|
|
|
|
|
|
0x07 => 12, |
531
|
|
|
|
|
|
|
0x08 => 1, |
532
|
|
|
|
|
|
|
0x09 => 8, |
533
|
|
|
|
|
|
|
0x0A => 0, |
534
|
|
|
|
|
|
|
0x0B => 2, |
535
|
|
|
|
|
|
|
0x0C => 17, |
536
|
|
|
|
|
|
|
0x0D => 5, |
537
|
|
|
|
|
|
|
0x0E => 5, |
538
|
|
|
|
|
|
|
0x0F => 11, |
539
|
|
|
|
|
|
|
0x10 => 4, |
540
|
|
|
|
|
|
|
0x11 => 8, |
541
|
|
|
|
|
|
|
0x12 => 8, |
542
|
|
|
|
|
|
|
0x13 => 16, |
543
|
|
|
|
|
|
|
0x7F => 0, |
544
|
|
|
|
|
|
|
0xFF => 0, |
545
|
|
|
|
|
|
|
); |
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
my $ERR_UNSUPPORTED = "unsupported BSON type \\x%X for key '%s'. Are you using the latest version of BSON.pm?"; |
548
|
|
|
|
|
|
|
my $ERR_TRUNCATED = "premature end of BSON field '%s' (type 0x%x)"; |
549
|
|
|
|
|
|
|
my $ERR_LENGTH = "BSON field '%s' (type 0x%x) has invalid length: wanted %d, got %d"; |
550
|
|
|
|
|
|
|
my $ERR_MISSING_NULL = "BSON field '%s' (type 0x%x) missing null terminator"; |
551
|
|
|
|
|
|
|
my $ERR_BAD_UTF8 = "BSON field '%s' (type 0x%x) contains invalid UTF-8"; |
552
|
|
|
|
|
|
|
my $ERR_NEG_LENGTH = "BSON field '%s' (type 0x%x) contains negative length"; |
553
|
|
|
|
|
|
|
my $ERR_BAD_OLDBINARY = "BSON field '%s' (type 0x%x, subtype 0x02) is invalid"; |
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
sub __dump_bson { |
556
|
0
|
|
|
0
|
|
0
|
my $bson = unpack("H*", shift); |
557
|
0
|
|
|
|
|
0
|
my @pairs = $bson=~ m/(..)/g; |
558
|
0
|
|
|
|
|
0
|
return join(" ", @pairs); |
559
|
|
|
|
|
|
|
} |
560
|
|
|
|
|
|
|
|
561
|
|
|
|
|
|
|
sub _decode_bson { |
562
|
29596
|
|
|
29596
|
|
72431
|
my ($bson, $opt) = @_; |
563
|
29596
|
50
|
|
|
|
47854
|
if ( !defined $bson ) { |
564
|
0
|
|
|
|
|
0
|
croak("Decode argument must not be undef"); |
565
|
|
|
|
|
|
|
} |
566
|
29596
|
100
|
|
|
|
47556
|
$opt->{_depth} = 0 unless defined $opt->{_depth}; |
567
|
29596
|
|
|
|
|
30761
|
$opt->{_depth}++; |
568
|
29596
|
100
|
|
|
|
44430
|
if ($opt->{_depth} > BSON_MAX_DEPTH) { |
569
|
1
|
|
|
|
|
567
|
croak "Exceeded max object depth of ". BSON_MAX_DEPTH; |
570
|
|
|
|
|
|
|
} |
571
|
29595
|
|
|
|
|
36702
|
my $blen= length($bson); |
572
|
29595
|
|
|
|
|
47740
|
my $len = unpack( BSON_INT32, $bson ); |
573
|
29595
|
100
|
|
|
|
46902
|
if ( length($bson) != $len ) { |
574
|
15
|
|
|
|
|
2035
|
croak("Incorrect length of the bson string (got $blen, wanted $len)"); |
575
|
|
|
|
|
|
|
} |
576
|
29580
|
100
|
|
|
|
64719
|
if ( chop($bson) ne "\x00" ) { |
577
|
5
|
|
|
|
|
580
|
croak("BSON document not null terminated"); |
578
|
|
|
|
|
|
|
} |
579
|
29575
|
|
|
|
|
52153
|
$bson = substr $bson, 4; |
580
|
29575
|
|
|
|
|
37432
|
my @array = (); |
581
|
29575
|
|
|
|
|
31496
|
my %hash = (); |
582
|
29575
|
100
|
|
|
|
48799
|
tie( %hash, 'Tie::IxHash' ) if $opt->{ordered}; |
583
|
29575
|
|
|
|
|
50203
|
my ($type, $key, $value); |
584
|
29575
|
|
|
|
|
43153
|
while ($bson) { |
585
|
147699
|
|
|
|
|
443886
|
( $type, $key, $bson ) = unpack( BSON_TYPE_NAME.BSON_REMAINING, $bson ); |
586
|
147699
|
|
|
|
|
286405
|
utf8::decode($key); |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
# Check type and truncation |
589
|
147699
|
|
|
|
|
193099
|
my $min_size = $FIELD_SIZES{$type}; |
590
|
147699
|
100
|
|
|
|
213783
|
if ( !defined $min_size ) { |
591
|
8
|
|
|
|
|
986
|
croak( sprintf( $ERR_UNSUPPORTED, $type, $key ) ); |
592
|
|
|
|
|
|
|
} |
593
|
147691
|
100
|
|
|
|
215675
|
if ( length($bson) < $min_size ) { |
594
|
12
|
|
|
|
|
2038
|
croak( sprintf( $ERR_TRUNCATED, $key, $type ) ); |
595
|
|
|
|
|
|
|
} |
596
|
|
|
|
|
|
|
|
597
|
|
|
|
|
|
|
# Double |
598
|
147679
|
100
|
100
|
|
|
740056
|
if ( $type == 0x01 ) { |
|
|
100
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
599
|
9234
|
|
|
|
|
24407
|
( $value, $bson ) = unpack( BSON_DOUBLE.BSON_REMAINING, $bson ); |
600
|
9234
|
100
|
|
|
|
19330
|
$value = BSON::Double->new( value => $value ) if $opt->{wrap_numbers}; |
601
|
|
|
|
|
|
|
} |
602
|
|
|
|
|
|
|
|
603
|
|
|
|
|
|
|
# String and Symbol (deprecated); Symbol will be convert to String |
604
|
|
|
|
|
|
|
elsif ( $type == 0x02 || $type == 0x0E ) { |
605
|
9238
|
|
|
|
|
23297
|
( $len, $bson ) = unpack( BSON_INT32 . BSON_REMAINING, $bson ); |
606
|
9238
|
100
|
100
|
|
|
31988
|
if ( length($bson) < $len || substr( $bson, $len - 1, 1 ) ne "\x00" ) { |
607
|
11
|
|
|
|
|
1198
|
croak( sprintf( $ERR_MISSING_NULL, $key, $type ) ); |
608
|
|
|
|
|
|
|
} |
609
|
9227
|
|
|
|
|
31824
|
( $value, $bson ) = unpack( "a$len" . BSON_REMAINING, $bson ); |
610
|
9227
|
|
|
|
|
12980
|
chop($value); # remove trailing \x00 |
611
|
9227
|
100
|
|
|
|
20366
|
if ( !utf8::decode($value) ) { |
612
|
3
|
|
|
|
|
295
|
croak( sprintf( $ERR_BAD_UTF8, $key, $type ) ); |
613
|
|
|
|
|
|
|
} |
614
|
9224
|
100
|
|
|
|
16911
|
$value = BSON::String->new( value => $value ) if $opt->{wrap_strings}; |
615
|
|
|
|
|
|
|
} |
616
|
|
|
|
|
|
|
|
617
|
|
|
|
|
|
|
# Document and Array |
618
|
|
|
|
|
|
|
elsif ( $type == 0x03 || $type == 0x04 ) { |
619
|
18550
|
|
|
|
|
30562
|
my $len = unpack( BSON_INT32, $bson ); |
620
|
18550
|
|
|
|
|
100361
|
$value = _decode_bson( substr( $bson, 0, $len ), { %$opt, _decode_array => $type == 0x04} ); |
621
|
18444
|
50
|
100
|
|
|
92513
|
if ( $opt->{wrap_dbrefs} && $type == 0x03 && exists $value->{'$id'} && exists $value->{'$ref'} ) { |
|
|
|
100
|
|
|
|
|
|
|
|
66
|
|
|
|
|
622
|
12
|
|
|
|
|
159
|
$value = BSON::DBRef->new( %$value ); |
623
|
|
|
|
|
|
|
} |
624
|
18444
|
|
|
|
|
50524
|
$bson = substr( $bson, $len, length($bson) - $len ); |
625
|
|
|
|
|
|
|
} |
626
|
|
|
|
|
|
|
|
627
|
|
|
|
|
|
|
# Binary |
628
|
|
|
|
|
|
|
elsif ( $type == 0x05 ) { |
629
|
9079
|
|
|
|
|
18823
|
my ( $len, $btype ) = unpack( BSON_INT32 . BSON_BINARY_TYPE, $bson ); |
630
|
9079
|
|
|
|
|
15621
|
substr( $bson, 0, 5, '' ); |
631
|
|
|
|
|
|
|
|
632
|
9079
|
100
|
|
|
|
16440
|
if ( $len < 0 ) { |
633
|
1
|
|
|
|
|
102
|
croak( sprintf( $ERR_NEG_LENGTH, $key, $type ) ); |
634
|
|
|
|
|
|
|
} |
635
|
9078
|
100
|
|
|
|
38905
|
if ( $len > length($bson) ) { |
636
|
1
|
|
|
|
|
217
|
croak( sprintf( $ERR_TRUNCATED, $key, $type ) ); |
637
|
|
|
|
|
|
|
} |
638
|
|
|
|
|
|
|
|
639
|
9077
|
|
|
|
|
14870
|
my $binary = substr( $bson, 0, $len, '' ); |
640
|
|
|
|
|
|
|
|
641
|
9077
|
100
|
|
|
|
16232
|
if ( $btype == 2 ) { |
642
|
5
|
50
|
|
|
|
12
|
if ( $len < 4 ) { |
643
|
0
|
|
|
|
|
0
|
croak( sprintf( $ERR_BAD_OLDBINARY, $key, $type ) ); |
644
|
|
|
|
|
|
|
} |
645
|
|
|
|
|
|
|
|
646
|
5
|
|
|
|
|
7
|
my $sublen = unpack( BSON_INT32, $binary ); |
647
|
5
|
100
|
|
|
|
12
|
if ( $sublen != length($binary) - 4 ) { |
648
|
3
|
|
|
|
|
614
|
croak( sprintf( $ERR_BAD_OLDBINARY, $key, $type ) ); |
649
|
|
|
|
|
|
|
} |
650
|
|
|
|
|
|
|
|
651
|
2
|
|
|
|
|
3
|
substr( $binary, 0, 4, '' ); |
652
|
|
|
|
|
|
|
} |
653
|
|
|
|
|
|
|
|
654
|
9074
|
|
|
|
|
154442
|
$value = BSON::Bytes->new( subtype => $btype, data => $binary ); |
655
|
|
|
|
|
|
|
} |
656
|
|
|
|
|
|
|
|
657
|
|
|
|
|
|
|
# Undef (deprecated) |
658
|
|
|
|
|
|
|
elsif ( $type == 0x06 ) { |
659
|
2
|
|
|
|
|
3
|
$value = undef; |
660
|
|
|
|
|
|
|
} |
661
|
|
|
|
|
|
|
|
662
|
|
|
|
|
|
|
# ObjectId |
663
|
|
|
|
|
|
|
elsif ( $type == 0x07 ) { |
664
|
9135
|
|
|
|
|
23216
|
( my $oid, $bson ) = unpack( BSON_OBJECTID.BSON_REMAINING, $bson ); |
665
|
9135
|
|
|
|
|
156305
|
$value = BSON::OID->new(oid => $oid); |
666
|
|
|
|
|
|
|
} |
667
|
|
|
|
|
|
|
|
668
|
|
|
|
|
|
|
# Boolean |
669
|
|
|
|
|
|
|
elsif ( $type == 0x08 ) { |
670
|
9092
|
|
|
|
|
29775
|
( my $bool, $bson ) = unpack( BSON_BOOLEAN.BSON_REMAINING, $bson ); |
671
|
9092
|
100
|
100
|
|
|
21583
|
croak("BSON boolean must be 0 or 1. Key '$key' is $bool") |
672
|
|
|
|
|
|
|
unless $bool == 0 || $bool == 1; |
673
|
9090
|
|
|
|
|
18909
|
$value = boolean( $bool ); |
674
|
|
|
|
|
|
|
} |
675
|
|
|
|
|
|
|
|
676
|
|
|
|
|
|
|
# Datetime |
677
|
|
|
|
|
|
|
elsif ( $type == 0x09 ) { |
678
|
9096
|
|
|
|
|
9721
|
if ( HAS_INT64 ) { |
679
|
9096
|
|
|
|
|
24599
|
($value, $bson) = unpack(BSON_INT64.BSON_REMAINING,$bson); |
680
|
|
|
|
|
|
|
} |
681
|
|
|
|
|
|
|
else { |
682
|
|
|
|
|
|
|
($value, $bson) = unpack(BSON_8BYTES.BSON_REMAINING,$bson); |
683
|
|
|
|
|
|
|
$value = _int64_to_bigint($value); |
684
|
|
|
|
|
|
|
} |
685
|
9096
|
|
|
|
|
151865
|
$value = BSON::Time->new( value => $value ); |
686
|
9096
|
|
|
|
|
79554
|
my $dt_type = $opt->{dt_type}; |
687
|
9096
|
100
|
100
|
|
|
18479
|
if ( defined $dt_type && $dt_type ne 'BSON::Time' ) { |
688
|
2
|
50
|
|
|
|
289
|
$value = |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
689
|
|
|
|
|
|
|
$dt_type eq 'Time::Moment' ? $value->as_time_moment |
690
|
|
|
|
|
|
|
: $dt_type eq 'DateTime' ? $value->as_datetime |
691
|
|
|
|
|
|
|
: $dt_type eq 'DateTime::Tiny' ? $value->as_datetime_tiny |
692
|
|
|
|
|
|
|
: $dt_type eq 'Mango::BSON::Time' ? $value->as_mango_time |
693
|
|
|
|
|
|
|
: croak("Unsupported dt_type '$dt_type'"); |
694
|
|
|
|
|
|
|
} |
695
|
|
|
|
|
|
|
} |
696
|
|
|
|
|
|
|
|
697
|
|
|
|
|
|
|
# Null |
698
|
|
|
|
|
|
|
elsif ( $type == 0x0A ) { |
699
|
9090
|
|
|
|
|
12049
|
$value = undef; |
700
|
|
|
|
|
|
|
} |
701
|
|
|
|
|
|
|
|
702
|
|
|
|
|
|
|
# Regex |
703
|
|
|
|
|
|
|
elsif ( $type == 0x0B ) { |
704
|
9227
|
|
|
|
|
32845
|
( my $re, my $op, $bson ) = unpack( BSON_CSTRING.BSON_CSTRING.BSON_REMAINING, $bson ); |
705
|
9227
|
|
|
|
|
169234
|
$value = BSON::Regex->new( pattern => $re, flags => $op ); |
706
|
|
|
|
|
|
|
} |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
# DBPointer (deprecated) |
709
|
|
|
|
|
|
|
elsif ( $type == 0x0C ) { |
710
|
11
|
|
|
|
|
28
|
( $len, $bson ) = unpack( BSON_INT32 . BSON_REMAINING, $bson ); |
711
|
11
|
100
|
66
|
|
|
44
|
if ( length($bson) < $len || substr( $bson, $len - 1, 1 ) ne "\x00" ) { |
712
|
3
|
|
|
|
|
534
|
croak( sprintf( $ERR_MISSING_NULL, $key, $type ) ); |
713
|
|
|
|
|
|
|
} |
714
|
8
|
|
|
|
|
26
|
( my ($ref), $bson ) = unpack( "a$len" . BSON_REMAINING, $bson ); |
715
|
8
|
|
|
|
|
14
|
chop($ref); # remove trailing \x00 |
716
|
8
|
100
|
|
|
|
21
|
if ( !utf8::decode($ref) ) { |
717
|
1
|
|
|
|
|
106
|
croak( sprintf( $ERR_BAD_UTF8, $key, $type ) ); |
718
|
|
|
|
|
|
|
} |
719
|
|
|
|
|
|
|
|
720
|
7
|
|
|
|
|
15
|
( my ($oid), $bson ) = unpack( BSON_OBJECTID . BSON_REMAINING, $bson ); |
721
|
7
|
|
|
|
|
145
|
$value = BSON::DBRef->new( '$ref' => $ref, '$id' => BSON::OID->new( oid => $oid ) ); |
722
|
|
|
|
|
|
|
} |
723
|
|
|
|
|
|
|
|
724
|
|
|
|
|
|
|
# Code |
725
|
|
|
|
|
|
|
elsif ( $type == 0x0D ) { |
726
|
285
|
|
|
|
|
960
|
( $len, $bson ) = unpack( BSON_INT32 . BSON_REMAINING, $bson ); |
727
|
285
|
50
|
33
|
|
|
1370
|
if ( length($bson) < $len || substr( $bson, $len - 1, 1 ) ne "\x00" ) { |
728
|
0
|
|
|
|
|
0
|
croak( sprintf( $ERR_MISSING_NULL, $key, $type ) ); |
729
|
|
|
|
|
|
|
} |
730
|
285
|
|
|
|
|
1193
|
( $value, $bson ) = unpack( "a$len" . BSON_REMAINING, $bson ); |
731
|
285
|
|
|
|
|
570
|
chop($value); # remove trailing \x00 |
732
|
285
|
50
|
|
|
|
885
|
if ( !utf8::decode($value) ) { |
733
|
0
|
|
|
|
|
0
|
croak( sprintf( $ERR_BAD_UTF8, $key, $type ) ); |
734
|
|
|
|
|
|
|
} |
735
|
285
|
|
|
|
|
4979
|
$value = BSON::Code->new( code => $value ); |
736
|
|
|
|
|
|
|
} |
737
|
|
|
|
|
|
|
|
738
|
|
|
|
|
|
|
# Code with scope |
739
|
|
|
|
|
|
|
elsif ( $type == 0x0F ) { |
740
|
8898
|
|
|
|
|
16507
|
my $len = unpack( BSON_INT32, $bson ); |
741
|
|
|
|
|
|
|
|
742
|
|
|
|
|
|
|
# validate length |
743
|
8898
|
100
|
|
|
|
16967
|
if ( $len < 0 ) { |
744
|
1
|
|
|
|
|
129
|
croak( sprintf( $ERR_NEG_LENGTH, $key, $type ) ); |
745
|
|
|
|
|
|
|
} |
746
|
8897
|
100
|
|
|
|
14204
|
if ( $len > length($bson) ) { |
747
|
2
|
|
|
|
|
216
|
croak( sprintf( $ERR_TRUNCATED, $key, $type ) ); |
748
|
|
|
|
|
|
|
} |
749
|
8895
|
100
|
|
|
|
13672
|
if ( $len < 5 ) { |
750
|
1
|
|
|
|
|
202
|
croak( sprintf( $ERR_LENGTH, $key, $type, 5, $len ) ); |
751
|
|
|
|
|
|
|
} |
752
|
|
|
|
|
|
|
|
753
|
|
|
|
|
|
|
# extract code and scope and chop off leading length |
754
|
8894
|
|
|
|
|
20929
|
my $codewscope = substr( $bson, 0, $len, '' ); |
755
|
8894
|
|
|
|
|
11935
|
substr( $codewscope, 0, 4, '' ); |
756
|
|
|
|
|
|
|
|
757
|
|
|
|
|
|
|
# extract code ( i.e. string ) |
758
|
8894
|
|
|
|
|
15152
|
my $strlen = unpack( BSON_INT32, $codewscope ); |
759
|
8894
|
|
|
|
|
11128
|
substr( $codewscope, 0, 4, '' ); |
760
|
|
|
|
|
|
|
|
761
|
8894
|
100
|
66
|
|
|
24995
|
if ( length($codewscope) < $strlen || substr( $codewscope, -1, 1 ) ne "\x00" ) { |
762
|
1
|
|
|
|
|
108
|
croak( sprintf( $ERR_MISSING_NULL, $key, $type ) ); |
763
|
|
|
|
|
|
|
} |
764
|
|
|
|
|
|
|
|
765
|
8893
|
|
|
|
|
16592
|
my $code = substr($codewscope, 0, $strlen, '' ); |
766
|
8893
|
|
|
|
|
12988
|
chop($code); # remove trailing \x00 |
767
|
8893
|
50
|
|
|
|
18582
|
if ( !utf8::decode($code) ) { |
768
|
0
|
|
|
|
|
0
|
croak( sprintf( $ERR_BAD_UTF8, $key, $type ) ); |
769
|
|
|
|
|
|
|
} |
770
|
|
|
|
|
|
|
|
771
|
8893
|
100
|
|
|
|
15221
|
if ( length($codewscope) < 5 ) { |
772
|
2
|
|
|
|
|
211
|
croak( sprintf( $ERR_TRUNCATED, $key, $type ) ); |
773
|
|
|
|
|
|
|
} |
774
|
|
|
|
|
|
|
|
775
|
|
|
|
|
|
|
# extract scope |
776
|
8891
|
|
|
|
|
14377
|
my $scopelen = unpack( BSON_INT32, $codewscope ); |
777
|
8891
|
100
|
66
|
|
|
25604
|
if ( length($codewscope) < $scopelen || substr( $codewscope, $scopelen - 1, 1 ) ne "\x00" ) { |
778
|
3
|
|
|
|
|
349
|
croak( sprintf( $ERR_MISSING_NULL, $key, $type ) ); |
779
|
|
|
|
|
|
|
} |
780
|
|
|
|
|
|
|
|
781
|
8888
|
|
|
|
|
41998
|
my $scope = _decode_bson( $codewscope, { %$opt, _decode_array => 0} ); |
782
|
|
|
|
|
|
|
|
783
|
8887
|
|
|
|
|
174366
|
$value = BSON::Code->new( code => $code, scope => $scope ); |
784
|
|
|
|
|
|
|
} |
785
|
|
|
|
|
|
|
|
786
|
|
|
|
|
|
|
# Int32 |
787
|
|
|
|
|
|
|
elsif ( $type == 0x10 ) { |
788
|
9057
|
|
|
|
|
25181
|
( $value, $bson ) = unpack( BSON_INT32.BSON_REMAINING, $bson ); |
789
|
9057
|
100
|
|
|
|
17468
|
$value = BSON::Int32->new( value => $value ) if $opt->{wrap_numbers}; |
790
|
|
|
|
|
|
|
} |
791
|
|
|
|
|
|
|
|
792
|
|
|
|
|
|
|
# Timestamp |
793
|
|
|
|
|
|
|
elsif ( $type == 0x11 ) { |
794
|
9085
|
|
|
|
|
30054
|
( my $sec, my $inc, $bson ) = unpack( BSON_UINT32.BSON_UINT32.BSON_REMAINING, $bson ); |
795
|
9085
|
|
|
|
|
154202
|
$value = BSON::Timestamp->new( $inc, $sec ); |
796
|
|
|
|
|
|
|
} |
797
|
|
|
|
|
|
|
|
798
|
|
|
|
|
|
|
# Int64 |
799
|
|
|
|
|
|
|
elsif ( $type == 0x12 ) { |
800
|
9165
|
|
|
|
|
9472
|
if ( HAS_INT64 ) { |
801
|
9165
|
|
|
|
|
23396
|
($value, $bson) = unpack(BSON_INT64.BSON_REMAINING,$bson); |
802
|
|
|
|
|
|
|
} |
803
|
|
|
|
|
|
|
else { |
804
|
|
|
|
|
|
|
($value, $bson) = unpack(BSON_8BYTES.BSON_REMAINING,$bson); |
805
|
|
|
|
|
|
|
$value = _int64_to_bigint($value); |
806
|
|
|
|
|
|
|
} |
807
|
9165
|
100
|
|
|
|
29949
|
$value = BSON::Int64->new( value => $value ) if $opt->{wrap_numbers}; |
808
|
|
|
|
|
|
|
} |
809
|
|
|
|
|
|
|
|
810
|
|
|
|
|
|
|
# Decimal128 |
811
|
|
|
|
|
|
|
elsif ( $type == 0x13 ) { |
812
|
1206
|
|
|
|
|
3378
|
( my $bytes, $bson ) = unpack( BSON_16BYTES.BSON_REMAINING, $bson ); |
813
|
1206
|
|
|
|
|
26837
|
$value = BSON::Decimal128->new( bytes => $bytes ); |
814
|
|
|
|
|
|
|
} |
815
|
|
|
|
|
|
|
|
816
|
|
|
|
|
|
|
# MinKey |
817
|
|
|
|
|
|
|
elsif ( $type == 0xFF ) { |
818
|
9085
|
|
|
|
|
25222
|
$value = BSON::MinKey->new; |
819
|
|
|
|
|
|
|
} |
820
|
|
|
|
|
|
|
|
821
|
|
|
|
|
|
|
# MaxKey |
822
|
|
|
|
|
|
|
elsif ( $type == 0x7F ) { |
823
|
9144
|
|
|
|
|
22762
|
$value = BSON::MaxKey->new; |
824
|
|
|
|
|
|
|
} |
825
|
|
|
|
|
|
|
|
826
|
|
|
|
|
|
|
# ??? |
827
|
|
|
|
|
|
|
else { |
828
|
|
|
|
|
|
|
# Should have already been caught in the minimum length check, |
829
|
|
|
|
|
|
|
# but just in case not: |
830
|
0
|
|
|
|
|
0
|
croak( sprintf( $ERR_UNSUPPORTED, $type, $key ) ); |
831
|
|
|
|
|
|
|
} |
832
|
|
|
|
|
|
|
|
833
|
147534
|
100
|
|
|
|
269172
|
if ( $opt->{_decode_array} ) { |
834
|
28031
|
|
|
|
|
57196
|
push @array, $value; |
835
|
|
|
|
|
|
|
} |
836
|
|
|
|
|
|
|
else { |
837
|
119503
|
|
|
|
|
272814
|
$hash{$key} = $value; |
838
|
|
|
|
|
|
|
} |
839
|
|
|
|
|
|
|
} |
840
|
29410
|
|
|
|
|
52815
|
$opt->{_depth}--; |
841
|
29410
|
100
|
|
|
|
72676
|
return $opt->{_decode_array} ? \@array : \%hash; |
842
|
|
|
|
|
|
|
} |
843
|
|
|
|
|
|
|
|
844
|
|
|
|
|
|
|
1; |
845
|
|
|
|
|
|
|
|
846
|
|
|
|
|
|
|
=pod |
847
|
|
|
|
|
|
|
|
848
|
|
|
|
|
|
|
=encoding UTF-8 |
849
|
|
|
|
|
|
|
|
850
|
|
|
|
|
|
|
=head1 NAME |
851
|
|
|
|
|
|
|
|
852
|
|
|
|
|
|
|
BSON::PP - Pure Perl BSON implementation |
853
|
|
|
|
|
|
|
|
854
|
|
|
|
|
|
|
=head1 VERSION |
855
|
|
|
|
|
|
|
|
856
|
|
|
|
|
|
|
version v1.12.2 |
857
|
|
|
|
|
|
|
|
858
|
|
|
|
|
|
|
=head1 DESCRIPTION |
859
|
|
|
|
|
|
|
|
860
|
|
|
|
|
|
|
This module contains the pure-Perl implementation for BSON encoding and |
861
|
|
|
|
|
|
|
decoding. There is no public API. Use the L module and it will |
862
|
|
|
|
|
|
|
choose the best implementation for you. |
863
|
|
|
|
|
|
|
|
864
|
|
|
|
|
|
|
=head1 AUTHORS |
865
|
|
|
|
|
|
|
|
866
|
|
|
|
|
|
|
=over 4 |
867
|
|
|
|
|
|
|
|
868
|
|
|
|
|
|
|
=item * |
869
|
|
|
|
|
|
|
|
870
|
|
|
|
|
|
|
David Golden |
871
|
|
|
|
|
|
|
|
872
|
|
|
|
|
|
|
=item * |
873
|
|
|
|
|
|
|
|
874
|
|
|
|
|
|
|
Stefan G. |
875
|
|
|
|
|
|
|
|
876
|
|
|
|
|
|
|
=back |
877
|
|
|
|
|
|
|
|
878
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
879
|
|
|
|
|
|
|
|
880
|
|
|
|
|
|
|
This software is Copyright (c) 2020 by Stefan G. and MongoDB, Inc. |
881
|
|
|
|
|
|
|
|
882
|
|
|
|
|
|
|
This is free software, licensed under: |
883
|
|
|
|
|
|
|
|
884
|
|
|
|
|
|
|
The Apache License, Version 2.0, January 2004 |
885
|
|
|
|
|
|
|
|
886
|
|
|
|
|
|
|
=cut |
887
|
|
|
|
|
|
|
|
888
|
|
|
|
|
|
|
__END__ |