Merge pull request #345 from tom-binary/feature/attribute_storage

Switch to Attribute::Storage for dealing with method annotations

Makefile.PL

@@ -24,6 +24,7 @@ my %WriteMakefileArgs = (
   "PREREQ_PM" => {
     "Alien::ProtoBuf" => 0,
     "Alien::uPB::Core" => 0,
+    "Attribute::Storage" => "0.12",
     "Check::UnitCheck" => 0,
     "Class::Method::Modifiers" => 0,
     "Compress::Zstd" => "0.20",
@@ -87,7 +88,7 @@ my %WriteMakefileArgs = (
     "curry" => "2.000001",
     "experimental" => "0.032",
     "indirect" => 0,
-    "meta" => "0.004",
+    "meta" => "0.008",
     "mro" => 0,
     "multidimensional" => 0
   },
@@ -117,6 +118,7 @@ my %WriteMakefileArgs = (
 my %FallbackPrereqs = (
   "Alien::ProtoBuf" => 0,
   "Alien::uPB::Core" => 0,
+  "Attribute::Storage" => "0.12",
   "Check::UnitCheck" => 0,
   "Class::Method::Modifiers" => 0,
   "Compress::Zstd" => "0.20",
@@ -194,7 +196,7 @@ my %FallbackPrereqs = (
   "curry" => "2.000001",
   "experimental" => "0.032",
   "indirect" => 0,
-  "meta" => "0.004",
+  "meta" => "0.008",
   "mro" => 0,
   "multidimensional" => 0
 );

cpanfile

@@ -1,5 +1,5 @@
 # Syntax
-requires 'meta', '>= 0.004';
+requires 'meta', '>= 0.008';
 requires 'mro';
 requires 'indirect';
 requires 'multidimensional';
@@ -23,6 +23,7 @@ requires 'Data::Checks', '>= 0.09';
 requires 'Object::Pad::FieldAttr::Checked';
 requires 'Sublike::Extended';
 requires 'Signature::Attribute::Checked', '>= 0.06';
+requires 'Attribute::Storage', '>= 0.12';
 # Streams
 requires 'Ryu', '>= 4.000';
 requires 'Ryu::Async', '>= 0.020';

lib/Myriad/Class.pm

@@ -49,6 +49,8 @@ The following Perl language features and modules are applied:
 
 =item * no L<bareword::filehandles>
 
+=item * L<meta>
+
 =item * L<Syntax::Keyword::Try>
 
 =item * L<Syntax::Keyword::Dynamically>
@@ -190,6 +192,8 @@ no multidimensional;
 no bareword::filehandles;
 use mro;
 use experimental qw(signatures);
+use meta;
+no warnings qw(meta::experimental);
 use curry;
 use Data::Checks;
 use Object::Pad::FieldAttr::Checked;
@@ -248,6 +252,8 @@ sub import {
     strict->import;
     warnings->import;
     utf8->import;
+    # ... but turn off experimental warnings for things that we use frequently
+    warnings->unimport(qw(meta::experimental));
 
     # We want mostly the 5.36 featureset, but since that includes `say` and `switch`
     # we need to customise the list somewhat

lib/Myriad/Service/Attributes.pm

@@ -1,6 +1,6 @@
 package Myriad::Service::Attributes;
 
-use Myriad::Class;
+use Myriad::Class class => '';
 
 # VERSION
 # AUTHORITY
@@ -26,16 +26,22 @@ which does all the real work.
 
 =cut
 
+use Attribute::Storage qw(get_subattr);
+
 use Myriad::Registry;
 
+use List::Util qw(pairmap);
 use Sub::Util ();
 
-our %KNOWN_ATTRIBUTES = (
-    RPC      => 'rpc',
-    Batch    => 'batch',
-    Emitter  => 'emitter',
-    Receiver => 'receiver',
-);
+our %KNOWN_ATTRIBUTES = map {;
+    my ($sym) = /[A-Za-z0-9_]+/g;
+    $sym => $sym
+} pairmap {
+    my $attr = get_subattr($b->reference, 'ATTR');
+    ($attr && $attr->{code})
+    ? $a
+    : ()
+} meta::get_this_package()->list_symbols(sigils => '&');
 
 =head1 METHODS
 
@@ -46,29 +52,6 @@ up attributes ourselves.
 
 =cut
 
-sub apply_attributes {
-    my ($class, %args) = @_;
-    my $pkg = $args{class};
-    my ($method) = Sub::Util::subname($args{code}) =~ /::([^:]+)$/;
-    for my $attr ($args{attributes}->@*) {
-        my ($type, $args) = $attr =~ m{^([a-z]+)(.*$)}si;
-        # Nasty, but functional for now - this will likely be replaced by
-        # an m//gc parser later with a restricted set of options.
-        $args = eval "+{ $args }" // die 'invalid attribute parameters: ' . $@ if length $args;
-
-        $log->tracef('Applying %s attribute to %s::%s with args (%s)', $type, $pkg, $method, $args);
-        my $handler = $KNOWN_ATTRIBUTES{$type}
-            or die 'unknown attribute ' . $type;
-        $class->$handler(
-            $pkg,
-            $method,
-            $args{code},
-            $args
-        );
-    }
-    return;
-}
-
 =head2 RPC
 
 Mark this async method as a callable RPC method.
@@ -81,14 +64,14 @@ This will cause the method to be registered in L<Myriad::Registry/add_rpc>.
 
 =cut
 
-sub rpc {
-    my ($class, $pkg, $method, $code, $args) = @_;
+sub RPC:ATTR(CODE,NAME) ($class, $method_name, @args) {
     require Myriad;
+    my $code = $class->can($method_name);
     $Myriad::REGISTRY->add_rpc(
-        $pkg,
-        $method,
+        $class,
+        $method_name,
         $code,
-        $args
+        +{ @args }
     );
 }
 
@@ -114,13 +97,14 @@ Takes the following parameters as a hashref:
 
 =cut
 
-sub batch {
-    my ($class, $pkg, $method, $code, $args) = @_;
+sub Batch:ATTR(CODE,NAME) ($class, $method_name, @args) {
+    require Myriad;
+    my $code = $class->can($method_name);
     $Myriad::REGISTRY->add_batch(
-        $pkg,
-        $method,
+        $class,
+        $method_name,
         $code,
-        $args,
+        +{ @args }
     );
 }
 
@@ -143,13 +127,14 @@ Takes the following parameters as a hashref:
 
 =cut
 
-sub emitter {
-    my ($class, $pkg, $method, $code, $args) = @_;
+sub Emitter:ATTR(CODE,NAME) ($class, $method_name, @args) {
+    require Myriad;
+    my $code = $class->can($method_name);
     $Myriad::REGISTRY->add_emitter(
-        $pkg,
-        $method,
+        $class,
+        $method_name,
         $code,
-        $args,
+        +{ @args }
     );
 }
 
@@ -160,13 +145,14 @@ L<Ryu::Source>. Events will be emitted to that source until termination.
 
 =cut
 
-sub receiver {
-    my ($class, $pkg, $method, $code, $args) = @_;
+sub Receiver:ATTR(CODE,NAME) ($class, $method_name, @args) {
+    require Myriad;
+    my $code = $class->can($method_name);
     $Myriad::REGISTRY->add_receiver(
-        $pkg,
-        $method,
+        $class,
+        $method_name,
         $code,
-        $args,
+        +{ @args }
     );
 }
 

lib/Myriad/Service/Implementation.pm

@@ -21,7 +21,7 @@ use Myriad::Storage::Implementation::Redis;
 use Myriad::Subscription;
 use Myriad::Util::UUID;
 
-use Myriad::Service::Attributes;
+use parent qw(Myriad::Service::Attributes);
 
 # Only defer up to this many seconds between batch iterations
 use constant MAX_EXPONENTIAL_BACKOFF => 2;
@@ -37,15 +37,6 @@ BEGIN {
     }
 }
 
-sub MODIFY_CODE_ATTRIBUTES {
-    my ($class, $code, @attrs) = @_;
-    Myriad::Service::Attributes->apply_attributes(
-        class      => $class,
-        code       => $code,
-        attributes => \@attrs
-    );
-}
-
 field $ryu;
 field $storage;
 field $myriad;

lib/Myriad/Subscription/Implementation/Memory.pm

@@ -2,7 +2,6 @@ package Myriad::Subscription::Implementation::Memory;
 
 use Myriad::Class ':v2', extends => qw(IO::Async::Notifier), does => [
     'Myriad::Role::Subscription',
-    'Myriad::Util::Defer'
 ];
 
 use constant USE_OPENTELEMETRY => $ENV{USE_OPENTELEMETRY};
@@ -16,6 +15,8 @@ BEGIN {
     }
 }
 
+use Myriad::Util::Defer;
+
 # VERSION
 # AUTHORITY
 
@@ -26,9 +27,6 @@ field $receivers;
 field $should_shutdown = 0;
 field $stopped;
 
-# FIXME Need to update :Defer for Object::Pad
-sub MODIFY_CODE_ATTRIBUTES { }
-
 BUILD {
     $receivers = [];
 }

lib/Myriad/Util/Defer.pm

@@ -23,30 +23,24 @@ and defaults to no delay.
 use constant RANDOM_DELAY => $ENV{MYRIAD_RANDOM_DELAY} || 0;
 
 use Sub::Util;
+use Attribute::Storage;
 
-sub MODIFY_CODE_ATTRIBUTES ($class, $code, @attrs) {
-    my $name = Sub::Util::subname($code);
-    my ($method_name) = $name =~ m{::([^:]+)$};
+# Attribute for code that wants to defer execution
+sub Defer :ATTR(CODE,NAME) ($class, $method_name, @attrs) {
     my $defer = __PACKAGE__->can('defer_method');
-    for my $attr (@attrs) {
-        if($attr eq 'Defer') {
-            $defer->($class, $method_name, $name);
-        } else {
-            die 'unknown attribute ' . $attr;
-        }
-    }
-    return;
+    $defer->($class, $method_name);
+    return 1;
 }
 
 sub import ($class, @) {
     my $pkg = caller;
-    no strict;
-    *{$pkg . '::MODIFY_CODE_ATTRIBUTES'} = $class->can('MODIFY_CODE_ATTRIBUTES');
+    push meta::get_package($pkg)->get_or_add_symbol(q{@ISA})->reference->@*, __PACKAGE__;
+    return;
 }
 
 # Helper method that allows us to return a not-quite-immediate
 # Future from some inherently non-async code.
-sub defer_method ($package, $name, $fqdn) {
+sub defer_method ($package, $name) {
     $log->tracef('will defer handler for %s::%s by %f', $package, $name, RANDOM_DELAY);
     my $code = $package->can($name);
     my $replacement = async sub ($self, @args) {