lib/Moose/Meta/Role.pm

   1
   2 package Moose::Meta::Role;
   3
   4 use strict;
   5 use warnings;
   6 use metaclass;
   7
   8 use Carp         'confess';
   9 use Scalar::Util 'blessed', 'reftype';
  10 use Sub::Name    'subname';
  11 use B            'svref_2object';
  12
  13 our $VERSION = '0.01';
  14
  15 Moose::Meta::Role->meta->add_attribute('$:package' => (
  16     reader   => 'name',
  17     init_arg => ':package',
  18 ));
  19
  20 Moose::Meta::Role->meta->add_attribute('@:requires' => (
  21     reader    => 'requires',
  22     predicate => 'has_requires',
  23     init_arg  => ':requires',
  24     default   => sub { [] }
  25 ));
  26
  27 {
  28     my %ROLES;
  29     sub initialize {
  30         my ($class, %options) = @_;
  31         my $pkg = $options{':package'};
  32         $ROLES{$pkg} ||= $class->meta->new_object(%options);
  33     }
  34 }
  35
  36 sub add_method {
  37     my ($self, $method_name, $method) = @_;
  38     (defined $method_name && $method_name)
  39         || confess "You must define a method name";
  40     # use reftype here to allow for blessed subs ...
  41     ('CODE' eq (reftype($method) || ''))
  42         || confess "Your code block must be a CODE reference";
  43     my $full_method_name = ($self->name . '::' . $method_name);
  44
  45     no strict 'refs';
  46     no warnings 'redefine';
  47     *{$full_method_name} = subname $full_method_name => $method;
  48 }
  49
  50 sub alias_method {
  51     my ($self, $method_name, $method) = @_;
  52     (defined $method_name && $method_name)
  53         || confess "You must define a method name";
  54     # use reftype here to allow for blessed subs ...
  55     ('CODE' eq (reftype($method) || ''))
  56         || confess "Your code block must be a CODE reference";
  57     my $full_method_name = ($self->name . '::' . $method_name);
  58
  59     no strict 'refs';
  60     no warnings 'redefine';
  61     *{$full_method_name} = $method;
  62 }
  63
  64 sub has_method {
  65     my ($self, $method_name) = @_;
  66     (defined $method_name && $method_name)
  67         || confess "You must define a method name";
  68
  69     my $sub_name = ($self->name . '::' . $method_name);
  70
  71     no strict 'refs';
  72     return 0 if !defined(&{$sub_name});
  73         my $method = \&{$sub_name};
  74     return 0 if (svref_2object($method)->GV->STASH->NAME || '') ne $self->name &&
  75                 (svref_2object($method)->GV->NAME || '')        ne '__ANON__';
  76     return 1;
  77 }
  78
  79 sub get_method {
  80     my ($self, $method_name) = @_;
  81     (defined $method_name && $method_name)
  82         || confess "You must define a method name";
  83
  84         return unless $self->has_method($method_name);
  85
  86     no strict 'refs';
  87     return \&{$self->name . '::' . $method_name};
  88 }
  89
  90 sub remove_method {
  91     my ($self, $method_name) = @_;
  92     (defined $method_name && $method_name)
  93         || confess "You must define a method name";
  94
  95     my $removed_method = $self->get_method($method_name);
  96
  97     no strict 'refs';
  98     delete ${$self->name . '::'}{$method_name}
  99         if defined $removed_method;
 100
 101     return $removed_method;
 102 }
 103
 104 sub get_method_list {
 105     my $self = shift;
 106     no strict 'refs';
 107     grep { !/meta/ && $self->has_method($_) } %{$self->name . '::'};
 108 }
 109
 110 1;
 111
 112 __END__
 113
 114 =pod
 115
 116 =head1 NAME
 117
 118 Moose::Meta::Role - The Moose role metaobject
 119
 120 =head1 SYNOPSIS
 121
 122 =head1 DESCRIPTION
 123
 124 =head1 METHODS
 125
 126 =over 4
 127
 128 =back
 129
 130 =head1 BUGS
 131
 132 All complex software has bugs lurking in it, and this module is no
 133 exception. If you find a bug please either email me, or add the bug
 134 to cpan-RT.
 135
 136 =head1 AUTHOR
 137
 138 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 139
 140 =head1 COPYRIGHT AND LICENSE
 141
 142 Copyright 2006 by Infinity Interactive, Inc.
 143
 144 L<http://www.iinteractive.com>
 145
 146 This library is free software; you can redistribute it and/or modify
 147 it under the same terms as Perl itself.
 148
 149 =cut