Re: invalid installdirs values

Index: t/add_property.t
===================================================================
--- t/add_property.t	(revision 0)
+++ t/add_property.t	(revision 0)
@@ -0,0 +1,88 @@
+#!/usr/bin/perl -w
+
+use strict;
+use lib $ENV{PERL_CORE} ? '../lib/Module/Build/t/lib' : 't/lib';
+use MBTest tests => 29;
+#use MBTest 'no_plan';
+use DistGen;
+
+BEGIN { use_ok 'Module::Build' or die; }
+ensure_blib 'Module::Build';
+
+my $tmp = MBTest->tmpdir;
+my $dist = DistGen->new( dir => $tmp );
+$dist->regen;
+$dist->chdir_in;
+
+ADDPROP: {
+    package My::Build::Prop;
+    use base 'Module::Build';
+    __PACKAGE__->add_property( 'foo' );
+    __PACKAGE__->add_property( 'bar', 'howdy' );
+    __PACKAGE__->add_property( 'baz', default => 'howdy' );
+    __PACKAGE__->add_property( 'code', default => sub { 'yay' } );
+    __PACKAGE__->add_property(
+        'check',
+        default => sub { 'howdy' },
+        check   => sub {
+            return 1 if $_ eq 'howdy';
+            shift->property_error(qq{"$_" is invalid});
+            return 0;
+        },
+    );
+    __PACKAGE__->add_property(
+        'hash',
+        default => { foo => 1 },
+        check   => sub {
+            return 1 if !defined $_ or exists $_->{foo};
+            shift->property_error(qq{hash is invalid});
+            return 0;
+        },
+    );
+}
+
+ok my $build = My::Build::Prop->new(
+    'module_name' => 'Simple',
+    quiet => 1,
+), 'Create new build object';
+
+is $build->foo, undef, 'Property "foo" should be undef';
+ok $build->foo(42), 'Set "foo"';
+is $build->foo, 42, 'Now "foo" should have new value';
+
+is $build->bar, 'howdy', 'Property "bar" should be its default';
+ok $build->bar('yo'), 'Set "bar"';
+is $build->bar, 'yo', 'Now "bar" should have new value';
+
+is $build->check, 'howdy', 'Property "check" should be its default';
+eval { $build->check('yo') };
+ok my $err = $@, 'Should get an error for an invalid value';
+like $err, qr/^ERROR: "yo" is invalid/, 'It should be the correct error';
+
+is $build->code, 'yay', 'Property "code" should have its code value';
+
+is_deeply $build->hash, { foo => 1 }, 'Property "hash" should be default';
+is $build->hash('foo'), 1, 'Should be able to get key in hash';
+ok $build->hash( bar => 3 ), 'Add a key to the hash prop';
+is_deeply $build->hash, { foo => 1, bar => 3 }, 'New key should be in hash';
+eval { $build->hash({ bar => 3 }) };
+ok $err = $@, 'Should get exception for assigning invalid hash';
+like $err, qr/^ERROR: hash is invalid/, 'It should be the correct error';
+eval { $build->hash( []) };
+ok $err = $@, 'Should get exception for assigning an array for a hash';
+like $err, qr/^Unexpected arguments for property 'hash'/,
+    'It should be the proper error';
+is $build->hash(undef), undef, 'Should be able to set hash to undef';
+
+# Check core properties.
+is $build->installdirs, 'site', 'Property "installdirs" should be default';
+ok $build->installdirs('core'), 'Set "installdirst" to "core"';
+is $build->installdirs, 'core', 'Now "installdirs" should be "core"';
+eval { $build->installdirs('perl') };
+ok $err = $@, 'Should have caught exception setting "installdirs" to "perl"';
+like $err, qr/^ERROR: Perhaps you meant installdirs to be "core" rather than "perl"\?/,
+    'And it should suggest "core" in the error message';
+eval { $build->installdirs('foo') };
+ok $err = $@, 'Should catch exception for invalid "installdirs" value';
+like $err, qr/ERROR: installdirs must be one of "core", "site", or "vendor"/,
+    'And it should suggest the proper values in the error message';
Index: lib/Module/Build/Base.pm
===================================================================
--- lib/Module/Build/Base.pm	(revision 11885)
+++ lib/Module/Build/Base.pm	(working copy)
@@ -665,7 +665,9 @@
     sub valid_properties_defaults {
       my %out;
       for (reverse shift->_mb_classes) {
-	@out{ keys %{ $valid_properties{$_} } } = values %{ $valid_properties{$_} };
+	@out{ keys %{ $valid_properties{$_} } } = map {
+            $_->()
+        } values %{ $valid_properties{$_} };
       }
       return \%out;
     }
