view release on metacpan or  search on metacpan

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

	if($self->{_cover_available}) {
		$coverage = $self->_run_with_cover($input, \$result, \$error);
	} else {
		$coverage = {};

		# Include instance as invocant for method calls
		my @call_args = defined($self->{instance})
			? ($self->{instance}, $input)
			: ($input);

		my @warnings;
		eval {
			local $SIG{__WARN__} = sub { push @warnings, @_ };
			local $SIG{__DIE__};
			$result = $self->{target_sub}->(@call_args);
		};
		$error = $@ if $@;

		# Treat unexpected warnings matching known bad patterns as soft bugs
		if(!defined($error) && @warnings) {
			my $w = join '', @warnings;
			$error = "warning: $w"
				if $w =~ /uninitialized|undefined|blessed|invalid/i;
		}
	}

	# Record bugs — only when the input was valid per the schema.
	# A die on invalid input is correct behaviour, not a bug.
	if($error && $self->_input_is_valid($input)) {
		push @{ $self->{bugs} }, { input => $input, error => "$error" };
		$self->{stats}{bugs}++;
	}

	# Keep the input in the corpus if it exercised new branches
	if($self->_is_interesting($coverage)) {
		push @{ $self->{corpus} }, { input => $input, coverage => $coverage };
		$self->_update_covered($coverage);
		$self->{stats}{interesting}++;
	}
}

# --------------------------------------------------
# _run_with_cover
#
# Purpose:    Run the target sub with Devel::Cover
#             active and return the set of newly hit
#             branches as a hashref.
#
# Entry:      $input      - value to pass to target_sub.
#             $result_ref - scalar ref to store result.
#             $error_ref  - scalar ref to store error.
#
# Exit:       Returns a hashref of newly hit branch
#             keys ("file:line:branch").
#
# Side effects: Calls Devel::Cover::start/stop.
#               Sets $$result_ref and $$error_ref.
#
# Notes:      Snapshot comparison is imprecise for
#             concurrent use but correct for single-
#             threaded fuzzing. Instance is passed
#             as invocant when set.
# --------------------------------------------------
sub _run_with_cover {
	my ($self, $input, $result_ref, $error_ref) = @_;

	Devel::Cover::start() if Devel::Cover->can('start');

	my %before = $self->_snapshot_cover();

	# Include instance as invocant for method calls
	my @call_args = defined($self->{instance})
		? ($self->{instance}, $input)
		: ($input);

	eval {
		local $SIG{__DIE__};
		$$result_ref = $self->{target_sub}->(@call_args);
	};
	$$error_ref = $@ if $@;

	my %after = $self->_snapshot_cover();
	Devel::Cover::stop() if Devel::Cover->can('stop');

	# Return only branches newly hit in this call
	my %delta;
	for my $key (keys %after) {
		$delta{$key} = 1 unless exists $before{$key};
	}

	return \%delta;
}

# --------------------------------------------------
# _snapshot_cover
#
# Purpose:    Take a lightweight snapshot of the
#             currently hit branches from Devel::Cover.
#
# Entry:      None beyond $self.
# Exit:       Returns a hash of "file:line:branch" keys.
#
# Side effects: Reads Devel::Cover internal state.
#
# Notes:      Falls back to empty hash if the
#             Devel::Cover API is not accessible.
#             All errors are silently swallowed since
#             coverage is best-effort.
# --------------------------------------------------
sub _snapshot_cover {
	my ($self) = @_;
	my %snap;

	eval {
		my $cover = Devel::Cover::get_coverage();
		return unless $cover;

		for my $file (keys %{$cover}) {
			my $branch = $cover->{$file}{branch} or next;
			for my $line (keys %{$branch}) {
				for my $b (0 .. $#{ $branch->{$line} }) {