lib/Class/MOP/Class.pm

   1
   2 package Class::MOP::Class;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Carp         'confess';
   8 use Scalar::Util 'blessed', 'reftype';
   9 use Sub::Name    'subname';
  10 use B            'svref_2object';
  11
  12 our $VERSION = '0.01';
  13
  14 # Creation
  15
  16 {
  17     # Metaclasses are singletons, so we cache them here.
  18     # there is no need to worry about destruction though
  19     # because they should die only when the program dies.
  20     # After all, do package definitions even get reaped?
  21     my %METAS;
  22     sub initialize {
  23         my ($class, $package_name) = @_;
  24         (defined $package_name && $package_name)
  25             || confess "You must pass a package name";
  26         $METAS{$package_name} ||= bless \$package_name => blessed($class) || $class;
  27     }
  28 }
  29
  30 sub create {
  31     my ($class, $package_name, $package_version, %options) = @_;
  32     (defined $package_name && $package_name)
  33         || confess "You must pass a package name";
  34     my $code = "package $package_name;";
  35     $code .= "\$$package_name\:\:VERSION = '$package_version';"
  36         if defined $package_version;
  37     eval $code;
  38     confess "creation of $package_name failed : $@" if $@;
  39     my $meta = $class->initialize($package_name);
  40     $meta->superclasses(@{$options{superclasses}})
  41         if exists $options{superclasses};
  42     if (exists $options{methods}) {
  43         foreach my $method_name (keys %{$options{methods}}) {
  44             $meta->add_method($method_name, $options{methods}->{$method_name});
  45         }
  46     }
  47     return $meta;
  48 }
  49
  50 # Informational
  51
  52 sub name { ${$_[0]} }
  53
  54 sub version {
  55     my $self = shift;
  56     no strict 'refs';
  57     ${$self->name . '::VERSION'};
  58 }
  59
  60 # Inheritance
  61
  62 sub superclasses {
  63     my $self = shift;
  64     no strict 'refs';
  65     if (@_) {
  66         my @supers = @_;
  67         @{$self->name . '::ISA'} = @supers;
  68     }
  69     @{$self->name . '::ISA'};
  70 }
  71
  72 sub class_precedence_list {
  73     my $self = shift;
  74     # NOTE:
  75     # We need to check for ciruclar inheirtance here.
  76     # This will do nothing if all is well, and blow
  77     # up otherwise. Yes, it's an ugly hack, better
  78     # suggestions are welcome.
  79     { $self->name->isa('This is a test for circular inheritance') }
  80     # ... and no back to our regularly scheduled program
  81     (
  82         $self->name,
  83         map {
  84             $self->initialize($_)->class_precedence_list()
  85         } $self->superclasses()
  86     );
  87 }
  88
  89 ## Methods
  90
  91 sub add_method {
  92     my ($self, $method_name, $method) = @_;
  93     (defined $method_name && $method_name)
  94         || confess "You must define a method name";
  95     # use reftype here to allow for blessed subs ...
  96     (reftype($method) && reftype($method) eq 'CODE')
  97         || confess "Your code block must be a CODE reference";
  98     my $full_method_name = ($self->name . '::' . $method_name);
  99
 100     no strict 'refs';
 101     no warnings 'redefine';
 102     *{$full_method_name} = subname $full_method_name => $method;
 103 }
 104
 105 {
 106
 107     ## private utility functions for has_method
 108     my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } };
 109     my $_find_subroutine_name         = sub { eval { svref_2object($_[0])->GV->NAME        } };
 110
 111     sub has_method {
 112         my ($self, $method_name) = @_;
 113         (defined $method_name && $method_name)
 114             || confess "You must define a method name";
 115
 116         my $sub_name = ($self->name . '::' . $method_name);
 117
 118         no strict 'refs';
 119         return 0 if !defined(&{$sub_name});
 120         return 0 if $_find_subroutine_package_name->(\&{$sub_name}) ne $self->name &&
 121                     $_find_subroutine_name->(\&{$sub_name})         ne '__ANON__';
 122         return 1;
 123     }
 124
 125 }
 126
 127 sub get_method {
 128     my ($self, $method_name) = @_;
 129     (defined $method_name && $method_name)
 130         || confess "You must define a method name";
 131
 132     no strict 'refs';
 133     return \&{$self->name . '::' . $method_name}
 134         if $self->has_method($method_name);
 135     return; # <- make sure to return undef
 136 }
 137
 138 sub remove_method {
 139     my ($self, $method_name) = @_;
 140     (defined $method_name && $method_name)
 141         || confess "You must define a method name";
 142
 143     my $removed_method = $self->get_method($method_name);
 144
 145     no strict 'refs';
 146     delete ${$self->name . '::'}{$method_name}
 147         if defined $removed_method;
 148
 149     return $removed_method;
 150 }
 151
 152 sub get_method_list {
 153     my $self = shift;
 154     no strict 'refs';
 155     grep { $self->has_method($_) } %{$self->name . '::'};
 156 }
 157
 158 sub compute_all_applicable_methods {
 159     my $self = shift;
 160     my @methods;
 161     # keep a record of what we have seen
 162     # here, this will handle all the
 163     # inheritence issues because we are
 164     # using the &class_precedence_list
 165     my (%seen_class, %seen_method);
 166     foreach my $class ($self->class_precedence_list()) {
 167         next if $seen_class{$class};
 168         $seen_class{$class}++;
 169         # fetch the meta-class ...
 170         my $meta = $self->initialize($class);
 171         foreach my $method_name ($meta->get_method_list()) {
 172             next if exists $seen_method{$method_name};
 173             $seen_method{$method_name}++;
 174             push @methods => {
 175                 name  => $method_name,
 176                 class => $class,
 177                 code  => $meta->get_method($method_name)
 178             };
 179         }
 180     }
 181     return @methods;
 182 }
 183
 184 ## Recursive Version of compute_all_applicable_methods
 185 # sub compute_all_applicable_methods {
 186 #     my ($self, $seen) = @_;
 187 #     $seen ||= {};
 188 #     (
 189 #         (map {
 190 #             if (exists $seen->{$_}) {
 191 #                 ();
 192 #             }
 193 #             else {
 194 #                 $seen->{$_}++;
 195 #                 {
 196 #                     name  => $_,
 197 #                     class => $self->name,
 198 #                     code  => $self->get_method($_)
 199 #                 };
 200 #             }
 201 #         } $self->get_method_list()),
 202 #         map {
 203 #             $self->initialize($_)->compute_all_applicable_methods($seen)
 204 #         } $self->superclasses()
 205 #     );
 206 # }
 207
 208 sub find_all_methods_by_name {
 209     my ($self, $method_name) = @_;
 210     (defined $method_name && $method_name)
 211         || confess "You must define a method name to find";
 212     my @methods;
 213     # keep a record of what we have seen
 214     # here, this will handle all the
 215     # inheritence issues because we are
 216     # using the &class_precedence_list
 217     my %seen_class;
 218     foreach my $class ($self->class_precedence_list()) {
 219         next if $seen_class{$class};
 220         $seen_class{$class}++;
 221         # fetch the meta-class ...
 222         my $meta = $self->initialize($class);
 223         push @methods => {
 224             name  => $method_name,
 225             class => $class,
 226             code  => $meta->get_method($method_name)
 227         } if $meta->has_method($method_name);
 228     }
 229     return @methods;
 230
 231 }
 232
 233 1;
 234
 235 __END__
 236
 237 =pod
 238
 239 =head1 NAME
 240
 241 Class::MOP::Class - Class Meta Object
 242
 243 =head1 SYNOPSIS
 244
 245 =head1 DESCRIPTION
 246
 247 =head1 AUTHOR
 248
 249 Stevan Little E<gt>stevan@iinteractive.comE<lt>
 250
 251 =head1 COPYRIGHT AND LICENSE
 252
 253 Copyright 2006 by Infinity Interactive, Inc.
 254
 255 L<http://www.iinteractive.com>
 256
 257 This library is free software; you can redistribute it and/or modify
 258 it under the same terms as Perl itself.
 259
 260 =cut