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