custom boilerplate modules

Perl-Critic · Nov 25, 2024 · 1c7b42e · 1c7b42e
1 parent bb83571
commit 1c7b42e
Show file tree

Hide file tree

Showing 4 changed files with 165 additions and 4 deletions.
diff --git a/Changes b/Changes
@@ -10,6 +10,8 @@ Revision history for Perl extension PPI
 	  - `use feature` in code
 	  - `use $Common::CPAN::Module` in code
 	  - PPI::Document->new( feature_mods => ... )
+	  - PPI::Document->new( custom_feature_includes => ... )
+	  - PPI::Document->new( custom_feature_include_cb => ... )
 	- Added ability to parse features:
 	  - signatures, as PPI::Structure::Signature
 	  - try catch, as PPI::Statement::Compound

diff --git a/lib/PPI/Document.pm b/lib/PPI/Document.pm
@@ -145,6 +145,32 @@ Setting feature_mods with a hashref allows defining perl parsing features to be
 enabled for the whole document. (e.g. when the code is assumed to be run as a
 oneliner)
 
+=head3 custom_feature_includes
+
+  custom_feature_includes =>
+    { strEct => { signatures => "Syntax::Keyword::Try" } }
+
+Setting custom_feature_includes with a hashref allows defining include names
+which act like pragmas that enable parsing features within their scope.
+
+This is mostly useful when your work project has its own boilerplate module.
+
+=head3 custom_feature_include_cb
+
+  custom_feature_include_cb => sub {
+    my ($statement) = @_;
+    return $statement->module eq "strEct" ? { signatures => "perl" } : ();
+  },
+
+Setting custom_feature_include_cb with a code reference causes all inspections
+on includes to call that sub before doing any other inspections. The sub can
+decide to either return a hashref of features to be enabled or disabled, which
+will be used for the scope the include was called in, or undef to continue with
+the default inspections. The argument to the sub will be the
+L<PPI::Statement::Include> object.
+
+This can be useful when your work project has a complex boilerplate module.
+
 =cut
 
 sub new {
@@ -232,9 +258,11 @@ sub load {
 
 sub _setattr {
 	my ( $class, $document, %attr ) = @_;
-	$document->{readonly}     = !!$attr{readonly};
-	$document->{filename}     = $attr{filename};
-	$document->{feature_mods} = $attr{feature_mods};
+	$document->{readonly}                  = !!$attr{readonly};
+	$document->{filename}                  = $attr{filename};
+	$document->{feature_mods}              = $attr{feature_mods};
+	$document->{custom_feature_includes}   = $attr{custom_feature_includes};
+	$document->{custom_feature_include_cb} = $attr{custom_feature_include_cb};
 	return $document;
 }
 
@@ -360,6 +388,26 @@ sub feature_mods {
 	$self->{feature_mods} = shift;
 }
 
+=head2 custom_feature_includes { module_name => { feature_name => $provider } }
+
+=cut
+
+sub custom_feature_includes {
+	my $self = shift;
+	return $self->{custom_feature_includes} unless @_;
+	$self->{custom_feature_includes} = shift;
+}
+
+=head2 custom_feature_include_cb sub { ... }
+
+=cut
+
+sub custom_feature_include_cb {
+	my $self = shift;
+	return $self->{custom_feature_include_cb} unless @_;
+	$self->{custom_feature_include_cb} = shift;
+}
+
 =pod
 
 =head2 save

diff --git a/lib/PPI/Statement/Include.pm b/lib/PPI/Statement/Include.pm
@@ -259,6 +259,9 @@ sub feature_mods {
 	my ($self) = @_;
 	return if $self->type eq "require";
 
+	if ( my $cb_features = $self->_custom_feature_include_cb->($self) )    #
+	{ return $cb_features; }
+
 	if ( my $perl_version = $self->version ) {
 		## tried using feature.pm, but it is impossible to install future
 		## versions of it, so e.g. a 5.20 install cannot know about
@@ -284,9 +287,26 @@ sub feature_mods {
 		return { try => $on_or_off ? "Syntax::Keyword::Try" : 0 };
 	}
 
+	if ( my $custom = $self->_custom_feature_includes->{ $self->module } )    #
+	{ return $custom; }
+
 	return;
 }
 
+sub _custom_feature_includes {
+	my ($self) = @_;
+	return unless                                                             #
+	  my $document = $self->document;
+	return $document->custom_feature_includes || {};
+}
+
+sub _custom_feature_include_cb {
+	my ($self) = @_;
+	return unless                                                             #
+	  my $document = $self->document;
+	return $document->custom_feature_include_cb || sub { };
+}
+
 1;
 
 =pod

diff --git a/t/feature_tracking.t b/t/feature_tracking.t
@@ -2,7 +2,7 @@
 
 use lib 't/lib';
 use PPI::Test::pragmas;
-use Test::More tests => 6 + ( $ENV{AUTHOR_TESTING} ? 1 : 0 );
+use Test::More tests => 8 + ( $ENV{AUTHOR_TESTING} ? 1 : 0 );
 
 use B 'perlstring';
 
@@ -198,6 +198,97 @@ END_PERL
 	  "core try";
 }
 
+HOMEBREW_ARGS: {
+	test_document
+	  [ custom_feature_includes => { strEct => { signatures => 1 } } ],
+	  <<'END_PERL',
+		use strEct;
+		sub meep($) {}
+		sub marp($left, $right) {}
+END_PERL
+	  [
+		'PPI::Statement::Include',    'use strEct;',
+		'PPI::Token::Word',           'use',
+		'PPI::Token::Word',           'strEct',
+		'PPI::Token::Structure',      ';',
+		'PPI::Statement::Sub',        'sub meep($) {}',
+		'PPI::Token::Word',           'sub',
+		'PPI::Token::Word',           'meep',
+		'PPI::Structure::Signature',  '($)',
+		'PPI::Token::Structure',      '(',
+		'PPI::Statement::Expression', '$',
+		'PPI::Token::Symbol',         '$',
+		'PPI::Token::Structure',      ')',
+		'PPI::Structure::Block',      '{}',
+		'PPI::Token::Structure',      '{',
+		'PPI::Token::Structure',      '}',
+		'PPI::Statement::Sub',        'sub marp($left, $right) {}',
+		'PPI::Token::Word',           'sub',
+		'PPI::Token::Word',           'marp',
+		'PPI::Structure::Signature',  '($left, $right)',
+		'PPI::Token::Structure',      '(',
+		'PPI::Statement::Expression', '$left, $right',
+		'PPI::Token::Symbol',         '$left',
+		'PPI::Token::Operator',       ',',
+		'PPI::Token::Symbol',         '$right',
+		'PPI::Token::Structure',      ')',
+		'PPI::Structure::Block',      '{}',
+		'PPI::Token::Structure',      '{',
+		'PPI::Token::Structure',      '}',
+	  ],
+	  "simple custom boilerplate modules";
+}
+
+HOMEBREW_CB: {
+	test_document    #
+	  [
+		custom_feature_include_cb => sub {
+			my ($inc) = @_;
+			my ($arg) = $inc->arguments;
+			return ( $inc->module eq "strEct" and $arg->string eq "sigg" )
+			  ? { signatures => 1 }
+			  : ();
+		}
+	  ],
+	  <<'END_PERL',
+		use strEct "sigg";
+		sub meep($) {}
+		sub marp($left, $right) {}
+END_PERL
+	  [
+		'PPI::Statement::Include',    'use strEct "sigg";',
+		'PPI::Token::Word',           'use',
+		'PPI::Token::Word',           'strEct',
+		'PPI::Token::Quote::Double',  '"sigg"',
+		'PPI::Token::Structure',      ';',
+		'PPI::Statement::Sub',        'sub meep($) {}',
+		'PPI::Token::Word',           'sub',
+		'PPI::Token::Word',           'meep',
+		'PPI::Structure::Signature',  '($)',
+		'PPI::Token::Structure',      '(',
+		'PPI::Statement::Expression', '$',
+		'PPI::Token::Symbol',         '$',
+		'PPI::Token::Structure',      ')',
+		'PPI::Structure::Block',      '{}',
+		'PPI::Token::Structure',      '{',
+		'PPI::Token::Structure',      '}',
+		'PPI::Statement::Sub',        'sub marp($left, $right) {}',
+		'PPI::Token::Word',           'sub',
+		'PPI::Token::Word',           'marp',
+		'PPI::Structure::Signature',  '($left, $right)',
+		'PPI::Token::Structure',      '(',
+		'PPI::Statement::Expression', '$left, $right',
+		'PPI::Token::Symbol',         '$left',
+		'PPI::Token::Operator',       ',',
+		'PPI::Token::Symbol',         '$right',
+		'PPI::Token::Structure',      ')',
+		'PPI::Structure::Block',      '{}',
+		'PPI::Token::Structure',      '{',
+		'PPI::Token::Structure',      '}',
+	  ],
+	  "callback for complex custom boilerplate modules";
+}
+
 ### TODO from ppi_token_unknown.t , deduplicate
 
 sub one_line_explain {