view release on metacpan or  search on metacpan

t/CoverageGuided_Fuzzer.t  view on Meta::CPAN

#!/usr/bin/env perl

use strict;
use warnings;

use Test::Most;
use File::Temp qw(tempdir);
use File::Spec;

BEGIN { use_ok('App::Test::Generator::CoverageGuidedFuzzer') }

# ------------------------------------------------------------------
# Helper: minimal valid fuzzer construction
# ------------------------------------------------------------------
sub _fuzzer {
	my (%args) = @_;
	return App::Test::Generator::CoverageGuidedFuzzer->new(
		schema     => $args{schema}     // { input => { type => 'string' } },
		target_sub => $args{target_sub} // sub { 1 },
		iterations => $args{iterations} // 0,
		seed       => $args{seed}       // 42,
		exists $args{instance} ? (instance => $args{instance}) : (),
	);
}

# ==================================================================
# new — validation
# ==================================================================
subtest 'new() croaks when schema is missing' => sub {
	throws_ok(
		sub {
			App::Test::Generator::CoverageGuidedFuzzer->new(
				target_sub => sub { 1 },
			)
		},
		qr/schema required/,
		'missing schema croaks',
	);
};

subtest 'new() croaks when target_sub is missing' => sub {
	throws_ok(
		sub {
			App::Test::Generator::CoverageGuidedFuzzer->new(
				schema => { input => {} },
			)
		},
		qr/target_sub required/,
		'missing target_sub croaks',
	);
};

subtest 'new() returns a blessed object' => sub {
	my $f = _fuzzer();
	ok(defined $f, 'new() returns defined value');
	isa_ok($f, 'App::Test::Generator::CoverageGuidedFuzzer');
};

subtest 'new() defaults iterations to 100' => sub {
	my $f = App::Test::Generator::CoverageGuidedFuzzer->new(
		schema     => { input => {} },
		target_sub => sub { 1 },
		seed       => 42,
	);
	is($f->{iterations}, 100, 'iterations defaults to 100');
};

subtest 'new() stores explicit iterations' => sub {
	my $f = _fuzzer(iterations => 50);
	is($f->{iterations}, 50, 'explicit iterations stored');
};

subtest 'new() stores seed and initialises srand' => sub {
	my $f = _fuzzer(seed => 99);
	is($f->{seed}, 99, 'seed stored');
};

subtest 'new() initialises corpus, covered, bugs, and stats' => sub {
	my $f = _fuzzer();
	is(ref($f->{corpus}),  'ARRAY', 'corpus is arrayref');
	is(ref($f->{covered}), 'HASH',  'covered is hashref');
	is(ref($f->{bugs}),    'ARRAY', 'bugs is arrayref');
	is(ref($f->{stats}),   'HASH',  'stats is hashref');
	is(scalar @{$f->{corpus}}, 0, 'corpus initially empty');
	is(scalar @{$f->{bugs}},   0, 'bugs initially empty');
};

subtest 'new() initialises stats keys to zero' => sub {
	my $f = _fuzzer();
	is($f->{stats}{total},       0, 'stats.total = 0');
	is($f->{stats}{interesting}, 0, 'stats.interesting = 0');
	is($f->{stats}{bugs},        0, 'stats.bugs = 0');
	is($f->{stats}{coverage},    0, 'stats.coverage = 0');
};

subtest 'new() stores optional instance' => sub {
	my $obj = bless {}, 'FakeClass';
	my $f   = _fuzzer(instance => $obj);
	is($f->{instance}, $obj, 'instance stored');
};

# ==================================================================
# corpus and bugs accessors
# ==================================================================
subtest 'corpus() returns the corpus arrayref' => sub {
	my $f = _fuzzer();
	my $c = $f->corpus();
	is(ref($c), 'ARRAY', 'corpus() returns arrayref');
	is($c, $f->{corpus}, 'returns same reference as internal state');
};

subtest 'bugs() returns the bugs arrayref' => sub {
	my $f = _fuzzer();
	my $b = $f->bugs();
	is(ref($b), 'ARRAY', 'bugs() returns arrayref');
	is($b, $f->{bugs}, 'returns same reference as internal state');
};

# ==================================================================
# _is_interesting
# ==================================================================
subtest '_is_interesting() returns 1 for new branch key' => sub {
	my $f = _fuzzer();
	$f->{covered} = {};
	ok($f->_is_interesting({ 'foo.pm:10:0' => 1 }),
		'new branch key -> interesting');
};

subtest '_is_interesting() returns 0 for already-covered branch' => sub {
	my $f = _fuzzer();
	$f->{covered} = { 'foo.pm:10:0' => 1 };
	# When coverage is non-empty but all keys are known, returns 0
	# (the random keep path only fires when coverage is empty)
	is($f->_is_interesting({ 'foo.pm:10:0' => 1 }), 0,
		'known branch -> not interesting');
};

