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 &bogus not defined at <_> 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