From: gfx <gfuji@cpan.org>
Date: Mon, 21 Sep 2009 02:14:10 +0000 (+0900)
Subject: Use throw_error() instead of confess()
X-Git-Tag: 0.32~39
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=fce211ae5c3943a1b041b9c0985c4daf189fb8a8;p=gitmo%2FMouse.git

Use throw_error() instead of confess()
---

diff --git a/lib/Mouse/Meta/Attribute.pm b/lib/Mouse/Meta/Attribute.pm
index 8abdd14..6a231ca 100644
--- a/lib/Mouse/Meta/Attribute.pm
+++ b/lib/Mouse/Meta/Attribute.pm
@@ -159,7 +159,7 @@ sub _generate_accessor{
     }';
 
     my $sub = eval $accessor;
-    Carp::confess($@) if $@;
+    $attribute->throw_error($@) if $@;
     return $sub;
 }
 
@@ -171,7 +171,7 @@ sub _generate_predicate {
     my $predicate = 'sub { exists($_[0]->{'.$key.'}) }';
 
     my $sub = eval $predicate;
-    confess $@ if $@;
+    $attribute->throw_error($@) if $@;
     return $sub;
 }
 
@@ -182,7 +182,7 @@ sub _generate_clearer {
     my $clearer = 'sub { delete($_[0]->{'.$key.'}) }';
 
     my $sub = eval $clearer;
-    confess $@ if $@;
+    $attribute->throw_error($@) if $@;
     return $sub;
 }
 
@@ -202,7 +202,7 @@ sub _generate_handles {
         }';
 
         $method_map{$local_method} = eval $method;
-        confess $@ if $@;
+        $attribute->throw_error($@) if $@;
     }
 
     return \%method_map;
@@ -296,31 +296,31 @@ sub validate_args {
     my $name = shift;
     my $args = shift;
 
-    confess "You can not use lazy_build and default for the same attribute ($name)"
+    $self->throw_error("You can not use lazy_build and default for the same attribute ($name)")
         if $args->{lazy_build} && exists $args->{default};
 
-    confess "You cannot have lazy attribute ($name) without specifying a default value for it"
+    $self->throw_error("You cannot have lazy attribute ($name) without specifying a default value for it")
         if $args->{lazy}
         && !exists($args->{default})
         && !exists($args->{builder});
 
-    confess "References are not allowed as default values, you must wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])"
+    $self->throw_error("References are not allowed as default values, you must wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])")
         if ref($args->{default})
         && ref($args->{default}) ne 'CODE';
 
-    confess "You cannot auto-dereference without specifying a type constraint on attribute ($name)"
+    $self->throw_error("You cannot auto-dereference without specifying a type constraint on attribute ($name)")
         if $args->{auto_deref} && !exists($args->{isa});
 
-    confess "You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)"
+    $self->throw_error("You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)")
         if $args->{auto_deref}
         && $args->{isa} !~ /^(?:ArrayRef|HashRef)(?:\[.*\])?$/;
 
     if ($args->{trigger}) {
         if (ref($args->{trigger}) eq 'HASH') {
-            Carp::carp "HASH-based form of trigger has been removed. Only the coderef form of triggers are now supported.";
+            $self->throw_error("HASH-based form of trigger has been removed. Only the coderef form of triggers are now supported.");
         }
 
-        confess "Trigger must be a CODE ref on attribute ($name)"
+        $self->throw_error("Trigger must be a CODE ref on attribute ($name)")
             if ref($args->{trigger}) ne 'CODE';
     }
 
@@ -340,7 +340,7 @@ sub verify_against_type_constraint {
 
 sub verify_type_constraint_error {
     my($self, $name, $value, $type) = @_;
-    Carp::confess("Attribute ($name) does not pass the type constraint because: " . $type->get_message($value));
+    $self->throw_error("Attribute ($name) does not pass the type constraint because: " . $type->get_message($value));
 }
 
 sub coerce_constraint { ## my($self, $value) = @_;
@@ -360,7 +360,7 @@ sub _canonicalize_handles {
         return map { $_ => $_ } @$handles;
     }
     else {
-        confess "Unable to canonicalize the 'handles' option with $handles";
+        $self->throw_error("Unable to canonicalize the 'handles' option with $handles");
     }
 }
 
@@ -384,7 +384,14 @@ sub get_parent_args {
         return %{ $super_attr->_create_args };
     }
 
-    confess "Could not find an attribute by the name of '$name' to inherit from";
+    $self->throw_error("Could not find an attribute by the name of '$name' to inherit from");
+}
+
+sub throw_error{
+    my $self = shift;
+
+    my $metaclass = (ref $self && $self->associated_class) || 'Mouse::Meta::Class';
+    $metaclass->throw_error(@_, depth => 1);
 }
 
 1;
diff --git a/lib/Mouse/Meta/Class.pm b/lib/Mouse/Meta/Class.pm
index abc8a25..4a6adec 100644
--- a/lib/Mouse/Meta/Class.pm
+++ b/lib/Mouse/Meta/Class.pm
@@ -5,8 +5,7 @@ use warnings;
 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);
 
