lib/MooseX/AttributeHelpers/MethodProvider.pm

   1 package MooseX::AttributeHelpers::MethodProvider;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Carp qw(confess);
   7 use Exporter qw(import);
   8 our @EXPORT = qw(get_provider_methods add_method_provider get_provider_type);
   9
  10 our $VERSION   = '0.01';
  11 our $AUTHORITY = 'cpan:STEVAN';
  12
  13 my %REGISTRY;
  14
  15 sub get_provider_type {
  16     my $name = shift;
  17     return $REGISTRY{$name}->{type} || confess "No provider named $name";
  18 }
  19
  20 sub get_provider_methods {
  21     my ($name, $how) = @_;
  22     $how ||= q();
  23
  24     my $methods = $REGISTRY{$name}->{provides}
  25         || confess "No provider named $name";
  26
  27     if ($how eq ':all') {
  28         return $methods;
  29     }
  30
  31     if (ref $how eq 'ARRAY') {
  32         return {
  33             map {
  34                 $_ => $methods->{$_} || confess "No factory named $_"
  35             } (@$how)
  36         };
  37     }
  38
  39     if (ref $how eq 'HASH') {
  40         return {
  41             map {
  42                 my ($old, $new) = ($_, $how->{$_});
  43                 $new => $methods->{$old} || confess "No factory named $old"
  44             } (keys %$how)
  45         };
  46     }
  47
  48     confess "Don't know to get provider methods by $how";
  49 }
  50
  51 sub add_method_provider ($;%) {
  52     my ($name, %options) = @_;
  53
  54     confess "Already a method provider named $name"
  55         if exists $REGISTRY{$name};
  56
  57     my $method_map = $options{provides} or confess "No factories provided";
  58
  59     my $consumes = $options{consumes};
  60     foreach my $provider (keys %$consumes) {
  61         my $methods = get_provider_methods($provider, $consumes->{$provider});
  62         foreach (keys %$methods) {
  63             confess "Method $_ already provided" if exists $method_map->{$_};
  64             $method_map->{$_} = $methods->{$_};
  65         };
  66     }
  67
  68     $REGISTRY{$name} = {
  69         type     => $options{type} || 'Any',
  70         provides => $method_map,
  71     };
  72 }
  73
  74 1;