File Coverage

File:blib/lib/App/Test/Generator/Emitter/Perl.pm
Coverage:98.4%

linestmtbrancondsubtimecode
1package App::Test::Generator::Emitter::Perl;
2
3
5
5
5
5
132486
6
68
use strict;
4
5
5
5
5
9
3
92
use warnings;
5
5
5
5
5
9
4
96
use Carp qw(croak);
6
5
5
5
5
395
3367
2538
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# --------------------------------------------------
13Readonly my $TEST_BASIC           => 'basic_test';
14Readonly my $TEST_GETTER          => 'getter_test';
15Readonly my $TEST_SETTER          => 'setter_test';
16Readonly my $TEST_GETSET          => 'getset_test';
17Readonly my $TEST_CHAINING        => 'chaining_test';
18Readonly my $TEST_ERROR_HANDLING  => 'error_handling_test';
19Readonly my $TEST_CONTEXT         => 'context_tests';
20Readonly my $TEST_OBJECT_INJECT   => 'object_injection_test';
21Readonly my $TEST_PREDICATE       => 'predicate_test';
22Readonly my $TEST_BOOLEAN         => 'boolean_test';
23Readonly my $TEST_VOID            => 'void_context_test';
24Readonly my $TEST_BOUNDARY        => 'boundary_tests';
25
26# --------------------------------------------------
27# Input/output type strings from the schema
28# --------------------------------------------------
29Readonly my $TYPE_OBJECT  => 'object';
30Readonly my $TYPE_BOOLEAN => 'boolean';
31
32our $VERSION = '0.36';
33
34 - 96
=head1 VERSION

Version 0.36

=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
98sub new {
99
116
116
987703
        my ($class, %args) = @_;
100
101        # All three arguments are required for meaningful emission
102
116
100
172
        croak 'schema required'  unless defined $args{schema};
103
114
100
124
        croak 'plans required'   unless defined $args{plans};
104
112
100
110
        croak 'package required' unless defined $args{package};
105
106        return bless {
107                schema  => $args{schema},
108                plans   => $args{plans},
109                package => $args{package},
110
110
228
        }, $class;
111}
112
113 - 147
=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 API specification

=head4 input

    {
        self => { type => OBJECT, isa => 'App::Test::Generator::Emitter::Perl' },
    }

=head4 output

    { type => SCALAR }

