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