Lots of files got moved around,a nd some got added.

[gitmo/MooseX-AttributeHelpers.git] / lib / MooseX / AttributeHelpers / MethodProvider.pm

diff --git a/lib/MooseX/AttributeHelpers/MethodProvider.pm b/lib/MooseX/AttributeHelpers/MethodProvider.pm
new file mode 100644 (file)
index 0000000..8317f29
--- /dev/null
+++ b/lib/MooseX/AttributeHelpers/MethodProvider.pm
@@ -0,0 +1,74 @@
+package MooseX::AttributeHelpers::MethodProvider;
+
+use strict;
+use warnings;
+
+use Carp qw(confess);
+use Exporter qw(import);
+our @EXPORT = qw(get_provider_methods add_method_provider get_provider_type);
+
+our $VERSION   = '0.01';
+our $AUTHORITY = 'cpan:STEVAN';
+
+my %REGISTRY;
+
+sub get_provider_type {
+    my $name = shift;
+    return $REGISTRY{$name}->{type} || confess "No provider named $name";
+}
+
+sub get_provider_methods {
+    my ($name, $how) = @_;
+    $how ||= q();
+
+    my $methods = $REGISTRY{$name}->{provides}
+        || confess "No provider named $name";
+
+    if ($how eq ':all') {
+        return $methods;
+    }
+
+    if (ref $how eq 'ARRAY') {
+        return { 
+            map { 
+                $_ => $methods->{$_} || confess "No factory named $_" 
+            } (@$how) 
+        };
+    }
+
+    if (ref $how eq 'HASH') {
+        return { 
+            map { 
+                my ($old, $new) = ($_, $how->{$_});
+                $new => $methods->{$old} || confess "No factory named $old"
+            } (keys %$how)
+        };
+    }
+
+    confess "Don't know to get provider methods by $how";
+}
+
+sub add_method_provider ($;%) {
+    my ($name, %options) = @_;
+
+    confess "Already a method provider named $name" 
+        if exists $REGISTRY{$name};
+
+    my $method_map = $options{provides} or confess "No factories provided";
+
+    my $consumes = $options{consumes};
+    foreach my $provider (keys %$consumes) {
+        my $methods = get_provider_methods($provider, $consumes->{$provider});
+        foreach (keys %$methods) {
+            confess "Method $_ already provided" if exists $method_map->{$_};
+            $method_map->{$_} = $methods->{$_};
+        };
+    }
+
+    $REGISTRY{$name} = {
+        type     => $options{type} || 'Any',
+        provides => $method_map,
+    };
+}
+
+1;