TER1 (Statement): 100.00%
TER2 (Branch): 100.00%
TER3 (LCSAJ): 100.0% (8/8)
Approximate LCSAJ segments: 33
● Covered — this LCSAJ path was executed during testing.
● Not covered — this LCSAJ path was never executed. These are the paths to focus on.
Multiple dots on a line indicate that multiple control-flow paths begin at that line. Hovering over any dot shows:
start → end → jump
Uncovered paths show [NOT COVERED] in the tooltip.
1: package App::Test::Generator::Emitter::Perl; 2: 3: use strict; 4: use warnings; 5: use Carp qw(croak); 6: 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.36'; 33: 34: =head1 VERSION 35: 36: Version 0.36 37: 38: =head1 DESCRIPTION 39: 40: Emits Perl test code for a set of method schemas and their associated 41: test plans. Each method plan is translated into one or more test blocks 42: using L<Test::Most>. The emitted code is returned as a string ready to 43: be written to a C<.t> file. 44: 45: =head2 new 46: 47: Construct a new Perl emitter. 48: 49: my $emitter = App::Test::Generator::Emitter::Perl->new( 50: schema => \%schemas, 51: plans => \%plans, 52: package => 'My::Module', 53: ); 54: 55: =head3 Arguments 56: 57: =over 4 58: 59: =item * C<schema> 60: 61: A hashref of method name to schema hashref. Required. 62: 63: =item * C<plans> 64: 65: A hashref of method name to test plan hashref, as produced by 66: L<App::Test::Generator::TestStrategy> or 67: L<App::Test::Generator::Planner>. Required. 68: 69: =item * C<package> 70: 71: The Perl package name of the module under test. Required. 72: 73: =back 74: 75: =head3 Returns 76: 77: A blessed hashref. Croaks if any required argument is missing. 78: 79: =head3 API specification 80: 81: =head4 input 82: 83: { 84: schema => { type => HASHREF }, 85: plans => { type => HASHREF }, 86: package => { type => SCALAR }, 87: } 88: 89: =head4 output 90: 91: { 92: type => OBJECT, 93: isa => 'App::Test::Generator::Emitter::Perl', 94: } 95: 96: =cut 97: 98: sub new { 99: my ($class, %args) = @_; 100: 101: # All three arguments are required for meaningful emission 102: croak 'schema required' unless defined $args{schema}; 103: croak 'plans required' unless defined $args{plans}; 104: croak 'package required' unless defined $args{package}; 105: 106: return bless { 107: schema => $args{schema}, 108: plans => $args{plans}, 109: package => $args{package}, 110: }, $class; 111: } 112: 113: =head2 emit 114: 115: Generate and return the complete Perl test file source as a string, 116: including the file header, one test block per method, and the 117: C<done_testing()> footer. 118: 119: my $emitter = App::Test::Generator::Emitter::Perl->new( 120: schema => \%schemas, 121: plans => \%plans, 122: package => 'My::Module', 123: ); 124: my $test_code = $emitter->emit; 125: write_file('t/generated.t', $test_code); 126: 127: =head3 Arguments 128: 129: None beyond C<$self>. 130: 131: =head3 Returns 132: 133: A string containing the complete Perl test file source. 134: 135: =head3 API specification 136: 137: =head4 input 138: 139: { 140: self => { type => OBJECT, isa => 'App::Test::Generator::Emitter::Perl' }, 141: } 142: 143: =head4 output 144: 145: { type => SCALAR } 146: 147: =cut 148: 149: sub emit { ●150 → 156 → 161●150 → 156 → 0 150: my $self = $_[0]; 151: 152: # Start with the file header then append per-method test blocks 153: my $code = $self->_emit_header(); 154: 155: # Sort methods for deterministic output order 156: for my $method (sort keys %{ $self->{plans} }) { 157: $code .= $self->_emit_method_tests($method); 158: } 159: 160: # TAP footer required by Test::More / Test::Most ●161 → 163 → 0 161: $code .= "\ndone_testing();\n"; 162: 163: return $code;Mutants (Total: 2, Killed: 2, Survived: 0)
164: } 165: 166: # -------------------------------------------------- 167: # _emit_header 168: # 169: # Purpose: Generate the standard test file header 170: # including strict/warnings, use_ok and 171: # a default object construction. 172: # 173: # Entry: None beyond $self. 174: # Exit: Returns a string of Perl code. 175: # Side effects: None. 176: # Notes: The generated $obj is used by all 177: # subsequent test blocks. 178: # -------------------------------------------------- 179: sub _emit_header { 180: my $self = $_[0]; 181: 182: return <<"END_HEADER";
Mutants (Total: 2, Killed: 2, Survived: 0)
183: use strict; 184: use warnings; 185: use Test::Most; 186: 187: use_ok('$self->{package}'); 188: 189: my \$obj = new_ok('$self->{package}'); 190: 191: END_HEADER 192: } 193: 194: # -------------------------------------------------- 195: # _emit_method_tests 196: # 197: # Purpose: Dispatch to the appropriate emit method 198: # for each test type flagged in the plan 199: # for a given method. 200: # 201: # Entry: $method - the method name string. 202: # Plan and schema are read from $self. 203: # Exit: Returns a string of Perl test code. 204: # Side effects: None. 205: # Notes: Test types are emitted in a fixed order 206: # for deterministic output. Methods with 207: # no recognised plan flags produce no 208: # output beyond the section comment. 209: # -------------------------------------------------- 210: sub _emit_method_tests { 211: my ($self, $method) = @_; 212: 213: my $plan = $self->{plans}{$method}; 214: my $code = "\n# --- Tests for $method ---\n"; 215: 216: # Emit each test type in a consistent fixed order 217: $code .= $self->_emit_basic_test($method) if $plan->{$TEST_BASIC}; 218: 219: $code .= $self->_emit_getter_test($method) if $plan->{$TEST_GETTER}; 220: 221: $code .= $self->_emit_setter_test($method) if $plan->{$TEST_SETTER}; 222: 223: $code .= $self->_emit_getset_test($method) if $plan->{$TEST_GETSET}; 224: 225: $code .= $self->_emit_chaining_test($method) if $plan->{$TEST_CHAINING}; 226: 227: $code .= $self->_emit_error_test($method) if $plan->{$TEST_ERROR_HANDLING}; 228: 229: $code .= $self->_emit_context_test($method) if $plan->{$TEST_CONTEXT}; 230: 231: $code .= $self->_emit_object_injection_test($method) if $plan->{$TEST_OBJECT_INJECT}; 232: 233: $code .= $self->_emit_boolean_test($method) if $plan->{$TEST_PREDICATE} || $plan->{$TEST_BOOLEAN}; 234: 235: $code .= $self->_emit_void_test($method) if $plan->{$TEST_VOID}; 236: 237: return $code;
Mutants (Total: 2, Killed: 2, Survived: 0)
238: } 239: 240: # -------------------------------------------------- 241: # _emit_basic_test 242: # 243: # Purpose: Emit a minimal test that calls the 244: # method and verifies it does not die. 245: # 246: # Entry: $method - method name string. 247: # Exit: Returns a string of Perl test code. 248: # Side effects: None. 249: # -------------------------------------------------- 250: sub _emit_basic_test { 251: my ($self, $method) = @_; 252: 253: return <<"END_TEST";
Mutants (Total: 2, Killed: 2, Survived: 0)
254: { 255: my \$result = eval { \$obj->$method() }; 256: ok(!\$@, '$method does not die'); 257: } 258: END_TEST 259: } 260: 261: # -------------------------------------------------- 262: # _emit_getter_test 263: # 264: # Purpose: Emit a test that calls the getter and 265: # verifies it returns a defined value. 266: # 267: # Entry: $method - method name string. 268: # Exit: Returns a string of Perl test code. 269: # Side effects: None. 270: # -------------------------------------------------- 271: sub _emit_getter_test { 272: my ($self, $method) = @_; 273: 274: return <<"END_TEST";
Mutants (Total: 2, Killed: 2, Survived: 0)
275: { 276: my \$value = \$obj->$method(); 277: ok(defined \$value, '$method returns a value'); 278: } 279: END_TEST 280: } 281: 282: # -------------------------------------------------- 283: # _emit_setter_test 284: # 285: # Purpose: Emit a test that calls the setter with 286: # a string argument and verifies it 287: # accepts the input without dying. 288: # 289: # Entry: $method - method name string. 290: # Exit: Returns a string of Perl test code. 291: # Side effects: None. 292: # -------------------------------------------------- 293: sub _emit_setter_test { 294: my ($self, $method) = @_; 295: 296: return <<"END_TEST";
Mutants (Total: 2, Killed: 2, Survived: 0)
297: { 298: ok(\$obj->$method('test'), '$method accepts input'); 299: } 300: END_TEST 301: } 302: 303: # -------------------------------------------------- 304: # _emit_getset_test 305: # 306: # Purpose: Emit a round-trip get/set test. The 307: # test type (object, boolean, or string) 308: # is determined from the schema input 309: # parameter type. 310: # 311: # Entry: $method - method name string. 312: # Schema is read from $self. 313: # Exit: Returns a string of Perl test code. 314: # Side effects: None. 315: # Notes: Falls back to string round-trip if the 316: # parameter type is unrecognised. 317: # -------------------------------------------------- 318: sub _emit_getset_test { ●319 → 328 → 339●319 → 328 → 0 319: my ($self, $method) = @_; 320: 321: my $schema = $self->{schema}{$method}; 322: 323: # Find the first non-internal input parameter 324: my ($param) = grep { !/^_/ } keys %{ $schema->{input} || {} }; 325: my $type = ($param && $schema->{input}{$param}{type}) // ''; 326: 327: # Object injection round-trip 328: if($type eq $TYPE_OBJECT) {
Mutants (Total: 1, Killed: 1, Survived: 0)
329: return <<"END_TEST";
Mutants (Total: 2, Killed: 2, Survived: 0)
330: { 331: my \$mock = bless {}, 'Test::MockObject'; 332: \$obj->$method(\$mock); 333: isa_ok(\$obj->$method(), ref(\$mock), '$method get/set works'); 334: } 335: END_TEST 336: } 337: 338: # Boolean round-trip ●339 → 339 → 351●339 → 339 → 0 339: if($type eq $TYPE_BOOLEAN) {
Mutants (Total: 1, Killed: 1, Survived: 0)
340: return <<"END_TEST";
Mutants (Total: 2, Killed: 2, Survived: 0)
341: { 342: \$obj->$method(1); 343: ok(\$obj->$method(), '$method get/set boolean true works'); 344: \$obj->$method(0); 345: ok(!\$obj->$method(), '$method get/set boolean false works'); 346: } 347: END_TEST 348: } 349: 350: # Default string round-trip ●351 → 351 → 0 351: return <<"END_TEST";
Mutants (Total: 2, Killed: 2, Survived: 0)
352: { 353: \$obj->$method('value'); 354: is(\$obj->$method(), 'value', '$method get/set works'); 355: } 356: END_TEST 357: } 358: 359: # -------------------------------------------------- 360: # _emit_chaining_test 361: # 362: # Purpose: Emit a test that verifies the method 363: # returns $self for method chaining. 364: # 365: # Entry: $method - method name string. 366: # Exit: Returns a string of Perl test code. 367: # Side effects: None. 368: # -------------------------------------------------- 369: sub _emit_chaining_test { 370: my ($self, $method) = @_; 371: 372: return <<"END_TEST";
Mutants (Total: 2, Killed: 2, Survived: 0)
373: { 374: my \$ret = \$obj->$method(); 375: isa_ok(\$ret, ref(\$obj), '$method returns self for chaining'); 376: } 377: END_TEST 378: } 379: 380: # -------------------------------------------------- 381: # _emit_error_test 382: # 383: # Purpose: Emit a test that calls the method with 384: # undef input and verifies it handles the 385: # error gracefully. 386: # 387: # Entry: $method - method name string. 388: # Exit: Returns a string of Perl test code. 389: # Side effects: None. 390: # -------------------------------------------------- 391: sub _emit_error_test { 392: my ($self, $method) = @_; 393: 394: return <<"END_TEST";
Mutants (Total: 2, Killed: 2, Survived: 0)
395: { 396: my \$result = eval { \$obj->$method(undef) }; 397: ok(!\$result || \$@, '$method handles invalid input'); 398: } 399: END_TEST 400: } 401: 402: # -------------------------------------------------- 403: # _emit_context_test 404: # 405: # Purpose: Emit tests that call the method in 406: # both scalar and list context to verify 407: # context-aware return behaviour. 408: # 409: # Entry: $method - method name string. 410: # Exit: Returns a string of Perl test code. 411: # Side effects: None. 412: # Notes: Uses eval to verify the calls survive 413: # rather than checking return values, 414: # since context-aware return values vary. 415: # -------------------------------------------------- 416: sub _emit_context_test { 417: my ($self, $method) = @_; 418: 419: return <<"END_TEST";
Mutants (Total: 2, Killed: 2, Survived: 0)
420: { 421: my \$scalar = eval { \$obj->$method() }; 422: ok(!\$@, '$method survives in scalar context'); 423: 424: my \@list = eval { \$obj->$method() }; 425: ok(!\$@, '$method survives in list context'); 426: } 427: END_TEST 428: } 429: 430: # -------------------------------------------------- 431: # _emit_object_injection_test 432: # 433: # Purpose: Emit a test that injects a mock object 434: # and verifies the same object is returned 435: # by the getter. 436: # 437: # Entry: $method - method name string. 438: # Exit: Returns a string of Perl test code. 439: # Side effects: None. 440: # -------------------------------------------------- 441: sub _emit_object_injection_test { 442: my ($self, $method) = @_; 443: 444: return <<"END_TEST";
Mutants (Total: 2, Killed: 2, Survived: 0)
445: { 446: my \$mock = bless {}, 'Mock::Object'; 447: \$obj->$method(\$mock); 448: isa_ok(\$obj->$method(), 'Mock::Object', 449: '$method stores injected object instance'); 450: } 451: END_TEST 452: } 453: 454: # -------------------------------------------------- 455: # _emit_boolean_test 456: # 457: # Purpose: Emit a test that verifies the method 458: # returns a defined scalar boolean value. 459: # 460: # Entry: $method - method name string. 461: # Exit: Returns a string of Perl test code. 462: # Side effects: None. 463: # Notes: Checks that the return value is defined, 464: # is not a reference, and is boolean-like 465: # without using numeric comparison which 466: # would warn on string returns. 467: # -------------------------------------------------- 468: sub _emit_boolean_test { 469: my ($self, $method) = @_; 470: 471: return <<"END_TEST";
Mutants (Total: 2, Killed: 2, Survived: 0)
472: { 473: my \$result = \$obj->$method(); 474: ok(defined \$result, '$method returns a defined value'); 475: ok(!ref \$result, '$method returns a scalar'); 476: ok(\$result ? 1 : 0, '$method returns a boolean-like value'); 477: } 478: END_TEST 479: } 480: 481: # -------------------------------------------------- 482: # _emit_void_test 483: # 484: # Emit a test that verifies the method 485: # does not return a meaningful value, 486: # consistent with a void return type. 487: # 488: # Entry: $method - method name string. 489: # Exit: Returns a string of Perl test code. 490: # Side effects: None. 491: # -------------------------------------------------- 492: sub _emit_void_test { 493: my ($self, $method) = @_; 494: 495: return <<"END_TEST";
Mutants (Total: 2, Killed: 2, Survived: 0)
496: { 497: my \$result = eval { \$obj->$method() }; 498: ok(!\$@, '$method does not die'); 499: ok(!defined \$result, '$method returns nothing (void)'); 500: } 501: END_TEST 502: } 503: 504: 1;