File Coverage

File:blib/lib/App/Test/Generator/BenchmarkGenerator.pm
Coverage:96.0%

linestmtbrancondsubtimecode
1package App::Test::Generator::BenchmarkGenerator;
2
3
17
17
77514
38
use 5.036;
4
17
17
17
29
17
466
use Carp qw(croak);
5
17
17
17
2161
88651
446
use Params::Get qw(get_params);
6
17
17
17
39
14
346
use Readonly;
7
17
17
17
39
17
10431
use Scalar::Util qw(looks_like_number);
8
9our $VERSION = '0.46';
10
11Readonly my %TYPE_DEFAULTS => (
12        number  => 42,
13        integer => 42,
14        float   => 3.14,
15        string  => "'hello'",
16        boolean => 1,
17        arrayref => '[]',
18        hashref  => '{}',
19);
20
21 - 117
=head1 NAME

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

=head1 VERSION

Version 0.46

=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

Construct a new BenchmarkGenerator for a given ATG schema.

    my $bg = App::Test::Generator::BenchmarkGenerator->new(schema => $schema);

=head3 Arguments

=over 4

=item * C<schema>

A hashref representing the parsed YAML schema for the target function, as
produced by C<extract-schemas> or written by hand.  Must contain at minimum
C<module> and C<function> keys.  Required.

=back

=head3 Returns

A blessed C<App::Test::Generator::BenchmarkGenerator> object.
Croaks if C<schema> is missing or not a hashref.

=head3 EXAMPLE

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

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

=head3 MESSAGES

=over 4

=item C<schema is required>

C<schema> was not supplied or was C<undef>.

=item C<schema must be a hashref>

C<schema> was supplied but is not a plain hashref (e.g. an arrayref or string
was passed instead).

=back

=head3 API SPECIFICATION

=head4 input

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

=head4 output

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

=head3 FORMAL SPECIFICATION

Pre:  C<defined schema ∧ ref(schema) eq 'HASH'>

Post: C<ref(result) eq 'App::Test::Generator::BenchmarkGenerator'>
      âˆ§ C<result-E<gt>{schema} eq schema>

=cut
118
119sub new {
120
67
473442
        my ($class, @args) = @_;
121
67
117
        my $params = get_params('schema', \@args);
122
64
1017
        croak 'schema is required' unless defined $params->{schema};
123
62
127
        croak 'schema must be a hashref' unless ref $params->{schema} eq 'HASH';
124
55
109
        return bless { schema => $params->{schema} }, $class;
125}
126
127 - 205
=head2 generate

Generate the complete benchmark script as a string.

    my $script = $bg->generate();
    write_file('benchmarks/greet.pl', $script);

=head3 Arguments

None beyond C<$self>.

=head3 Returns

A string containing the complete, self-contained Perl benchmark script
using C<Benchmark::cmpthese>.  The string is ready to write directly to a
C<.pl> file and run with C<perl>.

Croaks if the schema is missing a C<module> or C<function> key.

=head3 EXAMPLE

    my $script = $bg->generate();
    # Write to file
    open my $fh, '>', 'benchmarks/my_func.pl' or die $!;
    print $fh $script;
    close $fh;

    # Or run immediately:
    require File::Temp;
    my $tmp = File::Temp->new(SUFFIX => '.pl');
    print $tmp $script;
    system($^X, "$tmp");

=head3 MESSAGES

=over 4

=item C<schema missing module>

The schema hashref has no C<module> key.

=item C<schema missing function>

The schema hashref has no C<function> key.

=back

=head3 API SPECIFICATION

=head4 input

None (reads from the schema passed to C<new>).

=head4 output

A string containing the complete benchmark script, ready to write to a file.

=head3 FORMAL SPECIFICATION

Pre:  C<defined schema-E<gt>{module} ∧ defined schema-E<gt>{function}>

Post: C<result> is a syntactically valid Perl script
      âˆ§ C<result> contains exactly one C<cmpthese(...)> call
      âˆ§ C<|variants| == max(1, |schema-E<gt>{transforms}|)>

=head3 PSEUDOCODE

    read module, function, input, transforms from schema
    emit shebang, use strict/warnings, use Benchmark
    unless module eq 'builtin': emit use $module
    if schema has 'new' key and not builtin:
        emit my $obj = Module->new(...)
    if transforms defined and non-empty:
        for each transform: build a named variant call
    else:
        build a single 'default' variant call
    emit cmpthese($COUNT, { variant => sub { ... }, ... })

