This is an automated email from the git hooks/post-receive script.
js pushed a commit to tag 0.043_02
in repository libtype-tiny-perl.
commit 3686bdd54d47447cb3b3017e53272e823384d94c
Author: Toby Inkster <m...@tobyinkster.co.uk>
Date: Thu Apr 10 12:02:33 2014 +0100
my_methods stuff
---
lib/Type/Tiny.pm | 57 +++++++++++++++++++++++++++++++++++----
lib/Type/Tiny/Manual/Policies.pod | 5 ++++
t/20-unit/Type-Tiny/my-methods.t | 39 +++++++++++++++++++++++++++
3 files changed, 96 insertions(+), 5 deletions(-)
diff --git a/lib/Type/Tiny.pm b/lib/Type/Tiny.pm
index 2092a63..64d6efa 100644
--- a/lib/Type/Tiny.pm
+++ b/lib/Type/Tiny.pm
@@ -254,6 +254,7 @@ sub parameters { $_[0]{parameters} }
sub moose_type { $_[0]{moose_type} ||=
$_[0]->_build_moose_type }
sub mouse_type { $_[0]{mouse_type} ||=
$_[0]->_build_mouse_type }
sub deep_explanation { $_[0]{deep_explanation} }
+sub my_methods { $_[0]{my_methods} ||=
$_[0]->_build_my_methods }
sub has_parent { exists $_[0]{parent} }
sub has_library { exists $_[0]{library} }
@@ -977,10 +978,33 @@ sub isa
{
return !!1;
}
-
+
$self->SUPER::isa(@_);
}
+sub _build_my_methods
+{
+ return {};
+}
+
+sub _lookup_my_method
+{
+ my $self = shift;
+ my ($name) = @_;
+
+ if ($self->my_methods->{$name})
+ {
+ return $self->my_methods->{$name};
+ }
+
+ if ($self->has_parent)
+ {
+ return $self->parent->_lookup_my_method(@_);
+ }
+
+ return;
+}
+
sub can
{
my $self = shift;
@@ -990,9 +1014,18 @@ sub can
my $can = $self->SUPER::can(@_);
return $can if $can;
- if ($INC{"Moose.pm"} and ref($self) and my $method =
$self->moose_type->can(@_))
+ if (ref($self))
{
- return sub { $method->(shift->moose_type, @_) };
+ if ($INC{"Moose.pm"})
+ {
+ my $method = $self->moose_type->can(@_);
+ return sub { shift->moose_type->$method(@_) };
+ }
+ if ($_[0] =~ /\Amy_(.+)\z/)
+ {
+ my $method = $self->_lookup_my_method($1);
+ return $method if $method;
+ }
}
return;
@@ -1004,9 +1037,18 @@ sub AUTOLOAD
my ($m) = (our $AUTOLOAD =~ /::(\w+)$/);
return if $m eq 'DESTROY';
- if ($INC{"Moose.pm"} and ref($self) and my $method =
$self->moose_type->can($m))
+ if (ref($self))
{
- return $method->($self->moose_type, @_);
+ if ($INC{"Moose.pm"})
+ {
+ my $method = $self->moose_type->can($m);
+ return $self->moose_type->$method(@_) if $method;
+ }
+ if ($m =~ /\Amy_(.+)\z/)
+ {
+ my $method = $self->_lookup_my_method($1);
+ return $self->$method(@_) if $method;
+ }
}
_croak q[Can't locate object method "%s" via package "%s"], $m,
ref($self)||$self;
@@ -1187,6 +1229,11 @@ You may pass C<< coercion => 1 >> to the constructor to
inherit coercions
from the constraint's parent. (This requires the parent constraint to have
a coercion.)
+=item C<< my_methods >>
+
+Experimenal hashref of additional methods that can be called on the type
+constraint object.
+
=back
=head3 Attributes related to parameterizable and parameterized types
diff --git a/lib/Type/Tiny/Manual/Policies.pod
b/lib/Type/Tiny/Manual/Policies.pod
index e995308..4fbc3d3 100644
--- a/lib/Type/Tiny/Manual/Policies.pod
+++ b/lib/Type/Tiny/Manual/Policies.pod
@@ -54,6 +54,11 @@ This is experimental. See L<Type::Utils>.
=item *
+L<Type::Tiny>'s C<my_methods> attribute and the functionality it
+provides is experimental.
+
+=item *
+
The L<parameterizable coercion API|Type::Coercion> is subject to change.
=item *
diff --git a/t/20-unit/Type-Tiny/my-methods.t b/t/20-unit/Type-Tiny/my-methods.t
new file mode 100644
index 0000000..ce233ca
--- /dev/null
+++ b/t/20-unit/Type-Tiny/my-methods.t
@@ -0,0 +1,39 @@
+=pod
+
+=encoding utf-8
+
+=head1 PURPOSE
+
+Checks Type::Tiny's C<my_methods> attribute.
+
+=head1 AUTHOR
+
+Toby Inkster E<lt>toby...@cpan.orge<gt>.
+
+=head1 COPYRIGHT AND LICENCE
+
+This software is copyright (c) 2014 by Toby Inkster.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
+
+use strict;
+use warnings;
+use lib qw( ./lib ./t/lib ../inc ./inc );
+use Test::More;
+
+use Types::Standard qw(Num);
+
+my $type = Num->create_child_type(
+ name => 'Number',
+ my_methods => { round_off => sub { int($_[1]) } }
+);
+
+my $type2 = $type->create_child_type(name => 'Number2');
+
+can_ok($_, 'my_round_off') for $type, $type2;
+is($_->my_round_off(42.3), 42, "$_ my_round_off works") for $type, $type2;
+
+done_testing;
--
Alioth's /usr/local/bin/git-commit-notice on
/srv/git.debian.org/git/pkg-perl/packages/libtype-tiny-perl.git
_______________________________________________
Pkg-perl-cvs-commits mailing list
Pkg-perl-cvs-commits@lists.alioth.debian.org
http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits
