line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package BSON::Decode; |
2
|
|
|
|
|
|
|
|
3
|
2
|
|
|
2
|
|
32247
|
use 5.006; |
|
2
|
|
|
|
|
4
|
|
4
|
2
|
|
|
2
|
|
7
|
use strict; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
32
|
|
5
|
2
|
|
|
2
|
|
6
|
use warnings; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
43
|
|
6
|
2
|
|
|
2
|
|
5
|
use Carp qw(carp croak); |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
2570
|
|
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
=head1 NAME |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
BSON::Decode - Decode BSON file and return a perl data structure! |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
=head1 VERSION |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
Version 0.04 |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
=cut |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
our $VERSION = '0.04'; |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
=head1 SYNOPSIS |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
A small module to parse BSON file to a perl structure |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
my $file = shift; |
25
|
|
|
|
|
|
|
open( my $INF ,$file); |
26
|
|
|
|
|
|
|
my $bs = BSON::Decode->new($INF); |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
say Dumper $bs->fetch(); # read first element |
29
|
|
|
|
|
|
|
say Dumper $bs->fetch(); # read second element |
30
|
|
|
|
|
|
|
$bs->rewind();# rewind the filehandle |
31
|
|
|
|
|
|
|
say Dumper $bs->fetch_all(); # read all element in an ARRAY |
32
|
|
|
|
|
|
|
close $INF; |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
=cut |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
=head1 DESCRIPTION |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
This is a pure perl BSON decoder. It is simple and without any dependencies. |
41
|
|
|
|
|
|
|
(It was mandatory to allow use in an embeded system) |
42
|
|
|
|
|
|
|
The main use is to compare 2 BSON files |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
Some of the BSON grammar's element are not implemented |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
\x06 Undefined (value) Deprecated |
47
|
|
|
|
|
|
|
\x0C DBPointer Deprecated |
48
|
|
|
|
|
|
|
\x0E Deprecated |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
For binary content (\x05) |
51
|
|
|
|
|
|
|
The data is uuencoded as value of the subtype. |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
=cut |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
=head1 METHOD |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
=head2 new |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
Instanciate the parser. |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
By default the parser read from STDIN (unix filter). |
62
|
|
|
|
|
|
|
In that case no rewind is possible. Only sequential read. |
63
|
|
|
|
|
|
|
my $bs = BSON::Decode->new(); |
64
|
|
|
|
|
|
|
It is possible to pass an argument to the constructor to chose another source. |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
=head3 filehandle |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
an open filehandle from where to read the BSON data: |
69
|
|
|
|
|
|
|
open( my $INF ,$file); |
70
|
|
|
|
|
|
|
my $bs = BSON::Decode->new($INF); |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
=cut |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
=head3 file name |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
this a path to an existing BSON file: |
77
|
|
|
|
|
|
|
my $bs = BSON::Decode->new($file); |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
=cut |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
=head3 scalar |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
a perl scalar with the BSON data: |
84
|
|
|
|
|
|
|
my $bs = BSON::Decode->new($bson); |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
=cut |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
sub new |
89
|
|
|
|
|
|
|
{ |
90
|
1
|
|
|
1
|
1
|
62804
|
my $class = shift; |
91
|
|
|
|
|
|
|
|
92
|
1
|
|
|
|
|
1
|
my $self = {}; |
93
|
1
|
|
|
|
|
2
|
bless( $self, $class ); |
94
|
1
|
|
50
|
|
|
10
|
$self->{fh} = shift // ''; |
95
|
1
|
|
|
|
|
2
|
my $valid = 0; |
96
|
|
|
|
|
|
|
{ |
97
|
1
|
|
|
|
|
1
|
local $@ = ""; |
|
1
|
|
|
|
|
2
|
|
98
|
1
|
|
|
|
|
1
|
my $fd = eval {fileno $self->{fh}}; |
|
1
|
|
|
|
|
6
|
|
99
|
1
|
|
33
|
|
|
7
|
$valid = !$@ && defined $fd; |
100
|
|
|
|
|
|
|
} |
101
|
1
|
50
|
|
|
|
4
|
if ( !$valid ) |
102
|
|
|
|
|
|
|
{ |
103
|
1
|
50
|
|
|
|
28
|
if ( -f $self->{fh} ) |
|
|
50
|
|
|
|
|
|
104
|
|
|
|
|
|
|
{ |
105
|
0
|
|
|
|
|
0
|
my $f_name = delete $self->{fh}; |
106
|
0
|
|
|
|
|
0
|
open $self->{fh}, '<', $f_name; |
107
|
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
|
elsif ( length $self->{fh} ) |
109
|
|
|
|
|
|
|
{ |
110
|
1
|
|
|
|
|
4
|
$self->{buffer} = $self->{buffer_bck} = delete $self->{fh}; |
111
|
|
|
|
|
|
|
} |
112
|
|
|
|
|
|
|
else |
113
|
|
|
|
|
|
|
{ |
114
|
0
|
|
|
|
|
0
|
$self->{fh} = *STDIN; |
115
|
0
|
|
|
|
|
0
|
$self->{stdin} = 1; |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
} |
118
|
1
|
50
|
|
|
|
9
|
binmode( $self->{fh} ) if exists $self->{fh}; |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
$self->{func} = { |
121
|
|
|
|
|
|
|
1 => sub { ## 64-bit float |
122
|
3
|
|
|
3
|
|
4
|
my ( $bson, $name ) = @_; |
123
|
3
|
|
|
|
|
5
|
my $data = substr( $$bson, 0, 8, '' ); |
124
|
3
|
|
|
|
|
17
|
return unpack( "d", $data ); |
125
|
|
|
|
|
|
|
}, |
126
|
|
|
|
|
|
|
2 => sub { ## UTF-8 string |
127
|
10
|
|
|
10
|
|
15
|
my ( $bson, $name ) = @_; |
128
|
10
|
|
|
|
|
30
|
my $size = unpack( "i", substr( $$bson, 0, 4, '' ) ); |
129
|
10
|
|
|
|
|
23
|
my $data = substr( $$bson, 0, $size - 1, '' ); |
130
|
|
|
|
|
|
|
|
131
|
10
|
|
|
|
|
48
|
return unpack( "a*", $data ); |
132
|
|
|
|
|
|
|
}, |
133
|
|
|
|
|
|
|
3 => sub { ## Embedded document |
134
|
0
|
|
|
0
|
|
0
|
my ( $bson, $name ) = @_; |
135
|
0
|
|
|
|
|
0
|
my $size = unpack( "i", substr( $$bson, 0, 4, '' ) ); |
136
|
0
|
|
|
|
|
0
|
return $self->document( $bson, $size - 4 ); |
137
|
|
|
|
|
|
|
}, |
138
|
|
|
|
|
|
|
4 => sub { ## Array |
139
|
0
|
|
|
0
|
|
0
|
my ( $bson, $name ) = @_; |
140
|
0
|
|
|
|
|
0
|
my $size = unpack( "i", substr( $$bson, 0, 4, '' ) ); |
141
|
0
|
|
|
|
|
0
|
my $r = $self->document( $bson, $size - 4 ); |
142
|
0
|
|
|
|
|
0
|
my @t; |
143
|
0
|
|
|
|
|
0
|
foreach my $k ( sort keys %$r ) |
144
|
|
|
|
|
|
|
{ |
145
|
0
|
0
|
|
|
|
0
|
push @t, $r->{$k} if $k =~ /^\d+$/; |
146
|
|
|
|
|
|
|
} |
147
|
0
|
|
|
|
|
0
|
return \@t; |
148
|
|
|
|
|
|
|
}, |
149
|
|
|
|
|
|
|
5 => sub { ## Binary data |
150
|
0
|
|
|
0
|
|
0
|
my ( $bson, $name ) = @_; |
151
|
0
|
|
|
|
|
0
|
my $size = unpack( "i", substr( $$bson, 0, 4, '' ) ); |
152
|
0
|
|
|
|
|
0
|
my $subtype = substr( $$bson, 0, 1, '' ); |
153
|
0
|
|
|
|
|
0
|
my $binary = pack( 'u', substr( $$bson, 0, $size, '' ) ); |
154
|
0
|
|
|
|
|
0
|
return ( $subtype => $binary ); |
155
|
|
|
|
|
|
|
}, |
156
|
|
|
|
|
|
|
7 => sub { ## ObjectId |
157
|
5
|
|
|
5
|
|
10
|
my ( $bson, $name ) = @_; |
158
|
5
|
|
|
|
|
11
|
my $data = substr( $$bson, 0, 12, '' ); |
159
|
5
|
|
|
|
|
18
|
return unpack( "H*", $data ); |
160
|
|
|
|
|
|
|
}, |
161
|
|
|
|
|
|
|
8 => sub { ## Boolean |
162
|
2
|
|
|
2
|
|
3
|
my ( $bson, $name ) = @_; |
163
|
2
|
|
|
|
|
7
|
my $data = substr( $$bson, 0, 1, '' ); |
164
|
2
|
|
|
|
|
11
|
return oct( "0x" . unpack( "H*", $data ) ); |
165
|
|
|
|
|
|
|
}, |
166
|
|
|
|
|
|
|
9 => sub { ## UTC datetime |
167
|
3
|
|
|
3
|
|
4
|
my ( $bson, $name ) = @_; |
168
|
3
|
|
|
|
|
5
|
my $data = substr( $$bson, 0, 8, '' ); |
169
|
3
|
|
|
|
|
13
|
return unpack( "q", $data ); |
170
|
|
|
|
|
|
|
}, |
171
|
|
|
|
|
|
|
10 => sub { ## Null value |
172
|
0
|
|
|
0
|
|
0
|
my ( $bson, $name ) = @_; |
173
|
0
|
|
|
|
|
0
|
return 'null'; |
174
|
|
|
|
|
|
|
}, |
175
|
|
|
|
|
|
|
11 => sub { ## REGEX |
176
|
2
|
|
|
2
|
|
2
|
my ( $bson, $name ) = @_; |
177
|
2
|
|
|
|
|
5
|
my $regex = unpack( "Z*", $$bson ); |
178
|
2
|
|
|
|
|
4
|
substr $$bson, 0, length( $regex ) + 1, ''; |
179
|
2
|
|
|
|
|
5
|
my $regex_options = unpack( "Z*", $$bson ); |
180
|
2
|
|
|
|
|
4
|
substr $$bson, 0, length( $regex_options ) + 1, ''; |
181
|
2
|
|
|
|
|
9
|
return '/' . $regex . '/' . $regex_options; |
182
|
|
|
|
|
|
|
}, |
183
|
|
|
|
|
|
|
13 => sub { ## javascript code |
184
|
0
|
|
|
0
|
|
0
|
my ( $bson, $name ) = @_; |
185
|
0
|
|
|
|
|
0
|
my $size = unpack( "i", substr( $$bson, 0, 4, '' ) ); |
186
|
0
|
|
|
|
|
0
|
my $data = substr( $$bson, 0, $size - 1, '' ); |
187
|
0
|
|
|
|
|
0
|
return unpack( "a*", $data ); |
188
|
|
|
|
|
|
|
}, |
189
|
|
|
|
|
|
|
16 => sub { ## 32-bit integer |
190
|
0
|
|
|
0
|
|
0
|
my ( $bson, $name ) = @_; |
191
|
0
|
|
|
|
|
0
|
my $data = substr( $$bson, 0, 4, '' ); |
192
|
0
|
|
|
|
|
0
|
return unpack( "i", $data ); |
193
|
|
|
|
|
|
|
}, |
194
|
|
|
|
|
|
|
17 => sub { ## timestamp |
195
|
2
|
|
|
2
|
|
4
|
my ( $bson, $name ) = @_; |
196
|
2
|
|
|
|
|
5
|
my $data = substr( $$bson, 0, 8, '' ); |
197
|
2
|
|
|
|
|
10
|
return unpack( "Q", $data ); |
198
|
|
|
|
|
|
|
}, |
199
|
|
|
|
|
|
|
18 => sub { ## 64-bit integer |
200
|
0
|
|
|
0
|
|
0
|
my ( $bson, $name ) = @_; |
201
|
0
|
|
|
|
|
0
|
my $data = substr( $$bson, 0, 8, '' ); |
202
|
0
|
|
|
|
|
0
|
return unpack( "Q", $data ); |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
}, |
205
|
|
|
|
|
|
|
19 => sub { ## 128-bit integer |
206
|
0
|
|
|
0
|
|
0
|
my ( $bson, $name ) = @_; |
207
|
0
|
|
|
|
|
0
|
my $data = substr( $$bson, 0, 16, '' ); |
208
|
0
|
|
|
|
|
0
|
return unpack( "Q", $data ); |
209
|
|
|
|
|
|
|
}, |
210
|
|
|
|
|
|
|
127 => sub { ## MAX key |
211
|
0
|
|
|
0
|
|
0
|
my ( $bson, $name ) = @_; |
212
|
0
|
|
|
|
|
0
|
return 'maxkey'; |
213
|
|
|
|
|
|
|
}, |
214
|
|
|
|
|
|
|
255 => sub { ## MIN key |
215
|
0
|
|
|
0
|
|
0
|
my ( $bson, $name ) = @_; |
216
|
0
|
|
|
|
|
0
|
return 'minkey'; |
217
|
|
|
|
|
|
|
} |
218
|
1
|
|
|
|
|
38
|
}; |
219
|
1
|
|
|
|
|
3
|
return $self; |
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
=head2 fetch_all |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
Parse the BSON data and return an ARRAY with each element in a perl structure. |
225
|
|
|
|
|
|
|
The parsing is done from the current position. |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
=cut |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
sub fetch_all |
230
|
|
|
|
|
|
|
{ |
231
|
1
|
|
|
1
|
1
|
3
|
my ( $self ) = @_; |
232
|
1
|
|
|
|
|
2
|
my @all; |
233
|
1
|
50
|
|
|
|
2
|
if ( $self->{fh} ) |
234
|
|
|
|
|
|
|
{ |
235
|
0
|
|
|
|
|
0
|
push @all, $self->fetch() while ( !eof $self->{fh} ); |
236
|
|
|
|
|
|
|
} |
237
|
|
|
|
|
|
|
else |
238
|
|
|
|
|
|
|
{ |
239
|
1
|
|
|
|
|
6
|
push @all, $self->fetch() while ( $self->{buffer} ); |
240
|
|
|
|
|
|
|
} |
241
|
1
|
|
|
|
|
13
|
return \@all; |
242
|
|
|
|
|
|
|
} |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
=head2 fetch |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
Parse the BSON data and return the next element in a perl structure. |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
=cut |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
sub fetch |
251
|
|
|
|
|
|
|
{ |
252
|
5
|
|
|
5
|
1
|
505
|
my ( $self ) = @_; |
253
|
5
|
|
|
|
|
2
|
my $res; |
254
|
|
|
|
|
|
|
my $sizebits; |
255
|
0
|
|
|
|
|
0
|
my $bson; |
256
|
0
|
|
|
|
|
0
|
my $size; |
257
|
5
|
50
|
|
|
|
9
|
if ( $self->{fh} ) |
258
|
|
|
|
|
|
|
{ |
259
|
0
|
|
|
|
|
0
|
my $n = read( $self->{fh}, $sizebits, 4 ); |
260
|
0
|
0
|
|
|
|
0
|
carp "error reading size\n" if ( $n != 4 ); |
261
|
|
|
|
|
|
|
|
262
|
0
|
|
|
|
|
0
|
$size = unpack( "i", $sizebits ); |
263
|
0
|
|
|
|
|
0
|
$size -= 4; # -4 because the size includes itself |
264
|
0
|
|
|
|
|
0
|
$n = read( $self->{fh}, $bson, $size ); |
265
|
0
|
0
|
|
|
|
0
|
carp "error reading bson string\n" if ( $n != $size ); |
266
|
|
|
|
|
|
|
} |
267
|
|
|
|
|
|
|
else |
268
|
|
|
|
|
|
|
{ |
269
|
|
|
|
|
|
|
|
270
|
5
|
|
|
|
|
14
|
$sizebits = substr( $self->{buffer}, 0, 4, '' ); |
271
|
5
|
|
|
|
|
12
|
$size = unpack( "i", $sizebits ); |
272
|
5
|
|
|
|
|
9
|
$size -= 4; |
273
|
5
|
|
|
|
|
11
|
$bson = substr( $self->{buffer}, 0, $size, '' ); |
274
|
|
|
|
|
|
|
} |
275
|
5
|
50
|
|
|
|
12
|
if ( length $bson ) |
276
|
|
|
|
|
|
|
{ |
277
|
5
|
|
|
|
|
9
|
my $sep = substr( $bson, -1, 1 ); |
278
|
5
|
50
|
|
|
|
11
|
croak( "Bad record seperator '".unpack( "H*",$sep)."'" ) if ( $sep ne "\x00" ); |
279
|
|
|
|
|
|
|
} |
280
|
5
|
|
|
|
|
12
|
$res = $self->document( \$bson, $size ); |
281
|
5
|
|
|
|
|
12
|
return $res; |
282
|
|
|
|
|
|
|
} |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
=head2 rewind |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
Rewind the file descriptor ( or buffer ). |
287
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
=cut |
289
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
sub rewind |
291
|
|
|
|
|
|
|
{ |
292
|
2
|
|
|
2
|
1
|
784
|
my ( $self ) = @_; |
293
|
2
|
50
|
|
|
|
4
|
if ( $self->{stdin} ) |
294
|
|
|
|
|
|
|
{ |
295
|
0
|
|
|
|
|
0
|
carp( "No rewind for STDIN" ); |
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
else |
298
|
|
|
|
|
|
|
{ |
299
|
2
|
50
|
|
|
|
4
|
if ( exists $self->{fh} ) |
300
|
|
|
|
|
|
|
{ |
301
|
0
|
|
|
|
|
0
|
seek( $self->{fh}, 0, 0 ); |
302
|
|
|
|
|
|
|
} |
303
|
|
|
|
|
|
|
else |
304
|
|
|
|
|
|
|
{ |
305
|
2
|
|
|
|
|
4
|
$self->{buffer} = $self->{buffer_bck}; |
306
|
|
|
|
|
|
|
} |
307
|
|
|
|
|
|
|
} |
308
|
2
|
|
|
|
|
3
|
return; |
309
|
|
|
|
|
|
|
} |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
sub document |
312
|
|
|
|
|
|
|
{ |
313
|
5
|
|
|
5
|
0
|
8
|
my ( $self, $str, $size ) = @_; |
314
|
5
|
|
|
|
|
5
|
my $res = {}; |
315
|
5
|
|
|
|
|
15
|
my $bson = substr( $$str, 0, $size, '' ); |
316
|
5
|
50
|
|
|
|
12
|
if ( length( $bson ) != $size ) |
317
|
|
|
|
|
|
|
{ |
318
|
0
|
|
|
|
|
0
|
die "error reading bson string " . length( $bson ) . " != $size\n"; |
319
|
|
|
|
|
|
|
} |
320
|
5
|
|
|
|
|
7
|
my $sep = substr( $bson, -1, 1 ); |
321
|
5
|
50
|
|
|
|
9
|
if ( $sep ne "\x00" ) |
322
|
|
|
|
|
|
|
{ |
323
|
0
|
|
|
|
|
0
|
die( "Bad record seperator '$sep'" ); |
324
|
|
|
|
|
|
|
} |
325
|
5
|
|
|
|
|
14
|
while ( length( $bson ) ) |
326
|
|
|
|
|
|
|
{ |
327
|
42
|
|
|
|
|
94
|
my $element = oct( "0x" . unpack( "H*", substr( $bson, 0, 1, '' ) ) ); |
328
|
42
|
|
|
|
|
35
|
my $name; |
329
|
42
|
100
|
|
|
|
85
|
next if ( $element == 0 ); |
330
|
27
|
|
|
|
|
43
|
$name = unpack( "Z*", $bson ); |
331
|
27
|
|
|
|
|
38
|
substr $bson, 0, length( $name ) + 1, ''; |
332
|
27
|
50
|
|
|
|
43
|
if ( exists $self->{func}{$element} ) |
333
|
|
|
|
|
|
|
{ |
334
|
27
|
|
|
|
|
38
|
$res->{$name} = $self->{func}{$element}->( \$bson, $name ); |
335
|
|
|
|
|
|
|
} |
336
|
|
|
|
|
|
|
else |
337
|
|
|
|
|
|
|
{ |
338
|
0
|
|
|
|
|
0
|
warn "Type $element not implemented for $name"; |
339
|
0
|
|
|
|
|
0
|
last; |
340
|
|
|
|
|
|
|
} |
341
|
|
|
|
|
|
|
} |
342
|
5
|
|
|
|
|
10
|
return $res; |
343
|
|
|
|
|
|
|
} |
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
sub delete_hash_deep |
347
|
|
|
|
|
|
|
{ |
348
|
0
|
|
|
0
|
0
|
|
my ( $hash, $allowed_keys ) = @_; |
349
|
|
|
|
|
|
|
|
350
|
0
|
0
|
0
|
|
|
|
if ( ref( $hash ) && ref( $hash ) eq "ARRAY" ) |
351
|
|
|
|
|
|
|
{ |
352
|
0
|
|
|
|
|
|
foreach my $h ( @$hash ) |
353
|
|
|
|
|
|
|
{ |
354
|
0
|
|
|
|
|
|
delete_hash_deep( $h, $allowed_keys ); |
355
|
|
|
|
|
|
|
} |
356
|
|
|
|
|
|
|
} |
357
|
|
|
|
|
|
|
else |
358
|
|
|
|
|
|
|
{ |
359
|
0
|
0
|
|
|
|
|
if ( ref( $hash ) eq 'HASH' ) |
360
|
|
|
|
|
|
|
{ |
361
|
0
|
|
|
|
|
|
foreach my $k ( keys %{$hash} ) |
|
0
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
{ |
363
|
0
|
0
|
|
|
|
|
if ( ( grep {$k =~ /$_/} @{$allowed_keys} ) ) |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
{ |
365
|
0
|
|
|
|
|
|
delete $hash->{$k}; |
366
|
0
|
|
|
|
|
|
next; |
367
|
|
|
|
|
|
|
} |
368
|
|
|
|
|
|
|
else |
369
|
|
|
|
|
|
|
{ |
370
|
0
|
0
|
|
|
|
|
if ( ref( $hash->{$k} ) ) |
371
|
|
|
|
|
|
|
{ |
372
|
0
|
0
|
0
|
|
|
|
if ( ref( $hash->{$k} ) eq "HASH" || ref( $hash->{$k} ) eq "ARRAY" ) |
373
|
|
|
|
|
|
|
{ |
374
|
0
|
|
|
|
|
|
delete_hash_deep( $hash->{$k}, $allowed_keys ); |
375
|
|
|
|
|
|
|
} |
376
|
|
|
|
|
|
|
} |
377
|
|
|
|
|
|
|
} |
378
|
|
|
|
|
|
|
} |
379
|
|
|
|
|
|
|
} |
380
|
|
|
|
|
|
|
} |
381
|
|
|
|
|
|
|
} |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
=head1 AUTHOR |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
DULAUNOY Fabrice, C<< >> |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
=head1 BUGS |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
Please report any bugs or feature requests to C, or through |
391
|
|
|
|
|
|
|
the web interface at L. I will be notified, and then you'll |
392
|
|
|
|
|
|
|
automatically be notified of progress on your bug as I make changes. |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
=head1 SUPPORT |
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
You can find documentation for this module with the perldoc command. |
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
perldoc BSON::Decode |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
|
404
|
|
|
|
|
|
|
You can also look for information at: |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
=over 4 |
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
=item * RT: CPAN's request tracker (report bugs here) |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
L |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
=item * AnnoCPAN: Annotated CPAN documentation |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
L |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
=item * CPAN Ratings |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
L |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
=item * Search CPAN |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
L |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
=back |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
|
427
|
|
|
|
|
|
|
=head1 ACKNOWLEDGEMENTS |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
=head1 LICENSE AND COPYRIGHT |
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
Copyright 2016 DULAUNOY Fabrice. |
433
|
|
|
|
|
|
|
|
434
|
|
|
|
|
|
|
This program is free software; you can redistribute it and/or modify it |
435
|
|
|
|
|
|
|
under the terms of the the Artistic License (2.0). You may obtain a |
436
|
|
|
|
|
|
|
copy of the full license at: |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
L |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
Any use, modification, and distribution of the Standard or Modified |
441
|
|
|
|
|
|
|
Versions is governed by this Artistic License. By using, modifying or |
442
|
|
|
|
|
|
|
distributing the Package, you accept this license. Do not use, modify, |
443
|
|
|
|
|
|
|
or distribute the Package, if you do not accept this license. |
444
|
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
If your Modified Version has been derived from a Modified Version made |
446
|
|
|
|
|
|
|
by someone other than you, you are nevertheless required to ensure that |
447
|
|
|
|
|
|
|
your Modified Version complies with the requirements of this license. |
448
|
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
This license does not grant you the right to use any trademark, service |
450
|
|
|
|
|
|
|
mark, tradename, or logo of the Copyright Holder. |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
This license includes the non-exclusive, worldwide, free-of-charge |
453
|
|
|
|
|
|
|
patent license to make, have made, use, offer to sell, sell, import and |
454
|
|
|
|
|
|
|
otherwise transfer the Package with respect to any patent claims |
455
|
|
|
|
|
|
|
licensable by the Copyright Holder that are necessarily infringed by the |
456
|
|
|
|
|
|
|
Package. If you institute patent litigation (including a cross-claim or |
457
|
|
|
|
|
|
|
counterclaim) against any party alleging that the Package constitutes |
458
|
|
|
|
|
|
|
direct or contributory patent infringement, then this Artistic License |
459
|
|
|
|
|
|
|
to you shall terminate on the date that such litigation is filed. |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER |
462
|
|
|
|
|
|
|
AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. |
463
|
|
|
|
|
|
|
THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR |
464
|
|
|
|
|
|
|
PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY |
465
|
|
|
|
|
|
|
YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR |
466
|
|
|
|
|
|
|
CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR |
467
|
|
|
|
|
|
|
CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, |
468
|
|
|
|
|
|
|
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
=cut |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
1; # End of BSON::Decode |