'Scalar::Util' => '1.18',
'Carp' => '0.01',
'Class::MOP' => '0.20',
+ 'Sub::Name' => '0.02',
},
optional => {
},
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();
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
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;
=item B<new>
+=item B<generate_accessor_method>
+
+=item B<generate_writer_method>
+
+=back
+
+=over 4
+
+=item B<has_type_constraint>
+
+=item B<type_constraint>
+
+=item B<has_weak_ref>
+
+=item B<weak_ref>
+
=back
=head1 BUGS
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__
=over 4
+=item B<construct_instance>
+
=back
=head1 BUGS
--- /dev/null
+
+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<type>
+
+=item B<subtype>
+
+=item B<as>
+
+=item B<where>
+
+=back
+
+=head2 Built-in Type Constraints
+
+=over 4
+
+=item B<Any>
+
+=item B<Value>
+
+=item B<Int>
+
+=item B<Str>
+
+=item B<Ref>
+
+=item B<ArrayRef>
+
+=item B<CodeRef>
+
+=item B<HashRef>
+
+=item B<RegexpRef>
+
+=item B<ScalarRef>
+
+=item B<Object>
+
+=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<Devel::Cover> to test the code coverage of my tests, below is the
+L<Devel::Cover> report on this module's test suite.
+
+=head1 ACKNOWLEDGEMENTS
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+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
use strict;
use warnings;
-use Test::More tests => 32;
+use Test::More tests => 41;
use Test::Exception;
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);
}
extends 'Point';
- has '$:z';
+ has 'z' => (type_constraint => Int());
after 'clear' => sub {
my $self = shift;
- $self->{'$:z'} = 0;
+ $self->{z} = 0;
};
}
$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');
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');
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;
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
'... 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 . '"');
'... 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 . '"');
}
-
-
use warnings;
use Moose;
- has '$.balance' => (accessor => 'balance', default => 0);
+ has 'balance' => (
+ accessor => 'balance',
+ default => 0,
+ type_constraint => Int(),
+ );
sub deposit {
my ($self, $amount) = @_;
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) = @_;
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');
}
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 {
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');
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');
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');
use strict;
use warnings;
-use Test::More tests => 12;
+use Test::More tests => 16;
use Test::Exception;
BEGIN {
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');
}
--- /dev/null
+#!/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');
--- /dev/null
+#!/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
--- /dev/null
+#!/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');
projects / gitmo/Moose.git / commitdiff