From: Vyacheslav Matyukhin <mmcleric@yandex-team.ru>
Date: Wed, 6 Jun 2012 19:51:50 +0000 (+0400)
Subject: generate_method checks if default is a coderef
X-Git-Tag: v0.091010~11
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMoo.git;a=commitdiff_plain;h=533797e172427f98b5529a1643d48a0a56a2c629

generate_method checks if default is a coderef

Blessed objects are allowed, scalars and non-blessed non-subs are not
allowed.
---

diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm
index 10040e9..64bb881 100644
--- a/lib/Method/Generate/Accessor.pm
+++ b/lib/Method/Generate/Accessor.pm
@@ -43,6 +43,16 @@ sub generate_method {
   if (($spec->{trigger}||0) eq 1) {
     $spec->{trigger} = quote_sub('shift->_trigger_'.$name.'(@_)');
   }
+  if (exists $spec->{default}) {
+    if (not ref $spec->{default}) {
+      die "Invalid default $spec->{default}";
+    }
+    elsif (ref $spec->{default} ne 'CODE') {
+      require Scalar::Util;
+      die "Invalid default $spec->{default}" unless Scalar::Util::blessed $spec->{default};
+    }
+  }
+
   my %methods;
   if (my $reader = $spec->{reader}) {
     if (our $CAN_HAZ_XS && $self->is_simple_get($name, $spec)) {
diff --git a/t/method-generate-accessor.t b/t/method-generate-accessor.t
index 13ac5a8..cd7741b 100644
--- a/t/method-generate-accessor.t
+++ b/t/method-generate-accessor.t
@@ -25,6 +25,26 @@ like(
   qr/Unknown is purple/, 'is purple rejected'
 );
 
+like(
+  exception { $gen->generate_method('Foo' => 'four' => { is => 'ro', default => 5 }) },
+  qr/Invalid default/, 'default scalar rejected'
+);
+
+like(
+  exception { $gen->generate_method('Foo' => 'five' => { is => 'ro', default => [] }) },
+  qr/Invalid default/, 'default arrayref rejected'
+);
+
+is(
+  exception { $gen->generate_method('Foo' => 'six' => { is => 'ro', default => sub { 5 } }) },
+  undef, 'default coderef accepted'
+);
+
+is(
+  exception { $gen->generate_method('Foo' => 'seven' => { is => 'ro', default => bless sub { 5 } => 'Blah' }) },
+  undef, 'default blessed sub accepted'
+);
+
 my $foo = Foo->new(one => 1);
 
 is($foo->one, 1, 'ro reads');