=cut
148
149sub emit {
150
59
59
165
        my $self = $_[0];
151
152        # Start with the file header then append per-method test blocks
153
59
78
        my $code = $self->_emit_header();
154
155        # Sort methods for deterministic output order
156
59
59
49
109
        for my $method (sort keys %{ $self->{plans} }) {
157
114
131
                $code .= $self->_emit_method_tests($method);
158        }
159
160        # TAP footer required by Test::More / Test::Most
161
59
51
        $code .= "\ndone_testing();\n";
162
163
59
105
        return $code;
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# --------------------------------------------------
179sub _emit_header {
180
66
66
45
        my $self = $_[0];
181
182
66
108
        return <<"END_HEADER";
183use strict;
184use warnings;
185use Test::Most;
186
187use_ok('$self->{package}');
188
189my \$obj = new_ok('$self->{package}');
190
191END_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# --------------------------------------------------
210sub _emit_method_tests {
211
131
131
119
        my ($self, $method) = @_;
212
213
131
105
        my $plan   = $self->{plans}{$method};
214
131
93
        my $code   = "\n# --- Tests for $method ---\n";
215
216        # Emit each test type in a consistent fixed order
217
131
100
186
        $code .= $self->_emit_basic_test($method) if $plan->{$TEST_BASIC};
218
219
131
100
255
        $code .= $self->_emit_getter_test($method) if $plan->{$TEST_GETTER};
220
221
131
100
291
        $code .= $self->_emit_setter_test($method) if $plan->{$TEST_SETTER};
222
223
131
100
273
        $code .= $self->_emit_getset_test($method) if $plan->{$TEST_GETSET};
224
225
131
100
260
        $code .= $self->_emit_chaining_test($method) if $plan->{$TEST_CHAINING};
226
227
131
100
278
        $code .= $self->_emit_error_test($method) if $plan->{$TEST_ERROR_HANDLING};
228
229
131
100
270
        $code .= $self->_emit_context_test($method) if $plan->{$TEST_CONTEXT};
230
231
131
100
299
        $code .= $self->_emit_object_injection_test($method) if $plan->{$TEST_OBJECT_INJECT};
232
233
131
100
67
272
        $code .= $self->_emit_boolean_test($method) if $plan->{$TEST_PREDICATE} || $plan->{$TEST_BOOLEAN};
234
235
131
100
519
        $code .= $self->_emit_void_test($method) if $plan->{$TEST_VOID};
236
237
131
347
        return $code;
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# --------------------------------------------------
250sub _emit_basic_test {
251
65
65
173
        my ($self, $method) = @_;
252
253
65
66
        return <<"END_TEST";
254{
255        my \$result = eval { \$obj->$method() };
256        ok(!\$@, '$method does not die');
257}
258END_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# --------------------------------------------------
271sub _emit_getter_test {
272
13
13
48
        my ($self, $method) = @_;
273
274
13
25
        return <<"END_TEST";
275{
276        my \$value = \$obj->$method();
277        ok(defined \$value, '$method returns a value');
278}
279END_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# --------------------------------------------------
293sub _emit_setter_test {
294
12
12
37
        my ($self, $method) = @_;
295
296
12
17
        return <<"END_TEST";
297{
298        ok(\$obj->$method('test'), '$method accepts input');
299}
300END_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# --------------------------------------------------
318sub _emit_getset_test {
319
21
21
77
        my ($self, $method) = @_;
320
321
21
21
        my $schema  = $self->{schema}{$method};
322
323        # Find the first non-internal input parameter
324
21
14
21
100
16
30
39
        my ($param) = grep { !/^_/ } keys %{ $schema->{input} || {} };
325
21
67
68
        my $type    = ($param && $schema->{input}{$param}{type}) // '';
326
327        # Object injection round-trip
328
21
100
43
        if($type eq $TYPE_OBJECT) {
329
4
16
                return <<"END_TEST";
330{
331        my \$mock = bless {}, 'Test::MockObject';
332        \$obj->$method(\$mock);
333        isa_ok(\$obj->$method(), ref(\$mock), '$method get/set works');
334}
335END_TEST
336        }
337
338        # Boolean round-trip
339
17
100
61
        if($type eq $TYPE_BOOLEAN) {
340
4
22
                return <<"END_TEST";
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}
347END_TEST
348        }
349
350        # Default string round-trip
351
13
44
        return <<"END_TEST";
352{
353        \$obj->$method('value');
354        is(\$obj->$method(), 'value', '$method get/set works');
355}
356END_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# --------------------------------------------------
369sub _emit_chaining_test {
370
7
7
23
        my ($self, $method) = @_;
371
372
7
13
        return <<"END_TEST";
373{
374        my \$ret = \$obj->$method();
375        isa_ok(\$ret, ref(\$obj), '$method returns self for chaining');
376}
377END_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# --------------------------------------------------
391sub _emit_error_test {
392
7
7
26
        my ($self, $method) = @_;
393
394
7
26
        return <<"END_TEST";
395{
396        my \$result = eval { \$obj->$method(undef) };
397        ok(!\$result || \$@, '$method handles invalid input');
398}
399END_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# --------------------------------------------------
416sub _emit_context_test {
417
4
4
15
        my ($self, $method) = @_;
418
419
4
7
        return <<"END_TEST";
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}
427END_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# --------------------------------------------------
441sub _emit_object_injection_test {
442
6
6
27
        my ($self, $method) = @_;
443
444
6
11
        return <<"END_TEST";
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}
451END_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# --------------------------------------------------
468sub _emit_boolean_test {
469
8
8
43
        my ($self, $method) = @_;
470
471
8
17
        return <<"END_TEST";
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}
478END_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# --------------------------------------------------
492sub _emit_void_test {
493
5
5
17
        my ($self, $method) = @_;
494
495
5
17
        return <<"END_TEST";
496{
497        my \$result = eval { \$obj->$method() };
498        ok(!\$@,          '$method does not die');
499        ok(!defined \$result, '$method returns nothing (void)');
500}
501END_TEST
502}
503
5041;