view release on metacpan or  search on metacpan

lib/App/Test/Generator/Emitter/Perl.pm  view on Meta::CPAN

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

sub new {
	my ($class, %args) = @_;

	# All three arguments are required for meaningful emission
	croak 'schema required'  unless defined $args{schema};
	croak 'plans required'   unless defined $args{plans};
	croak 'package required' unless defined $args{package};

	# $args{package} is spliced unescaped into use_ok()/new_ok() calls
	# in _emit_header() — reject anything that isn't a valid Perl
	# package name now, rather than generating broken or injected code.
	croak "package '$args{package}' is not a valid Perl package name"
		unless $args{package} =~ /^[A-Za-z_]\w*(?:::[A-Za-z_]\w*)*\z/;

	return bless {
		schema  => $args{schema},
		plans   => $args{plans},
		package => $args{package},
	}, $class;
}

=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

sub emit {
	my $self = $_[0];

	# Start with the file header then append per-method test blocks
	my $code = $self->_emit_header();

	# Sort methods for deterministic output order
	for my $method (sort keys %{ $self->{plans} }) {
		$code .= $self->_emit_method_tests($method);
	}

	# TAP footer required by Test::More / Test::Most
	$code .= "\ndone_testing();\n";

	return $code;
}

# --------------------------------------------------
# _emit_header
#
# Purpose:    Generate the standard test file header
#             including strict/warnings, use_ok and
#             a default object construction.
#
# Entry:      None beyond $self.
# Exit:       Returns a string of Perl code.
# Side effects: None.
# Notes:      The generated $obj is used by all
#             subsequent test blocks.
# --------------------------------------------------
sub _emit_header {
	my $self = $_[0];

	return <<"END_HEADER";
use strict;
use warnings;
use Test::Most;

use_ok('$self->{package}');

my \$obj = new_ok('$self->{package}');

END_HEADER
}

# --------------------------------------------------
# _emit_method_tests
#
# Purpose:    Dispatch to the appropriate emit method
#             for each test type flagged in the plan
#             for a given method.
#
# Entry:      $method - the method name string.
#             Plan and schema are read from $self.
# Exit:       Returns a string of Perl test code.
# Side effects: None.
# Notes:      Test types are emitted in a fixed order
#             for deterministic output. Methods with
#             no recognised plan flags produce no
#             output beyond the section comment.
# --------------------------------------------------
sub _emit_method_tests {
	my ($self, $method) = @_;

	# $method is spliced unescaped as a bareword method name
	# (->$method(...)) by every _emit_*_test sub below — reject
	# anything that isn't a valid Perl identifier before any of them run.
	croak "method '$method' is not a valid Perl identifier"
		unless $method =~ /^[A-Za-z_]\w*\z/;

	my $plan   = $self->{plans}{$method};
	my $code   = "\n# --- Tests for $method ---\n";

	# Emit each test type in a consistent fixed order
	$code .= $self->_emit_basic_test($method) if $plan->{$TEST_BASIC};

	$code .= $self->_emit_getter_test($method) if $plan->{$TEST_GETTER};

	$code .= $self->_emit_setter_test($method) if $plan->{$TEST_SETTER};

	$code .= $self->_emit_getset_test($method) if $plan->{$TEST_GETSET};

	$code .= $self->_emit_chaining_test($method) if $plan->{$TEST_CHAINING};

	$code .= $self->_emit_error_test($method) if $plan->{$TEST_ERROR_HANDLING};

	$code .= $self->_emit_context_test($method) if $plan->{$TEST_CONTEXT};

	$code .= $self->_emit_object_injection_test($method) if $plan->{$TEST_OBJECT_INJECT};

	$code .= $self->_emit_boolean_test($method) if $plan->{$TEST_PREDICATE} || $plan->{$TEST_BOOLEAN};

	$code .= $self->_emit_void_test($method) if $plan->{$TEST_VOID};

	$code .= $self->_emit_boundary_test($method) if $plan->{$TEST_BOUNDARY};

	return $code;
}

# --------------------------------------------------
# _emit_basic_test
#
# Purpose:    Emit a minimal test that calls the
#             method and verifies it does not die.
#
# Entry:      $method - method name string.
# Exit:       Returns a string of Perl test code.
# Side effects: None.
# --------------------------------------------------
sub _emit_basic_test {
	my ($self, $method) = @_;

	return <<"END_TEST";
{
	my \$result = eval { \$obj->$method() };
	ok(!\$@, '$method does not die');
}
END_TEST
}

# --------------------------------------------------
# _emit_getter_test
#
# Purpose:    Emit a test that calls the getter and
#             verifies it returns a defined value.