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 sub initialize {
  17     my ($class, $package_name) = @_;
  18     (defined $package_name)
  19         || confess "You must pass a package name";
  20     bless \$package_name => $class;
  21 }
  22
  23 sub create {
  24     my ($class, $package_name, $package_version, %options) = @_;
  25     (defined $package_name)
  26         || confess "You must pass a package name";
  27     my $code = "package $package_name;";
  28     $code .= "\$$package_name\:\:VERSION = '$package_version';"
  29         if defined $package_version;
  30     eval $code;
  31     confess "creation of $package_name failed : $@" if $@;
  32     my $meta = $package_name->meta;
  33     $meta->superclasses(@{$options{superclasses}})
  34         if exists $options{superclasses};
  35     # ... rest to come later ...
  36     return $meta;
  37 }
  38
  39 # Informational
  40
  41 sub name { ${$_[0]} }
  42
  43 sub version {
  44     my $self = shift;
  45     no strict 'refs';
  46     ${$self->name . '::VERSION'};
  47 }
  48
  49 # Inheritance
  50
  51 sub superclasses {
  52     my $self = shift;
  53     no strict 'refs';
  54     if (@_) {
  55         my @supers = @_;
  56         @{$self->name . '::ISA'} = @supers;
  57     }
  58     @{$self->name . '::ISA'};
  59 }
  60
  61 sub class_precedence_list {
  62     my $self = shift;
  63     (
  64         $self->name,
  65         map {
  66             $_->meta->class_precedence_list()
  67         } $self->superclasses()
  68     );
  69 }
  70
  71 ## Methods
  72
  73 sub add_method {
  74     my ($self, $method_name, $method) = @_;
  75     (defined $method_name && $method_name)
  76         || confess "You must define a method name";
  77     (reftype($method) && reftype($method) eq 'CODE')
  78         || confess "Your code block must be a CODE reference";
  79     my $full_method_name = ($self->name . '::' . $method_name);
  80
  81     no strict 'refs';
  82     *{$full_method_name} = subname $full_method_name => $method;
  83 }
  84
  85 sub has_method {
  86     my ($self, $method_name, $method) = @_;
  87     (defined $method_name && $method_name)
  88         || confess "You must define a method name";
  89
  90     my $sub_name = ($self->name . '::' . $method_name);
  91
  92     no strict 'refs';
  93     return 0 unless defined &{$sub_name};
  94     return 0 unless _find_subroutine_package(\&{$sub_name}) eq $self->name;
  95     return 1;
  96 }
  97
  98 sub get_method {
  99     my ($self, $method_name, $method) = @_;
 100     (defined $method_name && $method_name)
 101         || confess "You must define a method name";
 102
 103     no strict 'refs';
 104     return \&{$self->name . '::' . $method_name}
 105         if $self->has_method($method_name);
 106 }
 107
 108 ## Private Utility Methods
 109
 110 # initially borrowed from Class::Trait 0.20 - Thanks Ovid :)
 111 # later re-worked to support subs named with Sub::Name
 112 sub _find_subroutine_package {
 113     my $sub     = shift;
 114     my $package = eval { svref_2object($sub)->GV->STASH->NAME };
 115     confess "Could not determine calling package: $@" if $@;
 116     return $package;
 117 }
 118
 119 1;
 120
 121 __END__
 122
 123 =pod
 124
 125 =head1 NAME
 126
 127 Class::MOP::Class - Class Meta Object
 128
 129 =head1 SYNOPSIS
 130
 131 =head1 DESCRIPTION
 132
 133 =head1 AUTHOR
 134
 135 Stevan Little E<gt>stevan@iinteractive.comE<lt>
 136
 137 =head1 COPYRIGHT AND LICENSE
 138
 139 Copyright 2006 by Infinity Interactive, Inc.
 140
 141 L<http://www.iinteractive.com>
 142
 143 This library is free software; you can redistribute it and/or modify
 144 it under the same terms as Perl itself.
 145
 146 =cut