| line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
|
1
|
|
|
|
|
|
|
package RPC::ExtDirect::Serializer; |
|
2
|
|
|
|
|
|
|
|
|
3
|
28
|
|
|
28
|
|
519
|
use strict; |
|
|
28
|
|
|
|
|
30
|
|
|
|
28
|
|
|
|
|
623
|
|
|
4
|
28
|
|
|
28
|
|
100
|
use warnings; |
|
|
28
|
|
|
|
|
27
|
|
|
|
28
|
|
|
|
|
566
|
|
|
5
|
28
|
|
|
28
|
|
80
|
no warnings 'uninitialized'; ## no critic |
|
|
28
|
|
|
|
|
24
|
|
|
|
28
|
|
|
|
|
605
|
|
|
6
|
|
|
|
|
|
|
|
|
7
|
28
|
|
|
28
|
|
81
|
use Carp; |
|
|
28
|
|
|
|
|
27
|
|
|
|
28
|
|
|
|
|
1276
|
|
|
8
|
28
|
|
|
28
|
|
91
|
use JSON (); |
|
|
28
|
|
|
|
|
33
|
|
|
|
28
|
|
|
|
|
372
|
|
|
9
|
|
|
|
|
|
|
|
|
10
|
28
|
|
|
28
|
|
92
|
use RPC::ExtDirect::Config; |
|
|
28
|
|
|
|
|
25
|
|
|
|
28
|
|
|
|
|
433
|
|
|
11
|
|
|
|
|
|
|
|
|
12
|
28
|
|
|
28
|
|
89
|
use RPC::ExtDirect::Util::Accessor; |
|
|
28
|
|
|
|
|
34
|
|
|
|
28
|
|
|
|
|
645
|
|
|
13
|
28
|
|
|
|
|
20140
|
use RPC::ExtDirect::Util qw/ |
|
14
|
|
|
|
|
|
|
clean_error_message get_caller_info parse_global_flags |
|
15
|
28
|
|
|
28
|
|
84
|
/; |
|
|
28
|
|
|
|
|
26
|
|
|
16
|
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
### PUBLIC CLASS METHOD (CONSTRUCTOR) ### |
|
18
|
|
|
|
|
|
|
# |
|
19
|
|
|
|
|
|
|
# Instantiate a new Serializer |
|
20
|
|
|
|
|
|
|
# |
|
21
|
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
sub new { |
|
23
|
94
|
|
|
94
|
0
|
610
|
my ($class, %arg) = @_; |
|
24
|
|
|
|
|
|
|
|
|
25
|
94
|
|
|
|
|
235
|
my $self = bless { %arg }, $class; |
|
26
|
|
|
|
|
|
|
|
|
27
|
94
|
|
|
|
|
209
|
return $self; |
|
28
|
|
|
|
|
|
|
} |
|
29
|
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
### PUBLIC INSTANCE METHOD ### |
|
31
|
|
|
|
|
|
|
# |
|
32
|
|
|
|
|
|
|
# Serialize the data passed to it in JSON |
|
33
|
|
|
|
|
|
|
# |
|
34
|
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
sub serialize { |
|
36
|
57
|
|
|
57
|
0
|
127
|
my ($self, %arg) = @_; |
|
37
|
|
|
|
|
|
|
|
|
38
|
57
|
|
50
|
|
|
145
|
my $data = delete $arg{data} || []; |
|
39
|
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
# Try to serialize each response separately; |
|
41
|
|
|
|
|
|
|
# if one fails it's better to return an exception |
|
42
|
|
|
|
|
|
|
# for one response than fail all of them |
|
43
|
57
|
|
|
|
|
83
|
my @serialized = map { $self->_encode_response($_, %arg) } |
|
|
59
|
|
|
|
|
136
|
|
|
44
|
|
|
|
|
|
|
@$data; |
|
45
|
|
|
|
|
|
|
|
|
46
|
57
|
100
|
|
|
|
119
|
my $text = @serialized == 1 ? shift @serialized |
|
47
|
|
|
|
|
|
|
: '[' . join(',', @serialized) . ']' |
|
48
|
|
|
|
|
|
|
; |
|
49
|
|
|
|
|
|
|
|
|
50
|
57
|
|
|
|
|
144
|
return $text; |
|
51
|
|
|
|
|
|
|
} |
|
52
|
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
### PUBLIC INSTANCE METHOD ### |
|
54
|
|
|
|
|
|
|
# |
|
55
|
|
|
|
|
|
|
# Turns JSONified POST request(s) into array of instantiated |
|
56
|
|
|
|
|
|
|
# RPC::ExtDirect::Request (Exception) objects. Returns arrayref. |
|
57
|
|
|
|
|
|
|
# |
|
58
|
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
sub decode_post { |
|
60
|
28
|
|
|
28
|
0
|
63
|
my ($self, %arg) = @_; |
|
61
|
|
|
|
|
|
|
|
|
62
|
28
|
|
|
|
|
38
|
my $post_text = delete $arg{data}; |
|
63
|
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
# Try to decode data, return Exception upon failure |
|
65
|
28
|
|
|
|
|
31
|
local $@; |
|
66
|
28
|
|
|
|
|
27
|
my $data = eval { $self->_decode_json($post_text) }; |
|
|
28
|
|
|
|
|
44
|
|
|
67
|
|
|
|
|
|
|
|
|
68
|
28
|
100
|
|
|
|
547
|
if ( $@ ) { |
|
69
|
3
|
|
|
|
|
7
|
my $error = $self->_clean_msg($@); |
|
70
|
|
|
|
|
|
|
|
|
71
|
3
|
|
|
|
|
5
|
my $msg = "ExtDirect error decoding POST data: '$error'"; |
|
72
|
3
|
|
|
|
|
13
|
my $xcpt = $self->_exception({ |
|
73
|
|
|
|
|
|
|
direction => 'deserialize', |
|
74
|
|
|
|
|
|
|
message => $msg, |
|
75
|
|
|
|
|
|
|
%arg, |
|
76
|
|
|
|
|
|
|
}); |
|
77
|
|
|
|
|
|
|
|
|
78
|
3
|
|
|
|
|
13
|
return [ $xcpt ]; |
|
79
|
|
|
|
|
|
|
}; |
|
80
|
|
|
|
|
|
|
|
|
81
|
25
|
100
|
|
|
|
64
|
$data = [ $data ] unless ref $data eq 'ARRAY'; |
|
82
|
|
|
|
|
|
|
|
|
83
|
25
|
|
|
|
|
38
|
my @requests = map { $self->_request({ %$_, %arg }) } @$data; |
|
|
31
|
|
|
|
|
146
|
|
|
84
|
|
|
|
|
|
|
|
|
85
|
25
|
|
|
|
|
98
|
return \@requests; |
|
86
|
|
|
|
|
|
|
} |
|
87
|
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
### PUBLIC INSTANCE METHOD ### |
|
89
|
|
|
|
|
|
|
# |
|
90
|
|
|
|
|
|
|
# Instantiates Request based on form submitted to ExtDirect handler |
|
91
|
|
|
|
|
|
|
# Returns arrayref with single Request. |
|
92
|
|
|
|
|
|
|
# |
|
93
|
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
sub decode_form { |
|
95
|
10
|
|
|
10
|
0
|
26
|
my ($self, %arg) = @_; |
|
96
|
|
|
|
|
|
|
|
|
97
|
10
|
|
|
|
|
15
|
my $form_href = delete $arg{data}; |
|
98
|
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
# Create the Request (or Exception) |
|
100
|
10
|
|
|
|
|
61
|
my $request = $self->_request({ %$form_href, %arg }); |
|
101
|
|
|
|
|
|
|
|
|
102
|
10
|
|
|
|
|
43
|
return [ $request ]; |
|
103
|
|
|
|
|
|
|
} |
|
104
|
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
RPC::ExtDirect::Util::Accessor::mk_accessors( |
|
106
|
|
|
|
|
|
|
simple => [qw/ config api /], |
|
107
|
|
|
|
|
|
|
); |
|
108
|
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
############## PRIVATE METHODS BELOW ############## |
|
110
|
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
### PRIVATE INSTANCE METHOD ### |
|
112
|
|
|
|
|
|
|
# |
|
113
|
|
|
|
|
|
|
# Clean error message |
|
114
|
|
|
|
|
|
|
# |
|
115
|
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
sub _clean_msg { |
|
117
|
6
|
|
|
6
|
|
9
|
my ($self, $msg) = @_; |
|
118
|
|
|
|
|
|
|
|
|
119
|
6
|
|
|
|
|
16
|
return clean_error_message($msg); |
|
120
|
|
|
|
|
|
|
} |
|
121
|
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
### PRIVATE INSTANCE METHOD ### |
|
123
|
|
|
|
|
|
|
# |
|
124
|
|
|
|
|
|
|
# Try encoding one response into JSON |
|
125
|
|
|
|
|
|
|
# |
|
126
|
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
sub _encode_response { |
|
128
|
59
|
|
|
59
|
|
94
|
my ($self, $response, %arg) = @_; |
|
129
|
|
|
|
|
|
|
|
|
130
|
59
|
|
|
|
|
63
|
my $mute_exceptions = $arg{mute_exceptions}; |
|
131
|
|
|
|
|
|
|
|
|
132
|
59
|
|
|
|
|
51
|
local $@; |
|
133
|
59
|
|
|
|
|
62
|
my $text = eval { $self->_encode_json($response, %arg) }; |
|
|
59
|
|
|
|
|
120
|
|
|
134
|
|
|
|
|
|
|
|
|
135
|
59
|
100
|
100
|
|
|
1938
|
if ( $@ and not $mute_exceptions ) { |
|
136
|
3
|
|
|
|
|
10
|
my $msg = $self->_clean_msg($@); |
|
137
|
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
# It's not a given that response/exception hashrefs |
|
139
|
|
|
|
|
|
|
# will be actual blessed objects, so we have to peek |
|
140
|
|
|
|
|
|
|
# into them instead of using accessors |
|
141
|
|
|
|
|
|
|
my $exception = $self->_exception({ |
|
142
|
|
|
|
|
|
|
direction => 'serialize', |
|
143
|
|
|
|
|
|
|
action => $response->{action}, |
|
144
|
|
|
|
|
|
|
method => $response->{method}, |
|
145
|
|
|
|
|
|
|
tid => $response->{tid}, |
|
146
|
3
|
|
|
|
|
21
|
where => __PACKAGE__, |
|
147
|
|
|
|
|
|
|
message => $msg, |
|
148
|
|
|
|
|
|
|
%arg, |
|
149
|
|
|
|
|
|
|
}); |
|
150
|
|
|
|
|
|
|
|
|
151
|
3
|
|
|
|
|
7
|
local $@; |
|
152
|
3
|
|
|
|
|
5
|
$text = eval { |
|
153
|
3
|
|
|
|
|
8
|
$self->_encode_json( $exception->result(), %arg ) |
|
154
|
|
|
|
|
|
|
}; |
|
155
|
|
|
|
|
|
|
}; |
|
156
|
|
|
|
|
|
|
|
|
157
|
59
|
|
|
|
|
290
|
return $text; |
|
158
|
|
|
|
|
|
|
} |
|
159
|
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
### PRIVATE INSTANCE METHOD ### |
|
161
|
|
|
|
|
|
|
# |
|
162
|
|
|
|
|
|
|
# Actually encode JSON |
|
163
|
|
|
|
|
|
|
# |
|
164
|
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
sub _encode_json { |
|
166
|
62
|
|
|
62
|
|
81
|
my ($self, $data, %arg) = @_; |
|
167
|
|
|
|
|
|
|
|
|
168
|
62
|
|
66
|
|
|
1343
|
my $config = $arg{config} || $self->config; |
|
169
|
|
|
|
|
|
|
my $options = defined $arg{json_options} ? $arg{json_options} |
|
170
|
62
|
50
|
|
|
|
1141
|
: $config->json_options_serialize |
|
171
|
|
|
|
|
|
|
; |
|
172
|
|
|
|
|
|
|
my $debug = defined $arg{debug} ? $arg{debug} |
|
173
|
61
|
100
|
|
|
|
217
|
: $config->debug_serialize |
|
174
|
|
|
|
|
|
|
; |
|
175
|
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
# We force UTF-8 as per Ext.Direct spec |
|
177
|
61
|
|
|
|
|
101
|
$options->{utf8} = 1; |
|
178
|
|
|
|
|
|
|
$options->{canonical} = $debug |
|
179
|
61
|
100
|
|
|
|
140
|
unless defined $options->{canonical}; |
|
180
|
|
|
|
|
|
|
|
|
181
|
61
|
|
|
|
|
141
|
return JSON::to_json($data, $options); |
|
182
|
|
|
|
|
|
|
} |
|
183
|
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
### PRIVATE INSTANCE METHOD ### |
|
185
|
|
|
|
|
|
|
# |
|
186
|
|
|
|
|
|
|
# Actually decode JSON |
|
187
|
|
|
|
|
|
|
# |
|
188
|
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
sub _decode_json { |
|
190
|
28
|
|
|
28
|
|
32
|
my ($self, $text) = @_; |
|
191
|
|
|
|
|
|
|
|
|
192
|
28
|
|
|
|
|
543
|
my $options = $self->config->json_options_deserialize; |
|
193
|
|
|
|
|
|
|
|
|
194
|
28
|
|
|
|
|
69
|
return JSON::from_json($text, $options); |
|
195
|
|
|
|
|
|
|
} |
|
196
|
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
### PRIVATE INSTANCE METHOD ### |
|
198
|
|
|
|
|
|
|
# |
|
199
|
|
|
|
|
|
|
# Return a new Request object |
|
200
|
|
|
|
|
|
|
# |
|
201
|
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
sub _request { |
|
203
|
42
|
|
|
42
|
|
44
|
my ($self, $arg) = @_; |
|
204
|
|
|
|
|
|
|
|
|
205
|
42
|
|
|
|
|
771
|
my $api = $self->api; |
|
206
|
42
|
|
|
|
|
692
|
my $config = $self->config; |
|
207
|
42
|
|
|
|
|
698
|
my $request_class = $config->request_class_deserialize; |
|
208
|
|
|
|
|
|
|
|
|
209
|
42
|
|
|
|
|
1609
|
eval "require $request_class"; |
|
210
|
|
|
|
|
|
|
|
|
211
|
42
|
|
|
|
|
326
|
return $request_class->new({ |
|
212
|
|
|
|
|
|
|
config => $config, |
|
213
|
|
|
|
|
|
|
api => $api, |
|
214
|
|
|
|
|
|
|
%$arg |
|
215
|
|
|
|
|
|
|
}); |
|
216
|
|
|
|
|
|
|
} |
|
217
|
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
### PRIVATE INSTANCE METHOD ### |
|
219
|
|
|
|
|
|
|
# |
|
220
|
|
|
|
|
|
|
# Return a new Exception object |
|
221
|
|
|
|
|
|
|
# |
|
222
|
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
sub _exception { |
|
224
|
10
|
|
|
10
|
|
362
|
my ($self, $arg) = @_; |
|
225
|
|
|
|
|
|
|
|
|
226
|
10
|
|
|
|
|
11
|
my $direction = $arg->{direction}; |
|
227
|
|
|
|
|
|
|
|
|
228
|
10
|
|
|
|
|
192
|
my $config = $self->config; |
|
229
|
10
|
|
|
|
|
16
|
my $getter_class = "exception_class_$direction"; |
|
230
|
10
|
|
|
|
|
13
|
my $getter_debug = "debug_$direction"; |
|
231
|
|
|
|
|
|
|
|
|
232
|
10
|
|
|
|
|
177
|
my $exception_class = $config->$getter_class(); |
|
233
|
10
|
|
|
|
|
188
|
my $debug = $config->$getter_debug(); |
|
234
|
|
|
|
|
|
|
|
|
235
|
10
|
|
|
|
|
450
|
eval "require $exception_class"; |
|
236
|
|
|
|
|
|
|
|
|
237
|
10
|
100
|
|
|
|
50
|
$arg->{debug} = !!$debug unless defined $arg->{debug}; |
|
238
|
10
|
100
|
|
|
|
31
|
$arg->{where} = get_caller_info(2) unless defined $arg->{where}; |
|
239
|
|
|
|
|
|
|
|
|
240
|
10
|
|
|
|
|
203
|
$arg->{verbose} = $config->verbose_exceptions(); |
|
241
|
|
|
|
|
|
|
|
|
242
|
10
|
|
|
|
|
27
|
return $exception_class->new($arg); |
|
243
|
|
|
|
|
|
|
} |
|
244
|
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
1; |