@@ -685,55 +687,67 @@
     }
 
     sub add_property {
-      my ($class, $property, $default) = @_;
-      die "Property '$property' already exists" if $class->valid_property($property);
+        my ($class, $property) = (shift, shift);
+        die "Property '$property' already exists"
+            if $class->valid_property($property);
+        my %p = @_ == 1 ? ( default => shift ) : @_;
 
-      $valid_properties{$class}{$property} = $default;
+        my $type = ref $p{default};
+        $valid_properties{$class}{$property} = $type eq 'CODE'
+            ? $p{default}
+            : sub { $p{default} };
 
-      my $type = ref $default;
-      if ($type) {
-	push @{$additive_properties{$class}->{$type}}, $property;
-      }
+        push @{$additive_properties{$class}->{$type}}, $property
+            if $type;
 
-      unless ($class->can($property)) {
-        no strict 'refs';
-	if ( $type eq 'HASH' ) {
-          *{"$class\::$property"} = sub {
-            # XXX this needs 'use strict' again
-	    my $self = shift;
-	    my $x = $self->{properties};
-	    return $x->{$property} unless @_;
+        return $class if $class->can($property);
 
-	    if ( defined($_[0]) && !ref($_[0]) ) {
-	      if ( @_ == 1 ) {
-		return exists( $x->{$property}{$_[0]} ) ?
-		         $x->{$property}{$_[0]} : undef;
-              } elsif ( @_ % 2 == 0 ) {
-	        my %args = @_;
-	        while ( my($k, $v) = each %args ) {
-	          $x->{$property}{$k} = $v;
-	        }
-	      } else {
-		die "Unexpected arguments for property '$property'\n";
-	      }
-	    } else {
-	      $x->{$property} = $_[0];
-	    }
-	  };
+        my $check = $p{check} || sub { 1 };
+        my $sub = $type eq 'HASH' ? sub {
+            my $self = shift;
+            # Allow to work in class or object context.
+            my $x = do { no strict 'refs'; $self->{properties} };
+            return $x->{$property} unless @_;
 
-        } else {
-          *{"$class\::$property"} = sub {
-            # XXX this needs 'use strict' again
-	    my $self = shift;
-	    $self->{properties}{$property} = shift if @_;
-	    return $self->{properties}{$property};
-	  }
-        }
+            my $prop = $x->{$property};
+            if ( defined $_[0] && !ref $_[0] ) {
+                if ( @_ == 1 ) {
+                    return exists $prop->{$_[0]} ? $prop->{$_[0]} : undef;
+                } elsif ( @_ % 2 == 0 ) {
+                    my %new = (%{ $prop }, @_);
+                    local $_ = \%new;
+                    $x->{$property} = \%new if $check->($self);
+                    return $x->{$property};
+                } else {
+                    die "Unexpected arguments for property '$property'\n";
+                }
+            } else {
+                die "Unexpected arguments for property '$property'\n"
+                    if defined $_[0] && ref $_[0] ne 'HASH';
+                local $_ = $_[0];
+                $x->{$property} = shift if $check->($self);
+            }
+        } : sub {
+            my $self = shift;
+            # Allow to work in class or object context.
+            my $x = do { no strict 'refs'; $self->{properties} };
+            return $x->{$property} unless @_;
+            local $_ = $_[0];
+            $x->{$property} = shift if $check->($self);
+            return $x->{$property};
+        };
 
-      }
-      return $class;
+        no strict 'refs';
+        *{"$class\::$property"} = $sub;
+
+        return $class;
     }
 
