Author: ericwilhelm
Date: Thu Dec 11 18:09:07 2008
New Revision: 12149
Added:
Module-Build/trunk/t/add_property.t
Modified:
Module-Build/trunk/Changes
Module-Build/trunk/lib/Module/Build/API.pod
Module-Build/trunk/lib/Module/Build/Base.pm
Log:
[by: David Wheeler]
lib/Module/Build/Base.pm - 'check' subs for add_property(),
validate 'install_dirs' values
t/add_property.t - tested
lib/Module/Build/API.pod - documentation of add_property() + default/check
Changes - update
Modified: Module-Build/trunk/Changes
==============================================================================
--- Module-Build/trunk/Changes (original)
+++ Module-Build/trunk/Changes Thu Dec 11 18:09:07 2008
@@ -24,6 +24,8 @@
the license. This requires Software::License on the author's
machine. THIS ALSO STILL NEEDS DOCS.
- Added lgpl2/lgpl3 entries to the supported licenses (RT#40532).
+ - Support for validating properties with a check subref. [David
+ Wheeler]
Test Fixes
- Defend against more stray environment variables interfering
Modified: Module-Build/trunk/lib/Module/Build/API.pod
==============================================================================
--- Module-Build/trunk/lib/Module/Build/API.pod (original)
+++ Module-Build/trunk/lib/Module/Build/API.pod Thu Dec 11 18:09:07 2008
@@ -795,6 +795,86 @@
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 constructor and 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 sends an error message to
+C<property_error()> and returns 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
@@ -887,7 +967,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]
Modified: Module-Build/trunk/lib/Module/Build/Base.pm
==============================================================================
--- Module-Build/trunk/lib/Module/Build/Base.pm (original)
+++ Module-Build/trunk/lib/Module/Build/Base.pm Thu Dec 11 18:09:07 2008
@@ -672,7 +672,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;
}
@@ -692,22 +694,24 @@
}
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 ) : @_;
+
+ my $type = ref $p{default};
+ $valid_properties{$class}{$property} = $type eq 'CODE'
+ ? $p{default}
+ : sub { $p{default} };
- $valid_properties{$class}{$property} = $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)) {
- my $maker = $type eq 'HASH' ?
- '_make_hash_accessor' : '_make_accessor';
# TODO probably should put these in a util package
- $maker = $class->can($maker) or die "where did it go?";
- my $sub = $maker->($property);
+ my $sub = $type eq 'HASH'
+ ? _make_hash_accessor($property, \%p)
+ : _make_accessor($property, \%p);
no strict 'refs';
*{"$class\::$property"} = $sub;
}
@@ -715,6 +719,11 @@
return $class;
}
+ sub property_error {
+ my $self = shift;
+ die 'ERROR: ', @_;
+ }
+
sub _set_defaults {
my $self = shift;
@@ -746,7 +755,8 @@
} # end closure
########################################################################
sub _make_hash_accessor {
- my ($property) = @_;
+ my ($property, $p) = @_;
+ my $check = $p->{check} || sub { 1 };
return sub {
my $self = shift;
@@ -762,31 +772,30 @@
my $x = $self->{properties};
return $x->{$property} unless @_;
- 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 {
+ 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 {
- $x->{$property} = $_[0];
+ } else {
+ die "Unexpected arguments for property '$property'\n"
+ if defined $_[0] && ref $_[0] ne 'HASH';
+ local $_ = $_[0];
+ $x->{$property} = shift if $check->($self);
}
};
}
########################################################################
sub _make_accessor {
- my ($property) = @_;
+ my ($property, $p) = @_;
+ my $check = $p->{check} || sub { 1 };
return sub {
my $self = shift;
@@ -799,8 +808,11 @@
return;
}
- $self->{properties}{$property} = shift if @_;
- return $self->{properties}{$property};
+ my $x = $self->{properties};
+ return $x->{$property} unless @_;
+ local $_ = $_[0];
+ $x->{$property} = shift if $check->($self);
+ return $x->{$property};
};
}
########################################################################
@@ -813,7 +825,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);
@@ -823,6 +834,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};
Added: Module-Build/trunk/t/add_property.t
==============================================================================
--- (empty file)
+++ Module-Build/trunk/t/add_property.t Thu Dec 11 18:09:07 2008
@@ -0,0 +1,93 @@
+#!/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';
