/
10_data.t
502 lines (460 loc) · 20.9 KB
/
10_data.t
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
#!/usr/bin/perl
# Test the data-manipulation routines in RPC::XML
use strict;
use vars qw($val $str $fh $obj $class %val_tbl @values $datetime_avail);
use Test::More tests => 250;
use File::Spec;
use RPC::XML ':all';
BEGIN
{
eval "use DateTime";
$datetime_avail = $@ ? 0 : 1;
}
# First, make sure we can't instantiate any of "abstract" classes directly,
# and also make sure that certain base-class methods properly return when
# (wrongly) called as static methods:
$obj = RPC::XML::simple_type->new('foo');
ok(! ref $obj, 'Attempt to directly construct simple_type failed');
like($RPC::XML::ERROR, qr/Cannot instantiate/, 'Correct error message');
$val = RPC::XML::simple_type->value;
ok(! defined $val, 'Static call to RPC::XML::simple_type::value fails');
like($RPC::XML::ERROR, qr/static method/, 'Correct error message');
ok(! RPC::XML::simple_type->as_string(),
'Static call to RPC::XML::simple_type::as_string fails');
like($RPC::XML::ERROR, qr/static method/, 'Correct error message');
# RPC::XML::double and RPC::XML::string have their own as_string methods
ok(! RPC::XML::double->as_string(),
'Static call to RPC::XML::simple_type::as_string fails');
like($RPC::XML::ERROR, qr/static method/, 'Correct error message');
ok(! RPC::XML::string->as_string(),
'Static call to RPC::XML::simple_type::as_string fails');
like($RPC::XML::ERROR, qr/static method/, 'Correct error message');
# Try instantiating a non-scalar reference
$obj = RPC::XML::int->new([]);
ok(! ref $obj, 'Attempt to instantiate from non-scalar ref failed');
like($RPC::XML::ERROR, qr/not derived from scalar/, 'Correct error message');
# Next, the most basic data-types
%val_tbl = (
'int' => int(rand 10000) + 1,
i4 => int(rand 10000) + 1,
i8 => 2**32,
double => 0.5,
string => __FILE__
);
for (sort keys %val_tbl)
{
$val = $val_tbl{$_};
$class = "RPC::XML::$_";
$obj = $class->new($val);
isa_ok($obj, $class, "Basic data-type $_");
is($obj->value, $val, "Basic data-type $_, value check");
is($obj->as_string, "<$_>$val</$_>",
"Basic data-type $_, XML serialization");
is($obj->type, $_, "Basic data-type $_, type identification");
is(length($obj->as_string), $obj->length,
"Basic data-type $_, length() method test");
}
# Go again, with each of the values being a blessed scalar reference
my @vals = (1, -1, 2**32, 0.5, __FILE__);
%val_tbl = (
'int' => bless(\(shift(@vals)), "Tmp::Scalar::Int"),
i4 => bless(\(shift(@vals)), "Tmp::Scalar::I4"),
i8 => bless(\(shift(@vals)), "Tmp::Scalar::I8"),
double => bless(\(shift(@vals)), "Tmp::Scalar::Double"),
string => bless(\(shift(@vals)), "Tmp::Scalar::String")
);
for (sort keys %val_tbl)
{
$val = $val_tbl{$_};
$class = "RPC::XML::$_";
$obj = $class->new($val);
isa_ok($obj, $class, "Data objects from blessed scalar refs, type $_");
is($obj->value, $$val,
"Data objects from blessed scalar refs, type $_, value check");
is($obj->as_string, "<$_>${$val}</$_>",
"Data objects from blessed scalar refs, type $_, XML serialization");
is($obj->type, $_,
"Data objects from blessed scalar refs, type $_, type identification");
is(length($obj->as_string), $obj->length,
"Data objects from blessed scalar refs, type $_, length() method test");
}
# A few extra tests for RPC::XML::double to make sure the stringification
# doesn't lead to wonky values:
$obj = RPC::XML::double->new(10.0);
is($obj->as_string, '<double>10.0</double>',
'RPC::XML::double stringification [1]');
$obj = RPC::XML::double->new(0.50);
is($obj->as_string, '<double>0.5</double>',
'RPC::XML::double stringification [2]');
# Another little test for RPC::XML::string, to check encoding
$val = 'Subroutine &bogus not defined at <_> line -NaN';
$obj = RPC::XML::string->new($val);
is($obj->value, $val, "RPC::XML::string extra tests, value check");
is($obj->as_string,
"<string>Subroutine &bogus not defined at <_> line -NaN</string>",
"RPC::XML::string extra tests, XML serialization");
# Test for correct handling of encoding a 0 (false but defined)
$val = 0;
$obj = RPC::XML::string->new($val);
is($obj->as_string, "<string>0</string>", "RPC::XML::string, encoding '0'");
# Type boolean is a little funky
# Each of these should be OK
for (qw(0 1 yes no tRuE FaLsE))
{
$val = (/0|no|false/i) ? 0 : 1;
$obj = RPC::XML::boolean->new($_);
isa_ok($obj, 'RPC::XML::boolean', '$obj($_)');
is($obj->value, $val, "RPC::XML::boolean($_), value check");
is($obj->as_string, "<boolean>$val</boolean>",
"RPC::XML::boolean($_), XML serialization");
is($obj->type, 'boolean', "RPC::XML::boolean($_), type identification");
}
# This should not
$obj = RPC::XML::boolean->new('of course!');
ok(! ref $obj, "RPC::XML::boolean, bad value did not yield referent");
like($RPC::XML::ERROR, qr/::new: Value must be one of/,
"RPC::XML::boolean, bad value correctly set \$RPC::XML::ERROR");
# The dateTime.iso8601 type
$val = time2iso8601(time);
$obj = RPC::XML::datetime_iso8601->new($val);
isa_ok($obj, 'RPC::XML::datetime_iso8601', '$obj');
is($obj->type, 'dateTime.iso8601',
'RPC::XML::datetime_iso8601, type identification');
is(length($obj->as_string), $obj->length,
'RPC::XML::datetime_iso8601, length() method test');
is($obj->value, $val, 'RPC::XML::datetime_iso8601, value() method test');
$obj = RPC::XML::datetime_iso8601->new(\$val);
isa_ok($obj, 'RPC::XML::datetime_iso8601', '$obj');
is($obj->type, 'dateTime.iso8601',
'RPC::XML::datetime_iso8601, type identification (ref)');
is(length($obj->as_string), $obj->length,
'RPC::XML::datetime_iso8601, length() method test (ref)');
is($obj->value, $val, 'RPC::XML::datetime_iso8601, value() method test (ref)');
# Add a fractional part and try again
chop $val; # Lose the 'Z'
$val .= '.125Z';
$obj = RPC::XML::datetime_iso8601->new($val);
isa_ok($obj, 'RPC::XML::datetime_iso8601', '$obj');
is($obj->type, 'dateTime.iso8601',
"RPC::XML::datetime_iso8601, type identification");
is(length($obj->as_string), $obj->length,
"RPC::XML::datetime_iso8601, length() method test");
is($obj->value, $val, 'RPC::XML::datetime_iso8601, value() method test');
# Test bad date-data
substr($val, -5, 5) = ''; # Drop the Z and the fractional
$val .= '-07:00'; # Add a specification of a time zone that isn't UTC
$obj = RPC::XML::datetime_iso8601->new();
ok(! ref $obj, "RPC::XML::datetime_iso8601, bad value did not yield referent");
like($RPC::XML::ERROR, qr/::new: Malformed data.*passed/,
'RPC::XML::datetime_iso8601, bad value correctly set \$RPC::XML::ERROR');
# Test the slightly different date format
$obj = RPC::XML::datetime_iso8601->new('2008-09-29T12:00:00-07:00');
isa_ok($obj, 'RPC::XML::datetime_iso8601', '$obj');
is($obj->type, 'dateTime.iso8601',
"RPC::XML::datetime_iso8601, type identification");
is($obj->value, '20080929T12:00:00-07:00',
'RPC::XML::datetime_iso8601, value() method test');
# Test interoperability with the DateTime package, if it is available
SKIP: {
skip 'Module DateTime not available', 4
if (! $datetime_avail);
my $dt = DateTime->now();
(my $dt_str = "$dt") =~ s/-//g;
$obj = RPC::XML::datetime_iso8601->new("$dt");
isa_ok($obj, 'RPC::XML::datetime_iso8601', '$obj');
is($obj->value, $dt_str, 'RPC::XML::datetime_iso8601, from DateTime');
$obj = smart_encode($dt);
isa_ok($obj, 'RPC::XML::datetime_iso8601', '$obj');
is($obj->value, $dt_str,
'RPC::XML::datetime_iso8601, from DateTime via smart_encode');
}
# Test the base64 type
require MIME::Base64;
$str = 'one reasonable-length string';
$val = MIME::Base64::encode_base64($str, '');
$obj = RPC::XML::base64->new($str);
isa_ok($obj, 'RPC::XML::base64', '$obj');
is($obj->as_string, "<base64>$val</base64>",
'RPC::XML::base64, XML serialization');
is($obj->value, $str, 'RPC::XML::base64, correct value()');
is(length($obj->as_string), $obj->length,
"RPC::XML::base64, length() method test");
# Test pre-encoded data
$obj = RPC::XML::base64->new($val, 'pre-encoded');
isa_ok($obj, 'RPC::XML::base64', '$obj (pre-encoded)');
is($obj->value, $str, 'RPC::XML::base64(pre-encoded), value check');
# Test passing in a reference
$obj = RPC::XML::base64->new(\$str);
isa_ok($obj, 'RPC::XML::base64', '$obj');
is($obj->value, $str, 'RPC::XML::base64, correct value()');
# Test a null Base64 object
$obj = RPC::XML::base64->new();
isa_ok($obj, 'RPC::XML::base64', '$obj');
is($obj->value, '', 'Zero-length base64 object value OK');
is($obj->as_string, '<base64></base64>',
'Zero-length base64 object stringifies OK');
# Now we throw some junk at smart_encode()
@values = smart_encode(
__FILE__, # [0] string
10, # [1] int
3.14159, # [2] double
'2112', # [3] int
RPC::XML::string->new('2112'), # [4] string
[], # [5] array
{}, # [6] struct
\ "foo", # [7] string
\2, # [8] int
\1.414, # [9] double
2_147_483_647, # [10] int
-2_147_483_648, # [11] int
9_223_372_036_854_775_807, # [12] i8
-9_223_372_036_854_775_808, # [13] i8
4_294_967_295, # [14] i8
'2009-09-03T10:25:00', # [15] dateTime.iso8601
'20090903T10:25:00Z', # [16] dateTime.iso8601
'2009-09-03T10:25:00.125' # [17] dateTime.iso8601
);
is($values[0]->type, 'string', "smart_encode, string<1>");
is($values[1]->type, 'int', "smart_encode, int<1>");
is($values[2]->type, 'double', "smart_encode, double<1>");
# Should have been encoded int regardless of ''
is($values[3]->type, 'int', "smart_encode, int<2>");
# Was given an object explicitly
is($values[4]->type, 'string', "smart_encode, string<2>");
is($values[5]->type, 'array', "smart_encode, array");
is($values[6]->type, 'struct', "smart_encode, struct");
is($values[7]->type, 'string', "smart_encode, string<3>");
is($values[8]->type, 'int', "smart_encode, int<3>");
is($values[9]->type, 'double', "smart_encode, double<2>");
is($values[10]->type, 'int', 'smart_encode, int<4>');
is($values[11]->type, 'int', 'smart_encode, int<5>');
TODO: {
local $TODO = 'Big integer issues in smart_encode';
is($values[12]->type, 'i8', 'smart_encode, i8<1>');
is($values[13]->type, 'i8', 'smart_encode, i8<2>');
}
is($values[14]->type, 'i8', 'smart_encode, i8<3>');
is($values[15]->type, 'dateTime.iso8601', 'smart_encode, dateTime.iso8601');
is($values[16]->type, 'dateTime.iso8601', 'smart_encode, dateTime.iso8601<2>');
is($values[17]->type, 'dateTime.iso8601', 'smart_encode, dateTime.iso8601<3>');
# Without $RPC::XML::ALLOW_NIL set, smart_encode should encode this as a null
# string:
$obj = smart_encode(undef);
is($obj->type, 'string', 'smart_encode undef->string type');
is($obj->value, '', 'smart_encode undef->string value');
# Check that smart_encode gives up on un-convertable references
{
my $badvalue;
eval { $badvalue = smart_encode(\*STDIN); };
ok(! ref($badvalue),
"smart_encode, bad reference argument did not yield referent");
like($@, qr/Un-convertable reference/,
"smart_encode, bad reference argument set \$@ as expected");
}
# Arrays
$obj = RPC::XML::array->new(1 .. 10);
isa_ok($obj, 'RPC::XML::array', '$obj');
is($obj->type, 'array', "RPC::XML::array, type identification");
@values = @{ $obj->value };
is(scalar(@values), 10, "RPC::XML::array, array size test");
@values = @{ $obj->value(1) };
ok(ref($values[0]) && ($values[0]->type eq 'int'),
'RPC::XML::array, array content is RPC::XML::* referent');
like($obj->as_string, qr|<array>.*(<int>\d+</int>.*){10}.*</array>|sm,
'RPC::XML::array, XML serialization');
is(length($obj->as_string), $obj->length,
'RPC::XML::array, length() method test');
# Blessed array references
my $arrayobj = bless [ 1 .. 10 ], "Tmp::Array$$";
$obj = RPC::XML::array->new(from => $arrayobj);
isa_ok($obj, 'RPC::XML::array', '$obj from blessed arrayref');
is($obj->type, 'array',
'RPC::XML::array from blessed arrayref, type identification');
@values = @{ $obj->value };
is(scalar(@values), 10,
'RPC::XML::array from blessed arrayref, array size test');
@values = @{ $obj->value(1) };
ok(ref($values[0]) && ($values[0]->type eq 'int'),
'RPC::XML::array from blessed arrayref, array content is referent');
like($obj->as_string, qr|<array>.*(<int>\d+</int>.*){10}.*</array>|sm,
'RPC::XML::array from blessed arrayref, XML serialization');
is(length($obj->as_string), $obj->length,
'RPC::XML::array from blessed arrayref, length() method test');
undef $arrayobj;
# Structs
$obj = RPC::XML::struct->new(key1 => 1, key2 => 2);
isa_ok($obj, 'RPC::XML::struct', '$obj');
is($obj->type, 'struct', 'RPC::XML::struct, type identification');
$val = $obj->value;
is(ref($val), 'HASH', 'RPC::XML::struct, ref-type of value()');
is(scalar(keys %$val), 2, 'RPC::XML::struct, correct number of keys');
is($val->{key1}, 1, q(RPC::XML::struct, 'key1' value test));
$val = $obj->value(1);
ok(ref($val->{key1}) && ($val->{key1}->type eq 'int'),
'RPC::XML::struct, key-value is referent in shallow conversion');
$val->{key1} = RPC::XML::string->new('hello');
$obj = RPC::XML::struct->new($val);
isa_ok($obj, 'RPC::XML::struct', '$obj(object-values)');
is(($obj->value)->{key1}, 'hello',
q{RPC::XML::struct(object-values), 'key1' value test});
is(($obj->value(1))->{key1}->type, 'string',
'RPC::XML::struct(object-values), value-object type correctness');
like($obj->as_string, qr|<struct>.*(<member>.*
<name>.*</name>.*
<value>.*</value>.*
</member>.*){2}.*</struct>|smx,
'RPC::XML::struct, XML serialization');
is(length($obj->as_string), $obj->length,
"RPC::XML::struct, length() method test");
# Test handling of keys that contain XML special characters
$obj = RPC::XML::struct->new('>' => these =>
'<' => are =>
'&' => special =>
'<>' => XML =>
'&&' => 'characters');
isa_ok($obj, 'RPC::XML::struct', '$obj(with XML special char keys)');
is((my $tmp = $obj->as_string) =~ tr/&/&/, 7,
'RPC::XML::struct, XML-encoding of serialized form with char entities');
# Blessed struct reference
my $structobj = bless { key1 => 1, key2 => 2 }, "Tmp::Struct$$";
$obj = RPC::XML::struct->new($structobj);
isa_ok($obj, 'RPC::XML::struct', '$obj(struct<1>)');
is($obj->type, 'struct', 'struct object type method');
$val = $obj->value;
isa_ok($val, 'HASH', 'struct $obj->value');
is(scalar(keys %$val), 2, 'struct obj number of keys test');
is($val->{key1}, 1, 'struct obj "key1" test');
$val = $obj->value(1);
isa_ok($val->{key1}, 'RPC::XML::int', '$val->{key1} (shallow eval)');
$val->{key1} = RPC::XML::string->new('hello');
$obj = RPC::XML::struct->new($val);
isa_ok($obj, 'RPC::XML::struct', '$obj(struct<2>)');
is(($obj->value)->{key1}, 'hello', 'struct<2> "key1" test');
is(($obj->value(1))->{key1}->type, 'string', 'struct<2> "key1" type test');
like($obj->as_string, qr|<struct>.*(<member>.*
<name>.*</name>.*
<value>.*</value>.*
</member>.*){2}.*</struct>|smx,
'struct<2> XML serialization');
is(length($obj->as_string), $obj->length, 'struct<2> length() check');
# No need to re-test the XML character handling
# Faults are a subclass of structs
$obj = RPC::XML::fault->new(faultCode => 1, faultString => 'test');
isa_ok($obj, 'RPC::XML::fault', '$obj (fault)');
# Since it's a subclass, I won't waste cycles testing the similar methods
$obj = RPC::XML::fault->new(faultCode => 1);
ok(! ref $obj, 'fault class constructor fails on missing key(s)');
like($RPC::XML::ERROR, qr/:new: Missing required struct fields/,
'fault class failure set error string');
$obj = RPC::XML::fault->new(faultCode => 1, faultString => 'test',
faultFail => 'extras are not allowed');
ok(! ref($obj), 'fault class rejects extra args');
like($RPC::XML::ERROR, qr/:new: Extra struct/,
'fault class failure set error string');
$obj = RPC::XML::fault->new(1, 'test');
isa_ok($obj, 'RPC::XML::fault', '$obj<2> (fault)');
is($obj->code, 1, 'fault code() method');
is($obj->string, 'test', 'fault string() method');
like($obj->as_string, qr|<fault>.*
<value>.*
<struct>.*
(<member>.*
<name>.*</name>.*
<value>.*</value>.*
</member>.*){2}.*
</struct>.*
</value>.*
</fault>|smx,
'fault XML serialization');
is(length($obj->as_string), $obj->length, 'fault length() check');
# Requests
$obj = RPC::XML::request->new('test.method');
isa_ok($obj, 'RPC::XML::request', '$obj (request)');
is($obj->name, 'test.method', 'request name method');
ok($obj->args && (@{ $obj->args } == 0), 'request args method');
$obj = RPC::XML::request->new();
ok(! ref($obj), 'bad request contructor failed');
like($RPC::XML::ERROR, qr/:new: At least a method name/,
'bad request constructor set error string');
$obj = RPC::XML::request->new('#*'); # Bad method name, should fail
ok(! ref($obj), 'Bad method name in constructor failed');
like($RPC::XML::ERROR, qr/Invalid method name/,
'Bad method name in constructor set error string');
$obj = RPC::XML::request->new('test.method', (1 .. 10));
ok($obj->args && (@{ $obj->args } == 10), 'request args method size test');
# The new() method uses smart_encode on the args, which has already been
# tested. These are just to ensure that it *does* in fact call it
is($obj->args->[0]->type, 'int', 'request args elt[0] type test');
is($obj->args->[9]->value, 10, 'request args elt[9] value test');
like($obj->as_string, qr|<\?xml.*
<methodCall>.*
<methodName>.*</methodName>.*
<params>.*
(<param>.*</param>.*){10}.*
</params>.*
</methodCall>|smx,
'request XML serialization');
is(length($obj->as_string), $obj->length, 'request length() test');
# Responses
$obj = RPC::XML::response->new('ok');
isa_ok($obj, 'RPC::XML::response', '$obj (response)');
is($obj->value->type, 'string', 'response value->type test');
is($obj->value->value, 'ok', 'response value->value test');
ok(! $obj->is_fault, 'response object not fault');
like($obj->as_string, qr|<\?xml.*
<methodResponse>.*
<params>.*
<param>.*</param>.*
</params>.*
</methodResponse>|smx,
'response XML serialization');
is(length($obj->as_string), $obj->length, 'response length() test');
$obj = RPC::XML::response->new();
ok(! ref($obj), 'bad response constructor failed');
like($RPC::XML::ERROR, qr/:new: One of a datatype, value or a fault/,
'bad response constructor set error string');
$obj = RPC::XML::response->new(qw(one two));
ok(! ref($obj), 'bad response constructor failed');
like($RPC::XML::ERROR, qr/only one argument/,
'bad response constructor set error string');
$obj = RPC::XML::response->new(RPC::XML::fault->new(1, 'test'));
isa_ok($obj, 'RPC::XML::response', '$obj (response/fault)');
# The other methods have already been tested
ok($obj->is_fault, 'fault response creation is_fault test');
### test for bug where encoding was done too freely, encoding
### any ^\d+$ as int, etc
{
my %map = (
256 => 'int',
256**4+1 => 'i8', # will do *-1 as well
256**8+1 => 'double',
1e37+1 => 'string',
);
while (my($val,$type) = each %map)
{
for my $mod (1,-1)
{
{
my $obj = smart_encode($mod * $val);
ok($obj, "smart_encode zealousness test, $mod * $val");
is($obj->type, $type,
'smart_encode zealousness, non-forced type');
}
### test force string encoding
{
### double assign to silence -w
local $RPC::XML::FORCE_STRING_ENCODING = 1;
local $RPC::XML::FORCE_STRING_ENCODING = 1;
my $obj = smart_encode($mod * $val);
ok($obj, "smart_encode zealousness test, $mod * $val (force)");
is($obj->type, 'string',
'smart_encode zealousness, forced to string');
}
}
}
}
# Test for RT# 31818, ensure that very small double values are expressed in
# a format that conforms to the XML-RPC spec.
is(RPC::XML::double->new(0.000005)->as_string, '<double>0.000005</double>',
'Floating-point format test, RT31818');
exit 0;