Support for method modifiers in roles

tobyink · Jul 1, 2022 · 9b1e569 · 9b1e569
1 parent 77662ae
commit 9b1e569
Show file tree

Hide file tree

Showing 17 changed files with 214 additions and 115 deletions.
diff --git a/.mite/config b/.mite/config
@@ -1,6 +1,6 @@
 ---
 compiled_to: lib
 project: Mite
-shim: Mite::Miteception::Shim
+shim: Mite::Shim
 source_from: lib
 perltidy: 1
diff --git a/lib/Mite/App/Command.pm.mite.pm b/lib/Mite/App/Command.pm.mite.pm
@@ -76,6 +76,7 @@ sub DOES {
     my ( $self, $role ) = @_;
     our %DOES;
     return $DOES{$role} if exists $DOES{$role};
+    return 1 if $role eq __PACKAGE__;
     return $self->SUPER::DOES( $role );
 }
 

diff --git a/lib/Mite/App/Command/clean.pm.mite.pm b/lib/Mite/App/Command/clean.pm.mite.pm
@@ -76,6 +76,7 @@ sub DOES {
     my ( $self, $role ) = @_;
     our %DOES;
     return $DOES{$role} if exists $DOES{$role};
+    return 1 if $role eq __PACKAGE__;
     return $self->SUPER::DOES( $role );
 }
 

diff --git a/lib/Mite/App/Command/compile.pm.mite.pm b/lib/Mite/App/Command/compile.pm.mite.pm
@@ -76,6 +76,7 @@ sub DOES {
     my ( $self, $role ) = @_;
     our %DOES;
     return $DOES{$role} if exists $DOES{$role};
+    return 1 if $role eq __PACKAGE__;
     return $self->SUPER::DOES( $role );
 }
 

diff --git a/lib/Mite/App/Command/init.pm.mite.pm b/lib/Mite/App/Command/init.pm.mite.pm
@@ -76,6 +76,7 @@ sub DOES {
     my ( $self, $role ) = @_;
     our %DOES;
     return $DOES{$role} if exists $DOES{$role};
+    return 1 if $role eq __PACKAGE__;
     return $self->SUPER::DOES( $role );
 }
 

diff --git a/lib/Mite/Attribute.pm.mite.pm b/lib/Mite/Attribute.pm.mite.pm
@@ -91,6 +91,7 @@ sub DOES {
     my ( $self, $role ) = @_;
     our %DOES;
     return $DOES{$role} if exists $DOES{$role};
+    return 1 if $role eq __PACKAGE__;
     return $self->SUPER::DOES( $role );
 }
 

