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