view release on metacpan or  search on metacpan

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

package App::Test::Generator::BenchmarkGenerator;

use 5.036;
use Carp qw(croak);
use Params::Get qw(get_params);
use Readonly;
use Scalar::Util qw(looks_like_number);

our $VERSION = '0.43';

Readonly my %TYPE_DEFAULTS => (
	number  => 42,
	integer => 42,
	float   => 3.14,
	string  => "'hello'",
	boolean => 1,
	arrayref => '[]',
	hashref  => '{}',
);

=head1 NAME

App::Test::Generator::BenchmarkGenerator - Generate Benchmark harnesses from ATG schemas

=head1 VERSION

Version 0.43

=head1 SYNOPSIS

    use App::Test::Generator::BenchmarkGenerator;
    use YAML::XS qw(LoadFile);

    my $schema = LoadFile('schemas/my_func.yml');
    my $bg     = App::Test::Generator::BenchmarkGenerator->new(schema => $schema);
    print $bg->generate();

=head1 DESCRIPTION

Given an ATG YAML schema (as produced by C<extract-schemas> or written by hand),
generates a self-contained Perl benchmark script using L<Benchmark/cmpthese>.

Each transform defined in the schema becomes one variant in the C<cmpthese> call,
with representative input values derived from the transform's type and range
constraints.  When no transforms are defined, a single C<'default'> variant is
emitted using the base input specification.

The generated script is a plain C<.pl> file suitable for running directly with
C<perl>.  It is not a test file and has no dependency on any test framework.

=head1 METHODS

=head2 new

=head3 API SPECIFICATION

=head4 input

    schema   => HashRef   (required) - ATG schema hashref as loaded from YAML

=head4 output

An C<App::Test::Generator::BenchmarkGenerator> object.

=cut

sub new {

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

# --------------------------------------------------
# _build_call
#
# Purpose:    Build the Perl expression that calls the target function
#             with representative values derived from the input spec.
#
# Entry:      $module   - module name string
#             $function - function/method name
#             $has_new  - true if schema has 'new:' key (OOP call)
#             $input    - hashref of param name → spec
#
# Exit:       Returns a Perl expression string suitable for use inside
#             an anonymous sub in a cmpthese() call.
# --------------------------------------------------
sub _build_call {
	my ($module, $function, $has_new, $input) = @_;

	my $has_positions = grep { defined $_->{position} } values %$input;
	my $call;

	if($has_positions) {
		my @positional = sort { $a->{position} <=> $b->{position} }
		                 grep { defined $_->{position} }
		                 values %$input;
		my $args = join(', ', map { _representative_value($_) } @positional);
		$call = $has_new ? "\$obj->$function($args)"
		                 : ($module eq 'builtin' ? "$function($args)"
		                                         : "${module}::$function($args)");
	} else {
		my @pairs = map { "$_ => " . _representative_value($input->{$_}) }
		            sort keys %$input;
		my $args = join(', ', @pairs);
		$call = $has_new ? "\$obj->$function($args)"
		                 : "${module}::$function($args)";
	}

	return $call;
}

# --------------------------------------------------
# _representative_value
#
# Purpose:    Return a Perl literal string that is a plausible representative
#             value for a parameter given its schema spec.  The choice is
#             informed by type, min, max, and enum constraints.
#
# Entry:      $spec - hashref with at minimum a 'type' key
#
# Exit:       Returns a Perl literal string (e.g. '42', "'hello'", 'undef').
# --------------------------------------------------
sub _representative_value {
	my ($spec) = @_;
	return 'undef' unless defined $spec;

	my $type = lc($spec->{type} // 'string');

	if($type eq 'number' || $type eq 'integer' || $type eq 'float') {
		my $min = $spec->{min};
		my $max = $spec->{max};
		my $default = $TYPE_DEFAULTS{$type} // 42;
		if(defined $min && looks_like_number($min) && defined $max && looks_like_number($max)) {
			return int(($min + $max) / 2);
		}
		if(defined $min && looks_like_number($min)) {
			# pick the type default if it already satisfies >= min, else min+1
			return $default > $min ? $default : $min + 1;
		}
		if(defined $max && looks_like_number($max)) {
			# pick the type default if it already satisfies <= max, else max-1
			return $default < $max ? $default : $max - 1;
		}
		return $default;
	}

	return $TYPE_DEFAULTS{$type} // "'value'";
}

# --------------------------------------------------
# _quote_value
#
# Purpose:    Quote a scalar value for use in generated Perl source.
#
# Entry:      $v - scalar value (undef, number, or string)
#
# Exit:       Returns a Perl literal string.
# --------------------------------------------------
sub _quote_value {
	my ($v) = @_;
	return 'undef' unless defined $v;
	return $v if looks_like_number($v);
	(my $escaped = $v) =~ s/'/\\'/g;
	return "'$escaped'";
}

=head1 AUTHOR

Nigel Horne

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

1;