lib/Mouse/Meta/Module.pm

   1 package Mouse::Meta::Module;
   2 use Mouse::Util qw/:meta get_code_package get_code_ref load_class not_supported/; # enables strict and warnings
   3
   4 use Carp         ();
   5 use Scalar::Util ();
   6
   7 my %METAS;
   8
   9 if(Mouse::Util::_MOUSE_XS){
  10     # register meta storage for performance
  11     Mouse::Util::__register_metaclass_storage(\%METAS, 0);
  12
  13     # ensure thread safety
  14     *CLONE = sub { Mouse::Util::__register_metaclass_storage(\%METAS, 1) };
  15 }
  16
  17 sub _metaclass_cache { # DEPRECATED
  18     my($class, $name) = @_;
  19     return $METAS{$name};
  20 }
  21
  22 sub initialize {
  23     my($class, $package_name, @args) = @_;
  24
  25     ($package_name && !ref($package_name))
  26         || $class->throw_error("You must pass a package name and it cannot be blessed");
  27
  28     return $METAS{$package_name}
  29         ||= $class->_construct_meta(package => $package_name, @args);
  30 }
  31
  32 sub class_of{
  33     my($class_or_instance) = @_;
  34     return undef unless defined $class_or_instance;
  35     return $METAS{ ref($class_or_instance) || $class_or_instance };
  36 }
  37
  38 # Means of accessing all the metaclasses that have
  39 # been initialized thus far
  40 #sub get_all_metaclasses         {        %METAS         }
  41 sub get_all_metaclass_instances { values %METAS         }
  42 sub get_all_metaclass_names     { keys   %METAS         }
  43 sub get_metaclass_by_name       { $METAS{$_[0]}         }
  44 #sub store_metaclass_by_name     { $METAS{$_[0]} = $_[1] }
  45 #sub weaken_metaclass            { weaken($METAS{$_[0]}) }
  46 #sub does_metaclass_exist        { defined $METAS{$_[0]} }
  47 #sub remove_metaclass_by_name    { delete $METAS{$_[0]}  }
  48
  49 sub name;
  50
  51 sub namespace;
  52
  53 # The followings are Class::MOP specific methods
  54
  55 #sub version   { no strict 'refs'; ${shift->name.'::VERSION'}   }
  56 #sub authority { no strict 'refs'; ${shift->name.'::AUTHORITY'} }
  57 #sub identifier {
  58 #    my $self = shift;
  59 #    return join '-' => (
  60 #       $self->name,
  61 #        ($self->version   || ()),
  62 #        ($self->authority || ()),
  63 #    );
  64 #}
  65
  66 # add_attribute is an abstract method
  67
  68 sub get_attribute_map { # DEPRECATED
  69     Carp::cluck('get_attribute_map() has been deprecated');
  70     return $_[0]->{attributes};
  71 }
  72
  73 sub has_attribute     { exists $_[0]->{attributes}->{$_[1]} }
  74 sub get_attribute     {        $_[0]->{attributes}->{$_[1]} }
  75 sub remove_attribute  { delete $_[0]->{attributes}->{$_[1]} }
  76
  77 sub get_attribute_list{ keys   %{$_[0]->{attributes}} }
  78
  79
  80 # XXX: for backward compatibility
  81 my %foreign = map{ $_ => undef } qw(
  82     Mouse Mouse::Role Mouse::Util Mouse::Util::TypeConstraints
  83     Carp Scalar::Util List::Util
  84 );
  85 sub _code_is_mine{
  86 #    my($self, $code) = @_;
  87
  88     return !exists $foreign{ get_code_package($_[1]) };
  89 }
  90
  91 sub add_method;
  92
  93 sub has_method {
  94     my($self, $method_name) = @_;
  95
  96     defined($method_name)
  97         or $self->throw_error('You must define a method name');
  98
  99     return defined($self->{methods}{$method_name}) || do{
 100         my $code = get_code_ref($self->{package}, $method_name);
 101         $code && $self->_code_is_mine($code);
 102     };
 103 }
 104
 105 sub get_method_body {
 106     my($self, $method_name) = @_;
 107
 108     defined($method_name)
 109         or $self->throw_error('You must define a method name');
 110
 111     return $self->{methods}{$method_name} ||= do{
 112         my $code = get_code_ref($self->{package}, $method_name);
 113         $code && $self->_code_is_mine($code) ? $code : undef;
 114     };
 115 }
 116
 117 sub get_method{
 118     my($self, $method_name) = @_;
 119
 120     if(my $code = $self->get_method_body($method_name)){
 121         my $method_metaclass = $self->method_metaclass;
 122         load_class($method_metaclass);
 123
 124         return $method_metaclass->wrap(
 125             body                 => $code,
 126             name                 => $method_name,
 127             package              => $self->name,
 128             associated_metaclass => $self,
 129         );
 130     }
 131
 132     return undef;
 133 }
 134
 135 sub get_method_list {
 136     my($self) = @_;
 137
 138     return grep { $self->has_method($_) } keys %{ $self->namespace };
 139 }
 140
 141 {
 142     my $ANON_SERIAL = 0;
 143
 144     my %IMMORTALS;
 145
 146     sub create {
 147         my($self, $package_name, %options) = @_;
 148
 149         my $class = ref($self) || $self;
 150         $self->throw_error('You must pass a package name') if @_ < 2;
 151
 152         my $superclasses;
 153         if(exists $options{superclasses}){
 154             if(Mouse::Util::is_a_metarole($self)){
 155                 delete $options{superclasses};
 156             }
 157             else{
 158                 $superclasses = delete $options{superclasses};
 159                 (ref $superclasses eq 'ARRAY')
 160                     || $self->throw_error("You must pass an ARRAY ref of superclasses");
 161             }
 162         }
 163
 164         my $attributes = delete $options{attributes};
 165         if(defined $attributes){
 166             (ref $attributes eq 'ARRAY' || ref $attributes eq 'HASH')
 167                 || $self->throw_error("You must pass an ARRAY ref of attributes");
 168         }
 169         my $methods = delete $options{methods};
 170         if(defined $methods){
 171             (ref $methods eq 'HASH')
 172                 || $self->throw_error("You must pass a HASH ref of methods");
 173         }
 174         my $roles = delete $options{roles};
 175         if(defined $roles){
 176             (ref $roles eq 'ARRAY')
 177                 || $self->throw_error("You must pass an ARRAY ref of roles");
 178         }
 179         my $mortal;
 180         my $cache_key;
 181
 182         if(!defined $package_name){ # anonymous
 183             $mortal = !$options{cache};
 184
 185             # anonymous but immortal
 186             if(!$mortal){
 187                     # something like Super::Class|Super::Class::2=Role|Role::1
 188                     $cache_key = join '=' => (
 189                         join('|',      @{$superclasses || []}),
 190                         join('|', sort @{$roles        || []}),
 191                     );
 192                     return $IMMORTALS{$cache_key} if exists $IMMORTALS{$cache_key};
 193             }
 194             $options{anon_serial_id} = ++$ANON_SERIAL;
 195             $package_name = $class . '::__ANON__::' . $ANON_SERIAL;
 196         }
 197
 198         # instantiate a module
 199         {
 200             no strict 'refs';
 201             ${ $package_name . '::VERSION'   } = delete $options{version}   if exists $options{version};
 202             ${ $package_name . '::AUTHORITY' } = delete $options{authority} if exists $options{authority};
 203         }
 204
 205         my $meta = $self->initialize( $package_name, %options);
 206
 207         Scalar::Util::weaken $METAS{$package_name}
 208             if $mortal;
 209
 210         $meta->add_method(meta => sub{
 211             $self->initialize(ref($_[0]) || $_[0]);
 212         });
 213
 214         $meta->superclasses(@{$superclasses})
 215             if defined $superclasses;
 216
 217         # NOTE:
 218         # process attributes first, so that they can
 219         # install accessors, but locally defined methods
 220         # can then overwrite them. It is maybe a little odd, but
 221         # I think this should be the order of things.
 222         if (defined $attributes) {
 223             if(ref($attributes) eq 'ARRAY'){
 224                 # array of Mouse::Meta::Attribute
 225                 foreach my $attr (@{$attributes}) {
 226                     $meta->add_attribute($attr);
 227                 }
 228             }
 229             else{
 230                 # hash map of name and attribute spec pairs
 231                 while(my($name, $attr) = each %{$attributes}){
 232                     $meta->add_attribute($name => $attr);
 233                 }
 234             }
 235         }
 236         if (defined $methods) {
 237             while(my($method_name, $method_body) = each %{$methods}){
 238                 $meta->add_method($method_name, $method_body);
 239             }
 240         }
 241         if (defined $roles){
 242             Mouse::Util::apply_all_roles($package_name, @{$roles});
 243         }
 244
 245         if($cache_key){
 246             $IMMORTALS{$cache_key} = $meta;
 247         }
 248
 249         return $meta;
 250     }
 251
 252     sub DESTROY{
 253         my($self) = @_;
 254
 255         my $serial_id = $self->{anon_serial_id};
 256
 257         return if !$serial_id;
 258
 259         # @ISA is a magical variable, so we clear it manually.
 260         @{$self->{superclasses}} = () if exists $self->{superclasses};
 261
 262         # Then, clear the symbol table hash
 263         %{$self->namespace} = ();
 264
 265         my $name = $self->name;
 266         delete $METAS{$name};
 267
 268         $name =~ s/ $serial_id \z//xms;
 269
 270         no strict 'refs';
 271         delete ${$name}{ $serial_id . '::' };
 272
 273         return;
 274     }
 275 }
 276
 277 sub throw_error{
 278     my($class, $message, %args) = @_;
 279
 280     local $Carp::CarpLevel  = $Carp::CarpLevel + 1 + ($args{depth} || 0);
 281     local $Carp::MaxArgNums = 20; # default is 8, usually we use named args which gets messier though
 282
 283     if(exists $args{longmess} && !$args{longmess}){ # intentionaly longmess => 0
 284         Carp::croak($message);
 285     }
 286     else{
 287         Carp::confess($message);
 288     }
 289 }
 290
 291 1;
 292
 293 __END__
 294
 295 =head1 NAME
 296
 297 Mouse::Meta::Module - The base class for Mouse::Meta::Class and Mouse::Meta::Role
 298
 299 =head1 VERSION
 300
 301 This document describes Mouse version 0.40_06
 302
 303 =head1 SEE ALSO
 304
 305 L<Class::MOP::Class>
 306
 307 L<Class::MOP::Module>
 308
 309 L<Class::MOP::Package>
 310
 311 =cut
 312