TER1 (Statement): 100.00%
TER2 (Branch): 100.00%
TER3 (LCSAJ): 100.0% (7/7)
Approximate LCSAJ segments: 47
● 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::BenchmarkGenerator; 2: 3: use 5.036; 4: use Carp qw(croak); 5: use Params::Get qw(get_params); 6: use Readonly; 7: use Scalar::Util qw(looks_like_number); 8: 9: our $VERSION = '0.46'; 10: 11: Readonly 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: =head1 NAME 22: 23: App::Test::Generator::BenchmarkGenerator - Generate Benchmark harnesses from ATG schemas 24: 25: =head1 VERSION 26: 27: Version 0.46 28: 29: =head1 SYNOPSIS 30: 31: use App::Test::Generator::BenchmarkGenerator; 32: use YAML::XS qw(LoadFile); 33: 34: my $schema = LoadFile('schemas/my_func.yml'); 35: my $bg = App::Test::Generator::BenchmarkGenerator->new(schema => $schema); 36: print $bg->generate(); 37: 38: =head1 DESCRIPTION 39: 40: Given an ATG YAML schema (as produced by C<extract-schemas> or written by hand), 41: generates a self-contained Perl benchmark script using L<Benchmark/cmpthese>. 42: 43: Each transform defined in the schema becomes one variant in the C<cmpthese> call, 44: with representative input values derived from the transform's type and range 45: constraints. When no transforms are defined, a single C<'default'> variant is 46: emitted using the base input specification. 47: 48: The generated script is a plain C<.pl> file suitable for running directly with 49: C<perl>. It is not a test file and has no dependency on any test framework. 50: 51: =head1 METHODS 52: 53: =head2 new 54: 55: Construct a new BenchmarkGenerator for a given ATG schema. 56: 57: my $bg = App::Test::Generator::BenchmarkGenerator->new(schema => $schema); 58: 59: =head3 Arguments 60: 61: =over 4 62: 63: =item * C<schema> 64: 65: A hashref representing the parsed YAML schema for the target function, as 66: produced by C<extract-schemas> or written by hand. Must contain at minimum 67: C<module> and C<function> keys. Required. 68: 69: =back 70: 71: =head3 Returns 72: 73: A blessed C<App::Test::Generator::BenchmarkGenerator> object. 74: Croaks if C<schema> is missing or not a hashref. 75: 76: =head3 EXAMPLE 77: 78: use YAML::XS qw(LoadFile); 79: use App::Test::Generator::BenchmarkGenerator; 80: 81: my $schema = LoadFile('schemas/greet.yml'); 82: my $bg = App::Test::Generator::BenchmarkGenerator->new(schema => $schema); 83: print $bg->generate(); 84: 85: =head3 MESSAGES 86: 87: =over 4 88: 89: =item C<schema is required> 90: 91: C<schema> was not supplied or was C<undef>. 92: 93: =item C<schema must be a hashref> 94: 95: C<schema> was supplied but is not a plain hashref (e.g. an arrayref or string 96: was passed instead). 97: 98: =back 99: 100: =head3 API SPECIFICATION 101: 102: =head4 input 103: 104: schema => HashRef (required) - ATG schema hashref as loaded from YAML 105: 106: =head4 output 107: 108: An C<App::Test::Generator::BenchmarkGenerator> object. 109: 110: =head3 FORMAL SPECIFICATION 111: 112: Pre: C<defined schema ∧ ref(schema) eq 'HASH'> 113: 114: Post: C<ref(result) eq 'App::Test::Generator::BenchmarkGenerator'> 115: ∧ C<result-E<gt>{schema} eq schema> 116: 117: =cut 118: 119: sub new { 120: my ($class, @args) = @_; 121: my $params = get_params('schema', \@args); 122: croak 'schema is required' unless defined $params->{schema}; 123: croak 'schema must be a hashref' unless ref $params->{schema} eq 'HASH'; 124: return bless { schema => $params->{schema} }, $class;Mutants (Total: 2, Killed: 2, Survived: 0)
125: } 126: 127: =head2 generate 128: 129: Generate the complete benchmark script as a string. 130: 131: my $script = $bg->generate(); 132: write_file('benchmarks/greet.pl', $script); 133: 134: =head3 Arguments 135: 136: None beyond C<$self>. 137: 138: =head3 Returns 139: 140: A string containing the complete, self-contained Perl benchmark script 141: using C<Benchmark::cmpthese>. The string is ready to write directly to a 142: C<.pl> file and run with C<perl>. 143: 144: Croaks if the schema is missing a C<module> or C<function> key. 145: 146: =head3 EXAMPLE 147: 148: my $script = $bg->generate(); 149: # Write to file 150: open my $fh, '>', 'benchmarks/my_func.pl' or die $!; 151: print $fh $script; 152: close $fh; 153: 154: # Or run immediately: 155: require File::Temp; 156: my $tmp = File::Temp->new(SUFFIX => '.pl'); 157: print $tmp $script; 158: system($^X, "$tmp"); 159: 160: =head3 MESSAGES 161: 162: =over 4 163: 164: =item C<schema missing module> 165: 166: The schema hashref has no C<module> key. 167: 168: =item C<schema missing function> 169: 170: The schema hashref has no C<function> key. 171: 172: =back 173: 174: =head3 API SPECIFICATION 175: 176: =head4 input 177: 178: None (reads from the schema passed to C<new>). 179: 180: =head4 output 181: 182: A string containing the complete benchmark script, ready to write to a file. 183: 184: =head3 FORMAL SPECIFICATION 185: 186: Pre: C<defined schema-E<gt>{module} ∧ defined schema-E<gt>{function}> 187: 188: Post: C<result> is a syntactically valid Perl script 189: ∧ C<result> contains exactly one C<cmpthese(...)> call 190: ∧ C<|variants| == max(1, |schema-E<gt>{transforms}|)> 191: 192: =head3 PSEUDOCODE 193: 194: read module, function, input, transforms from schema 195: emit shebang, use strict/warnings, use Benchmark 196: unless module eq 'builtin': emit use $module 197: if schema has 'new' key and not builtin: 198: emit my $obj = Module->new(...) 199: if transforms defined and non-empty: 200: for each transform: build a named variant call 201: else: 202: build a single 'default' variant call 203: emit cmpthese($COUNT, { variant => sub { ... }, ... }) 204: 205: =cut 206: 207: sub generate { ●208 → 214 → 218 208: my $self = $_[0]; 209: 210: my $schema = $self->{schema}; 211: my $module = $schema->{module} // croak 'schema missing module'; 212: my $function = $schema->{function} // croak 'schema missing function'; 213: 214: unless($module eq 'builtin') {
Mutants (Total: 1, Killed: 1, Survived: 0)
215: croak("BenchmarkGenerator: module '$module' is not a valid Perl identifier") 216: unless $module =~ /^[A-Za-z_]\w*(?:::[A-Za-z_]\w*)*\z/; 217: } ●218 → 238 → 242 218: croak("BenchmarkGenerator: function '$function' is not a valid Perl identifier") 219: unless $function =~ /^[A-Za-z_]\w*(?:::[A-Za-z_]\w*)*\z/; 220: my $has_new = exists $schema->{new}; 221: my %input = %{ $schema->{input} // {} }; 222: my %xforms = %{ $schema->{transforms} // {} }; 223: 224: my $is_builtin = ($module eq 'builtin'); 225: 226: my @lines; 227: 228: 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: unless($is_builtin) {
Mutants (Total: 1, Killed: 1, Survived: 0)
239: push @lines, "use $module;"; 240: } 241: ●242 → 247 → 258 242: push @lines, 243: q{}, 244: 'my $COUNT = -3; # seconds per variant (negative = time-based)', 245: q{}; 246: 247: if($has_new && !$is_builtin) {
Mutants (Total: 1, Killed: 1, Survived: 0)
248: my $new_spec = $schema->{new}; 249: if(ref $new_spec eq 'HASH' && %$new_spec) {
Mutants (Total: 1, Killed: 1, Survived: 0)
250: my $args = join(', ', map { "$_ => " . _quote_value($new_spec->{$_}) } sort keys %$new_spec); 251: push @lines, "my \$obj = ${module}->new($args);"; 252: } else { 253: push @lines, "my \$obj = ${module}->new();"; 254: } 255: push @lines, q{}; 256: } 257: ●258 → 261 → 270 258: push @lines, "printf \"Benchmarking ${function}\\n\\n\";", q{}; 259: 260: my %variants; 261: if(%xforms) {
Mutants (Total: 1, Killed: 1, Survived: 0)
262: for my $name (sort keys %xforms) { 263: my %xinput = %{ $xforms{$name}{input} // \%input }; 264: $variants{$name} = _build_call($module, $function, $has_new, \%xinput); 265: } 266: } else { 267: $variants{'default'} = _build_call($module, $function, $has_new, \%input); 268: } 269: ●270 → 272 → 276 270: push @lines, 'cmpthese($COUNT, {'; 271: my $name_width = length((sort { length($b) <=> length($a) } keys %variants)[0]); 272: for my $name (sort keys %variants) { 273: my $padded = sprintf "%-*s", $name_width, "'$name'"; 274: push @lines, "\t$padded => sub { $variants{$name} },"; 275: } 276: push @lines, '});', q{}; 277: 278: return join("\n", @lines);
Mutants (Total: 2, Killed: 2, Survived: 0)
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: # -------------------------------------------------- 295: sub _build_call { ●296 → 301 → 317 296: my ($module, $function, $has_new, $input) = @_; 297: 298: my $has_positions = grep { defined $_->{position} } values %$input; 299: my $call; 300: 301: if($has_positions) {
Mutants (Total: 1, Killed: 1, Survived: 0)
302: my @positional = sort { $a->{position} <=> $b->{position} } 303: grep { defined $_->{position} } 304: values %$input; 305: my $args = join(', ', map { _representative_value($_) } @positional); 306: $call = $has_new ? "\$obj->$function($args)" 307: : ($module eq 'builtin' ? "$function($args)" 308: : "${module}::$function($args)"); 309: } else { 310: my @pairs = map { "$_ => " . _representative_value($input->{$_}) } 311: sort keys %$input; 312: my $args = join(', ', @pairs); 313: $call = $has_new ? "\$obj->$function($args)" 314: : "${module}::$function($args)"; 315: } 316: 317: return $call;
Mutants (Total: 2, Killed: 2, Survived: 0)
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: # -------------------------------------------------- 331: sub _representative_value { ●332 → 337 → 355 332: my ($spec) = @_; 333: return 'undef' unless defined $spec;
Mutants (Total: 2, Killed: 2, Survived: 0)
334: 335: my $type = lc($spec->{type} // 'string'); 336: 337: if($type eq 'number' || $type eq 'integer' || $type eq 'float') {
Mutants (Total: 1, Killed: 1, Survived: 0)
338: my $min = $spec->{min}; 339: my $max = $spec->{max}; 340: my $default = $TYPE_DEFAULTS{$type} // 42; 341: if(defined $min && looks_like_number($min) && defined $max && looks_like_number($max)) {
Mutants (Total: 1, Killed: 1, Survived: 0)
342: return int(($min + $max) / 2);
Mutants (Total: 2, Killed: 2, Survived: 0)
343: } 344: if(defined $min && looks_like_number($min)) {
Mutants (Total: 1, Killed: 1, Survived: 0)
345: # pick the type default if it already satisfies >= min, else min+1 346: return $default > $min ? $default : $min + 1;
Mutants (Total: 5, Killed: 5, Survived: 0)
347: } 348: if(defined $max && looks_like_number($max)) {
Mutants (Total: 1, Killed: 1, Survived: 0)
349: # pick the type default if it already satisfies <= max, else max-1 350: return $default < $max ? $default : $max - 1;
Mutants (Total: 5, Killed: 5, Survived: 0)
351: } 352: return $default;
Mutants (Total: 2, Killed: 2, Survived: 0)
353: } 354: 355: return $TYPE_DEFAULTS{$type} // "'value'";
Mutants (Total: 2, Killed: 2, Survived: 0)
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: # -------------------------------------------------- 367: sub _quote_value { 368: my ($v) = @_; 369: return 'undef' unless defined $v;
Mutants (Total: 2, Killed: 2, Survived: 0)
370: return $v if looks_like_number($v);
Mutants (Total: 2, Killed: 2, Survived: 0)
371: (my $escaped = $v) =~ s/'/\\'/g; 372: return "'$escaped'";
Mutants (Total: 2, Killed: 2, Survived: 0)
373: } 374: 375: =head1 COMMON PITFALLS 376: 377: =over 4 378: 379: =item Schema missing C<module> or C<function> 380: 381: C<generate> croaks immediately if either key is absent. Always ensure the 382: schema has been loaded from a valid ATG YAML file before calling C<generate>. 383: 384: =item Expecting test-framework output 385: 386: The generated script uses C<Benchmark::cmpthese> and prints timing results to 387: STDOUT. It is B<not> a test file and produces no TAP output. Do not run it 388: with C<prove>. 389: 390: =item OOP schemas need a C<new:> key 391: 392: If the function under benchmark is an instance method, the schema must have a 393: C<new:> key (even if its value is an empty hashref C<{}>) so C<generate> emits 394: a C<my $obj = Module->new(...)> constructor call before the C<cmpthese> block. 395: Without it, the variant calls use C<Module::function(...)> form. 396: 397: =item Transforms that omit the C<input> key 398: 399: If a transform's hashref has no C<input> key, C<generate> falls back to the 400: base schema C<input> spec for that variant. This is intentional but may 401: produce identical argument lists across variants if you forgot to add per- 402: transform input overrides. 403: 404: =back 405: 406: =head1 LIMITATIONS 407: 408: =over 4 409: 410: =item Representative values are heuristic 411: 412: C<_representative_value> picks a single value based on type and C<min>/C<max> 413: constraints. It does not guarantee the chosen value exercises any particular 414: code path, and it does not use the schema's C<enum> or C<matches> keys. 415: 416: =item No round-trip with C<extract-schemas> 417: 418: The generator reads any conforming ATG YAML schema, but it does not verify 419: that the schema accurately describes the actual function's signature. If the 420: schema is stale, the generated benchmark may pass wrong argument types. 421: 422: =back 423: 424: =head1 SEE ALSO 425: 426: =over 4 427: 428: =item L<Benchmark> 429: 430: =item C<bin/benchmark-generator> 431: 432: =item L<App::Test::Generator> 433: 434: =back 435: 436: =head1 AUTHOR 437: 438: Nigel Horne, C<< <njh at nigelhorne.com> >> 439: 440: =head1 LICENCE AND COPYRIGHT 441: 442: Copyright 2026 Nigel Horne. 443: 444: Usage is subject to the terms of GPL2. 445: If you use it, 446: please let me know. 447: 448: =cut 449: 450: 1;