view release on metacpan or  search on metacpan

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

# Notes:      Croaks if more than one package
#             declaration is found — multi-package
#             files are not supported.
# --------------------------------------------------
sub _extract_package_name {
	my ($self, $document) = @_;

	if(!defined($document)) {
		$document = $self->{_document};
	}
	my $pkgs = $document->find('PPI::Statement::Package') || [];
	if(@$pkgs == 0) {
		my $package_stmt = $document->find_first('PPI::Statement::Package');
		return $package_stmt ? $package_stmt->namespace() : '';
	}
	croak('More than one package declaration found') if @$pkgs > 1;
	$self->{_package_name} //= $pkgs->[0]->namespace();
	return $pkgs->[0]->namespace();
}

# --------------------------------------------------
# _find_methods
#
# Purpose:    Locate all subroutine and method
#             declarations in a PPI document,
#             including Moose-style method modifiers
#             and Perl 5.38 class/method syntax.
#
# Entry:      $document - a PPI::Document.
#
# Exit:       Returns an arrayref of method hashrefs,
#             each containing: name, node, body, pod,
#             type, and optionally modifier, class,
#             and fields keys.
#             Private methods (names beginning with
#             _) are excluded unless include_private
#             was set in new(), except for _new,
#             _init, and _build which are always
#             included.
#
# Side effects: Logs progress and warnings to stdout
#               when verbose is set.
#
# Notes:      Duplicate method names are silently
#             deduplicated — the second occurrence
#             is dropped with a verbose warning.
#             Class/method detection is regex-based
#             and may misbehave on complex code.
# --------------------------------------------------
sub _find_methods {
	my ($self, $document) = @_;

	my $subs = $document->find('PPI::Statement::Sub') || [];
	my $sub_decls = $document->find('PPI::Statement') || [];

	my @methods;
	foreach my $sub (@$subs) {
		my $name = $sub->name();

		next unless defined $name;	# Skip anonymous routines
		next if $name =~ /^(BEGIN|END|DESTROY|AUTOLOAD|CHECK|INIT|UNITCHECK)$/;

		# Skip private methods unless explicitly included, or they're special
		if ($name =~ /^_/ && $name !~ /^_(new|init|build)/) {
			next unless $self->{include_private};
		}

		# Get the POD before this sub
		my $pod = $self->_extract_pod_before($sub);

		push @methods, {
			name => $name,
			node => $sub,
			body => $sub->content(),
			pod => $pod,
			type => 'sub',
		};
	}

	# Look for class { method } syntax (Perl 5.38+)
	my $content = $document->content();
	if ($content =~ /\bclass\b/) {
		$self->_log('  Detecting class/method syntax...');
		$self->_extract_class_methods($content, \@methods);
	}

	# Process method modifiers (Moose)
	foreach my $decl (@$sub_decls) {
		my $content = $decl->content;
		if ($content =~ /^\s*(before|after|around)\s+['"]?(\w+)['"]?\b/) {
			my ($modifier, $method_name) = ($1, $2);
			my $full_name = "${modifier}_$method_name";

			# Look for the actual sub definition that follows
			my $next_sib = $decl->next_sibling;
			while ($next_sib && !$next_sib->isa('PPI::Statement::Sub')) {
				$next_sib = $next_sib->next_sibling;
			}

			if ($next_sib && $next_sib->isa('PPI::Statement::Sub')) {
				my $pod = $self->_extract_pod_before($decl); # POD might be before modifier
				push @methods, {
					name => $full_name,
					node => $next_sib,
					body => $next_sib->content,
					pod => $pod,
					type => 'modifier',
					original_method => $method_name,
					modifier => $modifier,
				};
				$self->_log("  Found method modifier: $full_name");
			}
		}
	}

	# Prevent silent duplicate method overwrites
	my %seen;
	@methods = grep {
		my $n = $_->{name};
		if ($seen{$n}++) {
			$self->_log("  WARNING: duplicate method '$n' ignored");