=cut
206
207sub generate {
208
52
299
        my $self = $_[0];
209
210
52
63
        my $schema   = $self->{schema};
211
52
97
        my $module   = $schema->{module}   // croak 'schema missing module';
212
49
79
        my $function = $schema->{function} // croak 'schema missing function';
213
214
46
66
        unless($module eq 'builtin') {
215
23
100
                croak("BenchmarkGenerator: module '$module' is not a valid Perl identifier")
216                        unless $module =~ /^[A-Za-z_]\w*(?:::[A-Za-z_]\w*)*\z/;
217        }
218
45
124
        croak("BenchmarkGenerator: function '$function' is not a valid Perl identifier")
219                unless $function =~ /^[A-Za-z_]\w*(?:::[A-Za-z_]\w*)*\z/;
220
44
46
        my $has_new  = exists $schema->{new};
221
44
44
38
77
        my %input    = %{ $schema->{input} // {} };
222
44
44
60
99
        my %xforms   = %{ $schema->{transforms} // {} };
223
224
44
54
        my $is_builtin = ($module eq 'builtin');
225
226
44
38
        my @lines;
227
228
44
158
        push @lines,
229                '#!/usr/bin/env perl',
230                "# Benchmark for $function (" . ($is_builtin ? 'builtin' : "module: $module") . ')',
231                '# Generated by benchmark-generator (App::Test::Generator ' . $VERSION . ')',
232                '# DO NOT EDIT -- regenerate with: benchmark-generator -i SCHEMA.yml',
233                q{},
234                'use strict;',
235                'use warnings;',
236                'use Benchmark qw(cmpthese);';
237
238
44
48
        unless($is_builtin) {
239
21
21
                push @lines, "use $module;";
240        }
241
242
44
49
        push @lines,
243                q{},
244                'my $COUNT = -3;    # seconds per variant (negative = time-based)',
245                q{};
246
247
44
73
        if($has_new && !$is_builtin) {
248
7
9
                my $new_spec = $schema->{new};
249
7
51
                if(ref $new_spec eq 'HASH' && %$new_spec) {
250
2
2
4
9
                        my $args = join(', ', map { "$_ => " . _quote_value($new_spec->{$_}) } sort keys %$new_spec);
251
2
4
                        push @lines, "my \$obj = ${module}->new($args);";
252                } else {
253
5
8
                        push @lines, "my \$obj = ${module}->new();";
254                }
255
7
10
                push @lines, q{};
256        }
257
258
44
53
        push @lines, "printf \"Benchmarking ${function}\\n\\n\";", q{};
259
260
44
32
        my %variants;
261
44
57
        if(%xforms) {
262
13
45
                for my $name (sort keys %xforms) {
263
121
121
87
154
                        my %xinput = %{ $xforms{$name}{input} // \%input };
264
121
108
                        $variants{$name} = _build_call($module, $function, $has_new, \%xinput);
265                }
266        } else {
267
31
53
                $variants{'default'} = _build_call($module, $function, $has_new, \%input);
268        }
269
270
44
53
        push @lines, 'cmpthese($COUNT, {';
271
44
373
74
227
        my $name_width = length((sort { length($b) <=> length($a) } keys %variants)[0]);
272
44
78
        for my $name (sort keys %variants) {
273
152
175
                my $padded = sprintf "%-*s", $name_width, "'$name'";
274
152
148
                push @lines, "\t$padded => sub { $variants{$name} },";
275        }
276
44
51
        push @lines, '});', q{};
277
278
44
182
        return join("\n", @lines);
279}
280
281# --------------------------------------------------
282# _build_call
283#
284# Purpose:    Build the Perl expression that calls the target function
285#             with representative values derived from the input spec.
286#
287# Entry:      $module   - module name string
288#             $function - function/method name
289#             $has_new  - true if schema has 'new:' key (OOP call)
290#             $input    - hashref of param name → spec
291#
292# Exit:       Returns a Perl expression string suitable for use inside
293#             an anonymous sub in a cmpthese() call.
294# --------------------------------------------------
295sub _build_call {
296
160
8781
        my ($module, $function, $has_new, $input) = @_;
297
298
160
152
147
158
        my $has_positions = grep { defined $_->{position} } values %$input;
299
160
115
        my $call;
300
301
160
175
        if($has_positions) {
302
2
6
                my @positional = sort { $a->{position} <=> $b->{position} }
303
34
36
31
51
                                 grep { defined $_->{position} }
304                                 values %$input;
305
34
36
45
43
                my $args = join(', ', map { _representative_value($_) } @positional);
306
34
85
                $call = $has_new ? "\$obj->$function($args)"
307                                 : ($module eq 'builtin' ? "$function($args)"
308                                                         : "${module}::$function($args)");
309        } else {
310
126
116
118
109
                my @pairs = map { "$_ => " . _representative_value($input->{$_}) }
311                            sort keys %$input;
312
126
121
                my $args = join(', ', @pairs);
313
126
164
                $call = $has_new ? "\$obj->$function($args)"
314                                 : "${module}::$function($args)";
315        }
316
317
160
230
        return $call;
318}
319
320# --------------------------------------------------
321# _representative_value
322#
323# Purpose:    Return a Perl literal string that is a plausible representative
324#             value for a parameter given its schema spec.  The choice is
325#             informed by type, min, max, and enum constraints.
326#
327# Entry:      $spec - hashref with at minimum a 'type' key
328#
329# Exit:       Returns a Perl literal string (e.g. '42', "'hello'", 'undef').
330# --------------------------------------------------
331sub _representative_value {
332
202
30780
        my ($spec) = @_;
333
202
190
        return 'undef' unless defined $spec;
334
335
199
228
        my $type = lc($spec->{type} // 'string');
336
337
199
318
        if($type eq 'number' || $type eq 'integer' || $type eq 'float') {
338
173
135
                my $min = $spec->{min};
339
173
115
                my $max = $spec->{max};
340
173
254
                my $default = $TYPE_DEFAULTS{$type} // 42;
341
173
653
                if(defined $min && looks_like_number($min) && defined $max && looks_like_number($max)) {
342
6
18
                        return int(($min + $max) / 2);
343                }
344
167
178
                if(defined $min && looks_like_number($min)) {
345                        # pick the type default if it already satisfies >= min, else min+1
346
18
49
                        return $default > $min ? $default : $min + 1;
347                }
348
149
182
                if(defined $max && looks_like_number($max)) {
349                        # pick the type default if it already satisfies <= max, else max-1
350
18
45
                        return $default < $max ? $default : $max - 1;
351                }
352
131
173
                return $default;
353        }
354
355
26
71
        return $TYPE_DEFAULTS{$type} // "'value'";
356}
357
358# --------------------------------------------------
359# _quote_value
360#
361# Purpose:    Quote a scalar value for use in generated Perl source.
362#
363# Entry:      $v - scalar value (undef, number, or string)
364#
365# Exit:       Returns a Perl literal string.
366# --------------------------------------------------
367sub _quote_value {
368
22
10592
        my ($v) = @_;
369
22
34
        return 'undef' unless defined $v;
370
19
42
        return $v if looks_like_number($v);
371
10
18
        (my $escaped = $v) =~ s/'/\\'/g;
372
10
23
        return "'$escaped'";
373}
374
375 - 448
=head1 COMMON PITFALLS

=over 4

=item Schema missing C<module> or C<function>

C<generate> croaks immediately if either key is absent.  Always ensure the
schema has been loaded from a valid ATG YAML file before calling C<generate>.

=item Expecting test-framework output

The generated script uses C<Benchmark::cmpthese> and prints timing results to
STDOUT.  It is B<not> a test file and produces no TAP output.  Do not run it
with C<prove>.

=item OOP schemas need a C<new:> key

If the function under benchmark is an instance method, the schema must have a
C<new:> key (even if its value is an empty hashref C<{}>) so C<generate> emits
a C<my $obj = Module->new(...)> constructor call before the C<cmpthese> block.
Without it, the variant calls use C<Module::function(...)> form.

=item Transforms that omit the C<input> key

If a transform's hashref has no C<input> key, C<generate> falls back to the
base schema C<input> spec for that variant.  This is intentional but may
produce identical argument lists across variants if you forgot to add per-
transform input overrides.

=back

=head1 LIMITATIONS

=over 4

=item Representative values are heuristic

C<_representative_value> picks a single value based on type and C<min>/C<max>
constraints.  It does not guarantee the chosen value exercises any particular
code path, and it does not use the schema's C<enum> or C<matches> keys.

=item No round-trip with C<extract-schemas>

The generator reads any conforming ATG YAML schema, but it does not verify
that the schema accurately describes the actual function's signature.  If the
schema is stale, the generated benchmark may pass wrong argument types.

=back

=head1 SEE ALSO

=over 4

=item L<Benchmark>

=item C<bin/benchmark-generator>

=item L<App::Test::Generator>

=back

=head1 AUTHOR

Nigel Horne, C<< <njh at nigelhorne.com> >>

=head1 LICENCE AND COPYRIGHT

Copyright 2026 Nigel Horne.

Usage is subject to the terms of GPL2.
If you use it,
please let me know.

=cut
449
4501;