App-Test-Generator

 view release on metacpan or  search on metacpan

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

	return undef unless $arrayref && ref $arrayref eq 'ARRAY' && @{$arrayref};
	return $arrayref->[ int(rand(scalar @$arrayref)) ];
}

sub rand_ascii_str {
	my $len = shift // int(rand(10)) + 1;
	# join '', map { chr(97 + int(rand(26))) } 1..$len;
	return Data::Random::String->create_random_string(length => $len, contains => 'alphanumeric');
}

my @unicode_codepoints = (
	0x00A9,	# ©
	0x00AE,	# ®
	0x03A9,	# Ω
	0x20AC,	# €
	0x2013,	# – (en-dash)
	0x0301,	# combining acute accent
	0x0308,	# combining diaeresis
	0x1F600,	# 😀 (emoji)
	0x1F62E,	# 😮
	0x1F4A9,	# 💩 (yes)

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

		$len = int(rand(10)) + 1;	# length random number between 1 and 10
	}

	return '' if($len == 0);

	if(!($config{'test_non_ascii'} // 0)) {
		return rand_ascii_str($len);
	}

	# my $rc = _rand_str_basic($len);
	# $rc = _rand_unicode_fuzzer($len);
	# my $l = Unicode::GCString->new($rc)->length();
	# if($len > $l) {
		# $rc .= 'a' x ($len - $l);	# Why is this needed?
	# }

	# return $rc;

	# TODO: length issues at the moment
	my $mode = int(rand(5));	# 0..4

	my $rc = _rand_str_basic($len);

	$rc = _rand_str_basic($len) if $mode == 0;
	$rc = _rand_codepoint_exact($len) if $mode == 1;
	$rc = _rand_grapheme_exact($len) if $mode == 2;
	$rc = _rand_unicode_fuzzer($len) if $mode == 3;
	$rc = rand_ascii_str($len) if($mode == 4);

	my $rc_len = Unicode::GCString->new($rc)->length();
	if($rc_len > $len) {
		my $gcstr = Unicode::GCString->new($rc);
		$rc = $gcstr->substr(0, $len)->as_string();
		$rc_len = Unicode::GCString->new($rc)->length();
	}
	if($len > $rc_len) {
		$rc .= 'a' x ($len - $rc_len);
		$rc_len = Unicode::GCString->new($rc)->length();
	}

	fail("BUG $rc_len != $len (mode == $mode)") if($rc_len != $len);

	return $rc;
}

#####################################################
# 1. EXACT-LENGTH CODEPOINT MODE
# Generate a random string: mostly ASCII, sometimes unicode, sometimes nul bytes or combining marks
#####################################################
sub _rand_str_basic
{
	my $len = $_[0];

	my @chars;
	for (1..$len) {
		my $r = rand();
		if ($r < PROB_LOWERCASE) {
			push @chars, chr(97 + int(rand(26)));	# a-z
		} elsif ($r < 0.88) {
			push @chars, chr(65 + int(rand(26)));	# A-Z
		} elsif ($r < 0.95) {
			push @chars, chr(48 + int(rand(10)));	# 0-9
		} elsif($r < 0.975) {
			push @chars, _rand_unicode_char();	# occasional emoji/marks
		} elsif($config{'test_nuls'}) {
			push @chars, chr(0);	# nul byte injection
		} else {
			push @chars, chr(97 + int(rand(26)));	# a-z
		}
	}

	if (rand() < 0.08) {
		# 8% chance to prepend combining acute accent (0301)
		$chars[-1] = chr(0x0301);

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

	return join('', @chars);
}

# helper for codepoint mode
sub _rand_base_char {
	my $r = rand();

	if ($r < 0.70) { return chr(97 + int(rand(26))); }
	if ($r < 0.88) { return chr(65 + int(rand(26))); }
	if ($r < 0.95) { return chr(48 + int(rand(10))); }
	return _rand_unicode_char();
}

#####################################################
# 3. EXACT-LENGTH GRAPHEME-CLUSTER MODE
# each "character" is a whole grapheme cluster:
# - emoji with ZWJ sequences
# - flags
# - skin-tone variants
# - accented characters
#####################################################

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

	}

	return join('', @clusters);
}

