From afaa68659e6ab1a6a820d28ba4fe00afdb8d6f30 Mon Sep 17 00:00:00 2001
From: Michael G. Schwern <schwern@pobox.com>
Date: Wed, 28 Oct 2009 18:08:44 -0700
Subject: [PATCH] Implement ScalarRef[...]
---
lib/Moose/Util/TypeConstraints.pm | 23 ++++++++--
t/paramatized_scalarref.t | 88 +++++++++++++++++++++++++++++++++++++
2 files changed, 107 insertions(+), 4 deletions(-)
create mode 100644 t/paramatized_scalarref.t
diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm
index 8384d40..e8d67fb 100644
--- a/lib/Moose/Util/TypeConstraints.pm
+++ b/lib/Moose/Util/TypeConstraints.pm
@@ -672,9 +672,6 @@ subtype 'Num' => as 'Str' =>
subtype 'Int' => as 'Num' => where { "$_" =~ /^-?[0-9]+$/ } =>
optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Int;
-subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' || ref($_) eq 'REF' } =>
- optimize_as
- \&Moose::Util::TypeConstraints::OptimizedConstraints::ScalarRef;
subtype 'CodeRef' => as 'Ref' => where { ref($_) eq 'CODE' } =>
optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::CodeRef;
subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' } =>
@@ -717,6 +714,24 @@ subtype 'RoleName' => as 'ClassName' => where {
$REGISTRY->add_type_constraint(
Moose::Meta::TypeConstraint::Parameterizable->new(
+ name => 'ScalarRef',
+ package_defined_in => __PACKAGE__,
+ parent => find_type_constraint('Ref'),
+ constraint => sub { ref($_) eq 'SCALAR' || ref($_) eq 'REF' },
+ optimized =>
+ \&Moose::Util::TypeConstraints::OptimizedConstraints::ScalarRef,
+ constraint_generator => sub {
+ my $type_parameter = shift;
+ my $check = $type_parameter->_compiled_type_constraint;
+ return sub {
+ return $check->($$_);
+ };
+ }
+ )
+);
+
+$REGISTRY->add_type_constraint(
+ Moose::Meta::TypeConstraint::Parameterizable->new(
name => 'ArrayRef',
package_defined_in => __PACKAGE__,
parent => find_type_constraint('Ref'),
@@ -775,7 +790,7 @@ $REGISTRY->add_type_constraint(
);
my @PARAMETERIZABLE_TYPES
- = map { $REGISTRY->get_type_constraint($_) } qw[ArrayRef HashRef Maybe];
+ = map { $REGISTRY->get_type_constraint($_) } qw[ScalarRef ArrayRef HashRef Maybe];
sub get_all_parameterizable_types {@PARAMETERIZABLE_TYPES}
diff --git a/t/paramatized_scalarref.t b/t/paramatized_scalarref.t
new file mode 100644
index 0000000..f1c5c40
--- /dev/null
+++ b/t/paramatized_scalarref.t
@@ -0,0 +1,88 @@
+#!/usr/bin/perl -w
+
+use strict;
+use warnings;
+
+use Test::More tests => 16;
+use Test::Exception;
+
+{
+ package Foo;
+ use Moose;
+
+ ::lives_ok {
+ has intref =>
+ is => 'rw',
+ isa => 'ScalarRef[Int]',
+ ;
+ } "isa ScalarRef[Int]";
+
+ ::lives_ok {
+ has nested =>
+ is => 'rw',
+ isa => 'ScalarRef[ScalarRef]',
+ ;
+ } "isa ScalarRef[ScalarRef]";
+}
+
+# Test ScalarRef[Int]
+{
+ my $obj = Foo->new;
+ isa_ok $obj, "Foo";
+
+ lives_ok {
+ $obj->intref(\42);
+ } "ref to int";
+
+ dies_ok {
+ $obj->intref(42);
+ } "plain int";
+
+ dies_ok {
+ $obj->intref(\"blah");
+ } "ref to string";
+
+ dies_ok {
+ $obj->intref(["42"]);
+ } "ref to array";
+
+ dies_ok {
+ my $thing;
+ $obj->intref(\$thing);
+ } "ref to undef";
+
+ {
+ my $thing = 42;
+ $obj->intref(\$thing);
+ is $obj->intref, \$thing, "reference preserved";
+ is ${$obj->intref}, $thing, "value preserved";
+ }
+}
+
+# Test ScalarRef[ScalarRef]
+{
+ my $obj = Foo->new;
+
+ my $inner = "wibble";
+ my $outer = \$inner;
+
+ lives_ok {
+ $obj->nested(\$outer);
+ } "nested scalar ref";
+
+ dies_ok {
+ $obj->nested(\$inner);
+ } "single layer scalar ref";
+
+ my $thing = [];
+ dies_ok {
+ $obj->nested(\$thing);
+ } "wrong inner ref";
+
+ {
+ $obj->nested(\$outer);
+ is $obj->nested, \$outer, "outer ref preserved";
+ is ${$obj->nested}, $outer, "inner ref preserved";
+ is ${${$obj->nested}}, $inner, "value preserved";
+ }
+}
--
1.6.5
