From: Gordon Irving <goraxe@goraxe.me.uk>
Date: Sat, 1 Aug 2009 19:26:28 +0000 (+0100)
Subject: in Moose::Object add support for a hook BUILDCLASS which allows
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=caefeda227e0704df7728a6ca8340964ee08446d;p=gitmo%2FMoose.git

in Moose::Object add support for a hook BUILDCLASS which allows
subclasses to change the class the object is being blessed into.  The
intended purpose is to allow MooseX::Traits and other classes which add
a new_with_X_feature to create an anon class and return it.  Thus
allowing all creation to go through a std new()
---

diff --git a/lib/Moose/Object.pm b/lib/Moose/Object.pm
index 15d9ffa..49f804a 100644
--- a/lib/Moose/Object.pm
+++ b/lib/Moose/Object.pm
@@ -23,7 +23,12 @@ sub new {
     # We want to support passing $self->new, but initialize
     # takes only an unblessed class name
     my $real_class = Scalar::Util::blessed($class) || $class;
-    my $self = Class::MOP::Class->initialize($real_class)->new_object($params);
+
+	# this provides a hook to allow subclasses, roles, traits etc a chance to change 
+	# how the class will behave
+	my $built_class = $real_class->BUILDALLCLASS($params);
+
+    my $self = Class::MOP::Class->initialize($built_class)->new_object($params);
 
     $self->BUILDALL($params);
 
@@ -56,6 +61,19 @@ sub BUILDALL {
     }
 }
 
+
+sub BUILDALLCLASS {
+    # NOTE: we ask Perl if we even
+    # need to do this first, to avoid
+    # extra meta level calls
+	return $_[0] unless $_[0]->can('BUILDCLASS');
+    my ($class, $params) = @_;
+    foreach my $method (reverse Class::MOP::class_of($class)->find_all_methods_by_name('BUILDCLASS')) {
+        $class = $method->{code}->execute($class, $params);
+    }
+	return $class;
+}
+
 sub DEMOLISHALL {
     my $self = shift;
     my ($in_global_destruction) = @_;