subtest '_is_interesting() returns randomly for empty coverage' => sub {
	# With seed 42, deterministic — just check it returns 0 or 1
	my $f = _fuzzer(seed => 42);
	my $result = $f->_is_interesting({});
	ok($result == 0 || $result == 1, 'empty coverage returns 0 or 1');
};

# ==================================================================
# _update_covered
# ==================================================================
subtest '_update_covered() merges new branch keys into covered' => sub {
	my $f = _fuzzer();
	$f->_update_covered({ 'a:1:0' => 1, 'b:2:1' => 1 });
	ok($f->{covered}{'a:1:0'}, 'a:1:0 merged');
	ok($f->{covered}{'b:2:1'}, 'b:2:1 merged');
};

subtest '_update_covered() does not remove existing keys' => sub {
	my $f = _fuzzer();
	$f->{covered} = { 'existing:1:0' => 1 };
	$f->_update_covered({ 'new:2:0' => 1 });
	ok($f->{covered}{'existing:1:0'}, 'existing key preserved');
	ok($f->{covered}{'new:2:0'},      'new key added');
};

# ==================================================================
# _seed_corpus
# ==================================================================
subtest '_seed_corpus() adds exactly SEED_CORPUS_SIZE entries' => sub {
	my $f = _fuzzer();
	$f->_seed_corpus();
	is(scalar @{$f->{corpus}}, 5, 'seed adds 5 corpus entries');
};

subtest '_seed_corpus() each entry has input and coverage keys' => sub {
	my $f = _fuzzer();
	$f->_seed_corpus();
	for my $entry (@{$f->{corpus}}) {
		ok(exists $entry->{input},    'entry has input key');
		ok(exists $entry->{coverage}, 'entry has coverage key');
		is(ref($entry->{coverage}), 'HASH', 'coverage is a hashref');
	}
};

# ==================================================================
# _build_report
# ==================================================================
subtest '_build_report() returns hashref with all required keys' => sub {
	my $f = _fuzzer();
	my $r = $f->_build_report();
	is(ref($r), 'HASH', 'returns hashref');
	for my $key (qw(total_iterations interesting_inputs corpus_size
	                branches_covered bugs_found bugs)) {
		ok(exists $r->{$key}, "$key present in report");
	}
};

subtest '_build_report() reflects current stats' => sub {
	my $f = _fuzzer();
	$f->{stats}{total}       = 10;
	$f->{stats}{interesting} = 3;
	$f->{stats}{coverage}    = 7;
	$f->{stats}{bugs}        = 1;
	push @{$f->{corpus}}, { input => 'x', coverage => {} };
	push @{$f->{bugs}},   { input => 'y', error => 'oops' };

	my $r = $f->_build_report();
	is($r->{total_iterations},   10, 'total_iterations from stats');
	is($r->{interesting_inputs}, 3,  'interesting_inputs from stats');
	is($r->{branches_covered},   7,  'branches_covered from stats');
	is($r->{bugs_found},         1,  'bugs_found from stats');
	is($r->{corpus_size},        1,  'corpus_size from corpus array');
	is(ref($r->{bugs}),     'ARRAY', 'bugs is arrayref');
};

# ==================================================================
# _validate_value
# ==================================================================
subtest '_validate_value() accepts valid integer' => sub {
	my $f = _fuzzer();
	ok($f->_validate_value(42, { type => 'integer' }), 'integer 42 valid');
	ok($f->_validate_value(-5, { type => 'integer' }), 'negative integer valid');
	ok($f->_validate_value(0,  { type => 'integer' }), 'zero valid');
};

subtest '_validate_value() rejects non-integer for integer type' => sub {
	my $f = _fuzzer();
	ok(!$f->_validate_value('abc',  { type => 'integer' }), 'string rejected');
	ok(!$f->_validate_value('3.14', { type => 'integer' }), 'float rejected');
};

subtest '_validate_value() enforces integer min/max' => sub {
	my $f = _fuzzer();
	ok( $f->_validate_value(5,  { type => 'integer', min => 1, max => 10 }), 'in range valid');
	ok(!$f->_validate_value(0,  { type => 'integer', min => 1, max => 10 }), 'below min invalid');
	ok(!$f->_validate_value(11, { type => 'integer', min => 1, max => 10 }), 'above max invalid');
};

subtest '_validate_value() accepts valid number' => sub {
	my $f = _fuzzer();
	ok($f->_validate_value('3.14',  { type => 'number' }), 'decimal accepted');
	ok($f->_validate_value('1e5',   { type => 'number' }), 'scientific notation accepted');
	ok($f->_validate_value('-0.5',  { type => 'number' }), 'negative float accepted');
};

subtest '_validate_value() rejects non-number for number type' => sub {
	my $f = _fuzzer();
	ok(!$f->_validate_value('abc', { type => 'number' }), 'string rejected for number');
};

