lib/Mouse/Meta/Module.pm

   1 package Mouse::Meta::Module;
   2 use strict;
   3 use warnings;
   4
   5 use Carp ();
   6 use Scalar::Util qw/blessed weaken/;
   7
   8 use Mouse::Util qw/:meta get_code_package not_supported load_class/;
   9
  10
  11 my %METAS;
  12
  13 # because Mouse doesn't introspect existing classes, we're forced to
  14 # only pay attention to other Mouse classes
  15 sub _metaclass_cache {
  16     my($class, $name) = @_;
  17     return $METAS{$name};
  18 }
  19
  20 sub initialize {
  21     my($class, $package_name, @args) = @_;
  22
  23     ($package_name && !ref($package_name))
  24         || $class->throw_error("You must pass a package name and it cannot be blessed");
  25
  26     return $METAS{$package_name}
  27         ||= $class->_construct_meta(package => $package_name, @args);
  28 }
  29
  30 sub class_of{
  31     my($class_or_instance) = @_;
  32     return undef unless defined $class_or_instance;
  33     return $METAS{ ref($class_or_instance) || $class_or_instance };
  34 }
  35
  36 # Means of accessing all the metaclasses that have
  37 # been initialized thus far
  38 #sub get_all_metaclasses         {        %METAS         }
  39 sub get_all_metaclass_instances { values %METAS         }
  40 sub get_all_metaclass_names     { keys   %METAS         }
  41 sub get_metaclass_by_name       { $METAS{$_[0]}         }
  42 #sub store_metaclass_by_name     { $METAS{$_[0]} = $_[1] }
  43 #sub weaken_metaclass            { weaken($METAS{$_[0]}) }
  44 #sub does_metaclass_exist        { defined $METAS{$_[0]} }
  45 #sub remove_metaclass_by_name    { delete $METAS{$_[0]}  }
  46
  47
  48
  49 sub name { $_[0]->{package} }
  50
  51 # The followings are Class::MOP specific methods
  52
  53 #sub version   { no strict 'refs'; ${shift->name.'::VERSION'}   }
  54 #sub authority { no strict 'refs'; ${shift->name.'::AUTHORITY'} }
  55 #sub identifier {
  56 #    my $self = shift;
  57 #    return join '-' => (
  58 #       $self->name,
  59 #        ($self->version   || ()),
  60 #        ($self->authority || ()),
  61 #    );
  62 #}
  63
  64 # add_attribute is an abstract method
  65
  66 sub get_attribute_map {
  67     Carp::cluck('get_attribute_map() has been deprecated');
  68     return $_[0]->{attributes};
  69 }
  70
  71 sub has_attribute     { exists $_[0]->{attributes}->{$_[1]} }
  72 sub get_attribute     {        $_[0]->{attributes}->{$_[1]} }
  73 sub get_attribute_list{ keys %{$_[0]->{attributes}}         }
  74 sub remove_attribute  { delete $_[0]->{attributes}->{$_[1]} }
  75
  76 sub namespace{
  77     my $name = $_[0]->{package};
  78     no strict 'refs';
  79     return \%{ $name . '::' };
  80 }
  81
  82 sub add_method {
  83     my($self, $name, $code) = @_;
  84
  85     if(!defined $name){
  86         $self->throw_error('You must pass a defined name');
  87     }
  88     if(!defined $code){
  89         $self->throw_error('You must pass a defined code');
  90     }
  91
  92     if(ref($code) ne 'CODE'){
  93         not_supported 'add_method for a method object';
  94     }
  95
  96     $self->{methods}->{$name}++; # Moose stores meta object here.
  97
  98     my $pkg = $self->name;
  99     no strict 'refs';
 100     no warnings 'redefine';
 101     *{ $pkg . '::' . $name } = $code;
 102 }
 103
 104 # XXX: for backward compatibility
 105 my %foreign = map{ $_ => undef } qw(
 106     Mouse Mouse::Role Mouse::Util Mouse::Util::TypeConstraints
 107     Carp Scalar::Util
 108 );
 109 sub _code_is_mine{
 110     my($self, $code) = @_;
 111
 112     my $package = get_code_package($code);
 113
 114     return !exists $foreign{$package};
 115 }
 116
 117 sub has_method {
 118     my($self, $method_name) = @_;
 119
 120     return 1 if $self->{methods}->{$method_name};
 121
 122     my $code = do{ no strict 'refs'; *{$self->{package} . '::' . $method_name}{CODE} };
 123
 124     return $code && $self->_code_is_mine($code);
 125 }
 126
 127 sub get_method{
 128     my($self, $method_name) = @_;
 129
 130     if($self->has_method($method_name)){
 131         my $method_metaclass = $self->method_metaclass;
 132         load_class($method_metaclass);
 133
 134         my $package = $self->name;
 135         return $method_metaclass->new(
 136             body    => $package->can($method_name),
 137             name    => $method_name,
 138             package => $package,
 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($class, $package_name, %options) = @_;
 158
 159         $class->throw_error('You must pass a package name') if @_ < 2;
 160
 161         my $superclasses;
 162         if(exists $options{superclasses}){
 163             if($class->isa('Mouse::Meta::Role')){
 164                 delete $options{superclasses};
 165             }
 166             else{
 167                 $superclasses = delete $options{superclasses};
 168                 (ref $superclasses eq 'ARRAY')
 169                     || $class->throw_error("You must pass an ARRAY ref of superclasses");
 170             }
 171         }
 172
 173         my $attributes = delete $options{attributes};
 174         if(defined $attributes){
 175             (ref $attributes eq 'ARRAY' || ref $attributes eq 'HASH')
 176                 || $class->throw_error("You must pass an ARRAY ref of attributes");
 177         }
 178         my $methods = delete $options{methods};
 179         if(defined $methods){
 180             (ref $methods eq 'HASH')
 181                 || $class->throw_error("You must pass a HASH ref of methods");
 182         }
 183         my $roles = delete $options{roles};
 184         if(defined $roles){
 185             (ref $roles eq 'ARRAY')
 186                 || $class->throw_error("You must pass an ARRAY ref of roles");
 187         }
 188         my $mortal;
 189         my $cache_key;
 190
 191         if(!defined $package_name){ # anonymous
 192             $mortal = !$options{cache};
 193
 194             # anonymous but immortal
 195             if(!$mortal){
 196                     # something like Super::Class|Super::Class::2=Role|Role::1
 197                     $cache_key = join '=' => (
 198                         join('|',      @{$superclasses || []}),
 199                         join('|', sort @{$roles        || []}),
 200                     );
 201                     return $IMMORTALS{$cache_key} if exists $IMMORTALS{$cache_key};
 202             }
 203             $options{anon_serial_id} = ++$ANON_SERIAL;
 204             $package_name = $class . '::__ANON__::' . $ANON_SERIAL;
 205         }
 206
 207         # instantiate a module
 208         {
 209             no strict 'refs';
 210             ${ $package_name . '::VERSION'   } = delete $options{version}   if exists $options{version};
 211             ${ $package_name . '::AUTHORITY' } = delete $options{authority} if exists $options{authority};
 212         }
 213
 214         my $meta = $class->initialize( $package_name, %options);
 215
 216         weaken $METAS{$package_name}
 217             if $mortal;
 218
 219         # FIXME totally lame
 220         $meta->add_method('meta' => sub {
 221             $class->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 SEE ALSO
 310
 311 L<Class::MOP::Class>
 312
 313 L<Class::MOP::Module>
 314
 315 L<Class::MOP::Package>
 316
 317 =cut
 318