use Mouse::Meta::Method::Constructor;
use Mouse::Meta::Method::Destructor;
use Scalar::Util qw/blessed weaken/;
-use Mouse::Util qw/get_linear_isa/;
-use Carp 'confess';
+use Mouse::Util qw/get_linear_isa not_supported/;
use base qw(Mouse::Meta::Module);
-do {
- my %METACLASS_CACHE;
+sub method_metaclass(){ 'Mouse::Meta::Method' } # required for get_method()
- # because Mouse doesn't introspect existing classes, we're forced to
- # only pay attention to other Mouse classes
- sub _metaclass_cache {
- my $class = shift;
- my $name = shift;
- return $METACLASS_CACHE{$name};
- }
-
- sub initialize {
- my($class, $package_name, @args) = @_;
-
- ($package_name && !ref($package_name))\r
- || confess("You must pass a package name and it cannot be blessed");\r
-
- return $METACLASS_CACHE{$package_name}
- ||= $class->_construct_class_instance(package => $package_name, @args);
- }
-
- sub class_of{
- my($class_or_instance) = @_;
- return undef unless defined $class_or_instance;
- return $METACLASS_CACHE{ blessed($class_or_instance) || $class_or_instance };
- }
-
- # Means of accessing all the metaclasses that have
- # been initialized thus far
- sub get_all_metaclasses { %METACLASS_CACHE }
- sub get_all_metaclass_instances { values %METACLASS_CACHE }
- sub get_all_metaclass_names { keys %METACLASS_CACHE }
- sub get_metaclass_by_name { $METACLASS_CACHE{$_[0]} }
- sub store_metaclass_by_name { $METACLASS_CACHE{$_[0]} = $_[1] }
- sub weaken_metaclass { weaken($METACLASS_CACHE{$_[0]}) }
- sub does_metaclass_exist { exists $METACLASS_CACHE{$_[0]} && defined $METACLASS_CACHE{$_[0]} }
- sub remove_metaclass_by_name { $METACLASS_CACHE{$_[0]} = undef }
-};
-
-sub _construct_class_instance {
+sub _new {
my($class, %args) = @_;
- $args{attributes} = {};
+ $args{attributes} ||= {};
+ $args{methods} ||= {};
+ $args{roles} ||= [];
+
$args{superclasses} = do {
no strict 'refs';
\@{ $args{package} . '::ISA' };
};
- $args{roles} ||= [];
- $args{methods} ||= {};
bless \%args, $class;
}
return @attr;
}
-sub get_attribute_map { $_[0]->{attributes} }
-sub has_attribute { exists $_[0]->{attributes}->{$_[1]} }
-sub get_attribute { $_[0]->{attributes}->{$_[1]} }
-sub get_attribute_list {
+sub linearized_isa { @{ get_linear_isa($_[0]->name) } }
+
+sub new_object {
my $self = shift;
- keys %{$self->get_attribute_map};
-}
+ my $args = (@_ == 1) ? $_[0] : { @_ };
-sub linearized_isa { @{ get_linear_isa($_[0]->name) } }
+ my $instance = bless {}, $self->name;
+
+ foreach my $attribute ($self->get_all_attributes) {
+ my $from = $attribute->init_arg;
+ my $key = $attribute->name;
+
+ if (defined($from) && exists($args->{$from})) {
+ $args->{$from} = $attribute->coerce_constraint($args->{$from})
+ if $attribute->should_coerce;
+ $attribute->verify_against_type_constraint($args->{$from});
+
+ $instance->{$key} = $args->{$from};
+
+ weaken($instance->{$key})
+ if ref($instance->{$key}) && $attribute->is_weak_ref;
+
+ if ($attribute->has_trigger) {
+ $attribute->trigger->($instance, $args->{$from});
+ }
+ }
+ else {
+ if ($attribute->has_default || $attribute->has_builder) {
+ unless ($attribute->is_lazy) {
+ my $default = $attribute->default;
+ my $builder = $attribute->builder;
+ my $value = $attribute->has_builder
+ ? $instance->$builder
+ : ref($default) eq 'CODE'
+ ? $default->($instance)
+ : $default;
+
+ $value = $attribute->coerce_constraint($value)
+ if $attribute->should_coerce;
+ $attribute->verify_against_type_constraint($value);
+
+ $instance->{$key} = $value;
+
+ weaken($instance->{$key})
+ if ref($instance->{$key}) && $attribute->is_weak_ref;
+ }
+ }
+ else {
+ if ($attribute->is_required) {
+ $self->throw_error("Attribute (".$attribute->name.") is required");
+ }
+ }
+ }
+ }
+ return $instance;
+}
sub clone_object {
my $class = shift;
my $instance = shift;
(blessed($instance) && $instance->isa($class->name))
- || confess "You must pass an instance of the metaclass (" . $class->name . "), not ($instance)";
+ || $class->throw_error("You must pass an instance of the metaclass (" . $class->name . "), not ($instance)");
$class->clone_instance($instance, @_);
}
my ($class, $instance, %params) = @_;
(blessed($instance))
- || confess "You can only clone instances, ($instance) is not a blessed instance";
+ || $class->throw_error("You can only clone instances, ($instance) is not a blessed instance");
my $clone = bless { %$instance }, ref $instance;
@_,
);
- my $name = $self->name;
$self->{is_immutable}++;
if ($args{inline_constructor}) {
return 1;
}
-sub make_mutable { confess "Mouse does not currently support 'make_mutable'" }
+sub make_mutable { not_supported }
-sub is_immutable { $_[0]->{is_immutable} }
-
-sub attribute_metaclass { "Mouse::Meta::Class" }
+sub is_immutable { $_[0]->{is_immutable} }
+sub is_mutable { !$_[0]->{is_immutable} }
sub _install_modifier {
my ( $self, $into, $type, $name, $code ) = @_;
# replace this method itself :)
{
- no strict 'refs';
no warnings 'redefine';
- *{__PACKAGE__ . '::_install_modifier'} = sub {
+ *_install_modifier = sub {
my ( $self, $into, $type, $name, $code ) = @_;
$modifier->(
$into,
$name,
$code
);
+ $self->{methods}{$name}++; # register it to the method map
+ return;
};
}
sub add_override_method_modifier {
my ($self, $name, $code) = @_;
- my $pkg = $self->name;
- my $method = "${pkg}::${name}";
-
- # Class::Method::Modifiers won't do this for us, so do it ourselves
+ my $package = $self->name;
- my $body = $pkg->can($name)
- or confess "You cannot override '$method' because it has no super method";
+ my $body = $package->can($name)
+ or $self->throw_error("You cannot override '$name' because it has no super method");
- no strict 'refs';
- *$method = sub { $code->($pkg, $body, @_) };
+ $self->add_method($name => sub { $code->($package, $body, @_) });
}
sub does_role {
my ($self, $role_name) = @_;
(defined $role_name)
- || confess "You must supply a role name to look for";
+ || $self->throw_error("You must supply a role name to look for");
for my $class ($self->linearized_isa) {
- my $meta = class_of($class);
+ my $meta = Mouse::Meta::Module::class_of($class);
next unless $meta && $meta->can('roles');
for my $role (@{ $meta->roles }) {
+
return 1 if $role->does_role($role_name);
}
}
my ($class, $package_name, %options) = @_;
(ref $options{superclasses} eq 'ARRAY')
- || confess "You must pass an ARRAY ref of superclasses"
+ || $class->throw_error("You must pass an ARRAY ref of superclasses")
if exists $options{superclasses};
(ref $options{attributes} eq 'ARRAY')
- || confess "You must pass an ARRAY ref of attributes"
+ || $class->throw_error("You must pass an ARRAY ref of attributes")
if exists $options{attributes};
(ref $options{methods} eq 'HASH')
- || confess "You must pass a HASH ref of methods"
+ || $class->throw_error("You must pass a HASH ref of methods")
if exists $options{methods};
- do {
- ( defined $package_name && $package_name )
- || confess "You must pass a package name";
+ (ref $options{roles} eq 'ARRAY')
+ || $class->throw_error("You must pass an ARRAY ref of roles")
+ if exists $options{roles};
- my $code = "package $package_name;";
- $code .= "\$$package_name\:\:VERSION = '" . $options{version} . "';"
- if exists $options{version};
- $code .= "\$$package_name\:\:AUTHORITY = '" . $options{authority} . "';"
- if exists $options{authority};
+ # instantiate a module
+ {
+ ( defined $package_name && $package_name )
+ || $class->throw_error("You must pass a package name");
- eval $code;
- confess "creation of $package_name failed : $@" if $@;
- };
+ no strict 'refs';
+ ${ $package_name . '::VERSION' } = $options{version} if exists $options{version};
+ ${ $package_name . '::AUTHORITY' } = $options{authority} if exists $options{authority};
+ }
my %initialize_options = %options;
delete @initialize_options{qw(
superclasses
attributes
methods
+ roles
version
authority
)};
$meta->superclasses(@{$options{superclasses}})
if exists $options{superclasses};
+
# NOTE:
# process attributes first, so that they can
# install accessors, but locally defined methods
$meta->add_method($method_name, $options{methods}->{$method_name});
}
}
+ if (exists $options{roles}){
+ Mouse::Util::apply_all_roles($package_name, @{$options{roles}});
+ }
return $meta;
}
{
my $ANON_CLASS_SERIAL = 0;
my $ANON_CLASS_PREFIX = 'Mouse::Meta::Class::__ANON__::SERIAL::';
+
+ my %IMMORTAL_ANON_CLASSES;
sub create_anon_class {
my ( $class, %options ) = @_;
+
+ my $cache = $options{cache};
+ my $cache_key;
+
+ if($cache){ # anonymous but not mortal
+ # something like Super::Class|Super::Class::2=Role|Role::1\r
+ $cache_key = join '=' => (\r
+ join('|', @{$options{superclasses} || []}),\r
+ join('|', sort @{$options{roles} || []}),\r
+ );
+ return $IMMORTAL_ANON_CLASSES{$cache_key} if exists $IMMORTAL_ANON_CLASSES{$cache_key};
+ }
my $package_name = $ANON_CLASS_PREFIX . ++$ANON_CLASS_SERIAL;
- return $class->create( $package_name, %options );
+ my $meta = $class->create( $package_name, anon_class_id => $ANON_CLASS_SERIAL, %options );
+
+ if($cache){
+ $IMMORTAL_ANON_CLASSES{$cache_key} = $meta;
+ }
+ else{
+ Mouse::Meta::Module::weaken_metaclass($package_name);
+ }
+ return $meta;
+ }
+
+ sub is_anon_class{
+ return exists $_[0]->{anon_class_id};
+ }
+
+
+ sub DESTROY{
+ my($self) = @_;
+
+ my $serial_id = $self->{anon_class_id};
+
+ return if !$serial_id;
+
+ my $stash = $self->namespace;
+
+ @{$self->{sperclasses}} = ();
+ %{$stash} = ();
+ Mouse::Meta::Module::remove_metaclass_by_name($self->name);
+
+ no strict 'refs';
+ delete ${$ANON_CLASS_PREFIX}{ $serial_id . '::' };
+
+ return;
}
+
}
1;
projects / gitmo/Mouse.git / blobdiff