use Mouse::Meta::Method::Constructor;
use Mouse::Meta::Method::Destructor;
use Scalar::Util qw/blessed weaken/;
-use Mouse::Util qw/get_linear_isa version authority identifier/;
-use Carp 'confess';
-
-do {
- my %METACLASS_CACHE;
-
- # 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) = @_;
+use Mouse::Util qw/get_linear_isa not_supported/;
- ($package_name && !ref($package_name))\r
- || confess("You must pass a package name and it cannot be blessed");\r
+use base qw(Mouse::Meta::Module);
- return $METACLASS_CACHE{$package_name}
- ||= $class->_construct_class_instance(package => $package_name, @args);
- }
- # 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} ||= [];
bless \%args, $class;
}
-sub name { $_[0]->{package} }
+sub roles { $_[0]->{roles} }
sub superclasses {
my $self = shift;
@{ $self->{superclasses} };
}
-sub add_method {
- my $self = shift;
- my $name = shift;
- my $code = shift;
-
- my $pkg = $self->name;
-
- no strict 'refs';
- no warnings 'redefine';
- $self->{'methods'}->{$name}++; # Moose stores meta object here.
- *{ $pkg . '::' . $name } = $code;
-}
-
-sub has_method {
- my $self = shift;
- my $name = shift;
- $self->name->can($name);
-}
-
-# copied from Class::Inspector
-my $get_methods_for_class = sub {
- my $self = shift;
- my $name = shift;
-
- no strict 'refs';
- # Get all the CODE symbol table entries
- my @functions =
- grep !/^(?:has|with|around|before|after|augment|inner|blessed|extends|confess|override|super)$/,
- grep { defined &{"${name}::$_"} }
- keys %{"${name}::"};
- push @functions, keys %{$self->{'methods'}->{$name}} if $self;
- wantarray ? @functions : \@functions;
-};
-
-sub get_method_list {
- my $self = shift;
- $get_methods_for_class->($self, $self->name);
-}
-
sub get_all_method_names {
my $self = shift;
my %uniq;
return grep { $uniq{$_}++ == 0 }
- map { $get_methods_for_class->(undef, $_) }
+ map { Mouse::Meta::Class->initialize($_)->get_method_list() }
$self->linearized_isa;
}
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 _install_modifier {
my ( $self, $into, $type, $name, $code ) = @_;
# Class::Method::Modifiers won't do this for us, so do it ourselves
my $body = $pkg->can($name)
- or confess "You cannot override '$method' because it has no super method";
+ or $self->throw_error("You cannot override '$method' because it has no super method");
no strict 'refs';
*$method = sub { $code->($pkg, $body, @_) };
}
-
-sub roles { $_[0]->{roles} }
-
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) {
- next unless $class->can('meta') and $class->meta->can('roles');
- for my $role (@{ $class->meta->roles }) {
- return 1 if $role->name eq $role_name;
+ my $meta = Mouse::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";
+ || $class->throw_error("You must pass a package name");
my $code = "package $package_name;";
$code .= "\$$package_name\:\:VERSION = '" . $options{version} . "';"
if exists $options{authority};
eval $code;
- confess "creation of $package_name failed : $@" if $@;
+ $class->throw_error("creation of $package_name failed : $@") if $@;
};
my %initialize_options = %options;