sub get_read_method_ref{
my($self) = @_;
- return $self->{_read_method_ref}
+ return $self->{_mouse_cache_read_method_ref}
||= $self->_get_accessor_method_ref('get_read_method', '_generate_reader');
}
sub get_write_method_ref{
my($self) = @_;
- return $self->{_write_method_ref}
+ return $self->{_mouse_cache_write_method_ref}
||= $self->_get_accessor_method_ref('get_write_method', '_generate_writer');
}
# remove temporary caches
foreach my $attr(keys %{$args}){
- if($attr =~ /\A _/xms){
+ if($attr =~ /\A _mouse_cache_/xms){
delete $args->{$attr};
}
}
sub has_value {
my($self, $object) = @_;
- my $accessor_ref = $self->{_predicate_ref}
+ my $accessor_ref = $self->{_mouse_cache_predicate_ref}
||= $self->_get_accessor_method_ref('predicate', '_generate_predicate');
return $accessor_ref->($object);
sub clear_value {
my($self, $object) = @_;
- my $accessor_ref = $self->{_crealer_ref}
+ my $accessor_ref = $self->{_mouse_cache_crealer_ref}
||= $self->_get_accessor_method_ref('clearer', '_generate_clearer');
return $accessor_ref->($object);
=head1 VERSION
- This document describes Mouse version 0.73
+ This document describes Mouse version 0.74
=head1 DESCRIPTION
package Mouse::Meta::Class;
use Mouse::Util qw/:meta/; # enables strict and warnings
-use Scalar::Util qw/blessed weaken/;
+use Scalar::Util ();
use Mouse::Meta::Module;
our @ISA = qw(Mouse::Meta::Module);
my($class, $super) = @_;
Carp::carp("You inherit from non-Mouse class ($super),"
. " but it is unlikely to work correctly."
- . " Please concider to use MouseX::Foreign");
+ . " Please consider using MouseX::Foreign");
return;
}
}
-sub find_method_by_name{
+sub find_method_by_name {
my($self, $method_name) = @_;
defined($method_name)
or $self->throw_error('You must define a method name to find');
$self->linearized_isa;
}
-sub find_attribute_by_name{
+sub find_attribute_by_name {
my($self, $name) = @_;
- my $attr;
- foreach my $class($self->linearized_isa){
- my $meta = Mouse::Util::get_metaclass_by_name($class) or next;
- $attr = $meta->get_attribute($name) and last;
+ defined($name)
+ or $self->throw_error('You must define an attribute name to find');
+ foreach my $attr($self->get_all_attributes) {
+ return $attr if $attr->name eq $name;
}
- return $attr;
+ return undef;
}
sub add_attribute {
my($attr, $name);
- if(blessed $_[0]){
+ if(Scalar::Util::blessed($_[0])){
$attr = $_[0];
$attr->isa('Mouse::Meta::Attribute')
}
}
- weaken( $attr->{associated_class} = $self );
+ Scalar::Util::weaken( $attr->{associated_class} = $self );
# install accessors first
$attr->install_accessors();
# then register the attribute to the metaclass
- $attr->{insertion_order} = keys %{ $self->{attributes} };
- $self->{attributes}{$attr->name} = $attr;
+ $attr->{insertion_order} = keys %{ $self->{attributes} };
+ $self->{attributes}{$name} = $attr;
+ delete $self->{_mouse_cache}; # clears internal cache
if(!$attr->{associated_methods} && ($attr->{is} || '') ne 'bare'){
Carp::carp(qq{Attribute ($name) of class }.$self->name
.qq{ has no associated methods (did you mean to provide an "is" argument?)});
}
+ return $attr;
+}
- if(!Mouse::Util::MOUSE_XS) {
- # in Mouse::PurePerl, attribute initialization code is cached, so it
- # must be clear here. See _initialize_object() in Mouse::PurePerl.
- delete $self->{_initialize_object};
+sub _calculate_all_attributes {
+ my($self) = @_;
+ my %seen;
+ my @all_attrs;
+ foreach my $class($self->linearized_isa) {
+ my $meta = Mouse::Util::get_metaclass_by_name($class) or next;
+ my @attrs = grep { !$seen{$_->name}++ } values %{$meta->{attributes}};
+ @attrs = sort {
+ $b->{insertion_order} <=> $a->{insertion_order}
+ } @attrs;
+ push @all_attrs, @attrs;
}
- return $attr;
+ return [reverse @all_attrs];
}
sub linearized_isa;
=head1 VERSION
- This document describes Mouse version 0.73
+ This document describes Mouse version 0.74
=head1 DESCRIPTION
package Mouse::Meta::Method::Accessor;
use Mouse::Util qw(:meta); # enables strict and warnings
+ use constant _MOUSE_DEBUG => !!$ENV{MOUSE_DEBUG};
+
sub _inline_slot{
my(undef, $self_var, $attr_name) = @_;
return sprintf '%s->{q{%s}}', $self_var, $attr_name;
}
elsif(defined $constraint){
$accessor .= "my \$tmp = $value;\n";
-
$accessor .= "\$compiled_type_constraint->(\$tmp)";
$accessor .= " || \$attribute->_throw_type_constraint_error(\$tmp, \$constraint);\n";
$accessor .= "$slot = \$tmp;\n";
$accessor .= "return $slot;\n}\n";
- #print $accessor, "\n";
+ warn $accessor if _MOUSE_DEBUG;
my $code;
my $e = do{
local $@;
=head1 VERSION
- This document describes Mouse version 0.73
+ This document describes Mouse version 0.74
=head1 SEE ALSO
package Mouse::Meta::Method::Constructor;
use Mouse::Util qw(:meta); # enables strict and warnings
+ use constant _MOUSE_DEBUG => !!$ENV{MOUSE_DEBUG};
+
sub _inline_slot{
my(undef, $self_var, $attr_name) = @_;
return sprintf '%s->{q{%s}}', $self_var, $attr_name;
my $buildall = $class->_generate_BUILDALL($metaclass);
my $buildargs = $class->_generate_BUILDARGS($metaclass);
- my $initializer = $metaclass->{_initialize_object} ||= do {
+ my $initializer = $metaclass->{_mouse_cache}{_initialize_object} ||=
$class->_generate_initialize_object($metaclass);
-
- my $source = sprintf(<<'EOT', __LINE__, __FILE__, $metaclass->name, $buildargs, $buildall);
- #line %d %s
- };
+ my $source = sprintf(<<'EOT', __FILE__, $metaclass->name, $buildargs, $buildall);
+ #line 1 "%s"
package %s;
sub {
my $class = shift;
return $instance;
}
EOT
- #warn $source;
+ warn $source if _MOUSE_DEBUG;
my $body;
my $e = do{
local $@;
push @res, q{$_->[0]->($instance, $_->[1]) for @triggers;};
}
- my $source = sprintf <<'EOT', __LINE__, __FILE__, $metaclass->name, join "\n", @res;
- #line %d %s
+ my $source = sprintf <<'EOT', __FILE__, $metaclass->name, join "\n", @res;
+ #line 1 "%s"
package %s;
sub {
my($meta, $instance, $args, $is_cloning) = @_;
return $instance;
}
EOT
- warn $source if $ENV{MOUSE_DEBUG};
+ warn $source if _MOUSE_DEBUG;
my $body;
my $e = do {
local $@;
=head1 VERSION
- This document describes Mouse version 0.73
+ This document describes Mouse version 0.74
=head1 SEE ALSO
package Mouse::Meta::Module;
-use Mouse::Util qw/:meta get_code_package get_code_ref not_supported/; # enables strict and warnings
+use Mouse::Util qw/:meta/; # enables strict and warnings
use Carp ();
use Scalar::Util ();
sub _code_is_mine{
# my($self, $code) = @_;
- return !exists $foreign{ get_code_package($_[1]) };
+ return !exists $foreign{ Mouse::Util::get_code_package($_[1]) };
}
sub add_method;
or $self->throw_error('You must define a method name');
return defined($self->{methods}{$method_name}) || do{
- my $code = get_code_ref($self->{package}, $method_name);
+ my $code = Mouse::Util::get_code_ref($self->{package}, $method_name);
$code && $self->_code_is_mine($code);
};
}
or $self->throw_error('You must define a method name');
return $self->{methods}{$method_name} ||= do{
- my $code = get_code_ref($self->{package}, $method_name);
+ my $code = Mouse::Util::get_code_ref($self->{package}, $method_name);
$code && $self->_code_is_mine($code) ? $code : undef;
};
}
=head1 VERSION
- This document describes Mouse version 0.73
+ This document describes Mouse version 0.74
=head1 DESCRIPTION
package Mouse::Meta::TypeConstraint;
use Mouse::Util qw(:meta); # enables strict and warnings
-use Scalar::Util ();
sub new {
my $class = shift;
$args{name} = '__ANON__' if !defined $args{name};
- if($args{parent}) {
+ if(defined $args{parent}) {
%args = (%{$args{parent}}, %args);
# a child type must not inherit 'compiled_type_constraint'
# and 'hand_optimized_type_constraint' from the parent
sub _add_type_coercions { # ($self, @pairs)
my $self = shift;
+ if(exists $self->{type_constraints}){ # union type
+ $self->throw_error(
+ "Cannot add additional type coercions to Union types '$self'");
+ }
+
my $coercions = ($self->{coercion_map} ||= []);
my %has = map{ $_->[0] => undef } @{$coercions};
push @{$coercions}, [ $type => $action ];
}
- # compile
- if(exists $self->{type_constraints}){ # union type
- $self->throw_error(
- "Cannot add additional type coercions to Union types");
- }
- else{
- $self->_compile_type_coercion();
- }
+ $self->_compile_type_coercion();
return;
}
sub coerce {
my $self = shift;
-
- my $coercion = $self->_compiled_type_coercion;
- if(!$coercion){
- $self->throw_error("Cannot coerce without a type coercion");
- }
-
return $_[0] if $self->check(@_);
+ my $coercion = $self->{_compiled_type_coercion}
+ or $self->throw_error("Cannot coerce without a type coercion");
return $coercion->(@_);
}
}
}
-sub is_a_type_of{
+sub is_a_type_of {
my($self, $other) = @_;
# ->is_a_type_of('__ANON__') is always false
}
sub _as_string { $_[0]->name } # overload ""
-sub _identity { Scalar::Util::refaddr($_[0]) } # overload 0+
+sub _identity; # overload 0+
sub _unite { # overload infix:<|>
my($lhs, $rhs) = @_;
=head1 VERSION
- This document describes Mouse version 0.73
+ This document describes Mouse version 0.74
=head1 DESCRIPTION
package Mouse::Util::TypeConstraints;
-use Scalar::Util qw(blessed looks_like_number openhandle);
+use Scalar::Util ();
sub Any { 1 }
sub Item { 1 }
sub Undef { !defined($_[0]) }
sub Defined { defined($_[0]) }
sub Value { defined($_[0]) && !ref($_[0]) }
-sub Num { looks_like_number($_[0]) }
-sub Int {
- my($value) = @_;
- looks_like_number($value) && $value =~ /\A [+-]? [0-9]+ \z/xms;
-}
+sub Num { Scalar::Util::looks_like_number($_[0]) }
sub Str {
+ # We need to use a copy here to flatten MAGICs, for instance as in
+ # Str( substr($_, 0, 42) ).
my($value) = @_;
return defined($value) && ref(\$value) eq 'SCALAR';
}
+sub Int {
+ # We need to use a copy here to save the original internal SV flags.
+ my($value) = @_;
+ return defined($value) && $value =~ /\A -? [0-9]+ \z/xms;
+}
sub Ref { ref($_[0]) }
sub ScalarRef {
sub GlobRef { ref($_[0]) eq 'GLOB' }
sub FileHandle {
- return openhandle($_[0]) || (blessed($_[0]) && $_[0]->isa("IO::Handle"))
+ my($value) = @_;
+ return Scalar::Util::openhandle($value)
+ || (Scalar::Util::blessed($value) && $value->isa("IO::Handle"))
}
-sub Object { blessed($_[0]) && blessed($_[0]) ne 'Regexp' }
+sub Object { Scalar::Util::blessed($_[0]) && ref($_[0]) ne 'Regexp' }
sub ClassName { Mouse::Util::is_class_loaded($_[0]) }
sub RoleName { (Mouse::Util::class_of($_[0]) || return 0)->isa('Mouse::Meta::Role') }
sub linearized_isa { @{ Mouse::Util::get_linear_isa($_[0]->{package}) } }
-sub get_all_attributes {
- my($self) = @_;
- my %attrs = map { %{ $self->initialize($_)->{attributes} } } reverse $self->linearized_isa;
- return values %attrs;
-}
-
sub new_object {
my $meta = shift;
my %args = (@_ == 1 ? %{$_[0]} : @_);
my $object = shift;
my $args = $object->Mouse::Object::BUILDARGS(@_);
- (blessed($object) && $object->isa($class->name))
+ (Scalar::Util::blessed($object) && $object->isa($class->name))
|| $class->throw_error("You must pass an instance of the metaclass (" . $class->name . "), not ($object)");
my $cloned = bless { %$object }, ref $object;
my($self, $object, $args, $is_cloning) = @_;
# The initializer, which is used everywhere, must be clear
# when an attribute is added. See Mouse::Meta::Class::add_attribute.
- my $initializer = $self->{_initialize_object} ||= do {
+ my $initializer = $self->{_mouse_cache}{_initialize_object} ||=
Mouse::Util::load_class($self->constructor_class)
->_generate_initialize_object($self);
goto &{$initializer};
}
+sub get_all_attributes {
+ my($self) = @_;
+ return @{ $self->{_mouse_cache}{all_attributes}
+ ||= $self->_calculate_all_attributes };
+}
+
sub is_immutable { $_[0]->{is_immutable} }
sub strict_constructor;
sub parent { $_[0]->{parent} }
sub message { $_[0]->{message} }
+sub _identity { Scalar::Util::refaddr($_[0]) } # overload 0+
+
sub type_parameter { $_[0]->{type_parameter} }
sub _compiled_type_constraint{ $_[0]->{compiled_type_constraint} }
sub _compiled_type_coercion { $_[0]->{_compiled_type_coercion} }
=head1 VERSION
- This document describes Mouse version 0.73
+ This document describes Mouse version 0.74
=head1 SEE ALSO
package Mouse::Role;
use Mouse::Exporter; # enables strict and warnings
- our $VERSION = '0.73';
+ our $VERSION = '0.74';
use Carp qw(confess);
use Scalar::Util qw(blessed);
-use Mouse::Util qw(not_supported);
-use Mouse::Meta::Role;
use Mouse ();
Mouse::Exporter->setup_import_methods(
}
sub excludes {
- not_supported;
+ Mouse::Util::not_supported();
}
sub init_meta{
=head1 VERSION
- This document describes Mouse version 0.73
+ This document describes Mouse version 0.74
=head1 SYNOPSIS
},
);
- our $VERSION = '0.73';
+ our $VERSION = '0.74';
my $xs = !(defined(&is_valid_class_name) || $ENV{MOUSE_PUREPERL} || $ENV{PERL_ONLY});
sub not_supported{
my($feature) = @_;
- $feature ||= ( caller(1) )[3]; # subroutine name
+ $feature ||= ( caller(1) )[3] . '()'; # subroutine name
local $Carp::CarpLevel = $Carp::CarpLevel + 1;
Carp::confess("Mouse does not currently support $feature");
=head1 VERSION
- This document describes Mouse version 0.73
+ This document describes Mouse version 0.74
=head1 SYNOPSIS
projects / gitmo/Mouse.git / commitdiff