use Mouse::Util;
use Mouse::Meta::Attribute;
+use Mouse::Meta::Module; # class_of()
use Mouse::Meta::Class;
use Mouse::Object;
use Mouse::Util::TypeConstraints;
return 0;
}
-sub class_of {
- return Mouse::Meta::Class::class_of($_[0]);
-}
-
1;
__END__
use base qw(Mouse::Meta::Module);
-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) = @_;
-
- ($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) } }
+ foreach my $attribute ($self->meta->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 $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 $attribute->is_weak_ref;
+ }
+ }
+ else {
+ if ($attribute->is_required) {
+ confess "Attribute (".$attribute->name.") is required";
+ }
+ }
+ }
+ }
+ return $instance;
+}
sub clone_object {
my $class = shift;
|| confess "You must supply a role name to look for";
for my $class ($self->linearized_isa) {
- my $meta = class_of($class);
+ my $meta = Mouse::class_of($class);
next unless $meta && $meta->can('roles');
for my $role (@{ $meta->roles }) {
use warnings;
use Mouse::Util qw/get_code_info/;
-use Carp 'confess';
+use Scalar::Util qw/blessed/;
+use Carp ();
+
+{
+ 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, $name) = @_;
+ 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->_new(package => $package_name, @args);
+ }
+
+ sub Mouse::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 { defined $METACLASS_CACHE{$_[0]} }
+ sub remove_metaclass_by_name { delete $METACLASS_CACHE{$_[0]} }
+
+}
+
+sub _new{ Carp::croak("Mouse::Meta::Module is an abstract class") }
sub name { $_[0]->{package} }
sub _method_map{ $_[0]->{methods} }
-
sub version { no strict 'refs'; ${shift->name.'::VERSION'} }
sub authority { no strict 'refs'; ${shift->name.'::AUTHORITY'} }
sub identifier {
);
}
+# add_attribute is an abstract method
+
+sub get_attribute_map { $_[0]->{attributes} }
+sub has_attribute { exists $_[0]->{attributes}->{$_[1]} }
+sub get_attribute { $_[0]->{attributes}->{$_[1]} }
+sub get_attribute_list{ keys %{$_[0]->{attributes}} }
sub namespace{
my $name = $_[0]->{package};
return $code && $self->_code_is_mine($code);
}
-
+sub get_method{
+ Carp::croak("get_method() is not yet implemented");
+}
sub get_method_list {\r
my($self) = @_;
return grep { $self->has_method($_) } keys %{ $self->namespace };\r
}
-sub get_attribute_map { $_[0]->{attributes} }
-sub has_attribute { exists $_[0]->{attributes}->{$_[1]} }
-sub get_attribute { $_[0]->{attributes}->{$_[1]} }
-sub get_attribute_list {
- my $self = shift;
- keys %{$self->get_attribute_map};
-}
+sub throw_error{
+ my($class, $message, %args) = @_;
+
+ local $Carp::CarpLevel = $Carp::CarpLevel + ($args{depth} || 1);
+ local $Carp::MaxArgNums = 20; # default is 8, usually we use named args which gets messier though\r
+ if(exists $args{longmess} && !$args{longmess}){ # intentionaly longmess => 0
+ Carp::croak($message);
+ }
+ else{
+ Carp::confess($message);
+ }
+}
1;
use base qw(Mouse::Meta::Module);
-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) = @_;
-
- ($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->_new(package => $package_name, @args);
- }
-};
-
sub _new {
my $class = shift;
my %args = @_;
$self->{attributes}->{$name} = $spec;
}
-sub has_attribute { exists $_[0]->{attributes}->{$_[1]} }
-sub get_attribute_list { keys %{ $_[0]->{attributes} } }
-sub get_attribute { $_[0]->{attributes}->{$_[1]} }
-
sub _check_required_methods{
my($role, $class, $args, @other_roles) = @_;
use strict;
use warnings;
-use Scalar::Util 'weaken';
use Carp 'confess';
sub new {
my $class = shift;
- my $args = $class->BUILDARGS(@_);
+ confess('Cannot call new() on an instance') if ref $class;
- my $instance = bless {}, $class;
-
- for my $attribute ($class->meta->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) {
- confess "Attribute (".$attribute->name.") is required";
- }
- }
- }
- }
+ my $args = $class->BUILDARGS(@_);
+ my $instance = Mouse::Meta::Class->initialize($class)->new_object($params);
$instance->BUILDALL($args);
-
return $instance;
}
# short circuit
return unless $self->can('DEMOLISH');
- no strict 'refs';
-
- my @isa;
- if ( my $meta = Mouse::Meta::Class::class_of($self) ) {
- @isa = $meta->linearized_isa;
- } else {
- # We cannot count on being able to retrieve a previously made
- # metaclass, _or_ being able to make a new one during global
- # destruction. However, we should still be able to use mro at
- # that time (at least tests suggest so ;)
- my $class_name = ref $self;
- @isa = @{ Mouse::Util::get_linear_isa($class_name) }
- }
+ # We cannot count on being able to retrieve a previously made
+ # metaclass, _or_ being able to make a new one during global
+ # destruction. However, we should still be able to use mro at
+ # that time (at least tests suggest so ;)
- foreach my $class (@isa) {
- no strict 'refs';
- my $demolish = *{"${class}::DEMOLISH"}{CODE};
- $self->$demolish
+ foreach my $class (@{ Mouse::Util::get_linear_isa(ref $self) }) {
+ my $demolish = do{ no strict 'refs'; *{"${class}::DEMOLISH"}{CODE} };
+ $self->$demolish()
if defined $demolish;
}
return;
}
sub dump {
- my $self = shift;
- require Data::Dumper;
- local $Data::Dumper::Maxdepth = shift if @_;
- Data::Dumper::Dumper($self);
+ my($self, $maxdepth) = @_;
+
+ require 'Data/Dumper.pm'; # we don't want to create its namespace
+ my $dd = Data::Dumper->new([$self]);
+ $dd->Maxdepth($maxdepth || 1);
+ return $dd->Dump();
}
projects / gitmo/Mouse.git / commitdiff