view release on metacpan or  search on metacpan

t/app.t  view on Meta::CPAN

		# ── Step 1: extract schemas ──────────────────────────────────────
		diag("step 1: extracting schemas from $pm_file") if $VERBOSE;
		my $t0 = time;

		my $extractor = App::Test::Generator::SchemaExtractor->new(
			input_file => $pm_file,
			output_dir => $tmpdir,
			strict_pod => 'fatal',
			verbose    => 0,
		);

		my $schemas;
		eval { $schemas = $extractor->extract_all() };
		if ($@) {
			fail("SchemaExtractor died for $pm_file");
			diag($@);
			diag("Diagnostics kept in: $tmpdir");
			done_testing();
			return;
		}

		if (!$schemas || !keys %$schemas) {
			pass("no methods extracted from $pm_file");
			rmtree($tmpdir);
			done_testing();
			return;
		}

		my $n_schemas = scalar keys %$schemas;
		diag(sprintf('step 1 done in %ds: %d schemas extracted (%s)',
			time - $t0, $n_schemas, join(', ', sort keys %$schemas))) if $VERBOSE;

		pass('SchemaExtractor completed without error');

		# ── Step 2: generate a fuzz harness for each schema ──────────────
		diag("step 2: generating fuzz harnesses") if $VERBOSE;
		$t0 = time;

		# Functions that require real file-system inputs can't be meaningfully
		# fuzz-tested: the harness would supply random strings as file paths and
		# every call would die with "file not found". Syntax-check these files
		# (step 3a) but skip them in the prove run (step 3b).
		# DB::DB is a Perl debugger hook in the DB package; ATG extracts it
		# from Devel::... files but it is not callable as a module method.
		# get_data_section returns a reference whose type PVS cannot validate.
		# new constructors often require mandatory parameters the fuzzer can't supply.
		# export conflicts with Perl's import mechanism; generated test uses 'use export'.
		# merge/if/applies_to require real files or PPI objects or are Perl keywords.
		# mutate/applies_to require a PPI::Document object the fuzzer can't construct.
		# render_args_hash/render_arrayref_map/render_hash return '' for
		# wrong-type inputs rather than dying, so fuzz "dies" tests fail.
		my %no_prove = map { $_ => 1 } qw(generate DB::DB get_data_section new export merge mutate applies_to if render_args_hash render_arrayref_map render_hash);

		my @test_files;
		my @prove_files;
		for my $func (sort keys %$schemas) {
			my $schema_file = File::Spec->catfile($tmpdir, "${func}.yml");
			next unless -f $schema_file;

			# Patch schema: short per-case timeout (3s vs default 10s), no
			# test_empty, low iterations, and cap string max lengths.
			# The 64K-string cases come from a separate path and are only
			# suppressed by setting max; test_empty only removes '' cases.
			my $skip_prove = 0;
			eval {
				my ($schema) = LoadFile($schema_file);
				if (ref($schema) eq 'HASH') {
					$schema->{iterations}             = 3;
					$schema->{config}{timeout}        = 3;
					$schema->{config}{test_empty}     = 0;
					$schema->{config}{close_stdin}    = 1;
					# Cap unconstrained file-path string fields to prevent 64K-char test cases.
					# Only applied to fields whose name suggests a file path — not general
					# string arguments like 's', 'v', etc., which don't enforce length.
					if (ref($schema->{input}) eq 'HASH') {
						for my $field (keys %{$schema->{input}}) {
							my $spec = $schema->{input}{$field};
							next unless ref($spec) eq 'HASH';
							if (($spec->{type}//'') eq 'string'
								&& !defined($spec->{max})
								&& $field =~ /(?:file|path|dir|filename|dirname)/i) {
								$spec->{max} = 1025;
							}
							# A mandatory 'object'-type param without 'can' cannot be
							# mocked by the fuzz harness — skip prove for such functions.
							if (($spec->{type}//'') eq 'object'
								&& !$spec->{optional}
								&& !defined($spec->{can})) {
								$skip_prove = 1;
							}
						}
					}
					# OOP instance methods have 'new:' in their schema — the fuzz
					# harness would need to instantiate the class, which fails for
					# classes whose constructors require mandatory parameters.
					$skip_prove = 1 if exists $schema->{new};
					DumpFile($schema_file, $schema);
				}
			};

			# Private functions (leading underscore) are internal helpers that
			# typically lack input validation; fuzz tests expect die-on-bad-input.
			$skip_prove = 1 if $func =~ /^_/;

			my $test_file = File::Spec->catfile($tmpdir, "${func}.t");

			diag("  generating $func.t") if $VERBOSE;
			my (undef, undef) = capture {
				eval {
					App::Test::Generator->generate(
						schema_file => $schema_file,
						output_file => $test_file,
					);
				};
			};

			if ($@) {
				fail("Generator died for $func in $pm_file");
				diag($@);
				diag("Diagnostics kept in: $tmpdir");
				$failed++;
				next;
			}

			if (-f $test_file) {
				push @test_files, $test_file;
				push @prove_files, $test_file
					unless $no_prove{$func} || $skip_prove;