lib/MooseX/Role/Parameterized.pm

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