| File: | blib/lib/App/Test/Generator/Emitter/Perl.pm |
| Coverage: | 98.7% |
| line | stmt | bran | cond | sub | time | code |
|---|---|---|---|---|---|---|
| 1 | package App::Test::Generator::Emitter::Perl; | |||||
| 2 | ||||||
| 3 | 8 8 8 | 130154 7 100 | use strict; | |||
| 4 | 8 8 8 | 13 3 147 | use warnings; | |||
| 5 | 8 8 8 | 17 6 148 | use Carp qw(croak); | |||
| 6 | 8 8 8 | 396 3286 4975 | use Readonly; | |||
| 7 | ||||||
| 8 | # -------------------------------------------------- | |||||
| 9 | # Plan key names — must match those emitted by | |||||
| 10 | # App::Test::Generator::TestStrategy and | |||||
| 11 | # App::Test::Generator::Planner | |||||
| 12 | # -------------------------------------------------- | |||||
| 13 | Readonly my $TEST_BASIC => 'basic_test'; | |||||
| 14 | Readonly my $TEST_GETTER => 'getter_test'; | |||||
| 15 | Readonly my $TEST_SETTER => 'setter_test'; | |||||
| 16 | Readonly my $TEST_GETSET => 'getset_test'; | |||||
| 17 | Readonly my $TEST_CHAINING => 'chaining_test'; | |||||
| 18 | Readonly my $TEST_ERROR_HANDLING => 'error_handling_test'; | |||||
| 19 | Readonly my $TEST_CONTEXT => 'context_tests'; | |||||
| 20 | Readonly my $TEST_OBJECT_INJECT => 'object_injection_test'; | |||||
| 21 | Readonly my $TEST_PREDICATE => 'predicate_test'; | |||||
| 22 | Readonly my $TEST_BOOLEAN => 'boolean_test'; | |||||
| 23 | Readonly my $TEST_VOID => 'void_context_test'; | |||||
| 24 | Readonly my $TEST_BOUNDARY => 'boundary_tests'; | |||||
| 25 | ||||||
| 26 | # -------------------------------------------------- | |||||
| 27 | # Input/output type strings from the schema | |||||
| 28 | # -------------------------------------------------- | |||||
| 29 | Readonly my $TYPE_OBJECT => 'object'; | |||||
| 30 | Readonly my $TYPE_BOOLEAN => 'boolean'; | |||||
| 31 | ||||||
| 32 | our $VERSION = '0.41'; | |||||
| 33 | ||||||
| 34 - 96 | =head1 VERSION
Version 0.41
=head1 DESCRIPTION
Emits Perl test code for a set of method schemas and their associated
test plans. Each method plan is translated into one or more test blocks
using L<Test::Most>. The emitted code is returned as a string ready to
be written to a C<.t> file.
=head2 new
Construct a new Perl emitter.
my $emitter = App::Test::Generator::Emitter::Perl->new(
schema => \%schemas,
plans => \%plans,
package => 'My::Module',
);
=head3 Arguments
=over 4
=item * C<schema>
A hashref of method name to schema hashref. Required.
=item * C<plans>
A hashref of method name to test plan hashref, as produced by
L<App::Test::Generator::TestStrategy> or
L<App::Test::Generator::Planner>. Required.
=item * C<package>
The Perl package name of the module under test. Required.
=back
=head3 Returns
A blessed hashref. Croaks if any required argument is missing.
=head3 API specification
=head4 input
{
schema => { type => HASHREF },
plans => { type => HASHREF },
package => { type => SCALAR },
}
=head4 output
{
type => OBJECT,
isa => 'App::Test::Generator::Emitter::Perl',
}
=cut | |||||
| 97 | ||||||
| 98 | sub new { | |||||
| 99 | 131 | 1205425 | my ($class, %args) = @_; | |||
| 100 | ||||||
| 101 | # All three arguments are required for meaningful emission | |||||
| 102 | 131 | 209 | croak 'schema required' unless defined $args{schema}; | |||
| 103 | 128 | 146 | croak 'plans required' unless defined $args{plans}; | |||
| 104 | 125 | 150 | croak 'package required' unless defined $args{package}; | |||
| 105 | ||||||
| 106 | # $args{package} is spliced unescaped into use_ok()/new_ok() calls | |||||
| 107 | # in _emit_header() — reject anything that isn't a valid Perl | |||||
| 108 | # package name now, rather than generating broken or injected code. | |||||
| 109 | croak "package '$args{package}' is not a valid Perl package name" | |||||
| 110 | 122 | 347 | unless $args{package} =~ /^[A-Za-z_]\w*(?:::[A-Za-z_]\w*)*\z/; | |||
| 111 | ||||||
| 112 | return bless { | |||||
| 113 | schema => $args{schema}, | |||||
| 114 | plans => $args{plans}, | |||||
| 115 | package => $args{package}, | |||||
| 116 | 120 | 254 | }, $class; | |||
| 117 | } | |||||
| 118 | ||||||
| 119 - 161 | =head2 emit
Generate and return the complete Perl test file source as a string,
including the file header, one test block per method, and the
C<done_testing()> footer.
my $emitter = App::Test::Generator::Emitter::Perl->new(
schema => \%schemas,
plans => \%plans,
package => 'My::Module',
);
my $test_code = $emitter->emit;
write_file('t/generated.t', $test_code);
=head3 Arguments
None beyond C<$self>.
=head3 Returns
A string containing the complete Perl test file source.
=head3 Notes
A method whose plan has the C<boundary_tests> flag set (because its
schema carries non-empty C<_yamltest_hints>) gets one smoke-test block
per hint value in C<boundary_values> and C<invalid_inputs>, calling
the method with that value and asserting only that the call does not
crash the test process.
=head3 API specification
=head4 input
{
self => { type => OBJECT, isa => 'App::Test::Generator::Emitter::Perl' },
}
=head4 output
{ type => SCALAR }
=cut | |||||
| 162 | ||||||
| 163 | sub emit { | |||||
| 164 | 64 | 179 | my $self = $_[0]; | |||
| 165 | ||||||
| 166 | # Start with the file header then append per-method test blocks | |||||
| 167 | 64 | 80 | my $code = $self->_emit_header(); | |||
| 168 | ||||||
| 169 | # Sort methods for deterministic output order | |||||
| 170 | 64 64 | 51 123 | for my $method (sort keys %{ $self->{plans} }) { | |||
| 171 | 119 | 120 | $code .= $self->_emit_method_tests($method); | |||
| 172 | } | |||||
| 173 | ||||||
| 174 | # TAP footer required by Test::More / Test::Most | |||||
| 175 | 63 | 58 | $code .= "\ndone_testing();\n"; | |||
| 176 | ||||||
| 177 | 63 | 89 | return $code; | |||
| 178 | } | |||||
| 179 | ||||||
| 180 | # -------------------------------------------------- | |||||
| 181 | # _emit_header | |||||
| 182 | # | |||||
| 183 | # Purpose: Generate the standard test file header | |||||
| 184 | # including strict/warnings, use_ok and | |||||
| 185 | # a default object construction. | |||||
| 186 | # | |||||
| 187 | # Entry: None beyond $self. | |||||
| 188 | # Exit: Returns a string of Perl code. | |||||
| 189 | # Side effects: None. | |||||
| 190 | # Notes: The generated $obj is used by all | |||||
| 191 | # subsequent test blocks. | |||||
| 192 | # -------------------------------------------------- | |||||
| 193 | sub _emit_header { | |||||
| 194 | 71 | 55 | my $self = $_[0]; | |||
| 195 | ||||||
| 196 | 71 | 118 | return <<"END_HEADER"; | |||
| 197 | use strict; | |||||
| 198 | use warnings; | |||||
| 199 | use Test::Most; | |||||
| 200 | ||||||
| 201 | use_ok('$self->{package}'); | |||||
| 202 | ||||||
| 203 | my \$obj = new_ok('$self->{package}'); | |||||
| 204 | ||||||
| 205 | END_HEADER | |||||
| 206 | } | |||||
| 207 | ||||||
| 208 | # -------------------------------------------------- | |||||
| 209 | # _emit_method_tests | |||||
| 210 | # | |||||
| 211 | # Purpose: Dispatch to the appropriate emit method | |||||
| 212 | # for each test type flagged in the plan | |||||
| 213 | # for a given method. | |||||
| 214 | # | |||||
| 215 | # Entry: $method - the method name string. | |||||
| 216 | # Plan and schema are read from $self. | |||||
| 217 | # Exit: Returns a string of Perl test code. | |||||
| 218 | # Side effects: None. | |||||
| 219 | # Notes: Test types are emitted in a fixed order | |||||
| 220 | # for deterministic output. Methods with | |||||
| 221 | # no recognised plan flags produce no | |||||
| 222 | # output beyond the section comment. | |||||
| 223 | # -------------------------------------------------- | |||||
| 224 | sub _emit_method_tests { | |||||
| 225 | 139 | 152 | my ($self, $method) = @_; | |||
| 226 | ||||||
| 227 | # $method is spliced unescaped as a bareword method name | |||||
| 228 | # (->$method(...)) by every _emit_*_test sub below — reject | |||||
| 229 | # anything that isn't a valid Perl identifier before any of them run. | |||||
| 230 | 139 | 217 | croak "method '$method' is not a valid Perl identifier" | |||
| 231 | unless $method =~ /^[A-Za-z_]\w*\z/; | |||||
| 232 | ||||||
| 233 | 137 | 119 | my $plan = $self->{plans}{$method}; | |||
| 234 | 137 | 91 | my $code = "\n# --- Tests for $method ---\n"; | |||
| 235 | ||||||
| 236 | # Emit each test type in a consistent fixed order | |||||
| 237 | 137 | 214 | $code .= $self->_emit_basic_test($method) if $plan->{$TEST_BASIC}; | |||
| 238 | ||||||
| 239 | 137 | 272 | $code .= $self->_emit_getter_test($method) if $plan->{$TEST_GETTER}; | |||
| 240 | ||||||
| 241 | 137 | 293 | $code .= $self->_emit_setter_test($method) if $plan->{$TEST_SETTER}; | |||
| 242 | ||||||
| 243 | 137 | 291 | $code .= $self->_emit_getset_test($method) if $plan->{$TEST_GETSET}; | |||
| 244 | ||||||
| 245 | 137 | 274 | $code .= $self->_emit_chaining_test($method) if $plan->{$TEST_CHAINING}; | |||
| 246 | ||||||
| 247 | 137 | 367 | $code .= $self->_emit_error_test($method) if $plan->{$TEST_ERROR_HANDLING}; | |||
| 248 | ||||||
| 249 | 137 | 292 | $code .= $self->_emit_context_test($method) if $plan->{$TEST_CONTEXT}; | |||
| 250 | ||||||
| 251 | 137 | 282 | $code .= $self->_emit_object_injection_test($method) if $plan->{$TEST_OBJECT_INJECT}; | |||
| 252 | ||||||
| 253 | 137 | 307 | $code .= $self->_emit_boolean_test($method) if $plan->{$TEST_PREDICATE} || $plan->{$TEST_BOOLEAN}; | |||
| 254 | ||||||
| 255 | 137 | 579 | $code .= $self->_emit_void_test($method) if $plan->{$TEST_VOID}; | |||
| 256 | ||||||
| 257 | 137 | 290 | $code .= $self->_emit_boundary_test($method) if $plan->{$TEST_BOUNDARY}; | |||
| 258 | ||||||
| 259 | 137 | 346 | return $code; | |||
| 260 | } | |||||
| 261 | ||||||
| 262 | # -------------------------------------------------- | |||||
| 263 | # _emit_basic_test | |||||
| 264 | # | |||||
| 265 | # Purpose: Emit a minimal test that calls the | |||||
| 266 | # method and verifies it does not die. | |||||
| 267 | # | |||||
| 268 | # Entry: $method - method name string. | |||||
| 269 | # Exit: Returns a string of Perl test code. | |||||
| 270 | # Side effects: None. | |||||
| 271 | # -------------------------------------------------- | |||||
| 272 | sub _emit_basic_test { | |||||
| 273 | 66 | 166 | my ($self, $method) = @_; | |||
| 274 | ||||||
| 275 | 66 | 67 | return <<"END_TEST"; | |||
| 276 | { | |||||
| 277 | my \$result = eval { \$obj->$method() }; | |||||
| 278 | ok(!\$@, '$method does not die'); | |||||
| 279 | } | |||||
| 280 | END_TEST | |||||
| 281 | } | |||||
| 282 | ||||||
| 283 | # -------------------------------------------------- | |||||
| 284 | # _emit_getter_test | |||||
| 285 | # | |||||
| 286 | # Purpose: Emit a test that calls the getter and | |||||
| 287 | # verifies it returns a defined value. | |||||
| 288 | # | |||||
| 289 | # Entry: $method - method name string. | |||||
| 290 | # Exit: Returns a string of Perl test code. | |||||
| 291 | # Side effects: None. | |||||
| 292 | # -------------------------------------------------- | |||||
| 293 | sub _emit_getter_test { | |||||
| 294 | 14 | 43 | my ($self, $method) = @_; | |||
| 295 | ||||||
| 296 | 14 | 19 | return <<"END_TEST"; | |||
| 297 | { | |||||
| 298 | my \$value = \$obj->$method(); | |||||
| 299 | ok(defined \$value, '$method returns a value'); | |||||
| 300 | } | |||||
| 301 | END_TEST | |||||
| 302 | } | |||||
| 303 | ||||||
| 304 | # -------------------------------------------------- | |||||
| 305 | # _emit_setter_test | |||||
| 306 | # | |||||
| 307 | # Purpose: Emit a test that calls the setter with | |||||
| 308 | # a string argument and verifies it | |||||
| 309 | # accepts the input without dying. | |||||
| 310 | # | |||||
| 311 | # Entry: $method - method name string. | |||||
| 312 | # Exit: Returns a string of Perl test code. | |||||
| 313 | # Side effects: None. | |||||
| 314 | # -------------------------------------------------- | |||||
| 315 | sub _emit_setter_test { | |||||
| 316 | 12 | 31 | my ($self, $method) = @_; | |||
| 317 | ||||||
| 318 | 12 | 15 | return <<"END_TEST"; | |||
| 319 | { | |||||
| 320 | ok(\$obj->$method('test'), '$method accepts input'); | |||||
| 321 | } | |||||
| 322 | END_TEST | |||||
| 323 | } | |||||
| 324 | ||||||
| 325 | # -------------------------------------------------- | |||||
| 326 | # _emit_getset_test | |||||
| 327 | # | |||||
| 328 | # Purpose: Emit a round-trip get/set test. The | |||||
| 329 | # test type (object, boolean, or string) | |||||
| 330 | # is determined from the schema input | |||||
| 331 | # parameter type. | |||||
| 332 | # | |||||
| 333 | # Entry: $method - method name string. | |||||
| 334 | # Schema is read from $self. | |||||
| 335 | # Exit: Returns a string of Perl test code. | |||||
| 336 | # Side effects: None. | |||||
| 337 | # Notes: Falls back to string round-trip if the | |||||
| 338 | # parameter type is unrecognised. | |||||
| 339 | # -------------------------------------------------- | |||||
| 340 | sub _emit_getset_test { | |||||
| 341 | 22 | 84 | my ($self, $method) = @_; | |||
| 342 | ||||||
| 343 | 22 | 25 | my $schema = $self->{schema}{$method}; | |||
| 344 | ||||||
| 345 | # Find the first non-internal input parameter | |||||
| 346 | 22 14 22 | 20 21 42 | my ($param) = grep { !/^_/ } keys %{ $schema->{input} || {} }; | |||
| 347 | 22 | 63 | my $type = ($param && $schema->{input}{$param}{type}) // ''; | |||
| 348 | ||||||
| 349 | # Object injection round-trip | |||||
| 350 | 22 | 31 | if($type eq $TYPE_OBJECT) { | |||
| 351 | 4 | 14 | return <<"END_TEST"; | |||
| 352 | { | |||||
| 353 | my \$mock = bless {}, 'Test::MockObject'; | |||||
| 354 | \$obj->$method(\$mock); | |||||
| 355 | isa_ok(\$obj->$method(), ref(\$mock), '$method get/set works'); | |||||
| 356 | } | |||||
| 357 | END_TEST | |||||
| 358 | } | |||||
| 359 | ||||||
| 360 | # Boolean round-trip | |||||
| 361 | 18 | 66 | if($type eq $TYPE_BOOLEAN) { | |||
| 362 | 4 | 18 | return <<"END_TEST"; | |||
| 363 | { | |||||
| 364 | \$obj->$method(1); | |||||
| 365 | ok(\$obj->$method(), '$method get/set boolean true works'); | |||||
| 366 | \$obj->$method(0); | |||||
| 367 | ok(!\$obj->$method(), '$method get/set boolean false works'); | |||||
| 368 | } | |||||
| 369 | END_TEST | |||||
| 370 | } | |||||
| 371 | ||||||
| 372 | # Default string round-trip | |||||
| 373 | 14 | 47 | return <<"END_TEST"; | |||
| 374 | { | |||||
| 375 | \$obj->$method('value'); | |||||
| 376 | is(\$obj->$method(), 'value', '$method get/set works'); | |||||
| 377 | } | |||||
| 378 | END_TEST | |||||
| 379 | } | |||||
| 380 | ||||||
| 381 | # -------------------------------------------------- | |||||
| 382 | # _emit_chaining_test | |||||
| 383 | # | |||||
| 384 | # Purpose: Emit a test that verifies the method | |||||
| 385 | # returns $self for method chaining. | |||||
| 386 | # | |||||
| 387 | # Entry: $method - method name string. | |||||
| 388 | # Exit: Returns a string of Perl test code. | |||||
| 389 | # Side effects: None. | |||||
| 390 | # -------------------------------------------------- | |||||
| 391 | sub _emit_chaining_test { | |||||
| 392 | 7 | 24 | my ($self, $method) = @_; | |||
| 393 | ||||||
| 394 | 7 | 10 | return <<"END_TEST"; | |||
| 395 | { | |||||
| 396 | my \$ret = \$obj->$method(); | |||||
| 397 | isa_ok(\$ret, ref(\$obj), '$method returns self for chaining'); | |||||
| 398 | } | |||||
| 399 | END_TEST | |||||
| 400 | } | |||||
| 401 | ||||||
| 402 | # -------------------------------------------------- | |||||
| 403 | # _emit_error_test | |||||
| 404 | # | |||||
| 405 | # Purpose: Emit a test that calls the method with | |||||
| 406 | # undef input and verifies it handles the | |||||
| 407 | # error gracefully. | |||||
| 408 | # | |||||
| 409 | # Entry: $method - method name string. | |||||
| 410 | # Exit: Returns a string of Perl test code. | |||||
| 411 | # Side effects: None. | |||||
| 412 | # -------------------------------------------------- | |||||
| 413 | sub _emit_error_test { | |||||
| 414 | 7 | 20 | my ($self, $method) = @_; | |||
| 415 | ||||||
| 416 | 7 | 11 | return <<"END_TEST"; | |||
| 417 | { | |||||
| 418 | my \$result = eval { \$obj->$method(undef) }; | |||||
| 419 | ok(!\$result || \$@, '$method handles invalid input'); | |||||
| 420 | } | |||||
| 421 | END_TEST | |||||
| 422 | } | |||||
| 423 | ||||||
| 424 | # -------------------------------------------------- | |||||
| 425 | # _emit_context_test | |||||
| 426 | # | |||||
| 427 | # Purpose: Emit tests that call the method in | |||||
| 428 | # both scalar and list context to verify | |||||
| 429 | # context-aware return behaviour. | |||||
| 430 | # | |||||
| 431 | # Entry: $method - method name string. | |||||
| 432 | # Exit: Returns a string of Perl test code. | |||||
| 433 | # Side effects: None. | |||||
| 434 | # Notes: Uses eval to verify the calls survive | |||||
| 435 | # rather than checking return values, | |||||
| 436 | # since context-aware return values vary. | |||||
| 437 | # -------------------------------------------------- | |||||
| 438 | sub _emit_context_test { | |||||
| 439 | 4 | 16 | my ($self, $method) = @_; | |||
| 440 | ||||||
| 441 | 4 | 8 | return <<"END_TEST"; | |||
| 442 | { | |||||
| 443 | my \$scalar = eval { \$obj->$method() }; | |||||
| 444 | ok(!\$@, '$method survives in scalar context'); | |||||
| 445 | ||||||
| 446 | my \@list = eval { \$obj->$method() }; | |||||
| 447 | ok(!\$@, '$method survives in list context'); | |||||
| 448 | } | |||||
| 449 | END_TEST | |||||
| 450 | } | |||||
| 451 | ||||||
| 452 | # -------------------------------------------------- | |||||
| 453 | # _emit_object_injection_test | |||||
| 454 | # | |||||
| 455 | # Purpose: Emit a test that injects a mock object | |||||
| 456 | # and verifies the same object is returned | |||||
| 457 | # by the getter. | |||||
| 458 | # | |||||
| 459 | # Entry: $method - method name string. | |||||
| 460 | # Exit: Returns a string of Perl test code. | |||||
| 461 | # Side effects: None. | |||||
| 462 | # -------------------------------------------------- | |||||
| 463 | sub _emit_object_injection_test { | |||||
| 464 | 6 | 20 | my ($self, $method) = @_; | |||
| 465 | ||||||
| 466 | 6 | 9 | return <<"END_TEST"; | |||
| 467 | { | |||||
| 468 | my \$mock = bless {}, 'Mock::Object'; | |||||
| 469 | \$obj->$method(\$mock); | |||||
| 470 | isa_ok(\$obj->$method(), 'Mock::Object', | |||||
| 471 | '$method stores injected object instance'); | |||||
| 472 | } | |||||
| 473 | END_TEST | |||||
| 474 | } | |||||
| 475 | ||||||
| 476 | # -------------------------------------------------- | |||||
| 477 | # _emit_boolean_test | |||||
| 478 | # | |||||
| 479 | # Purpose: Emit a test that verifies the method | |||||
| 480 | # returns a defined scalar boolean value. | |||||
| 481 | # | |||||
| 482 | # Entry: $method - method name string. | |||||
| 483 | # Exit: Returns a string of Perl test code. | |||||
| 484 | # Side effects: None. | |||||
| 485 | # Notes: Checks that the return value is defined, | |||||
| 486 | # is not a reference, and is boolean-like | |||||
| 487 | # without using numeric comparison which | |||||
| 488 | # would warn on string returns. | |||||
| 489 | # -------------------------------------------------- | |||||
| 490 | sub _emit_boolean_test { | |||||
| 491 | 8 | 38 | my ($self, $method) = @_; | |||
| 492 | ||||||
| 493 | 8 | 15 | return <<"END_TEST"; | |||
| 494 | { | |||||
| 495 | my \$result = \$obj->$method(); | |||||
| 496 | ok(defined \$result, '$method returns a defined value'); | |||||
| 497 | ok(!ref \$result, '$method returns a scalar'); | |||||
| 498 | ok(\$result ? 1 : 0, '$method returns a boolean-like value'); | |||||
| 499 | } | |||||
| 500 | END_TEST | |||||
| 501 | } | |||||
| 502 | ||||||
| 503 | # -------------------------------------------------- | |||||
| 504 | # _emit_void_test | |||||
| 505 | # | |||||
| 506 | # Emit a test that verifies the method | |||||
| 507 | # does not return a meaningful value, | |||||
| 508 | # consistent with a void return type. | |||||
| 509 | # | |||||
| 510 | # Entry: $method - method name string. | |||||
| 511 | # Exit: Returns a string of Perl test code. | |||||
| 512 | # Side effects: None. | |||||
| 513 | # -------------------------------------------------- | |||||
| 514 | sub _emit_void_test { | |||||
| 515 | 5 | 13 | my ($self, $method) = @_; | |||
| 516 | ||||||
| 517 | 5 | 16 | return <<"END_TEST"; | |||
| 518 | { | |||||
| 519 | my \$result = eval { \$obj->$method() }; | |||||
| 520 | ok(!\$@, '$method does not die'); | |||||
| 521 | ok(!defined \$result, '$method returns nothing (void)'); | |||||
| 522 | } | |||||
| 523 | END_TEST | |||||
| 524 | } | |||||
| 525 | ||||||
| 526 | # -------------------------------------------------- | |||||
| 527 | # _emit_boundary_test | |||||
| 528 | # | |||||
| 529 | # Purpose: Emit one smoke-test block per boundary | |||||
| 530 | # or invalid-input value detected by | |||||
| 531 | # SchemaExtractor's _yamltest_hints, calling | |||||
| 532 | # the method with each and confirming the | |||||
| 533 | # call does not crash the test process. | |||||
| 534 | # | |||||
| 535 | # Entry: $method - method name string. | |||||
| 536 | # Schema is read from $self. | |||||
| 537 | # Exit: Returns a string of Perl test code, or | |||||
| 538 | # the empty string if no hint values exist. | |||||
| 539 | # Side effects: None. | |||||
| 540 | # Notes: boundary_values and invalid_inputs are | |||||
| 541 | # deliberately tested the same way: these | |||||
| 542 | # are smoke tests proving resilience, not | |||||
| 543 | # assertions on whether the call should | |||||
| 544 | # succeed or die, since invalid_inputs are | |||||
| 545 | # expected to be rejected while boundary_values | |||||
| 546 | # are expected to be accepted. | |||||
| 547 | # -------------------------------------------------- | |||||
| 548 | sub _emit_boundary_test { | |||||
| 549 | 2 | 6 | my ($self, $method) = @_; | |||
| 550 | ||||||
| 551 | 2 | 4 | require App::Test::Generator; | |||
| 552 | ||||||
| 553 | 2 | 3 | my $hints = $self->{schema}{$method}{_yamltest_hints} || {}; | |||
| 554 | my @values = ( | |||||
| 555 | 2 | 2 | @{ $hints->{boundary_values} || [] }, | |||
| 556 | 2 2 | 2 4 | @{ $hints->{invalid_inputs} || [] }, | |||
| 557 | ); | |||||
| 558 | ||||||
| 559 | 2 | 3 | return '' unless @values; | |||
| 560 | ||||||
| 561 | 1 | 1 | my $code = ''; | |||
| 562 | 1 | 1 | for my $value (@values) { | |||
| 563 | 3 | 17 | my $literal = App::Test::Generator::perl_quote($value); | |||
| 564 | 3 | 3 | $code .= <<"END_TEST"; | |||
| 565 | { | |||||
| 566 | eval { \$obj->$method($literal) }; | |||||
| 567 | pass('$method survives boundary input $literal'); | |||||
| 568 | } | |||||
| 569 | END_TEST | |||||
| 570 | } | |||||
| 571 | ||||||
| 572 | 1 | 2 | return $code; | |||
| 573 | } | |||||
| 574 | ||||||
| 575 | 1; | |||||