####################################################
# 4. UNICODE FUZZER MODE
# Extremely aggressive: invalid sequences, NULs, bidirectional markers, Zalgo
# Exclude unpaired surrogates for now, since TAP::Harness complains about that
####################################################
sub _rand_unicode_fuzzer {
	my $len = $_[0];
	my @out;

	my @zalgo_up = map { chr($_) } (0x030D..0x036F);
	my @bidi = ("\x{202A}", "\x{202B}", "\x{202D}", "\x{202E}", "\x{2066}", "\x{2067}");
	my @weird = $config{'test_nuls'} ? ("\x{0000}", "\x{FFFD}", "\x{FEFF}") : ("\x{FFFD}", "\x{FEFF}");

	for (1..$len) {
		my $r = rand();

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

				$cp = int(rand(0x10FFFF));
			} while ($cp >= 0xD800 && $cp <= 0xDFFF);
			push @out, chr($cp);
		} elsif ($r < 0.40) {
			push @out, chr(65 + int(rand(26))) . $zalgo_up[rand @zalgo_up]; # Zalgo
		} elsif ($r < 0.55) {
			push @out, $bidi[rand @bidi];
		} elsif ($r < 0.70) {
			push @out, $weird[rand @weird];
		} else {
			push @out, _rand_unicode_char();
		}
	}

	return join('', @out);
}

###################################################
# Random Unicode character helper
###################################################
sub _rand_unicode_char
{
	if(rand() < 0.5) {
		my $cp = $unicode_codepoints[ int(rand(@unicode_codepoints)) ];
		return chr($cp);
	}

	my @pool = (
		0x00A9, 0x00AE, 0x2600, 0x2601,
		0x1F600 + int(rand(200)),	# emoji block
		0x0300 + int(rand(80)),	# combining marks
	);
	return chr( $pool[int rand @pool] );
}

t/edge_cases.t  view on Meta::CPAN

	print $fh "input:\n  x:\n    type: integer\n    min: 100\n    max: 1\n";
	print $fh "output:\n  type: integer\n";
	close $fh;
	# Should not crash even with inverted constraints
	lives_ok(
		sub { capture(sub { App::Test::Generator->generate($path) }) },
		'inverted min/max does not crash',
	);
};

subtest 'Generator: schema with unicode function name' => sub {
	my ($fh, $path) = tempfile(SUFFIX => '.yml', UNLINK => 1);
	binmode $fh, ':utf8';
	print $fh "module: builtin\nfunction: my_func\n";
	print $fh "input:\n  type: string\noutput:\n  type: string\n";
	close $fh;
	lives_ok(
		sub { capture(sub { App::Test::Generator->generate($path) }) },
		'unicode in schema file does not crash',
	);
};

# ==================================================================
# Generator — render helpers with pathological inputs
# ==================================================================

subtest 'perl_quote: handles undef' => sub {
	is(App::Test::Generator::perl_quote(undef), 'undef',
		'undef -> literal undef string');

t/edge_cases.t  view on Meta::CPAN

	binmode $fh, ':utf8';
	print $fh "package Unicode;\nuse utf8;\nsub greet { return 'héllo'; }\n1;\n";
	close $fh;
	lives_ok(
		sub {
			my $e = App::Test::Generator::SchemaExtractor->new(
				input_file => $pm
			);
			$e->extract_all(no_write => 1);
		},
		'unicode source does not crash',
	);
};

subtest 'SchemaExtractor: confidence_threshold at extremes' => sub {
	my ($fh, $pm) = tempfile(SUFFIX => '.pm', UNLINK => 1);
	print $fh "package Foo;\nsub bar { return 1; }\n1;\n";
	close $fh;

	for my $thresh (0.0, 0.5, 1.0) {
		lives_ok(