diff --git a/lib/Mite/Class.pm.mite.pm b/lib/Mite/Class.pm.mite.pm
@@ -22,14 +22,13 @@ sub new {
     # Initialize attributes
     if ( exists($args->{q[attributes]}) ) { (do { package Mite::Miteception; ref($args->{q[attributes]}) eq 'HASH' } and do { my $ok = 1; for my $i (values %{$args->{q[attributes]}}) { ($ok = 0, last) unless (do { use Scalar::Util (); Scalar::Util::blessed($i) and $i->isa(q[Mite::Attribute]) }) }; $ok }) or require Carp && Carp::croak(q[Type check failed in constructor: attributes should be HashRef[InstanceOf["Mite::Attribute"]]]); $self->{q[attributes]} = $args->{q[attributes]};  } else { my $value = do { my $default_value = do { my $method = $Mite::Role::__attributes_DEFAULT__; $self->$method }; do { package Mite::Miteception; (ref($default_value) eq 'HASH') and do { my $ok = 1; for my $i (values %{$default_value}) { ($ok = 0, last) unless (do { use Scalar::Util (); Scalar::Util::blessed($i) and $i->isa(q[Mite::Attribute]) }) }; $ok } } or do { require Carp; Carp::croak(q[Type check failed in default: attributes should be HashRef[InstanceOf["Mite::Attribute"]]]) }; $default_value }; $self->{q[attributes]} = $value;  }
     if ( exists($args->{q[extends]}) ) { (do { package Mite::Miteception; ref($args->{q[extends]}) eq 'ARRAY' } and do { my $ok = 1; for my $i (@{$args->{q[extends]}}) { ($ok = 0, last) unless do { package Mite::Miteception; defined($i) and do { ref(\$i) eq 'SCALAR' or ref(\(my $val = $i)) eq 'SCALAR' } } }; $ok }) or require Carp && Carp::croak(q[Type check failed in constructor: extends should be ArrayRef[Str]]); $self->{q[extends]} = $args->{q[extends]};  } else { my $value = do { my $default_value = do { my $method = $Mite::Class::__extends_DEFAULT__; $self->$method }; do { package Mite::Miteception; (ref($default_value) eq 'ARRAY') and do { my $ok = 1; for my $i (@{$default_value}) { ($ok = 0, last) unless do { package Mite::Miteception; defined($i) and do { ref(\$i) eq 'SCALAR' or ref(\(my $val = $i)) eq 'SCALAR' } } }; $ok } } or do { require Carp; Carp::croak(q[Type check failed in default: extends should be ArrayRef[Str]]) }; $default_value }; $self->{q[extends]} = $value;  } $self->_trigger_extends( $self->{q[extends]} );
-    if ( exists($args->{q[method_modifiers]}) ) { do { package Mite::Miteception; ref($args->{q[method_modifiers]}) eq 'ARRAY' } or require Carp && Carp::croak(q[Type check failed in constructor: method_modifiers should be ArrayRef]); $self->{q[method_modifiers]} = $args->{q[method_modifiers]};  } else { my $value = do { my $default_value = $self->_build_method_modifiers; (ref($default_value) eq 'ARRAY') or do { require Carp; Carp::croak(q[Type check failed in default: method_modifiers should be ArrayRef]) }; $default_value }; $self->{q[method_modifiers]} = $value;  }
     if ( exists($args->{q[name]}) ) { do { package Mite::Miteception; defined($args->{q[name]}) and do { ref(\$args->{q[name]}) eq 'SCALAR' or ref(\(my $val = $args->{q[name]})) eq 'SCALAR' } } or require Carp && Carp::croak(q[Type check failed in constructor: name should be Str]); $self->{q[name]} = $args->{q[name]};  } else { require Carp; Carp::croak("Missing key in constructor: name") }
     if ( exists($args->{q[parents]}) ) { (do { package Mite::Miteception; ref($args->{q[parents]}) eq 'ARRAY' } and do { my $ok = 1; for my $i (@{$args->{q[parents]}}) { ($ok = 0, last) unless (do { use Scalar::Util (); Scalar::Util::blessed($i) and $i->isa(q[Mite::Class]) }) }; $ok }) or require Carp && Carp::croak(q[Type check failed in constructor: parents should be ArrayRef[InstanceOf["Mite::Class"]]]); $self->{q[parents]} = $args->{q[parents]};  }
     if ( exists($args->{q[roles]}) ) { do { package Mite::Miteception; ref($args->{q[roles]}) eq 'ARRAY' } or require Carp && Carp::croak(q[Type check failed in constructor: roles should be ArrayRef]); $self->{q[roles]} = $args->{q[roles]};  } else { my $value = do { my $default_value = $self->_build_roles; (ref($default_value) eq 'ARRAY') or do { require Carp; Carp::croak(q[Type check failed in default: roles should be ArrayRef]) }; $default_value }; $self->{q[roles]} = $value;  }
     if ( exists($args->{q[source]}) ) { (do { use Scalar::Util (); Scalar::Util::blessed($args->{q[source]}) and $args->{q[source]}->isa(q[Mite::Source]) }) or require Carp && Carp::croak(q[Type check failed in constructor: source should be InstanceOf["Mite::Source"]]); $self->{q[source]} = $args->{q[source]};  } require Scalar::Util && Scalar::Util::weaken($self->{q[source]});
 
     # Enforce strict constructor
-    my @unknown = grep not( do { package Mite::Miteception; (defined and !ref and m{\A(?:(?:attributes|extends|method_modifiers|name|parents|roles|source))\z}) } ), keys %{$args}; @unknown and require Carp and Carp::croak("Unexpected keys in constructor: " . join(q[, ], sort @unknown));
+    my @unknown = grep not( do { package Mite::Miteception; (defined and !ref and m{\A(?:(?:attributes|extends|name|parents|roles|source))\z}) } ), keys %{$args}; @unknown and require Carp and Carp::croak("Unexpected keys in constructor: " . join(q[, ], sort @unknown));
 
     # Call BUILD methods
     unless ( $no_build ) { $_->($self, $args) for @{ $meta->{BUILD} || [] } };
@@ -82,6 +81,7 @@ sub DOES {
     my ( $self, $role ) = @_;
     our %DOES;
     return $DOES{$role} if exists $DOES{$role};
+    return 1 if $role eq __PACKAGE__;
     return $self->SUPER::DOES( $role );
 }
 

diff --git a/lib/Mite/Compiled.pm.mite.pm b/lib/Mite/Compiled.pm.mite.pm
@@ -70,6 +70,7 @@ sub DOES {
     my ( $self, $role ) = @_;
     our %DOES;
     return $DOES{$role} if exists $DOES{$role};
+    return 1 if $role eq __PACKAGE__;
     return $self->SUPER::DOES( $role );
 }
 

diff --git a/lib/Mite/Config.pm.mite.pm b/lib/Mite/Config.pm.mite.pm
@@ -73,6 +73,7 @@ sub DOES {
     my ( $self, $role ) = @_;
     our %DOES;
     return $DOES{$role} if exists $DOES{$role};
+    return 1 if $role eq __PACKAGE__;
     return $self->SUPER::DOES( $role );
 }
 

diff --git a/lib/Mite/MakeMaker.pm.mite.pm b/lib/Mite/MakeMaker.pm.mite.pm
@@ -69,6 +69,7 @@ sub DOES {
     my ( $self, $role ) = @_;
     our %DOES;
     return $DOES{$role} if exists $DOES{$role};
+    return 1 if $role eq __PACKAGE__;
     return $self->SUPER::DOES( $role );
 }
 

diff --git a/lib/Mite/Project.pm b/lib/Mite/Project.pm
@@ -70,6 +70,11 @@ sub source_for {
     );
 }
 
