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     (reftype($method) && reftype($method) eq 'CODE')
  96         || confess "Your code block must be a CODE reference";
  97     my $full_method_name = ($self->name . '::' . $method_name);
  98
  99     no strict 'refs';
 100     no warnings 'redefine';
 101     *{$full_method_name} = subname $full_method_name => $method;
 102 }
 103
 104 {
 105
 106     ## private utility functions for has_method
 107     my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } };
 108     my $_find_subroutine_name         = sub { eval { svref_2object($_[0])->GV->NAME        } };
 109
 110     sub has_method {
 111         my ($self, $method_name) = @_;
 112         (defined $method_name && $method_name)
 113             || confess "You must define a method name";
 114
 115         my $sub_name = ($self->name . '::' . $method_name);
 116
 117         no strict 'refs';
 118         return 0 if !defined(&{$sub_name});
 119         return 0 if $_find_subroutine_package_name->(\&{$sub_name}) ne $self->name &&
 120                     $_find_subroutine_name->(\&{$sub_name})         ne '__ANON__';
 121         return 1;
 122     }
 123
 124 }
 125
 126 sub get_method {
 127     my ($self, $method_name) = @_;
 128     (defined $method_name && $method_name)
 129         || confess "You must define a method name";
 130
 131     no strict 'refs';
 132     return \&{$self->name . '::' . $method_name}
 133         if $self->has_method($method_name);
 134     return; # <- make sure to return undef
 135 }
 136
 137 sub remove_method {
 138     my ($self, $method_name) = @_;
 139     (defined $method_name && $method_name)
 140         || confess "You must define a method name";
 141
 142     my $removed_method = $self->get_method($method_name);
 143
 144     no strict 'refs';
 145     delete ${$self->name . '::'}{$method_name}
 146         if defined $removed_method;
 147
 148     return $removed_method;
 149 }
 150
 151 sub get_method_list {
 152     my $self = shift;
 153     no strict 'refs';
 154     grep {
 155         defined &{$self->name . '::' . $_} && $self->has_method($_)
 156     } %{$self->name . '::'};
 157 }
 158
 159 1;
 160
 161 __END__
 162
 163 =pod
 164
 165 =head1 NAME
 166
 167 Class::MOP::Class - Class Meta Object
 168
 169 =head1 SYNOPSIS
 170
 171 =head1 DESCRIPTION
 172
 173 =head1 AUTHOR
 174
 175 Stevan Little E<gt>stevan@iinteractive.comE<lt>
 176
 177 =head1 COPYRIGHT AND LICENSE
 178
 179 Copyright 2006 by Infinity Interactive, Inc.
 180
 181 L<http://www.iinteractive.com>
 182
 183 This library is free software; you can redistribute it and/or modify
 184 it under the same terms as Perl itself.
 185
 186 =cut