+    sub property_error {
+        my $self = shift;
+        die 'ERROR: ', @_;
+    }
+
     sub _set_defaults {
       my $self = shift;
 
@@ -772,7 +786,6 @@
 __PACKAGE__->add_property(build_bat => 0);
 __PACKAGE__->add_property(config_dir => '_build');
 __PACKAGE__->add_property(include_dirs => []);
-__PACKAGE__->add_property(installdirs => 'site');
 __PACKAGE__->add_property(metafile => 'META.yml');
 __PACKAGE__->add_property(recurse_into => []);
 __PACKAGE__->add_property(use_rcfile => 1);
@@ -782,6 +795,20 @@
 __PACKAGE__->add_property(test_file_exts => ['.t']);
 __PACKAGE__->add_property(use_tap_harness => 0);
 __PACKAGE__->add_property(tap_harness_args => {});
+__PACKAGE__->add_property(
+    'installdirs',
+    default => 'site',
+    check   => sub {
+        return 1 if /^(core|site|vendor)$/;
+        return shift->property_error(
+            $_ eq 'perl'
+            ? 'Perhaps you meant installdirs to be "core" rather than "perl"?'
+            : 'installdirs must be one of "core", "site", or "vendor"'
+        );
+        return shift->property_error("Perhaps you meant 'core'?") if $_ eq 'perl';
+        return 0;
+    },
+);
 
 {
   my $Is_ActivePerl = eval {require ActivePerl::DocTools};
Index: lib/Module/Build/API.pod
===================================================================
--- lib/Module/Build/API.pod	(revision 11885)
+++ lib/Module/Build/API.pod	(working copy)
@@ -791,9 +791,89 @@
 defaults to C<MyModuleBuilder>.  The C<code> parameter specifies Perl
 code to use as the body of the subclass.
 
+=item add_property
+
+[version 0.31]
+
+  package 'My::Build';
+  use base 'Module::Build';
+  __PACKAGE__->add_property( 'pedantic' );
+  __PACKAGE__->add_property( answer => 42 );
+  __PACKAGE__->add_property(
+      'epoch',
+      default => sub { time },
+      check   => sub {
+          return 1 if /^\d+$/;
+          shift->property_error( "'$_' is not an epoch time" );
+          return 0;
+      },
+  );
+
+Adds a property to a Module::Build class. Properties are those attributes of a
+Module::Build object which can be passed to the constructorand which have
+accessors to get and set them. All of the core properties, such as
+C<module_name> and C<license>, are defined using this class method.
+
+The first argument to C<add_property()> is always the name of the property.
+The second argument can be either a default value for the property, or a list
+of key/value pairs. The supported keys are:
+
+=over
+
+=item C<default>
+
+The default value. May optionally be specified as a code reference, in which
+case the return value from the execution of the code reference will be used.
+If you need the default to be a code reference, just use a code reference to
+return it, e.g.:
+
+      default => sub { sub { ... } },
+
+=item C<check>
+
+A code reference that checks that a value specified for the property is valid.
+During the execution of the code reference, the new value will be included in
+the C<$_> variable. If the value is correct, the C<check> code reference
+should return true. If the value is not correct, it send an error message to
+C<property_error()> and return false.
+
 =back
 
+When this method is called, a new property will be installed in the
+Module::Build class, and an accessor will be built to allow the property to be
+get or set on the build object.
 
+  print $build->pedantic, $/;
+  $build->pedantic(0);
+
+If the default value is a hash reference, this generetes a special-case
+accessor method, wherein individual key/value pairs may be set or fetched:
+
+  print "stuff{foo} is: ", $build->stuff( 'foo' ), $/;
+  $build->stuff( foo => 'bar' );
+  print $build->stuff( 'foo' ), $/; # Outputs "bar"
+
+Of course, you can still set the entire hash reference at once, as well:
+
+  $build->stuff( { foo => 'bar', baz => 'yo' } );
+
+In either case, if a C<check> has been specified for the property, it will be
+applied to the entire hash. So the check code reference should look something
+like:
+
+      check => sub {
+            return 1 if defined $_ && exists $_->{foo};
+            shift->property_error(qq{Property "stuff" needs "foo"});
+            return 0;
+      },
+
+=item property_error
+
+[version 0.31]
+
+=back
+
+
 =head2 METHODS
 
 =over 4
@@ -883,7 +963,6 @@
 compiling & linking C code.  If no such object is available (e.g. if
 the system has no compiler installed) an exception will be thrown.
 
-
 =item check_installed_status($module, $version)
 
 [version 0.11]