@@ -104,7 +103,9 @@ sub new_object {
     my $self = shift;
     my $args = (@_ == 1) ? $_[0] : { @_ };
 
-    foreach my $attribute ($self->meta->get_all_attributes) {
+    my $instance = bless {}, $self->name;
+
+    foreach my $attribute ($self->get_all_attributes) {
         my $from = $attribute->init_arg;
         my $key  = $attribute->name;
 
@@ -116,7 +117,7 @@ sub new_object {
             $instance->{$key} = $args->{$from};
 
             weaken($instance->{$key})
-                if $attribute->is_weak_ref;
+                if ref($instance->{$key}) && $attribute->is_weak_ref;
 
             if ($attribute->has_trigger) {
                 $attribute->trigger->($instance, $args->{$from});
@@ -140,12 +141,12 @@ sub new_object {
                     $instance->{$key} = $value;
 
                     weaken($instance->{$key})
-                        if $attribute->is_weak_ref;
+                        if ref($instance->{$key}) && $attribute->is_weak_ref;
                 }
             }
             else {
                 if ($attribute->is_required) {
-                    confess "Attribute (".$attribute->name.") is required";
+                    $self->throw_error("Attribute (".$attribute->name.") is required");
                 }
             }
         }
@@ -158,7 +159,7 @@ sub clone_object {
     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, @_);
 }
@@ -167,7 +168,7 @@ sub clone_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;
 
@@ -191,7 +192,6 @@ sub make_immutable {
         @_,
     );
 
-    my $name = $self->name;
     $self->{is_immutable}++;
 
     if ($args{inline_constructor}) {
@@ -207,7 +207,7 @@ sub make_immutable {
     return 1;
 }
 
-sub make_mutable { confess "Mouse does not currently support 'make_mutable'" }
+sub make_mutable { not_supported }
 
 sub is_immutable { $_[0]->{is_immutable} }
 
@@ -271,7 +271,7 @@ sub add_override_method_modifier {
     # 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, @_) };
@@ -281,7 +281,7 @@ 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 = Mouse::class_of($class);
@@ -299,20 +299,20 @@ sub create {
     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} . "';"
@@ -321,7 +321,7 @@ sub create {
           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;
diff --git a/lib/Mouse/Meta/Module.pm b/lib/Mouse/Meta/Module.pm
index 8dedd7e..fa99e17 100755
--- a/lib/Mouse/Meta/Module.pm
+++ b/lib/Mouse/Meta/Module.pm
@@ -2,9 +2,9 @@ package Mouse::Meta::Module;
 use strict;
 use warnings;
 
-use Mouse::Util qw/get_code_info/;
+use Mouse::Util qw/get_code_info not_supported/;
 use Scalar::Util qw/blessed/;
-use Carp ();
+
 
 {
     my %METACLASS_CACHE;
@@ -20,7 +20,7 @@ use Carp ();
         my($class, $package_name, @args) = @_;
 
         ($package_name && !ref($package_name))
-            || confess("You must pass a package name and it cannot be blessed");
+            || $class->throw_error("You must pass a package name and it cannot be blessed");
 
         return $METACLASS_CACHE{$package_name}
             ||= $class->_new(package => $package_name, @args);
@@ -45,6 +45,8 @@ use Carp ();
 
 }
 
+sub meta{ Mouse::Meta::Class->initialize(ref $_[0] || $_[0]) }
+
 sub _new{ Carp::croak("Mouse::Meta::Module is an abstract class") }
 
 sub name { $_[0]->{package} }
@@ -78,10 +80,10 @@ sub add_method {
     my($self, $name, $code) = @_;
 
     if(!defined $name){
-        confess "You must pass a defined name";
+        $self->throw_error("You must pass a defined name");
     }
     if(ref($code) ne 'CODE'){
-        confess "You must pass a CODE reference";
+        not_supported 'add_method for a method object';
     }
 
     $self->_method_map->{$name}++; # Moose stores meta object here.
@@ -123,7 +125,7 @@ sub get_method_list {
 sub throw_error{
     my($class, $message, %args) = @_;
 
-    local $Carp::CarpLevel  = $Carp::CarpLevel + ($args{depth} || 1);
+    local $Carp::CarpLevel  = $Carp::CarpLevel + 1 + ($args{depth} || 0);
     local $Carp::MaxArgNums = 20; # default is 8, usually we use named args which gets messier though
 
     if(exists $args{longmess} && !$args{longmess}){ # intentionaly longmess => 0
diff --git a/lib/Mouse/Meta/Role.pm b/lib/Mouse/Meta/Role.pm
index db9a867..b9f6b38 100644
--- a/lib/Mouse/Meta/Role.pm
+++ b/lib/Mouse/Meta/Role.pm
@@ -1,8 +1,8 @@
 package Mouse::Meta::Role;
 use strict;
 use warnings;
-use Carp 'confess';
 
+use Mouse::Util qw(not_supported);
 use base qw(Mouse::Meta::Module);
 
 sub _new {
@@ -51,7 +51,7 @@ sub _check_required_methods{
                     }
                 }
                 
-                confess "'$role_name' requires the method '$method_name' to be implemented by '$class_name'"
+                $role->throw_error("'$role_name' requires the method '$method_name' to be implemented by '$class_name'")
                     unless $has_method;
             }
         }
@@ -159,7 +159,7 @@ sub apply {
     my($self, $class, %args) = @_;
 
     if ($class->isa('Mouse::Object')) {
-        Carp::croak('Mouse does not support Application::ToInstance yet');
+        not_supported 'Application::ToInstance';
     }
 
     $self->_check_required_methods($class, \%args);
@@ -217,7 +217,7 @@ 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");
 
     # if we are it,.. then return true
     return 1 if $role_name eq $self->name;
diff --git a/lib/Mouse/Object.pm b/lib/Mouse/Object.pm
index a641129..3eef06b 100644
--- a/lib/Mouse/Object.pm
+++ b/lib/Mouse/Object.pm
@@ -2,16 +2,14 @@ package Mouse::Object;
 use strict;
 use warnings;
 
-use Carp 'confess';
-
 sub new {
     my $class = shift;
 
-    confess('Cannot call new() on an instance') if ref $class;
+    $class->throw_error('Cannot call new() on an instance') if ref $class;
 
     my $args = $class->BUILDARGS(@_);
 
-    my $instance = Mouse::Meta::Class->initialize($class)->new_object($params);
+    my $instance = Mouse::Meta::Class->initialize($class)->new_object($args);
     $instance->BUILDALL($args);
     return $instance;
 }
@@ -21,7 +19,7 @@ sub BUILDARGS {
 
     if (scalar @_ == 1) {
         (ref($_[0]) eq 'HASH')
-            || confess "Single parameters to new() must be a HASH ref";
+            || $class->meta->throw_error("Single parameters to new() must be a HASH ref");
         return {%{$_[0]}};
     }
     else {
@@ -79,7 +77,7 @@ sub dump {
 sub does {
     my ($self, $role_name) = @_;
     (defined $role_name)
-        || confess "You must supply a role name to does()";
+        || $self->meta->throw_error("You must supply a role name to does()");
 
     return $self->meta->does_role($role_name);
 };
diff --git a/lib/Mouse/Util.pm b/lib/Mouse/Util.pm
index 30eea32..73e76ba 100644
--- a/lib/Mouse/Util.pm
+++ b/lib/Mouse/Util.pm
@@ -9,6 +9,7 @@ our @EXPORT_OK = qw(
     get_linear_isa
     apply_all_roles
     get_code_info
+    not_supported
 );
 our %EXPORT_TAGS = (
     all  => \@EXPORT_OK,
@@ -198,6 +199,15 @@ sub apply_all_roles {
     return;
 }
 
+sub not_supported{
+    my($feature) = @_;
+
+    $feature ||= ( caller(1) )[3]; # subroutine name
+
+    local $Carp::CarpLevel = $Carp::CarpLevel + 2;
+    Carp::croak("Mouse does not currently support $feature");
+}
+
 1;
 
 __END__