From: Stevan Little Date: Mon, 10 Apr 2006 19:51:42 +0000 (+0000) Subject: getting-there X-Git-Tag: 0_05~44 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=76d37e5a93324c12abfa3c9c6c51dbc3bf31baa5;p=gitmo%2FMoose.git getting-there --- diff --git a/Changes b/Changes index b651184..db23ff6 100644 --- a/Changes +++ b/Changes @@ -1,8 +1,8 @@ Revision history for Perl extension Moose -0.04 +0.03_01 * Moose::Cookbook - - added new Role recipe + - added new Role recipe (no content yet, only code) * Moose - added 'with' keyword for Role support @@ -13,6 +13,10 @@ Revision history for Perl extension Moose * Moose::Role - Roles for Moose - added test and docs + + * Moose::Util::TypeConstraints + - added the message keyword to add custom + error messages to type constraints * Moose::Meta::Role - the meta role to support Moose::Role @@ -27,6 +31,11 @@ Revision history for Perl extension Moose - moved the attribute option macros here instead of putting them in Moose.pm + * Moose::Meta::TypeConstraint + - added the message attributes and the + validate method + - added tests and docs for this + 0.03 Thurs. March 30, 2006 * Moose::Cookbook - added the Moose::Cookbook with 5 recipes, diff --git a/bin/moosedoc.pl b/bin/moosedoc.pl deleted file mode 100644 index 8e88e69..0000000 --- a/bin/moosedoc.pl +++ /dev/null @@ -1,44 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; - -use lib './lib'; - -use Moose; - -=pod - -=head1 ROADMAP - -This is the roadmap for the moosedoc utility. It is just a rough -sketch of what I am thinking for this. - -First question, should it be source-file oriented? or class oriented? - -In other words, should I have to do this: - - > moosedoc --target ./my_project/lib/ - -And have moosedoc traverse the ./my_project/lib/ directory looking for -.pm files, loading each one and then creating a .pod for it based on the -moose introspection? - -Or should it do this: - - > moosedoc --target ./my_project/script.pl - -And have moosedoc then ask Moose what classes/types/subtypes/etc. I -loaded, and create some kind of .pod for them? - -Second question, should I create a large source repository like javadoc? -or should it just be a file-per-file thing? - -If I do it like javadoc, then I would need an index file, a frameset, a -file for all types/subtypes made, one for all classes, one for all roles, -etc. At that point, POD may not make sense, and we are into pure HTML -(for the hyperlinking of course). This then restricts the type of output. - -Hmmm,.. gotta do some thinking. - -=cut diff --git a/lib/Moose.pm b/lib/Moose.pm index f2dc314..ab4ebf0 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -4,7 +4,7 @@ package Moose; use strict; use warnings; -our $VERSION = '0.04'; +our $VERSION = '0.03_01'; use Scalar::Util 'blessed', 'reftype'; use Carp 'confess'; @@ -261,7 +261,8 @@ superclasses properly inherit from L. =item B -This will apply a given C<$role> to the local class. +This will apply a given C<$role> to the local class. Role support is +currently very experimental, see L for more details. =item B diff --git a/lib/Moose/Meta/TypeConstraint.pm b/lib/Moose/Meta/TypeConstraint.pm index 518e448..fc9a14e 100644 --- a/lib/Moose/Meta/TypeConstraint.pm +++ b/lib/Moose/Meta/TypeConstraint.pm @@ -8,11 +8,15 @@ use metaclass; use Sub::Name 'subname'; use Carp 'confess'; -our $VERSION = '0.01'; +our $VERSION = '0.02'; __PACKAGE__->meta->add_attribute('name' => (reader => 'name' )); __PACKAGE__->meta->add_attribute('parent' => (reader => 'parent' )); __PACKAGE__->meta->add_attribute('constraint' => (reader => 'constraint')); +__PACKAGE__->meta->add_attribute('message' => ( + accessor => 'message', + predicate => 'has_message' +)); __PACKAGE__->meta->add_attribute('coercion' => ( accessor => 'coercion', predicate => 'has_coercion' @@ -57,6 +61,22 @@ sub compile_type_constraint () { sub check { $_[0]->_compiled_type_constraint->($_[1]) } +sub validate { + my ($self, $value) = @_; + if ($self->_compiled_type_constraint->($value)) { + return undef; + } + else { + if ($self->has_message) { + local $_ = $value; + return $self->message->($value); + } + else { + return "Validation failed for '" . $self->name . "' failed."; + } + } +} + 1; __END__ @@ -88,7 +108,17 @@ If you wish to use features at this depth, please come to the =item B -=item B +=item B + +This method will return a true (C<1>) if the C<$value> passes the +constraint, and false (C<0>) otherwise. + +=item B + +This method is similar to C, but it deals with the error +message. If the C<$value> passes the constraint, C will be +returned. If the C<$value> does B pass the constraint, then +the C will be used to construct a custom error message. =item B @@ -96,6 +126,10 @@ If you wish to use features at this depth, please come to the =item B +=item B + +=item B + =item B =item B diff --git a/lib/Moose/Role.pm b/lib/Moose/Role.pm index 70ed5ac..0fd67a1 100644 --- a/lib/Moose/Role.pm +++ b/lib/Moose/Role.pm @@ -90,14 +90,83 @@ __END__ Moose::Role - The Moose Role +=head1 SYNOPSIS + + package Eq; + use strict; + use warnings; + use Moose::Role; + + sub equal { confess "equal must be implemented" } + + sub no_equal { + my ($self, $other) = @_; + !$self->equal($other); + } + + # ... then in your classes + + package Currency; + use strict; + use warnings; + use Moose; + + with 'Eq'; + + sub equal { + my ($self, $other) = @_; + $other->as_float == $other->as_float; + } + =head1 DESCRIPTION -=head1 METHODS +This is currently a very early release of Perl 6 style Roles for +Moose, it should be considered experimental and incomplete. + +This feature is being actively developed, but $work is currently +preventing me from paying as much attention to it as I would like. +So I am releasing it in hopes people will help me on this I. + +If you are interested in helping, please come to #moose on irc.perl.org +and we can talk. + +=head1 CAVEATS + +Currently, the role support has a number of caveats. They are as follows: =over 4 +=item * + +There is no support for Roles consuming other Roles. The details of this +are not totally worked out yet, but it will mostly follow what is set out +in the Perl 6 Synopsis 12. + +=item * + +At this time classes I consume more than one Role, but they are simply +applied one after another in the order you ask for them. This is incorrect +behavior, the roles should be merged first, and conflicts determined, etc. +However, if your roles do not have any conflicts, then things will work just +fine. + +=item * + +I want to have B methods, which is unlike Perl 6 roles, and more +like the original Traits on which roles are based. This would be similar +in behavior to L. These are not yet implemented or course. + +=item * + +Roles cannot use the C keyword, it will throw an exception for now. +The same is true of the C and C keywords (not sure those +really make sense for roles). All other Moose keywords will be I +so that they can be applied to the consuming class. + =back +Basically thats all I can think of for now, I am sure there are more though. + =head1 BUGS All complex software has bugs lurking in it, and this module is no diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 0a0df2a..63ba714 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -17,7 +17,7 @@ sub import { my $pkg = shift || caller(); return if $pkg eq '-no-export'; no strict 'refs'; - foreach my $export (qw(type subtype as where coerce from via find_type_constraint)) { + foreach my $export (qw(type subtype as where message coerce from via find_type_constraint)) { *{"${pkg}::${export}"} = \&{"${export}"}; } } @@ -27,7 +27,7 @@ sub import { sub find_type_constraint { $TYPES{$_[0]}->[1] } sub _create_type_constraint { - my ($name, $parent, $check) = @_; + my ($name, $parent, $check, $message) = @_; my $pkg_defined_in = scalar(caller(1)); ($TYPES{$name}->[0] eq $pkg_defined_in) || confess "The type constraint '$name' has already been created" @@ -36,7 +36,8 @@ sub import { my $constraint = Moose::Meta::TypeConstraint->new( name => $name || '__ANON__', parent => $parent, - constraint => $check, + constraint => $check, + message => $message, ); $TYPES{$name} = [ $pkg_defined_in, $constraint ] if defined $name; return $constraint; @@ -70,8 +71,8 @@ sub type ($$) { _create_type_constraint($name, undef, $check); } -sub subtype ($$;$) { - unshift @_ => undef if scalar @_ == 2; +sub subtype ($$;$$) { + unshift @_ => undef if scalar @_ <= 2; _create_type_constraint(@_); } @@ -80,17 +81,18 @@ sub coerce ($@) { _install_type_coercions($type_name, \@coercion_map); } -sub as ($) { $_[0] } -sub from ($) { $_[0] } -sub where (&) { $_[0] } -sub via (&) { $_[0] } +sub as ($) { $_[0] } +sub from ($) { $_[0] } +sub where (&) { $_[0] } +sub via (&) { $_[0] } +sub message (&) { $_[0] } # define some basic types type 'Any' => where { 1 }; -type 'Value' => where { !ref($_) }; -type 'Ref' => where { ref($_) }; +subtype 'Value' => as 'Any' => where { !ref($_) }; +subtype 'Ref' => as 'Any' => where { ref($_) }; subtype 'Int' => as 'Value' => where { Scalar::Util::looks_like_number($_) }; subtype 'Str' => as 'Value' => where { !Scalar::Util::looks_like_number($_) }; @@ -218,6 +220,10 @@ This is just sugar for the type constraint construction syntax. This is just sugar for the type constraint construction syntax. +=item B + +This is just sugar for the type constraint construction syntax. + =back =head2 Type Coercion Constructors diff --git a/t/050_util_type_constraints.t b/t/050_util_type_constraints.t index 9216a7d..c651487 100644 --- a/t/050_util_type_constraints.t +++ b/t/050_util_type_constraints.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 17; +use Test::More tests => 25; use Test::Exception; use Scalar::Util (); @@ -21,7 +21,8 @@ subtype Natural subtype NaturalLessThanTen => as Natural - => where { $_ < 10 }; + => where { $_ < 10 } + => message { "The number '$_' is not less than 10" }; Moose::Util::TypeConstraints->export_type_contstraints_as_functions(); @@ -50,5 +51,28 @@ is($negative->check(-5), -5, '... this is a negative number'); ok(!defined($negative->check(5)), '... this is not a negative number'); is($negative->check('Foo'), undef, '... this is not a negative number'); +# check some meta-details + +my $natural_less_than_ten = find_type_constraint('NaturalLessThanTen'); +isa_ok($natural_less_than_ten, 'Moose::Meta::TypeConstraint'); + +ok($natural_less_than_ten->has_message, '... it has a message'); + +ok(!defined($natural_less_than_ten->validate(5)), '... validated successfully (no error)'); + +is($natural_less_than_ten->validate(15), + "The number '15' is not less than 10", + '... validated unsuccessfully (got error)'); + +my $natural = find_type_constraint('Natural'); +isa_ok($natural, 'Moose::Meta::TypeConstraint'); + +ok(!$natural->has_message, '... it does not have a message'); + +ok(!defined($natural->validate(5)), '... validated successfully (no error)'); + +is($natural->validate(-5), + "Validation failed for 'Natural' failed.", + '... validated unsuccessfully (got error)');