App-Test-Generator
view release on metacpan or search on metacpan
bin/fuzz-harness-generator view on Meta::CPAN
}
$t .= "\nplan tests => $test_count;\n\n";
for my $i (0 .. $#tests) {
my $test = $tests[$i];
my $n = $i + 1;
my $input = _format_input($test->{'input'});
my $label = "$test->{'method'} does not die on input from $test->{'file'}";
# Flatten and escape the original error for use as a comment
(my $orig_error = $test->{'error'} // '') =~ s/\n/ /g;
$orig_error =~ s/'/\\'/g;
$t .= "# Corpus bug: $orig_error\n";
$t .= "lives_ok { $test->{'module'}\->$test->{'method'}($input) }\n";
$t .= " '$label';\n\n";
}
return $t;
}
bin/fuzz-harness-generator view on Meta::CPAN
# directly in generated test source code.
#
# Entry: $input - the input value to format.
# May be undef, a numeric string,
# or an arbitrary string.
#
# Exit: Returns a Perl literal string:
# 'undef' if $input is undef
# bare number if $input looks numeric
# single-quoted string otherwise, with
# backslashes and single quotes escaped.
#
# Side effects: None.
#
# Notes: Only scalar inputs are handled — corpus
# entries with arrayref or hashref inputs
# are not currently supported and will be
# formatted as a single-quoted string of
# the stringified reference, which will
# not reproduce the original input.
# --------------------------------------------------
sub _format_input {
my ($input) = @_;
return 'undef' unless defined $input;
# Emit bare numeric literals without quoting
return $input if $input =~ /^-?(?:\d+\.?\d*|\.\d+)$/;
# Escape backslashes first, then single quotes, to avoid
# double-escaping when both appear in the same string
(my $escaped = $input) =~ s/\\/\\\\/g;
$escaped =~ s/'/\\'/g;
return "'$escaped'";
}
# --------------------------------------------------
# _infer_module_from_schema
#
# Purpose: Attempt to determine the Perl module
# name for a given corpus method by
# locating and reading the companion YAML
# schema file that sits alongside the
# corpus directory.
bin/test-generator-index view on Meta::CPAN
use Getopt::Long qw(GetOptions);
use IPC::Run3;
use JSON::MaybeXS;
use List::Util qw(max min);
use POSIX qw(strftime);
use HTML::Entities;
use HTTP::Tiny;
use Readonly;
use Storable qw(dclone);
use Time::HiRes qw(sleep);
use URI::Escape qw(uri_escape);
use version;
use WWW::RT::CPAN;
use YAML::XS qw(LoadFile);
=head1 NAME
test-generator-index - Test coverage dashboard generator
=head1 DESCRIPTION
bin/test-generator-index view on Meta::CPAN
# Now calculate deltas and create JavaScript data points
my @data_points;
my $prev_pct;
foreach my $point (@data_points_with_time) {
my $delta = defined $prev_pct ? sprintf('%.1f', $point->{pct} - $prev_pct) : 0;
$prev_pct = $point->{pct};
my $color = $delta > 0 ? 'green' : $delta < 0 ? 'red' : 'gray';
my $comment = js_escape($point->{comment});
push @data_points, qq{{ x: "$point->{timestamp}", y: $point->{pct}, delta: $delta, url: "$point->{url}", label: "$point->{timestamp}", pointBackgroundColor: "$color", comment: "$comment" }};
}
if(scalar(@data_points)) {
push @html, <<'HTML';
<div style="display: flex; justify-content: space-between; align-items: center; margin-bottom: 1em;">
<div>
<h2>Coverage Trend</h2>
<label>
<input type="checkbox" id="toggleTrend" checked>
bin/test-generator-index view on Meta::CPAN
'</p>';
} else {
push @html, "<p>No issues active on <a href=\"$rt_url\">RT</a></p>";
}
}
# -------------------------------
# CPAN Testers failing reports table
# -------------------------------
my $dist_name = $config{github_repo};
my $cpan_api = "https://api.cpantesters.org/v3/summary/" . uri_escape($dist_name);
my $http = HTTP::Tiny->new(agent => 'cpan-coverage-html/1.0', timeout => 30);
my $retry = 0;
my $success = 0;
my $res;
# Try a number of times because the cpantesters website can get overloaded
while($retry < $config{max_retry}) {
bin/test-generator-index view on Meta::CPAN
sub run_git {
my @cmd = @_;
my ($out, $err);
run3 ['git', @cmd], \undef, \$out, \$err;
return unless $? == 0;
chomp $out;
return $out;
}
# --------------------------------------------------
# js_escape
#
# Purpose: Escape a string for safe embedding in a
# JavaScript double-quoted string literal
# in generated HTML.
#
# Entry: $str - the string to escape.
#
# Exit: Returns the escaped string. Backslashes
# are doubled, double quotes are escaped,
# and newlines are replaced with \n.
#
# Side effects: None.
#
# Notes: Does not escape single quotes or other
# JS metacharacters — only the minimum
# needed for double-quoted string context.
# --------------------------------------------------
sub js_escape {
my $str = $_[0];
$str =~ s/\\/\\\\/g;
$str =~ s/"/\\"/g;
$str =~ s/\n/\\n/g;
return $str;
}
# --------------------------------------------------
# fetch_reports_by_grades
#
bin/test-generator-index view on Meta::CPAN
# in a single request.
# --------------------------------------------------
sub fetch_reports_by_grades {
my ($dist, $version, @grades) = @_;
my %seen;
my @reports;
for my $grade (@grades) {
my $url = 'https://api.cpantesters.org/v3/summary/'
. uri_escape($dist)
. '/' . uri_escape($version)
. "?grade=$grade";
my $res = $http->get($url);
next unless $res->{success};
my $arr = eval { decode_json($res->{content}) };
next unless ref $arr eq 'ARRAY';
for my $r (@$arr) {
my $key = make_key($r);
lib/App/Test/Generator.pm view on Meta::CPAN
# No positional arguments found in any field
return 0;
}
# --------------------------------------------------
# q_wrap
#
# Purpose: Wrap a string in the most readable
# q{} form that does not require escaping,
# falling back to single-quoted form with
# escaped apostrophes if no delimiter is
# available.
#
# Entry: $s - the string to wrap. May be undef.
# Exit: Returns a Perl source-code fragment that
# evaluates to the original string value,
# or the string 'undef' if $s is undef.
#
# Side effects: None.
#
# Notes: index() returns -1 when not found and
lib/App/Test/Generator.pm view on Meta::CPAN
}
# Try single-character delimiters in preference order
for my $d (@Q_SINGLE_DELIMITERS) {
# index() returns $INDEX_NOT_FOUND (-1) when not found.
# Must use != $INDEX_NOT_FOUND rather than > 0 since
# the delimiter may legitimately appear at position 0
return "q$d$s$d" if index($s, $d) == $INDEX_NOT_FOUND;
}
# Last resort — single-quoted string with escaped apostrophes
(my $esc = $s) =~ s/'/\\'/g;
return "'$esc'";
}
# --------------------------------------------------
# perl_sq
#
# Purpose: Escape a string for safe inclusion
# inside a single-quoted Perl string
# literal in generated test code.
#
# Entry: $s - the string to escape.
# Exit: Returns the escaped string, or an
# empty string if $s is undef.
#
# Side effects: None.
#
# Notes: NUL byte replacement produces the
# two-character sequence \0 which is
# only correct when the result is used
# inside a double-quoted string context
# in the generated test.
#
lib/App/Test/Generator.pm view on Meta::CPAN
sub perl_sq {
my $s = $_[0];
croak('perl_sq: argument must be a plain string, not a reference') if ref($s);
# Return empty string for undef — callers that need
# 'undef' literal should use perl_quote instead
return '' unless defined $s;
# Escape backslashes first so later substitutions
# don't double-escape already-escaped sequences
$s =~ s/\\/\\\\/g;
# Escape apostrophes so they don't terminate the
# surrounding single-quoted string literal
$s =~ s/'/\\'/g;
# Escape common control characters to their
# printable two-character escape sequences
$s =~ s/\n/\\n/g;
$s =~ s/\r/\\r/g;
$s =~ s/\t/\\t/g;
$s =~ s/\f/\\f/g;
# Replace NUL bytes with \0 — valid only in
# double-quoted string context in generated code
$s =~ s/\0/\\0/g;
return $s;
lib/App/Test/Generator/SchemaExtractor.pm view on Meta::CPAN
=item * Parameter lists: C<$param - type, default 'value'>
=back
=head3 Value Processing
Properly handles:
=over 4
=item * String literals with quotes and escape sequences
=item * Numeric values (integers and floats)
=item * Boolean values (true/false converted to 1/0)
=item * Empty data structures ([] and {})
=item * Special values (undef, __PACKAGE__)
=item * Complex expressions (preserved as-is when unevaluatable)
lib/App/Test/Generator/SchemaExtractor.pm view on Meta::CPAN
return unless defined $param && $param =~ /^\w+$/;
# ref() check for CODE
if ($code =~ /ref\s*\(\s*\$$param\s*\)\s*eq\s*['"]CODE['"]/i) {
$p->{type} = 'coderef';
$p->{semantic} = 'callback';
$self->_log(" ADVANCED: $param is coderef (ref check)");
return;
}
# Invocation as coderef - note the escaped @ in \@_
if ($code =~ /\$$param\s*->\s*\(/ ||
$code =~ /\$$param\s*->\s*\(\s*\@_\s*\)/ ||
$code =~ /&\s*\{\s*\$$param\s*\}/) {
$p->{type} = 'coderef';
$p->{semantic} = 'callback';
$self->_log(" ADVANCED: $param invoked as coderef");
return;
}
# Parameter name suggests callback
lib/App/Test/Generator/SchemaExtractor.pm view on Meta::CPAN
# extracted from code or POD into a
# clean Perl scalar, handling quoted
# strings, numeric literals, boolean
# keywords, empty containers, and
# undef.
#
# Entry: $value - raw value string.
# May be undef.
# $from_code - true if the value was
# extracted from source
# code (affects escape
# sequence handling).
#
# Exit: Returns the cleaned value:
# undef for undef or unparseable
# {} for empty hashrefs
# [] for empty arrayrefs
# integer for whole numbers
# float for decimal numbers
# 1 or 0 for boolean keywords
# string for everything else
lib/App/Test/Generator/SchemaExtractor.pm view on Meta::CPAN
$value = $1;
} elsif ($value =~ /^q[qwx]?\s*([^a-zA-Z0-9\{\[])(.*?)\1$/s) {
$value = $2;
}
# Handle quoted strings
if ($value =~ /^(['"])(.*)\1$/s) {
$value = $2;
if ($from_code) {
# In regex captures from source code, escape sequences are doubled
# \\n in capture needs to become \n for the test
$value =~ s/\\\\/\\/g;
}
# Only unescape the quote characters themselves
$value =~ s/\\"/"/g;
$value =~ s/\\'/'/g;
# If NOT from code (i.e., from POD), interpret escape sequences
unless ($from_code) {
$value =~ s/\\n/\n/g;
$value =~ s/\\r/\r/g;
$value =~ s/\\t/\t/g;
$value =~ s/\\\\/\\/g;
}
}
# Sometimes trailing ) is left on
if($value !~ /^\(/) {
t/Generator.t view on Meta::CPAN
*_get_dominant_type = \&App::Test::Generator::_get_dominant_type;
*_detect_transform_properties = \&App::Test::Generator::_detect_transform_properties;
*_render_properties = \&App::Test::Generator::_render_properties;
*_schema_to_lectrotest_generator = \&App::Test::Generator::_schema_to_lectrotest_generator;
*_get_semantic_generators = \&App::Test::Generator::_get_semantic_generators;
*_get_builtin_properties = \&App::Test::Generator::_get_builtin_properties;
*_is_perl_builtin = \&App::Test::Generator::_is_perl_builtin;
}
# ------------------------------------------------------------------
# perl_sq — escape a string for single-quoted Perl string context
# ------------------------------------------------------------------
subtest 'perl_sq() returns empty string for undef' => sub {
is(App::Test::Generator::perl_sq(undef), '', 'undef produces empty string');
};
subtest 'perl_sq() escapes backslashes first' => sub {
is(App::Test::Generator::perl_sq('a\\b'), 'a\\\\b', 'backslash doubled');
};
subtest 'perl_sq() escapes apostrophes' => sub {
is(App::Test::Generator::perl_sq("it's"), "it\\'s", 'apostrophe escaped');
};
subtest 'perl_sq() escapes common control characters' => sub {
is(App::Test::Generator::perl_sq("a\nb"), 'a\\nb', 'newline escaped');
is(App::Test::Generator::perl_sq("a\rb"), 'a\\rb', 'CR escaped');
is(App::Test::Generator::perl_sq("a\tb"), 'a\\tb', 'tab escaped');
is(App::Test::Generator::perl_sq("a\fb"), 'a\\fb', 'formfeed escaped');
};
subtest 'perl_sq() replaces NUL bytes' => sub {
is(App::Test::Generator::perl_sq("a\0b"), 'a\\0b', 'NUL replaced with \\0');
};
subtest 'perl_sq() leaves plain string unchanged' => sub {
is(App::Test::Generator::perl_sq('hello'), 'hello', 'plain string unchanged');
};
t/Generator.t view on Meta::CPAN
subtest 'q_wrap() falls back when curly braces in string' => sub {
my $result = App::Test::Generator::q_wrap('a{b}c');
# Should use a different delimiter
unlike($result, qr/^q\{a\{b\}c\}$/, 'does not use q{} when string contains {}');
ok(length($result) > 0, 'returns non-empty result');
};
subtest 'q_wrap() uses single-quote fallback when all delimiters used' => sub {
# A string containing all bracket pairs AND all single-char delimiters
# forces the escaped single-quote fallback
my $str = '{}()[]<>~!%^=+:,;|/#';
my $result = App::Test::Generator::q_wrap($str);
ok(defined $result, 'returns defined value for pathological string');
};
subtest 'q_wrap() correctly uses != INDEX_NOT_FOUND boundary' => sub {
# A string starting with ~ means index returns 0 (not -1)
# If the guard were "> 0" instead of "!= -1" it would wrongly
# choose ~ as the delimiter when ~ is at position 0
my $result = App::Test::Generator::q_wrap('~starts with tilde');
t/default_value_extraction.t view on Meta::CPAN
'test',
'Cleans string with whitespace'
);
is(
$extractor->_clean_default_value(' 42 '),
42,
'Cleans integer with whitespace'
);
# Test escaped strings
is(
$extractor->_clean_default_value('"line1\\nline2"'),
"line1\nline2",
'Handles escaped newlines'
);
is(
$extractor->_clean_default_value("'it\\'s working'"),
"it's working",
'Handles escaped quotes'
);
done_testing();
};
# POD default value extraction
subtest 'POD Default Value Extraction' => sub {
my $module = <<'END_MODULE';
package Test::PODDefaults;
use strict;
t/default_value_extraction.t view on Meta::CPAN
package Test::EdgeCases;
use strict;
use warnings;
sub edge_cases {
my ($self, $param1, $param2, $param3, $param4, $param5) = @_;
# Edge case 1: Default with quotes inside quotes
$param1 = $param1 || "it's complicated";
# Edge case 2: Default with escaped characters
$param2 //= "line1\\nline2\\ttab";
# Edge case 3: Default as expression in parentheses
$param3 = defined $param3 ? $param3 : (10 + 20);
# Edge case 4: Default with trailing comment
$param4 = $param4 || 'default'; # this is a comment
# Edge case 5: Default with q// operator
$param5 = $param5 || q{default value};
t/default_value_extraction.t view on Meta::CPAN
# Check specific edge cases
is(
$code_params->{param1}{_default},
"it's complicated",
'Handles quotes inside string default'
);
is(
$code_params->{param2}{_default},
"line1\\nline2\\ttab",
'Preserves escaped characters in default'
);
is(
$code_params->{param2}{_default},
"line1\\nline2\\ttab",
'Preserves escaped characters in default'
);
# Note: param3 returns expression "(10 + 20)" which we can't evaluate
ok(
$code_params->{param3}{_default},
'Extracts expression default (even if unevaluatable)'
);
is(
$code_params->{param4}{_default},
t/extended_tests.t view on Meta::CPAN
like($result, qr/i/, 'case-insensitive modifier included');
};
subtest 'perl_quote: hashref falls through to render_fallback' => sub {
my $result = App::Test::Generator::perl_quote({ key => 'val' });
ok(defined $result, 'hashref handled');
like($result, qr/key/, 'key present in output');
like($result, qr/val/, 'value present in output');
};
subtest 'perl_sq: backslash escaped correctly' => sub {
my $result = App::Test::Generator::perl_sq('a\\b');
like($result, qr/\\\\/, 'backslash doubled');
};
subtest 'perl_sq: single quote escaped correctly' => sub {
my $result = App::Test::Generator::perl_sq("it's");
like($result, qr/\\'/, 'apostrophe escaped');
};
subtest 'perl_sq: control characters escaped' => sub {
is(App::Test::Generator::perl_sq("\n"), '\\n', 'newline escaped');
is(App::Test::Generator::perl_sq("\t"), '\\t', 'tab escaped');
is(App::Test::Generator::perl_sq("\r"), '\\r', 'CR escaped');
};
subtest 'perl_sq: NUL byte escaped as \\0' => sub {
is(App::Test::Generator::perl_sq("\0"), '\\0', 'NUL escaped');
};
subtest 'q_wrap: prefers bracket form when available' => sub {
my $result = App::Test::Generator::q_wrap('hello');
like($result, qr/^q\{hello\}$/, 'bracket form preferred');
};
subtest 'q_wrap: falls back to () when {} used in string' => sub {
my $result = App::Test::Generator::q_wrap('a{b}c');
ok(defined $result, 'string with braces handled');
t/function.t view on Meta::CPAN
# Constants used across multiple subtests to avoid
# magic literals and make intent clear
# --------------------------------------------------
Readonly my $EMPTY_STRING => '';
Readonly my $UNDEF_LITERAL => 'undef';
# ==================================================================
# perl_sq
# --------------------------------------------------
# White-box tests for the low-level single-quote
# string escaper used by perl_quote and q_wrap
# ==================================================================
subtest 'perl_sq' => sub {
# Access the private function directly via the package namespace
my $fn = \&App::Test::Generator::perl_sq;
# Undef input returns empty string, not 'undef'
is($fn->(undef), $EMPTY_STRING, 'undef returns empty string');
# Plain ASCII string passes through unchanged
is($fn->('hello'), 'hello', 'plain ASCII unchanged');
# Apostrophe must be escaped so it does not break the surrounding
# single-quoted string literal in the generated test
is($fn->("it's"), "it\\'s", 'apostrophe escaped');
# Backslash must be escaped first so later substitutions
# do not double-escape already-escaped sequences
is($fn->('a\\b'), 'a\\\\b', 'backslash escaped');
# Control characters are converted to their two-char sequences
is($fn->("a\nb"), 'a\\nb', 'newline escaped');
is($fn->("a\rb"), 'a\\rb', 'carriage return escaped');
is($fn->("a\tb"), 'a\\tb', 'tab escaped');
is($fn->("a\fb"), 'a\\fb', 'form feed escaped');
# NUL byte is converted to \0 for double-quoted context
is($fn->("a\0b"), 'a\\0b', 'NUL byte escaped');
# Both apostrophe and backslash in the same string
is($fn->("a\\'b"), "a\\\\\\'b", 'backslash and apostrophe together');
done_testing();
};
# ==================================================================
# perl_quote
# --------------------------------------------------
t/function.t view on Meta::CPAN
is($fn->(0), '0', 'zero unquoted');
is($fn->(42), '42', 'positive integer unquoted');
is($fn->(-1), '-1', 'negative integer unquoted');
# Floats are emitted unquoted
is($fn->(3.14), '3.14', 'float unquoted');
# Plain strings are single-quoted
is($fn->('hello'), "'hello'", 'string single-quoted');
# Strings containing apostrophes have them escaped
is($fn->("it's"), "'it\\'s'", 'apostrophe in string escaped');
# Arrayrefs are recursively quoted with brackets
is($fn->([1, 2, 3]), '[ 1, 2, 3 ]', 'arrayref recursively quoted');
# Nested arrayrefs recurse correctly
is($fn->([1, [2, 3]]), '[ 1, [ 2, 3 ] ]', 'nested arrayref quoted');
# Arrayref containing undef produces undef literal in the output
is($fn->([undef, 1]), "[ $UNDEF_LITERAL, 1 ]", 'arrayref with undef element');
t/function.t view on Meta::CPAN
unlike($fn->($with_brace), qr/^q\{/, 'string with { avoids q{}');
# String containing all bracket pairs falls back to single chars
my $all_brackets = '{([<>])}';
my $result = $fn->($all_brackets);
like($result, qr/^q./, 'all-bracket string still uses q form');
# Empty string produces empty q form
is($fn->($EMPTY_STRING), 'q{}', 'empty string produces q{}');
# String with apostrophe — q_wrap avoids needing to escape it
# by choosing a delimiter that is not an apostrophe
my $apos = "it's";
my $wrapped = $fn->($apos);
unlike($wrapped, qr/\\'/, 'apostrophe not escaped in q_wrap output');
done_testing();
};
# ==================================================================
# render_fallback
# --------------------------------------------------
# Tests for the Data::Dumper-based catch-all renderer
# ==================================================================
subtest 'render_fallback' => sub {
( run in 0.793 second using v1.01-cache-2.11-cpan-df04353d9ac )