lib/MooseX/Role/Parameterized.pm

   1 #!/usr/bin/env perl
   2 package MooseX::Role::Parameterized;
   3 use Moose (
   4     extends => { -as => 'moose_extends' },
   5     qw/around confess/,
   6 );
   7
   8 use Carp 'croak';
   9 use Moose::Role ();
  10 moose_extends 'Moose::Exporter';
  11
  12 use MooseX::Role::Parameterized::Meta::Role::Parameterizable;
  13
  14 our $CURRENT_METACLASS;
  15
  16 __PACKAGE__->setup_import_methods(
  17     with_caller => ['parameter', 'role', 'method'],
  18     as_is       => ['has', 'with', 'extends', 'augment', 'inner'],
  19 );
  20
  21 sub parameter {
  22     my $caller = shift;
  23     my $names  = shift;
  24
  25     $names = [$names] if !ref($names);
  26
  27     for my $name (@$names) {
  28         Class::MOP::Class->initialize($caller)->add_parameter($name, @_);
  29     }
  30 }
  31
  32 sub role {
  33     my $caller         = shift;
  34     my $role_generator = shift;
  35     Class::MOP::Class->initialize($caller)->role_generator($role_generator);
  36 }
  37
  38 sub init_meta {
  39     my $self = shift;
  40
  41     return Moose::Role->init_meta(@_,
  42         metaclass => 'MooseX::Role::Parameterized::Meta::Role::Parameterizable',
  43     );
  44 }
  45
  46 # give role a (&) prototype
  47 around _make_wrapper => sub {
  48     my $orig = shift;
  49     my ($self, $caller, $sub, $fq_name) = @_;
  50
  51     if ($fq_name =~ /::role$/) {
  52         return sub (&) { $sub->($caller, @_) };
  53     }
  54
  55     return $orig->(@_);
  56 };
  57
  58 sub has {
  59     confess "has must be called within the role { ... } block."
  60         unless $CURRENT_METACLASS;
  61
  62     my $names = shift;
  63     $names = [$names] if !ref($names);
  64
  65     for my $name (@$names) {
  66         $CURRENT_METACLASS->add_attribute($name, @_);
  67     }
  68 }
  69
  70 sub method {
  71     confess "method must be called within the role { ... } block."
  72         unless $CURRENT_METACLASS;
  73
  74     my $caller = shift;
  75     my $name   = shift;
  76     my $body   = shift;
  77
  78     my $method = $CURRENT_METACLASS->method_metaclass->wrap(
  79         package_name => $caller,
  80         name         => $name,
  81         body         => $body,
  82     );
  83
  84     $CURRENT_METACLASS->add_method($name => $method);
  85 }
  86
  87 sub with {
  88     confess "with must be called within the role { ... } block."
  89         unless $CURRENT_METACLASS;
  90     Moose::Util::apply_all_roles($CURRENT_METACLASS, @_);
  91 }
  92
  93 sub extends { croak "Roles do not currently support 'extends'" }
  94
  95 sub inner { croak "Roles cannot support 'inner'" }
  96
  97 sub augment { croak "Roles cannot support 'augment'" }
  98
  99 1;
 100