subtest '_validate_value() enforces string length constraints' => sub {
	my $f = _fuzzer();
	ok( $f->_validate_value('hello', { type => 'string', min => 3, max => 10 }), 'in range valid');
	ok(!$f->_validate_value('hi',    { type => 'string', min => 3, max => 10 }), 'too short invalid');
	ok(!$f->_validate_value('x' x 11, { type => 'string', max => 10 }),          'too long invalid');
};

subtest '_validate_value() enforces string matches pattern' => sub {
	my $f = _fuzzer();
	ok( $f->_validate_value('foo123', { type => 'string', matches => '/^\w+$/' }), 'matching pattern valid');
	ok(!$f->_validate_value('foo bar', { type => 'string', matches => '/^\w+$/' }), 'non-matching invalid');
};

subtest '_validate_value() accepts valid boolean' => sub {
	my $f = _fuzzer();
	ok($f->_validate_value(0, { type => 'boolean' }), '0 is valid boolean');
	ok($f->_validate_value(1, { type => 'boolean' }), '1 is valid boolean');
};

t/CoverageGuided_Fuzzer.t  view on Meta::CPAN

		'undef path croaks',
	);
};

subtest 'load_corpus() croaks when path is missing' => sub {
	my $f = _fuzzer();
	throws_ok(
		sub { $f->load_corpus(undef) },
		qr/path required/,
		'undef path croaks',
	);
};

subtest 'save_corpus() and load_corpus() round-trip' => sub {
	my $has_json = eval {
			App::Test::Generator::CoverageGuidedFuzzer::_load_json_module();
			1;
		} // 0;

	SKIP: {
		skip 'No JSON module available', 6 unless $has_json;

		my $dir  = tempdir(CLEANUP => 1);
		my $path = File::Spec->catfile($dir, 'corpus.json');

		my $f1 = _fuzzer(seed => 42);
		push @{$f1->{corpus}}, { input => 'hello', coverage => {} };
		push @{$f1->{corpus}}, { input => 42,      coverage => {} };

		lives_ok(sub { $f1->save_corpus($path) }, 'save_corpus lives');
		ok(-f $path, 'corpus file created');

		my $f2 = _fuzzer(seed => 42);
		lives_ok(sub { $f2->load_corpus($path) }, 'load_corpus lives');

		is(scalar @{$f2->corpus()}, 2, 'two entries loaded');
		is($f2->corpus()->[0]{input}, 'hello', 'first input preserved');
		is($f2->corpus()->[1]{input}, 42,      'second input preserved');
	}
};

subtest 'load_corpus() croaks for unreadable file' => sub {
	my $has_json = eval {
			App::Test::Generator::CoverageGuidedFuzzer::_load_json_module();
			1;
		} // 0;

	SKIP: {
		skip 'No JSON module available', 1 unless $has_json;

		my $f = _fuzzer();
		throws_ok(
			sub { $f->load_corpus('/nonexistent/path/corpus.json') },
			qr/Cannot read corpus/,
			'unreadable file croaks',
		);
	}
};

# ==================================================================
# run — smoke test (iterations => 0 skips loop)
# ==================================================================
subtest 'run() with iterations=0 returns valid report structure' => sub {
	my $f      = _fuzzer(iterations => 0);
	my $report = $f->run();
	is(ref($report), 'HASH', 'run() returns hashref');
	for my $key (qw(total_iterations interesting_inputs corpus_size
	                branches_covered bugs_found bugs)) {
		ok(exists $report->{$key}, "$key present");
	}
};

subtest 'run() seeds corpus before loop' => sub {
	my $f = _fuzzer(iterations => 0);
	$f->run();
	is(scalar @{$f->corpus()}, 5, 'corpus seeded with 5 entries after run');
};

subtest 'run() with small iteration count completes without error' => sub {
	my $called = 0;
	my $f = App::Test::Generator::CoverageGuidedFuzzer->new(
		schema     => { input => { type => 'integer', min => 0, max => 100 } },
		target_sub => sub { $called++; return 1 },
		iterations => 10,
		seed       => 42,
	);
	my $report;
	lives_ok(sub { $report = $f->run() }, 'run() with 10 iterations lives');
	is($report->{total_iterations}, 10, 'total_iterations is 10');
	ok($called > 0, 'target_sub was called');
};

subtest 'run() detects bugs from target_sub die on valid input' => sub {
	my $f = App::Test::Generator::CoverageGuidedFuzzer->new(
		schema     => { input => { type => 'integer', min => 0, max => 100 } },
		target_sub => sub { die "always dies\n" },
		iterations => 5,
		seed       => 42,
	);
	my $report = $f->run();
	# May or may not find bugs depending on whether generated inputs are valid
	ok($report->{bugs_found} >= 0, 'bugs_found is non-negative');
	is(scalar @{$f->bugs()}, $report->{bugs_found}, 'bugs array matches bugs_found count');
};

done_testing();