+my $parse_mm_args = sub {
+    my $coderef = pop;
+    my $names   = [ map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_ ];
+    ( $names, $coderef );
+};
 
 # This is the shim Mite.pm uses when compiling.
 sub inject_mite_class_functions {
@@ -124,13 +129,8 @@ sub inject_mite_class_functions {
         return;
     };
 
-    my $parse_args = sub {
-        my $coderef = pop;
-        my $names   = [ map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_ ];
-        ( $names, $coderef );
-    };
     *{ $package .'::'. $_ } = sub {
-        my ( $names, $coderef ) = &$parse_args;
+        my ( $names, $coderef ) = &$parse_mm_args;
         require Carp;
         CodeRef->check( $coderef )
             or Carp::croak( "Expected a coderef method modifier" );
@@ -186,6 +186,16 @@ sub inject_mite_role_functions {
         $role->add_roles_by_name( @_ );
     };
 
+    *{ $package .'::'. $_ } = sub {
+        my ( $names, $coderef ) = &$parse_mm_args;
+        require Carp;
+        CodeRef->check( $coderef )
+            or Carp::croak( "Expected a coderef method modifier" );
+        ArrayRef->of(Str)->check( $names ) && @$names
+            or Carp::croak( "Expected a list of method names to modify" );
+        return;
+    } for qw( before after around );
+
     return;
 }
 
@@ -306,6 +316,8 @@ sub add_mite_shim {
     $shim_file->parent->mkpath;
 
     my $shim_package = $self->config->data->{shim};
+    return $shim_file if $shim_package eq 'Mite::Shim';
+
     my $src_shim = $self->_find_mite_shim;
     my $code = $src_shim->slurp;
     $code =~ s/package Mite::Shim;/package $shim_package;/;

diff --git a/lib/Mite/Project.pm.mite.pm b/lib/Mite/Project.pm.mite.pm
@@ -70,6 +70,7 @@ sub DOES {
     my ( $self, $role ) = @_;
     our %DOES;
     return $DOES{$role} if exists $DOES{$role};
+    return 1 if $role eq __PACKAGE__;
     return $self->SUPER::DOES( $role );
 }
 

diff --git a/lib/Mite/Role.pm b/lib/Mite/Role.pm
@@ -31,11 +31,6 @@ has source =>
   # avoid a circular dep with Mite::Source
   weak_ref      => true;
 
-has method_modifiers =>
-  is            => ro,
-  isa           => ArrayRef,
-  builder       => sub { [] };
-
 has roles =>
   is            => ro,
   isa           => ArrayRef,
@@ -113,6 +108,7 @@ sub methods_to_import_from_roles {
         DOES
         does
         __META__
+        __FINALIZE_APPLICATION__
     );
 
     return \%methods;
@@ -138,12 +134,6 @@ sub project {
     return $self->source->project;
 }
 
-sub add_method_modifier {
-    my ( $self, $type, $names, $coderef ) = @_;
-    push @{ $self->method_modifiers }, [ $type, $names, $coderef ];
-    return;
-}
-
 sub add_attributes {
     state $sig = sig_pos( Object, slurpy ArrayRef[InstanceOf['Mite::Attribute']] );
     my ( $self, $attributes ) = &$sig;
@@ -235,6 +225,7 @@ sub compilation_stages {
         _compile_with
         _compile_does
         _compile_composed_methods
+        _compile_callback
     );
 }
 
@@ -282,6 +273,7 @@ sub DOES {
     my ( $self, $role ) = @_;
     our %DOES;
     return $DOES{$role} if exists $DOES{$role};
+    return 1 if $role eq __PACKAGE__;
     return $self->SUPER::DOES( $role );
 }
 
@@ -300,7 +292,9 @@ sub _compile_composed_methods {
 
     $code .= "# Methods from roles\n";
     for my $name ( sort keys %methods ) {
-        $code .= sprintf '*%s = \&%s;' . "\n", $name, $methods{$name};
+        # Use goto to help namespace::autoclean recognize these as
+        # not being imported methods.
+        $code .= sprintf 'sub %s { goto \&%s; }' . "\n", $name, $methods{$name};
     }
 
     return $code;
@@ -349,4 +343,43 @@ sub __META__ {
 CODE
 }
 
+sub _compile_callback {
+    my $self = shift;
+
+    my $role_list = join q[, ], map sprintf( 'q[%s]', $_->name ), @{ $self->roles };
+    my $shim = $self->project->config->data->{shim};
+
+    return sprintf <<'CODE', $role_list, $shim;
+# Callback which classes consuming this role will call
+sub __FINALIZE_APPLICATION__ {
+    my ( $me, $target ) = @_;
+    our ( %%CONSUMERS, @METHOD_MODIFIERS );
+
+    # Ensure a given target only consumes this role once.
+    if ( exists $CONSUMERS{$target} ) {
+        return;
+    }
+    $CONSUMERS{$target} = 1;
+
+    my $type = do { no strict 'refs'; ${"$target\::USES_MITE"} };
+    if ( $type ne 'Mite::Class' ) {
+        return;
+    }
+
+    my @roles = ( %s );
+    for my $role ( @roles ) {
+        $role->__FINALIZE_APPLICATION__( $target );
+    }
+
+    my $shim = q[%s];
+    for my $modifier_rule ( @METHOD_MODIFIERS ) {
+        my ( $modification, $names, $coderef ) = @$modifier_rule;
+        $shim->$modification( $target, $names, $coderef );
+    }
+
+    return;
+}
+CODE
+}
+
 1;
diff --git a/lib/Mite/Role.pm.mite.pm b/lib/Mite/Role.pm.mite.pm
@@ -14,13 +14,12 @@ sub new {
 
     # Initialize attributes
     if ( exists($args->{q[attributes]}) ) { (do { package Mite::Miteception; ref($args->{q[attributes]}) eq 'HASH' } and do { my $ok = 1; for my $i (values %{$args->{q[attributes]}}) { ($ok = 0, last) unless (do { use Scalar::Util (); Scalar::Util::blessed($i) and $i->isa(q[Mite::Attribute]) }) }; $ok }) or require Carp && Carp::croak(q[Type check failed in constructor: attributes should be HashRef[InstanceOf["Mite::Attribute"]]]); $self->{q[attributes]} = $args->{q[attributes]};  } else { my $value = do { my $default_value = do { my $method = $Mite::Role::__attributes_DEFAULT__; $self->$method }; do { package Mite::Miteception; (ref($default_value) eq 'HASH') and do { my $ok = 1; for my $i (values %{$default_value}) { ($ok = 0, last) unless (do { use Scalar::Util (); Scalar::Util::blessed($i) and $i->isa(q[Mite::Attribute]) }) }; $ok } } or do { require Carp; Carp::croak(q[Type check failed in default: attributes should be HashRef[InstanceOf["Mite::Attribute"]]]) }; $default_value }; $self->{q[attributes]} = $value;  }
-    if ( exists($args->{q[method_modifiers]}) ) { do { package Mite::Miteception; ref($args->{q[method_modifiers]}) eq 'ARRAY' } or require Carp && Carp::croak(q[Type check failed in constructor: method_modifiers should be ArrayRef]); $self->{q[method_modifiers]} = $args->{q[method_modifiers]};  } else { my $value = do { my $default_value = $self->_build_method_modifiers; (ref($default_value) eq 'ARRAY') or do { require Carp; Carp::croak(q[Type check failed in default: method_modifiers should be ArrayRef]) }; $default_value }; $self->{q[method_modifiers]} = $value;  }
     if ( exists($args->{q[name]}) ) { do { package Mite::Miteception; defined($args->{q[name]}) and do { ref(\$args->{q[name]}) eq 'SCALAR' or ref(\(my $val = $args->{q[name]})) eq 'SCALAR' } } or require Carp && Carp::croak(q[Type check failed in constructor: name should be Str]); $self->{q[name]} = $args->{q[name]};  } else { require Carp; Carp::croak("Missing key in constructor: name") }
     if ( exists($args->{q[roles]}) ) { do { package Mite::Miteception; ref($args->{q[roles]}) eq 'ARRAY' } or require Carp && Carp::croak(q[Type check failed in constructor: roles should be ArrayRef]); $self->{q[roles]} = $args->{q[roles]};  } else { my $value = do { my $default_value = $self->_build_roles; (ref($default_value) eq 'ARRAY') or do { require Carp; Carp::croak(q[Type check failed in default: roles should be ArrayRef]) }; $default_value }; $self->{q[roles]} = $value;  }
     if ( exists($args->{q[source]}) ) { (do { use Scalar::Util (); Scalar::Util::blessed($args->{q[source]}) and $args->{q[source]}->isa(q[Mite::Source]) }) or require Carp && Carp::croak(q[Type check failed in constructor: source should be InstanceOf["Mite::Source"]]); $self->{q[source]} = $args->{q[source]};  } require Scalar::Util && Scalar::Util::weaken($self->{q[source]});
 
     # Enforce strict constructor
-    my @unknown = grep not( do { package Mite::Miteception; (defined and !ref and m{\A(?:(?:attributes|method_modifiers|name|roles|source))\z}) } ), keys %{$args}; @unknown and require Carp and Carp::croak("Unexpected keys in constructor: " . join(q[, ], sort @unknown));
+    my @unknown = grep not( do { package Mite::Miteception; (defined and !ref and m{\A(?:(?:attributes|name|roles|source))\z}) } ), keys %{$args}; @unknown and require Carp and Carp::croak("Unexpected keys in constructor: " . join(q[, ], sort @unknown));
 
     # Call BUILD methods
     unless ( $no_build ) { $_->($self, $args) for @{ $meta->{BUILD} || [] } };
@@ -73,6 +72,7 @@ sub DOES {
     my ( $self, $role ) = @_;
     our %DOES;
     return $DOES{$role} if exists $DOES{$role};
+    return 1 if $role eq __PACKAGE__;
     return $self->SUPER::DOES( $role );
 }
 
@@ -93,17 +93,6 @@ else {
     *attributes = sub { @_ > 1 ? require Carp && Carp::croak("attributes is a read-only attribute of @{[ref $_[0]]}") : $_[0]{q[attributes]} };
 }
 
-# Accessors for method_modifiers
-if ( $__XS ) {
-    Class::XSAccessor->import(
-        chained => 1,
-        getters => { q[method_modifiers] => q[method_modifiers] },
-    );
-}
-else {
-    *method_modifiers = sub { @_ > 1 ? require Carp && Carp::croak("method_modifiers is a read-only attribute of @{[ref $_[0]]}") : $_[0]{q[method_modifiers]} };
-}
-
 # Accessors for name
 if ( $__XS ) {
     Class::XSAccessor->import(