lib/MooseX/Role/Parameterized.pm

   1 #!/usr/bin/env perl
   2 package MooseX::Role::Parameterized;
   3 use Moose (
   4     extends => { -as => 'moose_extends' },
   5     around => { -as => 'moose_around' },
   6     'confess',
   7 );
   8
   9 use Carp 'croak';
  10 use Moose::Role ();
  11 moose_extends 'Moose::Exporter';
  12
  13 use MooseX::Role::Parameterized::Meta::Role::Parameterizable;
  14
  15 our $CURRENT_METACLASS;
  16
  17 __PACKAGE__->setup_import_methods(
  18     with_caller => ['parameter', 'role', 'method'],
  19     as_is       => ['has', 'with', 'extends', 'requires', 'excludes', 'augment', 'inner', 'before', 'after', 'around'],
  20 );
  21
  22 sub parameter {
  23     my $caller = shift;
  24     my $names  = shift;
  25
  26     $names = [$names] if !ref($names);
  27
  28     for my $name (@$names) {
  29         Class::MOP::Class->initialize($caller)->add_parameter($name, @_);
  30     }
  31 }
  32
  33 sub role {
  34     my $caller         = shift;
  35     my $role_generator = shift;
  36     Class::MOP::Class->initialize($caller)->role_generator($role_generator);
  37 }
  38
  39 sub init_meta {
  40     my $self = shift;
  41
  42     return Moose::Role->init_meta(@_,
  43         metaclass => 'MooseX::Role::Parameterized::Meta::Role::Parameterizable',
  44     );
  45 }
  46
  47 # give role a (&) prototype
  48 moose_around _make_wrapper => sub {
  49     my $orig = shift;
  50     my ($self, $caller, $sub, $fq_name) = @_;
  51
  52     if ($fq_name =~ /::role$/) {
  53         return sub (&) { $sub->($caller, @_) };
  54     }
  55
  56     return $orig->(@_);
  57 };
  58
  59 sub has {
  60     confess "has must be called within the role { ... } block."
  61         unless $CURRENT_METACLASS;
  62
  63     my $names = shift;
  64     $names = [$names] if !ref($names);
  65
  66     for my $name (@$names) {
  67         $CURRENT_METACLASS->add_attribute($name, @_);
  68     }
  69 }
  70
  71 sub method {
  72     confess "method must be called within the role { ... } block."
  73         unless $CURRENT_METACLASS;
  74
  75     my $caller = shift;
  76     my $name   = shift;
  77     my $body   = shift;
  78
  79     my $method = $CURRENT_METACLASS->method_metaclass->wrap(
  80         package_name => $caller,
  81         name         => $name,
  82         body         => $body,
  83     );
  84
  85     $CURRENT_METACLASS->add_method($name => $method);
  86 }
  87
  88 sub before {
  89     confess "before must be called within the role { ... } block."
  90         unless $CURRENT_METACLASS;
  91
  92     my $code = pop @_;
  93
  94     for (@_) {
  95         croak "Roles do not currently support "
  96             . ref($_)
  97             . " references for before method modifiers"
  98             if ref $_;
  99         $CURRENT_METACLASS->add_before_method_modifier($_, $code);
 100     }
 101 }
 102
 103 sub after {
 104     confess "after must be called within the role { ... } block."
 105         unless $CURRENT_METACLASS;
 106
 107     my $code = pop @_;
 108
 109     for (@_) {
 110         croak "Roles do not currently support "
 111             . ref($_)
 112             . " references for after method modifiers"
 113             if ref $_;
 114         $CURRENT_METACLASS->add_after_method_modifier($_, $code);
 115     }
 116 }
 117
 118 sub around {
 119     confess "around must be called within the role { ... } block."
 120         unless $CURRENT_METACLASS;
 121
 122     my $code = pop @_;
 123
 124     for (@_) {
 125         croak "Roles do not currently support "
 126             . ref($_)
 127             . " references for around method modifiers"
 128             if ref $_;
 129         $CURRENT_METACLASS->add_around_method_modifier($_, $code);
 130     }
 131 }
 132
 133 sub with {
 134     confess "with must be called within the role { ... } block."
 135         unless $CURRENT_METACLASS;
 136     Moose::Util::apply_all_roles($CURRENT_METACLASS, @_);
 137 }
 138
 139 sub requires {
 140     confess "requires must be called within the role { ... } block."
 141         unless $CURRENT_METACLASS;
 142     croak "Must specify at least one method" unless @_;
 143     $CURRENT_METACLASS->add_required_methods(@_);
 144 }
 145
 146 sub excludes {
 147     confess "excludes must be called within the role { ... } block."
 148         unless $CURRENT_METACLASS;
 149     croak "Must specify at least one role" unless @_;
 150     $CURRENT_METACLASS->add_excluded_roles(@_);
 151 }
 152
 153 sub extends { croak "Roles do not currently support 'extends'" }
 154
 155 sub inner { croak "Roles cannot support 'inner'" }
 156
 157 sub augment { croak "Roles cannot support 'augment'" }
 158
 159 1;
 160