From: Stevan Little Date: Sat, 11 Mar 2006 17:10:03 +0000 (+0000) Subject: MOOOOOOOOOOOOOOOOOOOOOOSSSSEE X-Git-Tag: 0_05~106 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a15dff8d91efac7a8b88111afb27f284714018d1;p=gitmo%2FMoose.git MOOOOOOOOOOOOOOOOOOOOOOSSSSEE --- diff --git a/Build.PL b/Build.PL index 1a4116b..d2ad178 100644 --- a/Build.PL +++ b/Build.PL @@ -9,6 +9,7 @@ my $build = Module::Build->new( 'Scalar::Util' => '1.18', 'Carp' => '0.01', 'Class::MOP' => '0.20', + 'Sub::Name' => '0.02', }, optional => { }, diff --git a/lib/Moose.pm b/lib/Moose.pm index b70436a..48dddc8 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -17,10 +17,14 @@ use Moose::Meta::Attribute; use Moose::Object; +require Moose::Util::TypeConstraints; + sub import { shift; my $pkg = caller(); + Moose::Util::TypeConstraints->import($pkg); + my $meta; if ($pkg->can('meta')) { $meta = $pkg->meta(); @@ -78,34 +82,6 @@ __END__ Moose - =head1 SYNOPSIS - - package Point; - use strict; - use warnings; - use Moose; - - has '$.x' => (reader => 'x'); - has '$.y' => (accessor => 'y'); - - sub clear { - my $self = shift; - $self->{'$.x'} = 0; - $self->y(0); - } - - package Point3D; - use strict; - use warnings; - use Moose; - - extends 'Point'; - - has '$:z'; - - after 'clear' => sub { - my $self = shift; - $self->{'$:z'} = 0; - }; =head1 DESCRIPTION diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index 0d4f30b..f79b99b 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -4,20 +4,116 @@ package Moose::Meta::Attribute; use strict; use warnings; +use Scalar::Util 'weaken', 'reftype'; +use Carp 'confess'; + +use Moose::Util::TypeConstraints ':no_export'; + our $VERSION = '0.01'; use base 'Class::MOP::Attribute'; -Moose::Meta::Attribute->meta->add_around_method_modifier('new' => sub { - my $cont = shift; - my ($class, $attribute_name, %options) = @_; - - # extract the init_arg - my ($init_arg) = ($attribute_name =~ /^[\$\@\%][\.\:](.*)$/); - - $cont->($class, $attribute_name, (init_arg => $init_arg, %options)); +Moose::Meta::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('weak_ref' => ( + reader => 'weak_ref', + predicate => { + 'has_weak_ref' => sub { $_[0]->weak_ref() ? 1 : 0 } + } + )) +); + +Moose::Meta::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('type_constraint' => ( + reader => 'type_constraint', + predicate => 'has_type_constraint', + )) +); + +Moose::Meta::Attribute->meta->add_before_method_modifier('new' => sub { + my (undef, undef, %options) = @_; + (reftype($options{type_constraint}) && reftype($options{type_constraint}) eq 'CODE') + || confess "Type cosntraint parameter must be a code-ref"; }); +sub generate_accessor_method { + my ($self, $attr_name) = @_; + if ($self->has_type_constraint) { + if ($self->has_weak_ref) { + return sub { + if (scalar(@_) == 2) { + (defined $self->type_constraint->($_[1])) + || confess "Attribute ($attr_name) does not pass the type contraint" + if defined $_[1]; + $_[0]->{$attr_name} = $_[1]; + weaken($_[0]->{$attr_name}); + } + $_[0]->{$attr_name}; + }; + } + else { + return sub { + if (scalar(@_) == 2) { + (defined $self->type_constraint->($_[1])) + || confess "Attribute ($attr_name) does not pass the type contraint" + if defined $_[1]; + $_[0]->{$attr_name} = $_[1]; + } + $_[0]->{$attr_name}; + }; + } + } + else { + if ($self->has_weak_ref) { + return sub { + if (scalar(@_) == 2) { + $_[0]->{$attr_name} = $_[1]; + weaken($_[0]->{$attr_name}); + } + $_[0]->{$attr_name}; + }; + } + else { + sub { + $_[0]->{$attr_name} = $_[1] if scalar(@_) == 2; + $_[0]->{$attr_name}; + }; + } + } +} + +sub generate_writer_method { + my ($self, $attr_name) = @_; + if ($self->has_type_constraint) { + if ($self->has_weak_ref) { + return sub { + (defined $self->type_constraint->($_[1])) + || confess "Attribute ($attr_name) does not pass the type contraint" + if defined $_[1]; + $_[0]->{$attr_name} = $_[1]; + weaken($_[0]->{$attr_name}); + }; + } + else { + return sub { + (defined $self->type_constraint->($_[1])) + || confess "Attribute ($attr_name) does not pass the type contraint" + if defined $_[1]; + $_[0]->{$attr_name} = $_[1]; + }; + } + } + else { + if ($self->has_weak_ref) { + return sub { + $_[0]->{$attr_name} = $_[1]; + weaken($_[0]->{$attr_name}); + }; + } + else { + return sub { $_[0]->{$attr_name} = $_[1] }; + } + } +} 1; @@ -39,6 +135,22 @@ Moose::Meta::Attribute - =item B +=item B + +=item B + +=back + +=over 4 + +=item B + +=item B + +=item B + +=item B + =back =head1 BUGS diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index 058b9ed..81c0740 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -4,10 +4,32 @@ package Moose::Meta::Class; use strict; use warnings; +use Carp 'confess'; + our $VERSION = '0.01'; use base 'Class::MOP::Class'; +sub construct_instance { + my ($class, %params) = @_; + my $instance = {}; + foreach my $attr ($class->compute_all_applicable_attributes()) { + my $init_arg = $attr->init_arg(); + # try to fetch the init arg from the %params ... + my $val; + $val = $params{$init_arg} if exists $params{$init_arg}; + # if nothing was in the %params, we can use the + # attribute's default value (if it has one) + $val ||= $attr->default($instance) if $attr->has_default; + if (defined $val && $attr->has_type_constraint) { + (defined $attr->type_constraint->($val)) + || confess "Attribute (" . $attr->name . ") does not pass the type contraint"; + } + $instance->{$attr->name} = $val; + } + return $instance; +} + 1; __END__ @@ -26,6 +48,8 @@ Moose::Meta::Class - =over 4 +=item B + =back =head1 BUGS diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm new file mode 100644 index 0000000..e973f23 --- /dev/null +++ b/lib/Moose/Util/TypeConstraints.pm @@ -0,0 +1,198 @@ + +package Moose::Util::TypeConstraints; + +use strict; +use warnings; + +use Sub::Name 'subname'; +use Scalar::Util 'blessed'; + +our $VERSION = '0.01'; + +sub import { + shift; + my $pkg = shift || caller(); + return if $pkg eq ':no_export'; + no strict 'refs'; + foreach my $export (qw( + type subtype as where + )) { + *{"${pkg}::${export}"} = \&{"${export}"}; + } + + foreach my $constraint (qw( + Any + Value Ref + Str Int + ScalarRef ArrayRef HashRef CodeRef RegexpRef + Object + )) { + *{"${pkg}::${constraint}"} = \&{"${constraint}"}; + } + +} + +my %TYPES; + +# might need this later +#sub find_type_constraint { $TYPES{$_[0]} } + +sub type ($$) { + my ($name, $check) = @_; + my $pkg = caller(); + my $full_name = "${pkg}::${name}"; + no strict 'refs'; + *{$full_name} = $TYPES{$name} = subname $full_name => sub { + return $TYPES{$name} unless defined $_[0]; + local $_ = $_[0]; + return undef unless $check->($_[0]); + $_[0]; + }; +} + +sub subtype ($$;$) { + my ($name, $parent, $check) = @_; + if (defined $check) { + my $pkg = caller(); + my $full_name = "${pkg}::${name}"; + no strict 'refs'; + $parent = $TYPES{$parent} unless $parent && ref($parent) eq 'CODE'; + *{$full_name} = $TYPES{$name} = subname $full_name => sub { + return $TYPES{$name} unless defined $_[0]; + local $_ = $_[0]; + return undef unless defined $parent->($_[0]) && $check->($_[0]); + $_[0]; + }; + } + else { + ($parent, $check) = ($name, $parent); + $parent = $TYPES{$parent} unless $parent && ref($parent) eq 'CODE'; + return subname((caller() . '::__anon_subtype__') => sub { + return $TYPES{$name} unless defined $_[0]; + local $_ = $_[0]; + return undef unless defined $parent->($_[0]) && $check->($_[0]); + $_[0]; + }); + } +} + +sub as ($) { $_[0] } +sub where (&) { $_[0] } + +# define some basic types + +type Any => where { 1 }; + +type Value => where { !ref($_) }; +type Ref => where { ref($_) }; + +subtype Int => as Value => where { Scalar::Util::looks_like_number($_) }; +subtype Str => as Value => where { !Scalar::Util::looks_like_number($_) }; + +subtype ScalarRef => as Ref => where { ref($_) eq 'SCALAR' }; +subtype ArrayRef => as Ref => where { ref($_) eq 'ARRAY' }; +subtype HashRef => as Ref => where { ref($_) eq 'HASH' }; +subtype CodeRef => as Ref => where { ref($_) eq 'CODE' }; +subtype RegexpRef => as Ref => where { ref($_) eq 'Regexp' }; + +# NOTE: +# blessed(qr/.../) returns true,.. how odd +subtype Object => as Ref => where { blessed($_) && blessed($_) ne 'Regexp' }; + +1; + +__END__ + +=pod + +=head1 NAME + +Moose::Util::TypeConstraints - + +=head1 SYNOPSIS + + use Moose::Util::TypeConstraints; + + type Num => where { Scalar::Util::looks_like_number($_) }; + + subtype Natural + => as Num + => where { $_ > 0 }; + + subtype NaturalLessThanTen + => as Natural + => where { $_ < 10 }; + +=head1 DESCRIPTION + +=head1 FUNCTIONS + +=head2 Type Constraint Constructors + +=over 4 + +=item B + +=item B + +=item B + +=item B + +=back + +=head2 Built-in Type Constraints + +=over 4 + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=back + +=head1 BUGS + +All complex software has bugs lurking in it, and this module is no +exception. If you find a bug please either email me, or add the bug +to cpan-RT. + +=head1 CODE COVERAGE + +I use L to test the code coverage of my tests, below is the +L report on this module's test suite. + +=head1 ACKNOWLEDGEMENTS + +=head1 AUTHOR + +Stevan Little Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut \ No newline at end of file diff --git a/t/001_basic.t b/t/001_basic.t index 2d072a2..21ec499 100644 --- a/t/001_basic.t +++ b/t/001_basic.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 32; +use Test::More tests => 41; use Test::Exception; BEGIN { @@ -16,12 +16,19 @@ BEGIN { use warnings; use Moose; - has '$.x' => (reader => 'x'); - has '$.y' => (accessor => 'y'); + has 'x' => ( + reader => 'x', + type_constraint => Int(), + ); + + has 'y' => ( + accessor => 'y', + type_constraint => Int(), + ); sub clear { my $self = shift; - $self->{'$.x'} = 0; + $self->{x} = 0; $self->y(0); } @@ -32,11 +39,11 @@ BEGIN { extends 'Point'; - has '$:z'; + has 'z' => (type_constraint => Int()); after 'clear' => sub { my $self = shift; - $self->{'$:z'} = 0; + $self->{z} = 0; }; } @@ -51,6 +58,10 @@ is($point->y, 2, '... got the right value for y'); $point->y(10); is($point->y, 10, '... got the right (changed) value for y'); +dies_ok { + $point->y('Foo'); +} '... cannot assign a non-Int to y'; + $point->x(1000); is($point->x, 1, '... got the right (un-changed) value for x'); @@ -59,6 +70,22 @@ $point->clear(); is($point->x, 0, '... got the right (cleared) value for x'); is($point->y, 0, '... got the right (cleared) value for y'); +# check the type constraints on the constructor + +lives_ok { + Point->new(x => 0, y => 0); +} '... can assign a 0 to x and y'; + +dies_ok { + Point->new(x => 10, y => 'Foo'); +} '... cannot assign a non-Int to y'; + +dies_ok { + Point->new(x => 'Foo', y => 10); +} '... cannot assign a non-Int to x'; + +# Point3D + my $point3d = Point3D->new(x => 10, y => 15, z => 3); isa_ok($point3d, 'Point3D'); isa_ok($point3d, 'Point'); @@ -66,7 +93,7 @@ isa_ok($point3d, 'Moose::Object'); is($point3d->x, 10, '... got the right value for x'); is($point3d->y, 15, '... got the right value for y'); -is($point3d->{'$:z'}, 3, '... got the right value for z'); +is($point3d->{'z'}, 3, '... got the right value for z'); dies_ok { $point3d->z; @@ -76,7 +103,19 @@ $point3d->clear(); is($point3d->x, 0, '... got the right (cleared) value for x'); is($point3d->y, 0, '... got the right (cleared) value for y'); -is($point3d->{'$:z'}, 0, '... got the right (cleared) value for z'); +is($point3d->{'z'}, 0, '... got the right (cleared) value for z'); + +dies_ok { + Point3D->new(x => 10, y => 'Foo', z => 3); +} '... cannot assign a non-Int to y'; + +dies_ok { + Point3D->new(x => 'Foo', y => 10, z => 3); +} '... cannot assign a non-Int to x'; + +dies_ok { + Point3D->new(x => 0, y => 10, z => 'Bar'); +} '... cannot assign a non-Int to z'; # test some class introspection @@ -96,11 +135,17 @@ is_deeply( '... Point got the automagic base class'); my @Point_methods = qw(x y clear); +my @Point_attrs = ('x', 'y'); is_deeply( [ sort @Point_methods ], [ sort Point->meta->get_method_list() ], '... we match the method list for Point'); + +is_deeply( + [ sort @Point_attrs ], + [ sort Point->meta->get_attribute_list() ], + '... we match the attribute list for Point'); foreach my $method (@Point_methods) { ok(Point->meta->has_method($method), '... Point has the method "' . $method . '"'); @@ -114,14 +159,18 @@ is_deeply( '... Point3D gets the parent given to it'); my @Point3D_methods = qw(clear); +my @Point3D_attrs = ('z'); is_deeply( [ sort @Point3D_methods ], [ sort Point3D->meta->get_method_list() ], '... we match the method list for Point3D'); + +is_deeply( + [ sort @Point3D_attrs ], + [ sort Point3D->meta->get_attribute_list() ], + '... we match the attribute list for Point3D'); foreach my $method (@Point3D_methods) { ok(Point3D->meta->has_method($method), '... Point3D has the method "' . $method . '"'); } - - diff --git a/t/002_basic.t b/t/002_basic.t index e5e772f..2b376a6 100644 --- a/t/002_basic.t +++ b/t/002_basic.t @@ -16,7 +16,11 @@ BEGIN { use warnings; use Moose; - has '$.balance' => (accessor => 'balance', default => 0); + has 'balance' => ( + accessor => 'balance', + default => 0, + type_constraint => Int(), + ); sub deposit { my ($self, $amount) = @_; @@ -38,7 +42,10 @@ BEGIN { extends 'BankAccount'; - has '$.overdraft_account' => (accessor => 'overdraft_account'); + has 'overdraft_account' => ( + accessor => 'overdraft_account', + type_constraint => subtype Object => where { $_->isa('BankAccount') }, + ); before 'withdraw' => sub { my ($self, $amount) = @_; diff --git a/t/003_basic.t b/t/003_basic.t index 527cb8d..df9c72c 100644 --- a/t/003_basic.t +++ b/t/003_basic.t @@ -3,9 +3,11 @@ use strict; use warnings; -use Test::More tests => 18; +use Test::More tests => 21; use Test::Exception; +use Scalar::Util 'isweak'; + BEGIN { use_ok('Moose'); } @@ -16,19 +18,23 @@ BEGIN { use warnings; use Moose; - has '$.parent' => ( - predicate => 'has_parent', - accessor => 'parent' + has 'parent' => ( + predicate => 'has_parent', + accessor => 'parent', + weak_ref => 1, + type_constraint => subtype Object => where { $_->isa('BinaryTree') }, ); - has '$.left' => ( - predicate => 'has_left', - accessor => 'left', + has 'left' => ( + predicate => 'has_left', + accessor => 'left', + type_constraint => subtype Object => where { $_->isa('BinaryTree') }, ); - has '$.right' => ( - predicate => 'has_right', - accessor => 'right', + has 'right' => ( + predicate => 'has_right', + accessor => 'right', + type_constraint => subtype Object => where { $_->isa('BinaryTree') }, ); before 'right', 'left' => sub { @@ -46,6 +52,8 @@ is($root->right, undef, '... no right node yet'); ok(!$root->has_left, '... no left node yet'); ok(!$root->has_right, '... no right node yet'); +ok(!$root->has_parent, '... no parent for root node'); + my $left = BinaryTree->new(); isa_ok($left, 'BinaryTree'); @@ -59,6 +67,8 @@ ok($root->has_left, '... we have a left node now'); ok($left->has_parent, '... lefts has a parent'); is($left->parent, $root, '... lefts parent is the root'); +ok(isweak($left->{parent}), '... parent is a weakened ref'); + my $right = BinaryTree->new(); isa_ok($right, 'BinaryTree'); @@ -71,3 +81,5 @@ ok($root->has_right, '... we have a right node now'); ok($right->has_parent, '... rights has a parent'); is($right->parent, $root, '... rights parent is the root'); + +ok(isweak($right->{parent}), '... parent is a weakened ref'); diff --git a/t/010_basic_class_setup.t b/t/010_basic_class_setup.t index af03108..e5fe63d 100644 --- a/t/010_basic_class_setup.t +++ b/t/010_basic_class_setup.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 12; +use Test::More tests => 16; use Test::Exception; BEGIN { @@ -26,6 +26,7 @@ foreach my $function (qw( has before after around blessed confess + type subtype as where )) { ok(!Foo->meta->has_method($function), '... the meta does not treat "' . $function . '" as a method'); } diff --git a/t/050_util_type_constraints.t b/t/050_util_type_constraints.t new file mode 100644 index 0000000..c9d6529 --- /dev/null +++ b/t/050_util_type_constraints.t @@ -0,0 +1,59 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 22; +use Test::Exception; + +use Scalar::Util (); + +BEGIN { + use_ok('Moose::Util::TypeConstraints'); +} + +type Num => where { Scalar::Util::looks_like_number($_) }; +type String => where { !ref($_) && !Num($_) }; + +subtype Natural + => as Num + => where { $_ > 0 }; + +subtype NaturalLessThanTen + => as Natural + => where { $_ < 10 }; + +is(Num(5), 5, '... this is a Num'); +ok(!defined(Num('Foo')), '... this is not a Num'); + +is(&Num, &Num, '... the type w/out arguments just returns itself'); +is(Num(), Num(), '... the type w/out arguments just returns itself'); + +is(String('Foo'), 'Foo', '... this is a Str'); +ok(!defined(String(5)), '... this is not a Str'); + +is(&String, &String, '... the type w/out arguments just returns itself'); + +is(Natural(5), 5, '... this is a Natural'); +is(Natural(-5), undef, '... this is not a Natural'); +is(Natural('Foo'), undef, '... this is not a Natural'); + +is(&Natural, &Natural, '... the type w/out arguments just returns itself'); + +is(NaturalLessThanTen(5), 5, '... this is a NaturalLessThanTen'); +is(NaturalLessThanTen(12), undef, '... this is not a NaturalLessThanTen'); +is(NaturalLessThanTen(-5), undef, '... this is not a NaturalLessThanTen'); +is(NaturalLessThanTen('Foo'), undef, '... this is not a NaturalLessThanTen'); + +is(&NaturalLessThanTen, &NaturalLessThanTen, + '... the type w/out arguments just returns itself'); + +# anon sub-typing + +my $negative = subtype Num => where { $_ < 0 }; +ok(defined $negative, '... got a value back from negative'); +is(ref($negative), 'CODE', '... got a type constraint back from negative'); + +is($negative->(-5), -5, '... this is a negative number'); +ok(!defined($negative->(5)), '... this is not a negative number'); +is($negative->('Foo'), undef, '... this is not a negative number'); diff --git a/t/051_util_type_constraints_export.t b/t/051_util_type_constraints_export.t new file mode 100644 index 0000000..b970a94 --- /dev/null +++ b/t/051_util_type_constraints_export.t @@ -0,0 +1,30 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 5; +use Test::Exception; + +BEGIN { + use_ok('Moose::Util::TypeConstraints', ('Foo')); +} + +{ + package Foo; + + eval { + type MyRef => where { ref($_) }; + }; + ::ok(!$@, '... successfully exported &type to Foo package'); + + eval { + subtype MyArrayRef + => as MyRef + => where { ref($_) eq 'ARRAY' }; + }; + ::ok(!$@, '... successfully exported &subtype to Foo package'); + + ::ok(MyRef({}), '... Ref worked correctly'); + ::ok(MyArrayRef([]), '... ArrayRef worked correctly'); +} \ No newline at end of file diff --git a/t/052_util_std_type_constraints.t b/t/052_util_std_type_constraints.t new file mode 100644 index 0000000..843c891 --- /dev/null +++ b/t/052_util_std_type_constraints.t @@ -0,0 +1,136 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 111; +use Test::Exception; + +use Scalar::Util (); + +BEGIN { + use_ok('Moose::Util::TypeConstraints'); +} + +my $SCALAR_REF = \(my $var); + +ok(defined Any(0), '... Any accepts anything'); +ok(defined Any(100), '... Any accepts anything'); +ok(defined Any(''), '... Any accepts anything'); +ok(defined Any('Foo'), '... Any accepts anything'); +ok(defined Any([]), '... Any accepts anything'); +ok(defined Any({}), '... Any accepts anything'); +ok(defined Any(sub {}), '... Any accepts anything'); +ok(defined Any($SCALAR_REF), '... Any accepts anything'); +ok(defined Any(qr/../), '... Any accepts anything'); +ok(defined Any(bless {}, 'Foo'), '... Any accepts anything'); + +ok(defined Value(0), '... Value accepts anything which is not a Ref'); +ok(defined Value(100), '... Value accepts anything which is not a Ref'); +ok(defined Value(''), '... Value accepts anything which is not a Ref'); +ok(defined Value('Foo'), '... Value accepts anything which is not a Ref'); +ok(!defined Value([]), '... Value rejects anything which is not a Value'); +ok(!defined Value({}), '... Value rejects anything which is not a Value'); +ok(!defined Value(sub {}), '... Value rejects anything which is not a Value'); +ok(!defined Value($SCALAR_REF), '... Value rejects anything which is not a Value'); +ok(!defined Value(qr/../), '... Value rejects anything which is not a Value'); +ok(!defined Value(bless {}, 'Foo'), '... Value rejects anything which is not a Value'); + +ok(!defined Ref(0), '... Ref accepts anything which is not a Value'); +ok(!defined Ref(100), '... Ref accepts anything which is not a Value'); +ok(!defined Ref(''), '... Ref accepts anything which is not a Value'); +ok(!defined Ref('Foo'), '... Ref accepts anything which is not a Value'); +ok(defined Ref([]), '... Ref rejects anything which is not a Ref'); +ok(defined Ref({}), '... Ref rejects anything which is not a Ref'); +ok(defined Ref(sub {}), '... Ref rejects anything which is not a Ref'); +ok(defined Ref($SCALAR_REF), '... Ref rejects anything which is not a Ref'); +ok(defined Ref(qr/../), '... Ref rejects anything which is not a Ref'); +ok(defined Ref(bless {}, 'Foo'), '... Ref rejects anything which is not a Ref'); + +ok(defined Int(0), '... Int accepts anything which is an Int'); +ok(defined Int(100), '... Int accepts anything which is an Int'); +ok(!defined Int(''), '... Int rejects anything which is not a Int'); +ok(!defined Int('Foo'), '... Int rejects anything which is not a Int'); +ok(!defined Int([]), '... Int rejects anything which is not a Int'); +ok(!defined Int({}), '... Int rejects anything which is not a Int'); +ok(!defined Int(sub {}), '... Int rejects anything which is not a Int'); +ok(!defined Int($SCALAR_REF), '... Int rejects anything which is not a Int'); +ok(!defined Int(qr/../), '... Int rejects anything which is not a Int'); +ok(!defined Int(bless {}, 'Foo'), '... Int rejects anything which is not a Int'); + +ok(!defined Str(0), '... Str rejects anything which is not a Str'); +ok(!defined Str(100), '... Str rejects anything which is not a Str'); +ok(defined Str(''), '... Str accepts anything which is a Str'); +ok(defined Str('Foo'), '... Str accepts anything which is a Str'); +ok(!defined Str([]), '... Str rejects anything which is not a Str'); +ok(!defined Str({}), '... Str rejects anything which is not a Str'); +ok(!defined Str(sub {}), '... Str rejects anything which is not a Str'); +ok(!defined Str($SCALAR_REF), '... Str rejects anything which is not a Str'); +ok(!defined Str(qr/../), '... Str rejects anything which is not a Str'); +ok(!defined Str(bless {}, 'Foo'), '... Str rejects anything which is not a Str'); + +ok(!defined ScalarRef(0), '... ScalarRef rejects anything which is not a ScalarRef'); +ok(!defined ScalarRef(100), '... ScalarRef rejects anything which is not a ScalarRef'); +ok(!defined ScalarRef(''), '... ScalarRef rejects anything which is not a ScalarRef'); +ok(!defined ScalarRef('Foo'), '... ScalarRef rejects anything which is not a ScalarRef'); +ok(!defined ScalarRef([]), '... ScalarRef rejects anything which is not a ScalarRef'); +ok(!defined ScalarRef({}), '... ScalarRef rejects anything which is not a ScalarRef'); +ok(!defined ScalarRef(sub {}), '... ScalarRef rejects anything which is not a ScalarRef'); +ok(defined ScalarRef($SCALAR_REF), '... ScalarRef accepts anything which is a ScalarRef'); +ok(!defined ScalarRef(qr/../), '... ScalarRef rejects anything which is not a ScalarRef'); +ok(!defined ScalarRef(bless {}, 'Foo'), '... ScalarRef rejects anything which is not a ScalarRef'); + +ok(!defined ArrayRef(0), '... ArrayRef rejects anything which is not a ArrayRef'); +ok(!defined ArrayRef(100), '... ArrayRef rejects anything which is not a ArrayRef'); +ok(!defined ArrayRef(''), '... ArrayRef rejects anything which is not a ArrayRef'); +ok(!defined ArrayRef('Foo'), '... ArrayRef rejects anything which is not a ArrayRef'); +ok(defined ArrayRef([]), '... ArrayRef accepts anything which is a ArrayRef'); +ok(!defined ArrayRef({}), '... ArrayRef rejects anything which is not a ArrayRef'); +ok(!defined ArrayRef(sub {}), '... ArrayRef rejects anything which is not a ArrayRef'); +ok(!defined ArrayRef($SCALAR_REF), '... ArrayRef rejects anything which is not a ArrayRef'); +ok(!defined ArrayRef(qr/../), '... ArrayRef rejects anything which is not a ArrayRef'); +ok(!defined ArrayRef(bless {}, 'Foo'), '... ArrayRef rejects anything which is not a ArrayRef'); + +ok(!defined HashRef(0), '... HashRef rejects anything which is not a HashRef'); +ok(!defined HashRef(100), '... HashRef rejects anything which is not a HashRef'); +ok(!defined HashRef(''), '... HashRef rejects anything which is not a HashRef'); +ok(!defined HashRef('Foo'), '... HashRef rejects anything which is not a HashRef'); +ok(!defined HashRef([]), '... HashRef rejects anything which is not a HashRef'); +ok(defined HashRef({}), '... HashRef accepts anything which is a HashRef'); +ok(!defined HashRef(sub {}), '... HashRef rejects anything which is not a HashRef'); +ok(!defined HashRef($SCALAR_REF), '... HashRef rejects anything which is not a HashRef'); +ok(!defined HashRef(qr/../), '... HashRef rejects anything which is not a HashRef'); +ok(!defined HashRef(bless {}, 'Foo'), '... HashRef rejects anything which is not a HashRef'); + +ok(!defined CodeRef(0), '... CodeRef rejects anything which is not a CodeRef'); +ok(!defined CodeRef(100), '... CodeRef rejects anything which is not a CodeRef'); +ok(!defined CodeRef(''), '... CodeRef rejects anything which is not a CodeRef'); +ok(!defined CodeRef('Foo'), '... CodeRef rejects anything which is not a CodeRef'); +ok(!defined CodeRef([]), '... CodeRef rejects anything which is not a CodeRef'); +ok(!defined CodeRef({}), '... CodeRef rejects anything which is not a CodeRef'); +ok(defined CodeRef(sub {}), '... CodeRef accepts anything which is a CodeRef'); +ok(!defined CodeRef($SCALAR_REF), '... CodeRef rejects anything which is not a CodeRef'); +ok(!defined CodeRef(qr/../), '... CodeRef rejects anything which is not a CodeRef'); +ok(!defined CodeRef(bless {}, 'Foo'), '... CodeRef rejects anything which is not a CodeRef'); + +ok(!defined RegexpRef(0), '... RegexpRef rejects anything which is not a RegexpRef'); +ok(!defined RegexpRef(100), '... RegexpRef rejects anything which is not a RegexpRef'); +ok(!defined RegexpRef(''), '... RegexpRef rejects anything which is not a RegexpRef'); +ok(!defined RegexpRef('Foo'), '... RegexpRef rejects anything which is not a RegexpRef'); +ok(!defined RegexpRef([]), '... RegexpRef rejects anything which is not a RegexpRef'); +ok(!defined RegexpRef({}), '... RegexpRef rejects anything which is not a RegexpRef'); +ok(!defined RegexpRef(sub {}), '... RegexpRef rejects anything which is not a RegexpRef'); +ok(!defined RegexpRef($SCALAR_REF), '... RegexpRef rejects anything which is not a RegexpRef'); +ok(defined RegexpRef(qr/../), '... RegexpRef accepts anything which is a RegexpRef'); +ok(!defined RegexpRef(bless {}, 'Foo'), '... RegexpRef rejects anything which is not a RegexpRef'); + +ok(!defined Object(0), '... Object rejects anything which is not blessed'); +ok(!defined Object(100), '... Object rejects anything which is not blessed'); +ok(!defined Object(''), '... Object rejects anything which is not blessed'); +ok(!defined Object('Foo'), '... Object rejects anything which is not blessed'); +ok(!defined Object([]), '... Object rejects anything which is not blessed'); +ok(!defined Object({}), '... Object rejects anything which is not blessed'); +ok(!defined Object(sub {}), '... Object rejects anything which is not blessed'); +ok(!defined Object($SCALAR_REF), '... Object rejects anything which is not blessed'); +ok(!defined Object(qr/../), '... Object rejects anything which is not blessed'); +ok(defined Object(bless {}, 'Foo'), '... Object accepts anything which is blessed');