diff options
Diffstat (limited to 't')
517 files changed, 54209 insertions, 0 deletions
diff --git a/t/00-report-prereqs.dd b/t/00-report-prereqs.dd new file mode 100644 index 0000000..c6684f5 --- /dev/null +++ b/t/00-report-prereqs.dd @@ -0,0 +1,199 @@ +do { my $x = { + 'configure' => { + 'requires' => { + 'Dist::CheckConflicts' => '0.02', + 'ExtUtils::CBuilder' => '0.27', + 'ExtUtils::MakeMaker' => '0', + 'File::Spec' => '0' + } + }, + 'develop' => { + 'requires' => { + 'Algorithm::C3' => '0', + 'Class::Load' => '0.07', + 'DBM::Deep' => '1.003', + 'Data::Visitor' => '0', + 'DateTime' => '0', + 'DateTime::Calendar::Mayan' => '0', + 'DateTime::Format::MySQL' => '0', + 'Declare::Constraints::Simple' => '0', + 'ExtUtils::MakeMaker::Dist::Zilla::Develop' => '0', + 'File::Find::Rule' => '0', + 'File::Spec' => '0', + 'HTTP::Headers' => '0', + 'IO::File' => '0', + 'IO::Handle' => '0', + 'IO::String' => '0', + 'IPC::Open3' => '0', + 'Locale::US' => '0', + 'Module::CPANTS::Analyse' => '0.92', + 'Module::Refresh' => '0', + 'MooseX::MarkAsMethods' => '0', + 'MooseX::NonMoose' => '0', + 'PadWalker' => '0', + 'Params::Coerce' => '0', + 'Regexp::Common' => '0', + 'SUPER' => '1.10', + 'Specio' => '0.10', + 'Test::CPAN::Changes' => '0.19', + 'Test::CPAN::Meta' => '0', + 'Test::Deep' => '0', + 'Test::EOL' => '0', + 'Test::Inline' => '0', + 'Test::Kwalitee' => '1.21', + 'Test::LeakTrace' => '0', + 'Test::Memory::Cycle' => '0', + 'Test::More' => '0.94', + 'Test::NoTabs' => '0', + 'Test::Output' => '0', + 'Test::Pod' => '1.41', + 'Test::Pod::Coverage' => '1.04', + 'Test::Spelling' => '0', + 'URI' => '0', + 'blib' => '0' + }, + 'suggests' => { + 'CPAN::Meta::Requirements' => '0', + 'Carp' => '1.22', + 'Class::Load' => '0.09', + 'Class::Load::XS' => '0.01', + 'Data::OptList' => '0.107', + 'Devel::GlobalDestruction' => '0', + 'Devel::OverloadInfo' => '0.002', + 'Devel::StackTrace' => '1.33', + 'Dist::Zilla' => '5', + 'Dist::Zilla::Plugin::BumpVersionAfterRelease' => '0', + 'Dist::Zilla::Plugin::CheckChangesHasContent' => '0', + 'Dist::Zilla::Plugin::CheckVersionIncrement' => '0', + 'Dist::Zilla::Plugin::ConfirmRelease' => '0', + 'Dist::Zilla::Plugin::Conflicts' => '0.16', + 'Dist::Zilla::Plugin::CopyFilesFromRelease' => '0', + 'Dist::Zilla::Plugin::EnsurePrereqsInstalled' => '0.003', + 'Dist::Zilla::Plugin::ExecDir' => '0', + 'Dist::Zilla::Plugin::FileFinder::ByName' => '0', + 'Dist::Zilla::Plugin::FileFinder::Filter' => '0', + 'Dist::Zilla::Plugin::Git::Check' => '0', + 'Dist::Zilla::Plugin::Git::CheckFor::CorrectBranch' => '0', + 'Dist::Zilla::Plugin::Git::Commit' => '0', + 'Dist::Zilla::Plugin::Git::Contributors' => '0', + 'Dist::Zilla::Plugin::Git::Describe' => '0.004', + 'Dist::Zilla::Plugin::Git::GatherDir' => '0', + 'Dist::Zilla::Plugin::Git::Push' => '0', + 'Dist::Zilla::Plugin::Git::Remote::Check' => '0', + 'Dist::Zilla::Plugin::Git::Tag' => '0', + 'Dist::Zilla::Plugin::License' => '0', + 'Dist::Zilla::Plugin::MakeMaker::Awesome' => '0', + 'Dist::Zilla::Plugin::Manifest' => '0', + 'Dist::Zilla::Plugin::MetaConfig' => '0', + 'Dist::Zilla::Plugin::MetaJSON' => '0', + 'Dist::Zilla::Plugin::MetaNoIndex' => '0', + 'Dist::Zilla::Plugin::MetaProvides::Package' => '1.15000002', + 'Dist::Zilla::Plugin::MetaResources' => '0', + 'Dist::Zilla::Plugin::MetaTests' => '0', + 'Dist::Zilla::Plugin::MetaYAML' => '0', + 'Dist::Zilla::Plugin::MojibakeTests' => '0', + 'Dist::Zilla::Plugin::NextRelease' => '5.033', + 'Dist::Zilla::Plugin::PodSyntaxTests' => '0', + 'Dist::Zilla::Plugin::Prereqs' => '0', + 'Dist::Zilla::Plugin::Prereqs::AuthorDeps' => '0', + 'Dist::Zilla::Plugin::PromptIfStale' => '0', + 'Dist::Zilla::Plugin::RewriteVersion' => '0', + 'Dist::Zilla::Plugin::Run::AfterRelease' => '0', + 'Dist::Zilla::Plugin::RunExtraTests' => '0', + 'Dist::Zilla::Plugin::ShareDir' => '0', + 'Dist::Zilla::Plugin::SurgicalPodWeaver' => '0.0023', + 'Dist::Zilla::Plugin::Test::CPAN::Changes' => '0', + 'Dist::Zilla::Plugin::Test::CheckBreaks' => '0', + 'Dist::Zilla::Plugin::Test::Compile' => '2.037', + 'Dist::Zilla::Plugin::Test::EOL' => '0.14', + 'Dist::Zilla::Plugin::Test::Kwalitee' => '0', + 'Dist::Zilla::Plugin::Test::NoTabs' => '0', + 'Dist::Zilla::Plugin::Test::ReportPrereqs' => '0', + 'Dist::Zilla::Plugin::TestRelease' => '0', + 'Dist::Zilla::Plugin::UploadToCPAN' => '0', + 'Dist::Zilla::Util::AuthorDeps' => '5.021', + 'Eval::Closure' => '0.04', + 'ExtUtils::CBuilder' => '0.27', + 'File::Find::Rule' => '0', + 'File::Spec' => '0', + 'File::pushd' => '0', + 'IPC::System::Simple' => '0', + 'List::MoreUtils' => '0.28', + 'List::Util' => '1.35', + 'MRO::Compat' => '0.05', + 'Module::Runtime' => '0.014', + 'Module::Runtime::Conflicts' => '0.002', + 'Package::DeprecationManager' => '0.11', + 'Package::Stash' => '0.32', + 'Package::Stash::XS' => '0.24', + 'Params::Util' => '1.00', + 'Path::Tiny' => '0', + 'Scalar::Util' => '1.19', + 'Sub::Exporter' => '0.980', + 'Sub::Identify' => '0', + 'Sub::Name' => '0.05', + 'Task::Weaken' => '0', + 'Test::Deep' => '0', + 'Test::Inline' => '0', + 'Test::Inline::Extract' => '0', + 'Try::Tiny' => '0.17', + 'parent' => '0.223', + 'perl' => 'v5.8.3', + 'strict' => '1.03', + 'warnings' => '1.03' + } + }, + 'runtime' => { + 'requires' => { + 'Carp' => '1.22', + 'Class::Load' => '0.09', + 'Class::Load::XS' => '0.01', + 'Data::OptList' => '0.107', + 'Devel::GlobalDestruction' => '0', + 'Devel::OverloadInfo' => '0.002', + 'Devel::StackTrace' => '1.33', + 'Dist::CheckConflicts' => '0.02', + 'Eval::Closure' => '0.04', + 'List::MoreUtils' => '0.28', + 'List::Util' => '1.35', + 'MRO::Compat' => '0.05', + 'Module::Runtime' => '0.014', + 'Module::Runtime::Conflicts' => '0.002', + 'Package::DeprecationManager' => '0.11', + 'Package::Stash' => '0.32', + 'Package::Stash::XS' => '0.24', + 'Params::Util' => '1.00', + 'Scalar::Util' => '1.19', + 'Sub::Exporter' => '0.980', + 'Sub::Identify' => '0', + 'Sub::Name' => '0.05', + 'Task::Weaken' => '0', + 'Try::Tiny' => '0.17', + 'parent' => '0.223', + 'perl' => 'v5.8.3', + 'strict' => '1.03', + 'warnings' => '1.03' + }, + 'suggests' => { + 'Devel::PartialDump' => '0.14' + } + }, + 'test' => { + 'recommends' => { + 'CPAN::Meta' => '2.120900' + }, + 'requires' => { + 'CPAN::Meta::Check' => '0.007', + 'CPAN::Meta::Requirements' => '0', + 'ExtUtils::MakeMaker' => '0', + 'File::Spec' => '0', + 'Test::CleanNamespaces' => '0.13', + 'Test::Fatal' => '0.001', + 'Test::More' => '0.88', + 'Test::Requires' => '0.05', + 'Test::Warnings' => '0.016' + } + } + }; + $x; + }
\ No newline at end of file diff --git a/t/00-report-prereqs.t b/t/00-report-prereqs.t new file mode 100644 index 0000000..00a51cf --- /dev/null +++ b/t/00-report-prereqs.t @@ -0,0 +1,203 @@ +#!perl + +use strict; +use warnings; + +# This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.021 + +use Test::More tests => 1; + +use ExtUtils::MakeMaker; +use File::Spec; + +# from $version::LAX +my $lax_version_re = + qr/(?: undef | (?: (?:[0-9]+) (?: \. | (?:\.[0-9]+) (?:_[0-9]+)? )? + | + (?:\.[0-9]+) (?:_[0-9]+)? + ) | (?: + v (?:[0-9]+) (?: (?:\.[0-9]+)+ (?:_[0-9]+)? )? + | + (?:[0-9]+)? (?:\.[0-9]+){2,} (?:_[0-9]+)? + ) + )/x; + +# hide optional CPAN::Meta modules from prereq scanner +# and check if they are available +my $cpan_meta = "CPAN::Meta"; +my $cpan_meta_pre = "CPAN::Meta::Prereqs"; +my $HAS_CPAN_META = eval "require $cpan_meta; $cpan_meta->VERSION('2.120900')" && eval "require $cpan_meta_pre"; ## no critic + +# Verify requirements? +my $DO_VERIFY_PREREQS = 1; + +sub _max { + my $max = shift; + $max = ( $_ > $max ) ? $_ : $max for @_; + return $max; +} + +sub _merge_prereqs { + my ($collector, $prereqs) = @_; + + # CPAN::Meta::Prereqs object + if (ref $collector eq $cpan_meta_pre) { + return $collector->with_merged_prereqs( + CPAN::Meta::Prereqs->new( $prereqs ) + ); + } + + # Raw hashrefs + for my $phase ( keys %$prereqs ) { + for my $type ( keys %{ $prereqs->{$phase} } ) { + for my $module ( keys %{ $prereqs->{$phase}{$type} } ) { + $collector->{$phase}{$type}{$module} = $prereqs->{$phase}{$type}{$module}; + } + } + } + + return $collector; +} + +my @include = qw( + Algorithm::C3 + DBM::Deep + DateTime + DateTime::Calendar::Mayan + DateTime::Format::MySQL + Declare::Constraints::Simple + Dist::CheckConflicts + HTTP::Headers + IO::File + IO::String + Locale::US + Module::Refresh + MooseX::NonMoose + Params::Coerce + Regexp::Common + SUPER + Test::Deep + Test::DependentModules + Test::LeakTrace + Test::Output + URI +); + +my @exclude = qw( + +); + +# Add static prereqs to the included modules list +my $static_prereqs = do 't/00-report-prereqs.dd'; + +# Merge all prereqs (either with ::Prereqs or a hashref) +my $full_prereqs = _merge_prereqs( + ( $HAS_CPAN_META ? $cpan_meta_pre->new : {} ), + $static_prereqs +); + +# Add dynamic prereqs to the included modules list (if we can) +my ($source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; +if ( $source && $HAS_CPAN_META ) { + if ( my $meta = eval { CPAN::Meta->load_file($source) } ) { + $full_prereqs = _merge_prereqs($full_prereqs, $meta->prereqs); + } +} +else { + $source = 'static metadata'; +} + +my @full_reports; +my @dep_errors; +my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs; + +# Add static includes into a fake section +for my $mod (@include) { + $req_hash->{other}{modules}{$mod} = 0; +} + +for my $phase ( qw(configure build test runtime develop other) ) { + next unless $req_hash->{$phase}; + next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING}); + + for my $type ( qw(requires recommends suggests conflicts modules) ) { + next unless $req_hash->{$phase}{$type}; + + my $title = ucfirst($phase).' '.ucfirst($type); + my @reports = [qw/Module Want Have/]; + + for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) { + next if $mod eq 'perl'; + next if grep { $_ eq $mod } @exclude; + + my $file = $mod; + $file =~ s{::}{/}g; + $file .= ".pm"; + my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC; + + my $want = $req_hash->{$phase}{$type}{$mod}; + $want = "undef" unless defined $want; + $want = "any" if !$want && $want == 0; + + my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required"; + + if ($prefix) { + my $have = MM->parse_version( File::Spec->catfile($prefix, $file) ); + $have = "undef" unless defined $have; + push @reports, [$mod, $want, $have]; + + if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) { + if ( $have !~ /\A$lax_version_re\z/ ) { + push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)"; + } + elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) { + push @dep_errors, "$mod version '$have' is not in required range '$want'"; + } + } + } + else { + push @reports, [$mod, $want, "missing"]; + + if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) { + push @dep_errors, "$mod is not installed ($req_string)"; + } + } + } + + if ( @reports ) { + push @full_reports, "=== $title ===\n\n"; + + my $ml = _max( map { length $_->[0] } @reports ); + my $wl = _max( map { length $_->[1] } @reports ); + my $hl = _max( map { length $_->[2] } @reports ); + + if ($type eq 'modules') { + splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl]; + push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports; + } + else { + splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl]; + push @full_reports, map { sprintf(" %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports; + } + + push @full_reports, "\n"; + } + } +} + +if ( @full_reports ) { + diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports; +} + +if ( @dep_errors ) { + diag join("\n", + "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n", + "The following REQUIRED prerequisites were not satisfied:\n", + @dep_errors, + "\n" + ); +} + +pass; + +# vim: ts=4 sts=4 sw=4 et: diff --git a/t/000_load.t b/t/000_load.t new file mode 100644 index 0000000..afd9e9f --- /dev/null +++ b/t/000_load.t @@ -0,0 +1,10 @@ +use strict; +use warnings; + +use Test::More; + +BEGIN { + use_ok('Moose'); +} + +done_testing; diff --git a/t/attributes/accessor_context.t b/t/attributes/accessor_context.t new file mode 100644 index 0000000..f07a499 --- /dev/null +++ b/t/attributes/accessor_context.t @@ -0,0 +1,68 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +is( exception { + package My::Class; + use Moose; + + has s_rw => ( + is => 'rw', + ); + + has s_ro => ( + is => 'ro', + ); + + has a_rw => ( + is => 'rw', + isa => 'ArrayRef', + + auto_deref => 1, + ); + + has a_ro => ( + is => 'ro', + isa => 'ArrayRef', + + auto_deref => 1, + ); + + has h_rw => ( + is => 'rw', + isa => 'HashRef', + + auto_deref => 1, + ); + + has h_ro => ( + is => 'ro', + isa => 'HashRef', + + auto_deref => 1, + ); +}, undef, 'class definition' ); + +is( exception { + my $o = My::Class->new(); + + is_deeply [scalar $o->s_rw], [undef], 'uninitialized scalar attribute/rw in scalar context'; + is_deeply [$o->s_rw], [undef], 'uninitialized scalar attribute/rw in list context'; + is_deeply [scalar $o->s_ro], [undef], 'uninitialized scalar attribute/ro in scalar context'; + is_deeply [$o->s_ro], [undef], 'uninitialized scalar attribute/ro in list context'; + + + is_deeply [scalar $o->a_rw], [undef], 'uninitialized ArrayRef attribute/rw in scalar context'; + is_deeply [$o->a_rw], [], 'uninitialized ArrayRef attribute/rw in list context'; + is_deeply [scalar $o->a_ro], [undef], 'uninitialized ArrayRef attribute/ro in scalar context'; + is_deeply [$o->a_ro], [], 'uninitialized ArrayRef attribute/ro in list context'; + + is_deeply [scalar $o->h_rw], [undef], 'uninitialized HashRef attribute/rw in scalar context'; + is_deeply [$o->h_rw], [], 'uninitialized HashRef attribute/rw in list context'; + is_deeply [scalar $o->h_ro], [undef], 'uninitialized HashRef attribute/ro in scalar context'; + is_deeply [$o->h_ro], [], 'uninitialized HashRef attribute/ro in list context'; + +}, undef, 'testing' ); + +done_testing; diff --git a/t/attributes/accessor_inlining.t b/t/attributes/accessor_inlining.t new file mode 100644 index 0000000..8212e53 --- /dev/null +++ b/t/attributes/accessor_inlining.t @@ -0,0 +1,32 @@ +use strict; +use warnings; +use Test::More; + +my $called; +{ + package Foo::Meta::Instance; + use Moose::Role; + + sub is_inlinable { 0 } + + after get_slot_value => sub { $called++ }; +} + +{ + package Foo; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { + instance => ['Foo::Meta::Instance'], + }, + ); + + has foo => (is => 'ro'); +} + +my $foo = Foo->new(foo => 1); +is($foo->foo, 1, "got the right value"); +is($called, 1, "reader was called"); + +done_testing; diff --git a/t/attributes/accessor_override_method.t b/t/attributes/accessor_override_method.t new file mode 100644 index 0000000..10343b9 --- /dev/null +++ b/t/attributes/accessor_override_method.t @@ -0,0 +1,57 @@ +use strict; +use warnings; +use Test::More; + +use Test::Requires 'Test::Output'; # skip all if not installed + +{ + + package Foo; + use Moose; + + sub get_a { } + sub set_b { } + sub has_c { } + sub clear_d { } + sub e { } + sub stub; +} + +my $foo_meta = Foo->meta; +stderr_like( + sub { $foo_meta->add_attribute( a => ( reader => 'get_a' ) ) }, + qr/^You are overwriting a locally defined method \(get_a\) with an accessor/, + 'reader overriding gives proper warning' +); +stderr_like( + sub { $foo_meta->add_attribute( b => ( writer => 'set_b' ) ) }, + qr/^You are overwriting a locally defined method \(set_b\) with an accessor/, + 'writer overriding gives proper warning' +); +stderr_like( + sub { $foo_meta->add_attribute( c => ( predicate => 'has_c' ) ) }, + qr/^You are overwriting a locally defined method \(has_c\) with an accessor/, + 'predicate overriding gives proper warning' +); +stderr_like( + sub { $foo_meta->add_attribute( d => ( clearer => 'clear_d' ) ) }, + qr/^You are overwriting a locally defined method \(clear_d\) with an accessor/, + 'clearer overriding gives proper warning' +); +stderr_like( + sub { $foo_meta->add_attribute( e => ( is => 'rw' ) ) }, + qr/^You are overwriting a locally defined method \(e\) with an accessor/, + 'accessor overriding gives proper warning' +); +stderr_is( + sub { $foo_meta->add_attribute( stub => ( is => 'rw' ) ) }, + q{}, + 'overriding a stub with an accessor does not warn' +); +stderr_like( + sub { $foo_meta->add_attribute( has => ( is => 'rw' ) ) }, + qr/^You are overwriting a locally defined function \(has\) with an accessor/, + 'function overriding gives proper warning' +); + +done_testing; diff --git a/t/attributes/accessor_overwrite_warning.t b/t/attributes/accessor_overwrite_warning.t new file mode 100644 index 0000000..aa659f7 --- /dev/null +++ b/t/attributes/accessor_overwrite_warning.t @@ -0,0 +1,25 @@ +use strict; +use warnings; + +use Test::More; + +use Test::Requires 'Test::Output'; + +{ + package Bar; + use Moose; + + has has_attr => ( + is => 'ro', + ); + + ::stderr_like{ has attr => ( + is => 'ro', + predicate => 'has_attr', + ) + } + qr/\QYou are overwriting an accessor (has_attr) for the has_attr attribute with a new accessor method for the attr attribute/, + 'overwriting an accessor for another attribute causes a warning'; +} + +done_testing; diff --git a/t/attributes/attr_dereference_test.t b/t/attributes/attr_dereference_test.t new file mode 100644 index 0000000..1aeea9c --- /dev/null +++ b/t/attributes/attr_dereference_test.t @@ -0,0 +1,80 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Customer; + use Moose; + + package Firm; + use Moose; + use Moose::Util::TypeConstraints; + + ::is( ::exception { + has 'customers' => ( + is => 'ro', + isa => subtype('ArrayRef' => where { + (blessed($_) && $_->isa('Customer') || return) for @$_; 1 }), + auto_deref => 1, + ); + }, undef, '... successfully created attr' ); +} + +{ + my $customer = Customer->new; + isa_ok($customer, 'Customer'); + + my $firm = Firm->new(customers => [ $customer ]); + isa_ok($firm, 'Firm'); + + can_ok($firm, 'customers'); + + is_deeply( + [ $firm->customers ], + [ $customer ], + '... got the right dereferenced value' + ); +} + +{ + my $firm = Firm->new(); + isa_ok($firm, 'Firm'); + + can_ok($firm, 'customers'); + + is_deeply( + [ $firm->customers ], + [], + '... got the right dereferenced value' + ); +} + +{ + package AutoDeref; + use Moose; + + has 'bar' => ( + is => 'rw', + isa => 'ArrayRef[Int]', + auto_deref => 1, + ); +} + +{ + my $autoderef = AutoDeref->new; + + isnt( exception { + $autoderef->bar(1, 2, 3); + }, undef, '... its auto-de-ref-ing, not auto-en-ref-ing' ); + + is( exception { + $autoderef->bar([ 1, 2, 3 ]) + }, undef, '... set the results of bar correctly' ); + + is_deeply [ $autoderef->bar ], [ 1, 2, 3 ], '... auto-dereffed correctly'; +} + +done_testing; diff --git a/t/attributes/attribute_accessor_generation.t b/t/attributes/attribute_accessor_generation.t new file mode 100644 index 0000000..e72ea7d --- /dev/null +++ b/t/attributes/attribute_accessor_generation.t @@ -0,0 +1,204 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Scalar::Util 'isweak'; + + +{ + package Foo; + use Moose; + + eval { + has 'foo' => ( + accessor => 'foo', + ); + }; + ::ok(!$@, '... created the accessor method okay'); + + eval { + has 'lazy_foo' => ( + accessor => 'lazy_foo', + lazy => 1, + default => sub { 10 } + ); + }; + ::ok(!$@, '... created the lazy accessor method okay'); + + + eval { + has 'foo_required' => ( + accessor => 'foo_required', + required => 1, + ); + }; + ::ok(!$@, '... created the required accessor method okay'); + + eval { + has 'foo_int' => ( + accessor => 'foo_int', + isa => 'Int', + ); + }; + ::ok(!$@, '... created the accessor method with type constraint okay'); + + eval { + has 'foo_weak' => ( + accessor => 'foo_weak', + weak_ref => 1 + ); + }; + ::ok(!$@, '... created the accessor method with weak_ref okay'); + + eval { + has 'foo_deref' => ( + accessor => 'foo_deref', + isa => 'ArrayRef', + auto_deref => 1, + ); + }; + ::ok(!$@, '... created the accessor method with auto_deref okay'); + + eval { + has 'foo_deref_ro' => ( + reader => 'foo_deref_ro', + isa => 'ArrayRef', + auto_deref => 1, + ); + }; + ::ok(!$@, '... created the reader method with auto_deref okay'); + + eval { + has 'foo_deref_hash' => ( + accessor => 'foo_deref_hash', + isa => 'HashRef', + auto_deref => 1, + ); + }; + ::ok(!$@, '... created the reader method with auto_deref okay'); +} + +{ + my $foo = Foo->new(foo_required => 'required'); + isa_ok($foo, 'Foo'); + + # regular accessor + + can_ok($foo, 'foo'); + is($foo->foo(), undef, '... got an unset value'); + is( exception { + $foo->foo(100); + }, undef, '... foo wrote successfully' ); + is($foo->foo(), 100, '... got the correct set value'); + + ok(!isweak($foo->{foo}), '... it is not a weak reference'); + + # required writer + + isnt( exception { + Foo->new; + }, undef, '... cannot create without the required attribute' ); + + can_ok($foo, 'foo_required'); + is($foo->foo_required(), 'required', '... got an unset value'); + is( exception { + $foo->foo_required(100); + }, undef, '... foo_required wrote successfully' ); + is($foo->foo_required(), 100, '... got the correct set value'); + + is( exception { + $foo->foo_required(undef); + }, undef, '... foo_required did not die with undef' ); + + is($foo->foo_required, undef, "value is undef"); + + ok(!isweak($foo->{foo_required}), '... it is not a weak reference'); + + # lazy + + ok(!exists($foo->{lazy_foo}), '... no value in lazy_foo slot'); + + can_ok($foo, 'lazy_foo'); + is($foo->lazy_foo(), 10, '... got an deferred value'); + + # with type constraint + + can_ok($foo, 'foo_int'); + is($foo->foo_int(), undef, '... got an unset value'); + is( exception { + $foo->foo_int(100); + }, undef, '... foo_int wrote successfully' ); + is($foo->foo_int(), 100, '... got the correct set value'); + + isnt( exception { + $foo->foo_int("Foo"); + }, undef, '... foo_int died successfully' ); + + ok(!isweak($foo->{foo_int}), '... it is not a weak reference'); + + # with weak_ref + + my $test = []; + + can_ok($foo, 'foo_weak'); + is($foo->foo_weak(), undef, '... got an unset value'); + is( exception { + $foo->foo_weak($test); + }, undef, '... foo_weak wrote successfully' ); + is($foo->foo_weak(), $test, '... got the correct set value'); + + ok(isweak($foo->{foo_weak}), '... it is a weak reference'); + + can_ok( $foo, 'foo_deref'); + is_deeply( [$foo->foo_deref()], [], '... default default value'); + my @list; + is( exception { + @list = $foo->foo_deref(); + }, undef, "... doesn't deref undef value" ); + is_deeply( \@list, [], "returns empty list in list context"); + + is( exception { + $foo->foo_deref( [ qw/foo bar gorch/ ] ); + }, undef, '... foo_deref wrote successfully' ); + + is( Scalar::Util::reftype( scalar $foo->foo_deref() ), "ARRAY", "returns an array reference in scalar context" ); + is_deeply( scalar($foo->foo_deref()), [ qw/foo bar gorch/ ], "correct array" ); + + is( scalar( () = $foo->foo_deref() ), 3, "returns list in list context" ); + is_deeply( [ $foo->foo_deref() ], [ qw/foo bar gorch/ ], "correct list" ); + + + can_ok( $foo, 'foo_deref' ); + is_deeply( [$foo->foo_deref_ro()], [], "... default default value" ); + + isnt( exception { + $foo->foo_deref_ro( [] ); + }, undef, "... read only" ); + + $foo->{foo_deref_ro} = [qw/la la la/]; + + is_deeply( scalar($foo->foo_deref_ro()), [qw/la la la/], "scalar context ro" ); + is_deeply( [ $foo->foo_deref_ro() ], [qw/la la la/], "list context ro" ); + + can_ok( $foo, 'foo_deref_hash' ); + is_deeply( { $foo->foo_deref_hash() }, {}, "... default default value" ); + + my %hash; + is( exception { + %hash = $foo->foo_deref_hash(); + }, undef, "... doesn't deref undef value" ); + is_deeply( \%hash, {}, "returns empty list in list context"); + + is( exception { + $foo->foo_deref_hash( { foo => 1, bar => 2 } ); + }, undef, '... foo_deref_hash wrote successfully' ); + + is_deeply( scalar($foo->foo_deref_hash), { foo => 1, bar => 2 }, "scalar context" ); + + %hash = $foo->foo_deref_hash; + is_deeply( \%hash, { foo => 1, bar => 2 }, "list context"); +} + +done_testing; diff --git a/t/attributes/attribute_custom_metaclass.t b/t/attributes/attribute_custom_metaclass.t new file mode 100644 index 0000000..2778de5 --- /dev/null +++ b/t/attributes/attribute_custom_metaclass.t @@ -0,0 +1,90 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo::Meta::Attribute; + use Moose; + + extends 'Moose::Meta::Attribute'; + + around 'new' => sub { + my $next = shift; + my $self = shift; + my $name = shift; + $next->($self, $name, (is => 'rw', isa => 'Foo'), @_); + }; + + package Foo; + use Moose; + + has 'foo' => (metaclass => 'Foo::Meta::Attribute'); +} +{ + my $foo = Foo->new; + isa_ok($foo, 'Foo'); + + my $foo_attr = Foo->meta->get_attribute('foo'); + isa_ok($foo_attr, 'Foo::Meta::Attribute'); + isa_ok($foo_attr, 'Moose::Meta::Attribute'); + + is($foo_attr->name, 'foo', '... got the right name for our meta-attribute'); + ok($foo_attr->has_accessor, '... our meta-attrubute created the accessor for us'); + + ok($foo_attr->has_type_constraint, '... our meta-attrubute created the type_constraint for us'); + + my $foo_attr_type_constraint = $foo_attr->type_constraint; + isa_ok($foo_attr_type_constraint, 'Moose::Meta::TypeConstraint'); + + is($foo_attr_type_constraint->name, 'Foo', '... got the right type constraint name'); + is($foo_attr_type_constraint->parent->name, 'Object', '... got the right type constraint parent name'); +} +{ + package Bar::Meta::Attribute; + use Moose; + + extends 'Class::MOP::Attribute'; + + package Bar; + use Moose; + + ::is( ::exception { + has 'bar' => (metaclass => 'Bar::Meta::Attribute'); + }, undef, '... the attribute metaclass need not be a Moose::Meta::Attribute as long as it behaves' ); +} + +{ + package Moose::Meta::Attribute::Custom::Foo; + sub register_implementation { 'Foo::Meta::Attribute' } + + package Moose::Meta::Attribute::Custom::Bar; + use Moose; + + extends 'Moose::Meta::Attribute'; + + package Another::Foo; + use Moose; + + ::is( ::exception { + has 'foo' => (metaclass => 'Foo'); + }, undef, '... the attribute metaclass alias worked correctly' ); + + ::is( ::exception { + has 'bar' => (metaclass => 'Bar', is => 'bare'); + }, undef, '... the attribute metaclass alias worked correctly' ); +} + +{ + my $foo_attr = Another::Foo->meta->get_attribute('foo'); + isa_ok($foo_attr, 'Foo::Meta::Attribute'); + isa_ok($foo_attr, 'Moose::Meta::Attribute'); + + my $bar_attr = Another::Foo->meta->get_attribute('bar'); + isa_ok($bar_attr, 'Moose::Meta::Attribute::Custom::Bar'); + isa_ok($bar_attr, 'Moose::Meta::Attribute'); +} + +done_testing; diff --git a/t/attributes/attribute_delegation.t b/t/attributes/attribute_delegation.t new file mode 100644 index 0000000..3c61edd --- /dev/null +++ b/t/attributes/attribute_delegation.t @@ -0,0 +1,483 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +# ------------------------------------------------------------------- +# HASH handles +# ------------------------------------------------------------------- +# the canonical form of of the 'handles' +# option is the hash ref mapping a +# method name to the delegated method name + +{ + package Foo; + use Moose; + + has 'bar' => (is => 'rw', default => 10); + + sub baz { 42 } + + package Bar; + use Moose; + + has 'foo' => ( + is => 'rw', + default => sub { Foo->new }, + handles => { + 'foo_bar' => 'bar', + foo_baz => 'baz', + 'foo_bar_to_20' => [ bar => 20 ], + }, + ); +} + +my $bar = Bar->new; +isa_ok($bar, 'Bar'); + +ok($bar->foo, '... we have something in bar->foo'); +isa_ok($bar->foo, 'Foo'); + +my $meth = Bar->meta->get_method('foo_bar'); +isa_ok($meth, 'Moose::Meta::Method::Delegation'); +is($meth->associated_attribute->name, 'foo', + 'associated_attribute->name for this method is foo'); + +is($bar->foo->bar, 10, '... bar->foo->bar returned the right default'); + +can_ok($bar, 'foo_bar'); +is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly'); + +# change the value ... + +$bar->foo->bar(30); + +# and make sure the delegation picks it up + +is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value'); +is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly'); + +# change the value through the delegation ... + +$bar->foo_bar(50); + +# and make sure everyone sees it + +is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value'); +is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly'); + +# change the object we are delegating too + +my $foo = Foo->new(bar => 25); +isa_ok($foo, 'Foo'); + +is($foo->bar, 25, '... got the right foo->bar'); + +is( exception { + $bar->foo($foo); +}, undef, '... assigned the new Foo to Bar->foo' ); + +is($bar->foo, $foo, '... assigned bar->foo with the new Foo'); + +is($bar->foo->bar, 25, '... bar->foo->bar returned the right result'); +is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again'); + +# curried handles +$bar->foo_bar_to_20; +is($bar->foo_bar, 20, '... correctly curried a single argument'); + +# ------------------------------------------------------------------- +# ARRAY handles +# ------------------------------------------------------------------- +# we also support an array based format +# which assumes that the name is the same +# on either end + +{ + package Engine; + use Moose; + + sub go { 'Engine::go' } + sub stop { 'Engine::stop' } + + package Car; + use Moose; + + has 'engine' => ( + is => 'rw', + default => sub { Engine->new }, + handles => [ 'go', 'stop' ] + ); +} + +my $car = Car->new; +isa_ok($car, 'Car'); + +isa_ok($car->engine, 'Engine'); +can_ok($car->engine, 'go'); +can_ok($car->engine, 'stop'); + +is($car->engine->go, 'Engine::go', '... got the right value from ->engine->go'); +is($car->engine->stop, 'Engine::stop', '... got the right value from ->engine->stop'); + +can_ok($car, 'go'); +can_ok($car, 'stop'); + +is($car->go, 'Engine::go', '... got the right value from ->go'); +is($car->stop, 'Engine::stop', '... got the right value from ->stop'); + +# ------------------------------------------------------------------- +# REGEXP handles +# ------------------------------------------------------------------- +# and we support regexp delegation + +{ + package Baz; + use Moose; + + sub foo { 'Baz::foo' } + sub bar { 'Baz::bar' } + sub boo { 'Baz::boo' } + + package Baz::Proxy1; + use Moose; + + has 'baz' => ( + is => 'ro', + isa => 'Baz', + default => sub { Baz->new }, + handles => qr/.*/ + ); + + package Baz::Proxy2; + use Moose; + + has 'baz' => ( + is => 'ro', + isa => 'Baz', + default => sub { Baz->new }, + handles => qr/.oo/ + ); + + package Baz::Proxy3; + use Moose; + + has 'baz' => ( + is => 'ro', + isa => 'Baz', + default => sub { Baz->new }, + handles => qr/b.*/ + ); +} + +{ + my $baz_proxy = Baz::Proxy1->new; + isa_ok($baz_proxy, 'Baz::Proxy1'); + + can_ok($baz_proxy, 'baz'); + isa_ok($baz_proxy->baz, 'Baz'); + + can_ok($baz_proxy, 'foo'); + can_ok($baz_proxy, 'bar'); + can_ok($baz_proxy, 'boo'); + + is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value'); + is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value'); + is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value'); +} +{ + my $baz_proxy = Baz::Proxy2->new; + isa_ok($baz_proxy, 'Baz::Proxy2'); + + can_ok($baz_proxy, 'baz'); + isa_ok($baz_proxy->baz, 'Baz'); + + can_ok($baz_proxy, 'foo'); + can_ok($baz_proxy, 'boo'); + + is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value'); + is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value'); +} +{ + my $baz_proxy = Baz::Proxy3->new; + isa_ok($baz_proxy, 'Baz::Proxy3'); + + can_ok($baz_proxy, 'baz'); + isa_ok($baz_proxy->baz, 'Baz'); + + can_ok($baz_proxy, 'bar'); + can_ok($baz_proxy, 'boo'); + + is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value'); + is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value'); +} + +# ------------------------------------------------------------------- +# ROLE handles +# ------------------------------------------------------------------- + +{ + package Foo::Bar; + use Moose::Role; + + requires 'foo'; + requires 'bar'; + + package Foo::Baz; + use Moose; + + sub foo { 'Foo::Baz::FOO' } + sub bar { 'Foo::Baz::BAR' } + sub baz { 'Foo::Baz::BAZ' } + + package Foo::Thing; + use Moose; + + has 'thing' => ( + is => 'rw', + isa => 'Foo::Baz', + handles => 'Foo::Bar', + ); + + package Foo::OtherThing; + use Moose; + use Moose::Util::TypeConstraints; + + has 'other_thing' => ( + is => 'rw', + isa => 'Foo::Baz', + handles => Moose::Util::TypeConstraints::find_type_constraint('Foo::Bar'), + ); +} + +{ + my $foo = Foo::Thing->new(thing => Foo::Baz->new); + isa_ok($foo, 'Foo::Thing'); + isa_ok($foo->thing, 'Foo::Baz'); + + ok($foo->meta->has_method('foo'), '... we have the method we expect'); + ok($foo->meta->has_method('bar'), '... we have the method we expect'); + ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect'); + + is($foo->foo, 'Foo::Baz::FOO', '... got the right value'); + is($foo->bar, 'Foo::Baz::BAR', '... got the right value'); + is($foo->thing->baz, 'Foo::Baz::BAZ', '... got the right value'); +} + +{ + my $foo = Foo::OtherThing->new(other_thing => Foo::Baz->new); + isa_ok($foo, 'Foo::OtherThing'); + isa_ok($foo->other_thing, 'Foo::Baz'); + + ok($foo->meta->has_method('foo'), '... we have the method we expect'); + ok($foo->meta->has_method('bar'), '... we have the method we expect'); + ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect'); + + is($foo->foo, 'Foo::Baz::FOO', '... got the right value'); + is($foo->bar, 'Foo::Baz::BAR', '... got the right value'); + is($foo->other_thing->baz, 'Foo::Baz::BAZ', '... got the right value'); +} +# ------------------------------------------------------------------- +# AUTOLOAD & handles +# ------------------------------------------------------------------- + +{ + package Foo::Autoloaded; + use Moose; + + sub AUTOLOAD { + my $self = shift; + + my $name = our $AUTOLOAD; + $name =~ s/.*://; # strip fully-qualified portion + + if (@_) { + return $self->{$name} = shift; + } else { + return $self->{$name}; + } + } + + package Bar::Autoloaded; + use Moose; + + has 'foo' => ( + is => 'rw', + default => sub { Foo::Autoloaded->new }, + handles => { 'foo_bar' => 'bar' } + ); + + package Baz::Autoloaded; + use Moose; + + has 'foo' => ( + is => 'rw', + default => sub { Foo::Autoloaded->new }, + handles => ['bar'] + ); + + package Goorch::Autoloaded; + use Moose; + + ::isnt( ::exception { + has 'foo' => ( + is => 'rw', + default => sub { Foo::Autoloaded->new }, + handles => qr/bar/ + ); + }, undef, '... you cannot delegate to AUTOLOADED class with regexp' ); +} + +# check HASH based delegation w/ AUTOLOAD + +{ + my $bar = Bar::Autoloaded->new; + isa_ok($bar, 'Bar::Autoloaded'); + + ok($bar->foo, '... we have something in bar->foo'); + isa_ok($bar->foo, 'Foo::Autoloaded'); + + # change the value ... + + $bar->foo->bar(30); + + # and make sure the delegation picks it up + + is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value'); + is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly'); + + # change the value through the delegation ... + + $bar->foo_bar(50); + + # and make sure everyone sees it + + is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value'); + is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly'); + + # change the object we are delegating too + + my $foo = Foo::Autoloaded->new; + isa_ok($foo, 'Foo::Autoloaded'); + + $foo->bar(25); + + is($foo->bar, 25, '... got the right foo->bar'); + + is( exception { + $bar->foo($foo); + }, undef, '... assigned the new Foo to Bar->foo' ); + + is($bar->foo, $foo, '... assigned bar->foo with the new Foo'); + + is($bar->foo->bar, 25, '... bar->foo->bar returned the right result'); + is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again'); +} + +# check ARRAY based delegation w/ AUTOLOAD + +{ + my $baz = Baz::Autoloaded->new; + isa_ok($baz, 'Baz::Autoloaded'); + + ok($baz->foo, '... we have something in baz->foo'); + isa_ok($baz->foo, 'Foo::Autoloaded'); + + # change the value ... + + $baz->foo->bar(30); + + # and make sure the delegation picks it up + + is($baz->foo->bar, 30, '... baz->foo->bar returned the right (changed) value'); + is($baz->bar, 30, '... baz->foo_bar delegated correctly'); + + # change the value through the delegation ... + + $baz->bar(50); + + # and make sure everyone sees it + + is($baz->foo->bar, 50, '... baz->foo->bar returned the right (changed) value'); + is($baz->bar, 50, '... baz->foo_bar delegated correctly'); + + # change the object we are delegating too + + my $foo = Foo::Autoloaded->new; + isa_ok($foo, 'Foo::Autoloaded'); + + $foo->bar(25); + + is($foo->bar, 25, '... got the right foo->bar'); + + is( exception { + $baz->foo($foo); + }, undef, '... assigned the new Foo to Baz->foo' ); + + is($baz->foo, $foo, '... assigned baz->foo with the new Foo'); + + is($baz->foo->bar, 25, '... baz->foo->bar returned the right result'); + is($baz->bar, 25, '... and baz->foo_bar delegated correctly again'); +} + +# Check that removing attributes removes their handles methods also. +{ + { + package Quux; + use Moose; + has foo => ( + isa => 'Foo', + default => sub { Foo->new }, + handles => { 'foo_bar' => 'bar' } + ); + } + my $i = Quux->new; + ok($i->meta->has_method('foo_bar'), 'handles method foo_bar is present'); + $i->meta->remove_attribute('foo'); + ok(!$i->meta->has_method('foo_bar'), 'handles method foo_bar is removed'); +} + +# Make sure that a useful error message is thrown when the delegation target is +# not an object +{ + my $i = Bar->new(foo => undef); + like( exception { $i->foo_bar }, qr/is not defined/, 'useful error from unblessed reference' ); + + my $j = Bar->new(foo => []); + like( exception { $j->foo_bar }, qr/is not an object \(got 'ARRAY/, 'useful error from unblessed reference' ); + + my $k = Bar->new(foo => "Foo"); + is( exception { $k->foo_baz }, undef, "but not for class name" ); +} + +{ + package Delegator; + use Moose; + + sub full { 1 } + sub stub; + + ::like( + ::exception{ has d1 => ( + isa => 'X', + handles => ['full'], + ); + }, + qr/\QYou cannot overwrite a locally defined method (full) with a delegation/, + 'got an error when trying to declare a delegation method that overwrites a local method' + ); + + ::is( + ::exception{ has d2 => ( + isa => 'X', + handles => ['stub'], + ); + }, + undef, + 'no error when trying to declare a delegation method that overwrites a stub method' + ); +} + +done_testing; diff --git a/t/attributes/attribute_does.t b/t/attributes/attribute_does.t new file mode 100644 index 0000000..32279a5 --- /dev/null +++ b/t/attributes/attribute_does.t @@ -0,0 +1,99 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo::Role; + use Moose::Role; + use Moose::Util::TypeConstraints; + + # if does() exists on its own, then + # we create a type constraint for + # it, just as we do for isa() + has 'bar' => (is => 'rw', does => 'Bar::Role'); + has 'baz' => ( + is => 'rw', + does => role_type('Bar::Role') + ); + + package Foo::Class; + use Moose; + + with 'Foo::Role'; + + package Bar::Role; + use Moose::Role; + + # if isa and does appear together, then see if Class->does(Role) + # if it does work... then the does() check is actually not needed + # since the isa() check will imply the does() check + has 'foo' => (is => 'rw', isa => 'Foo::Class', does => 'Foo::Role'); + + package Bar::Class; + use Moose; + + with 'Bar::Role'; +} + +my $foo = Foo::Class->new; +isa_ok($foo, 'Foo::Class'); + +my $bar = Bar::Class->new; +isa_ok($bar, 'Bar::Class'); + +is( exception { + $foo->bar($bar); +}, undef, '... bar passed the type constraint okay' ); + +isnt( exception { + $foo->bar($foo); +}, undef, '... foo did not pass the type constraint okay' ); + +is( exception { + $foo->baz($bar); +}, undef, '... baz passed the type constraint okay' ); + +isnt( exception { + $foo->baz($foo); +}, undef, '... foo did not pass the type constraint okay' ); + +is( exception { + $bar->foo($foo); +}, undef, '... foo passed the type constraint okay' ); + + + +# some error conditions + +{ + package Baz::Class; + use Moose; + + # if isa and does appear together, then see if Class->does(Role) + # if it does not,.. we have a conflict... so we die loudly + ::isnt( ::exception { + has 'foo' => (isa => 'Foo::Class', does => 'Bar::Class'); + }, undef, '... cannot have a does() which is not done by the isa()' ); +} + +{ + package Bling; + use strict; + use warnings; + + sub bling { 'Bling::bling' } + + package Bling::Bling; + use Moose; + + # if isa and does appear together, then see if Class->does(Role) + # if it does not,.. we have a conflict... so we die loudly + ::isnt( ::exception { + has 'foo' => (isa => 'Bling', does => 'Bar::Class'); + }, undef, '... cannot have a isa() which is cannot does()' ); +} + +done_testing; diff --git a/t/attributes/attribute_inherited_slot_specs.t b/t/attributes/attribute_inherited_slot_specs.t new file mode 100644 index 0000000..2556e9a --- /dev/null +++ b/t/attributes/attribute_inherited_slot_specs.t @@ -0,0 +1,269 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Thing::Meta::Attribute; + use Moose; + + extends 'Moose::Meta::Attribute'; + around illegal_options_for_inheritance => sub { + return (shift->(@_), qw/trigger/); + }; + + package Thing; + use Moose; + + sub hello { 'Hello World (from Thing)' } + sub goodbye { 'Goodbye World (from Thing)' } + + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + subtype 'FooStr' + => as 'Str' + => where { /Foo/ }; + + coerce 'FooStr' + => from ArrayRef + => via { 'FooArrayRef' }; + + has 'bar' => (is => 'ro', isa => 'Str', default => 'Foo::bar'); + has 'baz' => (is => 'rw', isa => 'Ref'); + has 'foo' => (is => 'rw', isa => 'FooStr'); + + has 'gorch' => (is => 'ro'); + has 'gloum' => (is => 'ro', default => sub {[]}); + has 'fleem' => (is => 'ro'); + + has 'bling' => (is => 'ro', isa => 'Thing'); + has 'blang' => (is => 'ro', isa => 'Thing', handles => ['goodbye']); + + has 'bunch_of_stuff' => (is => 'rw', isa => 'ArrayRef'); + + has 'one_last_one' => (is => 'rw', isa => 'Ref'); + + # this one will work here .... + has 'fail' => (isa => 'CodeRef', is => 'bare'); + has 'other_fail' => (metaclass => 'Thing::Meta::Attribute', is => 'bare', trigger => sub { }); + + package Bar; + use Moose; + use Moose::Util::TypeConstraints; + + extends 'Foo'; + + ::is( ::exception { + has '+bar' => (default => 'Bar::bar'); + }, undef, '... we can change the default attribute option' ); + + ::is( ::exception { + has '+baz' => (isa => 'ArrayRef'); + }, undef, '... we can add change the isa as long as it is a subtype' ); + + ::is( ::exception { + has '+foo' => (coerce => 1); + }, undef, '... we can change/add coerce as an attribute option' ); + + ::is( ::exception { + has '+gorch' => (required => 1); + }, undef, '... we can change/add required as an attribute option' ); + + ::is( ::exception { + has '+gloum' => (lazy => 1); + }, undef, '... we can change/add lazy as an attribute option' ); + + ::is( ::exception { + has '+fleem' => (lazy_build => 1); + }, undef, '... we can add lazy_build as an attribute option' ); + + ::is( ::exception { + has '+bunch_of_stuff' => (isa => 'ArrayRef[Int]'); + }, undef, '... extend an attribute with parameterized type' ); + + ::is( ::exception { + has '+one_last_one' => (isa => subtype('Ref', where { blessed $_ eq 'CODE' })); + }, undef, '... extend an attribute with anon-subtype' ); + + ::is( ::exception { + has '+one_last_one' => (isa => 'Value'); + }, undef, '... now can extend an attribute with a non-subtype' ); + + ::is( ::exception { + has '+fleem' => (weak_ref => 1); + }, undef, '... now allowed to add the weak_ref option via inheritance' ); + + ::is( ::exception { + has '+bling' => (handles => ['hello']); + }, undef, '... we can add the handles attribute option' ); + + # this one will *not* work here .... + ::isnt( ::exception { + has '+blang' => (handles => ['hello']); + }, undef, '... we can not alter the handles attribute option' ); + ::is( ::exception { + has '+fail' => (isa => 'Ref'); + }, undef, '... can now create an attribute with an improper subtype relation' ); + ::isnt( ::exception { + has '+other_fail' => (trigger => sub {}); + }, undef, '... cannot create an attribute with an illegal option' ); + ::like( ::exception { + has '+does_not_exist' => (isa => 'Str'); + }, qr/in Bar/, '... cannot extend a non-existing attribute' ); +} + +my $foo = Foo->new; +isa_ok($foo, 'Foo'); + +is($foo->foo, undef, '... got the right undef default value'); +is( exception { $foo->foo('FooString') }, undef, '... assigned foo correctly' ); +is($foo->foo, 'FooString', '... got the right value for foo'); + +isnt( exception { $foo->foo([]) }, undef, '... foo is not coercing (as expected)' ); + +is($foo->bar, 'Foo::bar', '... got the right default value'); +isnt( exception { $foo->bar(10) }, undef, '... Foo::bar is a read/only attr' ); + +is($foo->baz, undef, '... got the right undef default value'); + +{ + my $hash_ref = {}; + is( exception { $foo->baz($hash_ref) }, undef, '... Foo::baz accepts hash refs' ); + is($foo->baz, $hash_ref, '... got the right value assigned to baz'); + + my $array_ref = []; + is( exception { $foo->baz($array_ref) }, undef, '... Foo::baz accepts an array ref' ); + is($foo->baz, $array_ref, '... got the right value assigned to baz'); + + my $scalar_ref = \(my $var); + is( exception { $foo->baz($scalar_ref) }, undef, '... Foo::baz accepts scalar ref' ); + is($foo->baz, $scalar_ref, '... got the right value assigned to baz'); + + is( exception { $foo->bunch_of_stuff([qw[one two three]]) }, undef, '... Foo::bunch_of_stuff accepts an array of strings' ); + + is( exception { $foo->one_last_one(sub { 'Hello World'}) }, undef, '... Foo::one_last_one accepts a code ref' ); + + my $code_ref = sub { 1 }; + is( exception { $foo->baz($code_ref) }, undef, '... Foo::baz accepts a code ref' ); + is($foo->baz, $code_ref, '... got the right value assigned to baz'); +} + +isnt( exception { + Bar->new; +}, undef, '... cannot create Bar without required gorch param' ); + +my $bar = Bar->new(gorch => 'Bar::gorch'); +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +is($bar->foo, undef, '... got the right undef default value'); +is( exception { $bar->foo('FooString') }, undef, '... assigned foo correctly' ); +is($bar->foo, 'FooString', '... got the right value for foo'); +is( exception { $bar->foo([]) }, undef, '... assigned foo correctly' ); +is($bar->foo, 'FooArrayRef', '... got the right value for foo'); + +is($bar->gorch, 'Bar::gorch', '... got the right default value'); + +is($bar->bar, 'Bar::bar', '... got the right default value'); +isnt( exception { $bar->bar(10) }, undef, '... Bar::bar is a read/only attr' ); + +is($bar->baz, undef, '... got the right undef default value'); + +{ + my $hash_ref = {}; + isnt( exception { $bar->baz($hash_ref) }, undef, '... Bar::baz does not accept hash refs' ); + + my $array_ref = []; + is( exception { $bar->baz($array_ref) }, undef, '... Bar::baz can accept an array ref' ); + is($bar->baz, $array_ref, '... got the right value assigned to baz'); + + my $scalar_ref = \(my $var); + isnt( exception { $bar->baz($scalar_ref) }, undef, '... Bar::baz does not accept a scalar ref' ); + + is( exception { $bar->bunch_of_stuff([1, 2, 3]) }, undef, '... Bar::bunch_of_stuff accepts an array of ints' ); + isnt( exception { $bar->bunch_of_stuff([qw[one two three]]) }, undef, '... Bar::bunch_of_stuff does not accept an array of strings' ); + + my $code_ref = sub { 1 }; + isnt( exception { $bar->baz($code_ref) }, undef, '... Bar::baz does not accept a code ref' ); +} + +# check some meta-stuff + +ok(Bar->meta->has_attribute('foo'), '... Bar has a foo attr'); +ok(Bar->meta->has_attribute('bar'), '... Bar has a bar attr'); +ok(Bar->meta->has_attribute('baz'), '... Bar has a baz attr'); +ok(Bar->meta->has_attribute('gorch'), '... Bar has a gorch attr'); +ok(Bar->meta->has_attribute('gloum'), '... Bar has a gloum attr'); +ok(Bar->meta->has_attribute('bling'), '... Bar has a bling attr'); +ok(Bar->meta->has_attribute('bunch_of_stuff'), '... Bar does have a bunch_of_stuff attr'); +ok(!Bar->meta->has_attribute('blang'), '... Bar has a blang attr'); +ok(Bar->meta->has_attribute('fail'), '... Bar has a fail attr'); +ok(!Bar->meta->has_attribute('other_fail'), '... Bar does not have an other_fail attr'); + +isnt(Foo->meta->get_attribute('foo'), + Bar->meta->get_attribute('foo'), + '... Foo and Bar have different copies of foo'); +isnt(Foo->meta->get_attribute('bar'), + Bar->meta->get_attribute('bar'), + '... Foo and Bar have different copies of bar'); +isnt(Foo->meta->get_attribute('baz'), + Bar->meta->get_attribute('baz'), + '... Foo and Bar have different copies of baz'); +isnt(Foo->meta->get_attribute('gorch'), + Bar->meta->get_attribute('gorch'), + '... Foo and Bar have different copies of gorch'); +isnt(Foo->meta->get_attribute('gloum'), + Bar->meta->get_attribute('gloum'), + '... Foo and Bar have different copies of gloum'); +isnt(Foo->meta->get_attribute('bling'), + Bar->meta->get_attribute('bling'), + '... Foo and Bar have different copies of bling'); +isnt(Foo->meta->get_attribute('bunch_of_stuff'), + Bar->meta->get_attribute('bunch_of_stuff'), + '... Foo and Bar have different copies of bunch_of_stuff'); + +ok(Bar->meta->get_attribute('bar')->has_type_constraint, + '... Bar::bar inherited the type constraint too'); +ok(Bar->meta->get_attribute('baz')->has_type_constraint, + '... Bar::baz inherited the type constraint too'); + +is(Bar->meta->get_attribute('bar')->type_constraint->name, + 'Str', '... Bar::bar inherited the right type constraint too'); + +is(Foo->meta->get_attribute('baz')->type_constraint->name, + 'Ref', '... Foo::baz inherited the right type constraint too'); +is(Bar->meta->get_attribute('baz')->type_constraint->name, + 'ArrayRef', '... Bar::baz inherited the right type constraint too'); + +ok(!Foo->meta->get_attribute('gorch')->is_required, + '... Foo::gorch is not a required attr'); +ok(Bar->meta->get_attribute('gorch')->is_required, + '... Bar::gorch is a required attr'); + +is(Foo->meta->get_attribute('bunch_of_stuff')->type_constraint->name, + 'ArrayRef', + '... Foo::bunch_of_stuff is an ArrayRef'); +is(Bar->meta->get_attribute('bunch_of_stuff')->type_constraint->name, + 'ArrayRef[Int]', + '... Bar::bunch_of_stuff is an ArrayRef[Int]'); + +ok(!Foo->meta->get_attribute('gloum')->is_lazy, + '... Foo::gloum is not a required attr'); +ok(Bar->meta->get_attribute('gloum')->is_lazy, + '... Bar::gloum is a required attr'); + +ok(!Foo->meta->get_attribute('foo')->should_coerce, + '... Foo::foo should not coerce'); +ok(Bar->meta->get_attribute('foo')->should_coerce, + '... Bar::foo should coerce'); + +ok(!Foo->meta->get_attribute('bling')->has_handles, + '... Foo::foo should not handles'); +ok(Bar->meta->get_attribute('bling')->has_handles, + '... Bar::foo should handles'); + +done_testing; diff --git a/t/attributes/attribute_lazy_initializer.t b/t/attributes/attribute_lazy_initializer.t new file mode 100644 index 0000000..7651ea4 --- /dev/null +++ b/t/attributes/attribute_lazy_initializer.t @@ -0,0 +1,148 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + + has 'foo' => ( + reader => 'get_foo', + writer => 'set_foo', + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Moose::Meta::Attribute'); + ::is($attr->name, 'foo', '... got the right name'); + + $callback->($value * 2); + }, + ); + + has 'lazy_foo' => ( + reader => 'get_lazy_foo', + lazy => 1, + default => 10, + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Moose::Meta::Attribute'); + ::is($attr->name, 'lazy_foo', '... got the right name'); + + $callback->($value * 2); + }, + ); + + has 'lazy_foo_w_type' => ( + reader => 'get_lazy_foo_w_type', + isa => 'Int', + lazy => 1, + default => 20, + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Moose::Meta::Attribute'); + ::is($attr->name, 'lazy_foo_w_type', '... got the right name'); + + $callback->($value * 2); + }, + ); + + has 'lazy_foo_builder' => ( + reader => 'get_lazy_foo_builder', + builder => 'get_foo_builder', + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Moose::Meta::Attribute'); + ::is($attr->name, 'lazy_foo_builder', '... got the right name'); + + $callback->($value * 2); + }, + ); + + has 'lazy_foo_builder_w_type' => ( + reader => 'get_lazy_foo_builder_w_type', + isa => 'Int', + builder => 'get_foo_builder_w_type', + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Moose::Meta::Attribute'); + ::is($attr->name, 'lazy_foo_builder_w_type', '... got the right name'); + + $callback->($value * 2); + }, + ); + + sub get_foo_builder { 100 } + sub get_foo_builder_w_type { 1000 } +} + +{ + my $foo = Foo->new(foo => 10); + isa_ok($foo, 'Foo'); + + is($foo->get_foo, 20, 'initial value set to 2x given value'); + is($foo->get_lazy_foo, 20, 'initial lazy value set to 2x given value'); + is($foo->get_lazy_foo_w_type, 40, 'initial lazy value with type set to 2x given value'); + is($foo->get_lazy_foo_builder, 200, 'initial lazy value with builder set to 2x given value'); + is($foo->get_lazy_foo_builder_w_type, 2000, 'initial lazy value with builder and type set to 2x given value'); +} + +{ + package Bar; + use Moose; + + has 'foo' => ( + reader => 'get_foo', + writer => 'set_foo', + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Moose::Meta::Attribute'); + ::is($attr->name, 'foo', '... got the right name'); + + $callback->($value * 2); + }, + ); + + __PACKAGE__->meta->make_immutable; +} + +{ + my $bar = Bar->new(foo => 10); + isa_ok($bar, 'Bar'); + + is($bar->get_foo, 20, 'initial value set to 2x given value'); +} + +{ + package Fail::Bar; + use Moose; + + has 'foo' => ( + reader => 'get_foo', + writer => 'set_foo', + isa => 'Int', + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Moose::Meta::Attribute'); + ::is($attr->name, 'foo', '... got the right name'); + + $callback->("Hello $value World"); + }, + ); + + __PACKAGE__->meta->make_immutable; +} + +isnt( exception { + Fail::Bar->new(foo => 10) +}, undef, '... this fails, because initializer returns a bad type' ); + +done_testing; diff --git a/t/attributes/attribute_names.t b/t/attributes/attribute_names.t new file mode 100644 index 0000000..af6ee1e --- /dev/null +++ b/t/attributes/attribute_names.t @@ -0,0 +1,57 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +my $exception_regex = qr/You must provide a name for the attribute/; +{ + package My::Role; + use Moose::Role; + + ::like( ::exception { + has; + }, $exception_regex, 'has; fails' ); + + ::like( ::exception { + has undef; + }, $exception_regex, 'has undef; fails' ); + + ::is( ::exception { + has "" => ( + is => 'bare', + ); + }, undef, 'has ""; works now' ); + + ::is( ::exception { + has 0 => ( + is => 'bare', + ); + }, undef, 'has 0; works now' ); +} + +{ + package My::Class; + use Moose; + + ::like( ::exception { + has; + }, $exception_regex, 'has; fails' ); + + ::like( ::exception { + has undef; + }, $exception_regex, 'has undef; fails' ); + + ::is( ::exception { + has "" => ( + is => 'bare', + ); + }, undef, 'has ""; works now' ); + + ::is( ::exception { + has 0 => ( + is => 'bare', + ); + }, undef, 'has 0; works now' ); +} + +done_testing; diff --git a/t/attributes/attribute_reader_generation.t b/t/attributes/attribute_reader_generation.t new file mode 100644 index 0000000..8c2e257 --- /dev/null +++ b/t/attributes/attribute_reader_generation.t @@ -0,0 +1,103 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + + eval { + has 'foo' => ( + reader => 'get_foo' + ); + }; + ::ok(!$@, '... created the reader method okay'); + + eval { + has 'lazy_foo' => ( + reader => 'get_lazy_foo', + lazy => 1, + default => sub { 10 } + ); + }; + ::ok(!$@, '... created the lazy reader method okay') or warn $@; + + eval { + has 'lazy_weak_foo' => ( + reader => 'get_lazy_weak_foo', + lazy => 1, + default => sub { our $AREF = [] }, + weak_ref => 1, + ); + }; + ::ok(!$@, '... created the lazy weak reader method okay') or warn $@; + + my $warn; + + eval { + local $SIG{__WARN__} = sub { $warn = $_[0] }; + has 'mtfnpy' => ( + reder => 'get_mftnpy' + ); + }; + ::ok($warn, '... got a warning for mispelled attribute argument'); +} + +{ + my $foo = Foo->new; + isa_ok($foo, 'Foo'); + + can_ok($foo, 'get_foo'); + is($foo->get_foo(), undef, '... got an undefined value'); + isnt( exception { + $foo->get_foo(100); + }, undef, '... get_foo is a read-only' ); + + ok(!exists($foo->{lazy_foo}), '... no value in get_lazy_foo slot'); + + can_ok($foo, 'get_lazy_foo'); + is($foo->get_lazy_foo(), 10, '... got an deferred value'); + isnt( exception { + $foo->get_lazy_foo(100); + }, undef, '... get_lazy_foo is a read-only' ); + + is($foo->get_lazy_weak_foo(), $Foo::AREF, 'got the right value'); + ok($foo->meta->get_meta_instance->slot_value_is_weak($foo, 'lazy_weak_foo'), + '... and it is weak'); +} + +{ + my $foo = Foo->new; + isa_ok($foo, 'Foo'); + + my $attr = $foo->meta->find_attribute_by_name("lazy_foo"); + + isa_ok( $attr, "Moose::Meta::Attribute" ); + + ok( $attr->is_lazy, "it's lazy" ); + + is( $attr->get_raw_value($foo), undef, "raw value" ); + + is( $attr->get_value($foo), 10, "lazy value" ); + + is( $attr->get_raw_value($foo), 10, "raw value" ); + + my $lazy_weak_attr = $foo->meta->find_attribute_by_name("lazy_weak_foo"); + + is( $lazy_weak_attr->get_value($foo), $Foo::AREF, "it's the right value" ); + + ok( $foo->meta->get_meta_instance->slot_value_is_weak($foo, 'lazy_weak_foo'), "and it is weak"); +} + +{ + my $foo = Foo->new(foo => 10, lazy_foo => 100); + isa_ok($foo, 'Foo'); + + is($foo->get_foo(), 10, '... got the correct value'); + is($foo->get_lazy_foo(), 100, '... got the correct value'); +} + +done_testing; diff --git a/t/attributes/attribute_required.t b/t/attributes/attribute_required.t new file mode 100644 index 0000000..f0b39b2 --- /dev/null +++ b/t/attributes/attribute_required.t @@ -0,0 +1,66 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + + has 'bar' => (is => 'ro', required => 1); + has 'baz' => (is => 'rw', default => 100, required => 1); + has 'boo' => (is => 'rw', lazy => 1, default => 50, required => 1); +} + +{ + my $foo = Foo->new(bar => 10, baz => 20, boo => 100); + isa_ok($foo, 'Foo'); + + is($foo->bar, 10, '... got the right bar'); + is($foo->baz, 20, '... got the right baz'); + is($foo->boo, 100, '... got the right boo'); +} + +{ + my $foo = Foo->new(bar => 10, boo => 5); + isa_ok($foo, 'Foo'); + + is($foo->bar, 10, '... got the right bar'); + is($foo->baz, 100, '... got the right baz'); + is($foo->boo, 5, '... got the right boo'); +} + +{ + my $foo = Foo->new(bar => 10); + isa_ok($foo, 'Foo'); + + is($foo->bar, 10, '... got the right bar'); + is($foo->baz, 100, '... got the right baz'); + is($foo->boo, 50, '... got the right boo'); +} + +#Yeah.. this doesn't work like this anymore, see below. (groditi) +#throws_ok { +# Foo->new(bar => 10, baz => undef); +#} qr/^Attribute \(baz\) is required and cannot be undef/, '... must supply all the required attribute'; + +#throws_ok { +# Foo->new(bar => 10, boo => undef); +#} qr/^Attribute \(boo\) is required and cannot be undef/, '... must supply all the required attribute'; + +is( exception { + Foo->new(bar => 10, baz => undef); +}, undef, '... undef is a valid attribute value' ); + +is( exception { + Foo->new(bar => 10, boo => undef); +}, undef, '... undef is a valid attribute value' ); + + +like( exception { + Foo->new; +}, qr/^Attribute \(bar\) is required/, '... must supply all the required attribute' ); + +done_testing; diff --git a/t/attributes/attribute_traits.t b/t/attributes/attribute_traits.t new file mode 100644 index 0000000..bcdf491 --- /dev/null +++ b/t/attributes/attribute_traits.t @@ -0,0 +1,63 @@ +use strict; +use warnings; + +use Test::More; +use Test::Moose; + + +{ + package My::Attribute::Trait; + use Moose::Role; + + has 'alias_to' => (is => 'ro', isa => 'Str'); + + has foo => ( is => "ro", default => "blah" ); + + after 'install_accessors' => sub { + my $self = shift; + $self->associated_class->add_method( + $self->alias_to, + $self->get_read_method_ref + ); + }; +} + +{ + package My::Class; + use Moose; + + has 'bar' => ( + traits => [qw/My::Attribute::Trait/], + is => 'ro', + isa => 'Int', + alias_to => 'baz', + ); + + has 'gorch' => ( + is => 'ro', + isa => 'Int', + default => sub { 10 } + ); +} + +my $c = My::Class->new(bar => 100); +isa_ok($c, 'My::Class'); + +is($c->bar, 100, '... got the right value for bar'); +is($c->gorch, 10, '... got the right value for gorch'); + +can_ok($c, 'baz'); +is($c->baz, 100, '... got the right value for baz'); + +my $bar_attr = $c->meta->get_attribute('bar'); +does_ok($bar_attr, 'My::Attribute::Trait'); +ok($bar_attr->has_applied_traits, '... got the applied traits'); +is_deeply($bar_attr->applied_traits, [qw/My::Attribute::Trait/], '... got the applied traits'); +is($bar_attr->foo, "blah", "attr initialized"); + +my $gorch_attr = $c->meta->get_attribute('gorch'); +ok(!$gorch_attr->does('My::Attribute::Trait'), '... gorch doesnt do the trait'); +ok(!$gorch_attr->has_applied_traits, '... no traits applied'); +is($gorch_attr->applied_traits, undef, '... no traits applied'); + +done_testing; diff --git a/t/attributes/attribute_traits_n_meta.t b/t/attributes/attribute_traits_n_meta.t new file mode 100644 index 0000000..dd43a45 --- /dev/null +++ b/t/attributes/attribute_traits_n_meta.t @@ -0,0 +1,63 @@ +use strict; +use warnings; + +use Test::More; +use Test::Moose; + + + +{ + package My::Meta::Attribute::DefaultReadOnly; + use Moose; + + extends 'Moose::Meta::Attribute'; + + around 'new' => sub { + my $next = shift; + my ($self, $name, %options) = @_; + $options{is} = 'ro' + unless exists $options{is}; + $next->($self, $name, %options); + }; +} + +{ + package My::Attribute::Trait; + use Moose::Role; + + has 'alias_to' => (is => 'ro', isa => 'Str'); + + after 'install_accessors' => sub { + my $self = shift; + $self->associated_class->add_method( + $self->alias_to, + $self->get_read_method_ref + ); + }; +} + +{ + package My::Class; + use Moose; + + has 'bar' => ( + metaclass => 'My::Meta::Attribute::DefaultReadOnly', + traits => [qw/My::Attribute::Trait/], + isa => 'Int', + alias_to => 'baz', + ); +} + +my $c = My::Class->new(bar => 100); +isa_ok($c, 'My::Class'); + +is($c->bar, 100, '... got the right value for bar'); + +can_ok($c, 'baz'); +is($c->baz, 100, '... got the right value for baz'); + +isa_ok($c->meta->get_attribute('bar'), 'My::Meta::Attribute::DefaultReadOnly'); +does_ok($c->meta->get_attribute('bar'), 'My::Attribute::Trait'); +is($c->meta->get_attribute('bar')->_is_metadata, 'ro', '... got the right metaclass customization'); + +done_testing; diff --git a/t/attributes/attribute_traits_parameterized.t b/t/attributes/attribute_traits_parameterized.t new file mode 100644 index 0000000..cdf84b0 --- /dev/null +++ b/t/attributes/attribute_traits_parameterized.t @@ -0,0 +1,57 @@ +use strict; +use warnings; +use Test::More; + +{ + package My::Attribute::Trait; + use Moose::Role; + + sub reversed_name { + my $self = shift; + scalar reverse $self->name; + } +} + +{ + package My::Class; + use Moose; + + has foo => ( + traits => [ + 'My::Attribute::Trait' => { + -alias => { + reversed_name => 'eman', + }, + }, + ], + is => 'bare', + ); +} + +{ + package My::Other::Class; + use Moose; + + has foo => ( + traits => [ + 'My::Attribute::Trait' => { + -alias => { + reversed_name => 'reversed', + }, + -excludes => 'reversed_name', + }, + ], + is => 'bare', + ); +} + +my $attr = My::Class->meta->get_attribute('foo'); +is($attr->eman, 'oof', 'the aliased method is in the attribute'); +ok(!$attr->can('reversed'), "the method was not installed under the other class' alias"); + +my $other_attr = My::Other::Class->meta->get_attribute('foo'); +is($other_attr->reversed, 'oof', 'the aliased method is in the attribute'); +ok(!$other_attr->can('enam'), "the method was not installed under the other class' alias"); +ok(!$other_attr->can('reversed_name'), "the method was not installed under the original name when that was excluded"); + +done_testing; diff --git a/t/attributes/attribute_traits_registered.t b/t/attributes/attribute_traits_registered.t new file mode 100644 index 0000000..3ce332a --- /dev/null +++ b/t/attributes/attribute_traits_registered.t @@ -0,0 +1,114 @@ +use strict; +use warnings; + +use Test::More; +use Test::Moose; + + +{ + package My::Attribute::Trait; + use Moose::Role; + + has 'alias_to' => (is => 'ro', isa => 'Str'); + + has foo => ( is => "ro", default => "blah" ); + + after 'install_accessors' => sub { + my $self = shift; + $self->associated_class->add_method( + $self->alias_to, + $self->get_read_method_ref + ); + }; + + package Moose::Meta::Attribute::Custom::Trait::Aliased; + sub register_implementation { 'My::Attribute::Trait' } +} + +{ + package My::Other::Attribute::Trait; + use Moose::Role; + + my $method = sub { + 42; + }; + + has the_other_attr => ( isa => "Str", is => "rw", default => "oink" ); + + after 'install_accessors' => sub { + my $self = shift; + $self->associated_class->add_method( + 'additional_method', + $method + ); + }; + + package Moose::Meta::Attribute::Custom::Trait::Other; + sub register_implementation { 'My::Other::Attribute::Trait' } +} + +{ + package My::Class; + use Moose; + + has 'bar' => ( + traits => [qw/Aliased/], + is => 'ro', + isa => 'Int', + alias_to => 'baz', + ); +} + +{ + package My::Derived::Class; + use Moose; + + extends 'My::Class'; + + has '+bar' => ( + traits => [qw/Other/], + ); +} + +my $c = My::Class->new(bar => 100); +isa_ok($c, 'My::Class'); + +is($c->bar, 100, '... got the right value for bar'); + +can_ok($c, 'baz') and +is($c->baz, 100, '... got the right value for baz'); + +my $bar_attr = $c->meta->get_attribute('bar'); +does_ok($bar_attr, 'My::Attribute::Trait'); +is($bar_attr->foo, "blah", "attr initialized"); + +ok(!$bar_attr->meta->does_role('Aliased'), "does_role ignores aliases for sanity"); +ok($bar_attr->does('Aliased'), "attr->does uses aliases"); +ok(!$bar_attr->meta->does_role('Fictional'), "does_role returns false for nonexistent roles"); +ok(!$bar_attr->does('Fictional'), "attr->does returns false for nonexistent roles"); + +my $quux = My::Derived::Class->new(bar => 1000); + +is($quux->bar, 1000, '... got the right value for bar'); + +can_ok($quux, 'baz'); +is($quux->baz, 1000, '... got the right value for baz'); + +my $derived_bar_attr = $quux->meta->get_attribute("bar"); +does_ok($derived_bar_attr, 'My::Attribute::Trait' ); + +is( $derived_bar_attr->foo, "blah", "attr initialized" ); + +does_ok($derived_bar_attr, 'My::Other::Attribute::Trait' ); + +is($derived_bar_attr->the_other_attr, "oink", "attr initialized" ); + +ok(!$derived_bar_attr->meta->does_role('Aliased'), "does_role ignores aliases for sanity"); +ok($derived_bar_attr->does('Aliased'), "attr->does uses aliases"); +ok(!$derived_bar_attr->meta->does_role('Fictional'), "does_role returns false for nonexistent roles"); +ok(!$derived_bar_attr->does('Fictional'), "attr->does returns false for nonexistent roles"); + +can_ok($quux, 'additional_method'); +is(eval { $quux->additional_method }, 42, '... got the right value for additional_method'); + +done_testing; diff --git a/t/attributes/attribute_triggers.t b/t/attributes/attribute_triggers.t new file mode 100644 index 0000000..5b86ac6 --- /dev/null +++ b/t/attributes/attribute_triggers.t @@ -0,0 +1,219 @@ +use strict; +use warnings; + +use Scalar::Util 'isweak'; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + + has 'bar' => (is => 'rw', + isa => 'Maybe[Bar]', + trigger => sub { + my ($self, $bar) = @_; + $bar->foo($self) if defined $bar; + }); + + has 'baz' => (writer => 'set_baz', + reader => 'get_baz', + isa => 'Baz', + trigger => sub { + my ($self, $baz) = @_; + $baz->foo($self); + }); + + + package Bar; + use Moose; + + has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1); + + package Baz; + use Moose; + + has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1); +} + +{ + my $foo = Foo->new; + isa_ok($foo, 'Foo'); + + my $bar = Bar->new; + isa_ok($bar, 'Bar'); + + my $baz = Baz->new; + isa_ok($baz, 'Baz'); + + is( exception { + $foo->bar($bar); + }, undef, '... did not die setting bar' ); + + is($foo->bar, $bar, '... set the value foo.bar correctly'); + is($bar->foo, $foo, '... which in turn set the value bar.foo correctly'); + + ok(isweak($bar->{foo}), '... bar.foo is a weak reference'); + + is( exception { + $foo->bar(undef); + }, undef, '... did not die un-setting bar' ); + + is($foo->bar, undef, '... set the value foo.bar correctly'); + is($bar->foo, $foo, '... which in turn set the value bar.foo correctly'); + + # test the writer + + is( exception { + $foo->set_baz($baz); + }, undef, '... did not die setting baz' ); + + is($foo->get_baz, $baz, '... set the value foo.baz correctly'); + is($baz->foo, $foo, '... which in turn set the value baz.foo correctly'); + + ok(isweak($baz->{foo}), '... baz.foo is a weak reference'); +} + +{ + my $bar = Bar->new; + isa_ok($bar, 'Bar'); + + my $baz = Baz->new; + isa_ok($baz, 'Baz'); + + my $foo = Foo->new(bar => $bar, baz => $baz); + isa_ok($foo, 'Foo'); + + is($foo->bar, $bar, '... set the value foo.bar correctly'); + is($bar->foo, $foo, '... which in turn set the value bar.foo correctly'); + + ok(isweak($bar->{foo}), '... bar.foo is a weak reference'); + + is($foo->get_baz, $baz, '... set the value foo.baz correctly'); + is($baz->foo, $foo, '... which in turn set the value baz.foo correctly'); + + ok(isweak($baz->{foo}), '... baz.foo is a weak reference'); +} + +# some errors + +{ + package Bling; + use Moose; + + ::isnt( ::exception { + has('bling' => (is => 'rw', trigger => 'Fail')); + }, undef, '... a trigger must be a CODE ref' ); + + ::isnt( ::exception { + has('bling' => (is => 'rw', trigger => [])); + }, undef, '... a trigger must be a CODE ref' ); +} + +# Triggers do not fire on built values + +{ + package Blarg; + use Moose; + + our %trigger_calls; + our %trigger_vals; + has foo => (is => 'rw', default => sub { 'default foo value' }, + trigger => sub { my ($self, $val, $attr) = @_; + $trigger_calls{foo}++; + $trigger_vals{foo} = $val }); + has bar => (is => 'rw', lazy_build => 1, + trigger => sub { my ($self, $val, $attr) = @_; + $trigger_calls{bar}++; + $trigger_vals{bar} = $val }); + sub _build_bar { return 'default bar value' } + has baz => (is => 'rw', builder => '_build_baz', + trigger => sub { my ($self, $val, $attr) = @_; + $trigger_calls{baz}++; + $trigger_vals{baz} = $val }); + sub _build_baz { return 'default baz value' } +} + +{ + my $blarg; + is( exception { $blarg = Blarg->new; }, undef, 'Blarg->new() lives' ); + ok($blarg, 'Have a $blarg'); + foreach my $attr (qw/foo bar baz/) { + is($blarg->$attr(), "default $attr value", "$attr has default value"); + } + is_deeply(\%Blarg::trigger_calls, {}, 'No triggers fired'); + foreach my $attr (qw/foo bar baz/) { + $blarg->$attr("Different $attr value"); + } + is_deeply(\%Blarg::trigger_calls, { map { $_ => 1 } qw/foo bar baz/ }, 'All triggers fired once on assign'); + is_deeply(\%Blarg::trigger_vals, { map { $_ => "Different $_ value" } qw/foo bar baz/ }, 'All triggers given assigned values'); + + is( exception { $blarg => Blarg->new( map { $_ => "Yet another $_ value" } qw/foo bar baz/ ) }, undef, '->new() with parameters' ); + is_deeply(\%Blarg::trigger_calls, { map { $_ => 2 } qw/foo bar baz/ }, 'All triggers fired once on construct'); + is_deeply(\%Blarg::trigger_vals, { map { $_ => "Yet another $_ value" } qw/foo bar baz/ }, 'All triggers given assigned values'); +} + +# Triggers do not receive the meta-attribute as an argument, but do +# receive the old value + +{ + package Foo; + use Moose; + our @calls; + has foo => (is => 'rw', trigger => sub { push @calls, [@_] }); +} + +{ + my $attr = Foo->meta->get_attribute('foo'); + + my $foo = Foo->new; + $attr->set_value( $foo, 2 ); + + is_deeply( + \@Foo::calls, + [ [ $foo, 2 ] ], + 'trigger called correctly on initial set via meta-API', + ); + @Foo::calls = (); + + $attr->set_value( $foo, 3 ); + + is_deeply( + \@Foo::calls, + [ [ $foo, 3, 2 ] ], + 'trigger called correctly on second set via meta-API', + ); + @Foo::calls = (); + + $attr->set_raw_value( $foo, 4 ); + + is_deeply( + \@Foo::calls, + [ ], + 'trigger not called using set_raw_value method', + ); + @Foo::calls = (); +} + +{ + my $foo = Foo->new(foo => 2); + is_deeply( + \@Foo::calls, + [ [ $foo, 2 ] ], + 'trigger called correctly on construction', + ); + @Foo::calls = (); + + $foo->foo(3); + is_deeply( + \@Foo::calls, + [ [ $foo, 3, 2 ] ], + 'trigger called correctly on set (with old value)', + ); + @Foo::calls = (); + Foo->meta->make_immutable, redo if Foo->meta->is_mutable; +} + +done_testing; diff --git a/t/attributes/attribute_type_unions.t b/t/attributes/attribute_type_unions.t new file mode 100644 index 0000000..ab0ed60 --- /dev/null +++ b/t/attributes/attribute_type_unions.t @@ -0,0 +1,96 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + + has 'bar' => (is => 'rw', isa => 'ArrayRef | HashRef'); +} + +my $foo = Foo->new; +isa_ok($foo, 'Foo'); + +is( exception { + $foo->bar([]) +}, undef, '... set bar successfully with an ARRAY ref' ); + +is( exception { + $foo->bar({}) +}, undef, '... set bar successfully with a HASH ref' ); + +isnt( exception { + $foo->bar(100) +}, undef, '... couldnt set bar successfully with a number' ); + +isnt( exception { + $foo->bar(sub {}) +}, undef, '... couldnt set bar successfully with a CODE ref' ); + +# check the constructor + +is( exception { + Foo->new(bar => []) +}, undef, '... created new Foo with bar successfully set with an ARRAY ref' ); + +is( exception { + Foo->new(bar => {}) +}, undef, '... created new Foo with bar successfully set with a HASH ref' ); + +isnt( exception { + Foo->new(bar => 50) +}, undef, '... didnt create a new Foo with bar as a number' ); + +isnt( exception { + Foo->new(bar => sub {}) +}, undef, '... didnt create a new Foo with bar as a CODE ref' ); + +{ + package Bar; + use Moose; + + has 'baz' => (is => 'rw', isa => 'Str | CodeRef'); +} + +my $bar = Bar->new; +isa_ok($bar, 'Bar'); + +is( exception { + $bar->baz('a string') +}, undef, '... set baz successfully with a string' ); + +is( exception { + $bar->baz(sub { 'a sub' }) +}, undef, '... set baz successfully with a CODE ref' ); + +isnt( exception { + $bar->baz(\(my $var1)) +}, undef, '... couldnt set baz successfully with a SCALAR ref' ); + +isnt( exception { + $bar->baz({}) +}, undef, '... couldnt set bar successfully with a HASH ref' ); + +# check the constructor + +is( exception { + Bar->new(baz => 'a string') +}, undef, '... created new Bar with baz successfully set with a string' ); + +is( exception { + Bar->new(baz => sub { 'a sub' }) +}, undef, '... created new Bar with baz successfully set with a CODE ref' ); + +isnt( exception { + Bar->new(baz => \(my $var2)) +}, undef, '... didnt create a new Bar with baz as a number' ); + +isnt( exception { + Bar->new(baz => {}) +}, undef, '... didnt create a new Bar with baz as a HASH ref' ); + +done_testing; diff --git a/t/attributes/attribute_without_any_methods.t b/t/attributes/attribute_without_any_methods.t new file mode 100644 index 0000000..f1310fb --- /dev/null +++ b/t/attributes/attribute_without_any_methods.t @@ -0,0 +1,22 @@ +use strict; +use warnings; + +use Test::More; + +use Moose (); +use Moose::Meta::Class; + +my $meta = Moose::Meta::Class->create('Banana'); + +my $warn; +$SIG{__WARN__} = sub { $warn = "@_" }; + +$meta->add_attribute('foo'); +like $warn, qr/Attribute \(foo\) of class Banana has no associated methods/, + 'correct error message'; + +$warn = ''; +$meta->add_attribute('bar', is => 'bare'); +is $warn, '', 'add attribute with no methods and is => "bare"'; + +done_testing; diff --git a/t/attributes/attribute_writer_generation.t b/t/attributes/attribute_writer_generation.t new file mode 100644 index 0000000..ceb5acb --- /dev/null +++ b/t/attributes/attribute_writer_generation.t @@ -0,0 +1,117 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Scalar::Util 'isweak'; + + +{ + package Foo; + use Moose; + + eval { + has 'foo' => ( + reader => 'get_foo', + writer => 'set_foo', + ); + }; + ::ok(!$@, '... created the writer method okay'); + + eval { + has 'foo_required' => ( + reader => 'get_foo_required', + writer => 'set_foo_required', + required => 1, + ); + }; + ::ok(!$@, '... created the required writer method okay'); + + eval { + has 'foo_int' => ( + reader => 'get_foo_int', + writer => 'set_foo_int', + isa => 'Int', + ); + }; + ::ok(!$@, '... created the writer method with type constraint okay'); + + eval { + has 'foo_weak' => ( + reader => 'get_foo_weak', + writer => 'set_foo_weak', + weak_ref => 1 + ); + }; + ::ok(!$@, '... created the writer method with weak_ref okay'); +} + +{ + my $foo = Foo->new(foo_required => 'required'); + isa_ok($foo, 'Foo'); + + # regular writer + + can_ok($foo, 'set_foo'); + is($foo->get_foo(), undef, '... got an unset value'); + is( exception { + $foo->set_foo(100); + }, undef, '... set_foo wrote successfully' ); + is($foo->get_foo(), 100, '... got the correct set value'); + + ok(!isweak($foo->{foo}), '... it is not a weak reference'); + + # required writer + + isnt( exception { + Foo->new; + }, undef, '... cannot create without the required attribute' ); + + can_ok($foo, 'set_foo_required'); + is($foo->get_foo_required(), 'required', '... got an unset value'); + is( exception { + $foo->set_foo_required(100); + }, undef, '... set_foo_required wrote successfully' ); + is($foo->get_foo_required(), 100, '... got the correct set value'); + + isnt( exception { + $foo->set_foo_required(); + }, undef, '... set_foo_required died successfully with no value' ); + + is( exception { + $foo->set_foo_required(undef); + }, undef, '... set_foo_required did accept undef' ); + + ok(!isweak($foo->{foo_required}), '... it is not a weak reference'); + + # with type constraint + + can_ok($foo, 'set_foo_int'); + is($foo->get_foo_int(), undef, '... got an unset value'); + is( exception { + $foo->set_foo_int(100); + }, undef, '... set_foo_int wrote successfully' ); + is($foo->get_foo_int(), 100, '... got the correct set value'); + + isnt( exception { + $foo->set_foo_int("Foo"); + }, undef, '... set_foo_int died successfully' ); + + ok(!isweak($foo->{foo_int}), '... it is not a weak reference'); + + # with weak_ref + + my $test = []; + + can_ok($foo, 'set_foo_weak'); + is($foo->get_foo_weak(), undef, '... got an unset value'); + is( exception { + $foo->set_foo_weak($test); + }, undef, '... set_foo_weak wrote successfully' ); + is($foo->get_foo_weak(), $test, '... got the correct set value'); + + ok(isweak($foo->{foo_weak}), '... it is a weak reference'); +} + +done_testing; diff --git a/t/attributes/bad_coerce.t b/t/attributes/bad_coerce.t new file mode 100644 index 0000000..daffe91 --- /dev/null +++ b/t/attributes/bad_coerce.t @@ -0,0 +1,33 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package Foo; + + use Moose; + + ::like(::exception { + has foo => ( + is => 'ro', + isa => 'Str', + coerce => 1, + ); + }, + qr/\QYou cannot coerce an attribute (foo) unless its type (Str) has a coercion/, + 'Cannot coerce unless the type has a coercion'); + + ::like(::exception { + has bar => ( + is => 'ro', + isa => 'Str', + coerce => 1, + ); + }, + qr/\QYou cannot coerce an attribute (bar) unless its type (Str) has a coercion/, + 'Cannot coerce unless the type has a coercion - different attribute'); +} + +done_testing; diff --git a/t/attributes/chained_coercion.t b/t/attributes/chained_coercion.t new file mode 100644 index 0000000..853f251 --- /dev/null +++ b/t/attributes/chained_coercion.t @@ -0,0 +1,46 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Baz; + use Moose; + use Moose::Util::TypeConstraints; + + coerce 'Baz' => from 'HashRef' => via { Baz->new($_) }; + + has 'hello' => ( + is => 'ro', + isa => 'Str', + ); + + package Bar; + use Moose; + use Moose::Util::TypeConstraints; + + coerce 'Bar' => from 'HashRef' => via { Bar->new($_) }; + + has 'baz' => ( + is => 'ro', + isa => 'Baz', + coerce => 1 + ); + + package Foo; + use Moose; + + has 'bar' => ( + is => 'ro', + isa => 'Bar', + coerce => 1, + ); +} + +my $foo = Foo->new(bar => { baz => { hello => 'World' } }); +isa_ok($foo, 'Foo'); +isa_ok($foo->bar, 'Bar'); +isa_ok($foo->bar->baz, 'Baz'); +is($foo->bar->baz->hello, 'World', '... this all worked fine'); + +done_testing; diff --git a/t/attributes/clone_weak.t b/t/attributes/clone_weak.t new file mode 100644 index 0000000..1f5162d --- /dev/null +++ b/t/attributes/clone_weak.t @@ -0,0 +1,177 @@ +use strict; +use warnings; +use Test::More; + +{ + package Foo; + use Moose; + + has bar => ( + is => 'ro', + weak_ref => 1, + ); +} + +{ + package MyScopeGuard; + + sub new { + my ($class, $cb) = @_; + bless { cb => $cb }, $class; + } + + sub DESTROY { shift->{cb}->() } +} + +{ + my $destroyed = 0; + + my $foo = do { + my $bar = MyScopeGuard->new(sub { $destroyed++ }); + my $foo = Foo->new({ bar => $bar }); + my $clone = $foo->meta->clone_object($foo); + + is $destroyed, 0; + + $clone; + }; + + isa_ok($foo, 'Foo'); + is $foo->bar, undef; + is $destroyed, 1; +} + +{ + my $clone; + { + my $anon = Moose::Meta::Class->create_anon_class; + + my $foo = $anon->new_object; + isa_ok($foo, $anon->name); + ok(Class::MOP::class_of($foo), "has a metaclass"); + + $clone = $anon->clone_object($foo); + isa_ok($clone, $anon->name); + ok(Class::MOP::class_of($clone), "has a metaclass"); + } + + ok(Class::MOP::class_of($clone), "still has a metaclass"); +} + +{ + package Foo::Meta::Attr::Trait; + use Moose::Role; + + has value_slot => ( + is => 'ro', + isa => 'Str', + lazy => 1, + default => sub { shift->name }, + ); + + has count_slot => ( + is => 'ro', + isa => 'Str', + lazy => 1, + default => sub { '<<COUNT>>' . shift->name }, + ); + + sub slots { + my $self = shift; + return ($self->value_slot, $self->count_slot); + } + + sub _set_count { + my $self = shift; + my ($instance) = @_; + my $mi = $self->associated_class->get_meta_instance; + $mi->set_slot_value( + $instance, + $self->count_slot, + ($mi->get_slot_value($instance, $self->count_slot) || 0) + 1, + ); + } + + sub _clear_count { + my $self = shift; + my ($instance) = @_; + $self->associated_class->get_meta_instance->deinitialize_slot( + $instance, $self->count_slot + ); + } + + sub has_count { + my $self = shift; + my ($instance) = @_; + $self->associated_class->get_meta_instance->has_slot_value( + $instance, $self->count_slot + ); + } + + sub count { + my $self = shift; + my ($instance) = @_; + $self->associated_class->get_meta_instance->get_slot_value( + $instance, $self->count_slot + ); + } + + after set_initial_value => sub { + shift->_set_count(@_); + }; + + after set_value => sub { + shift->_set_count(@_); + }; + + around _inline_instance_set => sub { + my $orig = shift; + my $self = shift; + my ($instance) = @_; + + my $mi = $self->associated_class->get_meta_instance; + + return 'do { ' + . $mi->inline_set_slot_value( + $instance, + $self->count_slot, + $mi->inline_get_slot_value( + $instance, $self->count_slot + ) . ' + 1' + ) . ';' + . $self->$orig(@_) + . '}'; + }; + + after clear_value => sub { + shift->_clear_count(@_); + }; +} + +{ + package Bar; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { + attribute => ['Foo::Meta::Attr::Trait'], + }, + ); + + has baz => ( is => 'rw' ); +} + +{ + my $attr = Bar->meta->find_attribute_by_name('baz'); + + my $bar = Bar->new(baz => 1); + is($attr->count($bar), 1, "right count"); + + $bar->baz(2); + is($attr->count($bar), 2, "right count"); + + my $clone = $bar->meta->clone_object($bar); + is($attr->count($clone), $attr->count($bar), "right count"); +} + +done_testing; diff --git a/t/attributes/default_class_role_types.t b/t/attributes/default_class_role_types.t new file mode 100644 index 0000000..c0590ce --- /dev/null +++ b/t/attributes/default_class_role_types.t @@ -0,0 +1,47 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +{ + package Foo; + use Moose; + + has unknown_class => ( + is => 'ro', + isa => 'UnknownClass', + ); + + has unknown_role => ( + is => 'ro', + does => 'UnknownRole', + ); +} + +{ + my $meta = Foo->meta; + + my $class_tc = $meta->get_attribute('unknown_class')->type_constraint; + isa_ok($class_tc, 'Moose::Meta::TypeConstraint::Class'); + is($class_tc, find_type_constraint('UnknownClass'), + "class type is registered"); + like( + exception { subtype 'UnknownClass', as 'Str'; }, + qr/The type constraint 'UnknownClass' has already been created in Foo and cannot be created again in main/, + "Can't redefine implicitly defined class types" + ); + + my $role_tc = $meta->get_attribute('unknown_role')->type_constraint; + isa_ok($role_tc, 'Moose::Meta::TypeConstraint::Role'); + is($role_tc, find_type_constraint('UnknownRole'), + "role type is registered"); + like( + exception { subtype 'UnknownRole', as 'Str'; }, + qr/The type constraint 'UnknownRole' has already been created in Foo and cannot be created again in main/, + "Can't redefine implicitly defined class types" + ); +} + +done_testing; diff --git a/t/attributes/default_undef.t b/t/attributes/default_undef.t new file mode 100644 index 0000000..5c4bb55 --- /dev/null +++ b/t/attributes/default_undef.t @@ -0,0 +1,23 @@ +use strict; +use warnings; +use Test::More; +use Test::Moose; + +{ + package Foo; + use Moose; + + has foo => ( + is => 'ro', + isa => 'Maybe[Int]', + default => undef, + predicate => 'has_foo', + ); +} + +with_immutable { + is(Foo->new->foo, undef); + ok(Foo->new->has_foo); +} 'Foo'; + +done_testing; diff --git a/t/attributes/delegation_and_modifiers.t b/t/attributes/delegation_and_modifiers.t new file mode 100644 index 0000000..a0b9114 --- /dev/null +++ b/t/attributes/delegation_and_modifiers.t @@ -0,0 +1,54 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Bar; + use Moose; + + sub baz { 'Bar::baz' } + sub gorch { 'Bar::gorch' } + + package Foo; + use Moose; + + has 'bar' => ( + is => 'ro', + isa => 'Bar', + lazy => 1, + default => sub { Bar->new }, + handles => [qw[ baz gorch ]] + ); + + package Foo::Extended; + use Moose; + + extends 'Foo'; + + has 'test' => ( + is => 'rw', + isa => 'Bool', + default => sub { 0 }, + ); + + around 'bar' => sub { + my $next = shift; + my $self = shift; + + $self->test(1); + $self->$next(); + }; +} + +my $foo = Foo::Extended->new; +isa_ok($foo, 'Foo::Extended'); +isa_ok($foo, 'Foo'); + +ok(!$foo->test, '... the test value has not been changed'); + +is($foo->baz, 'Bar::baz', '... got the right delegated method'); + +ok($foo->test, '... the test value has now been changed'); + +done_testing; diff --git a/t/attributes/delegation_arg_aliasing.t b/t/attributes/delegation_arg_aliasing.t new file mode 100644 index 0000000..58a6b0a --- /dev/null +++ b/t/attributes/delegation_arg_aliasing.t @@ -0,0 +1,40 @@ +use strict; +use warnings; +use Test::More; + +{ + package Foo; + use Moose; + + sub aliased { + my $self = shift; + $_[1] = $_[0]; + } +} + +{ + package HasFoo; + use Moose; + + has foo => ( + is => 'ro', + isa => 'Foo', + handles => { + foo_aliased => 'aliased', + foo_aliased_curried => ['aliased', 'bar'], + } + ); +} + +my $hasfoo = HasFoo->new(foo => Foo->new); +my $x; +$hasfoo->foo->aliased('foo', $x); +is($x, 'foo', "direct aliasing works"); +undef $x; +$hasfoo->foo_aliased('foo', $x); +is($x, 'foo', "delegated aliasing works"); +undef $x; +$hasfoo->foo_aliased_curried($x); +is($x, 'bar', "delegated aliasing with currying works"); + +done_testing; diff --git a/t/attributes/delegation_target_not_loaded.t b/t/attributes/delegation_target_not_loaded.t new file mode 100644 index 0000000..3938786 --- /dev/null +++ b/t/attributes/delegation_target_not_loaded.t @@ -0,0 +1,35 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package X; + + use Moose; + + ::like( + ::exception{ has foo => ( + is => 'ro', + isa => 'Foo', + handles => qr/.*/, + ) + }, + qr/\QThe foo attribute is trying to delegate to a class which has not been loaded - Foo/, + 'cannot delegate to a class which is not yet loaded' + ); + + ::like( + ::exception{ has foo => ( + is => 'ro', + does => 'Role::Foo', + handles => qr/.*/, + ) + }, + qr/\QThe foo attribute is trying to delegate to a role which has not been loaded - Role::Foo/, + 'cannot delegate to a role which is not yet loaded' + ); +} + +done_testing; diff --git a/t/attributes/illegal_options_for_inheritance.t b/t/attributes/illegal_options_for_inheritance.t new file mode 100644 index 0000000..59ce26e --- /dev/null +++ b/t/attributes/illegal_options_for_inheritance.t @@ -0,0 +1,75 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +{ + package Foo; + use Moose; + + has foo => ( + is => 'ro', + ); + + has bar => ( + clearer => 'clear_bar', + ); +} + +{ + package Foo::Sub; + use Moose; + + extends 'Foo'; + + ::is( ::exception { has '+foo' => (is => 'rw') }, undef, "can override is" ); + ::like( ::exception { has '+foo' => (reader => 'bar') }, qr/illegal/, "can't override reader" ); + ::is( ::exception { has '+foo' => (clearer => 'baz') }, undef, "can override unspecified things" ); + + ::like( ::exception { has '+bar' => (clearer => 'quux') }, qr/illegal/, "can't override clearer" ); + ::is( ::exception { has '+bar' => (predicate => 'has_bar') }, undef, "can override unspecified things" ); +} + +{ + package Bar::Meta::Attribute; + use Moose::Role; + + has my_illegal_option => (is => 'ro'); + + around illegal_options_for_inheritance => sub { + return (shift->(@_), 'my_illegal_option'); + }; +} + +{ + package Bar; + use Moose; + + ::is( ::exception { + has bar => ( + traits => ['Bar::Meta::Attribute'], + my_illegal_option => 'FOO', + is => 'bare', + ); + }, undef, "can use illegal options" ); + + has baz => ( + traits => ['Bar::Meta::Attribute'], + is => 'bare', + ); +} + +{ + package Bar::Sub; + use Moose; + + extends 'Bar'; + + ::like( ::exception { has '+bar' => (my_illegal_option => 'BAR') }, qr/illegal/, "can't override illegal attribute" ); + ::is( ::exception { has '+baz' => (my_illegal_option => 'BAR') }, undef, "can add illegal option if superclass doesn't set it" ); +} + +my $bar_attr = Bar->meta->get_attribute('bar'); +ok((grep { $_ eq 'my_illegal_option' } $bar_attr->illegal_options_for_inheritance) > 0, '... added my_illegal_option as illegal option for inheritance'); + +done_testing; diff --git a/t/attributes/inherit_lazy_build.t b/t/attributes/inherit_lazy_build.t new file mode 100644 index 0000000..35919e5 --- /dev/null +++ b/t/attributes/inherit_lazy_build.t @@ -0,0 +1,75 @@ +use strict; +use warnings; + +use Test::More; + +{ + + package Parent; + use Moose; + has attr => ( is => 'rw', isa => 'Str' ); +} + +{ + package Child; + use Moose; + extends 'Parent'; + + has '+attr' => ( lazy_build => 1 ); + + sub _build_attr { + return 'value'; + } +} + +my $parent = Parent->new(); +my $child = Child->new(); + +ok( + !$parent->meta->get_attribute('attr')->is_lazy_build, + 'attribute in parent does not have lazy_build trait' +); +ok( + !$parent->meta->get_attribute('attr')->is_lazy, + 'attribute in parent does not have lazy trait' +); +ok( + !$parent->meta->get_attribute('attr')->has_builder, + 'attribute in parent does not have a builder method' +); +ok( + !$parent->meta->get_attribute('attr')->has_clearer, + 'attribute in parent does not have a clearer method' +); +ok( + !$parent->meta->get_attribute('attr')->has_predicate, + 'attribute in parent does not have a predicate method' +); + +ok( + $child->meta->get_attribute('attr')->is_lazy_build, + 'attribute in child has the lazy_build trait' +); +ok( + $child->meta->get_attribute('attr')->is_lazy, + 'attribute in child has the lazy trait' +); +ok( + $child->meta->get_attribute('attr')->has_builder, + 'attribute in child has a builder method' +); +ok( + $child->meta->get_attribute('attr')->has_clearer, + 'attribute in child has a clearer method' +); +ok( + $child->meta->get_attribute('attr')->has_predicate, + 'attribute in child has a predicate method' +); + +is( + $child->attr, 'value', + 'attribute defined as lazy_build in child is properly built' +); + +done_testing; diff --git a/t/attributes/lazy_no_default.t b/t/attributes/lazy_no_default.t new file mode 100644 index 0000000..c2ff635 --- /dev/null +++ b/t/attributes/lazy_no_default.t @@ -0,0 +1,22 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package Foo; + use Moose; + + ::like( + ::exception{ has foo => ( + is => 'ro', + lazy => 1, + ); + }, + qr/\QYou cannot have a lazy attribute (foo) without specifying a default value for it/, + 'lazy without a default or builder throws an error' + ); +} + +done_testing; diff --git a/t/attributes/method_generation_rules.t b/t/attributes/method_generation_rules.t new file mode 100644 index 0000000..15cabc0 --- /dev/null +++ b/t/attributes/method_generation_rules.t @@ -0,0 +1,61 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +=pod + + is => rw, writer => _foo # turns into (reader => foo, writer => _foo) + is => ro, writer => _foo # turns into (reader => foo, writer => _foo) as before + is => rw, accessor => _foo # turns into (accessor => _foo) + is => ro, accessor => _foo # error, accesor is rw + +=cut + +sub make_class { + my ($is, $attr, $class) = @_; + + eval "package $class; use Moose; has 'foo' => ( is => '$is', $attr => '_foo' );"; + + return $@ ? die $@ : $class; +} + +my $obj; +my $class; + +$class = make_class('rw', 'writer', 'Test::Class::WriterRW'); +ok($class, "Can define attr with rw + writer"); + +$obj = $class->new(); + +can_ok($obj, qw/foo _foo/); +is( exception {$obj->_foo(1)}, undef, "$class->_foo is writer" ); +is($obj->foo(), 1, "$class->foo is reader"); +isnt( exception {$obj->foo(2)}, undef, "$class->foo is not writer" ); # this should fail +ok(!defined $obj->_foo(), "$class->_foo is not reader"); + +$class = make_class('ro', 'writer', 'Test::Class::WriterRO'); +ok($class, "Can define attr with ro + writer"); + +$obj = $class->new(); + +can_ok($obj, qw/foo _foo/); +is( exception {$obj->_foo(1)}, undef, "$class->_foo is writer" ); +is($obj->foo(), 1, "$class->foo is reader"); +isnt( exception {$obj->foo(1)}, undef, "$class->foo is not writer" ); +isnt($obj->_foo(), 1, "$class->_foo is not reader"); + +$class = make_class('rw', 'accessor', 'Test::Class::AccessorRW'); +ok($class, "Can define attr with rw + accessor"); + +$obj = $class->new(); + +can_ok($obj, qw/_foo/); +is( exception {$obj->_foo(1)}, undef, "$class->_foo is writer" ); +is($obj->_foo(), 1, "$class->foo is reader"); + +isnt( exception { make_class('ro', 'accessor', "Test::Class::AccessorRO"); }, undef, "Cant define attr with ro + accessor" ); + +done_testing; diff --git a/t/attributes/misc_attribute_coerce_lazy.t b/t/attributes/misc_attribute_coerce_lazy.t new file mode 100644 index 0000000..341e55d --- /dev/null +++ b/t/attributes/misc_attribute_coerce_lazy.t @@ -0,0 +1,48 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + + +{ + package HTTPHeader; + use Moose; + + has 'array' => (is => 'ro'); + has 'hash' => (is => 'ro'); +} + +{ + package Request; + use Moose; + use Moose::Util::TypeConstraints; + + subtype Header => + => as Object + => where { $_->isa('HTTPHeader') }; + + coerce Header + => from ArrayRef + => via { HTTPHeader->new(array => $_[0]) } + => from HashRef + => via { HTTPHeader->new(hash => $_[0]) }; + + has 'headers' => ( + is => 'rw', + isa => 'Header', + coerce => 1, + lazy => 1, + default => sub { [ 'content-type', 'text/html' ] } + ); +} + +my $r = Request->new; +isa_ok($r, 'Request'); + +is( exception { + $r->headers; +}, undef, '... this coerces and passes the type constraint even with lazy' ); + +done_testing; diff --git a/t/attributes/misc_attribute_tests.t b/t/attributes/misc_attribute_tests.t new file mode 100644 index 0000000..7d392aa --- /dev/null +++ b/t/attributes/misc_attribute_tests.t @@ -0,0 +1,270 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + { + package Test::Attribute::Inline::Documentation; + use Moose; + + has 'foo' => ( + documentation => q{ + The 'foo' attribute is my favorite + attribute in the whole wide world. + }, + is => 'bare', + ); + } + + my $foo_attr = Test::Attribute::Inline::Documentation->meta->get_attribute('foo'); + + ok($foo_attr->has_documentation, '... the foo has docs'); + is($foo_attr->documentation, + q{ + The 'foo' attribute is my favorite + attribute in the whole wide world. + }, + '... got the foo docs'); +} + +{ + { + package Test::For::Lazy::TypeConstraint; + use Moose; + use Moose::Util::TypeConstraints; + + has 'bad_lazy_attr' => ( + is => 'rw', + isa => 'ArrayRef', + lazy => 1, + default => sub { "test" }, + ); + + has 'good_lazy_attr' => ( + is => 'rw', + isa => 'ArrayRef', + lazy => 1, + default => sub { [] }, + ); + + } + + my $test = Test::For::Lazy::TypeConstraint->new; + isa_ok($test, 'Test::For::Lazy::TypeConstraint'); + + isnt( exception { + $test->bad_lazy_attr; + }, undef, '... this does not work' ); + + is( exception { + $test->good_lazy_attr; + }, undef, '... this does not work' ); +} + +{ + { + package Test::Arrayref::Attributes; + use Moose; + + has [qw(foo bar baz)] => ( + is => 'rw', + ); + + } + + my $test = Test::Arrayref::Attributes->new; + isa_ok($test, 'Test::Arrayref::Attributes'); + can_ok($test, qw(foo bar baz)); + +} + +{ + { + package Test::Arrayref::RoleAttributes::Role; + use Moose::Role; + + has [qw(foo bar baz)] => ( + is => 'rw', + ); + + } + { + package Test::Arrayref::RoleAttributes; + use Moose; + with 'Test::Arrayref::RoleAttributes::Role'; + } + + my $test = Test::Arrayref::RoleAttributes->new; + isa_ok($test, 'Test::Arrayref::RoleAttributes'); + can_ok($test, qw(foo bar baz)); + +} + +{ + { + package Test::UndefDefault::Attributes; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'Str', + default => sub { return } + ); + + } + + isnt( exception { + Test::UndefDefault::Attributes->new; + }, undef, '... default must return a value which passes the type constraint' ); + +} + +{ + { + package OverloadedStr; + use Moose; + use overload '""' => sub { 'this is *not* a string' }; + + has 'a_str' => ( isa => 'Str' , is => 'rw' ); + } + + my $moose_obj = OverloadedStr->new; + + is($moose_obj->a_str( 'foobar' ), 'foobar', 'setter took string'); + ok($moose_obj, 'this is a *not* a string'); + + like( exception { + $moose_obj->a_str( $moose_obj ) + }, qr/Attribute \(a_str\) does not pass the type constraint because\: Validation failed for 'Str' with value .*OverloadedStr/, '... dies without overloading the string' ); + +} + +{ + { + package OverloadBreaker; + use Moose; + + has 'a_num' => ( isa => 'Int' , is => 'rw', default => 7.5 ); + } + + like( exception { + OverloadBreaker->new; + }, qr/Attribute \(a_num\) does not pass the type constraint because\: Validation failed for 'Int' with value 7\.5/, '... this doesnt trip overload to break anymore ' ); + + is( exception { + OverloadBreaker->new(a_num => 5); + }, undef, '... this works fine though' ); + +} + +{ + { + package Test::Builder::Attribute; + use Moose; + + has 'foo' => ( required => 1, builder => 'build_foo', is => 'ro'); + sub build_foo { return "works" }; + } + + my $meta = Test::Builder::Attribute->meta; + my $foo_attr = $meta->get_attribute("foo"); + + ok($foo_attr->is_required, "foo is required"); + ok($foo_attr->has_builder, "foo has builder"); + is($foo_attr->builder, "build_foo", ".. and it's named build_foo"); + + my $instance = Test::Builder::Attribute->new; + is($instance->foo, 'works', "foo builder works"); +} + +{ + { + package Test::Builder::Attribute::Broken; + use Moose; + + has 'foo' => ( required => 1, builder => 'build_foo', is => 'ro'); + } + + isnt( exception { + Test::Builder::Attribute::Broken->new; + }, undef, '... no builder, wtf' ); +} + + +{ + { + package Test::LazyBuild::Attribute; + use Moose; + + has 'foo' => ( lazy_build => 1, is => 'ro'); + has '_foo' => ( lazy_build => 1, is => 'ro'); + has 'fool' => ( lazy_build => 1, is => 'ro'); + sub _build_foo { return "works" }; + sub _build__foo { return "works too" }; + } + + my $meta = Test::LazyBuild::Attribute->meta; + my $foo_attr = $meta->get_attribute("foo"); + my $_foo_attr = $meta->get_attribute("_foo"); + + ok($foo_attr->is_lazy, "foo is lazy"); + ok($foo_attr->is_lazy_build, "foo is lazy_build"); + + ok($foo_attr->has_clearer, "foo has clearer"); + is($foo_attr->clearer, "clear_foo", ".. and it's named clear_foo"); + + ok($foo_attr->has_builder, "foo has builder"); + is($foo_attr->builder, "_build_foo", ".. and it's named build_foo"); + + ok($foo_attr->has_predicate, "foo has predicate"); + is($foo_attr->predicate, "has_foo", ".. and it's named has_foo"); + + ok($_foo_attr->is_lazy, "_foo is lazy"); + ok(!$_foo_attr->is_required, "lazy_build attributes are no longer automatically required"); + ok($_foo_attr->is_lazy_build, "_foo is lazy_build"); + + ok($_foo_attr->has_clearer, "_foo has clearer"); + is($_foo_attr->clearer, "_clear_foo", ".. and it's named _clear_foo"); + + ok($_foo_attr->has_builder, "_foo has builder"); + is($_foo_attr->builder, "_build__foo", ".. and it's named _build_foo"); + + ok($_foo_attr->has_predicate, "_foo has predicate"); + is($_foo_attr->predicate, "_has_foo", ".. and it's named _has_foo"); + + my $instance = Test::LazyBuild::Attribute->new; + ok(!$instance->has_foo, "noo foo value yet"); + ok(!$instance->_has_foo, "noo _foo value yet"); + is($instance->foo, 'works', "foo builder works"); + is($instance->_foo, 'works too', "foo builder works too"); + like( exception { $instance->fool }, qr/Test::LazyBuild::Attribute does not support builder method \'_build_fool\' for attribute \'fool\'/, "Correct error when a builder method is not present" ); + +} + +{ + package OutOfClassTest; + + use Moose; +} + +is( exception { OutOfClassTest::has('foo', is => 'bare'); }, undef, 'create attr via direct sub call' ); +is( exception { OutOfClassTest->can('has')->('bar', is => 'bare'); }, undef, 'create attr via can' ); + +ok(OutOfClassTest->meta->get_attribute('foo'), 'attr created from sub call'); +ok(OutOfClassTest->meta->get_attribute('bar'), 'attr created from can'); + + +{ + { + package Foo; + use Moose; + + ::like( ::exception { has 'foo' => ( 'ro', isa => 'Str' ) }, qr/\QYou must pass an even number of attribute options/, 'has throws error with odd number of attribute options' ); + } + +} + +done_testing; diff --git a/t/attributes/more_attr_delegation.t b/t/attributes/more_attr_delegation.t new file mode 100644 index 0000000..d40bb03 --- /dev/null +++ b/t/attributes/more_attr_delegation.t @@ -0,0 +1,263 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +=pod + +This tests the more complex +delegation cases and that they +do not fail at compile time. + +=cut + +{ + + package ChildASuper; + use Moose; + + sub child_a_super_method { "as" } + + package ChildA; + use Moose; + + extends "ChildASuper"; + + sub child_a_method_1 { "a1" } + sub child_a_method_2 { Scalar::Util::blessed($_[0]) . " a2" } + + package ChildASub; + use Moose; + + extends "ChildA"; + + sub child_a_method_3 { "a3" } + + package ChildB; + use Moose; + + sub child_b_method_1 { "b1" } + sub child_b_method_2 { "b2" } + sub child_b_method_3 { "b3" } + + package ChildC; + use Moose; + + sub child_c_method_1 { "c1" } + sub child_c_method_2 { "c2" } + sub child_c_method_3_la { "c3" } + sub child_c_method_4_la { "c4" } + + package ChildD; + use Moose; + + sub child_d_method_1 { "d1" } + sub child_d_method_2 { "d2" } + + package ChildE; + # no Moose + + sub new { bless {}, shift } + sub child_e_method_1 { "e1" } + sub child_e_method_2 { "e2" } + + package ChildF; + # no Moose + + sub new { bless {}, shift } + sub child_f_method_1 { "f1" } + sub child_f_method_2 { "f2" } + + $INC{'ChildF.pm'} = __FILE__; + + package ChildG; + use Moose; + + sub child_g_method_1 { "g1" } + + package ChildH; + use Moose; + + sub child_h_method_1 { "h1" } + sub parent_method_1 { "child_parent_1" } + + package ChildI; + use Moose; + + sub child_i_method_1 { "i1" } + sub parent_method_1 { "child_parent_1" } + + package Parent; + use Moose; + + sub parent_method_1 { "parent_1" } + ::can_ok('Parent', 'parent_method_1'); + + ::isnt( ::exception { + has child_a => ( + is => "ro", + default => sub { ChildA->new }, + handles => qr/.*/, + ); + }, undef, "all_methods requires explicit isa" ); + + ::is( ::exception { + has child_a => ( + isa => "ChildA", + is => "ro", + default => sub { ChildA->new }, + handles => qr/.*/, + ); + }, undef, "allow all_methods with explicit isa" ); + + ::is( ::exception { + has child_b => ( + is => 'ro', + default => sub { ChildB->new }, + handles => [qw/child_b_method_1/], + ); + }, undef, "don't need to declare isa if method list is predefined" ); + + ::is( ::exception { + has child_c => ( + isa => "ChildC", + is => "ro", + default => sub { ChildC->new }, + handles => qr/_la$/, + ); + }, undef, "can declare regex collector" ); + + ::isnt( ::exception { + has child_d => ( + is => "ro", + default => sub { ChildD->new }, + handles => sub { + my ( $class, $delegate_class ) = @_; + } + ); + }, undef, "can't create attr with generative handles parameter and no isa" ); + + ::is( ::exception { + has child_d => ( + isa => "ChildD", + is => "ro", + default => sub { ChildD->new }, + handles => sub { + my ( $class, $delegate_class ) = @_; + return; + } + ); + }, undef, "can't create attr with generative handles parameter and no isa" ); + + ::is( ::exception { + has child_e => ( + isa => "ChildE", + is => "ro", + default => sub { ChildE->new }, + handles => ["child_e_method_2"], + ); + }, undef, "can delegate to non moose class using explicit method list" ); + + my $delegate_class; + ::is( ::exception { + has child_f => ( + isa => "ChildF", + is => "ro", + default => sub { ChildF->new }, + handles => sub { + $delegate_class = $_[1]->name; + return; + }, + ); + }, undef, "subrefs on non moose class give no meta" ); + + ::is( $delegate_class, "ChildF", "plain classes are handed down to subs" ); + + ::is( ::exception { + has child_g => ( + isa => "ChildG", + default => sub { ChildG->new }, + handles => ["child_g_method_1"], + ); + }, undef, "can delegate to object even without explicit reader" ); + + ::can_ok('Parent', 'parent_method_1'); + ::isnt( ::exception { + has child_h => ( + isa => "ChildH", + is => "ro", + default => sub { ChildH->new }, + handles => sub { map { $_, $_ } $_[1]->get_all_method_names }, + ); + }, undef, "Can't override exisiting class method in delegate" ); + ::can_ok('Parent', 'parent_method_1'); + + ::is( ::exception { + has child_i => ( + isa => "ChildI", + is => "ro", + default => sub { ChildI->new }, + handles => sub { + map { $_, $_ } grep { !/^parent_method_1|meta$/ } + $_[1]->get_all_method_names; + }, + ); + }, undef, "Test handles code ref for skipping predefined methods" ); + + + sub parent_method { "p" } +} + +# sanity + +isa_ok( my $p = Parent->new, "Parent" ); +isa_ok( $p->child_a, "ChildA" ); +isa_ok( $p->child_b, "ChildB" ); +isa_ok( $p->child_c, "ChildC" ); +isa_ok( $p->child_d, "ChildD" ); +isa_ok( $p->child_e, "ChildE" ); +isa_ok( $p->child_f, "ChildF" ); +isa_ok( $p->child_i, "ChildI" ); + +ok(!$p->can('child_g'), '... no child_g accessor defined'); +ok(!$p->can('child_h'), '... no child_h accessor defined'); + + +is( $p->parent_method, "p", "parent method" ); +is( $p->child_a->child_a_super_method, "as", "child supermethod" ); +is( $p->child_a->child_a_method_1, "a1", "child method" ); + +can_ok( $p, "child_a_super_method" ); +can_ok( $p, "child_a_method_1" ); +can_ok( $p, "child_a_method_2" ); +ok( !$p->can( "child_a_method_3" ), "but not subclass of delegate class" ); + +is( $p->child_a_method_1, $p->child_a->child_a_method_1, "delegate behaves the same" ); +is( $p->child_a_method_2, "ChildA a2", "delegates are their own invocants" ); + + +can_ok( $p, "child_b_method_1" ); +ok( !$p->can("child_b_method_2"), "but not ChildB's unspecified siblings" ); + + +ok( !$p->can($_), "none of ChildD's methods ($_)" ) + for grep { /^child/ } map { $_->name } ChildD->meta->get_all_methods(); + +can_ok( $p, "child_c_method_3_la" ); +can_ok( $p, "child_c_method_4_la" ); + +is( $p->child_c_method_3_la, "c3", "ChildC method delegated OK" ); + +can_ok( $p, "child_e_method_2" ); +ok( !$p->can("child_e_method_1"), "but not child_e_method_1"); + +is( $p->child_e_method_2, "e2", "delegate to non moose class (child_e_method_2)" ); + +can_ok( $p, "child_g_method_1" ); +is( $p->child_g_method_1, "g1", "delegate to moose class without reader (child_g_method_1)" ); + +can_ok( $p, "child_i_method_1" ); +is( $p->parent_method_1, "parent_1", "delegate doesn't override existing method" ); + +done_testing; diff --git a/t/attributes/no_init_arg.t b/t/attributes/no_init_arg.t new file mode 100644 index 0000000..181e0c2 --- /dev/null +++ b/t/attributes/no_init_arg.t @@ -0,0 +1,32 @@ +use strict; +use warnings; + +use Test::More; + + + +{ + package Foo; + use Moose; + + eval { + has 'foo' => ( + is => "rw", + init_arg => undef, + ); + }; + ::ok(!$@, '... created the attr okay'); +} + +{ + my $foo = Foo->new( foo => "bar" ); + isa_ok($foo, 'Foo'); + + is( $foo->foo, undef, "field is not set via init arg" ); + + $foo->foo("blah"); + + is( $foo->foo, "blah", "field is set via setter" ); +} + +done_testing; diff --git a/t/attributes/no_slot_access.t b/t/attributes/no_slot_access.t new file mode 100644 index 0000000..22405ba --- /dev/null +++ b/t/attributes/no_slot_access.t @@ -0,0 +1,87 @@ +use strict; +use warnings; + +{ + package SomeAwesomeDB; + + sub new_row { } + sub read { } + sub write { } +} + +{ + package MooseX::SomeAwesomeDBFields; + + # implementation of methods not called in the example deliberately + # omitted + + use Moose::Role; + + sub inline_create_instance { + my ( $self, $classvar ) = @_; + + "bless SomeAwesomeDB::new_row(), $classvar"; + } + + sub inline_get_slot_value { + my ( $self, $invar, $slot ) = @_; + + "SomeAwesomeDB::read($invar, \"$slot\")"; + } + + sub inline_set_slot_value { + my ( $self, $invar, $slot, $valexp ) = @_; + + "SomeAwesomeDB::write($invar, \"$slot\", $valexp)"; + } + + sub inline_is_slot_initialized { + my ( $self, $invar, $slot ) = @_; + + "1"; + } + + sub inline_initialize_slot { + my ( $self, $invar, $slot ) = @_; + + ""; + } + + sub inline_slot_access { + die "inline_slot_access should not have been used"; + } +} + +{ + package Toy; + + use Moose; + use Moose::Util::MetaRole; + + use Test::More; + use Test::Fatal; + + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { instance => ['MooseX::SomeAwesomeDBFields'] }, + ); + + is( exception { + has lazy_attr => ( + is => 'ro', + isa => 'Bool', + lazy => 1, + default => sub {0}, + ); + }, undef, "Adding lazy accessor does not use inline_slot_access" ); + + is( exception { + has rw_attr => ( + is => 'rw', + ); + }, undef, "Adding read-write accessor does not use inline_slot_access" ); + + is( exception { __PACKAGE__->meta->make_immutable; }, undef, "Inling constructor does not use inline_slot_access" ); + + done_testing; +} diff --git a/t/attributes/non_alpha_attr_names.t b/t/attributes/non_alpha_attr_names.t new file mode 100644 index 0000000..f710c88 --- /dev/null +++ b/t/attributes/non_alpha_attr_names.t @@ -0,0 +1,66 @@ +use strict; +use warnings; + +use Test::More; +use Test::Moose; + +{ + package Foo; + use Moose; + has 'type' => ( + required => 0, + reader => 'get_type', + default => 1, + ); + + # Assigning types to these non-alpha attrs exposed a bug in Moose. + has '@type' => ( + isa => 'Str', + required => 0, + reader => 'get_at_type', + writer => 'set_at_type', + default => 'at type', + ); + + has 'has spaces' => ( + isa => 'Int', + required => 0, + reader => 'get_hs', + default => 42, + ); + + has '!req' => ( + required => 1, + reader => 'req' + ); + + no Moose; +} + +with_immutable { + ok( Foo->meta->has_attribute($_), "Foo has '$_' attribute" ) + for 'type', '@type', 'has spaces'; + + my $foo = Foo->new( '!req' => 42 ); + + is( $foo->get_type, 1, q{'type' attribute default is 1} ); + is( $foo->get_at_type, 'at type', q{'@type' attribute default is 1} ); + is( $foo->get_hs, 42, q{'has spaces' attribute default is 42} ); + + $foo = Foo->new( + type => 'foo', + '@type' => 'bar', + 'has spaces' => 200, + '!req' => 84, + ); + + isa_ok( $foo, 'Foo' ); + is( $foo->get_at_type, 'bar', q{reader for '@type'} ); + is( $foo->get_hs, 200, q{reader for 'has spaces'} ); + + $foo->set_at_type(99); + is( $foo->get_at_type, 99, q{writer for '@type' worked} ); +} +'Foo'; + +done_testing; diff --git a/t/attributes/numeric_defaults.t b/t/attributes/numeric_defaults.t new file mode 100644 index 0000000..0691cde --- /dev/null +++ b/t/attributes/numeric_defaults.t @@ -0,0 +1,130 @@ +use strict; +use warnings; +use Test::More; +use Test::Moose; +use B; + +{ + package Foo; + use Moose; + + has foo => (is => 'ro', default => 100); + + sub bar { 100 } +} + +with_immutable { + my $foo = Foo->new; + for my $meth (qw(foo bar)) { + my $val = $foo->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int"); + ok(!($flags & B::SVf_POK), "not a string"); + } +} 'Foo'; + +{ + package Bar; + use Moose; + + has foo => (is => 'ro', lazy => 1, default => 100); + + sub bar { 100 } +} + +with_immutable { + my $bar = Bar->new; + for my $meth (qw(foo bar)) { + my $val = $bar->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int"); + ok(!($flags & B::SVf_POK), "not a string"); + } +} 'Bar'; + +{ + package Baz; + use Moose; + + has foo => (is => 'ro', isa => 'Int', lazy => 1, default => 100); + + sub bar { 100 } +} + +with_immutable { + my $baz = Baz->new; + for my $meth (qw(foo bar)) { + my $val = $baz->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int"); + ok(!($flags & B::SVf_POK), "not a string"); + } +} 'Baz'; + +{ + package Foo2; + use Moose; + + has foo => (is => 'ro', default => 10.5); + + sub bar { 10.5 } +} + +with_immutable { + my $foo2 = Foo2->new; + for my $meth (qw(foo bar)) { + my $val = $foo2->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num"); + ok(!($flags & B::SVf_POK), "not a string"); + } +} 'Foo2'; + +{ + package Bar2; + use Moose; + + has foo => (is => 'ro', lazy => 1, default => 10.5); + + sub bar { 10.5 } +} + +with_immutable { + my $bar2 = Bar2->new; + for my $meth (qw(foo bar)) { + my $val = $bar2->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num"); + ok(!($flags & B::SVf_POK), "not a string"); + } +} 'Bar2'; + +{ + package Baz2; + use Moose; + + has foo => (is => 'ro', isa => 'Num', lazy => 1, default => 10.5); + + sub bar { 10.5 } +} + +with_immutable { + my $baz2 = Baz2->new; + for my $meth (qw(foo bar)) { + my $val = $baz2->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num"); + # it's making sure that the Num value doesn't get converted to a string for regex matching + # this is the reason for using a temporary variable, $val for regex matching, + # instead of $_[1] in Num implementation in lib/Moose/Util/TypeConstraints/Builtins.pm + ok(!($flags & B::SVf_POK), "not a string"); + } +} 'Baz2'; + +done_testing; diff --git a/t/attributes/trigger_and_coerce.t b/t/attributes/trigger_and_coerce.t new file mode 100644 index 0000000..d28b7ce --- /dev/null +++ b/t/attributes/trigger_and_coerce.t @@ -0,0 +1,53 @@ +use strict; +use warnings; + +use Test::More; + + +{ + + package Fake::DateTime; + use Moose; + + has 'string_repr' => ( is => 'ro' ); + + package Mortgage; + use Moose; + use Moose::Util::TypeConstraints; + + coerce 'Fake::DateTime' => from 'Str' => + via { Fake::DateTime->new( string_repr => $_ ) }; + + has 'closing_date' => ( + is => 'rw', + isa => 'Fake::DateTime', + coerce => 1, + trigger => sub { + my ( $self, $val ) = @_; + ::pass('... trigger is being called'); + ::isa_ok( $self->closing_date, 'Fake::DateTime' ); + ::isa_ok( $val, 'Fake::DateTime' ); + } + ); +} + +{ + my $mtg = Mortgage->new( closing_date => 'yesterday' ); + isa_ok( $mtg, 'Mortgage' ); + + # check that coercion worked + isa_ok( $mtg->closing_date, 'Fake::DateTime' ); +} + +Mortgage->meta->make_immutable; +ok( Mortgage->meta->is_immutable, '... Mortgage is now immutable' ); + +{ + my $mtg = Mortgage->new( closing_date => 'yesterday' ); + isa_ok( $mtg, 'Mortgage' ); + + # check that coercion worked + isa_ok( $mtg->closing_date, 'Fake::DateTime' ); +} + +done_testing; diff --git a/t/attributes/type_constraint.t b/t/attributes/type_constraint.t new file mode 100644 index 0000000..16bc981 --- /dev/null +++ b/t/attributes/type_constraint.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package AttrHasTC; + use Moose; + has foo => ( + is => 'ro', + isa => 'Int', + ); + + has bar => ( + is => 'ro', + ); +} + +ok( + AttrHasTC->meta->get_attribute('foo')->verify_against_type_constraint(42), + 'verify_against_type_constraint returns true with valid Int' +); + +my $e = exception { + AttrHasTC->meta->get_attribute('foo') + ->verify_against_type_constraint('foo'); +}; + +isa_ok( + $e, + 'Moose::Exception::ValidationFailedForTypeConstraint', + 'exception thrown when verify_against_type_constraint fails' +); + +ok( + AttrHasTC->meta->get_attribute('bar')->verify_against_type_constraint(42), + 'verify_against_type_constraint returns true when attr has no TC' +); + +done_testing; diff --git a/t/basics/always_strict_warnings.t b/t/basics/always_strict_warnings.t new file mode 100644 index 0000000..ca62682 --- /dev/null +++ b/t/basics/always_strict_warnings.t @@ -0,0 +1,71 @@ +use Test::More; + +# very intentionally not doing use strict; use warnings here... + +# for classes ... +{ + package Foo; + use Moose; + + eval '$foo = 5;'; + ::ok($@, '... got an error because strict is on'); + ::like($@, qr/Global symbol \"\$foo\" requires explicit package name /, '... got the right error'); + + { + my $warn; + local $SIG{__WARN__} = sub { $warn = $_[0] }; + + ::ok(!$warn, '... no warning yet'); + + eval 'my $bar = 1 + "hello"'; + + ::ok($warn, '... got a warning'); + ::like($warn, qr/Argument \"hello\" isn\'t numeric in addition \(\+\)/, '.. and it is the right warning'); + } +} + +# and for roles ... +{ + package Bar; + use Moose::Role; + + eval '$foo = 5;'; + ::ok($@, '... got an error because strict is on'); + ::like($@, qr/Global symbol \"\$foo\" requires explicit package name /, '... got the right error'); + + { + my $warn; + local $SIG{__WARN__} = sub { $warn = $_[0] }; + + ::ok(!$warn, '... no warning yet'); + + eval 'my $bar = 1 + "hello"'; + + ::ok($warn, '... got a warning'); + ::like($warn, qr/Argument \"hello\" isn\'t numeric in addition \(\+\)/, '.. and it is the right warning'); + } +} + +# and for exporters +{ + package Bar; + use Moose::Exporter; + + eval '$foo = 5;'; + ::ok($@, '... got an error because strict is on'); + ::like($@, qr/Global symbol \"\$foo\" requires explicit package name /, '... got the right error'); + + { + my $warn; + local $SIG{__WARN__} = sub { $warn = $_[0] }; + + ::ok(!$warn, '... no warning yet'); + + eval 'my $bar = 1 + "hello"'; + + ::ok($warn, '... got a warning'); + ::like($warn, qr/Argument \"hello\" isn\'t numeric in addition \(\+\)/, '.. and it is the right warning'); + } +} + +done_testing; diff --git a/t/basics/basic_class_setup.t b/t/basics/basic_class_setup.t new file mode 100644 index 0000000..64a5779 --- /dev/null +++ b/t/basics/basic_class_setup.t @@ -0,0 +1,50 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + use Moose::Util::TypeConstraints; +} + +can_ok('Foo', 'meta'); +isa_ok(Foo->meta, 'Moose::Meta::Class'); + +ok(Foo->meta->has_method('meta'), '... we got the &meta method'); +ok(Foo->isa('Moose::Object'), '... Foo is automagically a Moose::Object'); + +isnt( exception { + Foo->meta->has_method() +}, undef, '... has_method requires an arg' ); + +can_ok('Foo', 'does'); + +foreach my $function (qw( + extends + has + before after around + blessed confess + type subtype as where + coerce from via + find_type_constraint + )) { + ok(!Foo->meta->has_method($function), '... the meta does not treat "' . $function . '" as a method'); +} + +foreach my $import (qw( + blessed + try + catch + in_global_destruction +)) { + ok(!Moose::Object->can($import), "no namespace pollution in Moose::Object ($import)" ); + + local $TODO = $import eq 'blessed' ? "no automatic namespace cleaning yet" : undef; + ok(!Foo->can($import), "no namespace pollution in Moose::Object ($import)" ); +} + +done_testing; diff --git a/t/basics/buildargs.t b/t/basics/buildargs.t new file mode 100644 index 0000000..f7b5b5d --- /dev/null +++ b/t/basics/buildargs.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Foo; + use Moose; + + has bar => ( is => "rw" ); + has baz => ( is => "rw" ); + + sub BUILDARGS { + my ( $self, @args ) = @_; + unshift @args, "bar" if @args % 2 == 1; + return {@args}; + } + + package Bar; + use Moose; + + extends qw(Foo); +} + +foreach my $class (qw(Foo Bar)) { + is( $class->new->bar, undef, "no args" ); + is( $class->new( bar => 42 )->bar, 42, "normal args" ); + is( $class->new( 37 )->bar, 37, "single arg" ); + { + my $o = $class->new(bar => 42, baz => 47); + is($o->bar, 42, '... got the right bar'); + is($o->baz, 47, '... got the right bar'); + } + { + my $o = $class->new(42, baz => 47); + is($o->bar, 42, '... got the right bar'); + is($o->baz, 47, '... got the right bar'); + } +} + +done_testing; diff --git a/t/basics/buildargs_warning.t b/t/basics/buildargs_warning.t new file mode 100644 index 0000000..5b1a415 --- /dev/null +++ b/t/basics/buildargs_warning.t @@ -0,0 +1,32 @@ +use strict; +use warnings; + +use Test::Fatal; +use Test::More; +use Test::Moose qw( with_immutable ); + +use Test::Requires 'Test::Output'; + +{ + package Baz; + use Moose; +} + +with_immutable { + is( exception { + stderr_like { Baz->new( x => 42, 'y' ) } + qr{\QThe new() method for Baz expects a hash reference or a key/value list. You passed an odd number of arguments at $0 line \E\d+}, + 'warning when passing an odd number of args to new()'; + + stderr_unlike { Baz->new( x => 42, 'y' ) } + qr{\QOdd number of elements in anonymous hash}, + 'we suppress the standard warning from Perl for an odd number of elements in a hash'; + + stderr_is { Baz->new( { x => 42 } ) } + q{}, + 'we handle a single hashref to new without errors'; + }, undef ); +} +'Baz'; + +done_testing; diff --git a/t/basics/create.t b/t/basics/create.t new file mode 100644 index 0000000..37dcf57 --- /dev/null +++ b/t/basics/create.t @@ -0,0 +1,61 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::Load 'is_class_loaded'; + +{ + package Class; + use Moose; + + package Foo; + use Moose::Role; + sub foo_role_applied { 1 } + + package Conflicts::With::Foo; + use Moose::Role; + sub foo_role_applied { 0 } + + package Not::A::Role; + sub lol_wut { 42 } +} + +my $new_class; + +is( exception { + $new_class = Moose::Meta::Class->create( + 'Class::WithFoo', + superclasses => ['Class'], + roles => ['Foo'], + ); +}, undef, 'creating lives' ); +ok $new_class; + +my $with_foo = Class::WithFoo->new; + +ok $with_foo->foo_role_applied; +isa_ok $with_foo, 'Class', '$with_foo'; + +like( exception { + Moose::Meta::Class->create( + 'Made::Of::Fail', + superclasses => ['Class'], + roles => 'Foo', # "oops" + ); +}, qr/You must pass an ARRAY ref of roles/ ); + +ok !is_class_loaded('Made::Of::Fail'), "did not create Made::Of::Fail"; + +isnt( exception { + Moose::Meta::Class->create( + 'Continuing::To::Fail', + superclasses => ['Class'], + roles => ['Foo', 'Conflicts::With::Foo'], + ); +}, undef, 'conflicting roles == death' ); + +# XXX: Continuing::To::Fail gets created anyway + +done_testing; diff --git a/t/basics/create_anon.t b/t/basics/create_anon.t new file mode 100644 index 0000000..b36b2a8 --- /dev/null +++ b/t/basics/create_anon.t @@ -0,0 +1,125 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Meta::Class; + +{ + package Class; + use Moose; + + package Foo; + use Moose::Role; + sub foo_role_applied { 1 } + + package Bar; + use Moose::Role; + sub bar_role_applied { 1 } +} + +# try without caching first + +{ + my $class_and_foo_1 = Moose::Meta::Class->create_anon_class( + superclasses => ['Class'], + roles => ['Foo'], + ); + + my $class_and_foo_2 = Moose::Meta::Class->create_anon_class( + superclasses => ['Class'], + roles => ['Foo'], + ); + + isnt $class_and_foo_1->name, $class_and_foo_2->name, + 'creating the same class twice without caching results in 2 classes'; + + map { ok $_->name->foo_role_applied } ($class_and_foo_1, $class_and_foo_2); +} + +# now try with caching + +{ + my $class_and_foo_1 = Moose::Meta::Class->create_anon_class( + superclasses => ['Class'], + roles => ['Foo'], + cache => 1, + ); + + my $class_and_foo_2 = Moose::Meta::Class->create_anon_class( + superclasses => ['Class'], + roles => ['Foo'], + cache => 1, + ); + + is $class_and_foo_1->name, $class_and_foo_2->name, + 'with cache, the same class is the same class'; + + map { ok $_->name->foo_role_applied } ($class_and_foo_1, $class_and_foo_2); + + my $class_and_bar = Moose::Meta::Class->create_anon_class( + superclasses => ['Class'], + roles => ['Bar'], + cache => 1, + ); + + isnt $class_and_foo_1->name, $class_and_bar, + 'class_and_foo and class_and_bar are different'; + + ok $class_and_bar->name->bar_role_applied; +} + +# This tests that a cached metaclass can be reinitialized and still retain its +# metaclass object. +{ + my $name = Moose::Meta::Class->create_anon_class( + superclasses => ['Class'], + cache => 1, + )->name; + + $name->meta->reinitialize( $name ); + + can_ok( $name, 'meta' ); +} + +{ + my $name; + { + my $meta = Moose::Meta::Class->create_anon_class( + superclasses => ['Class'], + cache => 1, + ); + $name = $meta->name; + ok(!Class::MOP::metaclass_is_weak($name), "cache implies weaken => 0"); + } + ok(Class::MOP::class_of($name), "cache implies weaken => 0"); + Class::MOP::remove_metaclass_by_name($name); +} + +{ + my $name; + { + my $meta = Moose::Meta::Class->create_anon_class( + superclasses => ['Class'], + cache => 1, + weaken => 1, + ); + my $name = $meta->name; + ok(Class::MOP::metaclass_is_weak($name), "but we can override this"); + } + ok(!Class::MOP::class_of($name), "but we can override this"); +} + +{ + my $meta = Moose::Meta::Class->create_anon_class( + superclasses => ['Class'], + cache => 1, + ); + ok(!Class::MOP::metaclass_is_weak($meta->name), + "creates a nonweak metaclass"); + Scalar::Util::weaken($meta); + Class::MOP::remove_metaclass_by_name($meta->name); + ok(!$meta, "removing a cached anon class means it's actually gone"); +} + +done_testing; diff --git a/t/basics/deprecations.t b/t/basics/deprecations.t new file mode 100644 index 0000000..1eb7a9c --- /dev/null +++ b/t/basics/deprecations.t @@ -0,0 +1,23 @@ +use strict; +use warnings; + +use Test::More; + +use Moose (); +use Moose::Util::TypeConstraints; + +{ + my $warnings; + local $SIG{__WARN__} = sub { $warnings .= $_[0] }; + enum Foo => qw(Bar Baz Quux); + like($warnings, qr/Passing a list of values to enum is deprecated\. Enum values should be wrapped in an arrayref\./); +} + +{ + my $warnings; + local $SIG{__WARN__} = sub { $warnings .= $_[0] }; + duck_type Bar => qw(baz quux); + like($warnings, qr/Passing a list of values to duck_type is deprecated\. The method names should be wrapped in an arrayref\./); +} + +done_testing; diff --git a/t/basics/destruction.t b/t/basics/destruction.t new file mode 100644 index 0000000..55cb78e --- /dev/null +++ b/t/basics/destruction.t @@ -0,0 +1,51 @@ +use strict; +use warnings; + +use Test::More; + +our @demolished; +package Foo; +use Moose; + +sub DEMOLISH { + my $self = shift; + push @::demolished, __PACKAGE__; +} + +package Foo::Sub; +use Moose; +extends 'Foo'; + +sub DEMOLISH { + my $self = shift; + push @::demolished, __PACKAGE__; +} + +package Foo::Sub::Sub; +use Moose; +extends 'Foo::Sub'; + +sub DEMOLISH { + my $self = shift; + push @::demolished, __PACKAGE__; +} + +package main; +{ + my $foo = Foo->new; +} +is_deeply(\@demolished, ['Foo'], "Foo demolished properly"); +@demolished = (); +{ + my $foo_sub = Foo::Sub->new; +} +is_deeply(\@demolished, ['Foo::Sub', 'Foo'], "Foo::Sub demolished properly"); +@demolished = (); +{ + my $foo_sub_sub = Foo::Sub::Sub->new; +} +is_deeply(\@demolished, ['Foo::Sub::Sub', 'Foo::Sub', 'Foo'], + "Foo::Sub::Sub demolished properly"); +@demolished = (); + +done_testing; diff --git a/t/basics/error_handling.t b/t/basics/error_handling.t new file mode 100644 index 0000000..250aa30 --- /dev/null +++ b/t/basics/error_handling.t @@ -0,0 +1,19 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +# This tests the error handling in Moose::Object only + +{ + package Foo; + use Moose; +} + +like( exception { Foo->new('bad') }, qr/^\QSingle parameters to new() must be a HASH ref/, 'A single non-hashref arg to a constructor throws an error' ); +like( exception { Foo->new(undef) }, qr/^\QSingle parameters to new() must be a HASH ref/, 'A single non-hashref arg to a constructor throws an error' ); + +like( exception { Foo->does() }, qr/^\QYou must supply a role name to does()/, 'Cannot call does() without a role name' ); + +done_testing; diff --git a/t/basics/global-destruction-helper.pl b/t/basics/global-destruction-helper.pl new file mode 100644 index 0000000..a5b75c6 --- /dev/null +++ b/t/basics/global-destruction-helper.pl @@ -0,0 +1,34 @@ +#!/usr/bin/perl + +use strict; +use warnings; + + +{ + package Foo; + use Moose; + + sub DEMOLISH { + my $self = shift; + my ($igd) = @_; + + print $igd; + } +} + +{ + package Bar; + use Moose; + + sub DEMOLISH { + my $self = shift; + my ($igd) = @_; + + print $igd; + } + + __PACKAGE__->meta->make_immutable; +} + +our $foo = Foo->new; +our $bar = Bar->new; diff --git a/t/basics/global_destruction.t b/t/basics/global_destruction.t new file mode 100644 index 0000000..53a4db1 --- /dev/null +++ b/t/basics/global_destruction.t @@ -0,0 +1,49 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Foo; + use Moose; + + sub DEMOLISH { + my $self = shift; + my ($igd) = @_; + ::ok( + !$igd, + 'in_global_destruction state is passed to DEMOLISH properly (false)' + ); + } +} + +{ + my $foo = Foo->new; +} + +{ + package Bar; + use Moose; + + sub DEMOLISH { + my $self = shift; + my ($igd) = @_; + ::ok( + !$igd, + 'in_global_destruction state is passed to DEMOLISH properly (false)' + ); + } + + __PACKAGE__->meta->make_immutable; +} + +{ + my $bar = Bar->new; +} + +ok( + $_, + 'in_global_destruction state is passed to DEMOLISH properly (true)' +) for split //, `$^X t/basics/global-destruction-helper.pl`; + +done_testing; diff --git a/t/basics/import_unimport.t b/t/basics/import_unimport.t new file mode 100644 index 0000000..b44fea7 --- /dev/null +++ b/t/basics/import_unimport.t @@ -0,0 +1,98 @@ +use strict; +use warnings; + +use Test::More; + + +my @moose_exports = qw( + extends with + has + before after around + override + augment + super inner + blessed confess +); + +{ + package Foo; + + eval 'use Moose'; + die $@ if $@; +} + +can_ok('Foo', $_) for @moose_exports; + +{ + package Foo; + + eval 'no Moose'; + die $@ if $@; +} + +ok(!Foo->can($_), '... Foo can no longer do ' . $_) for @moose_exports; + +# and check the type constraints as well + +my @moose_type_constraint_exports = qw( + type subtype as where message + coerce from via + enum + find_type_constraint +); + +{ + package Bar; + + eval 'use Moose::Util::TypeConstraints'; + die $@ if $@; +} + +can_ok('Bar', $_) for @moose_type_constraint_exports; + +{ + package Bar; + + eval 'no Moose::Util::TypeConstraints'; + die $@ if $@; +} + +ok(!Bar->can($_), '... Bar can no longer do ' . $_) for @moose_type_constraint_exports; + + +{ + package Baz; + + use Moose; + use Scalar::Util qw( blessed ); + + no Moose; +} + +can_ok( 'Baz', 'blessed' ); + +{ + package Moo; + + use Scalar::Util qw( blessed ); + use Moose; + + no Moose; +} + +can_ok( 'Moo', 'blessed' ); + +my $blessed; +{ + package Quux; + + use Scalar::Util qw( blessed ); + use Moose blessed => { -as => \$blessed }; + + no Moose; +} + +can_ok( 'Quux', 'blessed' ); +is( $blessed, \&Scalar::Util::blessed ); + +done_testing; diff --git a/t/basics/inner_and_augment.t b/t/basics/inner_and_augment.t new file mode 100644 index 0000000..c343c38 --- /dev/null +++ b/t/basics/inner_and_augment.t @@ -0,0 +1,117 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + + sub foo { 'Foo::foo(' . (inner() || '') . ')' } + sub bar { 'Foo::bar(' . (inner() || '') . ')' } + sub baz { 'Foo::baz(' . (inner() || '') . ')' } + + package Bar; + use Moose; + + extends 'Foo'; + + augment foo => sub { 'Bar::foo(' . (inner() || '') . ')' }; + augment bar => sub { 'Bar::bar' }; + + no Moose; # ensure inner() still works after unimport + + package Baz; + use Moose; + + extends 'Bar'; + + augment foo => sub { 'Baz::foo' }; + augment baz => sub { 'Baz::baz' }; + + # this will actually never run, + # because Bar::bar does not call inner() + augment bar => sub { 'Baz::bar' }; +} + +my $baz = Baz->new(); +isa_ok($baz, 'Baz'); +isa_ok($baz, 'Bar'); +isa_ok($baz, 'Foo'); + +is($baz->foo(), 'Foo::foo(Bar::foo(Baz::foo))', '... got the right value from &foo'); +is($baz->bar(), 'Foo::bar(Bar::bar)', '... got the right value from &bar'); +is($baz->baz(), 'Foo::baz(Baz::baz)', '... got the right value from &baz'); + +my $bar = Bar->new(); +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +is($bar->foo(), 'Foo::foo(Bar::foo())', '... got the right value from &foo'); +is($bar->bar(), 'Foo::bar(Bar::bar)', '... got the right value from &bar'); +is($bar->baz(), 'Foo::baz()', '... got the right value from &baz'); + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +is($foo->foo(), 'Foo::foo()', '... got the right value from &foo'); +is($foo->bar(), 'Foo::bar()', '... got the right value from &bar'); +is($foo->baz(), 'Foo::baz()', '... got the right value from &baz'); + +# test saved state when crossing objects + +{ + package X; + use Moose; + has name => (is => 'rw'); + sub run { + "$_[0]->{name}.X", inner() + } + + package Y; + use Moose; + extends 'X'; + augment 'run' => sub { + "$_[0]->{name}.Y", ($_[1] ? $_[1]->() : ()), inner(); + }; + + package Z; + use Moose; + extends 'Y'; + augment 'run' => sub { + "$_[0]->{name}.Z" + } +} + +is('a.X a.Y b.X b.Y b.Z a.Z', + do { + my $a = Z->new(name => 'a'); + my $b = Z->new(name => 'b'); + join(' ', $a->run(sub { $b->run })) + }, + 'State is saved when cross-calling augmented methods on different objects'); + +# some error cases + +{ + package Bling; + use Moose; + + sub bling { 'Bling::bling' } + + package Bling::Bling; + use Moose; + + extends 'Bling'; + + sub bling { 'Bling::bling' } + + ::isnt( ::exception { + augment 'bling' => sub {}; + }, undef, '... cannot augment a method which has a local equivalent' ); + +} + +done_testing; diff --git a/t/basics/load_into_main.t b/t/basics/load_into_main.t new file mode 100644 index 0000000..ddfb834 --- /dev/null +++ b/t/basics/load_into_main.t @@ -0,0 +1,16 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +is( exception { + eval 'use Moose'; +}, undef, "export to main" ); + +isa_ok( main->meta, "Moose::Meta::Class" ); + +isa_ok( main->new, "main"); +isa_ok( main->new, "Moose::Object" ); + +done_testing; diff --git a/t/basics/method_modifier_with_regexp.t b/t/basics/method_modifier_with_regexp.t new file mode 100644 index 0000000..8f9319b --- /dev/null +++ b/t/basics/method_modifier_with_regexp.t @@ -0,0 +1,84 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + + package Dog; + use Moose; + + sub bark_once { + my $self = shift; + return 'bark'; + } + + sub bark_twice { + return 'barkbark'; + } + + around qr/bark.*/ => sub { + 'Dog::around(' . $_[0]->() . ')'; + }; + +} + +my $dog = Dog->new; +is( $dog->bark_once, 'Dog::around(bark)', 'around modifier is called' ); +is( $dog->bark_twice, 'Dog::around(barkbark)', 'around modifier is called' ); + +{ + + package Cat; + use Moose; + our $BEFORE_BARK_COUNTER = 0; + our $AFTER_BARK_COUNTER = 0; + + sub bark_once { + my $self = shift; + return 'bark'; + } + + sub bark_twice { + return 'barkbark'; + } + + before qr/bark.*/ => sub { + $BEFORE_BARK_COUNTER++; + }; + + after qr/bark.*/ => sub { + $AFTER_BARK_COUNTER++; + }; + +} + +my $cat = Cat->new; +$cat->bark_once; +is( $Cat::BEFORE_BARK_COUNTER, 1, 'before modifier is called once' ); +is( $Cat::AFTER_BARK_COUNTER, 1, 'after modifier is called once' ); +$cat->bark_twice; +is( $Cat::BEFORE_BARK_COUNTER, 2, 'before modifier is called twice' ); +is( $Cat::AFTER_BARK_COUNTER, 2, 'after modifier is called twice' ); + +{ + package Dog::Role; + use Moose::Role; + + ::isnt( ::exception { + before qr/bark.*/ => sub {}; + }, undef, '... this is not currently supported' ); + + ::isnt( ::exception { + around qr/bark.*/ => sub {}; + }, undef, '... this is not currently supported' ); + + ::isnt( ::exception { + after qr/bark.*/ => sub {}; + }, undef, '... this is not currently supported' ); + +} + +done_testing; diff --git a/t/basics/methods.t b/t/basics/methods.t new file mode 100644 index 0000000..da34a07 --- /dev/null +++ b/t/basics/methods.t @@ -0,0 +1,44 @@ +use strict; +use warnings; + +use Test::More; + + +my $test1 = Moose::Meta::Class->create_anon_class; +$test1->add_method( 'foo1', sub { } ); + +my $t1 = $test1->new_object; +my $t1_am = $t1->meta->get_method('foo1')->associated_metaclass; + +ok( $t1_am, 'associated_metaclass is defined' ); + +isa_ok( + $t1_am, 'Moose::Meta::Class', + 'associated_metaclass is correct class' +); + +like( $t1_am->name(), qr/::__ANON__::/, + 'associated_metaclass->name looks like an anonymous class' ); + +{ + package Test2; + + use Moose; + + sub foo2 { } +} + +my $t2 = Test2->new; +my $t2_am = $t2->meta->get_method('foo2')->associated_metaclass; + +ok( $t2_am, 'associated_metaclass is defined' ); + +isa_ok( + $t2_am, 'Moose::Meta::Class', + 'associated_metaclass is correct class' +); + +is( $t2_am->name(), 'Test2', + 'associated_metaclass->name is Test2' ); + +done_testing; diff --git a/t/basics/moose_object_does.t b/t/basics/moose_object_does.t new file mode 100644 index 0000000..87338af --- /dev/null +++ b/t/basics/moose_object_does.t @@ -0,0 +1,158 @@ +use strict; +use warnings; + +use Test::More; +use Test::Moose; + +{ + package Role::A; + use Moose::Role +} + +{ + package Role::B; + use Moose::Role +} + +{ + package Foo; + use Moose; +} + +{ + package Bar; + use Moose; + + with 'Role::A'; +} + +{ + package Baz; + use Moose; + + with qw( Role::A Role::B ); +} + +{ + package Foo::Child; + use Moose; + + extends 'Foo'; +} + +{ + package Bar::Child; + use Moose; + + extends 'Bar'; +} + +{ + package Baz::Child; + use Moose; + + extends 'Baz'; +} + +with_immutable { + + for my $thing ( 'Foo', Foo->new, 'Foo::Child', Foo::Child->new ) { + my $name = ref $thing ? (ref $thing) . ' object' : "$thing class"; + $name .= ' (immutable)' if $thing->meta->is_immutable; + + ok( + !$thing->does('Role::A'), + "$name does not do Role::A" + ); + ok( + !$thing->does('Role::B'), + "$name does not do Role::B" + ); + + ok( + !$thing->does( Role::A->meta ), + "$name does not do Role::A (passed as object)" + ); + ok( + !$thing->does( Role::B->meta ), + "$name does not do Role::B (passed as object)" + ); + + ok( + !$thing->DOES('Role::A'), + "$name does not do Role::A (using DOES)" + ); + ok( + !$thing->DOES('Role::B'), + "$name does not do Role::B (using DOES)" + ); + } + + for my $thing ( 'Bar', Bar->new, 'Bar::Child', Bar::Child->new ) { + my $name = ref $thing ? (ref $thing) . ' object' : "$thing class"; + $name .= ' (immutable)' if $thing->meta->is_immutable; + + ok( + $thing->does('Role::A'), + "$name does Role::A" + ); + ok( + !$thing->does('Role::B'), + "$name does not do Role::B" + ); + + ok( + $thing->does( Role::A->meta ), + "$name does Role::A (passed as object)" + ); + ok( + !$thing->does( Role::B->meta ), + "$name does not do Role::B (passed as object)" + ); + + ok( + $thing->DOES('Role::A'), + "$name does Role::A (using DOES)" + ); + ok( + !$thing->DOES('Role::B'), + "$name does not do Role::B (using DOES)" + ); + } + + for my $thing ( 'Baz', Baz->new, 'Baz::Child', Baz::Child->new ) { + my $name = ref $thing ? (ref $thing) . ' object' : "$thing class"; + $name .= ' (immutable)' if $thing->meta->is_immutable; + + ok( + $thing->does('Role::A'), + "$name does Role::A" + ); + ok( + $thing->does('Role::B'), + "$name does Role::B" + ); + + ok( + $thing->does( Role::A->meta ), + "$name does Role::A (passed as object)" + ); + ok( + $thing->does( Role::B->meta ), + "$name does Role::B (passed as object)" + ); + + ok( + $thing->DOES('Role::A'), + "$name does Role::A (using DOES)" + ); + ok( + $thing->DOES('Role::B'), + "$name does Role::B (using DOES)" + ); + } + +} +qw( Foo Bar Baz Foo::Child Bar::Child Baz::Child ); + +done_testing; diff --git a/t/basics/moose_respects_type_constraints.t b/t/basics/moose_respects_type_constraints.t new file mode 100644 index 0000000..5dba161 --- /dev/null +++ b/t/basics/moose_respects_type_constraints.t @@ -0,0 +1,59 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +=pod + +This tests demonstrates that Moose will not override +a preexisting type constraint of the same name when +making constraints for a Moose-class. + +It also tests that an attribute which uses a 'Foo' for +its isa option will get the subtype Foo, and not a +type representing the Foo moose class. + +=cut + +BEGIN { + # create this subtype first (in BEGIN) + subtype Foo + => as 'Value' + => where { $_ eq 'Foo' }; +} + +{ # now seee if Moose will override it + package Foo; + use Moose; +} + +my $foo_constraint = find_type_constraint('Foo'); +isa_ok($foo_constraint, 'Moose::Meta::TypeConstraint'); + +is($foo_constraint->parent->name, 'Value', '... got the Value subtype for Foo'); + +ok($foo_constraint->check('Foo'), '... my constraint passed correctly'); +ok(!$foo_constraint->check('Bar'), '... my constraint failed correctly'); + +{ + package Bar; + use Moose; + + has 'foo' => (is => 'rw', isa => 'Foo'); +} + +my $bar = Bar->new; +isa_ok($bar, 'Bar'); + +is( exception { + $bar->foo('Foo'); +}, undef, '... checked the type constraint correctly' ); + +isnt( exception { + $bar->foo(Foo->new); +}, undef, '... checked the type constraint correctly' ); + +done_testing; diff --git a/t/basics/override_and_foreign_classes.t b/t/basics/override_and_foreign_classes.t new file mode 100644 index 0000000..f671fe9 --- /dev/null +++ b/t/basics/override_and_foreign_classes.t @@ -0,0 +1,72 @@ +use strict; +use warnings; + +use Test::More; + + +=pod + +This just tests the interaction of override/super +with non-Moose superclasses. It really should not +cause issues, the only thing it does is to create +a metaclass for Foo so that it can find the right +super method. + +This may end up being a sensitive issue for some +non-Moose classes, but in 99% of the cases it +should be just fine. + +=cut + +{ + package Foo; + use strict; + use warnings; + + sub new { bless {} => shift() } + + sub foo { 'Foo::foo' } + sub bar { 'Foo::bar' } + sub baz { 'Foo::baz' } + + package Bar; + use Moose; + + extends 'Foo'; + + override bar => sub { 'Bar::bar -> ' . super() }; + + package Baz; + use Moose; + + extends 'Bar'; + + override bar => sub { 'Baz::bar -> ' . super() }; + override baz => sub { 'Baz::baz -> ' . super() }; +} + +my $baz = Baz->new(); +isa_ok($baz, 'Baz'); +isa_ok($baz, 'Bar'); +isa_ok($baz, 'Foo'); + +is($baz->foo(), 'Foo::foo', '... got the right value from &foo'); +is($baz->bar(), 'Baz::bar -> Bar::bar -> Foo::bar', '... got the right value from &bar'); +is($baz->baz(), 'Baz::baz -> Foo::baz', '... got the right value from &baz'); + +my $bar = Bar->new(); +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +is($bar->foo(), 'Foo::foo', '... got the right value from &foo'); +is($bar->bar(), 'Bar::bar -> Foo::bar', '... got the right value from &bar'); +is($bar->baz(), 'Foo::baz', '... got the right value from &baz'); + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +is($foo->foo(), 'Foo::foo', '... got the right value from &foo'); +is($foo->bar(), 'Foo::bar', '... got the right value from &bar'); +is($foo->baz(), 'Foo::baz', '... got the right value from &baz'); + +done_testing; diff --git a/t/basics/override_augment_inner_super.t b/t/basics/override_augment_inner_super.t new file mode 100644 index 0000000..7ec35ea --- /dev/null +++ b/t/basics/override_augment_inner_super.t @@ -0,0 +1,69 @@ +use strict; +use warnings; + +use Test::More; + + +{ + package Foo; + use Moose; + + sub foo { 'Foo::foo(' . (inner() || '') . ')' }; + sub bar { 'Foo::bar(' . (inner() || '') . ')' } + + package Bar; + use Moose; + + extends 'Foo'; + + augment 'foo' => sub { 'Bar::foo' }; + override 'bar' => sub { 'Bar::bar -> ' . super() }; + + package Baz; + use Moose; + + extends 'Bar'; + + override 'foo' => sub { 'Baz::foo -> ' . super() }; + augment 'bar' => sub { 'Baz::bar' }; +} + +my $baz = Baz->new(); +isa_ok($baz, 'Baz'); +isa_ok($baz, 'Bar'); +isa_ok($baz, 'Foo'); + +=pod + +Let em clarify what is happening here. Baz::foo is calling +super(), which calls Bar::foo, which is an augmented sub +that calls Foo::foo, then calls inner() which actually +then calls Bar::foo. Confusing I know,.. but this is +*exactly* what is it supposed to do :) + +=cut + +is($baz->foo, + 'Baz::foo -> Foo::foo(Bar::foo)', + '... got the right value from mixed augment/override foo'); + +=pod + +Allow me to clarify this one now ... + +Since Baz::bar is an augment routine, it needs to find the +correct inner() to be called by. In this case it is Foo::bar. +However, Bar::bar is in-between us, so it should actually be +called first. Bar::bar is an overriden sub, and calls super() +which in turn then calls our Foo::bar, which calls inner(), +which calls Baz::bar. + +Confusing I know, but it is correct :) + +=cut + +is($baz->bar, + 'Bar::bar -> Foo::bar(Baz::bar)', + '... got the right value from mixed augment/override bar'); + +done_testing; diff --git a/t/basics/rebless.t b/t/basics/rebless.t new file mode 100644 index 0000000..db08d6b --- /dev/null +++ b/t/basics/rebless.t @@ -0,0 +1,136 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::Moose qw(with_immutable); +use Scalar::Util 'blessed'; + +use Moose::Util::TypeConstraints; + +subtype 'Positive' + => as 'Num' + => where { $_ > 0 }; + +{ + package Parent; + use Moose; + + has name => ( + is => 'rw', + isa => 'Str', + ); + + has lazy_classname => ( + is => 'ro', + lazy => 1, + default => sub { "Parent" }, + ); + + has type_constrained => ( + is => 'rw', + isa => 'Num', + default => 5.5, + ); + + package Child; + use Moose; + extends 'Parent'; + + has '+name' => ( + default => 'Junior', + ); + + has '+lazy_classname' => ( + default => sub {"Child"}, + ); + + has '+type_constrained' => ( + isa => 'Int', + default => 100, + ); + + our %trigger_calls; + our %initializer_calls; + + has new_attr => ( + is => 'rw', + isa => 'Str', + trigger => sub { + my ( $self, $val, $attr ) = @_; + $trigger_calls{new_attr}++; + }, + initializer => sub { + my ( $self, $value, $set, $attr ) = @_; + $initializer_calls{new_attr}++; + $set->($value); + }, + ); +} + +my @classes = qw(Parent Child); + +with_immutable { + my $foo = Parent->new; + my $bar = Parent->new; + + is( blessed($foo), 'Parent', 'Parent->new gives a Parent object' ); + is( $foo->name, undef, 'No name yet' ); + is( $foo->lazy_classname, 'Parent', "lazy attribute initialized" ); + is( + exception { $foo->type_constrained(10.5) }, undef, + "Num type constraint for now.." + ); + + # try to rebless, except it will fail due to Child's stricter type constraint + like( + exception { Child->meta->rebless_instance($foo) }, + qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 10\.5/, + '... this failed because of type check' + ); + like( + exception { Child->meta->rebless_instance($bar) }, + qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 5\.5/, + '... this failed because of type check' + ); + + $foo->type_constrained(10); + $bar->type_constrained(5); + + Child->meta->rebless_instance($foo); + Child->meta->rebless_instance( $bar, new_attr => 'blah' ); + + is( blessed($foo), 'Child', 'successfully reblessed into Child' ); + is( $foo->name, 'Junior', "Child->name's default came through" ); + + is( + $foo->lazy_classname, 'Parent', + "lazy attribute was already initialized" + ); + is( + $bar->lazy_classname, 'Child', + "lazy attribute just now initialized" + ); + + like( + exception { $foo->type_constrained(10.5) }, + qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 10\.5/, + '... this failed because of type check' + ); + + is_deeply( + \%Child::trigger_calls, { new_attr => 1 }, + 'Trigger fired on rebless_instance' + ); + is_deeply( + \%Child::initializer_calls, { new_attr => 1 }, + 'Initializer fired on rebless_instance' + ); + + undef %Child::trigger_calls; + undef %Child::initializer_calls; + +} +@classes; + +done_testing; diff --git a/t/basics/require_superclasses.t b/t/basics/require_superclasses.t new file mode 100644 index 0000000..f2b1683 --- /dev/null +++ b/t/basics/require_superclasses.t @@ -0,0 +1,64 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Test::More; +use Test::Fatal; + + +{ + + package Bar; + use Moose; + + ::is( ::exception { extends 'Foo' }, undef, 'loaded Foo superclass correctly' ); +} + +{ + + package Baz; + use Moose; + + ::is( ::exception { extends 'Bar' }, undef, 'loaded (inline) Bar superclass correctly' ); +} + +{ + + package Foo::Bar; + use Moose; + + ::is( ::exception { extends 'Foo', 'Bar' }, undef, 'loaded Foo and (inline) Bar superclass correctly' ); +} + +{ + + package Bling; + use Moose; + + my $warnings = ''; + local $SIG{__WARN__} = sub { $warnings .= $_[0] }; + ::is( ::exception { extends 'No::Class' }, undef, "extending an empty package is a valid thing to do" ); + ::like( $warnings, qr/^Can't locate package No::Class for \@Bling::ISA/, "but it does give a warning" ); +} + +{ + package Affe; + our $VERSION = 23; +} + +{ + package Tiger; + use Moose; + + ::is( ::exception { extends 'Foo', Affe => { -version => 13 } }, undef, 'extends with version requirement' ); +} + +{ + package Birne; + use Moose; + + ::like( ::exception { extends 'Foo', Affe => { -version => 42 } }, qr/Affe version 42 required--this is only version 23/, 'extends with unsatisfied version requirement' ); +} + +done_testing; diff --git a/t/basics/super_and_override.t b/t/basics/super_and_override.t new file mode 100644 index 0000000..edebc71 --- /dev/null +++ b/t/basics/super_and_override.t @@ -0,0 +1,79 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + + sub foo { 'Foo::foo' } + sub bar { 'Foo::bar' } + sub baz { 'Foo::baz' } + + package Bar; + use Moose; + + extends 'Foo'; + + override bar => sub { 'Bar::bar -> ' . super() }; + + package Baz; + use Moose; + + extends 'Bar'; + + override bar => sub { 'Baz::bar -> ' . super() }; + override baz => sub { 'Baz::baz -> ' . super() }; + + no Moose; # ensure super() still works after unimport +} + +my $baz = Baz->new(); +isa_ok($baz, 'Baz'); +isa_ok($baz, 'Bar'); +isa_ok($baz, 'Foo'); + +is($baz->foo(), 'Foo::foo', '... got the right value from &foo'); +is($baz->bar(), 'Baz::bar -> Bar::bar -> Foo::bar', '... got the right value from &bar'); +is($baz->baz(), 'Baz::baz -> Foo::baz', '... got the right value from &baz'); + +my $bar = Bar->new(); +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +is($bar->foo(), 'Foo::foo', '... got the right value from &foo'); +is($bar->bar(), 'Bar::bar -> Foo::bar', '... got the right value from &bar'); +is($bar->baz(), 'Foo::baz', '... got the right value from &baz'); + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +is($foo->foo(), 'Foo::foo', '... got the right value from &foo'); +is($foo->bar(), 'Foo::bar', '... got the right value from &bar'); +is($foo->baz(), 'Foo::baz', '... got the right value from &baz'); + +# some error cases + +{ + package Bling; + use Moose; + + sub bling { 'Bling::bling' } + + package Bling::Bling; + use Moose; + + extends 'Bling'; + + sub bling { 'Bling::bling' } + + ::isnt( ::exception { + override 'bling' => sub {}; + }, undef, '... cannot override a method which has a local equivalent' ); + +} + +done_testing; diff --git a/t/basics/super_warns_on_args.t b/t/basics/super_warns_on_args.t new file mode 100644 index 0000000..3600d9f --- /dev/null +++ b/t/basics/super_warns_on_args.t @@ -0,0 +1,44 @@ +use strict; +use warnings; + +use Test::Requires 'Test::Output'; +use Test::More; + +{ + package Parent; + use Moose; + + sub foo { 42 } + sub bar { 42 } + + package Child; + use Moose; + + extends 'Parent'; + + override foo => sub { + super( 1, 2, 3 ); + }; + + override bar => sub { + super(); + }; +} + +{ + my $file = __FILE__; + + stderr_like( + sub { Child->new->foo }, + qr/\QArguments passed to super() are ignored at $file/, + 'got a warning when passing args to super() call' + ); + + stderr_is( + sub { Child->new->bar }, + q{}, + 'no warning on super() call without arguments' + ); +} + +done_testing(); diff --git a/t/basics/universal_methods_wrappable.t b/t/basics/universal_methods_wrappable.t new file mode 100644 index 0000000..350688c --- /dev/null +++ b/t/basics/universal_methods_wrappable.t @@ -0,0 +1,29 @@ +use strict; +use warnings; + +use Test::Fatal; +use Test::More; + +{ + + package FakeBar; + use Moose::Role; + + around isa => sub { + my ( $orig, $self, $v ) = @_; + return 1 if $v eq 'Bar'; + return $orig->( $self, $v ); + }; + + package Foo; + use Moose; + + use Test::More; + + ::is( ::exception { with 'FakeBar' }, undef, 'applied role' ); + + my $foo = Foo->new; + ::isa_ok( $foo, 'Bar' ); +} + +done_testing; diff --git a/t/basics/wrapped_method_cxt_propagation.t b/t/basics/wrapped_method_cxt_propagation.t new file mode 100644 index 0000000..ce1e243 --- /dev/null +++ b/t/basics/wrapped_method_cxt_propagation.t @@ -0,0 +1,56 @@ +use strict; +use warnings; + +use Test::More; + + +{ + package TouchyBase; + use Moose; + + has x => ( is => 'rw', default => 0 ); + + sub inc { $_[0]->x( 1 + $_[0]->x ) } + + sub scalar_or_array { + wantarray ? (qw/a b c/) : "x"; + } + + sub void { + die "this must be void context" if defined wantarray; + } + + package AfterSub; + use Moose; + + extends "TouchyBase"; + + after qw/scalar_or_array void/ => sub { + my $self = shift; + $self->inc; + } +} + +my $base = TouchyBase->new; +my $after = AfterSub->new; + +foreach my $obj ( $base, $after ) { + my $class = ref $obj; + my @array = $obj->scalar_or_array; + my $scalar = $obj->scalar_or_array; + + is_deeply(\@array, [qw/a b c/], "array context ($class)"); + is($scalar, "x", "scalar context ($class)"); + + { + local $@; + eval { $obj->void }; + ok( !$@, "void context ($class)" ); + } + + if ( $obj->isa("AfterSub") ) { + is( $obj->x, 3, "methods were wrapped" ); + } +} + +done_testing; diff --git a/t/bugs/DEMOLISHALL.t b/t/bugs/DEMOLISHALL.t new file mode 100644 index 0000000..43d831e --- /dev/null +++ b/t/bugs/DEMOLISHALL.t @@ -0,0 +1,54 @@ +use strict; +use warnings; +use Test::More; + +my @called; + +do { + package Class; + use Moose; + + sub DEMOLISH { + push @called, 'Class::DEMOLISH'; + } + + sub DEMOLISHALL { + my $self = shift; + push @called, 'Class::DEMOLISHALL'; + $self->SUPER::DEMOLISHALL(@_); + } + + package Child; + use Moose; + extends 'Class'; + + sub DEMOLISH { + push @called, 'Child::DEMOLISH'; + } + + sub DEMOLISHALL { + my $self = shift; + push @called, 'Child::DEMOLISHALL'; + $self->SUPER::DEMOLISHALL(@_); + } +}; + +is_deeply([splice @called], [], "no DEMOLISH calls yet"); + +do { + my $object = Class->new; + + is_deeply([splice @called], [], "no DEMOLISH calls yet"); +}; + +is_deeply([splice @called], ['Class::DEMOLISHALL', 'Class::DEMOLISH']); + +do { + my $child = Child->new; + is_deeply([splice @called], [], "no DEMOLISH calls yet"); + +}; + +is_deeply([splice @called], ['Child::DEMOLISHALL', 'Class::DEMOLISHALL', 'Child::DEMOLISH', 'Class::DEMOLISH']); + +done_testing; diff --git a/t/bugs/DEMOLISHALL_shortcutted.t b/t/bugs/DEMOLISHALL_shortcutted.t new file mode 100644 index 0000000..9095791 --- /dev/null +++ b/t/bugs/DEMOLISHALL_shortcutted.t @@ -0,0 +1,35 @@ +use strict; +use warnings; + +## This test ensures that sub DEMOLISHALL fires even if there is no sub DEMOLISH +## Currently fails because of a bad optimization in DESTROY +## Feb 12, 2009 -- Evan Carroll me@evancarroll.com +package Role::DemolishAll; +use Moose::Role; +our $ok = 0; + +sub BUILD { $ok = 0 }; +after 'DEMOLISHALL' => sub { $Role::DemolishAll::ok++ }; + +package DemolishAll::WithoutDemolish; +use Moose; +with 'Role::DemolishAll'; + +package DemolishAll::WithDemolish; +use Moose; +with 'Role::DemolishAll'; +sub DEMOLISH {}; + + +package main; +use Test::More; + +my $m = DemolishAll::WithDemolish->new; +undef $m; +is ( $Role::DemolishAll::ok, 1, 'DemolishAll w/ explicit DEMOLISH sub' ); + +$m = DemolishAll::WithoutDemolish->new; +undef $m; +is ( $Role::DemolishAll::ok, 1, 'DemolishAll wo/ explicit DEMOLISH sub' ); + +done_testing; diff --git a/t/bugs/DEMOLISH_eats_exceptions.t b/t/bugs/DEMOLISH_eats_exceptions.t new file mode 100644 index 0000000..c8e9bb1 --- /dev/null +++ b/t/bugs/DEMOLISH_eats_exceptions.t @@ -0,0 +1,149 @@ +use strict; +use warnings; +use FindBin; + +use Test::More; + +use Moose::Util::TypeConstraints; + +subtype 'FilePath' + => as 'Str' + # This used to try to _really_ check for a valid Unix or Windows + # path, but the regex wasn't quite right, and all we care about + # for the tests is that it rejects '/' + => where { $_ ne '/' }; +{ + package Baz; + use Moose; + use Moose::Util::TypeConstraints; + + has 'path' => ( + is => 'ro', + isa => 'FilePath', + required => 1, + ); + + sub BUILD { + my ( $self, $params ) = @_; + confess $params->{path} . " does not exist" + unless -e $params->{path}; + } + + # Defining this causes the FIRST call to Baz->new w/o param to fail, + # if no call to ANY Moose::Object->new was done before. + sub DEMOLISH { + my ( $self ) = @_; + } +} + +{ + package Qee; + use Moose; + use Moose::Util::TypeConstraints; + + has 'path' => ( + is => 'ro', + isa => 'FilePath', + required => 1, + ); + + sub BUILD { + my ( $self, $params ) = @_; + confess $params->{path} . " does not exist" + unless -e $params->{path}; + } + + # Defining this causes the FIRST call to Qee->new w/o param to fail... + # if no call to ANY Moose::Object->new was done before. + sub DEMOLISH { + my ( $self ) = @_; + } +} + +{ + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + has 'path' => ( + is => 'ro', + isa => 'FilePath', + required => 1, + ); + + sub BUILD { + my ( $self, $params ) = @_; + confess $params->{path} . " does not exist" + unless -e $params->{path}; + } + + # Having no DEMOLISH, everything works as expected... +} + +check_em ( 'Baz' ); # 'Baz plain' will fail, aka NO error +check_em ( 'Qee' ); # ok +check_em ( 'Foo' ); # ok + +check_em ( 'Qee' ); # 'Qee plain' will fail, aka NO error +check_em ( 'Baz' ); # ok +check_em ( 'Foo' ); # ok + +check_em ( 'Foo' ); # ok +check_em ( 'Baz' ); # ok ! +check_em ( 'Qee' ); # ok + + +sub check_em { + my ( $pkg ) = @_; + my ( %param, $obj ); + + # Uncomment to see, that it is really any first call. + # Subsequents calls will not fail, aka giving the correct error. + { + local $@; + my $obj = eval { $pkg->new; }; + ::like( $@, qr/is required/, "... $pkg plain" ); + ::is( $obj, undef, "... the object is undef" ); + } + { + local $@; + my $obj = eval { $pkg->new(); }; + ::like( $@, qr/is required/, "... $pkg empty" ); + ::is( $obj, undef, "... the object is undef" ); + } + { + local $@; + my $obj = eval { $pkg->new ( notanattr => 1 ); }; + ::like( $@, qr/is required/, "... $pkg undef" ); + ::is( $obj, undef, "... the object is undef" ); + } + + { + local $@; + my $obj = eval { $pkg->new ( %param ); }; + ::like( $@, qr/is required/, "... $pkg undef param" ); + ::is( $obj, undef, "... the object is undef" ); + } + { + local $@; + my $obj = eval { $pkg->new ( path => '/' ); }; + ::like( $@, qr/does not pass the type constraint/, "... $pkg root path forbidden" ); + ::is( $obj, undef, "... the object is undef" ); + } + { + local $@; + my $obj = eval { $pkg->new ( path => '/this_path/does/not_exist' ); }; + ::like( $@, qr/does not exist/, "... $pkg non existing path" ); + ::is( $obj, undef, "... the object is undef" ); + } + { + local $@; + my $obj = eval { $pkg->new ( path => $FindBin::Bin ); }; + ::is( $@, '', "... $pkg no error" ); + ::isa_ok( $obj, $pkg ); + ::isa_ok( $obj, 'Moose::Object' ); + ::is( $obj->path, $FindBin::Bin, "... $pkg got the right value" ); + } +} + +done_testing; diff --git a/t/bugs/DEMOLISH_eats_mini.t b/t/bugs/DEMOLISH_eats_mini.t new file mode 100644 index 0000000..ab09e8a --- /dev/null +++ b/t/bugs/DEMOLISH_eats_mini.t @@ -0,0 +1,79 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + + has 'bar' => ( + is => 'ro', + required => 1, + ); + + # Defining this causes the FIRST call to Baz->new w/o param to fail, + # if no call to ANY Moose::Object->new was done before. + sub DEMOLISH { + my ( $self ) = @_; + # ... Moose (kinda) eats exceptions in DESTROY/DEMOLISH"; + } +} + +{ + my $obj = eval { Foo->new; }; + like( $@, qr/is required/, "... Foo plain" ); + is( $obj, undef, "... the object is undef" ); +} + +{ + package Bar; + + sub new { die "Bar died"; } + + sub DESTROY { + die "Vanilla Perl eats exceptions in DESTROY too"; + } +} + +{ + my $obj = eval { Bar->new; }; + like( $@, qr/Bar died/, "... Bar plain" ); + is( $obj, undef, "... the object is undef" ); +} + +{ + package Baz; + use Moose; + + sub DEMOLISH { + $? = 0; + } +} + +{ + local $@ = 42; + local $? = 84; + + { + Baz->new; + } + + is( $@, 42, '$@ is still 42 after object is demolished without dying' ); + is( $?, 84, '$? is still 84 after object is demolished without dying' ); + + local $@ = 0; + + { + Baz->new; + } + + is( $@, 0, '$@ is still 0 after object is demolished without dying' ); + + Baz->meta->make_immutable, redo + if Baz->meta->is_mutable +} + +done_testing; diff --git a/t/bugs/DEMOLISH_fails_without_metaclass.t b/t/bugs/DEMOLISH_fails_without_metaclass.t new file mode 100644 index 0000000..b0b0cf4 --- /dev/null +++ b/t/bugs/DEMOLISH_fails_without_metaclass.t @@ -0,0 +1,34 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package MyClass; + use Moose; + + sub DEMOLISH { } +} + +my $object = MyClass->new; + +# Removing the metaclass simulates the case where the metaclass object +# goes out of scope _before_ the object itself, which under normal +# circumstances only happens during global destruction. +Class::MOP::remove_metaclass_by_name('MyClass'); + +# The bug happened when DEMOLISHALL called +# Class::MOP::class_of($object) and did not get a metaclass object +# back. +is( exception { $object->DESTROY }, undef, 'can call DESTROY on an object without a metaclass object in the CMOP cache' ); + + +MyClass->meta->make_immutable; +Class::MOP::remove_metaclass_by_name('MyClass'); + +# The bug didn't manifest for immutable objects, but this test should +# help us prevent it happening in the future. +is( exception { $object->DESTROY }, undef, 'can call DESTROY on an object without a metaclass object in the CMOP cache (immutable version)' ); + +done_testing; diff --git a/t/bugs/Moose_Object_error.t b/t/bugs/Moose_Object_error.t new file mode 100644 index 0000000..b45f092 --- /dev/null +++ b/t/bugs/Moose_Object_error.t @@ -0,0 +1,10 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Test::More; + +use_ok('MyMooseObject'); + +done_testing; diff --git a/t/bugs/anon_method_metaclass.t b/t/bugs/anon_method_metaclass.t new file mode 100644 index 0000000..01c5285 --- /dev/null +++ b/t/bugs/anon_method_metaclass.t @@ -0,0 +1,50 @@ +use strict; +use warnings; +use Test::More; + +{ + package Ball; + use Moose; +} + +{ + package Arbitrary::Roll; + use Moose::Role; +} + +my $method_meta = Moose::Meta::Class->create_anon_class( + superclasses => ['Moose::Meta::Method'], + roles => ['Arbitrary::Roll'], +); + +# For comparing identity without actually keeping $original_meta around +my $original_meta = "$method_meta"; + +my $method_class = $method_meta->name; + +my $method_object = $method_class->wrap( + sub {'ok'}, + associated_metaclass => Ball->meta, + package_name => 'Ball', + name => 'bounce', +); + +Ball->meta->add_method( bounce => $method_object ); + +for ( 1, 2 ) { + is( Ball->bounce, 'ok', "method still exists on Ball" ); + is( Ball->meta->get_method('bounce')->meta->name, $method_class, + "method's package still exists" ); + + is( Ball->meta->get_method('bounce'), $method_object, + 'original method object is preserved' ); + + is( Ball->meta->get_method('bounce')->meta . '', $original_meta, + "method's metaclass still exists" ); + ok( Ball->meta->get_method('bounce')->meta->does_role('Arbitrary::Roll'), + "method still does Arbitrary::Roll" ); + + undef $method_meta; +} + +done_testing; diff --git a/t/bugs/application_metarole_compat.t b/t/bugs/application_metarole_compat.t new file mode 100644 index 0000000..70d17a7 --- /dev/null +++ b/t/bugs/application_metarole_compat.t @@ -0,0 +1,56 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +BEGIN { + { + package Foo; + use Moose::Role; + } + + { + package Bar::Class; + use Moose::Role; + } + + { + package Bar::ToClass; + use Moose::Role; + + after apply => sub { + my $self = shift; + my ($role, $class) = @_; + Moose::Util::MetaRole::apply_metaroles( + for => $class, + class_metaroles => { + class => ['Bar::Class'], + } + ); + }; + } + + { + package Bar; + use Moose::Role; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + role_metaroles => { + application_to_class => ['Bar::ToClass'], + } + ); + } +} + +{ + package Parent; + use Moose -traits => 'Foo'; +} + +{ + package Child; + use Moose -traits => 'Bar'; + ::is( ::exception { extends 'Parent' }, undef ); +} + +done_testing; diff --git a/t/bugs/apply_role_to_one_instance_only.t b/t/bugs/apply_role_to_one_instance_only.t new file mode 100644 index 0000000..36df900 --- /dev/null +++ b/t/bugs/apply_role_to_one_instance_only.t @@ -0,0 +1,43 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +{ + package MyRole1; + use Moose::Role; + + sub a_role_method { 'foo' } +} + +{ + package MyRole2; + use Moose::Role; + # empty +} + +{ + package Foo; + use Moose; +} + +my $instance_with_role1 = Foo->new; +MyRole1->meta->apply($instance_with_role1); + +my $instance_with_role2 = Foo->new; +MyRole2->meta->apply($instance_with_role2); + +ok ((not $instance_with_role2->does('MyRole1')), + 'instance does not have the wrong role'); + +ok ((not $instance_with_role2->can('a_role_method')), + 'instance does not have methods from the wrong role'); + +ok (($instance_with_role1->does('MyRole1')), + 'role was applied to the correct instance'); + +is( exception { + is $instance_with_role1->a_role_method, 'foo' +}, undef, 'instance has correct role method' ); + +done_testing; diff --git a/t/bugs/attribute_trait_parameters.t b/t/bugs/attribute_trait_parameters.t new file mode 100644 index 0000000..cd053d1 --- /dev/null +++ b/t/bugs/attribute_trait_parameters.t @@ -0,0 +1,46 @@ +use strict; +use warnings; + +use Test::More; +use Test::Requires 'Test::Output'; # skip all if not installed + +{ + package R; + use Moose::Role; + + sub method { } +} + +{ + package C; + use Moose; + + ::stderr_is{ + has attr => ( + is => 'ro', + traits => [ + R => { ignored => 1 }, + ], + ); + } q{}, 'no warning with foreign parameterized attribute traits'; + + ::stderr_is{ + has alias_attr => ( + is => 'ro', + traits => [ + R => { -alias => { method => 'new_name' } }, + ], + ); + } q{}, 'no warning with -alias parameterized attribute traits'; + + ::stderr_is{ + has excludes_attr => ( + is => 'ro', + traits => [ + R => { -excludes => ['method'] }, + ], + ); + } q{}, 'no warning with -excludes parameterized attribute traits'; +} + +done_testing; diff --git a/t/bugs/augment_recursion_bug.t b/t/bugs/augment_recursion_bug.t new file mode 100644 index 0000000..e55ca5a --- /dev/null +++ b/t/bugs/augment_recursion_bug.t @@ -0,0 +1,47 @@ +use strict; +use warnings; + +use Test::More; + + +{ + package Foo; + use Moose; + + sub foo { 'Foo::foo(' . (inner() || '') . ')' }; + + package Bar; + use Moose; + + extends 'Foo'; + + package Baz; + use Moose; + + extends 'Foo'; + + my $foo_call_counter; + augment 'foo' => sub { + die "infinite loop on Baz::foo" if $foo_call_counter++ > 1; + return 'Baz::foo and ' . Bar->new->foo; + }; +} + +my $baz = Baz->new(); +isa_ok($baz, 'Baz'); +isa_ok($baz, 'Foo'); + +=pod + +When a subclass which augments foo(), calls a subclass which does not augment +foo(), there is a chance for some confusion. If Moose does not realize that +Bar does not augment foo(), because it is in the call flow of Baz which does, +then we may have an infinite loop. + +=cut + +is($baz->foo, + 'Foo::foo(Baz::foo and Foo::foo())', + '... got the right value for 1 augmented subclass calling non-augmented subclass'); + +done_testing; diff --git a/t/bugs/coerce_without_coercion.t b/t/bugs/coerce_without_coercion.t new file mode 100644 index 0000000..63b74d3 --- /dev/null +++ b/t/bugs/coerce_without_coercion.t @@ -0,0 +1,26 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::Moose; + +{ + package Foo; + + use Moose; + + ::like( + ::exception { + has x => ( + is => 'rw', + isa => 'HashRef', + coerce => 1, + ) + }, + qr/You cannot coerce an attribute \(x\) unless its type \(HashRef\) has a coercion/, + "can't set coerce on an attribute whose type constraint has no coercion" + ); +} + +done_testing; diff --git a/t/bugs/constructor_object_overload.t b/t/bugs/constructor_object_overload.t new file mode 100644 index 0000000..c2d1347 --- /dev/null +++ b/t/bugs/constructor_object_overload.t @@ -0,0 +1,19 @@ +use strict; +use warnings; +use Test::More; + +{ + package Foo; + + use Moose; + + use overload '""' => sub {''}; + + sub bug { 'plenty' } + + __PACKAGE__->meta->make_immutable; +} + +ok(Foo->new()->bug(), 'call constructor on object reference with overloading'); + +done_testing; diff --git a/t/bugs/create_anon_recursion.t b/t/bugs/create_anon_recursion.t new file mode 100644 index 0000000..436048a --- /dev/null +++ b/t/bugs/create_anon_recursion.t @@ -0,0 +1,29 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +BEGIN { + plan skip_all => "preloading things makes this test meaningless" + if exists $INC{'Moose.pm'}; +} + +use Moose::Meta::Class; + +$SIG{__WARN__} = sub { die if shift =~ /recurs/ }; + +TODO: +{ + local $TODO + = 'Loading Moose::Meta::Class without loading Moose.pm causes weird problems'; + + my $meta; + is( exception { + $meta = Moose::Meta::Class->create_anon_class( + superclasses => [ 'Moose::Object', ], + ); + }, undef, 'Class is created successfully' ); +} + +done_testing; diff --git a/t/bugs/create_anon_role_pass.t b/t/bugs/create_anon_role_pass.t new file mode 100644 index 0000000..1e28d76 --- /dev/null +++ b/t/bugs/create_anon_role_pass.t @@ -0,0 +1,39 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Moose (); + +use lib 't/lib'; + +{ + package t::bugs::Bar; + use Moose; + + # empty class. + + no Moose; + __PACKAGE__->meta->make_immutable(); + + 1; +} + +my $meta; +use Data::Dumper; +isnt ( exception { + $meta = Moose::Meta::Class->create_anon_class( + superclasses => [ 't::bugs::Bar', ], # any old class will work + roles => [ 'Role::BreakOnLoad', ], + ) +}, undef, 'Class dies when attempting composition'); + +my $except; +isnt ( $except = exception { + $meta = Moose::Meta::Class->create_anon_class( + superclasses => [ 't::bugs::Bar', ], + roles => [ 'Role::BreakOnLoad', ], + ); +}, undef, 'Class continues to die when attempting composition'); + +done_testing; diff --git a/t/bugs/delete_sub_stash.t b/t/bugs/delete_sub_stash.t new file mode 100644 index 0000000..ce3f968 --- /dev/null +++ b/t/bugs/delete_sub_stash.t @@ -0,0 +1,23 @@ +use strict; +use warnings; +use Test::More; + +use Moose (); + +{ + package Foo; + sub bar { 'BAR' } +} + +my $method = \&Foo::bar; + +{ + no strict 'refs'; + delete ${'::'}{'Foo::'}; +} + +my $meta = Moose::Meta::Class->create('Bar'); +$meta->add_method(bar => $method); +is(Bar->bar, 'BAR'); + +done_testing; diff --git a/t/bugs/handles_foreign_class_bug.t b/t/bugs/handles_foreign_class_bug.t new file mode 100644 index 0000000..4706d08 --- /dev/null +++ b/t/bugs/handles_foreign_class_bug.t @@ -0,0 +1,111 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package Foo; + + sub new { + bless({}, 'Foo') + } + + sub a { 'Foo::a' } + + $INC{'Foo.pm'} = __FILE__; +} + +{ + package Bar; + use Moose; + + ::is( ::exception { + has 'baz' => ( + is => 'ro', + isa => 'Foo', + lazy => 1, + default => sub { Foo->new() }, + handles => qr/^a$/, + ); + }, undef, '... can create the attribute with delegations' ); + +} + +my $bar; +is( exception { + $bar = Bar->new; +}, undef, '... created the object ok' ); +isa_ok($bar, 'Bar'); + +is($bar->a, 'Foo::a', '... got the right delgated value'); + +my @w; +$SIG{__WARN__} = sub { push @w, "@_" }; +{ + package Baz; + use Moose; + + ::is( ::exception { + has 'bar' => ( + is => 'ro', + isa => 'Foo', + lazy => 1, + default => sub { Foo->new() }, + handles => qr/.*/, + ); + }, undef, '... can create the attribute with delegations' ); + +} + +is(@w, 0, "no warnings"); + + +my $baz; +is( exception { + $baz = Baz->new; +}, undef, '... created the object ok' ); +isa_ok($baz, 'Baz'); + +is($baz->a, 'Foo::a', '... got the right delgated value'); + + + + + +@w = (); + +{ + package Blart; + use Moose; + + ::is( ::exception { + has 'bar' => ( + is => 'ro', + isa => 'Foo', + lazy => 1, + default => sub { Foo->new() }, + handles => [qw(a new)], + ); + }, undef, '... can create the attribute with delegations' ); + +} + +{ + local $TODO = "warning not yet implemented"; + + is(@w, 1, "one warning"); + like($w[0], qr/not delegating.*new/i, "warned"); +} + + + +my $blart; +is( exception { + $blart = Blart->new; +}, undef, '... created the object ok' ); +isa_ok($blart, 'Blart'); + +is($blart->a, 'Foo::a', '... got the right delgated value'); + +done_testing; diff --git a/t/bugs/immutable_metaclass_does_role.t b/t/bugs/immutable_metaclass_does_role.t new file mode 100644 index 0000000..00cec0b --- /dev/null +++ b/t/bugs/immutable_metaclass_does_role.t @@ -0,0 +1,90 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +BEGIN { + package MyRole; + use Moose::Role; + + requires 'foo'; + + package MyMetaclass; + use Moose qw(extends with); + extends 'Moose::Meta::Class'; + with 'MyRole'; + + sub foo { 'i am foo' } +} + +{ + package MyClass; + use metaclass ('MyMetaclass'); + use Moose; +} + +my $mc = MyMetaclass->initialize('MyClass'); +isa_ok($mc, 'MyMetaclass'); + +ok($mc->meta->does_role('MyRole'), '... the metaclass does the role'); + +is(MyClass->meta, $mc, '... these metas are the same thing'); +is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing'); + +my $a = MyClass->new; +ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); +is( $a->meta->foo, 'i am foo', '... foo method returns expected value' ); +ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); +is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' ); + +is( exception { + MyClass->meta->make_immutable; +}, undef, '... make MyClass immutable okay' ); + +is(MyClass->meta, $mc, '... these metas are still the same thing'); +is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing'); + +ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); +is( $a->meta->foo, 'i am foo', '... foo method returns expected value' ); +ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); +is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' ); + +is( exception { + MyClass->meta->make_mutable; +}, undef, '... make MyClass mutable okay' ); + +is(MyClass->meta, $mc, '... these metas are still the same thing'); +is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing'); + +ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); +is( $a->meta->foo, 'i am foo', '... foo method returns expected value' ); +ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); +is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' ); + +is( exception { + MyMetaclass->meta->make_immutable; +}, undef, '... make MyMetaclass immutable okay' ); + +is(MyClass->meta, $mc, '... these metas are still the same thing'); +is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing'); + +ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); +is( $a->meta->foo, 'i am foo', '... foo method returns expected value' ); +ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); +is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' ); + +is( exception { + MyClass->meta->make_immutable; +}, undef, '... make MyClass immutable (again) okay' ); + +is(MyClass->meta, $mc, '... these metas are still the same thing'); +is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing'); + +ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); +is( $a->meta->foo, 'i am foo', '... foo method returns expected value' ); +ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); +is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' ); + +done_testing; diff --git a/t/bugs/immutable_n_default_x2.t b/t/bugs/immutable_n_default_x2.t new file mode 100644 index 0000000..2ba3e3b --- /dev/null +++ b/t/bugs/immutable_n_default_x2.t @@ -0,0 +1,39 @@ +use strict; +use warnings; + +use Test::More; + + +{ + package Foo; + use Moose; + + our $foo_default_called = 0; + + has foo => ( + is => 'rw', + isa => 'Str', + default => sub { $foo_default_called++; 'foo' }, + ); + + our $bar_default_called = 0; + + has bar => ( + is => 'rw', + isa => 'Str', + lazy => 1, + default => sub { $bar_default_called++; 'bar' }, + ); + + __PACKAGE__->meta->make_immutable; +} + +my $foo = Foo->new(); + +is($Foo::foo_default_called, 1, "foo default was only called once during constructor"); + +$foo->bar(); + +is($Foo::bar_default_called, 1, "bar default was only called once when lazy attribute is accessed"); + +done_testing; diff --git a/t/bugs/inheriting_from_roles.t b/t/bugs/inheriting_from_roles.t new file mode 100644 index 0000000..093864b --- /dev/null +++ b/t/bugs/inheriting_from_roles.t @@ -0,0 +1,21 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package My::Role; + use Moose::Role; +} +{ + package My::Class; + use Moose; + + ::like( ::exception { + extends 'My::Role'; + }, qr/You cannot inherit from a Moose Role \(My\:\:Role\)/, '... this croaks correctly' ); +} + +done_testing; diff --git a/t/bugs/inline_reader_bug.t b/t/bugs/inline_reader_bug.t new file mode 100644 index 0000000..ef14f71 --- /dev/null +++ b/t/bugs/inline_reader_bug.t @@ -0,0 +1,29 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +=pod + +This was a bug, but it is fixed now. This +test makes sure it does not creep back in. + +=cut + +{ + package Foo; + use Moose; + + ::is( ::exception { + has 'bar' => ( + is => 'ro', + isa => 'Int', + lazy => 1, + default => 10, + ); + }, undef, '... this didnt die' ); +} + +done_testing; diff --git a/t/bugs/instance_application_role_args.t b/t/bugs/instance_application_role_args.t new file mode 100644 index 0000000..120d12e --- /dev/null +++ b/t/bugs/instance_application_role_args.t @@ -0,0 +1,50 @@ +use strict; +use warnings; +use Test::More; + +{ + package Point; + use Moose; + + with qw/DoesNegated DoesTranspose/; + + has x => ( isa => 'Int', is => 'rw' ); + has y => ( isa => 'Int', is => 'rw' ); + + sub inspect { [$_[0]->x, $_[0]->y] } + + no Moose; +} + +{ + package DoesNegated; + use Moose::Role; + + sub negated { + my $self = shift; + $self->new( x => -$self->x, y => -$self->y ); + } + + no Moose::Role; +} + +{ + package DoesTranspose; + use Moose::Role; + + sub transpose { + my $self = shift; + $self->new( x => $self->y, y => $self->x ); + } + + no Moose::Role; +} + +my $p = Point->new( x => 4, y => 3 ); + +DoesTranspose->meta->apply( $p, -alias => { transpose => 'negated' } ); + +is_deeply($p->negated->inspect, [3, 4]); +is_deeply($p->transpose->inspect, [3, 4]); + +done_testing; diff --git a/t/bugs/lazybuild_required_undef.t b/t/bugs/lazybuild_required_undef.t new file mode 100644 index 0000000..9870587 --- /dev/null +++ b/t/bugs/lazybuild_required_undef.t @@ -0,0 +1,33 @@ +use strict; +use warnings; + +package Foo; +use Moose; + +## Problem: +## lazy_build sets required => 1 +## required does not permit setting to undef + +## Possible solutions: +#### remove required => 1 +#### check the attr to see if it accepts Undef (Maybe[], | Undef) +#### or, make required accept undef and use a predicate test + + +has 'foo' => ( isa => 'Int | Undef', is => 'rw', lazy_build => 1 ); +has 'bar' => ( isa => 'Int | Undef', is => 'rw' ); + +sub _build_foo { undef } + +package main; +use Test::More; + +ok ( !defined(Foo->new->bar), 'NonLazyBuild: Undef default' ); +ok ( !defined(Foo->new->bar(undef)), 'NonLazyBuild: Undef explicit' ); + +ok ( !defined(Foo->new->foo), 'LazyBuild: Undef default/lazy_build' ); + +## This test fails at the time of creation. +ok ( !defined(Foo->new->foo(undef)), 'LazyBuild: Undef explicit' ); + +done_testing; diff --git a/t/bugs/mark_as_methods_overloading_breakage.t b/t/bugs/mark_as_methods_overloading_breakage.t new file mode 100644 index 0000000..c9e0097 --- /dev/null +++ b/t/bugs/mark_as_methods_overloading_breakage.t @@ -0,0 +1,33 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::Requires { + 'MooseX::MarkAsMethods' => 0, +}; + +{ + package Role2; + use Moose::Role; + use MooseX::MarkAsMethods; + use overload q{""} => '_stringify'; + sub _stringify {ref $_[0]} +} + +{ + package Class2; + use Moose; + with 'Role2'; +} + +ok(! exception { + my $class2 = Class2->new; + is( + "$class2", + 'Class2', + 'Class2 got stringification overloading from Role2' + ); +}, 'No error creating a Class2 object'); + +done_testing; diff --git a/t/bugs/moose_exporter_false_circular_reference_rt_63818.t b/t/bugs/moose_exporter_false_circular_reference_rt_63818.t new file mode 100644 index 0000000..dd41ce2 --- /dev/null +++ b/t/bugs/moose_exporter_false_circular_reference_rt_63818.t @@ -0,0 +1,154 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +# OKSet1 +{ + + package TESTING::MooseExporter::Rt63818::OKSet1::ModuleA; + use Moose (); + Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + ] + ); +} + +# OKSet2 +{ + + package TESTING::MooseExporter::Rt63818::OKSet2::ModuleA; + use Moose (); + Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + ] + ); + + package TESTING::MooseExporter::Rt63818::OKSet2::ModuleB; + use Moose (); + Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + ] + ); +} + +# OKSet3 +{ + + package TESTING::MooseExporter::Rt63818::OKSet3::ModuleA; + use Moose (); + Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + ] + ); + + package TESTING::MooseExporter::Rt63818::OKSet3::ModuleB; + use Moose (); + Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + 'TESTING::MooseExporter::Rt63818::OKSet3::ModuleA', + ] + ); +} + +# OKSet4 +{ + + package TESTING::MooseExporter::Rt63818::OKSet4::ModuleA; + use Moose (); + Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + ] + ); + + package TESTING::MooseExporter::Rt63818::OKSet4::ModuleB; + use Moose (); + Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + 'TESTING::MooseExporter::Rt63818::OKSet4::ModuleA', + ] + ); + + package TESTING::MooseExporter::Rt63818::OKSet4::ModuleC; + use Moose (); + Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + 'TESTING::MooseExporter::Rt63818::OKSet4::ModuleA', + 'TESTING::MooseExporter::Rt63818::OKSet4::ModuleB', + ] + ); +} + +# OKSet5 +{ + + package TESTING::MooseExporter::Rt63818::OKSet5::ModuleA; + use Moose (); + Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + ] + ); + + package TESTING::MooseExporter::Rt63818::OKSet5::ModuleB; + use Moose (); + Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + 'TESTING::MooseExporter::Rt63818::OKSet5::ModuleA', + ] + ); + + package TESTING::MooseExporter::Rt63818::OKSet5::ModuleC; + use Moose (); + Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + 'TESTING::MooseExporter::Rt63818::OKSet5::ModuleA', + 'TESTING::MooseExporter::Rt63818::OKSet5::ModuleB', + ] + ); + + package TESTING::MooseExporter::Rt63818::OKSet5::ModuleD; + use Moose (); + Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + 'TESTING::MooseExporter::Rt63818::OKSet5::ModuleA', + 'TESTING::MooseExporter::Rt63818::OKSet5::ModuleC', + ] + ); +} + +# NotOKSet1 +{ + + package TESTING::MooseExporter::Rt63818::NotOKSet1::ModuleA; + use Moose (); + ::like( + ::exception { Moose::Exporter->setup_import_methods( + also => [ + 'Moose', + 'TESTING::MooseExporter::Rt63818::NotOKSet1::ModuleA', + ] + ) + }, + qr/\QCircular reference in 'also' parameter to Moose::Exporter between TESTING::MooseExporter::Rt63818::NotOKSet1::ModuleA and TESTING::MooseExporter::Rt63818::NotOKSet1::ModuleA/, + 'a single-hop circular reference in also dies with an error' + ); +} + +# Alas, I've not figured out how to craft a test which shows that we get the +# same error for multi-hop circularity... instead I get tests that die because +# one of the circularly-referenced things was not loaded. + +done_testing; diff --git a/t/bugs/moose_octal_defaults.t b/t/bugs/moose_octal_defaults.t new file mode 100644 index 0000000..42a0fb5 --- /dev/null +++ b/t/bugs/moose_octal_defaults.t @@ -0,0 +1,121 @@ +use strict; +use warnings; + +use Test::More; + +{ + my $package = qq{ +package Test::Moose::Go::Boom; +use Moose; +use lib qw(lib); + +has id => ( + isa => 'Str', + is => 'ro', + default => '019600', # this caused the original failure +); + +no Moose; + +__PACKAGE__->meta->make_immutable; +}; + + eval $package; + $@ ? ::fail($@) : ::pass('quoted 019600 default works'); + my $obj = Test::Moose::Go::Boom->new; + ::is( $obj->id, '019600', 'value is still the same' ); +} + +{ + my $package = qq{ +package Test::Moose::Go::Boom2; +use Moose; +use lib qw(lib); + +has id => ( + isa => 'Str', + is => 'ro', + default => 017600, +); + +no Moose; + +__PACKAGE__->meta->make_immutable; +}; + + eval $package; + $@ ? ::fail($@) : ::pass('017600 octal default works'); + my $obj = Test::Moose::Go::Boom2->new; + ::is( $obj->id, 8064, 'value is still the same' ); +} + +{ + my $package = qq{ +package Test::Moose::Go::Boom3; +use Moose; +use lib qw(lib); + +has id => ( + isa => 'Str', + is => 'ro', + default => 0xFF, +); + +no Moose; + +__PACKAGE__->meta->make_immutable; +}; + + eval $package; + $@ ? ::fail($@) : ::pass('017600 octal default works'); + my $obj = Test::Moose::Go::Boom3->new; + ::is( $obj->id, 255, 'value is still the same' ); +} + +{ + my $package = qq{ +package Test::Moose::Go::Boom4; +use Moose; +use lib qw(lib); + +has id => ( + isa => 'Str', + is => 'ro', + default => '0xFF', +); + +no Moose; + +__PACKAGE__->meta->make_immutable; +}; + + eval $package; + $@ ? ::fail($@) : ::pass('017600 octal default works'); + my $obj = Test::Moose::Go::Boom4->new; + ::is( $obj->id, '0xFF', 'value is still the same' ); +} + +{ + my $package = qq{ +package Test::Moose::Go::Boom5; +use Moose; +use lib qw(lib); + +has id => ( + isa => 'Str', + is => 'ro', + default => '0 but true', +); + +no Moose; + +__PACKAGE__->meta->make_immutable; +}; + + eval $package; + $@ ? ::fail($@) : ::pass('017600 octal default works'); + my $obj = Test::Moose::Go::Boom5->new; + ::is( $obj->id, '0 but true', 'value is still the same' ); +} + +done_testing; diff --git a/t/bugs/native_trait_handles_bad_value.t b/t/bugs/native_trait_handles_bad_value.t new file mode 100644 index 0000000..34824aa --- /dev/null +++ b/t/bugs/native_trait_handles_bad_value.t @@ -0,0 +1,27 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + + package Bug; + use Moose; + + ::like( + ::exception{ has member => ( + is => 'ro', + isa => 'HashRef', + traits => ['Hash'], + handles => { + method => sub { } + }, + ); + }, + qr/\QAll values passed to handles must be strings or ARRAY references, not CODE/, + 'bad value in handles throws a useful error' + ); +} + +done_testing; diff --git a/t/bugs/overloading_edge_cases.t b/t/bugs/overloading_edge_cases.t new file mode 100644 index 0000000..af2abfc --- /dev/null +++ b/t/bugs/overloading_edge_cases.t @@ -0,0 +1,43 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Role::Overloads; + use Moose::Role; + use overload q{""} => 'as_string'; + requires 'as_string'; +} + +{ + package Class::Overloads; + use Moose; + with 'Role::Overloads'; + sub as_string { 'foo' } +} + +is( + Class::Overloads->new() . q{}, 'foo', + 'Class::Overloads overloads stringification with overloading defined in role and method defined in class' +); + +{ + package Parent::NoOverloads; + use Moose; + sub name { ref $_[0] } +} + +{ + package Child::Overloads; + use Moose; + use overload q{""} => 'name'; + extends 'Parent::NoOverloads'; +} + +is( + Child::Overloads->new() . q{}, 'Child::Overloads', + 'Child::Overloads overloads stringification with method inherited from parent' +); + +done_testing; diff --git a/t/bugs/reader_precedence_bug.t b/t/bugs/reader_precedence_bug.t new file mode 100644 index 0000000..e223a14 --- /dev/null +++ b/t/bugs/reader_precedence_bug.t @@ -0,0 +1,21 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Foo; + use Moose; + has 'foo' => ( is => 'ro', reader => 'get_foo' ); +} + +{ + my $foo = Foo->new(foo => 10); + my $reader = $foo->meta->get_attribute('foo')->reader; + is($reader, 'get_foo', + 'reader => "get_foo" has correct presedence'); + can_ok($foo, 'get_foo'); + is($foo->$reader, 10, "Reader works as expected"); +} + +done_testing; diff --git a/t/bugs/role_caller.t b/t/bugs/role_caller.t new file mode 100644 index 0000000..6fdf5a1 --- /dev/null +++ b/t/bugs/role_caller.t @@ -0,0 +1,30 @@ +use strict; +use warnings; + +package MyRole; + +use Moose::Role; + +sub foo { return (caller(0))[3] } + +no Moose::Role; + +package MyClass1; use Moose; with 'MyRole'; no Moose; +package MyClass2; use Moose; with 'MyRole'; no Moose; + +package main; + +use Test::More; + +{ + local $TODO = 'Role composition does not clone methods yet'; + is(MyClass1->foo, 'MyClass1::foo', + 'method from role has correct name in caller()'); + is(MyClass2->foo, 'MyClass2::foo', + 'method from role has correct name in caller()'); +} + +isnt(MyClass1->foo, "MyClass2::foo", "role method is not confused with other class" ); +isnt(MyClass2->foo, "MyClass1::foo", "role method is not confused with other class" ); + +done_testing; diff --git a/t/bugs/subclass_use_base_bug.t b/t/bugs/subclass_use_base_bug.t new file mode 100644 index 0000000..9a4521c --- /dev/null +++ b/t/bugs/subclass_use_base_bug.t @@ -0,0 +1,28 @@ +use strict; +use warnings; + +use Test::More; + +=pod + +This just makes sure that the Bar gets +a metaclass initialized for it correctly. + +=cut + +{ + package Foo; + use Moose; + + package Bar; + use strict; + use warnings; + + use parent -norequire => 'Foo'; +} + +my $bar = Bar->new; +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +done_testing; diff --git a/t/bugs/subtype_conflict_bug.t b/t/bugs/subtype_conflict_bug.t new file mode 100644 index 0000000..93125cd --- /dev/null +++ b/t/bugs/subtype_conflict_bug.t @@ -0,0 +1,11 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Test::More; + +use_ok('MyMooseA'); +use_ok('MyMooseB'); + +done_testing; diff --git a/t/bugs/subtype_quote_bug.t b/t/bugs/subtype_quote_bug.t new file mode 100644 index 0000000..a507759 --- /dev/null +++ b/t/bugs/subtype_quote_bug.t @@ -0,0 +1,34 @@ +use strict; +use warnings; + +use Test::More; + +=pod + +This is a test for a bug found by Purge on #moose: +The code: + + subtype Stuff + => as Object + => where { ... } + +will break if the Object:: namespace exists. So the +solution is to quote 'Object', like so: + + subtype Stuff + => as 'Object' + => where { ... } + +Moose 0.03 did this, now it doesn't, so all should +be well from now on. + +=cut + +{ package Object::Test; } + +{ + package Foo; + ::use_ok('Moose'); +} + +done_testing; diff --git a/t/bugs/super_recursion.t b/t/bugs/super_recursion.t new file mode 100644 index 0000000..b6d920f --- /dev/null +++ b/t/bugs/super_recursion.t @@ -0,0 +1,69 @@ +use strict; +use warnings; + +use Test::More; + +{ + package First; + use Moose; + + sub foo { + ::BAIL_OUT('First::foo called twice') if $main::seen{'First::foo'}++; + return '1'; + } + + sub bar { + ::BAIL_OUT('First::bar called twice') if $main::seen{'First::bar'}++; + return '1'; + } + + sub baz { + ::BAIL_OUT('First::baz called twice') if $main::seen{'First::baz'}++; + return '1'; + } +} + +{ + package Second; + use Moose; + extends qw(First); + + sub foo { + ::BAIL_OUT('Second::foo called twice') if $main::seen{'Second::foo'}++; + return '2' . super(); + } + + sub bar { + ::BAIL_OUT('Second::bar called twice') if $main::seen{'Second::bar'}++; + return '2' . ( super() || '' ); + } + + override baz => sub { + ::BAIL_OUT('Second::baz called twice') if $main::seen{'Second::baz'}++; + return '2' . super(); + }; +} + +{ + package Third; + use Moose; + extends qw(Second); + + sub foo { return '3' . ( super() || '' ) } + + override bar => sub { + ::BAIL_OUT('Third::bar called twice') if $main::seen{'Third::bar'}++; + return '3' . super(); + }; + + override baz => sub { + ::BAIL_OUT('Third::baz called twice') if $main::seen{'Third::baz'}++; + return '3' . super(); + }; +} + +is( Third->new->foo, '3' ); +is( Third->new->bar, '32' ); +is( Third->new->baz, '321' ); + +done_testing; diff --git a/t/bugs/traits_with_exporter.t b/t/bugs/traits_with_exporter.t new file mode 100644 index 0000000..8f4fe92 --- /dev/null +++ b/t/bugs/traits_with_exporter.t @@ -0,0 +1,77 @@ +use strict; +use warnings; + +use Test::More; +use lib 't/lib'; + +BEGIN { + package MyExporterRole; + + use Moose (); + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + also => 'Moose', + ); + + sub init_meta { + my ($class,%args) = @_; + + my $meta = Moose->init_meta( %args ); + + Moose::Util::MetaRole::apply_metaroles( + for => $meta, + class_metaroles => { + class => ['MyMetaRole'], + }, + ); + + return $meta; + } + + $INC{'MyExporterRole.pm'} = __FILE__; +} + +{ + package MyMetaRole; + use Moose::Role; + + sub some_meta_class_method { + return "HEY" + } +} + +{ + package MyTrait; + use Moose::Role; + + sub some_meta_class_method_defined_by_trait { + return "HO" + } + + { + package Moose::Meta::Class::Custom::Trait::MyClassTrait; + use strict; + use warnings; + sub register_implementation { return 'MyTrait' } + } +} + +{ + package MyClass; + use MyExporterRole -traits => 'MyClassTrait'; +} + + + +my $my_class = MyClass->new; + +isa_ok($my_class,'MyClass'); + +my $meta = $my_class->meta(); +# Check if MyMetaRole has been applied +ok($meta->can('some_meta_class_method'),'Meta class has some_meta_class_method'); +# Check if MyTrait has been applied +ok($meta->can('some_meta_class_method_defined_by_trait'),'Meta class has some_meta_class_method_defined_by_trait'); + +done_testing; diff --git a/t/bugs/type_constraint_messages.t b/t/bugs/type_constraint_messages.t new file mode 100644 index 0000000..5bb076b --- /dev/null +++ b/t/bugs/type_constraint_messages.t @@ -0,0 +1,65 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +# RT #37569 + +{ + package MyObject; + use Moose; + + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + subtype 'MyArrayRef' + => as 'ArrayRef' + => where { defined $_->[0] } + => message { ref $_ ? "ref: ". ref $_ : 'scalar' } # stringy + ; + + subtype 'MyObjectType' + => as 'Object' + => where { $_->isa('MyObject') } + => message { + if ( $_->isa('SomeObject') ) { + return 'More detailed error message'; + } + elsif ( blessed $_ ) { + return 'Well it is an object'; + } + else { + return 'Doh!'; + } + } + ; + + type 'NewType' + => where { $_->isa('MyObject') } + => message { blessed $_ ? 'blessed' : 'scalar' } + ; + + has 'obj' => ( is => 'rw', isa => 'MyObjectType' ); + has 'ar' => ( is => 'rw', isa => 'MyArrayRef' ); + has 'nt' => ( is => 'rw', isa => 'NewType' ); +} + +my $foo = Foo->new; +my $obj = MyObject->new; + +like( exception { + $foo->ar( [] ); +}, qr/Attribute \(ar\) does not pass the type constraint because: ref: ARRAY/, '... got the right error message' ); + +like( exception { + $foo->obj($foo); # Doh! +}, qr/Attribute \(obj\) does not pass the type constraint because: Well it is an object/, '... got the right error message' ); + +like( exception { + $foo->nt($foo); # scalar +}, qr/Attribute \(nt\) does not pass the type constraint because: blessed/, '... got the right error message' ); + +done_testing; diff --git a/t/cmop/ArrayBasedStorage_test.t b/t/cmop/ArrayBasedStorage_test.t new file mode 100644 index 0000000..a654879 --- /dev/null +++ b/t/cmop/ArrayBasedStorage_test.t @@ -0,0 +1,203 @@ +use strict; +use warnings; + +use Test::More; + +use Scalar::Util 'reftype'; +use Class::MOP; + +use lib 't/cmop/lib'; +use ArrayBasedStorage; + +{ + package Foo; + + use strict; + use warnings; + use metaclass ( + 'instance_metaclass' => 'ArrayBasedStorage::Instance', + ); + + Foo->meta->add_attribute('foo' => ( + accessor => 'foo', + clearer => 'clear_foo', + predicate => 'has_foo', + )); + + Foo->meta->add_attribute('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + default => 'FOO is BAR' + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + package Bar; + use metaclass ( + 'instance_metaclass' => 'ArrayBasedStorage::Instance', + ); + + use strict; + use warnings; + + use parent -norequire => 'Foo'; + + Bar->meta->add_attribute('baz' => ( + accessor => 'baz', + predicate => 'has_baz', + )); + + package Baz; + use metaclass ( + 'instance_metaclass' => 'ArrayBasedStorage::Instance', + ); + + use strict; + use warnings; + use metaclass ( + 'instance_metaclass' => 'ArrayBasedStorage::Instance', + ); + + Baz->meta->add_attribute('bling' => ( + accessor => 'bling', + default => 'Baz::bling' + )); + + package Bar::Baz; + use metaclass ( + 'instance_metaclass' => 'ArrayBasedStorage::Instance', + ); + + use strict; + use warnings; + + use parent -norequire => 'Bar', 'Baz'; +} + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +is(reftype($foo), 'ARRAY', '... Foo is made with ARRAY'); + +can_ok($foo, 'foo'); +can_ok($foo, 'has_foo'); +can_ok($foo, 'get_bar'); +can_ok($foo, 'set_bar'); +can_ok($foo, 'clear_foo'); + +ok(!$foo->has_foo, '... Foo::foo is not defined yet'); +is($foo->foo(), undef, '... Foo::foo is not defined yet'); +is($foo->get_bar(), 'FOO is BAR', '... Foo::bar has been initialized'); + +$foo->foo('This is Foo'); + +ok($foo->has_foo, '... Foo::foo is defined now'); +is($foo->foo(), 'This is Foo', '... Foo::foo == "This is Foo"'); + +$foo->clear_foo; + +ok(!$foo->has_foo, '... Foo::foo is not defined anymore'); +is($foo->foo(), undef, '... Foo::foo is not defined anymore'); + +$foo->set_bar(42); +is($foo->get_bar(), 42, '... Foo::bar == 42'); + +my $foo2 = Foo->new(); +isa_ok($foo2, 'Foo'); + +is(reftype($foo2), 'ARRAY', '... Foo is made with ARRAY'); + +ok(!$foo2->has_foo, '... Foo2::foo is not defined yet'); +is($foo2->foo(), undef, '... Foo2::foo is not defined yet'); +is($foo2->get_bar(), 'FOO is BAR', '... Foo2::bar has been initialized'); + +$foo2->set_bar('DONT PANIC'); +is($foo2->get_bar(), 'DONT PANIC', '... Foo2::bar == DONT PANIC'); + +is($foo->get_bar(), 42, '... Foo::bar == 42'); + +# now Bar ... + +my $bar = Bar->new(); +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +is(reftype($bar), 'ARRAY', '... Bar is made with ARRAY'); + +can_ok($bar, 'foo'); +can_ok($bar, 'has_foo'); +can_ok($bar, 'get_bar'); +can_ok($bar, 'set_bar'); +can_ok($bar, 'baz'); +can_ok($bar, 'has_baz'); + +ok(!$bar->has_foo, '... Bar::foo is not defined yet'); +is($bar->foo(), undef, '... Bar::foo is not defined yet'); +is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); +ok(!$bar->has_baz, '... Bar::baz is not defined yet'); +is($bar->baz(), undef, '... Bar::baz is not defined yet'); + +$bar->foo('This is Bar::foo'); + +ok($bar->has_foo, '... Bar::foo is defined now'); +is($bar->foo(), 'This is Bar::foo', '... Bar::foo == "This is Bar"'); +is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); + +$bar->baz('This is Bar::baz'); + +ok($bar->has_baz, '... Bar::baz is defined now'); +is($bar->baz(), 'This is Bar::baz', '... Bar::foo == "This is Bar"'); +is($bar->foo(), 'This is Bar::foo', '... Bar::foo == "This is Bar"'); +is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); + +# now Baz ... + +my $baz = Bar::Baz->new(); +isa_ok($baz, 'Bar::Baz'); +isa_ok($baz, 'Bar'); +isa_ok($baz, 'Foo'); +isa_ok($baz, 'Baz'); + +is(reftype($baz), 'ARRAY', '... Bar::Baz is made with ARRAY'); + +can_ok($baz, 'foo'); +can_ok($baz, 'has_foo'); +can_ok($baz, 'get_bar'); +can_ok($baz, 'set_bar'); +can_ok($baz, 'baz'); +can_ok($baz, 'has_baz'); +can_ok($baz, 'bling'); + +is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); +is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); + +ok(!$baz->has_foo, '... Bar::Baz::foo is not defined yet'); +is($baz->foo(), undef, '... Bar::Baz::foo is not defined yet'); +ok(!$baz->has_baz, '... Bar::Baz::baz is not defined yet'); +is($baz->baz(), undef, '... Bar::Baz::baz is not defined yet'); + +$baz->foo('This is Bar::Baz::foo'); + +ok($baz->has_foo, '... Bar::Baz::foo is defined now'); +is($baz->foo(), 'This is Bar::Baz::foo', '... Bar::Baz::foo == "This is Bar"'); +is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); +is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); + +$baz->baz('This is Bar::Baz::baz'); + +ok($baz->has_baz, '... Bar::Baz::baz is defined now'); +is($baz->baz(), 'This is Bar::Baz::baz', '... Bar::Baz::foo == "This is Bar"'); +is($baz->foo(), 'This is Bar::Baz::foo', '... Bar::Baz::foo == "This is Bar"'); +is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); +is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); + +Foo->meta->add_attribute( forgotten => is => "rw" ); + +my $new_baz = Bar::Baz->new; + +cmp_ok( scalar(@$new_baz), ">", scalar(@$baz), "additional slot due to refreshed meta instance" ); + +done_testing; diff --git a/t/cmop/AttributesWithHistory_test.t b/t/cmop/AttributesWithHistory_test.t new file mode 100644 index 0000000..3b28a12 --- /dev/null +++ b/t/cmop/AttributesWithHistory_test.t @@ -0,0 +1,118 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; + +use lib 't/cmop/lib'; +use AttributesWithHistory; + +{ + package Foo; + use metaclass; + + Foo->meta->add_attribute(AttributesWithHistory->new('foo' => ( + accessor => 'foo', + history_accessor => 'get_foo_history', + ))); + + Foo->meta->add_attribute(AttributesWithHistory->new('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + history_accessor => 'get_bar_history', + ))); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } +} + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +can_ok($foo, 'foo'); +can_ok($foo, 'get_foo_history'); +can_ok($foo, 'set_bar'); +can_ok($foo, 'get_bar'); +can_ok($foo, 'get_bar_history'); + +my $foo2 = Foo->new(); +isa_ok($foo2, 'Foo'); + +is($foo->foo, undef, '... foo is not yet defined'); +is_deeply( + [ $foo->get_foo_history() ], + [ ], + '... got correct empty history for foo'); + +is($foo2->foo, undef, '... foo2 is not yet defined'); +is_deeply( + [ $foo2->get_foo_history() ], + [ ], + '... got correct empty history for foo2'); + +$foo->foo(42); +is($foo->foo, 42, '... foo == 42'); +is_deeply( + [ $foo->get_foo_history() ], + [ 42 ], + '... got correct history for foo'); + +is($foo2->foo, undef, '... foo2 is still not yet defined'); +is_deeply( + [ $foo2->get_foo_history() ], + [ ], + '... still got correct empty history for foo2'); + +$foo2->foo(100); +is($foo->foo, 42, '... foo is still == 42'); +is_deeply( + [ $foo->get_foo_history() ], + [ 42 ], + '... still got correct history for foo'); + +is($foo2->foo, 100, '... foo2 == 100'); +is_deeply( + [ $foo2->get_foo_history() ], + [ 100 ], + '... got correct empty history for foo2'); + +$foo->foo(43); +$foo->foo(44); +$foo->foo(45); +$foo->foo(46); + +is_deeply( + [ $foo->get_foo_history() ], + [ 42, 43, 44, 45, 46 ], + '... got correct history for foo'); + +is($foo->get_bar, undef, '... bar is not yet defined'); +is_deeply( + [ $foo->get_bar_history() ], + [ ], + '... got correct empty history for foo'); + + +$foo->set_bar("FOO"); +is($foo->get_bar, "FOO", '... bar == "FOO"'); +is_deeply( + [ $foo->get_bar_history() ], + [ "FOO" ], + '... got correct history for foo'); + +$foo->set_bar("BAR"); +$foo->set_bar("BAZ"); + +is_deeply( + [ $foo->get_bar_history() ], + [ qw/FOO BAR BAZ/ ], + '... got correct history for bar'); + +is_deeply( + [ $foo->get_foo_history() ], + [ 42, 43, 44, 45, 46 ], + '... still have the correct history for foo'); + +done_testing; diff --git a/t/cmop/BinaryTree_test.t b/t/cmop/BinaryTree_test.t new file mode 100644 index 0000000..91831dc --- /dev/null +++ b/t/cmop/BinaryTree_test.t @@ -0,0 +1,329 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::Load qw( is_class_loaded load_class ); + +use lib 't/cmop/lib'; + +## ---------------------------------------------------------------------------- +## These are all tests which are derived from the Tree::Binary test suite +## ---------------------------------------------------------------------------- + +ok(!is_class_loaded('BinaryTree'), '... the binary tree class is not loaded'); + +is( exception { + load_class('BinaryTree'); +}, undef, '... loaded the BinaryTree class without dying' ); + +ok(is_class_loaded('BinaryTree'), '... the binary tree class is now loaded'); + +## ---------------------------------------------------------------------------- +## t/10_Tree_Binary_test.t + +can_ok("BinaryTree", 'new'); +can_ok("BinaryTree", 'setLeft'); +can_ok("BinaryTree", 'setRight'); + +my $btree = BinaryTree->new("/") + ->setLeft( + BinaryTree->new("+") + ->setLeft( + BinaryTree->new("2") + ) + ->setRight( + BinaryTree->new("2") + ) + ) + ->setRight( + BinaryTree->new("*") + ->setLeft( + BinaryTree->new("4") + ) + ->setRight( + BinaryTree->new("5") + ) + ); +isa_ok($btree, 'BinaryTree'); + +## informational methods + +can_ok($btree, 'isRoot'); +ok($btree->isRoot(), '... this is the root'); + +can_ok($btree, 'isLeaf'); +ok(!$btree->isLeaf(), '... this is not a leaf node'); +ok($btree->getLeft()->getLeft()->isLeaf(), '... this is a leaf node'); + +can_ok($btree, 'hasLeft'); +ok($btree->hasLeft(), '... this has a left node'); + +can_ok($btree, 'hasRight'); +ok($btree->hasRight(), '... this has a right node'); + +## accessors + +can_ok($btree, 'getUID'); + +{ + my $UID = $btree->getUID(); + is(("$btree" =~ /\((.*?)\)$/)[0], $UID, '... our UID is derived from the stringified object'); +} + +can_ok($btree, 'getNodeValue'); +is($btree->getNodeValue(), '/', '... got what we expected'); + +{ + can_ok($btree, 'getLeft'); + my $left = $btree->getLeft(); + + isa_ok($left, 'BinaryTree'); + + is($left->getNodeValue(), '+', '... got what we expected'); + + can_ok($left, 'getParent'); + + my $parent = $left->getParent(); + isa_ok($parent, 'BinaryTree'); + + is($parent, $btree, '.. got what we expected'); +} + +{ + can_ok($btree, 'getRight'); + my $right = $btree->getRight(); + + isa_ok($right, 'BinaryTree'); + + is($right->getNodeValue(), '*', '... got what we expected'); + + can_ok($right, 'getParent'); + + my $parent = $right->getParent(); + isa_ok($parent, 'BinaryTree'); + + is($parent, $btree, '.. got what we expected'); +} + +## mutators + +can_ok($btree, 'setUID'); +$btree->setUID("Our UID for this tree"); + +is($btree->getUID(), 'Our UID for this tree', '... our UID is not what we expected'); + +can_ok($btree, 'setNodeValue'); +$btree->setNodeValue('*'); + +is($btree->getNodeValue(), '*', '... got what we expected'); + + +{ + can_ok($btree, 'removeLeft'); + my $left = $btree->removeLeft(); + isa_ok($left, 'BinaryTree'); + + ok(!$btree->hasLeft(), '... we dont have a left node anymore'); + ok(!$btree->isLeaf(), '... and we are not a leaf node'); + + $btree->setLeft($left); + + ok($btree->hasLeft(), '... we have our left node again'); + is($btree->getLeft(), $left, '... and it is what we told it to be'); +} + +{ + # remove left leaf + my $left_leaf = $btree->getLeft()->removeLeft(); + isa_ok($left_leaf, 'BinaryTree'); + + ok($left_leaf->isLeaf(), '... our left leaf is a leaf'); + + ok(!$btree->getLeft()->hasLeft(), '... we dont have a left leaf node anymore'); + + $btree->getLeft()->setLeft($left_leaf); + + ok($btree->getLeft()->hasLeft(), '... we have our left leaf node again'); + is($btree->getLeft()->getLeft(), $left_leaf, '... and it is what we told it to be'); +} + +{ + can_ok($btree, 'removeRight'); + my $right = $btree->removeRight(); + isa_ok($right, 'BinaryTree'); + + ok(!$btree->hasRight(), '... we dont have a right node anymore'); + ok(!$btree->isLeaf(), '... and we are not a leaf node'); + + $btree->setRight($right); + + ok($btree->hasRight(), '... we have our right node again'); + is($btree->getRight(), $right, '... and it is what we told it to be') +} + +{ + # remove right leaf + my $right_leaf = $btree->getRight()->removeRight(); + isa_ok($right_leaf, 'BinaryTree'); + + ok($right_leaf->isLeaf(), '... our right leaf is a leaf'); + + ok(!$btree->getRight()->hasRight(), '... we dont have a right leaf node anymore'); + + $btree->getRight()->setRight($right_leaf); + + ok($btree->getRight()->hasRight(), '... we have our right leaf node again'); + is($btree->getRight()->getRight(), $right_leaf, '... and it is what we told it to be'); +} + +# some of the recursive informational methods + +{ + + my $btree = BinaryTree->new("o") + ->setLeft( + BinaryTree->new("o") + ->setLeft( + BinaryTree->new("o") + ) + ->setRight( + BinaryTree->new("o") + ->setLeft( + BinaryTree->new("o") + ->setLeft( + BinaryTree->new("o") + ->setRight(BinaryTree->new("o")) + ) + ) + ) + ) + ->setRight( + BinaryTree->new("o") + ->setLeft( + BinaryTree->new("o") + ->setRight( + BinaryTree->new("o") + ->setLeft( + BinaryTree->new("o") + ) + ->setRight( + BinaryTree->new("o") + ) + ) + ) + ->setRight( + BinaryTree->new("o") + ->setRight(BinaryTree->new("o")) + ) + ); + isa_ok($btree, 'BinaryTree'); + + can_ok($btree, 'size'); + cmp_ok($btree->size(), '==', 14, '... we have 14 nodes in the tree'); + + can_ok($btree, 'height'); + cmp_ok($btree->height(), '==', 6, '... the tree is 6 nodes tall'); + +} + +## ---------------------------------------------------------------------------- +## t/13_Tree_Binary_mirror_test.t + +sub inOrderTraverse { + my $tree = shift; + my @results; + my $_inOrderTraverse = sub { + my ($tree, $traversal_function) = @_; + $traversal_function->($tree->getLeft(), $traversal_function) if $tree->hasLeft(); + push @results => $tree->getNodeValue(); + $traversal_function->($tree->getRight(), $traversal_function) if $tree->hasRight(); + }; + $_inOrderTraverse->($tree, $_inOrderTraverse); + @results; +} + +# test it on a simple well balanaced tree +{ + my $btree = BinaryTree->new(4) + ->setLeft( + BinaryTree->new(2) + ->setLeft( + BinaryTree->new(1) + ) + ->setRight( + BinaryTree->new(3) + ) + ) + ->setRight( + BinaryTree->new(6) + ->setLeft( + BinaryTree->new(5) + ) + ->setRight( + BinaryTree->new(7) + ) + ); + isa_ok($btree, 'BinaryTree'); + + is_deeply( + [ inOrderTraverse($btree) ], + [ 1 .. 7 ], + '... check that our tree starts out correctly'); + + can_ok($btree, 'mirror'); + $btree->mirror(); + + is_deeply( + [ inOrderTraverse($btree) ], + [ reverse(1 .. 7) ], + '... check that our tree ends up correctly'); +} + +# test is on a more chaotic tree +{ + my $btree = BinaryTree->new(4) + ->setLeft( + BinaryTree->new(20) + ->setLeft( + BinaryTree->new(1) + ->setRight( + BinaryTree->new(10) + ->setLeft( + BinaryTree->new(5) + ) + ) + ) + ->setRight( + BinaryTree->new(3) + ) + ) + ->setRight( + BinaryTree->new(6) + ->setLeft( + BinaryTree->new(5) + ->setRight( + BinaryTree->new(7) + ->setLeft( + BinaryTree->new(90) + ) + ->setRight( + BinaryTree->new(91) + ) + ) + ) + ); + isa_ok($btree, 'BinaryTree'); + + my @results = inOrderTraverse($btree); + + $btree->mirror(); + + is_deeply( + [ inOrderTraverse($btree) ], + [ reverse(@results) ], + '... this should be the reverse of the original'); +} + +done_testing; diff --git a/t/cmop/C3MethodDispatchOrder_test.t b/t/cmop/C3MethodDispatchOrder_test.t new file mode 100644 index 0000000..65e0e83 --- /dev/null +++ b/t/cmop/C3MethodDispatchOrder_test.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More; +use Test::Requires 'Algorithm::C3'; # skip all if not installed + +use Class::MOP; + +use lib 't/cmop/lib'; +use C3MethodDispatchOrder; + +{ + package Diamond_A; + use metaclass 'C3MethodDispatchOrder'; + + sub hello { 'Diamond_A::hello' } + + package Diamond_B; + use metaclass 'C3MethodDispatchOrder'; + __PACKAGE__->meta->superclasses('Diamond_A'); + + package Diamond_C; + use metaclass 'C3MethodDispatchOrder'; + __PACKAGE__->meta->superclasses('Diamond_A'); + + sub hello { 'Diamond_C::hello' } + + package Diamond_D; + use metaclass 'C3MethodDispatchOrder'; + __PACKAGE__->meta->superclasses('Diamond_B', 'Diamond_C'); +} + +is_deeply( + [ Diamond_D->meta->class_precedence_list ], + [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ], + '... got the right MRO for Diamond_D'); + +is(Diamond_D->hello, 'Diamond_C::hello', '... got the right dispatch order'); +is(Diamond_D->can('hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected'); + +done_testing; diff --git a/t/cmop/ClassEncapsulatedAttributes_test.t b/t/cmop/ClassEncapsulatedAttributes_test.t new file mode 100644 index 0000000..d5ee50b --- /dev/null +++ b/t/cmop/ClassEncapsulatedAttributes_test.t @@ -0,0 +1,106 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; + +use lib 't/cmop/lib'; +use ClassEncapsulatedAttributes; + +{ + package Foo; + + use metaclass 'ClassEncapsulatedAttributes'; + + Foo->meta->add_attribute('foo' => ( + accessor => 'foo', + predicate => 'has_foo', + default => 'init in FOO' + )); + + Foo->meta->add_attribute('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + default => 'init in FOO' + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + package Bar; + our @ISA = ('Foo'); + + Bar->meta->add_attribute('foo' => ( + accessor => 'foo', + predicate => 'has_foo', + default => 'init in BAR' + )); + + Bar->meta->add_attribute('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + default => 'init in BAR' + )); + + sub SUPER_foo { (shift)->SUPER::foo(@_) } + sub SUPER_has_foo { (shift)->SUPER::foo(@_) } + sub SUPER_get_bar { (shift)->SUPER::get_bar() } + sub SUPER_set_bar { (shift)->SUPER::set_bar(@_) } + +} + +{ + my $foo = Foo->new(); + isa_ok($foo, 'Foo'); + + can_ok($foo, 'foo'); + can_ok($foo, 'has_foo'); + can_ok($foo, 'get_bar'); + can_ok($foo, 'set_bar'); + + my $bar = Bar->new(); + isa_ok($bar, 'Bar'); + + can_ok($bar, 'foo'); + can_ok($bar, 'has_foo'); + can_ok($bar, 'get_bar'); + can_ok($bar, 'set_bar'); + + ok($foo->has_foo, '... Foo::has_foo == 1'); + ok($bar->has_foo, '... Bar::has_foo == 1'); + + is($foo->foo, 'init in FOO', '... got the right default value for Foo::foo'); + is($bar->foo, 'init in BAR', '... got the right default value for Bar::foo'); + + is($bar->SUPER_foo(), 'init in FOO', '... got the right default value for Bar::SUPER::foo'); + + $bar->SUPER_foo(undef); + + is($bar->SUPER_foo(), undef, '... successfully set Foo::foo through Bar::SUPER::foo'); + ok(!$bar->SUPER_has_foo, '... BAR::SUPER::has_foo == 0'); + + ok($foo->has_foo, '... Foo::has_foo (is still) 1'); +} + +{ + my $bar = Bar->new( + 'Foo' => { 'foo' => 'Foo::foo' }, + 'Bar' => { 'foo' => 'Bar::foo' } + ); + isa_ok($bar, 'Bar'); + + can_ok($bar, 'foo'); + can_ok($bar, 'has_foo'); + can_ok($bar, 'get_bar'); + can_ok($bar, 'set_bar'); + + ok($bar->has_foo, '... Bar::has_foo == 1'); + ok($bar->SUPER_has_foo, '... Bar::SUPER_has_foo == 1'); + + is($bar->foo, 'Bar::foo', '... got the right default value for Bar::foo'); + is($bar->SUPER_foo(), 'Foo::foo', '... got the right default value for Bar::SUPER::foo'); +} + +done_testing; diff --git a/t/cmop/Class_C3_compatibility.t b/t/cmop/Class_C3_compatibility.t new file mode 100644 index 0000000..81ebabc --- /dev/null +++ b/t/cmop/Class_C3_compatibility.t @@ -0,0 +1,64 @@ +use strict; +use warnings; + +use Test::More; + +=pod + +This tests that Class::MOP works correctly +with Class::C3 and it's somewhat insane +approach to method resolution. + +=cut + +use Class::MOP; + +{ + package Diamond_A; + use mro 'c3'; + use metaclass; # everyone will just inherit this now :) + + sub hello { 'Diamond_A::hello' } +} +{ + package Diamond_B; + use mro 'c3'; + use parent -norequire => 'Diamond_A'; +} +{ + package Diamond_C; + use mro 'c3'; + use parent -norequire => 'Diamond_A'; + + sub hello { 'Diamond_C::hello' } +} +{ + package Diamond_D; + use mro 'c3'; + use parent -norequire => 'Diamond_B', 'Diamond_C'; +} + +# we have to manually initialize +# Class::C3 since we potentially +# skip this test if it is not present +Class::C3::initialize(); + +is_deeply( +# [ Class::C3::calculateMRO('Diamond_D') ], + [ Diamond_D->meta->class_precedence_list ], + [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ], + '... got the right MRO for Diamond_D'); + +ok(Diamond_A->meta->has_method('hello'), '... A has a method hello'); +ok(!Diamond_B->meta->has_method('hello'), '... B does not have a method hello'); + +ok(Diamond_C->meta->has_method('hello'), '... C has a method hello'); +ok(!Diamond_D->meta->has_method('hello'), '... D does not have a method hello'); + +SKIP: { + skip "C3 does not make aliases on 5.9.5+", 2 if $] > 5.009_004; + ok(defined &Diamond_B::hello, '... B does have an alias to the method hello'); + ok(defined &Diamond_D::hello, '... D does have an alias to the method hello'); +} + +done_testing; diff --git a/t/cmop/InsideOutClass_test.t b/t/cmop/InsideOutClass_test.t new file mode 100644 index 0000000..d54568c --- /dev/null +++ b/t/cmop/InsideOutClass_test.t @@ -0,0 +1,223 @@ +use strict; +use warnings; + +use Test::More; + +use Scalar::Util 'reftype'; + +use lib 't/cmop/lib'; +require InsideOutClass; + +{ + package Foo; + + use strict; + use warnings; + + use metaclass ( + 'attribute_metaclass' => 'InsideOutClass::Attribute', + 'instance_metaclass' => 'InsideOutClass::Instance' + ); + + Foo->meta->add_attribute('foo' => ( + accessor => 'foo', + predicate => 'has_foo', + )); + + Foo->meta->add_attribute('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + default => 'FOO is BAR' + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + package Bar; + use metaclass ( + 'attribute_metaclass' => 'InsideOutClass::Attribute', + 'instance_metaclass' => 'InsideOutClass::Instance' + ); + + use strict; + use warnings; + + use parent -norequire => 'Foo'; + + Bar->meta->add_attribute('baz' => ( + accessor => 'baz', + predicate => 'has_baz', + )); + + package Baz; + + use strict; + use warnings; + use metaclass ( + 'attribute_metaclass' => 'InsideOutClass::Attribute', + 'instance_metaclass' => 'InsideOutClass::Instance' + ); + + Baz->meta->add_attribute('bling' => ( + accessor => 'bling', + default => 'Baz::bling' + )); + + package Bar::Baz; + use metaclass ( + 'attribute_metaclass' => 'InsideOutClass::Attribute', + 'instance_metaclass' => 'InsideOutClass::Instance' + ); + + use strict; + use warnings; + + use parent -norequire => 'Bar', 'Baz'; +} + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +is(reftype($foo), 'SCALAR', '... Foo is made with SCALAR'); + +can_ok($foo, 'foo'); +can_ok($foo, 'has_foo'); +can_ok($foo, 'get_bar'); +can_ok($foo, 'set_bar'); + +ok(!$foo->has_foo, '... Foo::foo is not defined yet'); +is($foo->foo(), undef, '... Foo::foo is not defined yet'); +is($foo->get_bar(), 'FOO is BAR', '... Foo::bar has been initialized'); + +$foo->foo('This is Foo'); + +ok($foo->has_foo, '... Foo::foo is defined now'); +is($foo->foo(), 'This is Foo', '... Foo::foo == "This is Foo"'); + +$foo->set_bar(42); +is($foo->get_bar(), 42, '... Foo::bar == 42'); + +my $foo2 = Foo->new(); +isa_ok($foo2, 'Foo'); + +is(reftype($foo2), 'SCALAR', '... Foo is made with SCALAR'); + +ok(!$foo2->has_foo, '... Foo2::foo is not defined yet'); +is($foo2->foo(), undef, '... Foo2::foo is not defined yet'); +is($foo2->get_bar(), 'FOO is BAR', '... Foo2::bar has been initialized'); + +$foo2->set_bar('DONT PANIC'); +is($foo2->get_bar(), 'DONT PANIC', '... Foo2::bar == DONT PANIC'); + +is($foo->get_bar(), 42, '... Foo::bar == 42'); + +# now Bar ... + +my $bar = Bar->new(); +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +is(reftype($bar), 'SCALAR', '... Bar is made with SCALAR'); + +can_ok($bar, 'foo'); +can_ok($bar, 'has_foo'); +can_ok($bar, 'get_bar'); +can_ok($bar, 'set_bar'); +can_ok($bar, 'baz'); +can_ok($bar, 'has_baz'); + +ok(!$bar->has_foo, '... Bar::foo is not defined yet'); +is($bar->foo(), undef, '... Bar::foo is not defined yet'); +is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); +ok(!$bar->has_baz, '... Bar::baz is not defined yet'); +is($bar->baz(), undef, '... Bar::baz is not defined yet'); + +$bar->foo('This is Bar::foo'); + +ok($bar->has_foo, '... Bar::foo is defined now'); +is($bar->foo(), 'This is Bar::foo', '... Bar::foo == "This is Bar"'); +is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); + +$bar->baz('This is Bar::baz'); + +ok($bar->has_baz, '... Bar::baz is defined now'); +is($bar->baz(), 'This is Bar::baz', '... Bar::foo == "This is Bar"'); +is($bar->foo(), 'This is Bar::foo', '... Bar::foo == "This is Bar"'); +is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); + +# now Baz ... + +my $baz = Bar::Baz->new(); +isa_ok($baz, 'Bar::Baz'); +isa_ok($baz, 'Bar'); +isa_ok($baz, 'Foo'); +isa_ok($baz, 'Baz'); + +is(reftype($baz), 'SCALAR', '... Bar::Baz is made with SCALAR'); + +can_ok($baz, 'foo'); +can_ok($baz, 'has_foo'); +can_ok($baz, 'get_bar'); +can_ok($baz, 'set_bar'); +can_ok($baz, 'baz'); +can_ok($baz, 'has_baz'); +can_ok($baz, 'bling'); + +is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); +is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); + +ok(!$baz->has_foo, '... Bar::Baz::foo is not defined yet'); +is($baz->foo(), undef, '... Bar::Baz::foo is not defined yet'); +ok(!$baz->has_baz, '... Bar::Baz::baz is not defined yet'); +is($baz->baz(), undef, '... Bar::Baz::baz is not defined yet'); + +$baz->foo('This is Bar::Baz::foo'); + +ok($baz->has_foo, '... Bar::Baz::foo is defined now'); +is($baz->foo(), 'This is Bar::Baz::foo', '... Bar::Baz::foo == "This is Bar"'); +is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); +is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); + +$baz->baz('This is Bar::Baz::baz'); + +ok($baz->has_baz, '... Bar::Baz::baz is defined now'); +is($baz->baz(), 'This is Bar::Baz::baz', '... Bar::Baz::foo == "This is Bar"'); +is($baz->foo(), 'This is Bar::Baz::foo', '... Bar::Baz::foo == "This is Bar"'); +is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); +is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); + +{ + no strict 'refs'; + + ok(*{'Foo::foo'}{HASH}, '... there is a foo package variable in Foo'); + ok(*{'Foo::bar'}{HASH}, '... there is a bar package variable in Foo'); + + is(scalar(keys(%{'Foo::foo'})), 4, '... got the right number of entries for Foo::foo'); + is(scalar(keys(%{'Foo::bar'})), 4, '... got the right number of entries for Foo::bar'); + + ok(!*{'Bar::foo'}{HASH}, '... no foo package variable in Bar'); + ok(!*{'Bar::bar'}{HASH}, '... no bar package variable in Bar'); + ok(*{'Bar::baz'}{HASH}, '... there is a baz package variable in Bar'); + + is(scalar(keys(%{'Bar::foo'})), 0, '... got the right number of entries for Bar::foo'); + is(scalar(keys(%{'Bar::bar'})), 0, '... got the right number of entries for Bar::bar'); + is(scalar(keys(%{'Bar::baz'})), 2, '... got the right number of entries for Bar::baz'); + + ok(*{'Baz::bling'}{HASH}, '... there is a bar package variable in Baz'); + + is(scalar(keys(%{'Baz::bling'})), 1, '... got the right number of entries for Baz::bling'); + + ok(!*{'Bar::Baz::foo'}{HASH}, '... no foo package variable in Bar::Baz'); + ok(!*{'Bar::Baz::bar'}{HASH}, '... no bar package variable in Bar::Baz'); + ok(!*{'Bar::Baz::baz'}{HASH}, '... no baz package variable in Bar::Baz'); + ok(!*{'Bar::Baz::bling'}{HASH}, '... no bar package variable in Baz::Baz'); + + is(scalar(keys(%{'Bar::Baz::foo'})), 0, '... got the right number of entries for Bar::Baz::foo'); + is(scalar(keys(%{'Bar::Baz::bar'})), 0, '... got the right number of entries for Bar::Baz::bar'); + is(scalar(keys(%{'Bar::Baz::baz'})), 0, '... got the right number of entries for Bar::Baz::baz'); + is(scalar(keys(%{'Bar::Baz::bling'})), 0, '... got the right number of entries for Bar::Baz::bling'); +} + +done_testing; diff --git a/t/cmop/InstanceCountingClass_test.t b/t/cmop/InstanceCountingClass_test.t new file mode 100644 index 0000000..e7acc22 --- /dev/null +++ b/t/cmop/InstanceCountingClass_test.t @@ -0,0 +1,57 @@ +use strict; +use warnings; + +use Test::More; + +use Class::MOP; + +use lib 't/cmop/lib'; +use InstanceCountingClass; + +=pod + +This is a trivial and contrived example of how to +make a metaclass which will count all the instances +created. It is not meant to be anything more than +a simple demonstration of how to make a metaclass. + +=cut + +{ + package Foo; + + use metaclass 'InstanceCountingClass'; + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + package Bar; + + our @ISA = ('Foo'); +} + +is(Foo->meta->get_count(), 0, '... our Foo count is 0'); +is(Bar->meta->get_count(), 0, '... our Bar count is 0'); + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +is(Foo->meta->get_count(), 1, '... our Foo count is now 1'); +is(Bar->meta->get_count(), 0, '... our Bar count is still 0'); + +my $bar = Bar->new(); +isa_ok($bar, 'Bar'); + +is(Foo->meta->get_count(), 1, '... our Foo count is still 1'); +is(Bar->meta->get_count(), 1, '... our Bar count is now 1'); + +for (2 .. 10) { + Foo->new(); +} + +is(Foo->meta->get_count(), 10, '... our Foo count is now 10'); +is(Bar->meta->get_count(), 1, '... our Bar count is still 1'); + +done_testing; diff --git a/t/cmop/LazyClass_test.t b/t/cmop/LazyClass_test.t new file mode 100644 index 0000000..35db374 --- /dev/null +++ b/t/cmop/LazyClass_test.t @@ -0,0 +1,81 @@ +use strict; +use warnings; + +use Test::More; + +use Class::MOP; + +use lib 't/cmop/lib'; +use LazyClass; + +{ + package BinaryTree; + + use metaclass ( + 'attribute_metaclass' => 'LazyClass::Attribute', + 'instance_metaclass' => 'LazyClass::Instance', + ); + + BinaryTree->meta->add_attribute('node' => ( + accessor => 'node', + init_arg => 'node' + )); + + BinaryTree->meta->add_attribute('left' => ( + reader => 'left', + default => sub { BinaryTree->new() } + )); + + BinaryTree->meta->add_attribute('right' => ( + reader => 'right', + default => sub { BinaryTree->new() } + )); + + sub new { + my $class = shift; + bless $class->meta->new_object(@_) => $class; + } +} + +my $root = BinaryTree->new('node' => 0); +isa_ok($root, 'BinaryTree'); + +ok(exists($root->{'node'}), '... node attribute has been initialized yet'); +ok(!exists($root->{'left'}), '... left attribute has not been initialized yet'); +ok(!exists($root->{'right'}), '... right attribute has not been initialized yet'); + +isa_ok($root->left, 'BinaryTree'); +isa_ok($root->right, 'BinaryTree'); + +ok(exists($root->{'left'}), '... left attribute has now been initialized'); +ok(exists($root->{'right'}), '... right attribute has now been initialized'); + +ok(!exists($root->left->{'node'}), '... node attribute has not been initialized yet'); +ok(!exists($root->left->{'left'}), '... left attribute has not been initialized yet'); +ok(!exists($root->left->{'right'}), '... right attribute has not been initialized yet'); + +ok(!exists($root->right->{'node'}), '... node attribute has not been initialized yet'); +ok(!exists($root->right->{'left'}), '... left attribute has not been initialized yet'); +ok(!exists($root->right->{'right'}), '... right attribute has not been initialized yet'); + +is($root->left->node(), undef, '... the left node is uninitialized'); + +ok(exists($root->left->{'node'}), '... node attribute has now been initialized'); + +$root->left->node(1); +is($root->left->node(), 1, '... the left node == 1'); + +ok(!exists($root->left->{'left'}), '... left attribute still has not been initialized yet'); +ok(!exists($root->left->{'right'}), '... right attribute still has not been initialized yet'); + +is($root->right->node(), undef, '... the right node is uninitialized'); + +ok(exists($root->right->{'node'}), '... node attribute has now been initialized'); + +$root->right->node(2); +is($root->right->node(), 2, '... the right node == 1'); + +ok(!exists($root->right->{'left'}), '... left attribute still has not been initialized yet'); +ok(!exists($root->right->{'right'}), '... right attribute still has not been initialized yet'); + +done_testing; diff --git a/t/cmop/Perl6Attribute_test.t b/t/cmop/Perl6Attribute_test.t new file mode 100644 index 0000000..9b3d73f --- /dev/null +++ b/t/cmop/Perl6Attribute_test.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More; + +use Class::MOP; + +use lib 't/cmop/lib'; +use Perl6Attribute; + +{ + package Foo; + + use metaclass; + + Foo->meta->add_attribute(Perl6Attribute->new('$.foo')); + Foo->meta->add_attribute(Perl6Attribute->new('@.bar')); + Foo->meta->add_attribute(Perl6Attribute->new('%.baz')); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } +} + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +can_ok($foo, 'foo'); +can_ok($foo, 'bar'); +can_ok($foo, 'baz'); + +is($foo->foo, undef, '... Foo.foo == undef'); + +$foo->foo(42); +is($foo->foo, 42, '... Foo.foo == 42'); + +is_deeply($foo->bar, [], '... Foo.bar == []'); +is_deeply($foo->baz, {}, '... Foo.baz == {}'); + +done_testing; diff --git a/t/cmop/RT_27329_fix.t b/t/cmop/RT_27329_fix.t new file mode 100644 index 0000000..0c8ee6a --- /dev/null +++ b/t/cmop/RT_27329_fix.t @@ -0,0 +1,47 @@ +use strict; +use warnings; + +use Test::More; + +use Class::MOP; + +=pod + +This tests a bug sent via RT #27329 + +=cut + +{ + package Foo; + use metaclass; + + Foo->meta->add_attribute('foo' => ( + init_arg => 'foo', + reader => 'get_foo', + default => 'BAR', + )); + +} + +my $foo = Foo->meta->new_object; +isa_ok($foo, 'Foo'); + +is($foo->get_foo, 'BAR', '... got the right default value'); + +{ + my $clone = $foo->meta->clone_object($foo, foo => 'BAZ'); + isa_ok($clone, 'Foo'); + isnt($clone, $foo, '... and it is a clone'); + + is($clone->get_foo, 'BAZ', '... got the right cloned value'); +} + +{ + my $clone = $foo->meta->clone_object($foo, foo => undef); + isa_ok($clone, 'Foo'); + isnt($clone, $foo, '... and it is a clone'); + + ok(!defined($clone->get_foo), '... got the right cloned value'); +} + +done_testing; diff --git a/t/cmop/RT_39001_fix.t b/t/cmop/RT_39001_fix.t new file mode 100644 index 0000000..a3575e8 --- /dev/null +++ b/t/cmop/RT_39001_fix.t @@ -0,0 +1,40 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +use Class::MOP; + +=pod + +This tests a bug sent via RT #39001 + +=cut + +{ + package Foo; + use metaclass; +} + +like( exception { + Foo->meta->superclasses('Foo'); +}, qr/^Recursive inheritance detected/, "error occurs when extending oneself" ); + +{ + package Bar; + use metaclass; +} + +# reset @ISA, so that calling methods like ->isa won't die (->meta does this +# if DEBUG_NO_META is set) +@Foo::ISA = (); + +is( exception { + Foo->meta->superclasses('Bar'); +}, undef, "regular subclass" ); + +like( exception { + Bar->meta->superclasses('Foo'); +}, qr/^Recursive inheritance detected/, "error occurs when Bar extends Foo, when Foo is a Bar" ); + +done_testing; diff --git a/t/cmop/RT_41255.t b/t/cmop/RT_41255.t new file mode 100644 index 0000000..101d358 --- /dev/null +++ b/t/cmop/RT_41255.t @@ -0,0 +1,51 @@ +use strict; +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + package BaseClass; + sub m1 { 1 } + sub m2 { 2 } + sub m3 { 3 } + sub m4 { 4 } + sub m5 { 5 } + + package Derived; + use parent -norequire => 'BaseClass'; + + sub m1; + sub m2 (); + sub m3 :method; + sub m4; m4() if 0; + sub m5; our $m5;; +} + +my $meta = Class::MOP::Class->initialize('Derived'); +my %methods = map { $_ => $meta->find_method_by_name($_) } 'm1' .. 'm5'; + +while (my ($name, $meta_method) = each %methods) { + is $meta_method->fully_qualified_name, "Derived::${name}"; + like( exception { $meta_method->execute }, qr/Undefined subroutine .* called at/ ); +} + +{ + package Derived; + eval <<'EOC'; + + sub m1 { 'affe' } + sub m2 () { 'apan' } + sub m3 :method { 'tiger' } + sub m4 { 'birne' } + sub m5 { 'apfel' } + +EOC +} + +while (my ($name, $meta_method) = each %methods) { + is $meta_method->fully_qualified_name, "Derived::${name}"; + is( exception { $meta_method->execute }, undef ); +} + +done_testing; diff --git a/t/cmop/add_attribute_alternate.t b/t/cmop/add_attribute_alternate.t new file mode 100644 index 0000000..f7ecde1 --- /dev/null +++ b/t/cmop/add_attribute_alternate.t @@ -0,0 +1,109 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + package Point; + use metaclass; + + Point->meta->add_attribute('x' => ( + reader => 'x', + init_arg => 'x' + )); + + Point->meta->add_attribute('y' => ( + accessor => 'y', + init_arg => 'y' + )); + + sub new { + my $class = shift; + bless $class->meta->new_object(@_) => $class; + } + + sub clear { + my $self = shift; + $self->{'x'} = 0; + $self->{'y'} = 0; + } + + package Point3D; + our @ISA = ('Point'); + + Point3D->meta->add_attribute('z' => ( + default => 123 + )); + + sub clear { + my $self = shift; + $self->{'z'} = 0; + $self->SUPER::clear(); + } +} + +isa_ok(Point->meta, 'Class::MOP::Class'); +isa_ok(Point3D->meta, 'Class::MOP::Class'); + +# ... test the classes themselves + +my $point = Point->new('x' => 2, 'y' => 3); +isa_ok($point, 'Point'); + +can_ok($point, 'x'); +can_ok($point, 'y'); +can_ok($point, 'clear'); + +{ + my $meta = $point->meta; + is($meta, Point->meta(), '... got the meta from the instance too'); +} + +is($point->y, 3, '... the y attribute was initialized correctly through the metaobject'); + +$point->y(42); +is($point->y, 42, '... the y attribute was set properly with the accessor'); + +is($point->x, 2, '... the x attribute was initialized correctly through the metaobject'); + +isnt( exception { + $point->x(42); +}, undef, '... cannot write to a read-only accessor' ); +is($point->x, 2, '... the x attribute was not altered'); + +$point->clear(); + +is($point->y, 0, '... the y attribute was cleared correctly'); +is($point->x, 0, '... the x attribute was cleared correctly'); + +my $point3d = Point3D->new('x' => 1, 'y' => 2, 'z' => 3); +isa_ok($point3d, 'Point3D'); +isa_ok($point3d, 'Point'); + +{ + my $meta = $point3d->meta; + is($meta, Point3D->meta(), '... got the meta from the instance too'); +} + +can_ok($point3d, 'x'); +can_ok($point3d, 'y'); +can_ok($point3d, 'clear'); + +is($point3d->x, 1, '... the x attribute was initialized correctly through the metaobject'); +is($point3d->y, 2, '... the y attribute was initialized correctly through the metaobject'); +is($point3d->{'z'}, 3, '... the z attribute was initialized correctly through the metaobject'); + +{ + my $point3d = Point3D->new(); + isa_ok($point3d, 'Point3D'); + + is($point3d->x, undef, '... the x attribute was not initialized'); + is($point3d->y, undef, '... the y attribute was not initialized'); + is($point3d->{'z'}, 123, '... the z attribute was initialized correctly through the metaobject'); + +} + +done_testing; diff --git a/t/cmop/add_method_debugmode.t b/t/cmop/add_method_debugmode.t new file mode 100644 index 0000000..152b990 --- /dev/null +++ b/t/cmop/add_method_debugmode.t @@ -0,0 +1,140 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Class::MOP::Mixin::HasMethods; + +# When the Perl debugger is enabled, %DB::sub tracks method information +# (line numbers and originating file). However, the reinitialize() +# functionality for classes and roles can sometimes clobber this information, +# causing to reference internal MOP files/lines instead. +# These tests check to make sure the the reinitialize() functionality +# preserves the correct debugging information when it (re)adds methods +# back into a class or role. + +BEGIN { + $^P = 831; # Enable debug mode +} + +# Empty debugger +sub DB::DB {} + +my ($foo_role_start, $foo_role_end, $foo_start_1, $foo_end_1, $foo_start_2, $foo_end_2); + +# Simple Moose Role +{ + package FooRole; + use Moose::Role; + + $foo_role_start = __LINE__ + 1; + sub foo_role { + return 'FooRole::foo_role'; + } + $foo_role_end = __LINE__ - 1; +} + +# Simple Moose package +{ + package Foo; + use Moose; + + with 'FooRole'; + + # Track the start/end line numbers of method foo(), for comparison later + $foo_start_1 = __LINE__ + 1; + sub foo { + return 'foo'; + } + $foo_end_1 = __LINE__ - 1; + + no Moose; +} + +# Extend our simple Moose package, with overriding method +{ + package Bar; + use Moose; + + extends 'Foo'; + + # Track the start/end line numbers of method foo(), for comparison later + $foo_start_2 = __LINE__ + 1; + sub foo { + return 'bar'; + } + $foo_end_2 = __LINE__ - 1; + + no Moose; +} + +# Check that Foo and Bar classes were set up correctly +my $bar_object = Bar->new(); +isa_ok(Foo->meta->get_method('foo'), 'Moose::Meta::Method'); +isa_ok(Bar->meta->get_method('foo'), 'Moose::Meta::Method'); +isa_ok(Foo->meta->get_method('foo_role'), 'Moose::Meta::Method'); +is($bar_object->foo_role(), 'FooRole::foo_role', 'Bar object has access to foo_role method'); + +# Run tests against Bar meta class... + +my $bar_meta = Bar->meta; +like($DB::sub{"Bar::foo"}, qr/add_method_debugmode\.t:($foo_start_2)-($foo_end_2)/, "Check line numbers for Bar::foo (initial)"); + +# Run _restore_metamethods_from directly (part of the reinitialize() process) +$bar_meta->_restore_metamethods_from($bar_meta); +like($DB::sub{"Foo::foo"}, qr/add_method_debugmode\.t:($foo_start_1)-($foo_end_1)/, "Check line numbers for Foo::foo (after _restore)"); +like($DB::sub{"Bar::foo"}, qr/add_method_debugmode\.t:($foo_start_2)-($foo_end_2)/, "Check line numbers for Bar::foo (after _restore)"); + +# Call reinitialize explicitly, which triggers HasMethods::add_method +is( exception { + $bar_meta = $bar_meta->reinitialize('Bar'); +}, undef ); +isa_ok(Bar->meta->get_method('foo'), 'Moose::Meta::Method'); +like($DB::sub{"Foo::foo"}, qr/add_method_debugmode\.t:($foo_start_1)-($foo_end_1)/, "Check line numbers for Foo::foo (after reinitialize)"); +like($DB::sub{"Bar::foo"}, qr/add_method_debugmode\.t:($foo_start_2)-($foo_end_2)/, "Check line numbers for Bar::foo (after reinitialize)"); + +# Add a method to Bar; this triggers reinitialize as well +# Check that method line numbers are still listed as part of this file, and not a MOP file +$bar_meta->add_method('foo2' => sub { return 'new method foo2'; }); +like($DB::sub{"Foo::foo"}, qr/add_method_debugmode\.t:($foo_start_1)-($foo_end_1)/, "Check line numbers for Foo::foo (after add_method)"); +like($DB::sub{"Bar::foo"}, qr/add_method_debugmode\.t:($foo_start_2)-($foo_end_2)/, "Check line numbers for Bar::foo (after add_method)"); +like($DB::sub{"Bar::foo2"}, qr/(.*):(\d+)-(\d+)/, "Check for existence of Bar::foo2"); + +# Clobber Bar::foo by adding a method with the same name +$bar_meta->add_method( + 'foo' => $bar_meta->method_metaclass->wrap( + package_name => $bar_meta->name, + name => 'foo', + body => sub { return 'clobbered Bar::foo'; } + ) +); +unlike($DB::sub{"Bar::foo"}, qr/add_method_debugmode\.t/, "Check that source file for Bar::foo has changed"); + +# Run tests against FooRole meta role ... + +my $foorole_meta = FooRole->meta; +like($DB::sub{"FooRole::foo_role"}, qr/add_method_debugmode\.t:($foo_role_start)-($foo_role_end)/, "Check line numbers for FooRole::foo_role (initial)"); + +# Call _restore_metamethods_from directly +$foorole_meta->_restore_metamethods_from($foorole_meta); +like($DB::sub{"FooRole::foo_role"}, qr/add_method_debugmode\.t:($foo_role_start)-($foo_role_end)/, "Check line numbers for FooRole::foo_role (after _restore)"); + +# Call reinitialize +# Check that method line numbers are still listed as part of this file +is( exception { + $foorole_meta->reinitialize('FooRole'); +}, undef ); +isa_ok(FooRole->meta->get_method('foo_role'), 'Moose::Meta::Method'); +like($DB::sub{"FooRole::foo_role"}, qr/add_method_debugmode\.t:($foo_role_start)-($foo_role_end)/, "Check line numbers for FooRole::foo_role (after reinitialize)"); + +# Clobber foo_role method +$foorole_meta->add_method( + 'foo_role' => $foorole_meta->method_metaclass->wrap( + package_name => $foorole_meta->name, + name => 'foo_role', + body => sub { return 'clobbered FooRole::foo_role'; } + ) +); +unlike($DB::sub{"FooRole::foo_role"}, qr/add_method_debugmode\.t/, "Check that source file for FooRole::foo_role has changed"); + +done_testing; diff --git a/t/cmop/add_method_modifier.t b/t/cmop/add_method_modifier.t new file mode 100644 index 0000000..b2f4a6c --- /dev/null +++ b/t/cmop/add_method_modifier.t @@ -0,0 +1,135 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + + package BankAccount; + + use strict; + use warnings; + use metaclass; + + use Carp 'confess'; + + BankAccount->meta->add_attribute( + 'balance' => ( + accessor => 'balance', + init_arg => 'balance', + default => 0 + ) + ); + + sub new { (shift)->meta->new_object(@_) } + + sub deposit { + my ( $self, $amount ) = @_; + $self->balance( $self->balance + $amount ); + } + + sub withdraw { + my ( $self, $amount ) = @_; + my $current_balance = $self->balance(); + ( $current_balance >= $amount ) + || confess "Account overdrawn"; + $self->balance( $current_balance - $amount ); + } + + package CheckingAccount; + + use strict; + use warnings; + use metaclass; + + use parent -norequire => 'BankAccount'; + + CheckingAccount->meta->add_attribute( + 'overdraft_account' => ( + accessor => 'overdraft_account', + init_arg => 'overdraft', + ) + ); + + CheckingAccount->meta->add_before_method_modifier( + 'withdraw' => sub { + my ( $self, $amount ) = @_; + my $overdraft_amount = $amount - $self->balance(); + if ( $overdraft_amount > 0 ) { + $self->overdraft_account->withdraw($overdraft_amount); + $self->deposit($overdraft_amount); + } + } + ); + + ::like( + ::exception{ CheckingAccount->meta->add_before_method_modifier( + 'does_not_exist' => sub { } + ); + }, + qr/\QThe method 'does_not_exist' was not found in the inheritance hierarchy for CheckingAccount/ + ); + + ::ok( CheckingAccount->meta->has_method('withdraw'), + '... checking account now has a withdraw method' ); + ::isa_ok( CheckingAccount->meta->get_method('withdraw'), + 'Class::MOP::Method::Wrapped' ); + ::isa_ok( BankAccount->meta->get_method('withdraw'), + 'Class::MOP::Method' ); + + CheckingAccount->meta->add_method( foo => sub { 'foo' } ); + CheckingAccount->meta->add_before_method_modifier( foo => sub { 'wrapped' } ); + ::isa_ok( CheckingAccount->meta->get_method('foo'), + 'Class::MOP::Method::Wrapped' ); +} + +my $savings_account = BankAccount->new( balance => 250 ); +isa_ok( $savings_account, 'BankAccount' ); + +is( $savings_account->balance, 250, '... got the right savings balance' ); +is( exception { + $savings_account->withdraw(50); +}, undef, '... withdrew from savings successfully' ); +is( $savings_account->balance, 200, + '... got the right savings balance after withdrawal' ); +isnt( exception { + $savings_account->withdraw(250); +}, undef, '... could not withdraw from savings successfully' ); + +$savings_account->deposit(150); +is( $savings_account->balance, 350, + '... got the right savings balance after deposit' ); + +my $checking_account = CheckingAccount->new( + balance => 100, + overdraft => $savings_account +); +isa_ok( $checking_account, 'CheckingAccount' ); +isa_ok( $checking_account, 'BankAccount' ); + +is( $checking_account->overdraft_account, $savings_account, + '... got the right overdraft account' ); + +is( $checking_account->balance, 100, '... got the right checkings balance' ); + +is( exception { + $checking_account->withdraw(50); +}, undef, '... withdrew from checking successfully' ); +is( $checking_account->balance, 50, + '... got the right checkings balance after withdrawal' ); +is( $savings_account->balance, 350, + '... got the right savings balance after checking withdrawal (no overdraft)' +); + +is( exception { + $checking_account->withdraw(200); +}, undef, '... withdrew from checking successfully' ); +is( $checking_account->balance, 0, + '... got the right checkings balance after withdrawal' ); +is( $savings_account->balance, 200, + '... got the right savings balance after overdraft withdrawal' ); + +done_testing; diff --git a/t/cmop/advanced_methods.t b/t/cmop/advanced_methods.t new file mode 100644 index 0000000..6cd0d02 --- /dev/null +++ b/t/cmop/advanced_methods.t @@ -0,0 +1,168 @@ +use strict; +use warnings; + +use Test::More; + +use Class::MOP; +use Class::MOP::Class; + +=pod + +The following class hierarhcy is very contrived +and totally horrid (it won't work under C3 even), +but it tests a number of aspect of this module. + +A more real-world example would be a nice addition :) + +=cut + +{ + package Foo; + + sub BUILD { 'Foo::BUILD' } + sub foo { 'Foo::foo' } + + package Bar; + our @ISA = ('Foo'); + + sub BUILD { 'Bar::BUILD' } + sub bar { 'Bar::bar' } + + package Baz; + our @ISA = ('Bar'); + + sub baz { 'Baz::baz' } + sub foo { 'Baz::foo' } + + package Foo::Bar; + our @ISA = ('Foo', 'Bar'); + + sub BUILD { 'Foo::Bar::BUILD' } + sub foobar { 'Foo::Bar::foobar' } + + package Foo::Bar::Baz; + our @ISA = ('Foo', 'Bar', 'Baz'); + + sub BUILD { 'Foo::Bar::Baz::BUILD' } + sub bar { 'Foo::Bar::Baz::bar' } + sub foobarbaz { 'Foo::Bar::Baz::foobarbaz' } +} + +ok(!defined(Class::MOP::Class->initialize('Foo')->find_next_method_by_name('BUILD')), + '... Foo::BUILD has not next method'); + +is(Class::MOP::Class->initialize('Bar')->find_next_method_by_name('BUILD'), + Class::MOP::Class->initialize('Foo')->get_method('BUILD'), + '... Bar::BUILD does have a next method'); + +is(Class::MOP::Class->initialize('Baz')->find_next_method_by_name('BUILD'), + Class::MOP::Class->initialize('Bar')->get_method('BUILD'), + '... Baz->BUILD does have a next method'); + +is(Class::MOP::Class->initialize('Foo::Bar')->find_next_method_by_name('BUILD'), + Class::MOP::Class->initialize('Foo')->get_method('BUILD'), + '... Foo::Bar->BUILD does have a next method'); + +is(Class::MOP::Class->initialize('Foo::Bar::Baz')->find_next_method_by_name('BUILD'), + Class::MOP::Class->initialize('Foo')->get_method('BUILD'), + '... Foo::Bar::Baz->BUILD does have a next method'); + +is_deeply( + [ + sort { $a->name cmp $b->name } + grep { $_->package_name ne 'UNIVERSAL' } + Class::MOP::Class->initialize('Foo')->get_all_methods() + ], + [ + Class::MOP::Class->initialize('Foo')->get_method('BUILD') , + Class::MOP::Class->initialize('Foo')->get_method('foo'), + ], + '... got the right list of applicable methods for Foo'); + +is_deeply( + [ + sort { $a->name cmp $b->name } + grep { $_->package_name ne 'UNIVERSAL' } + Class::MOP::Class->initialize('Bar')->get_all_methods() + ], + [ + Class::MOP::Class->initialize('Bar')->get_method('BUILD'), + Class::MOP::Class->initialize('Bar')->get_method('bar'), + Class::MOP::Class->initialize('Foo')->get_method('foo'), + ], + '... got the right list of applicable methods for Bar'); + + +is_deeply( + [ + sort { $a->name cmp $b->name } + grep { $_->package_name ne 'UNIVERSAL' } + Class::MOP::Class->initialize('Baz')->get_all_methods() + ], + [ + Class::MOP::Class->initialize('Bar')->get_method('BUILD'), + Class::MOP::Class->initialize('Bar')->get_method('bar'), + Class::MOP::Class->initialize('Baz')->get_method('baz'), + Class::MOP::Class->initialize('Baz')->get_method('foo'), + ], + '... got the right list of applicable methods for Baz'); + +is_deeply( + [ + sort { $a->name cmp $b->name } + grep { $_->package_name ne 'UNIVERSAL' } + Class::MOP::Class->initialize('Foo::Bar')->get_all_methods() + ], + [ + Class::MOP::Class->initialize('Foo::Bar')->get_method('BUILD'), + Class::MOP::Class->initialize('Bar')->get_method('bar'), + Class::MOP::Class->initialize('Foo')->get_method('foo'), + Class::MOP::Class->initialize('Foo::Bar')->get_method('foobar'), + ], + '... got the right list of applicable methods for Foo::Bar'); + +## find_all_methods_by_name + +is_deeply( + [ Class::MOP::Class->initialize('Foo::Bar')->find_all_methods_by_name('BUILD') ], + [ + { + name => 'BUILD', + class => 'Foo::Bar', + code => Class::MOP::Class->initialize('Foo::Bar')->get_method('BUILD') + }, + { + name => 'BUILD', + class => 'Foo', + code => Class::MOP::Class->initialize('Foo')->get_method('BUILD') + }, + { + name => 'BUILD', + class => 'Bar', + code => Class::MOP::Class->initialize('Bar')->get_method('BUILD') + } + ], + '... got the right list of BUILD methods for Foo::Bar'); + +is_deeply( + [ Class::MOP::Class->initialize('Foo::Bar::Baz')->find_all_methods_by_name('BUILD') ], + [ + { + name => 'BUILD', + class => 'Foo::Bar::Baz', + code => Class::MOP::Class->initialize('Foo::Bar::Baz')->get_method('BUILD') + }, + { + name => 'BUILD', + class => 'Foo', + code => Class::MOP::Class->initialize('Foo')->get_method('BUILD') + }, + { + name => 'BUILD', + class => 'Bar', + code => Class::MOP::Class->initialize('Bar')->get_method('BUILD') + }, + ], + '... got the right list of BUILD methods for Foo::Bar::Baz'); + +done_testing; diff --git a/t/cmop/anon_class.t b/t/cmop/anon_class.t new file mode 100644 index 0000000..19681e1 --- /dev/null +++ b/t/cmop/anon_class.t @@ -0,0 +1,70 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + package Foo; + use strict; + use warnings; + use metaclass; + + sub bar { 'Foo::bar' } +} + +my $anon_class_id; +{ + my $instance; + { + my $anon_class = Class::MOP::Class->create_anon_class(); + isa_ok($anon_class, 'Class::MOP::Class'); + + ($anon_class_id) = ($anon_class->name =~ /Class::MOP::Class::__ANON__::SERIAL::(\d+)/); + + ok(exists $main::Class::MOP::Class::__ANON__::SERIAL::{$anon_class_id . '::'}, '... the package exists'); + like($anon_class->name, qr/Class::MOP::Class::__ANON__::SERIAL::[0-9]+/, '... got an anon class package name'); + + is_deeply( + [$anon_class->superclasses], + [], + '... got an empty superclass list'); + is( exception { + $anon_class->superclasses('Foo'); + }, undef, '... can add a superclass to anon class' ); + is_deeply( + [$anon_class->superclasses], + [ 'Foo' ], + '... got the right superclass list'); + + ok(!$anon_class->has_method('foo'), '... no foo method'); + is( exception { + $anon_class->add_method('foo' => sub { "__ANON__::foo" }); + }, undef, '... added a method to my anon-class' ); + ok($anon_class->has_method('foo'), '... we have a foo method now'); + + $instance = $anon_class->new_object(); + isa_ok($instance, $anon_class->name); + isa_ok($instance, 'Foo'); + + is($instance->foo, '__ANON__::foo', '... got the right return value of our foo method'); + is($instance->bar, 'Foo::bar', '... got the right return value of our bar method'); + } + + ok(exists $main::Class::MOP::Class::__ANON__::SERIAL::{$anon_class_id . '::'}, '... the package still exists'); +} + +local $TODO = "anon class doesn't get GCed under Devel::Cover" if $INC{'Devel/Cover.pm'}; + +ok(!exists $main::Class::MOP::Class::__ANON__::SERIAL::{$anon_class_id . '::'}, '... the package no longer exists'); + +# but it breaks down when we try to create another one ... + +my $instance_2 = bless {} => ('Class::MOP::Class::__ANON__::SERIAL::' . $anon_class_id); +isa_ok($instance_2, ('Class::MOP::Class::__ANON__::SERIAL::' . $anon_class_id)); +ok(!$instance_2->isa('Foo'), '... but the new instance is not a Foo'); +ok(!$instance_2->can('foo'), '... and it can no longer call the foo method'); + +done_testing; diff --git a/t/cmop/anon_class_create_init.t b/t/cmop/anon_class_create_init.t new file mode 100644 index 0000000..a35a1eb --- /dev/null +++ b/t/cmop/anon_class_create_init.t @@ -0,0 +1,150 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + package MyMeta; + use parent 'Class::MOP::Class'; + sub initialize { + my $class = shift; + my ( $package, %options ) = @_; + ::cmp_ok( $options{foo}, 'eq', 'this', + 'option passed to initialize() on create_anon_class()' ); + return $class->SUPER::initialize( @_ ); + } + +} + +{ + my $anon = MyMeta->create_anon_class( foo => 'this' ); + isa_ok( $anon, 'MyMeta' ); +} + +my $instance; + +{ + my $meta = Class::MOP::Class->create_anon_class; + $instance = $meta->new_object; +} +{ + my $meta = Class::MOP::class_of($instance); + Scalar::Util::weaken($meta); + ok($meta, "anon class is kept alive by existing instances"); + + undef $instance; + ok(!$meta, "anon class is collected once instances go away"); +} + +{ + my $meta = Class::MOP::Class->create_anon_class; + $meta->make_immutable; + $instance = $meta->name->new; +} +{ + my $meta = Class::MOP::class_of($instance); + Scalar::Util::weaken($meta); + ok($meta, "anon class is kept alive by existing instances (immutable)"); + + undef $instance; + ok(!$meta, "anon class is collected once instances go away (immutable)"); +} + +{ + $instance = Class::MOP::Class->create('Foo')->new_object; + my $meta = Class::MOP::Class->create_anon_class(superclasses => ['Foo']); + $meta->rebless_instance($instance); +} +{ + my $meta = Class::MOP::class_of($instance); + Scalar::Util::weaken($meta); + ok($meta, "anon class is kept alive by existing instances"); + + undef $instance; + ok(!$meta, "anon class is collected once instances go away"); +} + +{ + { + my $meta = Class::MOP::Class->create_anon_class; + { + my $submeta = Class::MOP::Class->create_anon_class( + superclasses => [$meta->name] + ); + $instance = $submeta->new_object; + } + { + my $submeta = Class::MOP::class_of($instance); + Scalar::Util::weaken($submeta); + ok($submeta, "anon class is kept alive by existing instances"); + + $meta->rebless_instance_back($instance); + ok(!$submeta, "reblessing away loses the metaclass"); + } + } + + my $meta = Class::MOP::class_of($instance); + Scalar::Util::weaken($meta); + ok($meta, "anon class is kept alive by existing instances"); +} + +{ + my $submeta = Class::MOP::Class->create_anon_class( + superclasses => [Class::MOP::Class->create_anon_class->name], + ); + my @superclasses = $submeta->superclasses; + ok(Class::MOP::class_of($superclasses[0]), + "superclasses are kept alive by their subclasses"); +} + +{ + my $meta_name; + { + my $meta = Class::MOP::Class->create_anon_class( + superclasses => ['Class::MOP::Class'], + ); + $meta_name = $meta->name; + ok(Class::MOP::metaclass_is_weak($meta_name), + "default is for anon metaclasses to be weakened"); + } + ok(!Class::MOP::class_of($meta_name), + "and weak metaclasses go away when all refs do"); + { + my $meta = Class::MOP::Class->create_anon_class( + superclasses => ['Class::MOP::Class'], + weaken => 0, + ); + $meta_name = $meta->name; + ok(!Class::MOP::metaclass_is_weak($meta_name), + "anon classes can be told not to weaken"); + } + ok(Class::MOP::class_of($meta_name), "metaclass still exists"); + { + my $bar_meta; + is( exception { + $bar_meta = $meta_name->initialize('Bar'); + }, undef, "we can use the name on its own" ); + isa_ok($bar_meta, $meta_name); + } +} + +{ + my $meta = Class::MOP::Class->create( + 'Baz', + weaken => 1, + ); + $instance = $meta->new_object; +} +{ + my $meta = Class::MOP::class_of($instance); + Scalar::Util::weaken($meta); + ok($meta, "weak class is kept alive by existing instances"); + + undef $instance; + ok(!$meta, "weak class is collected once instances go away"); +} + +done_testing; diff --git a/t/cmop/anon_class_keep_alive.t b/t/cmop/anon_class_keep_alive.t new file mode 100644 index 0000000..ace95d8 --- /dev/null +++ b/t/cmop/anon_class_keep_alive.t @@ -0,0 +1,52 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; + +my $anon_class_name; +my $anon_meta_name; +{ + package Foo; + use strict; + use warnings; + use metaclass; + + sub make_anon_instance{ + my $self = shift; + my $class = ref $self || $self; + + my $anon_class = Class::MOP::Class->create_anon_class(superclasses => [$class]); + $anon_class_name = $anon_class->name; + $anon_meta_name = Scalar::Util::blessed($anon_class); + $anon_class->add_attribute( $_, reader => $_ ) for qw/bar baz/; + + my $obj = $anon_class->new_object(bar => 'a', baz => 'b'); + return $obj; + } + + sub foo{ 'foo' } + + 1; +} + +my $instance = Foo->make_anon_instance; + +isa_ok($instance, $anon_class_name); +isa_ok($instance->meta, $anon_meta_name); +isa_ok($instance, 'Foo', '... Anonymous instance isa Foo'); + +ok($instance->can('foo'), '... Anonymous instance can foo'); +ok($instance->meta->find_method_by_name('foo'), '... Anonymous instance has method foo'); + +ok($instance->meta->has_attribute('bar'), '... Anonymous instance still has attribute bar'); +ok($instance->meta->has_attribute('baz'), '... Anonymous instance still has attribute baz'); +is($instance->bar, 'a', '... Anonymous instance still has correct bar value'); +is($instance->baz, 'b', '... Anonymous instance still has correct baz value'); + +is_deeply([$instance->meta->class_precedence_list], + [$anon_class_name, 'Foo'], + '... Anonymous instance has class precedence list', + ); + +done_testing; diff --git a/t/cmop/anon_class_leak.t b/t/cmop/anon_class_leak.t new file mode 100644 index 0000000..0a292fc --- /dev/null +++ b/t/cmop/anon_class_leak.t @@ -0,0 +1,26 @@ +use strict; +use warnings; + +use Test::More; +use Test::Requires 'Test::LeakTrace'; # skip all if not installed + +BEGIN { + plan skip_all => 'Leak tests fail under Devel::Cover' if $INC{'Devel/Cover.pm'}; +} + +use Class::MOP; + +# 5.10.0 has a bug on weaken($hash_ref) which leaks an AV. +my $expected = ( $] == 5.010_000 ? 1 : 0 ); + +leaks_cmp_ok { + Class::MOP::Class->create_anon_class(); +} +'<=', $expected, 'create_anon_class()'; + +leaks_cmp_ok { + Class::MOP::Class->create_anon_class( superclasses => [qw(Exporter)] ); +} +'<=', $expected, 'create_anon_class(superclass => [...])'; + +done_testing; diff --git a/t/cmop/anon_class_removal.t b/t/cmop/anon_class_removal.t new file mode 100644 index 0000000..9d0313a --- /dev/null +++ b/t/cmop/anon_class_removal.t @@ -0,0 +1,40 @@ +use strict; +use warnings; +use Test::More; + +use Class::MOP; + +{ + my $class; + { + my $meta = Class::MOP::Class->create_anon_class( + methods => { + foo => sub { 'FOO' }, + }, + ); + + $class = $meta->name; + can_ok($class, 'foo'); + is($class->foo, 'FOO'); + } + ok(!$class->can('foo')); +} + +{ + my $class; + { + my $meta = Class::MOP::Class->create_anon_class( + methods => { + foo => sub { 'FOO' }, + }, + ); + + $class = $meta->name; + can_ok($class, 'foo'); + is($class->foo, 'FOO'); + Class::MOP::remove_metaclass_by_name($class); + } + ok(!$class->can('foo')); +} + +done_testing; diff --git a/t/cmop/anon_packages.t b/t/cmop/anon_packages.t new file mode 100644 index 0000000..3e5df88 --- /dev/null +++ b/t/cmop/anon_packages.t @@ -0,0 +1,40 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + my $name; + { + my $anon = Class::MOP::Package->create_anon; + $name = $anon->name; + $anon->add_package_symbol('&foo' => sub {}); + can_ok($name, 'foo'); + ok($anon->is_anon, "is anon"); + } + + ok(!$name->can('foo'), "!$name->can('foo')"); +} + +{ + my $name; + { + my $anon = Class::MOP::Package->create_anon(weaken => 0); + $name = $anon->name; + $anon->add_package_symbol('&foo' => sub {}); + can_ok($name, 'foo'); + ok($anon->is_anon, "is anon"); + } + + can_ok($name, 'foo'); +} + +{ + like(exception { Class::MOP::Package->create_anon(cache => 1) }, + qr/^Packages are not cacheable/, + "can't cache anon packages"); +} + +done_testing; diff --git a/t/cmop/attribute.t b/t/cmop/attribute.t new file mode 100644 index 0000000..f23a434 --- /dev/null +++ b/t/cmop/attribute.t @@ -0,0 +1,248 @@ +use strict; +use warnings; + +use Scalar::Util 'reftype', 'blessed'; + +use Test::More; +use Test::Fatal; + +use Class::MOP; +use Class::MOP::Attribute; +use Class::MOP::Method; + + +isnt( exception { Class::MOP::Attribute->name }, undef, q{... can't call name() as a class method} ); + + +{ + my $attr = Class::MOP::Attribute->new('$foo'); + isa_ok($attr, 'Class::MOP::Attribute'); + + is($attr->name, '$foo', '... $attr->name == $foo'); + ok($attr->has_init_arg, '... $attr does have an init_arg'); + is($attr->init_arg, '$foo', '... $attr init_arg is the name'); + + ok(!$attr->has_accessor, '... $attr does not have an accessor'); + ok(!$attr->has_reader, '... $attr does not have an reader'); + ok(!$attr->has_writer, '... $attr does not have an writer'); + ok(!$attr->has_default, '... $attr does not have an default'); + ok(!$attr->has_builder, '... $attr does not have a builder'); + + { + my $reader = $attr->get_read_method_ref; + my $writer = $attr->get_write_method_ref; + + ok(!blessed($reader), '... it is a plain old sub'); + ok(!blessed($writer), '... it is a plain old sub'); + + is(reftype($reader), 'CODE', '... it is a plain old sub'); + is(reftype($writer), 'CODE', '... it is a plain old sub'); + } + + my $class = Class::MOP::Class->initialize('Foo'); + isa_ok($class, 'Class::MOP::Class'); + + is( exception { + $attr->attach_to_class($class); + }, undef, '... attached a class successfully' ); + + is($attr->associated_class, $class, '... the class was associated correctly'); + + ok(!$attr->get_read_method, '... $attr does not have an read method'); + ok(!$attr->get_write_method, '... $attr does not have an write method'); + + { + my $reader = $attr->get_read_method_ref; + my $writer = $attr->get_write_method_ref; + + ok(blessed($reader), '... it is a plain old sub'); + ok(blessed($writer), '... it is a plain old sub'); + + isa_ok($reader, 'Class::MOP::Method'); + isa_ok($writer, 'Class::MOP::Method'); + } + + my $attr_clone = $attr->clone(); + isa_ok($attr_clone, 'Class::MOP::Attribute'); + isnt($attr, $attr_clone, '... but they are different instances'); + + is($attr->associated_class, $attr_clone->associated_class, '... the associated classes are the same though'); + is($attr->associated_class, $class, '... the associated classes are the same though'); + is($attr_clone->associated_class, $class, '... the associated classes are the same though'); + + is_deeply($attr, $attr_clone, '... but they are the same inside'); +} + +{ + my $attr = Class::MOP::Attribute->new('$foo', ( + init_arg => '-foo', + default => 'BAR' + )); + isa_ok($attr, 'Class::MOP::Attribute'); + + is($attr->name, '$foo', '... $attr->name == $foo'); + + ok($attr->has_init_arg, '... $attr does have an init_arg'); + is($attr->init_arg, '-foo', '... $attr->init_arg == -foo'); + ok($attr->has_default, '... $attr does have an default'); + is($attr->default, 'BAR', '... $attr->default == BAR'); + ok(!$attr->has_builder, '... $attr does not have a builder'); + + ok(!$attr->has_accessor, '... $attr does not have an accessor'); + ok(!$attr->has_reader, '... $attr does not have an reader'); + ok(!$attr->has_writer, '... $attr does not have an writer'); + + ok(!$attr->get_read_method, '... $attr does not have an read method'); + ok(!$attr->get_write_method, '... $attr does not have an write method'); + + { + my $reader = $attr->get_read_method_ref; + my $writer = $attr->get_write_method_ref; + + ok(!blessed($reader), '... it is a plain old sub'); + ok(!blessed($writer), '... it is a plain old sub'); + + is(reftype($reader), 'CODE', '... it is a plain old sub'); + is(reftype($writer), 'CODE', '... it is a plain old sub'); + } + + my $attr_clone = $attr->clone(); + isa_ok($attr_clone, 'Class::MOP::Attribute'); + isnt($attr, $attr_clone, '... but they are different instances'); + + is($attr->associated_class, $attr_clone->associated_class, '... the associated classes are the same though'); + is($attr->associated_class, undef, '... the associated class is actually undef'); + is($attr_clone->associated_class, undef, '... the associated class is actually undef'); + + is_deeply($attr, $attr_clone, '... but they are the same inside'); +} + +{ + my $attr = Class::MOP::Attribute->new('$foo', ( + accessor => 'foo', + init_arg => '-foo', + default => 'BAR' + )); + isa_ok($attr, 'Class::MOP::Attribute'); + + is($attr->name, '$foo', '... $attr->name == $foo'); + + ok($attr->has_init_arg, '... $attr does have an init_arg'); + is($attr->init_arg, '-foo', '... $attr->init_arg == -foo'); + ok($attr->has_default, '... $attr does have an default'); + is($attr->default, 'BAR', '... $attr->default == BAR'); + + ok($attr->has_accessor, '... $attr does have an accessor'); + is($attr->accessor, 'foo', '... $attr->accessor == foo'); + + ok(!$attr->has_reader, '... $attr does not have an reader'); + ok(!$attr->has_writer, '... $attr does not have an writer'); + + is($attr->get_read_method, 'foo', '... $attr does not have an read method'); + is($attr->get_write_method, 'foo', '... $attr does not have an write method'); + + { + my $reader = $attr->get_read_method_ref; + my $writer = $attr->get_write_method_ref; + + ok(!blessed($reader), '... it is not a plain old sub'); + ok(!blessed($writer), '... it is not a plain old sub'); + + is(reftype($reader), 'CODE', '... it is a plain old sub'); + is(reftype($writer), 'CODE', '... it is a plain old sub'); + } + + my $attr_clone = $attr->clone(); + isa_ok($attr_clone, 'Class::MOP::Attribute'); + isnt($attr, $attr_clone, '... but they are different instances'); + + is_deeply($attr, $attr_clone, '... but they are the same inside'); +} + +{ + my $attr = Class::MOP::Attribute->new('$foo', ( + reader => 'get_foo', + writer => 'set_foo', + init_arg => '-foo', + default => 'BAR' + )); + isa_ok($attr, 'Class::MOP::Attribute'); + + is($attr->name, '$foo', '... $attr->name == $foo'); + + ok($attr->has_init_arg, '... $attr does have an init_arg'); + is($attr->init_arg, '-foo', '... $attr->init_arg == -foo'); + ok($attr->has_default, '... $attr does have an default'); + is($attr->default, 'BAR', '... $attr->default == BAR'); + + ok($attr->has_reader, '... $attr does have an reader'); + is($attr->reader, 'get_foo', '... $attr->reader == get_foo'); + ok($attr->has_writer, '... $attr does have an writer'); + is($attr->writer, 'set_foo', '... $attr->writer == set_foo'); + + ok(!$attr->has_accessor, '... $attr does not have an accessor'); + + is($attr->get_read_method, 'get_foo', '... $attr does not have an read method'); + is($attr->get_write_method, 'set_foo', '... $attr does not have an write method'); + + { + my $reader = $attr->get_read_method_ref; + my $writer = $attr->get_write_method_ref; + + ok(!blessed($reader), '... it is not a plain old sub'); + ok(!blessed($writer), '... it is not a plain old sub'); + + is(reftype($reader), 'CODE', '... it is a plain old sub'); + is(reftype($writer), 'CODE', '... it is a plain old sub'); + } + + my $attr_clone = $attr->clone(); + isa_ok($attr_clone, 'Class::MOP::Attribute'); + isnt($attr, $attr_clone, '... but they are different instances'); + + is_deeply($attr, $attr_clone, '... but they are the same inside'); +} + +{ + my $attr = Class::MOP::Attribute->new('$foo'); + isa_ok($attr, 'Class::MOP::Attribute'); + + my $attr_clone = $attr->clone('name' => '$bar'); + isa_ok($attr_clone, 'Class::MOP::Attribute'); + isnt($attr, $attr_clone, '... but they are different instances'); + + isnt($attr->name, $attr_clone->name, '... we changes the name parameter'); + + is($attr->name, '$foo', '... $attr->name == $foo'); + is($attr_clone->name, '$bar', '... $attr_clone->name == $bar'); +} + +{ + my $attr = Class::MOP::Attribute->new('$foo', (builder => 'foo_builder')); + isa_ok($attr, 'Class::MOP::Attribute'); + + ok(!$attr->has_default, '... $attr does not have a default'); + ok($attr->has_builder, '... $attr does have a builder'); + is($attr->builder, 'foo_builder', '... $attr->builder == foo_builder'); + +} + +{ + for my $value ({}, bless({}, 'Foo')) { + like( exception { + Class::MOP::Attribute->new('$foo', default => $value); + }, qr/References are not allowed as default values/ ); + } +} + +{ + my $attr; + is( exception { + my $meth = Class::MOP::Method->wrap(sub {shift}, name => 'foo', package_name => 'bar'); + $attr = Class::MOP::Attribute->new('$foo', default => $meth); + }, undef, 'Class::MOP::Methods accepted as default' ); + + is($attr->default(42), 42, 'passthrough for default on attribute'); +} + +done_testing; diff --git a/t/cmop/attribute_duplication.t b/t/cmop/attribute_duplication.t new file mode 100644 index 0000000..4c4073f --- /dev/null +++ b/t/cmop/attribute_duplication.t @@ -0,0 +1,58 @@ +use strict; +use warnings; + +use Scalar::Util; + +use Test::More; + +use Class::MOP; + +=pod + +This tests that when an attribute of the same name +is added to a class, that it will remove the old +one first. + +=cut + +{ + package Foo; + use metaclass; + + Foo->meta->add_attribute('bar' => + reader => 'get_bar', + writer => 'set_bar', + ); + + ::can_ok('Foo', 'get_bar'); + ::can_ok('Foo', 'set_bar'); + ::ok(Foo->meta->has_attribute('bar'), '... Foo has the attribute bar'); + + my $bar_attr = Foo->meta->get_attribute('bar'); + + ::is($bar_attr->reader, 'get_bar', '... the bar attribute has the reader get_bar'); + ::is($bar_attr->writer, 'set_bar', '... the bar attribute has the writer set_bar'); + ::is($bar_attr->associated_class, Foo->meta, '... and the bar attribute is associated with Foo->meta'); + + Foo->meta->add_attribute('bar' => + reader => 'assign_bar' + ); + + ::ok(!Foo->can('get_bar'), '... Foo no longer has the get_bar method'); + ::ok(!Foo->can('set_bar'), '... Foo no longer has the set_bar method'); + ::can_ok('Foo', 'assign_bar'); + ::ok(Foo->meta->has_attribute('bar'), '... Foo still has the attribute bar'); + + my $bar_attr2 = Foo->meta->get_attribute('bar'); + + ::isnt($bar_attr, $bar_attr2, '... this is a new bar attribute'); + ::isnt($bar_attr->associated_class, Foo->meta, '... and the old bar attribute is no longer associated with Foo->meta'); + + ::is($bar_attr2->associated_class, Foo->meta, '... and the new bar attribute *is* associated with Foo->meta'); + + ::isnt($bar_attr2->reader, 'get_bar', '... the bar attribute no longer has the reader get_bar'); + ::isnt($bar_attr2->reader, 'set_bar', '... the bar attribute no longer has the reader set_bar'); + ::is($bar_attr2->reader, 'assign_bar', '... the bar attribute now has the reader assign_bar'); +} + +done_testing; diff --git a/t/cmop/attribute_errors_and_edge_cases.t b/t/cmop/attribute_errors_and_edge_cases.t new file mode 100644 index 0000000..e4a87d6 --- /dev/null +++ b/t/cmop/attribute_errors_and_edge_cases.t @@ -0,0 +1,232 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; +use Class::MOP::Attribute; + +# most values are static + +{ + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + default => qr/hello (.*)/ + )); + }, undef, '... no refs for defaults' ); + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + default => [] + )); + }, undef, '... no refs for defaults' ); + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + default => {} + )); + }, undef, '... no refs for defaults' ); + + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + default => \(my $var) + )); + }, undef, '... no refs for defaults' ); + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + default => bless {} => 'Foo' + )); + }, undef, '... no refs for defaults' ); + +} + +{ + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + builder => qr/hello (.*)/ + )); + }, undef, '... no refs for builders' ); + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + builder => [] + )); + }, undef, '... no refs for builders' ); + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + builder => {} + )); + }, undef, '... no refs for builders' ); + + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + builder => \(my $var) + )); + }, undef, '... no refs for builders' ); + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + builder => bless {} => 'Foo' + )); + }, undef, '... no refs for builders' ); + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + builder => 'Foo', default => 'Foo' + )); + }, undef, '... no default AND builder' ); + + my $undef_attr; + is( exception { + $undef_attr = Class::MOP::Attribute->new('$test' => ( + default => undef, + predicate => 'has_test', + )); + }, undef, '... undef as a default is okay' ); + ok($undef_attr->has_default, '... and it counts as an actual default'); + ok(!Class::MOP::Attribute->new('$test')->has_default, + '... but attributes with no default have no default'); + + Class::MOP::Class->create( + 'Foo', + attributes => [$undef_attr], + ); + { + my $obj = Foo->meta->new_object; + ok($obj->has_test, '... and the default is populated'); + is($obj->meta->get_attribute('$test')->get_value($obj), undef, '... with the right value'); + } + is( exception { Foo->meta->make_immutable }, undef, '... and it can be inlined' ); + { + my $obj = Foo->new; + ok($obj->has_test, '... and the default is populated'); + is($obj->meta->get_attribute('$test')->get_value($obj), undef, '... with the right value'); + } + +} + + +{ # bad construtor args + isnt( exception { + Class::MOP::Attribute->new(); + }, undef, '... no name argument' ); + + # These are no longer errors + is( exception { + Class::MOP::Attribute->new(''); + }, undef, '... bad name argument' ); + + is( exception { + Class::MOP::Attribute->new(0); + }, undef, '... bad name argument' ); +} + +{ + my $attr = Class::MOP::Attribute->new('$test'); + isnt( exception { + $attr->attach_to_class(); + }, undef, '... attach_to_class died as expected' ); + + isnt( exception { + $attr->attach_to_class('Fail'); + }, undef, '... attach_to_class died as expected' ); + + isnt( exception { + $attr->attach_to_class(bless {} => 'Fail'); + }, undef, '... attach_to_class died as expected' ); +} + +{ + my $attr = Class::MOP::Attribute->new('$test' => ( + reader => [ 'whoops, this wont work' ] + )); + + $attr->attach_to_class(Class::MOP::Class->initialize('Foo')); + + isnt( exception { + $attr->install_accessors; + }, undef, '... bad reader format' ); +} + +{ + my $attr = Class::MOP::Attribute->new('$test'); + + isnt( exception { + $attr->_process_accessors('fail', 'my_failing_sub'); + }, undef, '... cannot find "fail" type generator' ); +} + + +{ + { + package My::Attribute; + our @ISA = ('Class::MOP::Attribute'); + sub generate_reader_method { eval { die } } + } + + my $attr = My::Attribute->new('$test' => ( + reader => 'test' + )); + + isnt( exception { + $attr->install_accessors; + }, undef, '... failed to generate accessors correctly' ); +} + +{ + my $attr = Class::MOP::Attribute->new('$test' => ( + predicate => 'has_test' + )); + + my $Bar = Class::MOP::Class->create('Bar'); + isa_ok($Bar, 'Class::MOP::Class'); + + $Bar->add_attribute($attr); + + can_ok('Bar', 'has_test'); + + is($attr, $Bar->remove_attribute('$test'), '... removed the $test attribute'); + + ok(!Bar->can('has_test'), '... Bar no longer has the "has_test" method'); +} + + +{ + # NOTE: + # the next three tests once tested that + # the code would fail, but we lifted the + # restriction so you can have an accessor + # along with a reader/writer pair (I mean + # why not really). So now they test that + # it works, which is kinda silly, but it + # tests the API change, so I keep it. + + is( exception { + Class::MOP::Attribute->new('$foo', ( + accessor => 'foo', + reader => 'get_foo', + )); + }, undef, '... can create accessors with reader/writers' ); + + is( exception { + Class::MOP::Attribute->new('$foo', ( + accessor => 'foo', + writer => 'set_foo', + )); + }, undef, '... can create accessors with reader/writers' ); + + is( exception { + Class::MOP::Attribute->new('$foo', ( + accessor => 'foo', + reader => 'get_foo', + writer => 'set_foo', + )); + }, undef, '... can create accessors with reader/writers' ); +} + +done_testing; diff --git a/t/cmop/attribute_get_read_write.t b/t/cmop/attribute_get_read_write.t new file mode 100644 index 0000000..9f621a6 --- /dev/null +++ b/t/cmop/attribute_get_read_write.t @@ -0,0 +1,114 @@ +use strict; +use warnings; + +use Scalar::Util 'blessed', 'reftype'; + +use Test::More; + +use Class::MOP; + +=pod + +This checks the get_read/write_method +and get_read/write_method_ref methods + +=cut + +{ + package Foo; + use metaclass; + + Foo->meta->add_attribute('bar' => + reader => 'get_bar', + writer => 'set_bar', + ); + + Foo->meta->add_attribute('baz' => + accessor => 'baz', + ); + + Foo->meta->add_attribute('gorch' => + reader => { 'get_gorch', => sub { (shift)->{gorch} } } + ); + + package Bar; + use metaclass; + Bar->meta->superclasses('Foo'); + + Bar->meta->add_attribute('quux' => + accessor => 'quux', + ); +} + +can_ok('Foo', 'get_bar'); +can_ok('Foo', 'set_bar'); +can_ok('Foo', 'baz'); +can_ok('Foo', 'get_gorch'); + +ok(Foo->meta->has_attribute('bar'), '... Foo has the attribute bar'); +ok(Foo->meta->has_attribute('baz'), '... Foo has the attribute baz'); +ok(Foo->meta->has_attribute('gorch'), '... Foo has the attribute gorch'); + +my $bar_attr = Foo->meta->get_attribute('bar'); +my $baz_attr = Foo->meta->get_attribute('baz'); +my $gorch_attr = Foo->meta->get_attribute('gorch'); + +is($bar_attr->reader, 'get_bar', '... the bar attribute has the reader get_bar'); +is($bar_attr->writer, 'set_bar', '... the bar attribute has the writer set_bar'); +is($bar_attr->associated_class, Foo->meta, '... and the bar attribute is associated with Foo->meta'); + +is($bar_attr->get_read_method, 'get_bar', '... $attr does have an read method'); +is($bar_attr->get_write_method, 'set_bar', '... $attr does have an write method'); + +{ + my $reader = $bar_attr->get_read_method_ref; + my $writer = $bar_attr->get_write_method_ref; + + isa_ok($reader, 'Class::MOP::Method'); + isa_ok($writer, 'Class::MOP::Method'); + + is($reader->fully_qualified_name, 'Foo::get_bar', '... it is the sub we are looking for'); + is($writer->fully_qualified_name, 'Foo::set_bar', '... it is the sub we are looking for'); + + is(reftype($reader->body), 'CODE', '... it is a plain old sub'); + is(reftype($writer->body), 'CODE', '... it is a plain old sub'); +} + +is($baz_attr->accessor, 'baz', '... the bar attribute has the accessor baz'); +is($baz_attr->associated_class, Foo->meta, '... and the bar attribute is associated with Foo->meta'); + +is($baz_attr->get_read_method, 'baz', '... $attr does have an read method'); +is($baz_attr->get_write_method, 'baz', '... $attr does have an write method'); + +{ + my $reader = $baz_attr->get_read_method_ref; + my $writer = $baz_attr->get_write_method_ref; + + isa_ok($reader, 'Class::MOP::Method'); + isa_ok($writer, 'Class::MOP::Method'); + + is($reader, $writer, '... they are the same method'); + + is($reader->fully_qualified_name, 'Foo::baz', '... it is the sub we are looking for'); + is($writer->fully_qualified_name, 'Foo::baz', '... it is the sub we are looking for'); +} + +is(ref($gorch_attr->reader), 'HASH', '... the gorch attribute has the reader get_gorch (HASH ref)'); +is($gorch_attr->associated_class, Foo->meta, '... and the gorch attribute is associated with Foo->meta'); + +is($gorch_attr->get_read_method, 'get_gorch', '... $attr does have an read method'); +ok(!$gorch_attr->get_write_method, '... $attr does not have an write method'); + +{ + my $reader = $gorch_attr->get_read_method_ref; + my $writer = $gorch_attr->get_write_method_ref; + + isa_ok($reader, 'Class::MOP::Method'); + ok(blessed($writer), '... it is not a plain old sub'); + isa_ok($writer, 'Class::MOP::Method'); + + is($reader->fully_qualified_name, 'Foo::get_gorch', '... it is the sub we are looking for'); + is($writer->fully_qualified_name, 'Foo::__ANON__', '... it is the sub we are looking for'); +} + +done_testing; diff --git a/t/cmop/attribute_initializer.t b/t/cmop/attribute_initializer.t new file mode 100644 index 0000000..7d8ca32 --- /dev/null +++ b/t/cmop/attribute_initializer.t @@ -0,0 +1,50 @@ +use strict; +use warnings; + +use Scalar::Util 'reftype'; +use Test::More; +use Class::MOP; + +=pod + +This checks that the initializer is used to set the initial value. + +=cut + +{ + package Foo; + use metaclass; + + Foo->meta->add_attribute('bar' => + reader => 'get_bar', + writer => 'set_bar', + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Class::MOP::Attribute'); + ::is($attr->name, 'bar', '... the attribute is our own'); + + $callback->($value * 2); + }, + ); +} + +can_ok('Foo', 'get_bar'); +can_ok('Foo', 'set_bar'); + +my $foo = Foo->meta->new_object(bar => 10); +is($foo->get_bar, 20, "... initial argument was doubled as expected"); + +$foo->set_bar(30); + +is($foo->get_bar, 30, "... and setter works correctly"); + +# meta tests ... + +my $bar = Foo->meta->get_attribute('bar'); +isa_ok($bar, 'Class::MOP::Attribute'); + +ok($bar->has_initializer, '... bar has an initializer'); +is(reftype $bar->initializer, 'CODE', '... the initializer is a CODE ref'); + +done_testing; diff --git a/t/cmop/attribute_introspection.t b/t/cmop/attribute_introspection.t new file mode 100644 index 0000000..dc99492 --- /dev/null +++ b/t/cmop/attribute_introspection.t @@ -0,0 +1,131 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; + +{ + my $attr = Class::MOP::Attribute->new('$test'); + is( $attr->meta, Class::MOP::Attribute->meta, + '... instance and class both lead to the same meta' ); +} + +{ + my $meta = Class::MOP::Attribute->meta(); + isa_ok( $meta, 'Class::MOP::Class' ); + + my @methods = qw( + new + clone + + initialize_instance_slot + _set_initial_slot_value + _make_initializer_writer_callback + + name + has_accessor accessor + has_writer writer + has_write_method get_write_method get_write_method_ref + has_reader reader + has_read_method get_read_method get_read_method_ref + has_predicate predicate + has_clearer clearer + has_builder builder + has_init_arg init_arg + has_default default is_default_a_coderef + has_initializer initializer + has_insertion_order insertion_order _set_insertion_order + + definition_context + + slots + get_value + set_value + get_raw_value + set_raw_value + set_initial_value + has_value + clear_value + + associated_class + attach_to_class + detach_from_class + + accessor_metaclass + + associated_methods + associate_method + + _process_accessors + _accessor_description + install_accessors + remove_accessors + + _inline_get_value + _inline_set_value + _inline_has_value + _inline_clear_value + _inline_instance_get + _inline_instance_set + _inline_instance_has + _inline_instance_clear + + _new + ); + + is_deeply( + [ + sort Class::MOP::Mixin::AttributeCore->meta->get_method_list, + $meta->get_method_list + ], + [ sort @methods ], + '... our method list matches' + ); + + foreach my $method_name (@methods) { + ok( $meta->find_method_by_name($method_name), + '... Class::MOP::Attribute->find_method_by_name(' . $method_name . ')' ); + } + + my @attributes = ( + 'name', + 'accessor', + 'reader', + 'writer', + 'predicate', + 'clearer', + 'builder', + 'init_arg', + 'initializer', + 'definition_context', + 'default', + 'associated_class', + 'associated_methods', + 'insertion_order', + ); + + is_deeply( + [ + sort Class::MOP::Mixin::AttributeCore->meta->get_attribute_list, + $meta->get_attribute_list + ], + [ sort @attributes ], + '... our attribute list matches' + ); + + foreach my $attribute_name (@attributes) { + ok( $meta->find_attribute_by_name($attribute_name), + '... Class::MOP::Attribute->find_attribute_by_name(' + . $attribute_name + . ')' ); + } + + # We could add some tests here to make sure that + # the attribute have the appropriate + # accessor/reader/writer/predicate combinations, + # but that is getting a little excessive so I + # wont worry about it for now. Maybe if I get + # bored I will do it. +} + +done_testing; diff --git a/t/cmop/attribute_non_alpha_name.t b/t/cmop/attribute_non_alpha_name.t new file mode 100644 index 0000000..98e411e --- /dev/null +++ b/t/cmop/attribute_non_alpha_name.t @@ -0,0 +1,34 @@ +use strict; +use warnings; + +use Class::MOP; + +use Test::More; + +{ + package Foo; + use metaclass; + + Foo->meta->add_attribute( '@foo', accessor => 'foo' ); + Foo->meta->add_attribute( '!bar', reader => 'bar' ); + Foo->meta->add_attribute( '%baz', reader => 'baz' ); +} + +{ + my $meta = Foo->meta; + + for my $name ( '@foo', '!bar', '%baz' ) { + ok( + $meta->has_attribute($name), + "Foo has $name attribute" + ); + + my $meth = substr $name, 1; + ok( $meta->has_method($meth), 'Foo has $meth method' ); + } + + $meta->make_immutable, redo + unless $meta->is_immutable; +} + +done_testing; diff --git a/t/cmop/attributes.t b/t/cmop/attributes.t new file mode 100644 index 0000000..a6df570 --- /dev/null +++ b/t/cmop/attributes.t @@ -0,0 +1,262 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +my $FOO_ATTR = Class::MOP::Attribute->new('$foo'); +my $BAR_ATTR = Class::MOP::Attribute->new('$bar' => ( + accessor => 'bar' +)); +my $BAZ_ATTR = Class::MOP::Attribute->new('$baz' => ( + reader => 'get_baz', + writer => 'set_baz', +)); + +my $BAR_ATTR_2 = Class::MOP::Attribute->new('$bar'); + +my $FOO_ATTR_2 = Class::MOP::Attribute->new('$foo' => ( + accessor => 'foo', + builder => 'build_foo' +)); + +is($FOO_ATTR->name, '$foo', '... got the attributes name correctly'); +is($BAR_ATTR->name, '$bar', '... got the attributes name correctly'); +is($BAZ_ATTR->name, '$baz', '... got the attributes name correctly'); + +{ + package Foo; + use metaclass; + + my $meta = Foo->meta; + ::is( ::exception { + $meta->add_attribute($FOO_ATTR); + }, undef, '... we added an attribute to Foo successfully' ); + ::ok($meta->has_attribute('$foo'), '... Foo has $foo attribute'); + ::is($meta->get_attribute('$foo'), $FOO_ATTR, '... got the right attribute back for Foo'); + + ::ok(!$meta->has_method('foo'), '... no accessor created'); + + ::is( ::exception { + $meta->add_attribute($BAR_ATTR_2); + }, undef, '... we added an attribute to Foo successfully' ); + ::ok($meta->has_attribute('$bar'), '... Foo has $bar attribute'); + ::is($meta->get_attribute('$bar'), $BAR_ATTR_2, '... got the right attribute back for Foo'); + + ::ok(!$meta->has_method('bar'), '... no accessor created'); +} +{ + package Bar; + our @ISA = ('Foo'); + + my $meta = Bar->meta; + ::is( ::exception { + $meta->add_attribute($BAR_ATTR); + }, undef, '... we added an attribute to Bar successfully' ); + ::ok($meta->has_attribute('$bar'), '... Bar has $bar attribute'); + ::is($meta->get_attribute('$bar'), $BAR_ATTR, '... got the right attribute back for Bar'); + + my $attr = $meta->get_attribute('$bar'); + ::is($attr->get_read_method, 'bar', '... got the right read method for Bar'); + ::is($attr->get_write_method, 'bar', '... got the right write method for Bar'); + + ::ok($meta->has_method('bar'), '... an accessor has been created'); + ::isa_ok($meta->get_method('bar'), 'Class::MOP::Method::Accessor'); +} +{ + package Baz; + our @ISA = ('Bar'); + + my $meta = Baz->meta; + ::is( ::exception { + $meta->add_attribute($BAZ_ATTR); + }, undef, '... we added an attribute to Baz successfully' ); + ::ok($meta->has_attribute('$baz'), '... Baz has $baz attribute'); + ::is($meta->get_attribute('$baz'), $BAZ_ATTR, '... got the right attribute back for Baz'); + + my $attr = $meta->get_attribute('$baz'); + ::is($attr->get_read_method, 'get_baz', '... got the right read method for Baz'); + ::is($attr->get_write_method, 'set_baz', '... got the right write method for Baz'); + + ::ok($meta->has_method('get_baz'), '... a reader has been created'); + ::ok($meta->has_method('set_baz'), '... a writer has been created'); + + ::isa_ok($meta->get_method('get_baz'), 'Class::MOP::Method::Accessor'); + ::isa_ok($meta->get_method('set_baz'), 'Class::MOP::Method::Accessor'); +} + +{ + package Foo2; + use metaclass; + + my $meta = Foo2->meta; + $meta->add_attribute( + Class::MOP::Attribute->new( '$foo2' => ( reader => 'foo2' ) ) ); + + ::ok( $meta->has_method('foo2'), '... a reader has been created' ); + + my $attr = $meta->get_attribute('$foo2'); + ::is( $attr->get_read_method, 'foo2', + '... got the right read method for Foo2' ); + ::is( $attr->get_write_method, undef, + '... got undef for the writer with a read-only attribute in Foo2' ); +} + +{ + my $meta = Baz->meta; + isa_ok($meta, 'Class::MOP::Class'); + + is($meta->find_attribute_by_name('$bar'), $BAR_ATTR, '... got the right attribute for "bar"'); + is($meta->find_attribute_by_name('$baz'), $BAZ_ATTR, '... got the right attribute for "baz"'); + is($meta->find_attribute_by_name('$foo'), $FOO_ATTR, '... got the right attribute for "foo"'); + + is_deeply( + [ sort { $a->name cmp $b->name } $meta->get_all_attributes() ], + [ + $BAR_ATTR, + $BAZ_ATTR, + $FOO_ATTR, + ], + '... got the right list of applicable attributes for Baz'); + + is_deeply( + [ map { $_->associated_class } sort { $a->name cmp $b->name } $meta->get_all_attributes() ], + [ Bar->meta, Baz->meta, Foo->meta ], + '... got the right list of associated classes from the applicable attributes for Baz'); + + my $attr; + is( exception { + $attr = $meta->remove_attribute('$baz'); + }, undef, '... removed the $baz attribute successfully' ); + is($attr, $BAZ_ATTR, '... got the right attribute back for Baz'); + + ok(!$meta->has_attribute('$baz'), '... Baz no longer has $baz attribute'); + is($meta->get_attribute('$baz'), undef, '... Baz no longer has $baz attribute'); + + ok(!$meta->has_method('get_baz'), '... a reader has been removed'); + ok(!$meta->has_method('set_baz'), '... a writer has been removed'); + + is_deeply( + [ sort { $a->name cmp $b->name } $meta->get_all_attributes() ], + [ + $BAR_ATTR, + $FOO_ATTR, + ], + '... got the right list of applicable attributes for Baz'); + + is_deeply( + [ map { $_->associated_class } sort { $a->name cmp $b->name } $meta->get_all_attributes() ], + [ Bar->meta, Foo->meta ], + '... got the right list of associated classes from the applicable attributes for Baz'); + + { + my $attr; + is( exception { + $attr = Bar->meta->remove_attribute('$bar'); + }, undef, '... removed the $bar attribute successfully' ); + is($attr, $BAR_ATTR, '... got the right attribute back for Bar'); + + ok(!Bar->meta->has_attribute('$bar'), '... Bar no longer has $bar attribute'); + + ok(!Bar->meta->has_method('bar'), '... a accessor has been removed'); + } + + is_deeply( + [ sort { $a->name cmp $b->name } $meta->get_all_attributes() ], + [ + $BAR_ATTR_2, + $FOO_ATTR, + ], + '... got the right list of applicable attributes for Baz'); + + is_deeply( + [ map { $_->associated_class } sort { $a->name cmp $b->name } $meta->get_all_attributes() ], + [ Foo->meta, Foo->meta ], + '... got the right list of associated classes from the applicable attributes for Baz'); + + # remove attribute which is not there + my $val; + is( exception { + $val = $meta->remove_attribute('$blammo'); + }, undef, '... attempted to remove the non-existent $blammo attribute' ); + is($val, undef, '... got the right value back (undef)'); + +} + +{ + package Buzz; + use metaclass; + use Scalar::Util qw/blessed/; + + my $meta = Buzz->meta; + ::is( ::exception { + $meta->add_attribute($FOO_ATTR_2); + }, undef, '... we added an attribute to Buzz successfully' ); + + ::is( ::exception { + $meta->add_attribute( + Class::MOP::Attribute->new( + '$bar' => ( + accessor => 'bar', + predicate => 'has_bar', + clearer => 'clear_bar', + ) + ) + ); + }, undef, '... we added an attribute to Buzz successfully' ); + + ::is( ::exception { + $meta->add_attribute( + Class::MOP::Attribute->new( + '$bah' => ( + accessor => 'bah', + predicate => 'has_bah', + clearer => 'clear_bah', + default => 'BAH', + ) + ) + ); + }, undef, '... we added an attribute to Buzz successfully' ); + + ::is( ::exception { + $meta->add_method(build_foo => sub{ blessed shift; }); + }, undef, '... we added a method to Buzz successfully' ); +} + + + +for(1 .. 2){ + my $buzz; + ::is( ::exception { $buzz = Buzz->meta->new_object }, undef, '...Buzz instantiated successfully' ); + ::is($buzz->foo, 'Buzz', '...foo builder works as expected'); + ::ok(!$buzz->has_bar, '...bar is not set'); + ::is($buzz->bar, undef, '...bar returns undef'); + ::ok(!$buzz->has_bar, '...bar was not autovivified'); + + $buzz->bar(undef); + ::ok($buzz->has_bar, '...bar is set'); + ::is($buzz->bar, undef, '...bar is undef'); + $buzz->clear_bar; + ::ok(!$buzz->has_bar, '...bar is no longerset'); + + my $buzz2; + ::is( ::exception { $buzz2 = Buzz->meta->new_object('$bar' => undef) }, undef, '...Buzz instantiated successfully' ); + ::ok($buzz2->has_bar, '...bar is set'); + ::is($buzz2->bar, undef, '...bar is undef'); + + my $buzz3; + ::is( ::exception { $buzz3 = Buzz->meta->new_object }, undef, '...Buzz instantiated successfully' ); + ::ok($buzz3->has_bah, '...bah is set'); + ::is($buzz3->bah, 'BAH', '...bah returns "BAH" '); + + my $buzz4; + ::is( ::exception { $buzz4 = Buzz->meta->new_object('$bah' => undef) }, undef, '...Buzz instantiated successfully' ); + ::ok($buzz4->has_bah, '...bah is set'); + ::is($buzz4->bah, undef, '...bah is undef'); + + Buzz->meta->make_immutable(); +} + +done_testing; diff --git a/t/cmop/basic.t b/t/cmop/basic.t new file mode 100644 index 0000000..984b251 --- /dev/null +++ b/t/cmop/basic.t @@ -0,0 +1,78 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; +use Class::MOP::Class; + +{ + package Foo; + use metaclass; + our $VERSION = '0.01'; + + package Bar; + our @ISA = ('Foo'); + + our $AUTHORITY = 'cpan:JRANDOM'; +} + +my $Foo = Foo->meta; +isa_ok($Foo, 'Class::MOP::Class'); + +my $Bar = Bar->meta; +isa_ok($Bar, 'Class::MOP::Class'); + +is($Foo->name, 'Foo', '... Foo->name == Foo'); +is($Bar->name, 'Bar', '... Bar->name == Bar'); + +is($Foo->version, '0.01', '... Foo->version == 0.01'); +is($Bar->version, undef, '... Bar->version == undef'); + +is($Foo->authority, undef, '... Foo->authority == undef'); +is($Bar->authority, 'cpan:JRANDOM', '... Bar->authority == cpan:JRANDOM'); + +is($Foo->identifier, 'Foo-0.01', '... Foo->identifier == Foo-0.01'); +is($Bar->identifier, 'Bar-cpan:JRANDOM', '... Bar->identifier == Bar-cpan:JRANDOM'); + +is_deeply([$Foo->superclasses], [], '... Foo has no superclasses'); +is_deeply([$Bar->superclasses], ['Foo'], '... Bar->superclasses == (Foo)'); + +$Foo->superclasses('UNIVERSAL'); + +is_deeply([$Foo->superclasses], ['UNIVERSAL'], '... Foo->superclasses == (UNIVERSAL) now'); + +is_deeply( + [ $Foo->class_precedence_list ], + [ 'Foo', 'UNIVERSAL' ], + '... Foo->class_precedence_list == (Foo, UNIVERSAL)'); + +is_deeply( + [ $Bar->class_precedence_list ], + [ 'Bar', 'Foo', 'UNIVERSAL' ], + '... Bar->class_precedence_list == (Bar, Foo, UNIVERSAL)'); + +# create a class using Class::MOP::Class ... + +my $Baz = Class::MOP::Class->create( + 'Baz' => ( + version => '0.10', + authority => 'cpan:YOMAMA', + superclasses => [ 'Bar' ] + )); +isa_ok($Baz, 'Class::MOP::Class'); +is(Baz->meta, $Baz, '... our metaclasses are singletons'); + +is($Baz->name, 'Baz', '... Baz->name == Baz'); +is($Baz->version, '0.10', '... Baz->version == 0.10'); +is($Baz->authority, 'cpan:YOMAMA', '... Baz->authority == YOMAMA'); + +is($Baz->identifier, 'Baz-0.10-cpan:YOMAMA', '... Baz->identifier == Baz-0.10-cpan:YOMAMA'); + +is_deeply([$Baz->superclasses], ['Bar'], '... Baz->superclasses == (Bar)'); + +is_deeply( + [ $Baz->class_precedence_list ], + [ 'Baz', 'Bar', 'Foo', 'UNIVERSAL' ], + '... Baz->class_precedence_list == (Baz, Bar, Foo, UNIVERSAL)'); + +done_testing; diff --git a/t/cmop/before_after_dollar_under.t b/t/cmop/before_after_dollar_under.t new file mode 100644 index 0000000..65f9774 --- /dev/null +++ b/t/cmop/before_after_dollar_under.t @@ -0,0 +1,70 @@ +use strict; +use warnings; + +use Class::MOP; +use Class::MOP::Class; +use Test::More; +use Test::Fatal; + +my %results; + +{ + + package Base; + use metaclass; + sub hey { $results{base}++ } +} + +for my $wrap (qw(before after)) { + my $meta = Class::MOP::Class->create_anon_class( + superclasses => [ 'Base', 'Class::MOP::Object' ] ); + my $alter = "add_${wrap}_method_modifier"; + $meta->$alter( + 'hey' => sub { + $results{wrapped}++; + $_ = 'barf'; # 'barf' would replace the cached wrapper subref + } + ); + + %results = (); + my $o = $meta->get_meta_instance->create_instance; + isa_ok( $o, 'Base' ); + is( exception { + $o->hey; + $o->hey + ; # this would die with 'Can't use string ("barf") as a subroutine ref while "strict refs" in use' + }, undef, 'wrapped doesn\'t die when $_ gets changed' ); + is_deeply( + \%results, { base => 2, wrapped => 2 }, + 'saw expected calls to wrappers' + ); +} + +{ + my $meta = Class::MOP::Class->create_anon_class( + superclasses => [ 'Base', 'Class::MOP::Object' ] ); + for my $wrap (qw(before after)) { + my $alter = "add_${wrap}_method_modifier"; + $meta->$alter( + 'hey' => sub { + $results{wrapped}++; + $_ = 'barf'; # 'barf' would replace the cached wrapper subref + } + ); + } + + %results = (); + my $o = $meta->get_meta_instance->create_instance; + isa_ok( $o, 'Base' ); + is( exception { + $o->hey; + $o->hey + ; # this would die with 'Can't use string ("barf") as a subroutine ref while "strict refs" in use' + }, undef, 'double-wrapped doesn\'t die when $_ gets changed' ); + is_deeply( + \%results, { base => 2, wrapped => 4 }, + 'saw expected calls to wrappers' + ); +} + +done_testing; diff --git a/t/cmop/class_errors_and_edge_cases.t b/t/cmop/class_errors_and_edge_cases.t new file mode 100644 index 0000000..51810a3 --- /dev/null +++ b/t/cmop/class_errors_and_edge_cases.t @@ -0,0 +1,222 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + isnt( exception { + Class::MOP::Class->initialize(); + }, undef, '... initialize requires a name parameter' ); + + isnt( exception { + Class::MOP::Class->initialize(''); + }, undef, '... initialize requires a name valid parameter' ); + + isnt( exception { + Class::MOP::Class->initialize(bless {} => 'Foo'); + }, undef, '... initialize requires an unblessed parameter' ); +} + +{ + isnt( exception { + Class::MOP::Class->_construct_class_instance(); + }, undef, '... _construct_class_instance requires an :package parameter' ); + + isnt( exception { + Class::MOP::Class->_construct_class_instance(':package' => undef); + }, undef, '... _construct_class_instance requires a defined :package parameter' ); + + isnt( exception { + Class::MOP::Class->_construct_class_instance(':package' => ''); + }, undef, '... _construct_class_instance requires a valid :package parameter' ); +} + + +{ + isnt( exception { + Class::MOP::Class->create(); + }, undef, '... create requires an package_name parameter' ); + + isnt( exception { + Class::MOP::Class->create(undef); + }, undef, '... create requires a defined package_name parameter' ); + + isnt( exception { + Class::MOP::Class->create(''); + }, undef, '... create requires a valid package_name parameter' ); + + isnt( exception { + Class::MOP::Class->create('+++'); + }, qr/^\+\+\+ is not a module name/, '... create requires a valid package_name parameter' ); +} + +{ + isnt( exception { + Class::MOP::Class->clone_object(1); + }, undef, '... can only clone instances' ); +} + +{ + isnt( exception { + Class::MOP::Class->add_method(); + }, undef, '... add_method dies as expected' ); + + isnt( exception { + Class::MOP::Class->add_method(''); + }, undef, '... add_method dies as expected' ); + + isnt( exception { + Class::MOP::Class->add_method('foo' => 'foo'); + }, undef, '... add_method dies as expected' ); + + isnt( exception { + Class::MOP::Class->add_method('foo' => []); + }, undef, '... add_method dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->has_method(); + }, undef, '... has_method dies as expected' ); + + isnt( exception { + Class::MOP::Class->has_method(''); + }, undef, '... has_method dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->get_method(); + }, undef, '... get_method dies as expected' ); + + isnt( exception { + Class::MOP::Class->get_method(''); + }, undef, '... get_method dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->remove_method(); + }, undef, '... remove_method dies as expected' ); + + isnt( exception { + Class::MOP::Class->remove_method(''); + }, undef, '... remove_method dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->find_all_methods_by_name(); + }, undef, '... find_all_methods_by_name dies as expected' ); + + isnt( exception { + Class::MOP::Class->find_all_methods_by_name(''); + }, undef, '... find_all_methods_by_name dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->add_attribute(bless {} => 'Foo'); + }, undef, '... add_attribute dies as expected' ); +} + + +{ + isnt( exception { + Class::MOP::Class->has_attribute(); + }, undef, '... has_attribute dies as expected' ); + + isnt( exception { + Class::MOP::Class->has_attribute(''); + }, undef, '... has_attribute dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->get_attribute(); + }, undef, '... get_attribute dies as expected' ); + + isnt( exception { + Class::MOP::Class->get_attribute(''); + }, undef, '... get_attribute dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->remove_attribute(); + }, undef, '... remove_attribute dies as expected' ); + + isnt( exception { + Class::MOP::Class->remove_attribute(''); + }, undef, '... remove_attribute dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->add_package_symbol(); + }, undef, '... add_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->add_package_symbol(''); + }, undef, '... add_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->add_package_symbol('foo'); + }, undef, '... add_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->add_package_symbol('&foo'); + }, undef, '... add_package_symbol dies as expected' ); + +# throws_ok { +# Class::MOP::Class->meta->add_package_symbol('@-'); +# } qr/^Could not create package variable \(\@\-\) because/, +# '... add_package_symbol dies as expected'; +} + +{ + isnt( exception { + Class::MOP::Class->has_package_symbol(); + }, undef, '... has_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->has_package_symbol(''); + }, undef, '... has_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->has_package_symbol('foo'); + }, undef, '... has_package_symbol dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->get_package_symbol(); + }, undef, '... get_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->get_package_symbol(''); + }, undef, '... get_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->get_package_symbol('foo'); + }, undef, '... get_package_symbol dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->remove_package_symbol(); + }, undef, '... remove_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->remove_package_symbol(''); + }, undef, '... remove_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->remove_package_symbol('foo'); + }, undef, '... remove_package_symbol dies as expected' ); +} + +done_testing; diff --git a/t/cmop/class_is_pristine.t b/t/cmop/class_is_pristine.t new file mode 100644 index 0000000..4ab95c0 --- /dev/null +++ b/t/cmop/class_is_pristine.t @@ -0,0 +1,23 @@ +use strict; +use warnings; + +use Class::MOP; +use Test::More; + +{ + package Foo; + + sub foo { } + sub bar { } +} + +my $meta = Class::MOP::Class->initialize('Foo'); +ok( $meta->is_pristine, 'Foo is still pristine' ); + +$meta->add_method( baz => sub { } ); +ok( $meta->is_pristine, 'Foo is still pristine after add_method' ); + +$meta->add_attribute( name => 'attr', reader => 'get_attr' ); +ok( ! $meta->is_pristine, 'Foo is not pristine after add_attribute' ); + +done_testing; diff --git a/t/cmop/class_precedence_list.t b/t/cmop/class_precedence_list.t new file mode 100644 index 0000000..56ef28f --- /dev/null +++ b/t/cmop/class_precedence_list.t @@ -0,0 +1,160 @@ +use strict; +use warnings; + +use Test::More; + +use Class::MOP; +use Class::MOP::Class; + +=pod + + A + / \ +B C + \ / + D + +=cut + +{ + package My::A; + use metaclass; + package My::B; + our @ISA = ('My::A'); + package My::C; + our @ISA = ('My::A'); + package My::D; + our @ISA = ('My::B', 'My::C'); +} + +is_deeply( + [ My::D->meta->class_precedence_list ], + [ 'My::D', 'My::B', 'My::A', 'My::C', 'My::A' ], + '... My::D->meta->class_precedence_list == (D B A C A)'); + +is_deeply( + [ My::D->meta->linearized_isa ], + [ 'My::D', 'My::B', 'My::A', 'My::C' ], + '... My::D->meta->linearized_isa == (D B A C)'); + +=pod + + A <-+ + | | + B | + | | + C --+ + +=cut + +# 5.9.5+ dies at the moment of +# recursive @ISA definition, not later when +# you try to use the @ISAs. +eval { + { + package My::2::A; + use metaclass; + our @ISA = ('My::2::C'); + + package My::2::B; + our @ISA = ('My::2::A'); + + package My::2::C; + our @ISA = ('My::2::B'); + } + + My::2::B->meta->class_precedence_list +}; +ok($@, '... recursive inheritance breaks correctly :)'); + +=pod + + +--------+ + | A | + | / \ | + +->B C-+ + \ / + D + +=cut + +{ + package My::3::A; + use metaclass; + package My::3::B; + our @ISA = ('My::3::A'); + package My::3::C; + our @ISA = ('My::3::A', 'My::3::B'); + package My::3::D; + our @ISA = ('My::3::B', 'My::3::C'); +} + +is_deeply( + [ My::3::D->meta->class_precedence_list ], + [ 'My::3::D', 'My::3::B', 'My::3::A', 'My::3::C', 'My::3::A', 'My::3::B', 'My::3::A' ], + '... My::3::D->meta->class_precedence_list == (D B A C A B A)'); + +is_deeply( + [ My::3::D->meta->linearized_isa ], + [ 'My::3::D', 'My::3::B', 'My::3::A', 'My::3::C' ], + '... My::3::D->meta->linearized_isa == (D B A C B)'); + +=pod + +Test all the class_precedence_lists +using Perl's own dispatcher to check +against. + +=cut + +my @CLASS_PRECEDENCE_LIST; + +{ + package Foo; + use metaclass; + + sub CPL { push @CLASS_PRECEDENCE_LIST => 'Foo' } + + package Bar; + our @ISA = ('Foo'); + + sub CPL { + push @CLASS_PRECEDENCE_LIST => 'Bar'; + $_[0]->SUPER::CPL(); + } + + package Baz; + use metaclass; + our @ISA = ('Bar'); + + sub CPL { + push @CLASS_PRECEDENCE_LIST => 'Baz'; + $_[0]->SUPER::CPL(); + } + + package Foo::Bar; + our @ISA = ('Baz'); + + sub CPL { + push @CLASS_PRECEDENCE_LIST => 'Foo::Bar'; + $_[0]->SUPER::CPL(); + } + + package Foo::Bar::Baz; + our @ISA = ('Foo::Bar'); + + sub CPL { + push @CLASS_PRECEDENCE_LIST => 'Foo::Bar::Baz'; + $_[0]->SUPER::CPL(); + } + +} + +Foo::Bar::Baz->CPL(); + +is_deeply( + [ Foo::Bar::Baz->meta->class_precedence_list ], + [ @CLASS_PRECEDENCE_LIST ], + '... Foo::Bar::Baz->meta->class_precedence_list == @CLASS_PRECEDENCE_LIST'); + +done_testing; diff --git a/t/cmop/constant_codeinfo.t b/t/cmop/constant_codeinfo.t new file mode 100644 index 0000000..b40cc82 --- /dev/null +++ b/t/cmop/constant_codeinfo.t @@ -0,0 +1,22 @@ +use strict; +use warnings; +use Test::More; + +use Class::MOP; + +{ + package Foo; + use constant FOO => 'bar'; +} + +my $meta = Class::MOP::Class->initialize('Foo'); + +my $syms = $meta->get_all_package_symbols('CODE'); +is(ref $syms->{FOO}, 'CODE', 'get constant symbol'); + +undef $syms; + +$syms = $meta->get_all_package_symbols('CODE'); +is(ref $syms->{FOO}, 'CODE', 'constant symbol still there, although we dropped our reference'); + +done_testing; diff --git a/t/cmop/create_class.t b/t/cmop/create_class.t new file mode 100644 index 0000000..63a31d4 --- /dev/null +++ b/t/cmop/create_class.t @@ -0,0 +1,113 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +my $Point = Class::MOP::Class->create('Point' => ( + version => '0.01', + attributes => [ + Class::MOP::Attribute->new('x' => ( + reader => 'x', + init_arg => 'x' + )), + Class::MOP::Attribute->new('y' => ( + accessor => 'y', + init_arg => 'y' + )), + ], + methods => { + 'new' => sub { + my $class = shift; + my $instance = $class->meta->new_object(@_); + bless $instance => $class; + }, + 'clear' => sub { + my $self = shift; + $self->{'x'} = 0; + $self->{'y'} = 0; + } + } +)); + +my $Point3D = Class::MOP::Class->create('Point3D' => ( + version => '0.01', + superclasses => [ 'Point' ], + attributes => [ + Class::MOP::Attribute->new('z' => ( + default => 123 + )), + ], + methods => { + 'clear' => sub { + my $self = shift; + $self->{'z'} = 0; + $self->SUPER::clear(); + } + } +)); + +isa_ok($Point, 'Class::MOP::Class'); +isa_ok($Point3D, 'Class::MOP::Class'); + +# ... test the classes themselves + +my $point = Point->new('x' => 2, 'y' => 3); +isa_ok($point, 'Point'); + +can_ok($point, 'x'); +can_ok($point, 'y'); +can_ok($point, 'clear'); + +{ + my $meta = $point->meta; + is($meta, Point->meta(), '... got the meta from the instance too'); +} + +is($point->y, 3, '... the y attribute was initialized correctly through the metaobject'); + +$point->y(42); +is($point->y, 42, '... the y attribute was set properly with the accessor'); + +is($point->x, 2, '... the x attribute was initialized correctly through the metaobject'); + +isnt( exception { + $point->x(42); +}, undef, '... cannot write to a read-only accessor' ); +is($point->x, 2, '... the x attribute was not altered'); + +$point->clear(); + +is($point->y, 0, '... the y attribute was cleared correctly'); +is($point->x, 0, '... the x attribute was cleared correctly'); + +my $point3d = Point3D->new('x' => 1, 'y' => 2, 'z' => 3); +isa_ok($point3d, 'Point3D'); +isa_ok($point3d, 'Point'); + +{ + my $meta = $point3d->meta; + is($meta, Point3D->meta(), '... got the meta from the instance too'); +} + +can_ok($point3d, 'x'); +can_ok($point3d, 'y'); +can_ok($point3d, 'clear'); + +is($point3d->x, 1, '... the x attribute was initialized correctly through the metaobject'); +is($point3d->y, 2, '... the y attribute was initialized correctly through the metaobject'); +is($point3d->{'z'}, 3, '... the z attribute was initialized correctly through the metaobject'); + +{ + my $point3d = Point3D->new(); + isa_ok($point3d, 'Point3D'); + + is($point3d->x, undef, '... the x attribute was not initialized'); + is($point3d->y, undef, '... the y attribute was not initialized'); + is($point3d->{'z'}, 123, '... the z attribute was initialized correctly through the metaobject'); + +} + +done_testing; diff --git a/t/cmop/custom_instance.t b/t/cmop/custom_instance.t new file mode 100644 index 0000000..c6aeb6d --- /dev/null +++ b/t/cmop/custom_instance.t @@ -0,0 +1,137 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +use Class::MOP; + +my $instance; +{ + package Foo; + + sub new { + my $class = shift; + $instance = bless {@_}, $class; + return $instance; + } + + sub foo { shift->{foo} } +} + +{ + package Foo::Sub; + use parent -norequire => 'Foo'; + use metaclass; + + sub new { + my $class = shift; + $class->meta->new_object( + __INSTANCE__ => $class->SUPER::new(@_), + @_, + ); + } + + __PACKAGE__->meta->add_attribute( + bar => ( + reader => 'bar', + initializer => sub { + my $self = shift; + my ($value, $writer, $attr) = @_; + $writer->(uc $value); + }, + ), + ); +} + +undef $instance; +is( exception { + my $foo = Foo::Sub->new; + isa_ok($foo, 'Foo'); + isa_ok($foo, 'Foo::Sub'); + is($foo, $instance, "used the passed-in instance"); +}, undef ); + +undef $instance; +is( exception { + my $foo = Foo::Sub->new(foo => 'FOO'); + isa_ok($foo, 'Foo'); + isa_ok($foo, 'Foo::Sub'); + is($foo, $instance, "used the passed-in instance"); + is($foo->foo, 'FOO', "set non-CMOP constructor args"); +}, undef ); + +undef $instance; +is( exception { + my $foo = Foo::Sub->new(bar => 'bar'); + isa_ok($foo, 'Foo'); + isa_ok($foo, 'Foo::Sub'); + is($foo, $instance, "used the passed-in instance"); + is($foo->bar, 'BAR', "set CMOP attributes"); +}, undef ); + +undef $instance; +is( exception { + my $foo = Foo::Sub->new(foo => 'FOO', bar => 'bar'); + isa_ok($foo, 'Foo'); + isa_ok($foo, 'Foo::Sub'); + is($foo, $instance, "used the passed-in instance"); + is($foo->foo, 'FOO', "set non-CMOP constructor arg"); + is($foo->bar, 'BAR', "set correct CMOP attribute"); +}, undef ); + +{ + package BadFoo; + + sub new { + my $class = shift; + $instance = bless {@_}; + return $instance; + } + + sub foo { shift->{foo} } +} + +{ + package BadFoo::Sub; + use parent -norequire => 'BadFoo'; + use metaclass; + + sub new { + my $class = shift; + $class->meta->new_object( + __INSTANCE__ => $class->SUPER::new(@_), + @_, + ); + } + + __PACKAGE__->meta->add_attribute( + bar => ( + reader => 'bar', + initializer => sub { + my $self = shift; + my ($value, $writer, $attr) = @_; + $writer->(uc $value); + }, + ), + ); +} + +like( exception { BadFoo::Sub->new }, qr/BadFoo=HASH.*is not a BadFoo::Sub/, "error with incorrect constructors" ); + +{ + my $meta = Class::MOP::Class->create('Really::Bad::Foo'); + like( exception { + $meta->new_object(__INSTANCE__ => (bless {}, 'Some::Other::Class')) + }, qr/Some::Other::Class=HASH.*is not a Really::Bad::Foo/, "error with completely invalid class" ); +} + +{ + my $meta = Class::MOP::Class->create('Really::Bad::Foo::2'); + for my $invalid ('foo', 1, 0, '') { + like( exception { + $meta->new_object(__INSTANCE__ => $invalid) + }, qr/The __INSTANCE__ parameter must be a blessed reference, not $invalid/, "error with unblessed thing" ); + } +} + +done_testing; diff --git a/t/cmop/deprecated.t b/t/cmop/deprecated.t new file mode 100644 index 0000000..b29649b --- /dev/null +++ b/t/cmop/deprecated.t @@ -0,0 +1,31 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; + +use lib 't/cmop/lib'; + +{ + my $warnings; + local $SIG{__WARN__} = sub { $warnings .= $_[0] }; + Class::MOP::load_class('BinaryTree'); + like($warnings, qr/^Class::MOP::load_class is deprecated/); + ok(Class::MOP::does_metaclass_exist('BinaryTree')); +} + +{ + my $warnings; + local $SIG{__WARN__} = sub { $warnings .= $_[0] }; + ok(Class::MOP::is_class_loaded('BinaryTree')); + like($warnings, qr/^Class::MOP::is_class_loaded is deprecated/); +} + +{ + my $warnings; + local $SIG{__WARN__} = sub { $warnings .= $_[0] }; + is(Class::MOP::load_first_existing_class('this::class::probably::doesnt::exist', 'MyMetaClass'), 'MyMetaClass'); + like($warnings, qr/^Class::MOP::load_first_existing_class is deprecated/); +} + +done_testing; diff --git a/t/cmop/get_code_info.t b/t/cmop/get_code_info.t new file mode 100644 index 0000000..2770b76 --- /dev/null +++ b/t/cmop/get_code_info.t @@ -0,0 +1,52 @@ +use strict; +use warnings; + +use Test::More; +use Sub::Name 'subname'; + +BEGIN { + $^P &= ~0x200; # Don't munge anonymous sub names +} + +use Class::MOP; + + +sub code_name_is { + my ( $code, $stash, $name ) = @_; + + is_deeply( + [ Class::MOP::get_code_info($code) ], + [ $stash, $name ], + "sub name is ${stash}::$name" + ); +} + +code_name_is( sub {}, main => "__ANON__" ); + +code_name_is( subname("Foo::bar", sub {}), Foo => "bar" ); + +code_name_is( subname("", sub {}), "main" => "" ); + +require Class::MOP::Method; +code_name_is( \&Class::MOP::Method::name, "Class::MOP::Method", "name" ); + +{ + package Foo; + + sub MODIFY_CODE_ATTRIBUTES { + my ($class, $code) = @_; + my @info = Class::MOP::get_code_info($code); + + if ( $] >= 5.011 ) { + ::is_deeply(\@info, ['Foo', 'foo'], "got a name for a code ref in an attr handler"); + } + else { + ::is_deeply(\@info, [], "no name for a coderef that's still compiling"); + } + return (); + } + + sub foo : Bar {} +} + +done_testing; diff --git a/t/cmop/immutable_custom_trait.t b/t/cmop/immutable_custom_trait.t new file mode 100644 index 0000000..24b72b7 --- /dev/null +++ b/t/cmop/immutable_custom_trait.t @@ -0,0 +1,76 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + + package My::Meta; + + use strict; + use warnings; + + use parent 'Class::MOP::Class'; + + sub initialize { + shift->SUPER::initialize( + @_, + immutable_trait => 'My::Meta::Class::Immutable::Trait', + ); + } +} + +{ + package My::Meta::Class::Immutable::Trait; + + use MRO::Compat; + use parent 'Class::MOP::Class::Immutable::Trait'; + + sub another_method { 42 } + + sub superclasses { + my $orig = shift; + my $self = shift; + $self->$orig(@_); + } +} + +{ + package Foo; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->add_attribute('foo'); + + __PACKAGE__->meta->make_immutable; +} + +{ + package Bar; + + use strict; + use warnings; + use metaclass 'My::Meta'; + + use parent -norequire => 'Foo'; + + __PACKAGE__->meta->add_attribute('bar'); + + ::is( ::exception { __PACKAGE__->meta->make_immutable }, undef, 'can safely make a class immutable when it has a custom metaclass and immutable trait' ); +} + +{ + can_ok( Bar->meta, 'another_method' ); + is( Bar->meta->another_method, 42, 'another_method returns expected value' ); + is_deeply( + [ Bar->meta->superclasses ], ['Foo'], + 'Bar->meta->superclasses returns expected value after immutabilization' + ); +} + +done_testing; diff --git a/t/cmop/immutable_metaclass.t b/t/cmop/immutable_metaclass.t new file mode 100644 index 0000000..e674f34 --- /dev/null +++ b/t/cmop/immutable_metaclass.t @@ -0,0 +1,300 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + package Foo; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->add_attribute('bar'); + + package Bar; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Foo'); + + __PACKAGE__->meta->add_attribute('baz'); + + package Baz; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Bar'); + + __PACKAGE__->meta->add_attribute('bah'); +} + +{ + my $meta = Foo->meta; + my $original_metaclass_name = ref $meta; + + is_deeply( + { $meta->immutable_options }, {}, + 'immutable_options is empty before a class is made_immutable' + ); + + ok( $meta->make_immutable, 'make_immutable returns true' ); + my $line = __LINE__ - 1; + + ok( $meta->make_immutable, 'make_immutable still returns true' ); + + my $immutable_metaclass = $meta->_immutable_metaclass->meta; + + my $immutable_class_name = $immutable_metaclass->name; + + ok( !$immutable_class_name->is_mutable, '... immutable_metaclass is not mutable' ); + ok( $immutable_class_name->is_immutable, '... immutable_metaclass is immutable' ); + is( $immutable_class_name->meta, $immutable_metaclass, + '... immutable_metaclass meta hack works' ); + + is_deeply( + { $meta->immutable_options }, + { + inline_accessors => 1, + inline_constructor => 1, + inline_destructor => 0, + debug => 0, + immutable_trait => 'Class::MOP::Class::Immutable::Trait', + constructor_name => 'new', + constructor_class => 'Class::MOP::Method::Constructor', + destructor_class => undef, + file => $0, + line => $line, + }, + 'immutable_options is empty before a class is made_immutable' + ); + + isa_ok( $meta, "Class::MOP::Class" ); +} + +{ + my $meta = Foo->meta; + is( $meta->name, 'Foo', '... checking the Foo metaclass' ); + + ok( !$meta->is_mutable, '... our class is not mutable' ); + ok( $meta->is_immutable, '... our class is immutable' ); + + isa_ok( $meta, 'Class::MOP::Class' ); + + isnt( exception { $meta->add_method() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->alias_method() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_method() }, undef, '... exception thrown as expected' ); + + isnt( exception { $meta->add_attribute() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_attribute() }, undef, '... exception thrown as expected' ); + + isnt( exception { $meta->add_package_symbol() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_package_symbol() }, undef, '... exception thrown as expected' ); + + is( exception { $meta->identifier() }, undef, '... no exception for get_package_symbol special case' ); + + my @supers; + is( exception { + @supers = $meta->superclasses; + }, undef, '... got the superclasses okay' ); + + isnt( exception { $meta->superclasses( ['UNIVERSAL'] ) }, undef, '... but could not set the superclasses okay' ); + + my $meta_instance; + is( exception { + $meta_instance = $meta->get_meta_instance; + }, undef, '... got the meta instance okay' ); + isa_ok( $meta_instance, 'Class::MOP::Instance' ); + is( $meta_instance, $meta->get_meta_instance, + '... and we know it is cached' ); + + my @cpl; + is( exception { + @cpl = $meta->class_precedence_list; + }, undef, '... got the class precedence list okay' ); + is_deeply( + \@cpl, + ['Foo'], + '... we just have ourselves in the class precedence list' + ); + + my @attributes; + is( exception { + @attributes = $meta->get_all_attributes; + }, undef, '... got the attribute list okay' ); + is_deeply( + \@attributes, + [ $meta->get_attribute('bar') ], + '... got the right list of attributes' + ); +} + +{ + my $meta = Bar->meta; + is( $meta->name, 'Bar', '... checking the Bar metaclass' ); + + ok( $meta->is_mutable, '... our class is mutable' ); + ok( !$meta->is_immutable, '... our class is not immutable' ); + + is( exception { + $meta->make_immutable(); + }, undef, '... changed Bar to be immutable' ); + + ok( $meta->make_immutable, '... make immutable returns true' ); + + ok( !$meta->is_mutable, '... our class is no longer mutable' ); + ok( $meta->is_immutable, '... our class is now immutable' ); + + isa_ok( $meta, 'Class::MOP::Class' ); + + isnt( exception { $meta->add_method() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->alias_method() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_method() }, undef, '... exception thrown as expected' ); + + isnt( exception { $meta->add_attribute() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_attribute() }, undef, '... exception thrown as expected' ); + + isnt( exception { $meta->add_package_symbol() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_package_symbol() }, undef, '... exception thrown as expected' ); + + my @supers; + is( exception { + @supers = $meta->superclasses; + }, undef, '... got the superclasses okay' ); + + isnt( exception { $meta->superclasses( ['UNIVERSAL'] ) }, undef, '... but could not set the superclasses okay' ); + + my $meta_instance; + is( exception { + $meta_instance = $meta->get_meta_instance; + }, undef, '... got the meta instance okay' ); + isa_ok( $meta_instance, 'Class::MOP::Instance' ); + is( $meta_instance, $meta->get_meta_instance, + '... and we know it is cached' ); + + my @cpl; + is( exception { + @cpl = $meta->class_precedence_list; + }, undef, '... got the class precedence list okay' ); + is_deeply( + \@cpl, + [ 'Bar', 'Foo' ], + '... we just have ourselves in the class precedence list' + ); + + my @attributes; + is( exception { + @attributes = $meta->get_all_attributes; + }, undef, '... got the attribute list okay' ); + is_deeply( + [ sort { $a->name cmp $b->name } @attributes ], + [ Foo->meta->get_attribute('bar'), $meta->get_attribute('baz') ], + '... got the right list of attributes' + ); +} + +{ + my $meta = Baz->meta; + is( $meta->name, 'Baz', '... checking the Baz metaclass' ); + + ok( $meta->is_mutable, '... our class is mutable' ); + ok( !$meta->is_immutable, '... our class is not immutable' ); + + is( exception { + $meta->make_immutable(); + }, undef, '... changed Baz to be immutable' ); + + ok( $meta->make_immutable, '... make immutable returns true' ); + + ok( !$meta->is_mutable, '... our class is no longer mutable' ); + ok( $meta->is_immutable, '... our class is now immutable' ); + + isa_ok( $meta, 'Class::MOP::Class' ); + + isnt( exception { $meta->add_method() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->alias_method() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_method() }, undef, '... exception thrown as expected' ); + + isnt( exception { $meta->add_attribute() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_attribute() }, undef, '... exception thrown as expected' ); + + isnt( exception { $meta->add_package_symbol() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_package_symbol() }, undef, '... exception thrown as expected' ); + + my @supers; + is( exception { + @supers = $meta->superclasses; + }, undef, '... got the superclasses okay' ); + + isnt( exception { $meta->superclasses( ['UNIVERSAL'] ) }, undef, '... but could not set the superclasses okay' ); + + my $meta_instance; + is( exception { + $meta_instance = $meta->get_meta_instance; + }, undef, '... got the meta instance okay' ); + isa_ok( $meta_instance, 'Class::MOP::Instance' ); + is( $meta_instance, $meta->get_meta_instance, + '... and we know it is cached' ); + + my @cpl; + is( exception { + @cpl = $meta->class_precedence_list; + }, undef, '... got the class precedence list okay' ); + is_deeply( + \@cpl, + [ 'Baz', 'Bar', 'Foo' ], + '... we just have ourselves in the class precedence list' + ); + + my @attributes; + is( exception { + @attributes = $meta->get_all_attributes; + }, undef, '... got the attribute list okay' ); + is_deeply( + [ sort { $a->name cmp $b->name } @attributes ], + [ + $meta->get_attribute('bah'), Foo->meta->get_attribute('bar'), + Bar->meta->get_attribute('baz') + ], + '... got the right list of attributes' + ); +} + +# This test probably needs to go last since it will muck up the Foo class +{ + my $meta = Foo->meta; + + $meta->make_mutable; + $meta->make_immutable( + inline_accessors => 0, + inline_constructor => 0, + constructor_name => 'newer', + ); + my $line = __LINE__ - 5; + + is_deeply( + { $meta->immutable_options }, + { + inline_accessors => 0, + inline_constructor => 0, + inline_destructor => 0, + debug => 0, + immutable_trait => 'Class::MOP::Class::Immutable::Trait', + constructor_name => 'newer', + constructor_class => 'Class::MOP::Method::Constructor', + destructor_class => undef, + file => $0, + line => $line, + }, + 'custom immutable_options are returned by immutable_options accessor' + ); +} + +done_testing; diff --git a/t/cmop/immutable_w_constructors.t b/t/cmop/immutable_w_constructors.t new file mode 100644 index 0000000..cb95e20 --- /dev/null +++ b/t/cmop/immutable_w_constructors.t @@ -0,0 +1,301 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + + +{ + package Foo; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->add_attribute('bar' => ( + reader => 'bar', + default => 'BAR', + )); + + package Bar; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Foo'); + + __PACKAGE__->meta->add_attribute('baz' => ( + reader => 'baz', + default => sub { 'BAZ' }, + )); + + package Baz; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Bar'); + + __PACKAGE__->meta->add_attribute('bah' => ( + reader => 'bah', + default => 'BAH', + )); + + package Buzz; + + use strict; + use warnings; + use metaclass; + + + __PACKAGE__->meta->add_attribute('bar' => ( + accessor => 'bar', + predicate => 'has_bar', + clearer => 'clear_bar', + )); + + __PACKAGE__->meta->add_attribute('bah' => ( + accessor => 'bah', + predicate => 'has_bah', + clearer => 'clear_bah', + default => 'BAH' + )); + +} + +{ + my $meta = Foo->meta; + is($meta->name, 'Foo', '... checking the Foo metaclass'); + + { + my $bar_accessor = $meta->get_method('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined'); + } + + ok(!$meta->is_immutable, '... our class is not immutable'); + + is( exception { + $meta->make_immutable( + inline_constructor => 1, + inline_accessors => 0, + ); + }, undef, '... changed Foo to be immutable' ); + + ok($meta->is_immutable, '... our class is now immutable'); + isa_ok($meta, 'Class::MOP::Class'); + + # they made a constructor for us :) + can_ok('Foo', 'new'); + + { + my $foo = Foo->new; + isa_ok($foo, 'Foo'); + is($foo->bar, 'BAR', '... got the right default value'); + } + + { + my $foo = Foo->new(bar => 'BAZ'); + isa_ok($foo, 'Foo'); + is($foo->bar, 'BAZ', '... got the right parameter value'); + } + + # NOTE: + # check that the constructor correctly handles inheritance + { + my $bar = Bar->new(); + isa_ok($bar, 'Bar'); + isa_ok($bar, 'Foo'); + is($bar->bar, 'BAR', '... got the right inherited parameter value'); + is($bar->baz, 'BAZ', '... got the right inherited parameter value'); + } + + # check out accessors too + { + my $bar_accessor = $meta->get_method('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined'); + } +} + +{ + my $meta = Bar->meta; + is($meta->name, 'Bar', '... checking the Bar metaclass'); + + { + my $bar_accessor = $meta->find_method_by_name('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined'); + + my $baz_accessor = $meta->get_method('baz'); + isa_ok($baz_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($baz_accessor, 'Class::MOP::Method'); + + ok(!$baz_accessor->is_inline, '... the baz accessor is not inlined'); + } + + ok(!$meta->is_immutable, '... our class is not immutable'); + + is( exception { + $meta->make_immutable( + inline_constructor => 1, + inline_accessors => 1, + ); + }, undef, '... changed Bar to be immutable' ); + + ok($meta->is_immutable, '... our class is now immutable'); + isa_ok($meta, 'Class::MOP::Class'); + + # they made a constructor for us :) + can_ok('Bar', 'new'); + + { + my $bar = Bar->new; + isa_ok($bar, 'Bar'); + is($bar->bar, 'BAR', '... got the right default value'); + is($bar->baz, 'BAZ', '... got the right default value'); + } + + { + my $bar = Bar->new(bar => 'BAZ!', baz => 'BAR!'); + isa_ok($bar, 'Bar'); + is($bar->bar, 'BAZ!', '... got the right parameter value'); + is($bar->baz, 'BAR!', '... got the right parameter value'); + } + + # check out accessors too + { + my $bar_accessor = $meta->find_method_by_name('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined'); + + my $baz_accessor = $meta->get_method('baz'); + isa_ok($baz_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($baz_accessor, 'Class::MOP::Method'); + + ok($baz_accessor->is_inline, '... the baz accessor is not inlined'); + } +} + +{ + my $meta = Baz->meta; + is($meta->name, 'Baz', '... checking the Bar metaclass'); + + { + my $bar_accessor = $meta->find_method_by_name('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined'); + + my $baz_accessor = $meta->find_method_by_name('baz'); + isa_ok($baz_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($baz_accessor, 'Class::MOP::Method'); + + ok($baz_accessor->is_inline, '... the baz accessor is inlined'); + + my $bah_accessor = $meta->get_method('bah'); + isa_ok($bah_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bah_accessor, 'Class::MOP::Method'); + + ok(!$bah_accessor->is_inline, '... the baz accessor is not inlined'); + } + + ok(!$meta->is_immutable, '... our class is not immutable'); + + is( exception { + $meta->make_immutable( + inline_constructor => 0, + inline_accessors => 1, + ); + }, undef, '... changed Bar to be immutable' ); + + ok($meta->is_immutable, '... our class is now immutable'); + isa_ok($meta, 'Class::MOP::Class'); + + ok(!Baz->meta->has_method('new'), '... no constructor was made'); + + { + my $baz = Baz->meta->new_object; + isa_ok($baz, 'Bar'); + is($baz->bar, 'BAR', '... got the right default value'); + is($baz->baz, 'BAZ', '... got the right default value'); + } + + { + my $baz = Baz->meta->new_object(bar => 'BAZ!', baz => 'BAR!', bah => 'BAH!'); + isa_ok($baz, 'Baz'); + is($baz->bar, 'BAZ!', '... got the right parameter value'); + is($baz->baz, 'BAR!', '... got the right parameter value'); + is($baz->bah, 'BAH!', '... got the right parameter value'); + } + + # check out accessors too + { + my $bar_accessor = $meta->find_method_by_name('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined'); + + my $baz_accessor = $meta->find_method_by_name('baz'); + isa_ok($baz_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($baz_accessor, 'Class::MOP::Method'); + + ok($baz_accessor->is_inline, '... the baz accessor is not inlined'); + + my $bah_accessor = $meta->get_method('bah'); + isa_ok($bah_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bah_accessor, 'Class::MOP::Method'); + + ok($bah_accessor->is_inline, '... the baz accessor is not inlined'); + } +} + + +{ + my $buzz; + ::is( ::exception { $buzz = Buzz->meta->new_object }, undef, '...Buzz instantiated successfully' ); + ::ok(!$buzz->has_bar, '...bar is not set'); + ::is($buzz->bar, undef, '...bar returns undef'); + ::ok(!$buzz->has_bar, '...bar was not autovivified'); + + $buzz->bar(undef); + ::ok($buzz->has_bar, '...bar is set'); + ::is($buzz->bar, undef, '...bar is undef'); + $buzz->clear_bar; + ::ok(!$buzz->has_bar, '...bar is no longerset'); + + my $buzz2; + ::is( ::exception { $buzz2 = Buzz->meta->new_object('bar' => undef) }, undef, '...Buzz instantiated successfully' ); + ::ok($buzz2->has_bar, '...bar is set'); + ::is($buzz2->bar, undef, '...bar is undef'); + +} + +{ + my $buzz; + ::is( ::exception { $buzz = Buzz->meta->new_object }, undef, '...Buzz instantiated successfully' ); + ::ok($buzz->has_bah, '...bah is set'); + ::is($buzz->bah, 'BAH', '...bah returns "BAH"' ); + + my $buzz2; + ::is( ::exception { $buzz2 = Buzz->meta->new_object('bah' => undef) }, undef, '...Buzz instantiated successfully' ); + ::ok($buzz2->has_bah, '...bah is set'); + ::is($buzz2->bah, undef, '...bah is undef'); + +} + +done_testing; diff --git a/t/cmop/immutable_w_custom_metaclass.t b/t/cmop/immutable_w_custom_metaclass.t new file mode 100644 index 0000000..c0b722d --- /dev/null +++ b/t/cmop/immutable_w_custom_metaclass.t @@ -0,0 +1,71 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Scalar::Util; + +use Class::MOP; + +use lib 't/cmop/lib'; + +{ + + package Foo; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->make_immutable; + + package Bar; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->make_immutable; + + package Baz; + + use strict; + use warnings; + use metaclass 'MyMetaClass'; + + sub mymetaclass_attributes { + shift->meta->mymetaclass_attributes; + } + + ::is( ::exception { Baz->meta->superclasses('Bar') }, undef, '... we survive the metaclass incompatibility test' ); +} + +{ + my $meta = Baz->meta; + ok( $meta->is_mutable, '... Baz is mutable' ); + is( + Scalar::Util::blessed( Foo->meta ), + Scalar::Util::blessed( Bar->meta ), + 'Foo and Bar immutable metaclasses match' + ); + is( Scalar::Util::blessed($meta), 'MyMetaClass', + 'Baz->meta blessed as MyMetaClass' ); + ok( Baz->can('mymetaclass_attributes'), + '... Baz can do method before immutable' ); + ok( $meta->can('mymetaclass_attributes'), + '... meta can do method before immutable' ); + is( exception { $meta->make_immutable }, undef, "Baz is now immutable" ); + ok( $meta->is_immutable, '... Baz is immutable' ); + isa_ok( $meta, 'MyMetaClass', 'Baz->meta' ); + ok( Baz->can('mymetaclass_attributes'), + '... Baz can do method after imutable' ); + ok( $meta->can('mymetaclass_attributes'), + '... meta can do method after immutable' ); + isnt( Scalar::Util::blessed( Baz->meta ), + Scalar::Util::blessed( Bar->meta ), + 'Baz and Bar immutable metaclasses are different' ); + is( exception { $meta->make_mutable }, undef, "Baz is now mutable" ); + ok( $meta->is_mutable, '... Baz is mutable again' ); +} + +done_testing; diff --git a/t/cmop/inline_and_dollar_at.t b/t/cmop/inline_and_dollar_at.t new file mode 100644 index 0000000..80af4c9 --- /dev/null +++ b/t/cmop/inline_and_dollar_at.t @@ -0,0 +1,19 @@ +use strict; +use warnings; +use Test::More; +use Class::MOP; + + +{ + package Foo; + + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $@ = 'dollar at'; + + $meta->make_immutable; + + ::is( $@, 'dollar at', '$@ is untouched after immutablization' ); +} + +done_testing; diff --git a/t/cmop/inline_structor.t b/t/cmop/inline_structor.t new file mode 100644 index 0000000..b22c8a9 --- /dev/null +++ b/t/cmop/inline_structor.t @@ -0,0 +1,291 @@ +use strict; +use warnings; + +use Test::More; +use Test::Requires 'Test::Output'; # skip all if not installed + +use Class::MOP; + +{ + package HasConstructor; + + sub new { bless {}, $_[0] } + + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->superclasses('NotMoose'); + + ::stderr_like( + sub { $meta->make_immutable }, + qr/\QNot inlining a constructor for HasConstructor since it defines its own constructor.\E\s+\QIf you are certain you don't need to inline your constructor, specify inline_constructor => 0 in your call to HasConstructor->meta->make_immutable\E/, + 'got a warning that Foo will not have an inlined constructor because it defines its own new method' + ); + + ::is( + $meta->find_method_by_name('new')->body, + HasConstructor->can('new'), + 'HasConstructor->new was untouched' + ); +} + +{ + package My::Constructor; + + use parent 'Class::MOP::Method::Constructor'; + + sub _expected_method_class { 'Base::Class' } +} + +{ + package No::Constructor; +} + +{ + package My::Constructor2; + + use parent 'Class::MOP::Method::Constructor'; + + sub _expected_method_class { 'No::Constructor' } +} + +{ + package Base::Class; + + sub new { bless {}, $_[0] } + sub DESTROY { } +} + +{ + package NotMoose; + + sub new { + my $class = shift; + + return bless { not_moose => 1 }, $class; + } +} + +{ + package Foo; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->superclasses('NotMoose'); + + ::stderr_like( + sub { $meta->make_immutable( constructor_class => 'My::Constructor' ) }, + qr/\QNot inlining 'new' for Foo since it is not inheriting the default Base::Class::new\E\s+\QIf you are certain you don't need to inline your constructor, specify inline_constructor => 0 in your call to Foo->meta->make_immutable/, + 'got a warning that Foo will not have an inlined constructor' + ); + + ::is( + $meta->find_method_by_name('new')->body, + NotMoose->can('new'), + 'Foo->new is inherited from NotMoose' + ); +} + +{ + package Bar; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->superclasses('NotMoose'); + + ::stderr_is( + sub { $meta->make_immutable( replace_constructor => 1 ) }, + q{}, + 'no warning when replace_constructor is true' + ); + + ::is( + $meta->find_method_by_name('new')->package_name, + 'Bar', + 'Bar->new is inlined, and not inherited from NotMoose' + ); +} + +{ + package Baz; + Class::MOP::Class->initialize(__PACKAGE__)->make_immutable; +} + +{ + package Quux; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->superclasses('Baz'); + + ::stderr_is( + sub { $meta->make_immutable }, + q{}, + 'no warning when inheriting from a class that has already made itself immutable' + ); +} + +{ + package Whatever; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + ::stderr_like( + sub { $meta->make_immutable( constructor_class => 'My::Constructor2' ) }, + qr/\QNot inlining 'new' for Whatever since No::Constructor::new is not defined/, + 'got a warning that Whatever will not have an inlined constructor because its expected inherited method does not exist' + ); +} + +{ + package My::Constructor3; + + use parent 'Class::MOP::Method::Constructor'; +} + +{ + package CustomCons; + + Class::MOP::Class->initialize(__PACKAGE__)->make_immutable( constructor_class => 'My::Constructor3' ); +} + +{ + package Subclass; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->superclasses('CustomCons'); + + ::stderr_is( + sub { $meta->make_immutable }, + q{}, + 'no warning when inheriting from a class that has already made itself immutable' + ); +} + +{ + package ModdedNew; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + sub new { bless {}, shift } + + $meta->add_before_method_modifier( 'new' => sub { } ); +} + +{ + package ModdedSub; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->superclasses('ModdedNew'); + + ::stderr_like( + sub { $meta->make_immutable }, + qr/\QNot inlining 'new' for ModdedSub since it has method modifiers which would be lost if it were inlined/, + 'got a warning that ModdedSub will not have an inlined constructor since it inherited a wrapped new' + ); +} + +{ + package My::Destructor; + + use parent 'Class::MOP::Method::Inlined'; + + sub new { + my $class = shift; + my %options = @_; + + my $self = bless \%options, $class; + $self->_inline_destructor; + + return $self; + } + + sub _inline_destructor { + my $self = shift; + + my $code = $self->_compile_code('sub { }'); + + $self->{body} = $code; + } + + sub is_needed { 1 } + sub associated_metaclass { $_[0]->{metaclass} } + sub body { $_[0]->{body} } + sub _expected_method_class { 'Base::Class' } +} + +{ + package HasDestructor; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + sub DESTROY { } + + ::stderr_like( + sub { + $meta->make_immutable( + inline_destructor => 1, + destructor_class => 'My::Destructor', + ); + }, + qr/Not inlining a destructor for HasDestructor since it defines its own destructor./, + 'got a warning when trying to inline a destructor for a class that already defines DESTROY' + ); + + ::is( + $meta->find_method_by_name('DESTROY')->body, + HasDestructor->can('DESTROY'), + 'HasDestructor->DESTROY was untouched' + ); +} + +{ + package HasDestructor2; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + sub DESTROY { } + + $meta->make_immutable( + inline_destructor => 1, + destructor_class => 'My::Destructor', + replace_destructor => 1 + ); + + ::stderr_is( + sub { + $meta->make_immutable( + inline_destructor => 1, + destructor_class => 'My::Destructor', + replace_destructor => 1 + ); + }, + q{}, + 'no warning when replace_destructor is true' + ); + + ::isnt( + $meta->find_method_by_name('new')->body, + HasConstructor2->can('new'), + 'HasConstructor2->new was replaced' + ); +} + +{ + package ParentHasDestructor; + + sub DESTROY { } +} + +{ + package DestructorChild; + + use parent -norequire => 'ParentHasDestructor'; + + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + ::stderr_like( + sub { + $meta->make_immutable( + inline_destructor => 1, + destructor_class => 'My::Destructor', + ); + }, + qr/Not inlining 'DESTROY' for DestructorChild since it is not inheriting the default Base::Class::DESTROY/, + 'got a warning when trying to inline a destructor in a class that inherits an unexpected DESTROY' + ); +} + +done_testing; diff --git a/t/cmop/insertion_order.t b/t/cmop/insertion_order.t new file mode 100644 index 0000000..073d3b3 --- /dev/null +++ b/t/cmop/insertion_order.t @@ -0,0 +1,35 @@ +use strict; +use warnings; +use Test::More; +use Class::MOP; + +my $Point = Class::MOP::Class->create('Point' => ( + version => '0.01', + attributes => [ + Class::MOP::Attribute->new('x' => ( + reader => 'x', + init_arg => 'x' + )), + Class::MOP::Attribute->new('y' => ( + accessor => 'y', + init_arg => 'y' + )), + ], + methods => { + 'new' => sub { + my $class = shift; + my $instance = $class->meta->new_object(@_); + bless $instance => $class; + }, + 'clear' => sub { + my $self = shift; + $self->{'x'} = 0; + $self->{'y'} = 0; + } + } +)); + +is($Point->get_attribute('x')->insertion_order, 0, 'Insertion order of Attribute "x"'); +is($Point->get_attribute('y')->insertion_order, 1, 'Insertion order of Attribute "y"'); + +done_testing; diff --git a/t/cmop/instance.t b/t/cmop/instance.t new file mode 100644 index 0000000..943d6bb --- /dev/null +++ b/t/cmop/instance.t @@ -0,0 +1,137 @@ +use strict; +use warnings; + +use Test::More; + +use Scalar::Util qw/isweak reftype/; + +use Class::MOP::Instance; + +can_ok( "Class::MOP::Instance", $_ ) for qw/ + new + + create_instance + + get_all_slots + + initialize_all_slots + deinitialize_all_slots + + get_slot_value + set_slot_value + initialize_slot + deinitialize_slot + is_slot_initialized + weaken_slot_value + strengthen_slot_value + + inline_get_slot_value + inline_set_slot_value + inline_initialize_slot + inline_deinitialize_slot + inline_is_slot_initialized + inline_weaken_slot_value + inline_strengthen_slot_value +/; + +{ + package Foo; + use metaclass; + + Foo->meta->add_attribute('moosen'); + + package Bar; + use metaclass; + use parent -norequire => 'Foo'; + + Bar->meta->add_attribute('elken'); +} + +my $mi_foo = Foo->meta->get_meta_instance; +isa_ok($mi_foo, "Class::MOP::Instance"); + +is_deeply( + [ $mi_foo->get_all_slots ], + [ "moosen" ], + '... get all slots for Foo'); + +my $mi_bar = Bar->meta->get_meta_instance; +isa_ok($mi_bar, "Class::MOP::Instance"); + +isnt($mi_foo, $mi_bar, '... they are not the same instance'); + +is_deeply( + [ sort $mi_bar->get_all_slots ], + [ "elken", "moosen" ], + '... get all slots for Bar'); + +my $i_foo = $mi_foo->create_instance; +isa_ok($i_foo, "Foo"); + +{ + my $i_foo_2 = $mi_foo->create_instance; + isa_ok($i_foo_2, "Foo"); + isnt($i_foo_2, $i_foo, '... not the same instance'); + is_deeply($i_foo, $i_foo_2, '... but the same structure'); +} + +ok(!$mi_foo->is_slot_initialized( $i_foo, "moosen" ), "slot not initialized"); + +ok(!defined($mi_foo->get_slot_value( $i_foo, "moosen" )), "... no value for slot"); + +$mi_foo->initialize_slot( $i_foo, "moosen" ); + +#Removed becayse slot initialization works differently now (groditi) +#ok($mi_foo->is_slot_initialized( $i_foo, "moosen" ), "slot initialized"); + +ok(!defined($mi_foo->get_slot_value( $i_foo, "moosen" )), "... but no value for slot"); + +$mi_foo->set_slot_value( $i_foo, "moosen", "the value" ); + +is($mi_foo->get_slot_value( $i_foo, "moosen" ), "the value", "... get slot value"); +ok(!$i_foo->can('moosen'), '... Foo cant moosen'); + +my $ref = []; + +$mi_foo->set_slot_value( $i_foo, "moosen", $ref ); +$mi_foo->weaken_slot_value( $i_foo, "moosen" ); + +ok( isweak($i_foo->{moosen}), '... white box test of weaken' ); +is( $mi_foo->get_slot_value( $i_foo, "moosen" ), $ref, "weak value is fetchable" ); +ok( !isweak($mi_foo->get_slot_value( $i_foo, "moosen" )), "return value not weak" ); + +undef $ref; + +is( $mi_foo->get_slot_value( $i_foo, "moosen" ), undef, "weak value destroyed" ); + +$ref = []; + +$mi_foo->set_slot_value( $i_foo, "moosen", $ref ); + +undef $ref; + +is( reftype( $mi_foo->get_slot_value( $i_foo, "moosen" ) ), "ARRAY", "value not weak yet" ); + +$mi_foo->weaken_slot_value( $i_foo, "moosen" ); + +is( $mi_foo->get_slot_value( $i_foo, "moosen" ), undef, "weak value destroyed" ); + +$ref = []; + +$mi_foo->set_slot_value( $i_foo, "moosen", $ref ); +$mi_foo->weaken_slot_value( $i_foo, "moosen" ); +ok( isweak($i_foo->{moosen}), '... white box test of weaken' ); +$mi_foo->strengthen_slot_value( $i_foo, "moosen" ); +ok( !isweak($i_foo->{moosen}), '... white box test of weaken' ); + +undef $ref; + +is( reftype( $mi_foo->get_slot_value( $i_foo, "moosen" ) ), "ARRAY", "weak value can be strengthened" ); + +$mi_foo->deinitialize_slot( $i_foo, "moosen" ); + +ok(!$mi_foo->is_slot_initialized( $i_foo, "moosen" ), "slot deinitialized"); + +ok(!defined($mi_foo->get_slot_value( $i_foo, "moosen" )), "... no value for slot"); + +done_testing; diff --git a/t/cmop/instance_inline.t b/t/cmop/instance_inline.t new file mode 100644 index 0000000..07f2162 --- /dev/null +++ b/t/cmop/instance_inline.t @@ -0,0 +1,46 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP::Instance; + +my $C = 'Class::MOP::Instance'; + +{ + my $instance = '$self'; + my $slot_name = 'foo'; + my $value = '$value'; + my $class = '$class'; + + is($C->inline_create_instance($class), + 'bless {} => $class', + '... got the right code for create_instance'); + is($C->inline_get_slot_value($instance, $slot_name), + q[$self->{"foo"}], + '... got the right code for get_slot_value'); + + is($C->inline_set_slot_value($instance, $slot_name, $value), + q[$self->{"foo"} = $value], + '... got the right code for set_slot_value'); + + is($C->inline_initialize_slot($instance, $slot_name), + '', + '... got the right code for initialize_slot'); + + is($C->inline_is_slot_initialized($instance, $slot_name), + q[exists $self->{"foo"}], + '... got the right code for get_slot_value'); + + is($C->inline_weaken_slot_value($instance, $slot_name), + q[Scalar::Util::weaken( $self->{"foo"} )], + '... got the right code for weaken_slot_value'); + + is($C->inline_strengthen_slot_value($instance, $slot_name), + q[$self->{"foo"} = $self->{"foo"}], + '... got the right code for strengthen_slot_value'); + is($C->inline_rebless_instance_structure($instance, $class), + q[bless $self => $class], + '... got the right code for rebless_instance_structure'); +} + +done_testing; diff --git a/t/cmop/instance_metaclass_incompat.t b/t/cmop/instance_metaclass_incompat.t new file mode 100644 index 0000000..43188d0 --- /dev/null +++ b/t/cmop/instance_metaclass_incompat.t @@ -0,0 +1,68 @@ +use strict; +use warnings; + +use Test::More; + +use metaclass; + +# meta classes +{ + package Foo::Meta::Instance; + use parent 'Class::MOP::Instance'; + + package Bar::Meta::Instance; + use parent 'Class::MOP::Instance'; + + package FooBar::Meta::Instance; + use parent -norequire => 'Foo::Meta::Instance', 'Bar::Meta::Instance'; +} + +$@ = undef; +eval { + package Foo; + BEGIN { $INC{'Foo.pm'} = __FILE__ } + metaclass->import('instance_metaclass' => 'Foo::Meta::Instance'); +}; +ok(!$@, '... Foo.meta => Foo::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package Bar; + BEGIN { $INC{'Bar.pm'} = __FILE__ } + metaclass->import('instance_metaclass' => 'Bar::Meta::Instance'); +}; +ok(!$@, '... Bar.meta => Bar::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package Foo::Foo; + use parent -norequire => 'Foo'; + metaclass->import('instance_metaclass' => 'Bar::Meta::Instance'); +}; +ok($@, '... Foo::Foo.meta => Bar::Meta is not compatible') || diag $@; + +$@ = undef; +eval { + package Bar::Bar; + use parent -norequire => 'Bar'; + metaclass->import('instance_metaclass' => 'Foo::Meta::Instance'); +}; +ok($@, '... Bar::Bar.meta => Foo::Meta is not compatible') || diag $@; + +$@ = undef; +eval { + package FooBar; + use parent -norequire => 'Foo'; + metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance'); +}; +ok(!$@, '... FooBar.meta => FooBar::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package FooBar2; + use parent -norequire => 'Bar'; + metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance'); +}; +ok(!$@, '... FooBar2.meta => FooBar::Meta is compatible') || diag $@; + +done_testing; diff --git a/t/cmop/instance_metaclass_incompat_dyn.t b/t/cmop/instance_metaclass_incompat_dyn.t new file mode 100644 index 0000000..b648f44 --- /dev/null +++ b/t/cmop/instance_metaclass_incompat_dyn.t @@ -0,0 +1,66 @@ +use strict; +use warnings; + +use Test::More; + +use metaclass; + +# meta classes +{ + package Foo::Meta::Instance; + use parent 'Class::MOP::Instance'; + + package Bar::Meta::Instance; + use parent 'Class::MOP::Instance'; + + package FooBar::Meta::Instance; + use parent -norequire => 'Foo::Meta::Instance', 'Bar::Meta::Instance'; +} + +$@ = undef; +eval { + package Foo; + metaclass->import('instance_metaclass' => 'Foo::Meta::Instance'); +}; +ok(!$@, '... Foo.meta => Foo::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package Bar; + metaclass->import('instance_metaclass' => 'Bar::Meta::Instance'); +}; +ok(!$@, '... Bar.meta => Bar::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package Foo::Foo; + metaclass->import('instance_metaclass' => 'Bar::Meta::Instance'); + Foo::Foo->meta->superclasses('Foo'); +}; +ok($@, '... Foo::Foo.meta => Bar::Meta is not compatible') || diag $@; + +$@ = undef; +eval { + package Bar::Bar; + metaclass->import('instance_metaclass' => 'Foo::Meta::Instance'); + Bar::Bar->meta->superclasses('Bar'); +}; +ok($@, '... Bar::Bar.meta => Foo::Meta is not compatible') || diag $@; + +$@ = undef; +eval { + package FooBar; + metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance'); + FooBar->meta->superclasses('Foo'); +}; +ok(!$@, '... FooBar.meta => FooBar::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package FooBar2; + metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance'); + FooBar2->meta->superclasses('Bar'); +}; +ok(!$@, '... FooBar2.meta => FooBar::Meta is compatible') || diag $@; + +done_testing; diff --git a/t/cmop/lib/ArrayBasedStorage.pm b/t/cmop/lib/ArrayBasedStorage.pm new file mode 100644 index 0000000..3d83a38 --- /dev/null +++ b/t/cmop/lib/ArrayBasedStorage.pm @@ -0,0 +1,132 @@ +package # hide the package from PAUSE + ArrayBasedStorage::Instance; + +use strict; +use warnings; +use Scalar::Util qw/refaddr/; + +use Carp 'confess'; + +our $VERSION = '0.01'; +my $unbound = \'empty-slot-value'; + +use parent 'Class::MOP::Instance'; + +sub new { + my ($class, $meta, @attrs) = @_; + my $self = $class->SUPER::new($meta, @attrs); + my $index = 0; + $self->{'slot_index_map'} = { map { $_ => $index++ } $self->get_all_slots }; + return $self; +} + +sub create_instance { + my $self = shift; + my $instance = bless [], $self->_class_name; + $self->initialize_all_slots($instance); + return $instance; +} + +sub clone_instance { + my ($self, $instance) = shift; + $self->bless_instance_structure([ @$instance ]); +} + +# operations on meta instance + +sub get_slot_index_map { (shift)->{'slot_index_map'} } + +sub initialize_slot { + my ($self, $instance, $slot_name) = @_; + $self->set_slot_value($instance, $slot_name, $unbound); +} + +sub deinitialize_slot { + my ( $self, $instance, $slot_name ) = @_; + $self->set_slot_value($instance, $slot_name, $unbound); +} + +sub get_all_slots { + my $self = shift; + return sort $self->SUPER::get_all_slots; +} + +sub get_slot_value { + my ($self, $instance, $slot_name) = @_; + my $value = $instance->[ $self->{'slot_index_map'}->{$slot_name} ]; + return $value unless ref $value; + refaddr $value eq refaddr $unbound ? undef : $value; +} + +sub set_slot_value { + my ($self, $instance, $slot_name, $value) = @_; + $instance->[ $self->{'slot_index_map'}->{$slot_name} ] = $value; +} + +sub is_slot_initialized { + my ($self, $instance, $slot_name) = @_; + # NOTE: maybe use CLOS's *special-unbound-value* for this? + my $value = $instance->[ $self->{'slot_index_map'}->{$slot_name} ]; + return 1 unless ref $value; + refaddr $value eq refaddr $unbound ? 0 : 1; +} + +sub is_dependent_on_superclasses { 1 } + +1; + +__END__ + +=pod + +=head1 NAME + +ArrayBasedStorage - An example of an Array based instance storage + +=head1 SYNOPSIS + + package Foo; + + use metaclass ( + ':instance_metaclass' => 'ArrayBasedStorage::Instance' + ); + + __PACKAGE__->meta->add_attribute('foo' => ( + reader => 'get_foo', + writer => 'set_foo' + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + # now you can just use the class as normal + +=head1 DESCRIPTION + +This is a proof of concept using the Instance sub-protocol +which uses ARRAY refs to store the instance data. + +This is very similar now to the InsideOutClass example, and +in fact, they both share the exact same test suite, with +the only difference being the Instance metaclass they use. + +=head1 AUTHORS + +Stevan Little E<lt>stevan@iinteractive.comE<gt> + +Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> + +=head1 SEE ALSO + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 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 diff --git a/t/cmop/lib/AttributesWithHistory.pm b/t/cmop/lib/AttributesWithHistory.pm new file mode 100644 index 0000000..4978c99 --- /dev/null +++ b/t/cmop/lib/AttributesWithHistory.pm @@ -0,0 +1,135 @@ +package # hide the package from PAUSE + AttributesWithHistory; + +use strict; +use warnings; + +our $VERSION = '0.05'; + +use parent 'Class::MOP::Attribute'; + +# this is for an extra attribute constructor +# option, which is to be able to create a +# way for the class to access the history +AttributesWithHistory->meta->add_attribute('history_accessor' => ( + reader => 'history_accessor', + init_arg => 'history_accessor', + predicate => 'has_history_accessor', +)); + +# this is a place to store the actual +# history of the attribute +AttributesWithHistory->meta->add_attribute('_history' => ( + accessor => '_history', + default => sub { {} }, +)); + +sub accessor_metaclass { 'AttributesWithHistory::Method::Accessor' } + +AttributesWithHistory->meta->add_after_method_modifier('install_accessors' => sub { + my ($self) = @_; + # and now add the history accessor + $self->associated_class->add_method( + $self->_process_accessors('history_accessor' => $self->history_accessor()) + ) if $self->has_history_accessor(); +}); + +package # hide the package from PAUSE + AttributesWithHistory::Method::Accessor; + +use strict; +use warnings; + +our $VERSION = '0.01'; + +use parent 'Class::MOP::Method::Accessor'; + +# generate the methods + +sub _generate_history_accessor_method { + my $attr_name = (shift)->associated_attribute->name; + eval qq{sub { + unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{ + \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = []; + \} + \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\}; + }}; +} + +sub _generate_accessor_method { + my $attr_name = (shift)->associated_attribute->name; + eval qq{sub { + if (scalar(\@_) == 2) { + unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{ + \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = []; + \} + push \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\} => \$_[1]; + \$_[0]->{'$attr_name'} = \$_[1]; + } + \$_[0]->{'$attr_name'}; + }}; +} + +sub _generate_writer_method { + my $attr_name = (shift)->associated_attribute->name; + eval qq{sub { + unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{ + \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = []; + \} + push \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\} => \$_[1]; + \$_[0]->{'$attr_name'} = \$_[1]; + }}; +} + +1; + +=pod + +=head1 NAME + +AttributesWithHistory - An example attribute metaclass which keeps a history of changes + +=head1 SYSNOPSIS + + package Foo; + + Foo->meta->add_attribute(AttributesWithHistory->new('foo' => ( + accessor => 'foo', + history_accessor => 'get_foo_history', + ))); + + Foo->meta->add_attribute(AttributesWithHistory->new('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + history_accessor => 'get_bar_history', + ))); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + +=head1 DESCRIPTION + +This is an example of an attribute metaclass which keeps a +record of all the values it has been assigned. It stores the +history as a field in the attribute meta-object, and will +autogenerate a means of accessing that history for the class +which these attributes are added too. + +=head1 AUTHORS + +Stevan Little E<lt>stevan@iinteractive.comE<gt> + +Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 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 diff --git a/t/cmop/lib/BinaryTree.pm b/t/cmop/lib/BinaryTree.pm new file mode 100644 index 0000000..9a10e2c --- /dev/null +++ b/t/cmop/lib/BinaryTree.pm @@ -0,0 +1,142 @@ +package BinaryTree; + +use strict; +use warnings; +use Carp qw/confess/; + +use metaclass; + +our $VERSION = '0.02'; + +BinaryTree->meta->add_attribute('uid' => ( + reader => 'getUID', + writer => 'setUID', + default => sub { + my $instance = shift; + ("$instance" =~ /\((.*?)\)$/)[0]; + } +)); + +BinaryTree->meta->add_attribute('node' => ( + reader => 'getNodeValue', + writer => 'setNodeValue', + clearer => 'clearNodeValue', + init_arg => ':node' +)); + +BinaryTree->meta->add_attribute('parent' => ( + predicate => 'hasParent', + reader => 'getParent', + writer => 'setParent', + clearer => 'clearParent', +)); + +BinaryTree->meta->add_attribute('left' => ( + predicate => 'hasLeft', + clearer => 'clearLeft', + reader => 'getLeft', + writer => { + 'setLeft' => sub { + my ($self, $tree) = @_; + confess "undef left" unless defined $tree; + $tree->setParent($self) if defined $tree; + $self->{'left'} = $tree; + $self; + } + }, +)); + +BinaryTree->meta->add_attribute('right' => ( + predicate => 'hasRight', + clearer => 'clearRight', + reader => 'getRight', + writer => { + 'setRight' => sub { + my ($self, $tree) = @_; + confess "undef right" unless defined $tree; + $tree->setParent($self) if defined $tree; + $self->{'right'} = $tree; + $self; + } + } +)); + +sub new { + my $class = shift; + $class->meta->new_object(':node' => shift); +} + +sub removeLeft { + my ($self) = @_; + my $left = $self->getLeft(); + $left->clearParent; + $self->clearLeft; + return $left; +} + +sub removeRight { + my ($self) = @_; + my $right = $self->getRight; + $right->clearParent; + $self->clearRight; + return $right; +} + +sub isLeaf { + my ($self) = @_; + return (!$self->hasLeft && !$self->hasRight); +} + +sub isRoot { + my ($self) = @_; + return !$self->hasParent; +} + +sub traverse { + my ($self, $func) = @_; + $func->($self); + $self->getLeft->traverse($func) if $self->hasLeft; + $self->getRight->traverse($func) if $self->hasRight; +} + +sub mirror { + my ($self) = @_; + # swap left for right + if( $self->hasLeft && $self->hasRight) { + my $left = $self->getLeft; + my $right = $self->getRight; + $self->setLeft($right); + $self->setRight($left); + } elsif( $self->hasLeft && !$self->hasRight){ + my $left = $self->getLeft; + $self->clearLeft; + $self->setRight($left); + } elsif( !$self->hasLeft && $self->hasRight){ + my $right = $self->getRight; + $self->clearRight; + $self->setLeft($right); + } + + # and recurse + $self->getLeft->mirror if $self->hasLeft; + $self->getRight->mirror if $self->hasRight; + $self; +} + +sub size { + my ($self) = @_; + my $size = 1; + $size += $self->getLeft->size if $self->hasLeft; + $size += $self->getRight->size if $self->hasRight; + return $size; +} + +sub height { + my ($self) = @_; + my ($left_height, $right_height) = (0, 0); + $left_height = $self->getLeft->height() if $self->hasLeft(); + $right_height = $self->getRight->height() if $self->hasRight(); + return 1 + (($left_height > $right_height) ? $left_height : $right_height); +} + +1; diff --git a/t/cmop/lib/C3MethodDispatchOrder.pm b/t/cmop/lib/C3MethodDispatchOrder.pm new file mode 100644 index 0000000..c156133 --- /dev/null +++ b/t/cmop/lib/C3MethodDispatchOrder.pm @@ -0,0 +1,145 @@ +package # hide from PAUSE + C3MethodDispatchOrder; + +use strict; +use warnings; + +use Carp 'confess'; +use Algorithm::C3; + +our $VERSION = '0.03'; + +use parent 'Class::MOP::Class'; + +my $_find_method = sub { + my ($class, $method) = @_; + foreach my $super ($class->class_precedence_list) { + return $super->meta->get_method($method) + if $super->meta->has_method($method); + } +}; + +C3MethodDispatchOrder->meta->add_around_method_modifier('initialize' => sub { + my $cont = shift; + my $meta = $cont->(@_); + + # we need to look at $AUTOLOAD in the package where the coderef belongs + # if subname works, then it'll be where this AUTOLOAD method was installed + # otherwise, it'll be $C3MethodDispatchOrder::AUTOLOAD. get_code_info + # tells us where AUTOLOAD will look + my $autoload; + $autoload = sub { + my ($package) = Class::MOP::get_code_info($autoload); + my $label = ${ $package->meta->get_package_symbol('$AUTOLOAD') }; + my $method_name = (split /\:\:/ => $label)[-1]; + my $method = $_find_method->($_[0]->meta, $method_name); + (defined $method) || confess "Method ($method_name) not found"; + goto &$method; + }; + + $meta->add_method('AUTOLOAD' => $autoload) + unless $meta->has_method('AUTOLOAD'); + + $meta->add_method('can' => sub { + $_find_method->($_[0]->meta, $_[1]); + }) unless $meta->has_method('can'); + + return $meta; +}); + +sub superclasses { + my $self = shift; + + $self->add_package_symbol('@SUPERS' => []) + unless $self->has_package_symbol('@SUPERS'); + + if (@_) { + my @supers = @_; + @{$self->get_package_symbol('@SUPERS')} = @supers; + } + @{$self->get_package_symbol('@SUPERS')}; +} + +sub class_precedence_list { + my $self = shift; + return map { + $_->name; + } Algorithm::C3::merge($self, sub { + my $class = shift; + map { $_->meta } $class->superclasses; + }); +} + +1; + +__END__ + +=pod + +=head1 NAME + +C3MethodDispatchOrder - An example attribute metaclass for changing to C3 method dispatch order + +=head1 SYNOPSIS + + # a classic diamond inheritence graph + # + # <A> + # / \ + # <B> <C> + # \ / + # <D> + + package A; + use metaclass 'C3MethodDispatchOrder'; + + sub hello { return "Hello from A" } + + package B; + use metaclass 'C3MethodDispatchOrder'; + B->meta->superclasses('A'); + + package C; + use metaclass 'C3MethodDispatchOrder'; + C->meta->superclasses('A'); + + sub hello { return "Hello from C" } + + package D; + use metaclass 'C3MethodDispatchOrder'; + D->meta->superclasses('B', 'C'); + + print join ", " => D->meta->class_precedence_list; # prints C3 order D, B, C, A + + # later in other code ... + + print D->hello; # print 'Hello from C' instead of the normal 'Hello from A' + +=head1 DESCRIPTION + +This is an example of how you could change the method dispatch order of a +class using L<Class::MOP>. Using the L<Algorithm::C3> module, this repleces +the normal depth-first left-to-right perl dispatch order with the C3 method +dispatch order (see the L<Algorithm::C3> or L<Class::C3> docs for more +information about this). + +This example could be used as a template for other method dispatch orders +as well, all that is required is to write a the C<class_precedence_list> method +which will return a linearized list of classes to dispatch along. + +=head1 AUTHORS + +Stevan Little E<lt>stevan@iinteractive.comE<gt> + +Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 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 diff --git a/t/cmop/lib/ClassEncapsulatedAttributes.pm b/t/cmop/lib/ClassEncapsulatedAttributes.pm new file mode 100644 index 0000000..5fb3a24 --- /dev/null +++ b/t/cmop/lib/ClassEncapsulatedAttributes.pm @@ -0,0 +1,150 @@ +package # hide the package from PAUSE + ClassEncapsulatedAttributes; + +use strict; +use warnings; + +our $VERSION = '0.06'; + +use parent 'Class::MOP::Class'; + +sub initialize { + (shift)->SUPER::initialize(@_, + # use the custom attribute metaclass here + 'attribute_metaclass' => 'ClassEncapsulatedAttributes::Attribute', + ); +} + +sub construct_instance { + my ($class, %params) = @_; + + my $meta_instance = $class->get_meta_instance; + my $instance = $meta_instance->create_instance(); + + # initialize *ALL* attributes, including masked ones (as opposed to applicable) + foreach my $current_class ($class->class_precedence_list()) { + my $meta = $current_class->meta; + foreach my $attr_name ($meta->get_attribute_list()) { + my $attr = $meta->get_attribute($attr_name); + $attr->initialize_instance_slot($meta_instance, $instance, \%params); + } + } + + return $instance; +} + +package # hide the package from PAUSE + ClassEncapsulatedAttributes::Attribute; + +use strict; +use warnings; + +our $VERSION = '0.04'; + +use parent 'Class::MOP::Attribute'; + +# alter the way parameters are specified +sub initialize_instance_slot { + my ($self, $meta_instance, $instance, $params) = @_; + # if the attr has an init_arg, use that, otherwise, + # use the attributes name itself as the init_arg + my $init_arg = $self->init_arg(); + # try to fetch the init arg from the %params ... + my $class = $self->associated_class; + my $val; + $val = $params->{$class->name}->{$init_arg} + if exists $params->{$class->name} && + exists ${$params->{$class->name}}{$init_arg}; + # if nothing was in the %params, we can use the + # attribute's default value (if it has one) + if (!defined $val && $self->has_default) { + $val = $self->default($instance); + } + + # now add this to the instance structure + $meta_instance->set_slot_value($instance, $self->name, $val); +} + +sub name { + my $self = shift; + return ($self->associated_class->name . '::' . $self->SUPER::name) +} + +1; + +__END__ + +=pod + +=head1 NAME + +ClassEncapsulatedAttributes - A set of example metaclasses with class encapsulated attributes + +=head1 SYNOPSIS + + package Foo; + + use metaclass 'ClassEncapsulatedAttributes'; + + Foo->meta->add_attribute('foo' => ( + accessor => 'Foo_foo', + default => 'init in FOO' + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + package Bar; + our @ISA = ('Foo'); + + # duplicate the attribute name here + Bar->meta->add_attribute('foo' => ( + accessor => 'Bar_foo', + default => 'init in BAR' + )); + + # ... later in other code ... + + my $bar = Bar->new(); + prints $bar->Bar_foo(); # init in BAR + prints $bar->Foo_foo(); # init in FOO + + # and ... + + my $bar = Bar->new( + 'Foo' => { 'foo' => 'Foo::foo' }, + 'Bar' => { 'foo' => 'Bar::foo' } + ); + + prints $bar->Bar_foo(); # Foo::foo + prints $bar->Foo_foo(); # Bar::foo + +=head1 DESCRIPTION + +This is an example metaclass which encapsulates a class's +attributes on a per-class basis. This means that there is no +possibility of name clashes with inherited attributes. This +is similar to how C++ handles its data members. + +=head1 ACKNOWLEDGEMENTS + +Thanks to Yuval "nothingmuch" Kogman for the idea for this example. + +=head1 AUTHORS + +Stevan Little E<lt>stevan@iinteractive.comE<gt> + +Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 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 diff --git a/t/cmop/lib/InsideOutClass.pm b/t/cmop/lib/InsideOutClass.pm new file mode 100644 index 0000000..94ec0c5 --- /dev/null +++ b/t/cmop/lib/InsideOutClass.pm @@ -0,0 +1,194 @@ +package # hide the package from PAUSE + InsideOutClass::Attribute; + +use strict; +use warnings; + +our $VERSION = '0.02'; + +use Carp 'confess'; +use Scalar::Util 'refaddr'; + +use parent 'Class::MOP::Attribute'; + +sub initialize_instance_slot { + my ($self, $meta_instance, $instance, $params) = @_; + my $init_arg = $self->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) + if (!defined $val && defined $self->default) { + $val = $self->default($instance); + } + my $_meta_instance = $self->associated_class->get_meta_instance; + $_meta_instance->initialize_slot($instance, $self->name); + $_meta_instance->set_slot_value($instance, $self->name, $val); +} + +sub accessor_metaclass { 'InsideOutClass::Method::Accessor' } + +package # hide the package from PAUSE + InsideOutClass::Method::Accessor; + +use strict; +use warnings; + +our $VERSION = '0.01'; + +use Carp 'confess'; +use Scalar::Util 'refaddr'; + +use parent 'Class::MOP::Method::Accessor'; + +## Method generation helpers + +sub _generate_accessor_method { + my $attr = (shift)->associated_attribute; + my $meta_class = $attr->associated_class; + my $attr_name = $attr->name; + return sub { + my $meta_instance = $meta_class->get_meta_instance; + $meta_instance->set_slot_value($_[0], $attr_name, $_[1]) if scalar(@_) == 2; + $meta_instance->get_slot_value($_[0], $attr_name); + }; +} + +sub _generate_reader_method { + my $attr = (shift)->associated_attribute; + my $meta_class = $attr->associated_class; + my $attr_name = $attr->name; + return sub { + confess "Cannot assign a value to a read-only accessor" if @_ > 1; + $meta_class->get_meta_instance + ->get_slot_value($_[0], $attr_name); + }; +} + +sub _generate_writer_method { + my $attr = (shift)->associated_attribute; + my $meta_class = $attr->associated_class; + my $attr_name = $attr->name; + return sub { + $meta_class->get_meta_instance + ->set_slot_value($_[0], $attr_name, $_[1]); + }; +} + +sub _generate_predicate_method { + my $attr = (shift)->associated_attribute; + my $meta_class = $attr->associated_class; + my $attr_name = $attr->name; + return sub { + defined $meta_class->get_meta_instance + ->get_slot_value($_[0], $attr_name) ? 1 : 0; + }; +} + +package # hide the package from PAUSE + InsideOutClass::Instance; + +use strict; +use warnings; + +our $VERSION = '0.01'; + +use Carp 'confess'; +use Scalar::Util 'refaddr'; + +use parent 'Class::MOP::Instance'; + +sub create_instance { + my ($self, $class) = @_; + bless \(my $instance), $self->_class_name; +} + +sub get_slot_value { + my ($self, $instance, $slot_name) = @_; + $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance}; +} + +sub set_slot_value { + my ($self, $instance, $slot_name, $value) = @_; + $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} = $value; +} + +sub initialize_slot { + my ($self, $instance, $slot_name) = @_; + $self->associated_metaclass->add_package_symbol(('%' . $slot_name) => {}) + unless $self->associated_metaclass->has_package_symbol('%' . $slot_name); + $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} = undef; +} + +sub is_slot_initialized { + my ($self, $instance, $slot_name) = @_; + return 0 unless $self->associated_metaclass->has_package_symbol('%' . $slot_name); + return exists $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} ? 1 : 0; +} + +1; + +__END__ + +=pod + +=head1 NAME + +InsideOutClass - A set of example metaclasses which implement the Inside-Out technique + +=head1 SYNOPSIS + + package Foo; + + use metaclass ( + ':attribute_metaclass' => 'InsideOutClass::Attribute', + ':instance_metaclass' => 'InsideOutClass::Instance' + ); + + __PACKAGE__->meta->add_attribute('foo' => ( + reader => 'get_foo', + writer => 'set_foo' + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + # now you can just use the class as normal + +=head1 DESCRIPTION + +This is a set of example metaclasses which implement the Inside-Out +class technique. What follows is a brief explaination of the code +found in this module. + +We must create a subclass of B<Class::MOP::Instance> and override +the slot operations. This requires +overloading C<get_slot_value>, C<set_slot_value>, C<slot_initialized>, and +C<initialize_slot>, as well as their inline counterparts. Additionally we +overload C<add_slot> in order to initialize the global hash containing the +actual slot values. + +And that is pretty much all. Of course I am ignoring need for +inside-out objects to be C<DESTROY>-ed, and some other details as +well (threading, etc), but this is an example. A real implementation is left as +an exercise to the reader. + +=head1 AUTHORS + +Stevan Little E<lt>stevan@iinteractive.comE<gt> + +Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 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 diff --git a/t/cmop/lib/InstanceCountingClass.pm b/t/cmop/lib/InstanceCountingClass.pm new file mode 100644 index 0000000..35053fe --- /dev/null +++ b/t/cmop/lib/InstanceCountingClass.pm @@ -0,0 +1,72 @@ +package # hide the package from PAUSE + InstanceCountingClass; + +use strict; +use warnings; + +our $VERSION = '0.03'; + +use parent 'Class::MOP::Class'; + +InstanceCountingClass->meta->add_attribute('count' => ( + reader => 'get_count', + default => 0 +)); + +InstanceCountingClass->meta->add_before_method_modifier('_construct_instance' => sub { + my ($class) = @_; + $class->{'count'}++; +}); + +1; + +__END__ + +=pod + +=head1 NAME + +InstanceCountingClass - An example metaclass which counts instances + +=head1 SYNOPSIS + + package Foo; + + use metaclass 'InstanceCountingClass'; + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + # ... meanwhile, somewhere in the code + + my $foo = Foo->new(); + print Foo->meta->get_count(); # prints 1 + + my $foo2 = Foo->new(); + print Foo->meta->get_count(); # prints 2 + + # ... etc etc etc + +=head1 DESCRIPTION + +This is a classic example of a metaclass which keeps a count of each +instance which is created. + +=head1 AUTHORS + +Stevan Little E<lt>stevan@iinteractive.comE<gt> + +Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 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 diff --git a/t/cmop/lib/LazyClass.pm b/t/cmop/lib/LazyClass.pm new file mode 100644 index 0000000..1a2dc13 --- /dev/null +++ b/t/cmop/lib/LazyClass.pm @@ -0,0 +1,162 @@ +package # hide the package from PAUSE + LazyClass::Attribute; + +use strict; +use warnings; + +use Carp 'confess'; + +our $VERSION = '0.05'; + +use parent 'Class::MOP::Attribute'; + +sub initialize_instance_slot { + my ($self, $meta_instance, $instance, $params) = @_; + + # if the attr has an init_arg, use that, otherwise, + # use the attributes name itself as the init_arg + my $init_arg = $self->init_arg(); + + if ( exists $params->{$init_arg} ) { + my $val = $params->{$init_arg}; + $meta_instance->set_slot_value($instance, $self->name, $val); + } +} + +sub accessor_metaclass { 'LazyClass::Method::Accessor' } + +package # hide the package from PAUSE + LazyClass::Method::Accessor; + +use strict; +use warnings; + +use Carp 'confess'; + +our $VERSION = '0.01'; + +use parent 'Class::MOP::Method::Accessor'; + +sub _generate_accessor_method { + my $attr = (shift)->associated_attribute; + + my $attr_name = $attr->name; + my $meta_instance = $attr->associated_class->get_meta_instance; + + sub { + if (scalar(@_) == 2) { + $meta_instance->set_slot_value($_[0], $attr_name, $_[1]); + } + else { + unless ( $meta_instance->is_slot_initialized($_[0], $attr_name) ) { + my $value = $attr->has_default ? $attr->default($_[0]) : undef; + $meta_instance->set_slot_value($_[0], $attr_name, $value); + } + + $meta_instance->get_slot_value($_[0], $attr_name); + } + }; +} + +sub _generate_reader_method { + my $attr = (shift)->associated_attribute; + + my $attr_name = $attr->name; + my $meta_instance = $attr->associated_class->get_meta_instance; + + sub { + confess "Cannot assign a value to a read-only accessor" if @_ > 1; + + unless ( $meta_instance->is_slot_initialized($_[0], $attr_name) ) { + my $value = $attr->has_default ? $attr->default($_[0]) : undef; + $meta_instance->set_slot_value($_[0], $attr_name, $value); + } + + $meta_instance->get_slot_value($_[0], $attr_name); + }; +} + +package # hide the package from PAUSE + LazyClass::Instance; + +use strict; +use warnings; + +our $VERSION = '0.01'; + +use parent 'Class::MOP::Instance'; + +sub initialize_all_slots {} + +1; + +__END__ + +=pod + +=head1 NAME + +LazyClass - An example metaclass with lazy initialization + +=head1 SYNOPSIS + + package BinaryTree; + + use metaclass ( + ':attribute_metaclass' => 'LazyClass::Attribute', + ':instance_metaclass' => 'LazyClass::Instance', + ); + + BinaryTree->meta->add_attribute('node' => ( + accessor => 'node', + init_arg => ':node' + )); + + BinaryTree->meta->add_attribute('left' => ( + reader => 'left', + default => sub { BinaryTree->new() } + )); + + BinaryTree->meta->add_attribute('right' => ( + reader => 'right', + default => sub { BinaryTree->new() } + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + # ... later in code + + my $btree = BinaryTree->new(); + # ... $btree is an empty hash, no keys are initialized yet + +=head1 DESCRIPTION + +This is an example metclass in which all attributes are created +lazily. This means that no entries are made in the instance HASH +until the last possible moment. + +The example above of a binary tree is a good use for such a +metaclass because it allows the class to be space efficient +without complicating the programing of it. This would also be +ideal for a class which has a large amount of attributes, +several of which are optional. + +=head1 AUTHORS + +Stevan Little E<lt>stevan@iinteractive.comE<gt> + +Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 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 diff --git a/t/cmop/lib/MyMetaClass.pm b/t/cmop/lib/MyMetaClass.pm new file mode 100644 index 0000000..ade02e5 --- /dev/null +++ b/t/cmop/lib/MyMetaClass.pm @@ -0,0 +1,14 @@ +package MyMetaClass; + +use strict; +use warnings; + +use parent 'Class::MOP::Class'; + +sub mymetaclass_attributes{ + my $self = shift; + return grep { $_->isa("MyMetaClass::Attribute") } + $self->get_all_attributes; +} + +1; diff --git a/t/cmop/lib/MyMetaClass/Attribute.pm b/t/cmop/lib/MyMetaClass/Attribute.pm new file mode 100644 index 0000000..c187e9a --- /dev/null +++ b/t/cmop/lib/MyMetaClass/Attribute.pm @@ -0,0 +1,8 @@ +package MyMetaClass::Attribute; + +use strict; +use warnings; + +use parent 'Class::MOP::Attribute'; + +1; diff --git a/t/cmop/lib/MyMetaClass/Instance.pm b/t/cmop/lib/MyMetaClass/Instance.pm new file mode 100644 index 0000000..5383c4a --- /dev/null +++ b/t/cmop/lib/MyMetaClass/Instance.pm @@ -0,0 +1,8 @@ +package MyMetaClass::Instance; + +use strict; +use warnings; + +use parent 'Class::MOP::Instance'; + +1; diff --git a/t/cmop/lib/MyMetaClass/Method.pm b/t/cmop/lib/MyMetaClass/Method.pm new file mode 100644 index 0000000..072d49d --- /dev/null +++ b/t/cmop/lib/MyMetaClass/Method.pm @@ -0,0 +1,8 @@ +package MyMetaClass::Method; + +use strict; +use warnings; + +use parent 'Class::MOP::Method'; + +1; diff --git a/t/cmop/lib/MyMetaClass/Random.pm b/t/cmop/lib/MyMetaClass/Random.pm new file mode 100644 index 0000000..1c79b7b --- /dev/null +++ b/t/cmop/lib/MyMetaClass/Random.pm @@ -0,0 +1,6 @@ +package MyMetaClass::Random; + +use strict; +use warnings; + +1; diff --git a/t/cmop/lib/Perl6Attribute.pm b/t/cmop/lib/Perl6Attribute.pm new file mode 100644 index 0000000..420ef30 --- /dev/null +++ b/t/cmop/lib/Perl6Attribute.pm @@ -0,0 +1,82 @@ +package # hide the package from PAUSE + Perl6Attribute; + +use strict; +use warnings; + +our $VERSION = '0.02'; + +use parent 'Class::MOP::Attribute'; + +Perl6Attribute->meta->add_around_method_modifier('new' => sub { + my $cont = shift; + my ($class, $attribute_name, %options) = @_; + + # extract the sigil and accessor name + my ($sigil, $accessor_name) = ($attribute_name =~ /^([\$\@\%])\.(.*)$/); + + # pass the accessor name + $options{accessor} = $accessor_name; + + # create a default value based on the sigil + $options{default} = sub { [] } if ($sigil eq '@'); + $options{default} = sub { {} } if ($sigil eq '%'); + + $cont->($class, $attribute_name, %options); +}); + +1; + +__END__ + +=pod + +=head1 NAME + +Perl6Attribute - An example attribute metaclass for Perl 6 style attributes + +=head1 SYNOPSIS + + package Foo; + + Foo->meta->add_attribute(Perl6Attribute->new('$.foo')); + Foo->meta->add_attribute(Perl6Attribute->new('@.bar')); + Foo->meta->add_attribute(Perl6Attribute->new('%.baz')); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + +=head1 DESCRIPTION + +This is an attribute metaclass which implements Perl 6 style +attributes, including the auto-generating accessors. + +This code is very simple, we only need to subclass +C<Class::MOP::Attribute> and override C<&new>. Then we just +pre-process the attribute name, and create the accessor name +and default value based on it. + +More advanced features like the C<handles> trait (see +L<Perl6::Bible/A12>) can be accomplished as well doing the +same pre-processing approach. This is left as an exercise to +the reader though (if you do it, please send me a patch +though, and will update this). + +=head1 AUTHORS + +Stevan Little E<lt>stevan@iinteractive.comE<gt> + +Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 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 diff --git a/t/cmop/lib/SyntaxError.pm b/t/cmop/lib/SyntaxError.pm new file mode 100644 index 0000000..ab41f14 --- /dev/null +++ b/t/cmop/lib/SyntaxError.pm @@ -0,0 +1,9 @@ +package SyntaxError; +use strict; +use warnings; + +# this syntax error is intentional! + + { + +1; diff --git a/t/cmop/load.t b/t/cmop/load.t new file mode 100644 index 0000000..72f9bb7 --- /dev/null +++ b/t/cmop/load.t @@ -0,0 +1,176 @@ +use strict; +use warnings; + +# for instance, App::ForkProve +my $preloaded; +BEGIN { $preloaded = exists $INC{'Class/MOP.pm'} } + +use Test::More; + +use Class::Load qw(is_class_loaded); + +BEGIN { + use_ok('Class::MOP'); + use_ok('Class::MOP::Mixin'); + use_ok('Class::MOP::Mixin::AttributeCore'); + use_ok('Class::MOP::Mixin::HasAttributes'); + use_ok('Class::MOP::Mixin::HasMethods'); + use_ok('Class::MOP::Mixin::HasOverloads'); + use_ok('Class::MOP::Package'); + use_ok('Class::MOP::Module'); + use_ok('Class::MOP::Class'); + use_ok('Class::MOP::Class::Immutable::Trait'); + use_ok('Class::MOP::Method'); + use_ok('Class::MOP::Method'); + use_ok('Class::MOP::Method::Wrapped'); + use_ok('Class::MOP::Method::Inlined'); + use_ok('Class::MOP::Method::Generated'); + use_ok('Class::MOP::Method::Accessor'); + use_ok('Class::MOP::Method::Constructor'); + use_ok('Class::MOP::Method::Meta'); + use_ok('Class::MOP::Instance'); + use_ok('Class::MOP::Object'); + use_ok('Class::MOP::Overload'); +} + +# make sure we are tracking metaclasses correctly + +my %METAS = ( + 'Class::MOP::Attribute' => Class::MOP::Attribute->meta, + 'Class::MOP::Method::Inlined' => Class::MOP::Method::Inlined->meta, + 'Class::MOP::Method::Generated' => Class::MOP::Method::Generated->meta, + 'Class::MOP::Method::Accessor' => Class::MOP::Method::Accessor->meta, + 'Class::MOP::Method::Constructor' => Class::MOP::Method::Constructor->meta, + 'Class::MOP::Method::Meta' => Class::MOP::Method::Meta->meta, + 'Class::MOP::Mixin' => Class::MOP::Mixin->meta, + 'Class::MOP::Mixin::AttributeCore' => Class::MOP::Mixin::AttributeCore->meta, + 'Class::MOP::Mixin::HasAttributes' => Class::MOP::Mixin::HasAttributes->meta, + 'Class::MOP::Mixin::HasMethods' => Class::MOP::Mixin::HasMethods->meta, + 'Class::MOP::Mixin::HasOverloads' => Class::MOP::Mixin::HasOverloads->meta, + 'Class::MOP::Package' => Class::MOP::Package->meta, + 'Class::MOP::Module' => Class::MOP::Module->meta, + 'Class::MOP::Class' => Class::MOP::Class->meta, + 'Class::MOP::Method' => Class::MOP::Method->meta, + 'Class::MOP::Method::Wrapped' => Class::MOP::Method::Wrapped->meta, + 'Class::MOP::Instance' => Class::MOP::Instance->meta, + 'Class::MOP::Object' => Class::MOP::Object->meta, + 'Class::MOP::Overload' => Class::MOP::Overload->meta, + 'Class::MOP::Class::Immutable::Trait' => Class::MOP::class_of('Class::MOP::Class::Immutable::Trait'), + 'Class::MOP::Class::Immutable::Class::MOP::Class' => Class::MOP::Class::Immutable::Class::MOP::Class->meta, + 'UNIVERSAL' => Class::MOP::class_of('UNIVERSAL'), +); + +ok( is_class_loaded($_), '... ' . $_ . ' is loaded' ) + for sort keys %METAS; + +# The trait shouldn't be made immutable, it doesn't actually do anything, and +# it doesn't even matter because it's not a class that will be +# instantiated. Making UNIVERSAL immutable just seems like a bad idea. +my %expect_mutable = map { $_ => 1 } qw( Class::MOP::Class::Immutable::Trait UNIVERSAL ); + +for my $meta (values %METAS) { + if ( $expect_mutable{$meta->name} ) { + ok( $meta->is_mutable(), '... ' . $meta->name . ' is mutable' ); + } + else { + ok( $meta->is_immutable(), '... ' . $meta->name . ' is immutable' ); + } +} + +SKIP: { + skip "this list may be incorrect if we preloaded things", 3 if $preloaded; + is_deeply( + {Class::MOP::get_all_metaclasses}, + \%METAS, + '... got all the metaclasses' + ); + + is_deeply( + [ + sort { $a->name cmp $b->name } + Class::MOP::get_all_metaclass_instances + ], + [ + Class::MOP::Attribute->meta, + Class::MOP::Class->meta, + Class::MOP::Class::Immutable::Class::MOP::Class->meta, + Class::MOP::class_of('Class::MOP::Class::Immutable::Trait'), + Class::MOP::Instance->meta, + Class::MOP::Method->meta, + Class::MOP::Method::Accessor->meta, + Class::MOP::Method::Constructor->meta, + Class::MOP::Method::Generated->meta, + Class::MOP::Method::Inlined->meta, + Class::MOP::Method::Meta->meta, + Class::MOP::Method::Wrapped->meta, + Class::MOP::Mixin->meta, + Class::MOP::Mixin::AttributeCore->meta, + Class::MOP::Mixin::HasAttributes->meta, + Class::MOP::Mixin::HasMethods->meta, + Class::MOP::Mixin::HasOverloads->meta, + Class::MOP::Module->meta, + Class::MOP::Object->meta, + Class::MOP::Overload->meta, + Class::MOP::Package->meta, + Class::MOP::class_of('UNIVERSAL'), + ], + '... got all the metaclass instances' + ); + + is_deeply( + [ sort { $a cmp $b } Class::MOP::get_all_metaclass_names() ], + [ + sort qw/ + Class::MOP::Attribute + Class::MOP::Class + Class::MOP::Class::Immutable::Class::MOP::Class + Class::MOP::Class::Immutable::Trait + Class::MOP::Mixin + Class::MOP::Mixin::AttributeCore + Class::MOP::Mixin::HasAttributes + Class::MOP::Mixin::HasMethods + Class::MOP::Mixin::HasOverloads + Class::MOP::Instance + Class::MOP::Method + Class::MOP::Method::Accessor + Class::MOP::Method::Constructor + Class::MOP::Method::Generated + Class::MOP::Method::Inlined + Class::MOP::Method::Wrapped + Class::MOP::Method::Meta + Class::MOP::Module + Class::MOP::Object + Class::MOP::Overload + Class::MOP::Package + UNIVERSAL + /, + ], + '... got all the metaclass names' + ); +} + +# testing the meta-circularity of the system + +is( + Class::MOP::Class->meta->meta, Class::MOP::Class->meta->meta->meta, + '... Class::MOP::Class->meta->meta == Class::MOP::Class->meta->meta->meta' +); + +is( + Class::MOP::Class->meta->meta->meta, Class::MOP::Class->meta->meta->meta->meta, + '... Class::MOP::Class->meta->meta->meta == Class::MOP::Class->meta->meta->meta->meta' +); + +is( + Class::MOP::Class->meta->meta, Class::MOP::Class->meta->meta->meta->meta, + '... Class::MOP::Class->meta->meta == Class::MOP::Class->meta->meta->meta->meta' +); + +is( + Class::MOP::Class->meta->meta, Class::MOP::Class->meta->meta->meta->meta->meta, + '... Class::MOP::Class->meta->meta == Class::MOP::Class->meta->meta->meta->meta->meta' +); + +isa_ok(Class::MOP::Class->meta, 'Class::MOP::Class'); + +done_testing; diff --git a/t/cmop/magic.t b/t/cmop/magic.t new file mode 100644 index 0000000..bfb9dba --- /dev/null +++ b/t/cmop/magic.t @@ -0,0 +1,76 @@ +use strict; +use warnings; + +# Testing magical scalars (using tied scalar) +# Note that XSUBs do not handle magical scalars automatically. + +use Test::More; +use Test::Fatal; + +use Class::Load qw( is_class_loaded load_class ); +use Class::MOP; + +use Tie::Scalar; + +{ + package Foo; + use metaclass; + + Foo->meta->add_attribute('bar' => + reader => 'get_bar', + writer => 'set_bar', + ); + + Foo->meta->add_attribute('baz' => + accessor => 'baz', + ); + + Foo->meta->make_immutable(); +} + +{ + tie my $foo, 'Tie::StdScalar', Foo->new(bar => 100, baz => 200); + + is $foo->get_bar, 100, 'reader with tied self'; + is $foo->baz, 200, 'accessor/r with tied self'; + + $foo->set_bar(300); + $foo->baz(400); + + is $foo->get_bar, 300, 'writer with tied self'; + is $foo->baz, 400, 'accessor/w with tied self'; +} + +{ + my $foo = Foo->new(); + + tie my $value, 'Tie::StdScalar', 42; + + $foo->set_bar($value); + $foo->baz($value); + + is $foo->get_bar, 42, 'reader/writer with tied value'; + is $foo->baz, 42, 'accessor with tied value'; +} + +{ + my $x = tie my $value, 'Tie::StdScalar', 'Class::MOP'; + + is( exception { load_class($value) }, undef, 'load_class(tied scalar)' ); + + $value = undef; + $x->STORE('Class::MOP'); # reset + + is( exception { + ok is_class_loaded($value); + }, undef, 'is_class_loaded(tied scalar)' ); + + $value = undef; + $x->STORE(\&Class::MOP::get_code_info); # reset + + is( exception { + is_deeply [Class::MOP::get_code_info($value)], [qw(Class::MOP get_code_info)], 'get_code_info(tied scalar)'; + }, undef ); +} + +done_testing; diff --git a/t/cmop/make_mutable.t b/t/cmop/make_mutable.t new file mode 100644 index 0000000..cf30738 --- /dev/null +++ b/t/cmop/make_mutable.t @@ -0,0 +1,220 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Scalar::Util; + +use Class::MOP; + +{ + package Foo; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->add_attribute('bar'); + + package Bar; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Foo'); + + __PACKAGE__->meta->add_attribute('baz'); + + package Baz; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Bar'); + + __PACKAGE__->meta->add_attribute('bah'); +} + +{ + my $meta = Baz->meta; + is($meta->name, 'Baz', '... checking the Baz metaclass'); + my %orig_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; + # Since this has no default it won't be present yet, but it will + # be after the class is made immutable. + + is( exception {$meta->make_immutable; }, undef, '... changed Baz to be immutable' ); + ok(!$meta->is_mutable, '... our class is no longer mutable'); + ok($meta->is_immutable, '... our class is now immutable'); + ok($meta->make_immutable, '... make immutable returns true'); + ok($meta->get_method('new'), '... inlined constructor created'); + ok($meta->has_method('new'), '... inlined constructor created for sure'); + is_deeply([ map { $_->name } $meta->_inlined_methods ], [ 'new' ], '... really, i mean it'); + + is( exception { $meta->make_mutable; }, undef, '... changed Baz to be mutable' ); + ok($meta->is_mutable, '... our class is mutable'); + ok(!$meta->is_immutable, '... our class is not immutable'); + ok(!$meta->make_mutable, '... make mutable now returns nothing'); + ok(!$meta->get_method('new'), '... inlined constructor created'); + ok(!$meta->has_method('new'), '... inlined constructor removed for sure'); + + my %new_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; + is_deeply(\%orig_keys, \%new_keys, '... no extraneous hashkeys'); + + isa_ok($meta, 'Class::MOP::Class', '... Baz->meta isa Class::MOP::Class'); + + $meta->add_method('xyz', sub{'xxx'}); + is( Baz->xyz, 'xxx', '... method xyz works'); + + ok($meta->add_attribute('fickle', accessor => 'fickle'), '... added attribute'); + ok(Baz->can('fickle'), '... Baz can fickle'); + ok($meta->remove_attribute('fickle'), '... removed attribute'); + + my $reef = \ 'reef'; + $meta->add_package_symbol('$ref', $reef); + is($meta->get_package_symbol('$ref'), $reef, '... values match'); + is( exception { $meta->remove_package_symbol('$ref') }, undef, '... removed it' ); + isnt($meta->get_package_symbol('$ref'), $reef, '... values match'); + + ok( my @supers = $meta->superclasses, '... got the superclasses okay'); + ok( $meta->superclasses('Foo'), '... set the superclasses'); + is_deeply(['Foo'], [$meta->superclasses], '... set the superclasses okay'); + ok( $meta->superclasses( @supers ), '... reset superclasses'); + is_deeply([@supers], [$meta->superclasses], '... reset the superclasses okay'); + + ok( $meta->$_ , "... ${_} works") + for qw(get_meta_instance get_all_attributes + class_precedence_list ); + + is( exception {$meta->make_immutable; }, undef, '... changed Baz to be immutable again' ); + ok($meta->get_method('new'), '... inlined constructor recreated'); +} + +{ + my $meta = Baz->meta; + + is( exception { $meta->make_immutable() }, undef, 'Changed Baz to be immutable' ); + is( exception { $meta->make_mutable() }, undef, '... changed Baz to be mutable' ); + is( exception { $meta->make_immutable() }, undef, '... changed Baz to be immutable' ); + + isnt( exception { $meta->add_method('xyz', sub{'xxx'}) }, undef, '... exception thrown as expected' ); + + isnt( exception { + $meta->add_attribute('fickle', accessor => 'fickle') + }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_attribute('fickle') }, undef, '... exception thrown as expected' ); + + my $reef = \ 'reef'; + isnt( exception { $meta->add_package_symbol('$ref', $reef) }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_package_symbol('$ref') }, undef, '... exception thrown as expected' ); + + ok( my @supers = $meta->superclasses, '... got the superclasses okay'); + isnt( exception { $meta->superclasses('Foo') }, undef, '... set the superclasses' ); + + ok( $meta->$_ , "... ${_} works") + for qw(get_meta_instance get_all_attributes + class_precedence_list ); +} + +{ + + ok(Baz->meta->is_immutable, 'Superclass is immutable'); + my $meta = Baz->meta->create_anon_class(superclasses => ['Baz']); + my %orig_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; + my @orig_meths = sort { $a->name cmp $b->name } $meta->get_all_methods; + ok($meta->is_anon_class, 'We have an anon metaclass'); + ok($meta->is_mutable, '... our anon class is mutable'); + ok(!$meta->is_immutable, '... our anon class is not immutable'); + + is( exception {$meta->make_immutable( + inline_accessor => 1, + inline_destructor => 0, + inline_constructor => 1, + ) + }, undef, '... changed class to be immutable' ); + ok(!$meta->is_mutable, '... our class is no longer mutable'); + ok($meta->is_immutable, '... our class is now immutable'); + ok($meta->make_immutable, '... make immutable returns true'); + + is( exception { $meta->make_mutable }, undef, '... changed Baz to be mutable' ); + ok($meta->is_mutable, '... our class is mutable'); + ok(!$meta->is_immutable, '... our class is not immutable'); + ok(!$meta->make_mutable, '... make mutable now returns nothing'); + ok($meta->is_anon_class, '... still marked as an anon class'); + my $instance = $meta->new_object; + + my %new_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; + my @new_meths = sort { $a->name cmp $b->name } + $meta->get_all_methods; + is_deeply(\%orig_keys, \%new_keys, '... no extraneous hashkeys'); + is_deeply(\@orig_meths, \@new_meths, '... no straneous methods'); + + isa_ok($meta, 'Class::MOP::Class', '... Anon class isa Class::MOP::Class'); + + $meta->add_method('xyz', sub{'xxx'}); + is( $instance->xyz , 'xxx', '... method xyz works'); + ok( $meta->remove_method('xyz'), '... removed method'); + + ok($meta->add_attribute('fickle', accessor => 'fickle'), '... added attribute'); + ok($instance->can('fickle'), '... instance can fickle'); + ok($meta->remove_attribute('fickle'), '... removed attribute'); + + my $reef = \ 'reef'; + $meta->add_package_symbol('$ref', $reef); + is($meta->get_package_symbol('$ref'), $reef, '... values match'); + is( exception { $meta->remove_package_symbol('$ref') }, undef, '... removed it' ); + isnt($meta->get_package_symbol('$ref'), $reef, '... values match'); + + ok( my @supers = $meta->superclasses, '... got the superclasses okay'); + ok( $meta->superclasses('Foo'), '... set the superclasses'); + is_deeply(['Foo'], [$meta->superclasses], '... set the superclasses okay'); + ok( $meta->superclasses( @supers ), '... reset superclasses'); + is_deeply([@supers], [$meta->superclasses], '... reset the superclasses okay'); + + ok( $meta->$_ , "... ${_} works") + for qw(get_meta_instance get_all_attributes + class_precedence_list ); +}; + + +#rerun the same tests on an anon class.. just cause we can. +{ + my $meta = Baz->meta->create_anon_class(superclasses => ['Baz']); + + is( exception {$meta->make_immutable( + inline_accessor => 1, + inline_destructor => 0, + inline_constructor => 1, + ) + }, undef, '... changed class to be immutable' ); + is( exception { $meta->make_mutable() }, undef, '... changed class to be mutable' ); + is( exception {$meta->make_immutable }, undef, '... changed class to be immutable' ); + + isnt( exception { $meta->add_method('xyz', sub{'xxx'}) }, undef, '... exception thrown as expected' ); + + isnt( exception { + $meta->add_attribute('fickle', accessor => 'fickle') + }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_attribute('fickle') }, undef, '... exception thrown as expected' ); + + my $reef = \ 'reef'; + isnt( exception { $meta->add_package_symbol('$ref', $reef) }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_package_symbol('$ref') }, undef, '... exception thrown as expected' ); + + ok( my @supers = $meta->superclasses, '... got the superclasses okay'); + isnt( exception { $meta->superclasses('Foo') }, undef, '... set the superclasses' ); + + ok( $meta->$_ , "... ${_} works") + for qw(get_meta_instance get_all_attributes + class_precedence_list ); +} + +{ + Foo->meta->make_immutable; + Bar->meta->make_immutable; + Bar->meta->make_mutable; +} + +done_testing; diff --git a/t/cmop/meta_method.t b/t/cmop/meta_method.t new file mode 100644 index 0000000..de65543 --- /dev/null +++ b/t/cmop/meta_method.t @@ -0,0 +1,66 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; +use Class::MOP; + +{ + can_ok('Class::MOP::Class', 'meta'); + isa_ok(Class::MOP::Class->meta->find_method_by_name('meta'), + 'Class::MOP::Method::Meta'); + + { + package Baz; + use metaclass; + } + can_ok('Baz', 'meta'); + isa_ok(Baz->meta->find_method_by_name('meta'), + 'Class::MOP::Method::Meta'); + + my $meta = Class::MOP::Class->create('Quux'); + can_ok('Quux', 'meta'); + isa_ok(Quux->meta->find_method_by_name('meta'), + 'Class::MOP::Method::Meta'); +} + +{ + { + package Blarg; + use metaclass meta_name => 'blarg'; + } + ok(!Blarg->can('meta')); + can_ok('Blarg', 'blarg'); + isa_ok(Blarg->blarg->find_method_by_name('blarg'), + 'Class::MOP::Method::Meta'); + + my $meta = Class::MOP::Class->create('Blorg', meta_name => 'blorg'); + ok(!Blorg->can('meta')); + can_ok('Blorg', 'blorg'); + isa_ok(Blorg->blorg->find_method_by_name('blorg'), + 'Class::MOP::Method::Meta'); +} + +{ + { + package Foo; + use metaclass meta_name => undef; + } + + my $meta = Class::MOP::class_of('Foo'); + ok(!$meta->has_method('meta'), "no meta method was installed"); + $meta->add_method(meta => sub { die 'META' }); + is( exception { $meta->find_method_by_name('meta') }, undef, "can do meta-level stuff" ); + is( exception { $meta->make_immutable }, undef, "can do meta-level stuff" ); + is( exception { $meta->class_precedence_list }, undef, "can do meta-level stuff" ); +} + +{ + my $meta = Class::MOP::Class->create('Bar', meta_name => undef); + ok(!$meta->has_method('meta'), "no meta method was installed"); + $meta->add_method(meta => sub { die 'META' }); + is( exception { $meta->find_method_by_name('meta') }, undef, "can do meta-level stuff" ); + is( exception { $meta->make_immutable }, undef, "can do meta-level stuff" ); + is( exception { $meta->class_precedence_list }, undef, "can do meta-level stuff" ); +} + +done_testing; diff --git a/t/cmop/meta_package.t b/t/cmop/meta_package.t new file mode 100644 index 0000000..8e7f76e --- /dev/null +++ b/t/cmop/meta_package.t @@ -0,0 +1,280 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; +use Class::MOP::Package; + + +isnt( exception { Class::MOP::Package->get_all_package_symbols }, undef, q{... can't call get_all_package_symbols() as a class method} ); +isnt( exception { Class::MOP::Package->name }, undef, q{... can't call name() as a class method} ); + +{ + package Foo; + + use constant SOME_CONSTANT => 1; + + sub meta { Class::MOP::Package->initialize('Foo') } +} + +# ---------------------------------------------------------------------- +## tests adding a HASH + +ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); +ok(!Foo->meta->has_package_symbol('%foo'), '... the meta agrees'); +ok(!defined($Foo::{foo}), '... checking doesn\' vivify'); + +is( exception { + Foo->meta->add_package_symbol('%foo' => { one => 1 }); +}, undef, '... created %Foo::foo successfully' ); + +# ... scalar should NOT be created here + +ok(!Foo->meta->has_package_symbol('$foo'), '... SCALAR shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('@foo'), '... ARRAY shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('&foo'), '... CODE shouldnt have been created too'); + +ok(defined($Foo::{foo}), '... the %foo slot was created successfully'); +ok(Foo->meta->has_package_symbol('%foo'), '... the meta agrees'); + +# check the value ... + +{ + no strict 'refs'; + ok(exists ${'Foo::foo'}{one}, '... our %foo was initialized correctly'); + is(${'Foo::foo'}{one}, 1, '... our %foo was initialized correctly'); +} + +my $foo = Foo->meta->get_package_symbol('%foo'); +is_deeply({ one => 1 }, $foo, '... got the right package variable back'); + +# ... make sure changes propogate up + +$foo->{two} = 2; + +{ + no strict 'refs'; + is(\%{'Foo::foo'}, Foo->meta->get_package_symbol('%foo'), '... our %foo is the same as the metas'); + + ok(exists ${'Foo::foo'}{two}, '... our %foo was updated correctly'); + is(${'Foo::foo'}{two}, 2, '... our %foo was updated correctly'); +} + +# ---------------------------------------------------------------------- +## test adding an ARRAY + +ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); + +is( exception { + Foo->meta->add_package_symbol('@bar' => [ 1, 2, 3 ]); +}, undef, '... created @Foo::bar successfully' ); + +ok(defined($Foo::{bar}), '... the @bar slot was created successfully'); +ok(Foo->meta->has_package_symbol('@bar'), '... the meta agrees'); + +# ... why does this not work ... + +ok(!Foo->meta->has_package_symbol('$bar'), '... SCALAR shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('%bar'), '... HASH shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('&bar'), '... CODE shouldnt have been created too'); + +# check the value itself + +{ + no strict 'refs'; + is(scalar @{'Foo::bar'}, 3, '... our @bar was initialized correctly'); + is(${'Foo::bar'}[1], 2, '... our @bar was initialized correctly'); +} + +# ---------------------------------------------------------------------- +## test adding a SCALAR + +ok(!defined($Foo::{baz}), '... the $baz slot has not been created yet'); + +is( exception { + Foo->meta->add_package_symbol('$baz' => 10); +}, undef, '... created $Foo::baz successfully' ); + +ok(defined($Foo::{baz}), '... the $baz slot was created successfully'); +ok(Foo->meta->has_package_symbol('$baz'), '... the meta agrees'); + +ok(!Foo->meta->has_package_symbol('@baz'), '... ARRAY shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('%baz'), '... HASH shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('&baz'), '... CODE shouldnt have been created too'); + +is(${Foo->meta->get_package_symbol('$baz')}, 10, '... got the right value back'); + +{ + no strict 'refs'; + ${'Foo::baz'} = 1; + + is(${'Foo::baz'}, 1, '... our $baz was assigned to correctly'); + is(${Foo->meta->get_package_symbol('$baz')}, 1, '... the meta agrees'); +} + +# ---------------------------------------------------------------------- +## test adding a CODE + +ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet'); + +is( exception { + Foo->meta->add_package_symbol('&funk' => sub { "Foo::funk" }); +}, undef, '... created &Foo::funk successfully' ); + +ok(defined($Foo::{funk}), '... the &funk slot was created successfully'); +ok(Foo->meta->has_package_symbol('&funk'), '... the meta agrees'); + +ok(!Foo->meta->has_package_symbol('$funk'), '... SCALAR shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('@funk'), '... ARRAY shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('%funk'), '... HASH shouldnt have been created too'); + +{ + no strict 'refs'; + ok(defined &{'Foo::funk'}, '... our &funk exists'); +} + +is(Foo->funk(), 'Foo::funk', '... got the right value from the function'); + +# ---------------------------------------------------------------------- +## test multiple slots in the glob + +my $ARRAY = [ 1, 2, 3 ]; +my $CODE = sub { "Foo::foo" }; + +is( exception { + Foo->meta->add_package_symbol('@foo' => $ARRAY); +}, undef, '... created @Foo::foo successfully' ); + +ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot was added successfully'); +is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); + +is( exception { + Foo->meta->add_package_symbol('&foo' => $CODE); +}, undef, '... created &Foo::foo successfully' ); + +ok(Foo->meta->has_package_symbol('&foo'), '... the meta agrees'); +is(Foo->meta->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); + +is( exception { + Foo->meta->add_package_symbol('$foo' => 'Foo::foo'); +}, undef, '... created $Foo::foo successfully' ); + +ok(Foo->meta->has_package_symbol('$foo'), '... the meta agrees'); +my $SCALAR = Foo->meta->get_package_symbol('$foo'); +is($$SCALAR, 'Foo::foo', '... got the right scalar value back'); + +{ + no strict 'refs'; + is(${'Foo::foo'}, 'Foo::foo', '... got the right value from the scalar'); +} + +is( exception { + Foo->meta->remove_package_symbol('%foo'); +}, undef, '... removed %Foo::foo successfully' ); + +ok(!Foo->meta->has_package_symbol('%foo'), '... the %foo slot was removed successfully'); +ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists'); +ok(Foo->meta->has_package_symbol('&foo'), '... the &foo slot still exists'); +ok(Foo->meta->has_package_symbol('$foo'), '... the $foo slot still exists'); + +is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); +is(Foo->meta->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); +is(Foo->meta->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); + ok(defined(*{"Foo::foo"}{CODE}), '... the &foo slot has NOT been removed'); + ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); +} + +is( exception { + Foo->meta->remove_package_symbol('&foo'); +}, undef, '... removed &Foo::foo successfully' ); + +ok(!Foo->meta->has_package_symbol('&foo'), '... the &foo slot no longer exists'); + +ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists'); +ok(Foo->meta->has_package_symbol('$foo'), '... the $foo slot still exists'); + +is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); +is(Foo->meta->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); + ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); +} + +is( exception { + Foo->meta->remove_package_symbol('$foo'); +}, undef, '... removed $Foo::foo successfully' ); + +ok(!Foo->meta->has_package_symbol('$foo'), '... the $foo slot no longer exists'); + +ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists'); + +is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); + ok(!defined(${"Foo::foo"}), '... the $foo slot has now been removed'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); +} + +# get_all_package_symbols + +{ + my $syms = Foo->meta->get_all_package_symbols; + is_deeply( + [ sort keys %{ $syms } ], + [ sort Foo->meta->list_all_package_symbols ], + '... the fetched symbols are the same as the listed ones' + ); +} + +{ + my $syms = Foo->meta->get_all_package_symbols('CODE'); + + is_deeply( + [ sort keys %{ $syms } ], + [ sort Foo->meta->list_all_package_symbols('CODE') ], + '... the fetched symbols are the same as the listed ones' + ); + + foreach my $symbol (keys %{ $syms }) { + is($syms->{$symbol}, Foo->meta->get_package_symbol('&' . $symbol), '... got the right symbol'); + } +} + +{ + Foo->meta->add_package_symbol('%zork'); + + my $syms = Foo->meta->get_all_package_symbols('HASH'); + + is_deeply( + [ sort keys %{ $syms } ], + [ sort Foo->meta->list_all_package_symbols('HASH') ], + '... the fetched symbols are the same as the listed ones' + ); + + foreach my $symbol (keys %{ $syms }) { + is($syms->{$symbol}, Foo->meta->get_package_symbol('%' . $symbol), '... got the right symbol'); + } + + no warnings 'once'; + is_deeply( + $syms, + { zork => \%Foo::zork }, + "got the right ones", + ); +} + +done_testing; diff --git a/t/cmop/meta_package_extension.t b/t/cmop/meta_package_extension.t new file mode 100644 index 0000000..4754275 --- /dev/null +++ b/t/cmop/meta_package_extension.t @@ -0,0 +1,95 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + package My::Package::Stash; + use strict; + use warnings; + + use parent 'Package::Stash'; + + use metaclass; + + use Symbol 'gensym'; + + __PACKAGE__->meta->add_attribute( + 'namespace' => ( + reader => 'namespace', + default => sub { {} } + ) + ); + + sub new { + my $class = shift; + $class->meta->new_object(__INSTANCE__ => $class->SUPER::new(@_)); + } + + sub add_symbol { + my ($self, $variable, $initial_value) = @_; + + (my $name = $variable) =~ s/^[\$\@\%\&]//; + + my $glob = gensym(); + *{$glob} = $initial_value if defined $initial_value; + $self->namespace->{$name} = *{$glob}; + } +} + +{ + package My::Meta::Package; + + use strict; + use warnings; + + use parent 'Class::MOP::Package'; + + sub _package_stash { + $_[0]->{_package_stash} ||= My::Package::Stash->new($_[0]->name); + } +} + +# No actually package Foo exists :) +my $meta = My::Meta::Package->initialize('Foo'); + +isa_ok($meta, 'My::Meta::Package'); +isa_ok($meta, 'Class::MOP::Package'); + +ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); +ok(!$meta->has_package_symbol('%foo'), '... the meta agrees'); + +is( exception { + $meta->add_package_symbol('%foo' => { one => 1 }); +}, undef, '... the %foo symbol is created succcessfully' ); + +ok(!defined($Foo::{foo}), '... the %foo slot has not been created in the actual Foo package'); +ok($meta->has_package_symbol('%foo'), '... the meta agrees'); + +my $foo = $meta->get_package_symbol('%foo'); +is_deeply({ one => 1 }, $foo, '... got the right package variable back'); + +$foo->{two} = 2; + +is($foo, $meta->get_package_symbol('%foo'), '... our %foo is the same as the metas'); + +ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); + +is( exception { + $meta->add_package_symbol('@bar' => [ 1, 2, 3 ]); +}, undef, '... created @Foo::bar successfully' ); + +ok(!defined($Foo::{bar}), '... the @bar slot has still not been created'); + +ok(!defined($Foo::{baz}), '... the %baz slot has not been created yet'); + +is( exception { + $meta->add_package_symbol('%baz'); +}, undef, '... created %Foo::baz successfully' ); + +ok(!defined($Foo::{baz}), '... the %baz slot has still not been created'); + +done_testing; diff --git a/t/cmop/metaclass.t b/t/cmop/metaclass.t new file mode 100644 index 0000000..6bc5b64 --- /dev/null +++ b/t/cmop/metaclass.t @@ -0,0 +1,58 @@ +use strict; +use warnings; + +use Test::More; + +use metaclass; + +{ + package FooMeta; + use parent 'Class::MOP::Class'; + + package Foo; + use metaclass 'FooMeta'; +} + +can_ok('Foo', 'meta'); +isa_ok(Foo->meta, 'FooMeta'); +isa_ok(Foo->meta, 'Class::MOP::Class'); + +{ + package BarMeta; + use parent 'Class::MOP::Class'; + + package BarMeta::Attribute; + use parent 'Class::MOP::Attribute'; + + package BarMeta::Method; + use parent 'Class::MOP::Method'; + + package Bar; + use metaclass 'BarMeta' => ( + 'attribute_metaclass' => 'BarMeta::Attribute', + 'method_metaclass' => 'BarMeta::Method', + ); +} + +can_ok('Bar', 'meta'); +isa_ok(Bar->meta, 'BarMeta'); +isa_ok(Bar->meta, 'Class::MOP::Class'); + +is(Bar->meta->attribute_metaclass, 'BarMeta::Attribute', '... got the right attribute metaobject'); +is(Bar->meta->method_metaclass, 'BarMeta::Method', '... got the right method metaobject'); + +{ + package Baz; + use metaclass; +} + +can_ok('Baz', 'meta'); +isa_ok(Baz->meta, 'Class::MOP::Class'); + +eval { + package Boom; + metaclass->import('Foo'); +}; +ok($@, '... metaclasses must be subclass of Class::MOP::Class'); + +done_testing; diff --git a/t/cmop/metaclass_incompatibility.t b/t/cmop/metaclass_incompatibility.t new file mode 100644 index 0000000..9991a18 --- /dev/null +++ b/t/cmop/metaclass_incompatibility.t @@ -0,0 +1,264 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use metaclass; + +my %metaclass_attrs; +BEGIN { + %metaclass_attrs = ( + 'Instance' => 'instance_metaclass', + 'Attribute' => 'attribute_metaclass', + 'Method' => 'method_metaclass', + 'Method::Wrapped' => 'wrapped_method_metaclass', + 'Method::Constructor' => 'constructor_class', + ); + + # meta classes + for my $suffix ('Class', keys %metaclass_attrs) { + Class::MOP::Class->create( + "Foo::Meta::$suffix", + superclasses => ["Class::MOP::$suffix"] + ); + Class::MOP::Class->create( + "Bar::Meta::$suffix", + superclasses => ["Class::MOP::$suffix"] + ); + Class::MOP::Class->create( + "FooBar::Meta::$suffix", + superclasses => ["Foo::Meta::$suffix", "Bar::Meta::$suffix"] + ); + } +} + +# checking... + +is( exception { + Foo::Meta::Class->create('Foo') +}, undef, '... Foo.meta => Foo::Meta::Class is compatible' ); +is( exception { + Bar::Meta::Class->create('Bar') +}, undef, '... Bar.meta => Bar::Meta::Class is compatible' ); + +like( exception { + Bar::Meta::Class->create('Foo::Foo', superclasses => ['Foo']) +}, qr/compatible/, '... Foo::Foo.meta => Bar::Meta::Class is not compatible' ); +like( exception { + Foo::Meta::Class->create('Bar::Bar', superclasses => ['Bar']) +}, qr/compatible/, '... Bar::Bar.meta => Foo::Meta::Class is not compatible' ); + +is( exception { + FooBar::Meta::Class->create('FooBar', superclasses => ['Foo']) +}, undef, '... FooBar.meta => FooBar::Meta::Class is compatible' ); +is( exception { + FooBar::Meta::Class->create('FooBar2', superclasses => ['Bar']) +}, undef, '... FooBar2.meta => FooBar::Meta::Class is compatible' ); + +Foo::Meta::Class->create( + 'Foo::All', + map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs, +); + +like( exception { + Bar::Meta::Class->create( + 'Foo::All::Sub::Class', + superclasses => ['Foo::All'], + map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs, + ) +}, qr/compatible/, 'incompatible Class metaclass' ); +for my $suffix (keys %metaclass_attrs) { + like( exception { + Foo::Meta::Class->create( + "Foo::All::Sub::$suffix", + superclasses => ['Foo::All'], + (map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs), + $metaclass_attrs{$suffix} => "Bar::Meta::$suffix", + ) + }, qr/compatible/, "incompatible $suffix metaclass" ); +} + +# fixing... + +is( exception { + Class::MOP::Class->create('Foo::Foo::CMOP', superclasses => ['Foo']) +}, undef, 'metaclass fixing fixes a cmop metaclass, when the parent has a subclass' ); +isa_ok(Foo::Foo::CMOP->meta, 'Foo::Meta::Class'); +is( exception { + Class::MOP::Class->create('Bar::Bar::CMOP', superclasses => ['Bar']) +}, undef, 'metaclass fixing fixes a cmop metaclass, when the parent has a subclass' ); +isa_ok(Bar::Bar::CMOP->meta, 'Bar::Meta::Class'); + +is( exception { + Class::MOP::Class->create( + 'Foo::All::Sub::CMOP::Class', + superclasses => ['Foo::All'], + map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs, + ) +}, undef, 'metaclass fixing works with other non-default metaclasses' ); +isa_ok(Foo::All::Sub::CMOP::Class->meta, 'Foo::Meta::Class'); + +for my $suffix (keys %metaclass_attrs) { + is( exception { + Foo::Meta::Class->create( + "Foo::All::Sub::CMOP::$suffix", + superclasses => ['Foo::All'], + (map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs), + $metaclass_attrs{$suffix} => "Class::MOP::$suffix", + ) + }, undef, "$metaclass_attrs{$suffix} fixing works with other non-default metaclasses" ); + for my $suffix2 (keys %metaclass_attrs) { + my $method = $metaclass_attrs{$suffix2}; + isa_ok("Foo::All::Sub::CMOP::$suffix"->meta->$method, "Foo::Meta::$suffix2"); + } +} + +# initializing... + +{ + package Foo::NoMeta; +} + +Class::MOP::Class->create('Foo::NoMeta::Sub', superclasses => ['Foo::NoMeta']); +ok(!Foo::NoMeta->can('meta'), "non-cmop superclass doesn't get methods installed"); +isa_ok(Class::MOP::class_of('Foo::NoMeta'), 'Class::MOP::Class'); +isa_ok(Foo::NoMeta::Sub->meta, 'Class::MOP::Class'); + +{ + package Foo::NoMeta2; +} +Foo::Meta::Class->create('Foo::NoMeta2::Sub', superclasses => ['Foo::NoMeta2']); +ok(!Foo::NoMeta->can('meta'), "non-cmop superclass doesn't get methods installed"); +isa_ok(Class::MOP::class_of('Foo::NoMeta2'), 'Class::MOP::Class'); +isa_ok(Foo::NoMeta2::Sub->meta, 'Foo::Meta::Class'); + + +BEGIN { + Foo::Meta::Class->create('Foo::WithMeta'); +} +{ + package Foo::WithMeta::Sub; + use parent -norequire => 'Foo::WithMeta'; +} +Class::MOP::Class->create( + 'Foo::WithMeta::Sub::Sub', + superclasses => ['Foo::WithMeta::Sub'] +); + +isa_ok(Class::MOP::class_of('Foo::WithMeta'), 'Foo::Meta::Class'); +isa_ok(Class::MOP::class_of('Foo::WithMeta::Sub'), 'Foo::Meta::Class'); +isa_ok(Class::MOP::class_of('Foo::WithMeta::Sub::Sub'), 'Foo::Meta::Class'); + +BEGIN { + Foo::Meta::Class->create('Foo::WithMeta2'); +} +{ + package Foo::WithMeta2::Sub; + use parent -norequire => 'Foo::WithMeta2'; +} +{ + package Foo::WithMeta2::Sub::Sub; + use parent -norequire => 'Foo::WithMeta2::Sub'; +} +Class::MOP::Class->create( + 'Foo::WithMeta2::Sub::Sub::Sub', + superclasses => ['Foo::WithMeta2::Sub::Sub'] +); + +isa_ok(Class::MOP::class_of('Foo::WithMeta2'), 'Foo::Meta::Class'); +isa_ok(Class::MOP::class_of('Foo::WithMeta2::Sub'), 'Foo::Meta::Class'); +isa_ok(Class::MOP::class_of('Foo::WithMeta2::Sub::Sub'), 'Foo::Meta::Class'); +isa_ok(Class::MOP::class_of('Foo::WithMeta2::Sub::Sub::Sub'), 'Foo::Meta::Class'); + +Class::MOP::Class->create( + 'Foo::Reverse::Sub::Sub', + superclasses => ['Foo::Reverse::Sub'], +); +eval "package Foo::Reverse::Sub; use parent -norequire => 'Foo::Reverse';"; +Foo::Meta::Class->create( + 'Foo::Reverse', +); +isa_ok(Class::MOP::class_of('Foo::Reverse'), 'Foo::Meta::Class'); +{ local $TODO = 'No idea how to handle case where child class is created before parent'; +isa_ok(Class::MOP::class_of('Foo::Reverse::Sub'), 'Foo::Meta::Class'); +isa_ok(Class::MOP::class_of('Foo::Reverse::Sub::Sub'), 'Foo::Meta::Class'); +} + +# unsafe fixing... + +{ + Class::MOP::Class->create( + 'Foo::Unsafe', + attribute_metaclass => 'Foo::Meta::Attribute', + ); + my $meta = Class::MOP::Class->create( + 'Foo::Unsafe::Sub', + ); + $meta->add_attribute(foo => reader => 'foo'); + like( exception { $meta->superclasses('Foo::Unsafe') }, qr/compatibility.*pristine/, "can't switch out the attribute metaclass of a class that already has attributes" ); +} + +# immutability... + +{ + my $foometa = Foo::Meta::Class->create( + 'Foo::Immutable', + ); + $foometa->make_immutable; + my $barmeta = Class::MOP::Class->create( + 'Bar::Mutable', + ); + my $bazmeta = Class::MOP::Class->create( + 'Baz::Mutable', + ); + $bazmeta->superclasses($foometa->name); + is( exception { $bazmeta->superclasses($barmeta->name) }, undef, "can still set superclasses" ); + ok(!$bazmeta->is_immutable, + "immutable superclass doesn't make this class immutable"); + is( exception { $bazmeta->make_immutable }, undef, "can still make immutable" ); +} + +# nonexistent metaclasses + +Class::MOP::Class->create( + 'Weird::Meta::Method::Destructor', + superclasses => ['Class::MOP::Method'], +); + +is( exception { + Class::MOP::Class->create( + 'Weird::Class', + destructor_class => 'Weird::Meta::Method::Destructor', + ); +}, undef, "defined metaclass in child with defined metaclass in parent is fine" ); + +is(Weird::Class->meta->destructor_class, 'Weird::Meta::Method::Destructor', + "got the right destructor class"); + +is( exception { + Class::MOP::Class->create( + 'Weird::Class::Sub', + superclasses => ['Weird::Class'], + destructor_class => undef, + ); +}, undef, "undef metaclass in child with defined metaclass in parent can be fixed" ); + +is(Weird::Class::Sub->meta->destructor_class, 'Weird::Meta::Method::Destructor', + "got the right destructor class"); + +is( exception { + Class::MOP::Class->create( + 'Weird::Class::Sub2', + destructor_class => undef, + ); +}, undef, "undef metaclass in child with defined metaclass in parent can be fixed" ); + +is( exception { + Weird::Class::Sub2->meta->superclasses('Weird::Class'); +}, undef, "undef metaclass in child with defined metaclass in parent can be fixed" ); + +is(Weird::Class::Sub->meta->destructor_class, 'Weird::Meta::Method::Destructor', + "got the right destructor class"); + +done_testing; diff --git a/t/cmop/metaclass_incompatibility_dyn.t b/t/cmop/metaclass_incompatibility_dyn.t new file mode 100644 index 0000000..dccec28 --- /dev/null +++ b/t/cmop/metaclass_incompatibility_dyn.t @@ -0,0 +1,66 @@ +use strict; +use warnings; + +use Test::More; + +use metaclass; + +# meta classes +{ + package Foo::Meta; + use parent 'Class::MOP::Class'; + + package Bar::Meta; + use parent 'Class::MOP::Class'; + + package FooBar::Meta; + use parent -norequire => 'Foo::Meta', 'Bar::Meta'; +} + +$@ = undef; +eval { + package Foo; + metaclass->import('Foo::Meta'); +}; +ok(!$@, '... Foo.meta => Foo::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package Bar; + metaclass->import('Bar::Meta'); +}; +ok(!$@, '... Bar.meta => Bar::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package Foo::Foo; + metaclass->import('Bar::Meta'); + Foo::Foo->meta->superclasses('Foo'); +}; +ok($@, '... Foo::Foo.meta => Bar::Meta is not compatible') || diag $@; + +$@ = undef; +eval { + package Bar::Bar; + metaclass->import('Foo::Meta'); + Bar::Bar->meta->superclasses('Bar'); +}; +ok($@, '... Bar::Bar.meta => Foo::Meta is not compatible') || diag $@; + +$@ = undef; +eval { + package FooBar; + metaclass->import('FooBar::Meta'); + FooBar->meta->superclasses('Foo'); +}; +ok(!$@, '... FooBar.meta => FooBar::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package FooBar2; + metaclass->import('FooBar::Meta'); + FooBar2->meta->superclasses('Bar'); +}; +ok(!$@, '... FooBar2.meta => FooBar::Meta is compatible') || diag $@; + +done_testing; diff --git a/t/cmop/metaclass_inheritance.t b/t/cmop/metaclass_inheritance.t new file mode 100644 index 0000000..0cc2a5c --- /dev/null +++ b/t/cmop/metaclass_inheritance.t @@ -0,0 +1,43 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; + +=pod + +Test that a default set up will cause metaclasses to inherit +the same metaclass type, but produce different metaclasses. + +=cut + +{ + package Foo; + use metaclass; + + package Bar; + use parent -norequire => 'Foo'; + + package Baz; + use parent -norequire => 'Bar'; +} + +my $foo_meta = Foo->meta; +isa_ok($foo_meta, 'Class::MOP::Class'); + +is($foo_meta->name, 'Foo', '... foo_meta->name == Foo'); + +my $bar_meta = Bar->meta; +isa_ok($bar_meta, 'Class::MOP::Class'); + +is($bar_meta->name, 'Bar', '... bar_meta->name == Bar'); +isnt($bar_meta, $foo_meta, '... Bar->meta != Foo->meta'); + +my $baz_meta = Baz->meta; +isa_ok($baz_meta, 'Class::MOP::Class'); + +is($baz_meta->name, 'Baz', '... baz_meta->name == Baz'); +isnt($baz_meta, $bar_meta, '... Baz->meta != Bar->meta'); +isnt($baz_meta, $foo_meta, '... Baz->meta != Foo->meta'); + +done_testing; diff --git a/t/cmop/metaclass_loads_classes.t b/t/cmop/metaclass_loads_classes.t new file mode 100644 index 0000000..9c0fa01 --- /dev/null +++ b/t/cmop/metaclass_loads_classes.t @@ -0,0 +1,38 @@ +use strict; +use warnings; + +use Test::More; + +use Class::Load qw(is_class_loaded); + +use lib 't/cmop/lib'; + +{ + package Foo; + + use strict; + use warnings; + + use metaclass 'MyMetaClass' => ( + 'attribute_metaclass' => 'MyMetaClass::Attribute', + 'instance_metaclass' => 'MyMetaClass::Instance', + 'method_metaclass' => 'MyMetaClass::Method', + 'random_metaclass' => 'MyMetaClass::Random', + ); +} + +my $meta = Foo->meta; + +isa_ok($meta, 'MyMetaClass', '... Correct metaclass'); +ok(is_class_loaded('MyMetaClass'), '... metaclass loaded'); + +is($meta->attribute_metaclass, 'MyMetaClass::Attribute', '... Correct attribute metaclass'); +ok(is_class_loaded('MyMetaClass::Attribute'), '... attribute metaclass loaded'); + +is($meta->instance_metaclass, 'MyMetaClass::Instance', '... Correct instance metaclass'); +ok(is_class_loaded('MyMetaClass::Instance'), '... instance metaclass loaded'); + +is($meta->method_metaclass, 'MyMetaClass::Method', '... Correct method metaclass'); +ok(is_class_loaded('MyMetaClass::Method'), '... method metaclass loaded'); + +done_testing; diff --git a/t/cmop/metaclass_reinitialize.t b/t/cmop/metaclass_reinitialize.t new file mode 100644 index 0000000..e4a98f3 --- /dev/null +++ b/t/cmop/metaclass_reinitialize.t @@ -0,0 +1,205 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package Foo; + use metaclass; + sub foo {} + Foo->meta->add_attribute('bar'); +} + +sub check_meta_sanity { + my ($meta, $class) = @_; + isa_ok($meta, 'Class::MOP::Class'); + is($meta->name, $class); + ok($meta->has_method('foo')); + isa_ok($meta->get_method('foo'), 'Class::MOP::Method'); + ok($meta->has_attribute('bar')); + isa_ok($meta->get_attribute('bar'), 'Class::MOP::Attribute'); +} + +can_ok('Foo', 'meta'); + +my $meta = Foo->meta; +check_meta_sanity($meta, 'Foo'); + +is( exception { + $meta = $meta->reinitialize($meta->name); +}, undef ); +check_meta_sanity($meta, 'Foo'); + +is( exception { + $meta = $meta->reinitialize($meta); +}, undef ); +check_meta_sanity($meta, 'Foo'); + +like( exception { + $meta->reinitialize(''); +}, qr/You must pass a package name or an existing Class::MOP::Package instance/ ); + +like( exception { + $meta->reinitialize($meta->new_object); +}, qr/You must pass a package name or an existing Class::MOP::Package instance/ ); + +{ + package Bar::Meta::Method; + use parent 'Class::MOP::Method'; + __PACKAGE__->meta->add_attribute('test', accessor => 'test'); +} + +{ + package Bar::Meta::Attribute; + use parent 'Class::MOP::Attribute'; + __PACKAGE__->meta->add_attribute('tset', accessor => 'tset'); +} + +{ + package Bar; + use metaclass; + Bar->meta->add_method('foo' => Bar::Meta::Method->wrap(sub {}, name => 'foo', package_name => 'Bar')); + Bar->meta->add_attribute(Bar::Meta::Attribute->new('bar')); +} + +$meta = Bar->meta; +check_meta_sanity($meta, 'Bar'); +isa_ok(Bar->meta->get_method('foo'), 'Bar::Meta::Method'); +isa_ok(Bar->meta->get_attribute('bar'), 'Bar::Meta::Attribute'); +is( exception { + $meta = $meta->reinitialize('Bar'); +}, undef ); +check_meta_sanity($meta, 'Bar'); +isa_ok(Bar->meta->get_method('foo'), 'Bar::Meta::Method'); +isa_ok(Bar->meta->get_attribute('bar'), 'Bar::Meta::Attribute'); + +Bar->meta->get_method('foo')->test('FOO'); +Bar->meta->get_attribute('bar')->tset('OOF'); + +is(Bar->meta->get_method('foo')->test, 'FOO'); +is(Bar->meta->get_attribute('bar')->tset, 'OOF'); +is( exception { + $meta = $meta->reinitialize('Bar'); +}, undef ); +is(Bar->meta->get_method('foo')->test, 'FOO'); +is(Bar->meta->get_attribute('bar')->tset, 'OOF'); + +{ + package Baz::Meta::Attribute; + use parent 'Class::MOP::Attribute'; +} + +{ + package Baz::Meta::Method; + use parent 'Class::MOP::Method'; +} + +{ + package Baz; + use metaclass meta_name => undef; + + sub foo {} + Class::MOP::class_of('Baz')->add_attribute('bar'); +} + +$meta = Class::MOP::class_of('Baz'); +check_meta_sanity($meta, 'Baz'); +ok(!$meta->get_method('foo')->isa('Baz::Meta::Method')); +ok(!$meta->get_attribute('bar')->isa('Baz::Meta::Attribute')); +is( exception { + $meta = $meta->reinitialize( + 'Baz', + attribute_metaclass => 'Baz::Meta::Attribute', + method_metaclass => 'Baz::Meta::Method' + ); +}, undef ); +check_meta_sanity($meta, 'Baz'); +isa_ok($meta->get_method('foo'), 'Baz::Meta::Method'); +isa_ok($meta->get_attribute('bar'), 'Baz::Meta::Attribute'); + +{ + package Quux; + use metaclass + attribute_metaclass => 'Bar::Meta::Attribute', + method_metaclass => 'Bar::Meta::Method'; + + sub foo {} + Quux->meta->add_attribute('bar'); +} + +$meta = Quux->meta; +check_meta_sanity($meta, 'Quux'); +isa_ok(Quux->meta->get_method('foo'), 'Bar::Meta::Method'); +isa_ok(Quux->meta->get_attribute('bar'), 'Bar::Meta::Attribute'); +like( exception { + $meta = $meta->reinitialize( + 'Quux', + attribute_metaclass => 'Baz::Meta::Attribute', + method_metaclass => 'Baz::Meta::Method', + ); +}, qr/\QAttribute (class_name) is required/ ); + +{ + package Quuux::Meta::Attribute; + use parent 'Class::MOP::Attribute'; + + sub install_accessors {} +} + +{ + package Quuux; + use metaclass; + sub foo {} + Quuux->meta->add_attribute('bar', reader => 'bar'); +} + +$meta = Quuux->meta; +check_meta_sanity($meta, 'Quuux'); +ok($meta->has_method('bar')); +is( exception { + $meta = $meta->reinitialize( + 'Quuux', + attribute_metaclass => 'Quuux::Meta::Attribute', + ); +}, undef ); +check_meta_sanity($meta, 'Quuux'); +ok(!$meta->has_method('bar')); + +{ + package Blah::Meta::Method; + use parent 'Class::MOP::Method'; + + __PACKAGE__->meta->add_attribute('foo', reader => 'foo', default => 'TEST'); +} + +{ + package Blah::Meta::Attribute; + use parent 'Class::MOP::Attribute'; + + __PACKAGE__->meta->add_attribute('oof', reader => 'oof', default => 'TSET'); +} + +{ + package Blah; + use metaclass no_meta => 1; + sub foo {} + Class::MOP::class_of('Blah')->add_attribute('bar'); +} + +$meta = Class::MOP::class_of('Blah'); +check_meta_sanity($meta, 'Blah'); +is( exception { + $meta = Class::MOP::Class->reinitialize( + 'Blah', + attribute_metaclass => 'Blah::Meta::Attribute', + method_metaclass => 'Blah::Meta::Method', + ); +}, undef ); +check_meta_sanity($meta, 'Blah'); +can_ok($meta->get_method('foo'), 'foo'); +is($meta->get_method('foo')->foo, 'TEST'); +can_ok($meta->get_attribute('bar'), 'oof'); +is($meta->get_attribute('bar')->oof, 'TSET'); + +done_testing; diff --git a/t/cmop/method.t b/t/cmop/method.t new file mode 100644 index 0000000..dd15b8a --- /dev/null +++ b/t/cmop/method.t @@ -0,0 +1,172 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; +use Class::MOP::Method; + +my $method = Class::MOP::Method->wrap( + sub {1}, + package_name => 'main', + name => '__ANON__', +); +is( $method->meta, Class::MOP::Method->meta, + '... instance and class both lead to the same meta' ); + +is( $method->package_name, 'main', '... our package is main::' ); +is( $method->name, '__ANON__', '... our sub name is __ANON__' ); +is( $method->fully_qualified_name, 'main::__ANON__', + '... our subs full name is main::__ANON__' ); +is( $method->original_method, undef, '... no original_method ' ); +is( $method->original_package_name, 'main', + '... the original_package_name is the same as package_name' ); +is( $method->original_name, '__ANON__', + '... the original_name is the same as name' ); +is( $method->original_fully_qualified_name, 'main::__ANON__', + '... the original_fully_qualified_name is the same as fully_qualified_name' +); +ok( !$method->is_stub, + '... the method is not a stub' ); + +isnt( exception { Class::MOP::Method->wrap }, undef, q{... can't call wrap() without some code} ); +isnt( exception { Class::MOP::Method->wrap( [] ) }, undef, q{... can't call wrap() without some code} ); +isnt( exception { Class::MOP::Method->wrap( bless {} => 'Fail' ) }, undef, q{... can't call wrap() without some code} ); + +isnt( exception { Class::MOP::Method->name }, undef, q{... can't call name() as a class method} ); +isnt( exception { Class::MOP::Method->body }, undef, q{... can't call body() as a class method} ); +isnt( exception { Class::MOP::Method->package_name }, undef, q{... can't call package_name() as a class method} ); +isnt( exception { Class::MOP::Method->fully_qualified_name }, undef, q{... can't call fully_qualified_name() as a class method} ); + +my $meta = Class::MOP::Method->meta; +isa_ok( $meta, 'Class::MOP::Class' ); + +foreach my $method_name ( + qw( + wrap + package_name + name + ) + ) { + ok( $meta->has_method($method_name), + '... Class::MOP::Method->has_method(' . $method_name . ')' ); + my $method = $meta->get_method($method_name); + is( $method->package_name, 'Class::MOP::Method', + '... our package is Class::MOP::Method' ); + is( $method->name, $method_name, + '... our sub name is "' . $method_name . '"' ); +} + +isnt( exception { + Class::MOP::Method->wrap(); +}, undef, '... bad args for &wrap' ); + +isnt( exception { + Class::MOP::Method->wrap('Fail'); +}, undef, '... bad args for &wrap' ); + +isnt( exception { + Class::MOP::Method->wrap( [] ); +}, undef, '... bad args for &wrap' ); + +isnt( exception { + Class::MOP::Method->wrap( sub {'FAIL'} ); +}, undef, '... bad args for &wrap' ); + +isnt( exception { + Class::MOP::Method->wrap( sub {'FAIL'}, package_name => 'main' ); +}, undef, '... bad args for &wrap' ); + +isnt( exception { + Class::MOP::Method->wrap( sub {'FAIL'}, name => '__ANON__' ); +}, undef, '... bad args for &wrap' ); + +is( exception { + Class::MOP::Method->wrap( bless( sub {'FAIL'}, "Foo" ), + name => '__ANON__', package_name => 'Foo::Bar' ); +}, undef, '... blessed coderef to &wrap' ); + +my $clone = $method->clone( + package_name => 'NewPackage', + name => 'new_name', +); + +isa_ok( $clone, 'Class::MOP::Method' ); +is( $clone->package_name, 'NewPackage', + '... cloned method has new package name' ); +is( $clone->name, 'new_name', '... cloned method has new sub name' ); +is( $clone->fully_qualified_name, 'NewPackage::new_name', + '... cloned method has new fq name' ); +is( $clone->original_method, $method, + '... cloned method has correct original_method' ); +is( $clone->original_package_name, 'main', + '... cloned method has correct original_package_name' ); +is( $clone->original_name, '__ANON__', + '... cloned method has correct original_name' ); +is( $clone->original_fully_qualified_name, 'main::__ANON__', + '... cloned method has correct original_fully_qualified_name' ); + +my $clone2 = $clone->clone( + package_name => 'NewerPackage', + name => 'newer_name', +); + +is( $clone2->package_name, 'NewerPackage', + '... clone of clone has new package name' ); +is( $clone2->name, 'newer_name', '... clone of clone has new sub name' ); +is( $clone2->fully_qualified_name, 'NewerPackage::newer_name', + '... clone of clone new fq name' ); +is( $clone2->original_method, $clone, + '... cloned method has correct original_method' ); +is( $clone2->original_package_name, 'main', + '... original_package_name follows clone chain' ); +is( $clone2->original_name, '__ANON__', + '... original_name follows clone chain' ); +is( $clone2->original_fully_qualified_name, 'main::__ANON__', + '... original_fully_qualified_name follows clone chain' ); + +Class::MOP::Class->create( + 'Method::Subclass', + superclasses => ['Class::MOP::Method'], + attributes => [ + Class::MOP::Attribute->new( + foo => ( + accessor => 'foo', + ) + ), + ], +); + +my $wrapped = Method::Subclass->wrap($method, foo => 'bar'); +isa_ok($wrapped, 'Method::Subclass'); +isa_ok($wrapped, 'Class::MOP::Method'); +is($wrapped->foo, 'bar', 'attribute set properly'); +is($wrapped->package_name, 'main', 'package_name copied properly'); +is($wrapped->name, '__ANON__', 'method name copied properly'); + +my $wrapped2 = Method::Subclass->wrap($method, foo => 'baz', name => 'FOO'); +is($wrapped2->name, 'FOO', 'got a new method name'); + +{ + package Foo; + + sub full {1} + sub stub; +} + +{ + my $meta = Class::MOP::Class->initialize('Foo'); + + ok( $meta->has_method($_), "Foo class has $_ method" ) + for qw( full stub ); + + my $full = $meta->get_method('full'); + ok( !$full->is_stub, 'full is not a stub' ); + + my $stub = $meta->get_method('stub'); + + ok( $stub->is_stub, 'stub is a stub' ); +} + +done_testing; diff --git a/t/cmop/method_modifiers.t b/t/cmop/method_modifiers.t new file mode 100644 index 0000000..cb7078d --- /dev/null +++ b/t/cmop/method_modifiers.t @@ -0,0 +1,203 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; +use Class::MOP::Method; + +# test before and afters +{ + my $trace = ''; + + my $method = Class::MOP::Method->wrap( + body => sub { $trace .= 'primary' }, + package_name => 'main', + name => '__ANON__', + ); + isa_ok( $method, 'Class::MOP::Method' ); + + $method->(); + is( $trace, 'primary', '... got the right return value from method' ); + $trace = ''; + + my $wrapped = Class::MOP::Method::Wrapped->wrap($method); + isa_ok( $wrapped, 'Class::MOP::Method::Wrapped' ); + isa_ok( $wrapped, 'Class::MOP::Method' ); + + $wrapped->(); + is( $trace, 'primary', + '... got the right return value from the wrapped method' ); + $trace = ''; + + is( exception { + $wrapped->add_before_modifier( sub { $trace .= 'before -> ' } ); + }, undef, '... added the before modifier okay' ); + + $wrapped->(); + is( $trace, 'before -> primary', + '... got the right return value from the wrapped method (w/ before)' + ); + $trace = ''; + + is( exception { + $wrapped->add_after_modifier( sub { $trace .= ' -> after' } ); + }, undef, '... added the after modifier okay' ); + + $wrapped->(); + is( $trace, 'before -> primary -> after', + '... got the right return value from the wrapped method (w/ before)' + ); + $trace = ''; +} + +# test around method +{ + my $method = Class::MOP::Method->wrap( + sub {4}, + package_name => 'main', + name => '__ANON__', + ); + isa_ok( $method, 'Class::MOP::Method' ); + + is( $method->(), 4, '... got the right value from the wrapped method' ); + + my $wrapped = Class::MOP::Method::Wrapped->wrap($method); + isa_ok( $wrapped, 'Class::MOP::Method::Wrapped' ); + isa_ok( $wrapped, 'Class::MOP::Method' ); + + is( $wrapped->(), 4, '... got the right value from the wrapped method' ); + + is( exception { + $wrapped->add_around_modifier( sub { ( 3, $_[0]->() ) } ); + $wrapped->add_around_modifier( sub { ( 2, $_[0]->() ) } ); + $wrapped->add_around_modifier( sub { ( 1, $_[0]->() ) } ); + $wrapped->add_around_modifier( sub { ( 0, $_[0]->() ) } ); + }, undef, '... added the around modifier okay' ); + + is_deeply( + [ $wrapped->() ], + [ 0, 1, 2, 3, 4 ], + '... got the right results back from the around methods (in list context)' + ); + + is( scalar $wrapped->(), 4, + '... got the right results back from the around methods (in scalar context)' + ); +} + +{ + my @tracelog; + + my $method = Class::MOP::Method->wrap( + sub { push @tracelog => 'primary' }, + package_name => 'main', + name => '__ANON__', + ); + isa_ok( $method, 'Class::MOP::Method' ); + + my $wrapped = Class::MOP::Method::Wrapped->wrap($method); + isa_ok( $wrapped, 'Class::MOP::Method::Wrapped' ); + isa_ok( $wrapped, 'Class::MOP::Method' ); + + is( exception { + $wrapped->add_before_modifier( sub { push @tracelog => 'before 1' } ); + $wrapped->add_before_modifier( sub { push @tracelog => 'before 2' } ); + $wrapped->add_before_modifier( sub { push @tracelog => 'before 3' } ); + }, undef, '... added the before modifier okay' ); + + is( exception { + $wrapped->add_around_modifier( + sub { push @tracelog => 'around 1'; $_[0]->(); } ); + $wrapped->add_around_modifier( + sub { push @tracelog => 'around 2'; $_[0]->(); } ); + $wrapped->add_around_modifier( + sub { push @tracelog => 'around 3'; $_[0]->(); } ); + }, undef, '... added the around modifier okay' ); + + is( exception { + $wrapped->add_after_modifier( sub { push @tracelog => 'after 1' } ); + $wrapped->add_after_modifier( sub { push @tracelog => 'after 2' } ); + $wrapped->add_after_modifier( sub { push @tracelog => 'after 3' } ); + }, undef, '... added the after modifier okay' ); + + $wrapped->(); + is_deeply( + \@tracelog, + [ + 'before 3', 'before 2', 'before 1', # last-in-first-out order + 'around 3', 'around 2', 'around 1', # last-in-first-out order + 'primary', + 'after 1', 'after 2', 'after 3', # first-in-first-out order + ], + '... got the right tracelog from all our before/around/after methods' + ); +} + +# test introspection +{ + sub before1 { + } + + sub before2 { + } + + sub before3 { + } + + sub after1 { + } + + sub after2 { + } + + sub after3 { + } + + sub around1 { + } + + sub around2 { + } + + sub around3 { + } + + sub orig { + } + + my $method = Class::MOP::Method->wrap( + body => \&orig, + package_name => 'main', + name => '__ANON__', + ); + + my $wrapped = Class::MOP::Method::Wrapped->wrap($method); + + $wrapped->add_before_modifier($_) + for \&before1, \&before2, \&before3; + + $wrapped->add_after_modifier($_) + for \&after1, \&after2, \&after3; + + $wrapped->add_around_modifier($_) + for \&around1, \&around2, \&around3; + + is( $wrapped->get_original_method, $method, + 'check get_original_method' ); + + is_deeply( [ $wrapped->before_modifiers ], + [ \&before3, \&before2, \&before1 ], + 'check before_modifiers' ); + + is_deeply( [ $wrapped->after_modifiers ], + [ \&after1, \&after2, \&after3 ], + 'check after_modifiers' ); + + is_deeply( [ $wrapped->around_modifiers ], + [ \&around3, \&around2, \&around1 ], + 'check around_modifiers' ); +} + +done_testing; diff --git a/t/cmop/methods.t b/t/cmop/methods.t new file mode 100644 index 0000000..a7a5d46 --- /dev/null +++ b/t/cmop/methods.t @@ -0,0 +1,431 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Scalar::Util qw/reftype/; +use Sub::Name; + +use Class::MOP; +use Class::MOP::Class; +use Class::MOP::Method; + +{ + # This package tries to test &has_method as exhaustively as + # possible. More corner cases are welcome :) + package Foo; + + # import a sub + use Scalar::Util 'blessed'; + + sub pie; + sub cake (); + + use constant FOO_CONSTANT => 'Foo-CONSTANT'; + + # define a sub in package + sub bar {'Foo::bar'} + *baz = \&bar; + + # create something with the typeglob inside the package + *baaz = sub {'Foo::baaz'}; + + { # method named with Sub::Name inside the package scope + no strict 'refs'; + *{'Foo::floob'} = Sub::Name::subname 'floob' => sub {'!floob!'}; + } + + # We hateses the "used only once" warnings + { + my $temp1 = \&Foo::baz; + my $temp2 = \&Foo::baaz; + } + + package OinkyBoinky; + our @ISA = "Foo"; + + sub elk {'OinkyBoinky::elk'} + + package main; + + sub Foo::blah { $_[0]->Foo::baz() } + + { + no strict 'refs'; + *{'Foo::bling'} = sub {'$$Bling$$'}; + *{'Foo::bang'} = Sub::Name::subname 'Foo::bang' => sub {'!BANG!'}; + *{'Foo::boom'} = Sub::Name::subname 'boom' => sub {'!BOOM!'}; + + eval "package Foo; sub evaled_foo { 'Foo::evaled_foo' }"; + } +} + +my $Foo = Class::MOP::Class->initialize('Foo'); + +is join(' ', sort $Foo->get_method_list), + 'FOO_CONSTANT baaz bang bar baz blah cake evaled_foo floob pie'; + +ok( $Foo->has_method('pie'), '... got the method stub pie' ); +ok( $Foo->has_method('cake'), '... got the constant method stub cake' ); + +my $foo = sub {'Foo::foo'}; + +ok( !Scalar::Util::blessed($foo), + '... our method is not yet blessed' ); + +is( exception { + $Foo->add_method( 'foo' => $foo ); +}, undef, '... we added the method successfully' ); + +my $foo_method = $Foo->get_method('foo'); + +isa_ok( $foo_method, 'Class::MOP::Method' ); + +is( $foo_method->name, 'foo', '... got the right name for the method' ); +is( $foo_method->package_name, 'Foo', + '... got the right package name for the method' ); + +ok( $Foo->has_method('foo'), + '... Foo->has_method(foo) (defined with Sub::Name)' ); + +is( $Foo->get_method('foo')->body, $foo, + '... Foo->get_method(foo) == \&foo' ); +is( $Foo->get_method('foo')->execute, 'Foo::foo', + '... _method_foo->execute returns "Foo::foo"' ); +is( Foo->foo(), 'Foo::foo', '... Foo->foo() returns "Foo::foo"' ); + +my $bork_blessed = bless sub { }, 'Non::Meta::Class'; + +is( exception { + $Foo->add_method('bork', $bork_blessed); +}, undef, 'can add blessed sub as method'); + +# now check all our other items ... + +ok( $Foo->has_method('FOO_CONSTANT'), + '... not Foo->has_method(FOO_CONSTANT) (defined w/ use constant)' ); +ok( !$Foo->has_method('bling'), + '... not Foo->has_method(bling) (defined in main:: using symbol tables (no Sub::Name))' +); + +ok( $Foo->has_method('bar'), '... Foo->has_method(bar) (defined in Foo)' ); +ok( $Foo->has_method('baz'), + '... Foo->has_method(baz) (typeglob aliased within Foo)' ); +ok( $Foo->has_method('baaz'), + '... Foo->has_method(baaz) (typeglob aliased within Foo)' ); +ok( $Foo->has_method('floob'), + '... Foo->has_method(floob) (defined in Foo:: using symbol tables and Sub::Name w/out package name)' +); +ok( $Foo->has_method('blah'), + '... Foo->has_method(blah) (defined in main:: using fully qualified package name)' +); +ok( $Foo->has_method('bang'), + '... Foo->has_method(bang) (defined in main:: using symbol tables and Sub::Name)' +); +ok( $Foo->has_method('evaled_foo'), + '... Foo->has_method(evaled_foo) (evaled in main::)' ); + +my $OinkyBoinky = Class::MOP::Class->initialize('OinkyBoinky'); + +ok( $OinkyBoinky->has_method('elk'), + "the method 'elk' is defined in OinkyBoinky" ); + +ok( !$OinkyBoinky->has_method('bar'), + "the method 'bar' is not defined in OinkyBoinky" ); + +ok( my $bar = $OinkyBoinky->find_method_by_name('bar'), + "but if you look in the inheritence chain then 'bar' does exist" ); + +is( reftype( $bar->body ), "CODE", "the returned value is a code ref" ); + +# calling get_method blessed them all +for my $method_name ( + qw/baaz + bar + baz + floob + blah + bang + bork + evaled_foo + FOO_CONSTANT/ + ) { + isa_ok( $Foo->get_method($method_name), 'Class::MOP::Method' ); + { + no strict 'refs'; + is( $Foo->get_method($method_name)->body, + \&{ 'Foo::' . $method_name }, + '... body matches CODE ref in package for ' . $method_name ); + } +} + +for my $method_name ( + qw/ + bling + / + ) { + is( ref( $Foo->get_package_symbol( '&' . $method_name ) ), 'CODE', + '... got the __ANON__ methods' ); + { + no strict 'refs'; + is( $Foo->get_package_symbol( '&' . $method_name ), + \&{ 'Foo::' . $method_name }, + '... symbol matches CODE ref in package for ' . $method_name ); + } +} + +ok( !$Foo->has_method('blessed'), + '... !Foo->has_method(blessed) (imported into Foo)' ); +ok( !$Foo->has_method('boom'), + '... !Foo->has_method(boom) (defined in main:: using symbol tables and Sub::Name w/out package name)' +); + +ok( !$Foo->has_method('not_a_real_method'), + '... !Foo->has_method(not_a_real_method) (does not exist)' ); +is( $Foo->get_method('not_a_real_method'), undef, + '... Foo->get_method(not_a_real_method) == undef' ); + +is_deeply( + [ sort $Foo->get_method_list ], + [qw(FOO_CONSTANT baaz bang bar baz blah bork cake evaled_foo floob foo pie)], + '... got the right method list for Foo' +); + +my @universal_methods = qw/isa can VERSION/; +push @universal_methods, 'DOES' if $] >= 5.010; + +is_deeply( + [ + map { $_->name => $_ } + sort { $a->name cmp $b->name } $Foo->get_all_methods() + ], + [ + map { $_->name => $_ } + map { $Foo->find_method_by_name($_) } + sort qw( + FOO_CONSTANT + baaz + bang + bar + baz + blah + bork + cake + evaled_foo + floob + foo + pie + ), + @universal_methods, + ], + '... got the right list of applicable methods for Foo' +); + +is( $Foo->remove_method('foo')->body, $foo, '... removed the foo method' ); +ok( !$Foo->has_method('foo'), + '... !Foo->has_method(foo) we just removed it' ); +isnt( exception { Foo->foo }, undef, '... cannot call Foo->foo because it is not there' ); + +is_deeply( + [ sort $Foo->get_method_list ], + [qw(FOO_CONSTANT baaz bang bar baz blah bork cake evaled_foo floob pie)], + '... got the right method list for Foo' +); + +# ... test our class creator + +my $Bar = Class::MOP::Class->create( + package => 'Bar', + superclasses => ['Foo'], + methods => { + foo => sub {'Bar::foo'}, + bar => sub {'Bar::bar'}, + } +); +isa_ok( $Bar, 'Class::MOP::Class' ); + +ok( $Bar->has_method('foo'), '... Bar->has_method(foo)' ); +ok( $Bar->has_method('bar'), '... Bar->has_method(bar)' ); + +is( Bar->foo, 'Bar::foo', '... Bar->foo == Bar::foo' ); +is( Bar->bar, 'Bar::bar', '... Bar->bar == Bar::bar' ); + +is( exception { + $Bar->add_method( 'foo' => sub {'Bar::foo v2'} ); +}, undef, '... overwriting a method is fine' ); + +is_deeply( [ Class::MOP::get_code_info( $Bar->get_method('foo')->body ) ], + [ "Bar", "foo" ], "subname applied to anonymous method" ); + +ok( $Bar->has_method('foo'), '... Bar-> (still) has_method(foo)' ); +is( Bar->foo, 'Bar::foo v2', '... Bar->foo == "Bar::foo v2"' ); + +is_deeply( + [ sort $Bar->get_method_list ], + [qw(bar foo meta)], + '... got the right method list for Bar' +); + +is_deeply( + [ + map { $_->name => $_ } + sort { $a->name cmp $b->name } $Bar->get_all_methods() + ], + [ + map { $_->name => $_ } + sort { $a->name cmp $b->name } ( + $Foo->get_method('FOO_CONSTANT'), + $Foo->get_method('baaz'), + $Foo->get_method('bang'), + $Bar->get_method('bar'), + ( + map { $Foo->get_method($_) } + qw( + baz + blah + bork + cake + evaled_foo + floob + ) + ), + $Bar->get_method('foo'), + $Bar->get_method('meta'), + $Foo->get_method('pie'), + ( map { $Bar->find_next_method_by_name($_) } @universal_methods ) + ) + ], + '... got the right list of applicable methods for Bar' +); + +my $method = Class::MOP::Method->wrap( + name => 'objecty', + package_name => 'Whatever', + body => sub {q{I am an object, and I feel an object's pain}}, +); + +Bar->meta->add_method( $method->name, $method ); + +my $new_method = Bar->meta->get_method('objecty'); + +isnt( $method, $new_method, + 'add_method clones method objects as they are added' ); +is( $new_method->original_method, $method, + '... the cloned method has the correct original method' ) + or diag $new_method->dump; + +{ + package CustomAccessor; + + use Class::MOP; + + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->add_attribute( + foo => ( + accessor => 'foo', + ) + ); + + { + no warnings 'redefine', 'once'; + *foo = sub { + my $self = shift; + $self->{custom_store} = $_[0]; + }; + } + + $meta->add_around_method_modifier( + 'foo', + sub { + my $orig = shift; + $orig->(@_); + } + ); + + sub new { + return bless {}, shift; + } +} + +{ + my $o = CustomAccessor->new; + my $str = 'string'; + + $o->foo($str); + + is( + $o->{custom_store}, $str, + 'Custom glob-assignment-created accessor still has method modifier' + ); +} + +{ + # Since the sub reference below is not a closure, Perl caches it and uses + # the same reference each time through the loop. See RT #48985 for the + # bug. + foreach my $ns ( qw( Foo2 Bar2 Baz2 ) ) { + my $meta = Class::MOP::Class->create($ns); + + my $sub = sub { }; + + $meta->add_method( 'foo', $sub ); + + my $method = $meta->get_method('foo'); + ok( $method, 'Got the foo method back' ); + } +} + +{ + package HasConstants; + + use constant FOO => 1; + use constant BAR => []; + use constant BAZ => {}; + use constant UNDEF => undef; + + sub quux {1} + sub thing {1} +} + +my $HC = Class::MOP::Class->initialize('HasConstants'); + +is_deeply( + [ sort $HC->get_method_list ], + [qw( BAR BAZ FOO UNDEF quux thing )], + 'get_method_list handles constants properly' +); + +is_deeply( + [ sort map { $_->name } $HC->_get_local_methods ], + [qw( BAR BAZ FOO UNDEF quux thing )], + '_get_local_methods handles constants properly' +); + +{ + package DeleteFromMe; + sub foo { 1 } +} + +{ + my $DFMmeta = Class::MOP::Class->initialize('DeleteFromMe'); + ok($DFMmeta->get_method('foo')); + + delete $DeleteFromMe::{foo}; + + ok(!$DFMmeta->get_method('foo')); + ok(!DeleteFromMe->can('foo')); +} + +{ + my $baz_meta = Class::MOP::Class->initialize('Baz'); + $baz_meta->add_method(foo => sub { }); + my $stash = Package::Stash->new('Baz'); + $stash->remove_symbol('&foo'); + is_deeply([$baz_meta->get_method_list], [], "method is deleted"); + ok(!Baz->can('foo'), "Baz can't foo"); +} + + +done_testing; diff --git a/t/cmop/modify_parent_method.t b/t/cmop/modify_parent_method.t new file mode 100644 index 0000000..8ba6c43 --- /dev/null +++ b/t/cmop/modify_parent_method.t @@ -0,0 +1,99 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; + +my @calls; + +{ + package Parent; + + use strict; + use warnings; + use metaclass; + + use Carp 'confess'; + + sub method { push @calls, 'Parent::method' } + + package Child; + + use strict; + use warnings; + use metaclass; + + use parent -norequire => 'Parent'; + + Child->meta->add_around_method_modifier( + 'method' => sub { + my $orig = shift; + push @calls, 'before Child::method'; + $orig->(@_); + push @calls, 'after Child::method'; + } + ); +} + +Parent->method; + +is_deeply( + [ splice @calls ], + [ + 'Parent::method', + ] +); + +Child->method; + +is_deeply( + [ splice @calls ], + [ + 'before Child::method', + 'Parent::method', + 'after Child::method', + ] +); + +{ + package Parent; + + Parent->meta->add_around_method_modifier( + 'method' => sub { + my $orig = shift; + push @calls, 'before Parent::method'; + $orig->(@_); + push @calls, 'after Parent::method'; + } + ); +} + +Parent->method; + +is_deeply( + [ splice @calls ], + [ + 'before Parent::method', + 'Parent::method', + 'after Parent::method', + ] +); + +Child->method; + +TODO: { + local $TODO = "pending fix"; + is_deeply( + [ splice @calls ], + [ + 'before Child::method', + 'before Parent::method', + 'Parent::method', + 'after Parent::method', + 'after Child::method', + ], + "cache is correctly invalidated when the parent method is wrapped" + ); +} + +done_testing; diff --git a/t/cmop/new_and_clone_metaclasses.t b/t/cmop/new_and_clone_metaclasses.t new file mode 100644 index 0000000..1212c97 --- /dev/null +++ b/t/cmop/new_and_clone_metaclasses.t @@ -0,0 +1,124 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +use lib 't/cmop/lib'; + +# make sure the Class::MOP::Class->meta does the right thing + +my $meta = Class::MOP::Class->meta(); +isa_ok($meta, 'Class::MOP::Class'); + +my $new_meta = $meta->new_object('package' => 'Class::MOP::Class'); +isa_ok($new_meta, 'Class::MOP::Class'); +is($new_meta, $meta, '... it still creates the singleton'); + +my $cloned_meta = $meta->clone_object($meta); +isa_ok($cloned_meta, 'Class::MOP::Class'); +is($cloned_meta, $meta, '... it creates the singleton even if you try to clone it'); + +# make sure other metaclasses do the right thing + +{ + package Foo; + use metaclass; +} + +my $foo_meta = Foo->meta; +isa_ok($foo_meta, 'Class::MOP::Class'); + +is($meta->new_object('package' => 'Foo'), $foo_meta, '... got the right Foo->meta singleton'); +is($meta->clone_object($foo_meta), $foo_meta, '... cloning got the right Foo->meta singleton'); + +# make sure subclassed of Class::MOP::Class do the right thing + +my $my_meta = MyMetaClass->meta; +isa_ok($my_meta, 'Class::MOP::Class'); + +my $new_my_meta = $my_meta->new_object('package' => 'MyMetaClass'); +isa_ok($new_my_meta, 'Class::MOP::Class'); +is($new_my_meta, $my_meta, '... even subclasses still create the singleton'); + +my $cloned_my_meta = $meta->clone_object($my_meta); +isa_ok($cloned_my_meta, 'Class::MOP::Class'); +is($cloned_my_meta, $my_meta, '... and subclasses creates the singleton even if you try to clone it'); + +is($my_meta->new_object('package' => 'Foo'), $foo_meta, '... got the right Foo->meta singleton (w/subclass)'); +is($meta->clone_object($foo_meta), $foo_meta, '... cloning got the right Foo->meta singleton (w/subclass)'); + +# now create a metaclass for real + +my $bar_meta = $my_meta->new_object('package' => 'Bar'); +isa_ok($bar_meta, 'Class::MOP::Class'); + +is($bar_meta->name, 'Bar', '... got the right name for the Bar metaclass'); +is($bar_meta->version, undef, '... Bar does not exists, so it has no version'); + +$bar_meta->superclasses('Foo'); + +# check with MyMetaClass + +{ + package Baz; + use metaclass 'MyMetaClass'; +} + +my $baz_meta = Baz->meta; +isa_ok($baz_meta, 'Class::MOP::Class'); +isa_ok($baz_meta, 'MyMetaClass'); + +is($my_meta->new_object('package' => 'Baz'), $baz_meta, '... got the right Baz->meta singleton'); +is($my_meta->clone_object($baz_meta), $baz_meta, '... cloning got the right Baz->meta singleton'); + +$baz_meta->superclasses('Bar'); + +# now create a regular objects for real + +my $foo = $foo_meta->new_object(); +isa_ok($foo, 'Foo'); + +my $bar = $bar_meta->new_object(); +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +my $baz = $baz_meta->new_object(); +isa_ok($baz, 'Baz'); +isa_ok($baz, 'Bar'); +isa_ok($baz, 'Foo'); + +my $cloned_foo = $foo_meta->clone_object($foo); +isa_ok($cloned_foo, 'Foo'); + +isnt($cloned_foo, $foo, '... $cloned_foo is a new object different from $foo'); + +# check some errors + +isnt( exception { + $foo_meta->clone_object($meta); +}, undef, '... this dies as expected' ); + +# test stuff + +{ + package FooBar; + use metaclass; + + FooBar->meta->add_attribute('test'); +} + +my $attr = FooBar->meta->get_attribute('test'); +isa_ok($attr, 'Class::MOP::Attribute'); + +my $attr_clone = $attr->clone(); +isa_ok($attr_clone, 'Class::MOP::Attribute'); + +isnt($attr, $attr_clone, '... we successfully cloned our attributes'); +is($attr->associated_class, + $attr_clone->associated_class, + '... we successfully did not clone our associated metaclass'); + +done_testing; diff --git a/t/cmop/null_stash.t b/t/cmop/null_stash.t new file mode 100644 index 0000000..ee5d363 --- /dev/null +++ b/t/cmop/null_stash.t @@ -0,0 +1,11 @@ +use strict; +use warnings; +use Test::More; + +use Class::MOP; +my $non = Class::MOP::Class->initialize('Non::Existent::Package'); +$non->get_method('foo'); + +pass("empty stashes don't segfault"); + +done_testing; diff --git a/t/cmop/numeric_defaults.t b/t/cmop/numeric_defaults.t new file mode 100644 index 0000000..4c3102a --- /dev/null +++ b/t/cmop/numeric_defaults.t @@ -0,0 +1,124 @@ +use strict; +use warnings; +use Test::More; +use B; +use Class::MOP; + +my @int_defaults = ( + 100, + -2, + 01234, + 0xFF, +); + +my @num_defaults = ( + 10.5, + -20.0, + 1e3, + 1.3e-10, +); + +my @string_defaults = ( + 'foo', + '', + '100', + '10.5', + '1e3', + '0 but true', + '01234', + '09876', + '0xFF', +); + +for my $default (@int_defaults) { + my $copy = $default; # so we can print it out without modifying flags + my $attr = Class::MOP::Attribute->new( + foo => (default => $default, reader => 'foo'), + ); + my $meta = Class::MOP::Class->create_anon_class( + attributes => [$attr], + methods => {bar => sub { $default }}, + ); + + my $obj = $meta->new_object; + for my $meth (qw(foo bar)) { + my $val = $obj->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int ($copy)"); + ok(!($flags & B::SVf_POK), "not a string ($copy)"); + } + + $meta->make_immutable; + + my $immutable_obj = $meta->name->new; + for my $meth (qw(foo bar)) { + my $val = $immutable_obj->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int ($copy) (immutable)"); + ok(!($flags & B::SVf_POK), "not a string ($copy) (immutable)"); + } +} + +for my $default (@num_defaults) { + my $copy = $default; # so we can print it out without modifying flags + my $attr = Class::MOP::Attribute->new( + foo => (default => $default, reader => 'foo'), + ); + my $meta = Class::MOP::Class->create_anon_class( + attributes => [$attr], + methods => {bar => sub { $default }}, + ); + + my $obj = $meta->new_object; + for my $meth (qw(foo bar)) { + my $val = $obj->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num ($copy)"); + ok(!($flags & B::SVf_POK), "not a string ($copy)"); + } + + $meta->make_immutable; + + my $immutable_obj = $meta->name->new; + for my $meth (qw(foo bar)) { + my $val = $immutable_obj->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num ($copy) (immutable)"); + ok(!($flags & B::SVf_POK), "not a string ($copy) (immutable)"); + } +} + +for my $default (@string_defaults) { + my $copy = $default; # so we can print it out without modifying flags + my $attr = Class::MOP::Attribute->new( + foo => (default => $default, reader => 'foo'), + ); + my $meta = Class::MOP::Class->create_anon_class( + attributes => [$attr], + methods => {bar => sub { $default }}, + ); + + my $obj = $meta->new_object; + for my $meth (qw(foo bar)) { + my $val = $obj->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_POK, "it's a string ($copy)"); + } + + $meta->make_immutable; + + my $immutable_obj = $meta->name->new; + for my $meth (qw(foo bar)) { + my $val = $immutable_obj->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_POK, "it's a string ($copy) (immutable)"); + } +} + +done_testing; diff --git a/t/cmop/package_variables.t b/t/cmop/package_variables.t new file mode 100644 index 0000000..bcf960a --- /dev/null +++ b/t/cmop/package_variables.t @@ -0,0 +1,230 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + package Foo; + use metaclass; +} + +=pod + +This is the same test as 080_meta_package.t just here +we call all the methods through Class::MOP::Class. + +=cut + +# ---------------------------------------------------------------------- +## tests adding a HASH + +ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); +ok(!Foo->meta->has_package_symbol('%foo'), '... the meta agrees'); + +is( exception { + Foo->meta->add_package_symbol('%foo' => { one => 1 }); +}, undef, '... created %Foo::foo successfully' ); + +# ... scalar should NOT be created here + +ok(!Foo->meta->has_package_symbol('$foo'), '... SCALAR shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('@foo'), '... ARRAY shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('&foo'), '... CODE shouldnt have been created too'); + +ok(defined($Foo::{foo}), '... the %foo slot was created successfully'); +ok(Foo->meta->has_package_symbol('%foo'), '... the meta agrees'); + +# check the value ... + +{ + no strict 'refs'; + ok(exists ${'Foo::foo'}{one}, '... our %foo was initialized correctly'); + is(${'Foo::foo'}{one}, 1, '... our %foo was initialized correctly'); +} + +my $foo = Foo->meta->get_package_symbol('%foo'); +is_deeply({ one => 1 }, $foo, '... got the right package variable back'); + +# ... make sure changes propogate up + +$foo->{two} = 2; + +{ + no strict 'refs'; + is(\%{'Foo::foo'}, Foo->meta->get_package_symbol('%foo'), '... our %foo is the same as the metas'); + + ok(exists ${'Foo::foo'}{two}, '... our %foo was updated correctly'); + is(${'Foo::foo'}{two}, 2, '... our %foo was updated correctly'); +} + +# ---------------------------------------------------------------------- +## test adding an ARRAY + +ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); + +is( exception { + Foo->meta->add_package_symbol('@bar' => [ 1, 2, 3 ]); +}, undef, '... created @Foo::bar successfully' ); + +ok(defined($Foo::{bar}), '... the @bar slot was created successfully'); +ok(Foo->meta->has_package_symbol('@bar'), '... the meta agrees'); + +# ... why does this not work ... + +ok(!Foo->meta->has_package_symbol('$bar'), '... SCALAR shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('%bar'), '... HASH shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('&bar'), '... CODE shouldnt have been created too'); + +# check the value itself + +{ + no strict 'refs'; + is(scalar @{'Foo::bar'}, 3, '... our @bar was initialized correctly'); + is(${'Foo::bar'}[1], 2, '... our @bar was initialized correctly'); +} + +# ---------------------------------------------------------------------- +## test adding a SCALAR + +ok(!defined($Foo::{baz}), '... the $baz slot has not been created yet'); + +is( exception { + Foo->meta->add_package_symbol('$baz' => 10); +}, undef, '... created $Foo::baz successfully' ); + +ok(defined($Foo::{baz}), '... the $baz slot was created successfully'); +ok(Foo->meta->has_package_symbol('$baz'), '... the meta agrees'); + +ok(!Foo->meta->has_package_symbol('@baz'), '... ARRAY shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('%baz'), '... HASH shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('&baz'), '... CODE shouldnt have been created too'); + +is(${Foo->meta->get_package_symbol('$baz')}, 10, '... got the right value back'); + +{ + no strict 'refs'; + ${'Foo::baz'} = 1; + + is(${'Foo::baz'}, 1, '... our $baz was assigned to correctly'); + is(${Foo->meta->get_package_symbol('$baz')}, 1, '... the meta agrees'); +} + +# ---------------------------------------------------------------------- +## test adding a CODE + +ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet'); + +is( exception { + Foo->meta->add_package_symbol('&funk' => sub { "Foo::funk" }); +}, undef, '... created &Foo::funk successfully' ); + +ok(defined($Foo::{funk}), '... the &funk slot was created successfully'); +ok(Foo->meta->has_package_symbol('&funk'), '... the meta agrees'); + +ok(!Foo->meta->has_package_symbol('$funk'), '... SCALAR shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('@funk'), '... ARRAY shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('%funk'), '... HASH shouldnt have been created too'); + +{ + no strict 'refs'; + ok(defined &{'Foo::funk'}, '... our &funk exists'); +} + +is(Foo->funk(), 'Foo::funk', '... got the right value from the function'); + +# ---------------------------------------------------------------------- +## test multiple slots in the glob + +my $ARRAY = [ 1, 2, 3 ]; +my $CODE = sub { "Foo::foo" }; + +is( exception { + Foo->meta->add_package_symbol('@foo' => $ARRAY); +}, undef, '... created @Foo::foo successfully' ); + +ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot was added successfully'); +is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); + +is( exception { + Foo->meta->add_package_symbol('&foo' => $CODE); +}, undef, '... created &Foo::foo successfully' ); + +ok(Foo->meta->has_package_symbol('&foo'), '... the meta agrees'); +is(Foo->meta->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); + +is( exception { + Foo->meta->add_package_symbol('$foo' => 'Foo::foo'); +}, undef, '... created $Foo::foo successfully' ); + +ok(Foo->meta->has_package_symbol('$foo'), '... the meta agrees'); +my $SCALAR = Foo->meta->get_package_symbol('$foo'); +is($$SCALAR, 'Foo::foo', '... got the right scalar value back'); + +{ + no strict 'refs'; + is(${'Foo::foo'}, 'Foo::foo', '... got the right value from the scalar'); +} + +is( exception { + Foo->meta->remove_package_symbol('%foo'); +}, undef, '... removed %Foo::foo successfully' ); + +ok(!Foo->meta->has_package_symbol('%foo'), '... the %foo slot was removed successfully'); +ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists'); +ok(Foo->meta->has_package_symbol('&foo'), '... the &foo slot still exists'); +ok(Foo->meta->has_package_symbol('$foo'), '... the $foo slot still exists'); + +is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); +is(Foo->meta->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); +is(Foo->meta->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); + ok(defined(*{"Foo::foo"}{CODE}), '... the &foo slot has NOT been removed'); + ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); +} + +is( exception { + Foo->meta->remove_package_symbol('&foo'); +}, undef, '... removed &Foo::foo successfully' ); + +ok(!Foo->meta->has_package_symbol('&foo'), '... the &foo slot no longer exists'); + +ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists'); +ok(Foo->meta->has_package_symbol('$foo'), '... the $foo slot still exists'); + +is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); +is(Foo->meta->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); + ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); +} + +is( exception { + Foo->meta->remove_package_symbol('$foo'); +}, undef, '... removed $Foo::foo successfully' ); + +ok(!Foo->meta->has_package_symbol('$foo'), '... the $foo slot no longer exists'); + +ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists'); + +is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); + ok(!defined(${"Foo::foo"}), '... the $foo slot has now been removed'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); +} + +done_testing; diff --git a/t/cmop/random_eval_bug.t b/t/cmop/random_eval_bug.t new file mode 100644 index 0000000..285edb0 --- /dev/null +++ b/t/cmop/random_eval_bug.t @@ -0,0 +1,51 @@ +use strict; +use warnings; + +use Test::More; + +use Class::MOP; + +=pod + +This tests a bug which is fixed in 0.22 by localizing all the $@'s around any +evals. + +This a real pain to track down. + +Moral of the story: + + ALWAYS localize your globals :) + +=cut + +{ + package Company; + use strict; + use warnings; + use metaclass; + + sub new { + my ($class) = @_; + return bless {} => $class; + } + + sub employees { + die "This didnt work"; + } + + sub DESTROY { + my $self = shift; + foreach + my $method ( $self->meta->find_all_methods_by_name('DEMOLISH') ) { + $method->{code}->($self); + } + } +} + +eval { + my $c = Company->new(); + $c->employees(); +}; +ok( $@, '... we die correctly with bad args' ); + +done_testing; diff --git a/t/cmop/rebless_instance.t b/t/cmop/rebless_instance.t new file mode 100644 index 0000000..4cbefd6 --- /dev/null +++ b/t/cmop/rebless_instance.t @@ -0,0 +1,95 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Scalar::Util 'blessed'; + +{ + package Parent; + use metaclass; + + sub new { bless {} => shift } + sub whoami { "parent" } + sub parent { "parent" } + + package Child; + use metaclass; + use parent -norequire => 'Parent'; + + sub whoami { "child" } + sub child { "child" } + + package LeftField; + use metaclass; + + sub new { bless {} => shift } + sub whoami { "leftfield" } + sub myhax { "areleet" } +} + +# basic tests +my $foo = Parent->new; +is(blessed($foo), 'Parent', 'Parent->new gives a Parent'); +is($foo->whoami, "parent", 'Parent->whoami gives parent'); +is($foo->parent, "parent", 'Parent->parent gives parent'); +isnt( exception { $foo->child }, undef, "Parent->child method doesn't exist" ); + +Child->meta->rebless_instance($foo); +is(blessed($foo), 'Child', 'rebless_instance really reblessed the instance'); +is($foo->whoami, "child", 'reblessed->whoami gives child'); +is($foo->parent, "parent", 'reblessed->parent gives parent'); +is($foo->child, "child", 'reblessed->child gives child'); + +like( exception { LeftField->meta->rebless_instance($foo) }, qr/You may rebless only into a subclass of \(Child\), of which \(LeftField\) isn't\./ ); + +like( exception { Class::MOP::Class->initialize("NonExistent")->rebless_instance($foo) }, qr/You may rebless only into a subclass of \(Child\), of which \(NonExistent\) isn't\./ ); + +Parent->meta->rebless_instance_back($foo); +is(blessed($foo), 'Parent', 'Parent->new gives a Parent'); +is($foo->whoami, "parent", 'Parent->whoami gives parent'); +is($foo->parent, "parent", 'Parent->parent gives parent'); +isnt( exception { $foo->child }, undef, "Parent->child method doesn't exist" ); + +like( exception { LeftField->meta->rebless_instance_back($foo) }, qr/You may rebless only into a superclass of \(Parent\), of which \(LeftField\) isn't\./ ); + +like( exception { Class::MOP::Class->initialize("NonExistent")->rebless_instance_back($foo) }, qr/You may rebless only into a superclass of \(Parent\), of which \(NonExistent\) isn't\./ ); + +# make sure our ->meta is still sane +my $bar = Parent->new; +is(blessed($bar), 'Parent', "sanity check"); +is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class"); +is($bar->meta->name, 'Parent', "this Class::MOP::Class instance is for Parent"); + +ok($bar->meta->has_method('new'), 'metaclass has "new" method'); +ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method'); +ok($bar->meta->has_method('parent'), 'metaclass has "parent" method'); + +is(blessed($bar->meta->new_object), 'Parent', 'new_object gives a Parent'); + +Child->meta->rebless_instance($bar); +is(blessed($bar), 'Child', "rebless really reblessed"); +is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class"); +is($bar->meta->name, 'Child', "this Class::MOP::Class instance is for Child"); + +ok($bar->meta->find_method_by_name('new'), 'metaclass has "new" method'); +ok($bar->meta->find_method_by_name('parent'), 'metaclass has "parent" method'); +ok(!$bar->meta->has_method('new'), 'no "new" method in this class'); +ok(!$bar->meta->has_method('parent'), 'no "parent" method in this class'); +ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method'); +ok($bar->meta->has_method('child'), 'metaclass has "child" method'); + +is(blessed($bar->meta->new_object), 'Child', 'new_object gives a Child'); + +Parent->meta->rebless_instance_back($bar); +is(blessed($bar), 'Parent', "sanity check"); +is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class"); +is($bar->meta->name, 'Parent', "this Class::MOP::Class instance is for Parent"); + +ok($bar->meta->has_method('new'), 'metaclass has "new" method'); +ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method'); +ok($bar->meta->has_method('parent'), 'metaclass has "parent" method'); + +is(blessed($bar->meta->new_object), 'Parent', 'new_object gives a Parent'); + +done_testing; diff --git a/t/cmop/rebless_instance_away.t b/t/cmop/rebless_instance_away.t new file mode 100644 index 0000000..ad411ec --- /dev/null +++ b/t/cmop/rebless_instance_away.t @@ -0,0 +1,44 @@ +use strict; +use warnings; +use Test::More; +use Class::MOP; + +my @calls; + +do { + package My::Meta::Class; + use parent 'Class::MOP::Class'; + + sub rebless_instance_away { + push @calls, [@_]; + shift->SUPER::rebless_instance_away(@_); + } +}; + +do { + package Parent; + use metaclass 'My::Meta::Class'; + + package Child; + use metaclass 'My::Meta::Class'; + use parent -norequire => 'Parent'; +}; + +my $person = Parent->meta->new_object; +Child->meta->rebless_instance($person); + +is(@calls, 1, "one call to rebless_instance_away"); +is($calls[0][0]->name, 'Parent', 'rebless_instance_away is called on the old metaclass'); +is($calls[0][1], $person, 'with the instance'); +is($calls[0][2]->name, 'Child', 'and the new metaclass'); +splice @calls; + +Child->meta->rebless_instance($person, foo => 1); +is($calls[0][0]->name, 'Child'); +is($calls[0][1], $person); +is($calls[0][2]->name, 'Child'); +is($calls[0][3], 'foo'); +is($calls[0][4], 1); +splice @calls; + +done_testing; diff --git a/t/cmop/rebless_overload.t b/t/cmop/rebless_overload.t new file mode 100644 index 0000000..c3a7a68 --- /dev/null +++ b/t/cmop/rebless_overload.t @@ -0,0 +1,27 @@ +use strict; +use warnings; +use Test::More; +use Class::MOP; + +do { + package Without::Overloading; + sub new { bless {}, shift } + + package With::Overloading; + use parent -norequire => 'Without::Overloading'; + use overload q{""} => sub { "overloaded" }; +}; + +my $without = bless {}, "Without::Overloading"; +like("$without", qr/^Without::Overloading/, "no overloading"); + +my $with = With::Overloading->new; +is("$with", "overloaded", "initial overloading works"); + + +my $meta = Class::MOP::Class->initialize('With::Overloading'); + +$meta->rebless_instance($without); +is("$without", "overloaded", "overloading after reblessing works"); + +done_testing; diff --git a/t/cmop/rebless_with_extra_params.t b/t/cmop/rebless_with_extra_params.t new file mode 100644 index 0000000..2493ec4 --- /dev/null +++ b/t/cmop/rebless_with_extra_params.t @@ -0,0 +1,95 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + package Foo; + use metaclass; + Foo->meta->add_attribute('bar' => (reader => 'bar')); + + sub new { (shift)->meta->new_object(@_) } + + package Bar; + use metaclass; + use parent -norequire => 'Foo'; + Bar->meta->add_attribute('baz' => (reader => 'baz', default => 'BAZ')); +} + +# normal ... +{ + my $foo = Foo->new(bar => 'BAR'); + isa_ok($foo, 'Foo'); + + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + + is( exception { + Bar->meta->rebless_instance($foo) + }, undef, '... this works' ); + + is($foo->bar, 'BAR', '... got the expect value'); + ok($foo->can('baz'), '... we have baz method now'); + is($foo->baz, 'BAZ', '... got the expect value'); + + is( exception { + Foo->meta->rebless_instance_back($foo) + }, undef, '... this works' ); + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); +} + +# with extra params ... +{ + my $foo = Foo->new(bar => 'BAR'); + isa_ok($foo, 'Foo'); + + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + + is( exception { + Bar->meta->rebless_instance($foo, (baz => 'FOO-BAZ')) + }, undef, '... this works' ); + + is($foo->bar, 'BAR', '... got the expect value'); + ok($foo->can('baz'), '... we have baz method now'); + is($foo->baz, 'FOO-BAZ', '... got the expect value'); + + is( exception { + Foo->meta->rebless_instance_back($foo) + }, undef, '... this works' ); + + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + ok(!exists($foo->{baz}), '... and the baz attribute was deinitialized'); +} + +# with extra params ... +{ + my $foo = Foo->new(bar => 'BAR'); + isa_ok($foo, 'Foo'); + + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + + is( exception { + Bar->meta->rebless_instance($foo, (bar => 'FOO-BAR', baz => 'FOO-BAZ')) + }, undef, '... this works' ); + + is($foo->bar, 'FOO-BAR', '... got the expect value'); + ok($foo->can('baz'), '... we have baz method now'); + is($foo->baz, 'FOO-BAZ', '... got the expect value'); + + is( exception { + Foo->meta->rebless_instance_back($foo) + }, undef, '... this works' ); + + is($foo->bar, 'FOO-BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + ok(!exists($foo->{baz}), '... and the baz attribute was deinitialized'); +} + +done_testing; diff --git a/t/cmop/scala_style_mixin_composition.t b/t/cmop/scala_style_mixin_composition.t new file mode 100644 index 0000000..428b77d --- /dev/null +++ b/t/cmop/scala_style_mixin_composition.t @@ -0,0 +1,172 @@ +use strict; +use warnings; + +use Test::More; +use Test::Requires { + 'SUPER' => 1.10, # skip all if not installed +}; + +=pod + +This test demonstrates how simple it is to create Scala Style +Class Mixin Composition. Below is an example taken from the +Scala web site's example section, and trancoded to Class::MOP. + +NOTE: +We require SUPER for this test to handle the issue with SUPER:: +being determined at compile time. + +L<http://scala.epfl.ch/intro/mixin.html> + +A class can only be used as a mixin in the definition of another +class, if this other class extends a subclass of the superclass +of the mixin. Since ColoredPoint3D extends Point3D and Point3D +extends Point2D which is the superclass of ColoredPoint2D, the +code above is well-formed. + + class Point2D(xc: Int, yc: Int) { + val x = xc; + val y = yc; + override def toString() = "x = " + x + ", y = " + y; + } + + class ColoredPoint2D(u: Int, v: Int, c: String) extends Point2D(u, v) { + val color = c; + def setColor(newCol: String): Unit = color = newCol; + override def toString() = super.toString() + ", col = " + color; + } + + class Point3D(xc: Int, yc: Int, zc: Int) extends Point2D(xc, yc) { + val z = zc; + override def toString() = super.toString() + ", z = " + z; + } + + class ColoredPoint3D(xc: Int, yc: Int, zc: Int, col: String) + extends Point3D(xc, yc, zc) + with ColoredPoint2D(xc, yc, col); + + + Console.println(new ColoredPoint3D(1, 2, 3, "blue").toString()) + + "x = 1, y = 2, z = 3, col = blue" + +=cut + +use Scalar::Util 'blessed'; +use Carp 'confess'; + +sub ::with ($) { + # fetch the metaclass for the + # caller and the mixin arg + my $metaclass = (caller)->meta; + my $mixin = (shift)->meta; + + # according to Scala, the + # the superclass of our class + # must be a subclass of the + # superclass of the mixin (see above) + my ($super_meta) = $metaclass->superclasses(); + my ($super_mixin) = $mixin->superclasses(); + ($super_meta->isa($super_mixin)) + || confess "The superclass must extend a subclass of the superclass of the mixin"; + + # collect all the attributes + # and clone them so they can + # associate with the new class + my @attributes = map { + $mixin->get_attribute($_)->clone() + } $mixin->get_attribute_list; + + my %methods = map { + my $method = $mixin->get_method($_); + # we want to ignore accessors since + # they will be created with the attrs + (blessed($method) && $method->isa('Class::MOP::Method::Accessor')) + ? () : ($_ => $method) + } $mixin->get_method_list; + + # NOTE: + # I assume that locally defined methods + # and attributes get precedence over those + # from the mixin. + + # add all the attributes in .... + foreach my $attr (@attributes) { + $metaclass->add_attribute($attr) + unless $metaclass->has_attribute($attr->name); + } + + # add all the methods in .... + foreach my $method_name (keys %methods) { + $metaclass->add_method($method_name => $methods{$method_name}) + unless $metaclass->has_method($method_name); + } +} + +{ + package Point2D; + use metaclass; + + Point2D->meta->add_attribute('$x' => ( + accessor => 'x', + init_arg => 'x', + )); + + Point2D->meta->add_attribute('$y' => ( + accessor => 'y', + init_arg => 'y', + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + sub toString { + my $self = shift; + "x = " . $self->x . ", y = " . $self->y; + } + + package ColoredPoint2D; + our @ISA = ('Point2D'); + + ColoredPoint2D->meta->add_attribute('$color' => ( + accessor => 'color', + init_arg => 'color', + )); + + sub toString { + my $self = shift; + $self->SUPER() . ', col = ' . $self->color; + } + + package Point3D; + our @ISA = ('Point2D'); + + Point3D->meta->add_attribute('$z' => ( + accessor => 'z', + init_arg => 'z', + )); + + sub toString { + my $self = shift; + $self->SUPER() . ', z = ' . $self->z; + } + + package ColoredPoint3D; + our @ISA = ('Point3D'); + + ::with('ColoredPoint2D'); + +} + +my $colored_point_3d = ColoredPoint3D->new(x => 1, y => 2, z => 3, color => 'blue'); +isa_ok($colored_point_3d, 'ColoredPoint3D'); +isa_ok($colored_point_3d, 'Point3D'); +isa_ok($colored_point_3d, 'Point2D'); + +is($colored_point_3d->toString(), + 'x = 1, y = 2, z = 3, col = blue', + '... got the right toString method'); + +done_testing; diff --git a/t/cmop/self_introspection.t b/t/cmop/self_introspection.t new file mode 100644 index 0000000..69128f2 --- /dev/null +++ b/t/cmop/self_introspection.t @@ -0,0 +1,359 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; +use Class::MOP::Class; +use Class::MOP::Package; +use Class::MOP::Module; + +{ + my $class = Class::MOP::Class->initialize('Foo'); + is($class->meta, Class::MOP::Class->meta, '... instance and class both lead to the same meta'); +} + +my $class_mop_class_meta = Class::MOP::Class->meta(); +isa_ok($class_mop_class_meta, 'Class::MOP::Class'); + +my $class_mop_package_meta = Class::MOP::Package->meta(); +isa_ok($class_mop_package_meta, 'Class::MOP::Package'); + +my $class_mop_module_meta = Class::MOP::Module->meta(); +isa_ok($class_mop_module_meta, 'Class::MOP::Module'); + +my @class_mop_package_methods = qw( + _new + + initialize reinitialize create create_anon is_anon + _free_anon _anon_cache_key _anon_package_prefix + + name + namespace + + add_package_symbol get_package_symbol has_package_symbol + remove_package_symbol get_or_add_package_symbol + list_all_package_symbols get_all_package_symbols remove_package_glob + + _package_stash + + DESTROY +); + +my @class_mop_module_methods = qw( + _new + + _instantiate_module + + version authority identifier create + + _anon_cache_key _anon_package_prefix +); + +my @class_mop_class_methods = qw( + _new + + is_pristine + + initialize reinitialize create + + create_anon_class is_anon_class + _anon_cache_key _anon_package_prefix + + instance_metaclass get_meta_instance + _inline_create_instance + _inline_rebless_instance + _inline_get_mop_slot _inline_set_mop_slot _inline_clear_mop_slot + _create_meta_instance + new_object clone_object + _inline_new_object _inline_default_value _inline_preserve_weak_metaclasses + _inline_slot_initializer _inline_extra_init _inline_fallback_constructor + _inline_generate_instance _inline_params _inline_slot_initializers + _inline_init_attr_from_constructor _inline_init_attr_from_default + _generate_fallback_constructor + _eval_environment + _construct_instance + _construct_class_instance + _clone_instance + rebless_instance rebless_instance_back rebless_instance_away + _force_rebless_instance _fixup_attributes_after_rebless + _check_metaclass_compatibility + _check_class_metaclass_compatibility _check_single_metaclass_compatibility + _class_metaclass_is_compatible _single_metaclass_is_compatible + _fix_metaclass_incompatibility _fix_class_metaclass_incompatibility + _fix_single_metaclass_incompatibility _base_metaclasses + _can_fix_metaclass_incompatibility + _class_metaclass_can_be_made_compatible + _single_metaclass_can_be_made_compatible + + _remove_generated_metaobjects + _restore_metaobjects_from + + add_meta_instance_dependencies remove_meta_instance_dependencies update_meta_instance_dependencies + add_dependent_meta_instance remove_dependent_meta_instance + invalidate_meta_instances invalidate_meta_instance + + superclasses subclasses direct_subclasses class_precedence_list + linearized_isa _method_lookup_order _superclasses_updated _superclass_metas + + get_all_method_names get_all_methods + find_method_by_name find_all_methods_by_name find_next_method_by_name + + add_before_method_modifier add_after_method_modifier add_around_method_modifier + + _attach_attribute + _post_add_attribute + remove_attribute + find_attribute_by_name + get_all_attributes + + is_mutable is_immutable make_mutable make_immutable + _initialize_immutable _install_inlined_code _inlined_methods + _add_inlined_method _inline_accessors _inline_constructor + _inline_destructor _immutable_options _real_ref_name + _rebless_as_immutable _rebless_as_mutable _remove_inlined_code + + _immutable_metaclass + immutable_trait immutable_options + constructor_name constructor_class destructor_class +); + +# check the class ... + +is_deeply([ sort $class_mop_class_meta->get_method_list ], [ sort @class_mop_class_methods ], '... got the correct method list for class'); + +foreach my $method_name (sort @class_mop_class_methods) { + ok($class_mop_class_meta->has_method($method_name), '... Class::MOP::Class->has_method(' . $method_name . ')'); + { + no strict 'refs'; + is($class_mop_class_meta->get_method($method_name)->body, + \&{'Class::MOP::Class::' . $method_name}, + '... Class::MOP::Class->get_method(' . $method_name . ') == &Class::MOP::Class::' . $method_name); + } +} + +## check the package .... + +is_deeply([ sort $class_mop_package_meta->get_method_list ], [ sort @class_mop_package_methods ], '... got the correct method list for package'); + +foreach my $method_name (sort @class_mop_package_methods) { + ok($class_mop_package_meta->has_method($method_name), '... Class::MOP::Package->has_method(' . $method_name . ')'); + { + no strict 'refs'; + is($class_mop_package_meta->get_method($method_name)->body, + \&{'Class::MOP::Package::' . $method_name}, + '... Class::MOP::Package->get_method(' . $method_name . ') == &Class::MOP::Package::' . $method_name); + } +} + +## check the module .... + +is_deeply([ sort $class_mop_module_meta->get_method_list ], [ sort @class_mop_module_methods ], '... got the correct method list for module'); + +foreach my $method_name (sort @class_mop_module_methods) { + ok($class_mop_module_meta->has_method($method_name), '... Class::MOP::Module->has_method(' . $method_name . ')'); + { + no strict 'refs'; + is($class_mop_module_meta->get_method($method_name)->body, + \&{'Class::MOP::Module::' . $method_name}, + '... Class::MOP::Module->get_method(' . $method_name . ') == &Class::MOP::Module::' . $method_name); + } +} + + +# check for imported functions which are not methods + +foreach my $non_method_name (qw( + confess + blessed + subname + svref_2object + )) { + ok(!$class_mop_class_meta->has_method($non_method_name), '... NOT Class::MOP::Class->has_method(' . $non_method_name . ')'); +} + +# check for the right attributes + +my @class_mop_package_attributes = ( + 'package', + 'namespace', +); + +my @class_mop_module_attributes = ( + 'version', + 'authority' +); + +my @class_mop_class_attributes = ( + 'superclasses', + 'instance_metaclass', + 'immutable_trait', + 'constructor_name', + 'constructor_class', + 'destructor_class', +); + +# check class + +is_deeply( + [ sort $class_mop_class_meta->get_attribute_list ], + [ sort @class_mop_class_attributes ], + '... got the right list of attributes' +); + +is_deeply( + [ sort keys %{$class_mop_class_meta->_attribute_map} ], + [ sort @class_mop_class_attributes ], + '... got the right list of attributes'); + +foreach my $attribute_name (sort @class_mop_class_attributes) { + ok($class_mop_class_meta->has_attribute($attribute_name), '... Class::MOP::Class->has_attribute(' . $attribute_name . ')'); + isa_ok($class_mop_class_meta->get_attribute($attribute_name), 'Class::MOP::Attribute'); +} + +# check module + +is_deeply( + [ sort $class_mop_package_meta->get_attribute_list ], + [ sort @class_mop_package_attributes ], + '... got the right list of attributes'); + +is_deeply( + [ sort keys %{$class_mop_package_meta->_attribute_map} ], + [ sort @class_mop_package_attributes ], + '... got the right list of attributes'); + +foreach my $attribute_name (sort @class_mop_package_attributes) { + ok($class_mop_package_meta->has_attribute($attribute_name), '... Class::MOP::Package->has_attribute(' . $attribute_name . ')'); + isa_ok($class_mop_package_meta->get_attribute($attribute_name), 'Class::MOP::Attribute'); +} + +# check package + +is_deeply( + [ sort $class_mop_module_meta->get_attribute_list ], + [ sort @class_mop_module_attributes ], + '... got the right list of attributes'); + +is_deeply( + [ sort keys %{$class_mop_module_meta->_attribute_map} ], + [ sort @class_mop_module_attributes ], + '... got the right list of attributes'); + +foreach my $attribute_name (sort @class_mop_module_attributes) { + ok($class_mop_module_meta->has_attribute($attribute_name), '... Class::MOP::Module->has_attribute(' . $attribute_name . ')'); + isa_ok($class_mop_module_meta->get_attribute($attribute_name), 'Class::MOP::Attribute'); +} + +## check the attributes themselves + +# ... package + +ok($class_mop_package_meta->get_attribute('package')->has_reader, '... Class::MOP::Class package has a reader'); +is(ref($class_mop_package_meta->get_attribute('package')->reader), 'HASH', '... Class::MOP::Class package\'s a reader is { name => sub { ... } }'); + +ok($class_mop_package_meta->get_attribute('package')->has_init_arg, '... Class::MOP::Class package has a init_arg'); +is($class_mop_package_meta->get_attribute('package')->init_arg, 'package', '... Class::MOP::Class package\'s a init_arg is package'); + +# ... class, but inherited from HasMethods +ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_reader, '... Class::MOP::Class method_metaclass has a reader'); +is_deeply($class_mop_class_meta->find_attribute_by_name('method_metaclass')->reader, + { 'method_metaclass' => \&Class::MOP::Mixin::HasMethods::method_metaclass }, + '... Class::MOP::Class method_metaclass\'s a reader is &method_metaclass'); + +ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_init_arg, '... Class::MOP::Class method_metaclass has a init_arg'); +is($class_mop_class_meta->find_attribute_by_name('method_metaclass')->init_arg, + 'method_metaclass', + '... Class::MOP::Class method_metaclass\'s init_arg is method_metaclass'); + +ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_default, '... Class::MOP::Class method_metaclass has a default'); +is($class_mop_class_meta->find_attribute_by_name('method_metaclass')->default, + 'Class::MOP::Method', + '... Class::MOP::Class method_metaclass\'s a default is Class::MOP:::Method'); + +ok($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->has_reader, '... Class::MOP::Class wrapped_method_metaclass has a reader'); +is_deeply($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->reader, + { 'wrapped_method_metaclass' => \&Class::MOP::Mixin::HasMethods::wrapped_method_metaclass }, + '... Class::MOP::Class wrapped_method_metaclass\'s a reader is &wrapped_method_metaclass'); + +ok($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->has_init_arg, '... Class::MOP::Class wrapped_method_metaclass has a init_arg'); +is($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->init_arg, + 'wrapped_method_metaclass', + '... Class::MOP::Class wrapped_method_metaclass\'s init_arg is wrapped_method_metaclass'); + +ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_default, '... Class::MOP::Class method_metaclass has a default'); +is($class_mop_class_meta->find_attribute_by_name('method_metaclass')->default, + 'Class::MOP::Method', + '... Class::MOP::Class method_metaclass\'s a default is Class::MOP:::Method'); + + +# ... class, but inherited from HasAttributes + +ok($class_mop_class_meta->find_attribute_by_name('attributes')->has_reader, '... Class::MOP::Class attributes has a reader'); +is_deeply($class_mop_class_meta->find_attribute_by_name('attributes')->reader, + { '_attribute_map' => \&Class::MOP::Mixin::HasAttributes::_attribute_map }, + '... Class::MOP::Class attributes\'s a reader is &_attribute_map'); + +ok($class_mop_class_meta->find_attribute_by_name('attributes')->has_init_arg, '... Class::MOP::Class attributes has a init_arg'); +is($class_mop_class_meta->find_attribute_by_name('attributes')->init_arg, + 'attributes', + '... Class::MOP::Class attributes\'s a init_arg is attributes'); + +ok($class_mop_class_meta->find_attribute_by_name('attributes')->has_default, '... Class::MOP::Class attributes has a default'); +is_deeply($class_mop_class_meta->find_attribute_by_name('attributes')->default('Foo'), + {}, + '... Class::MOP::Class attributes\'s a default of {}'); + +ok($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->has_reader, '... Class::MOP::Class attribute_metaclass has a reader'); +is_deeply($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->reader, + { 'attribute_metaclass' => \&Class::MOP::Mixin::HasAttributes::attribute_metaclass }, + '... Class::MOP::Class attribute_metaclass\'s a reader is &attribute_metaclass'); + +ok($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->has_init_arg, '... Class::MOP::Class attribute_metaclass has a init_arg'); +is($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->init_arg, + 'attribute_metaclass', + '... Class::MOP::Class attribute_metaclass\'s a init_arg is attribute_metaclass'); + +ok($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->has_default, '... Class::MOP::Class attribute_metaclass has a default'); +is($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->default, + 'Class::MOP::Attribute', + '... Class::MOP::Class attribute_metaclass\'s a default is Class::MOP:::Attribute'); + +# check the values of some of the methods + +is($class_mop_class_meta->name, 'Class::MOP::Class', '... Class::MOP::Class->name'); +is($class_mop_class_meta->version, $Class::MOP::Class::VERSION, '... Class::MOP::Class->version'); + +if ( defined $Class::MOP::Class::VERSION ) { + ok($class_mop_class_meta->has_package_symbol('$VERSION'), '... Class::MOP::Class->has_package_symbol($VERSION)'); +} +is(${$class_mop_class_meta->get_package_symbol('$VERSION')}, + $Class::MOP::Class::VERSION, + '... Class::MOP::Class->get_package_symbol($VERSION)'); + +is_deeply( + [ $class_mop_class_meta->superclasses ], + [ qw/Class::MOP::Module Class::MOP::Mixin::HasAttributes Class::MOP::Mixin::HasMethods Class::MOP::Mixin::HasOverloads/ ], + '... Class::MOP::Class->superclasses == [ Class::MOP::Module ]'); + +is_deeply( + [ $class_mop_class_meta->class_precedence_list ], + [ qw/ + Class::MOP::Class + Class::MOP::Module + Class::MOP::Package + Class::MOP::Object + Class::MOP::Mixin + Class::MOP::Mixin::HasAttributes + Class::MOP::Mixin + Class::MOP::Mixin::HasMethods + Class::MOP::Mixin + Class::MOP::Mixin::HasOverloads + Class::MOP::Mixin + / ], + '... Class::MOP::Class->class_precedence_list == [ Class::MOP::Class Class::MOP::Module Class::MOP::Package ]'); + +is($class_mop_class_meta->attribute_metaclass, 'Class::MOP::Attribute', '... got the right value for attribute_metaclass'); +is($class_mop_class_meta->method_metaclass, 'Class::MOP::Method', '... got the right value for method_metaclass'); +is($class_mop_class_meta->instance_metaclass, 'Class::MOP::Instance', '... got the right value for instance_metaclass'); + +done_testing; diff --git a/t/cmop/subclasses.t b/t/cmop/subclasses.t new file mode 100644 index 0000000..3104bf4 --- /dev/null +++ b/t/cmop/subclasses.t @@ -0,0 +1,45 @@ +use strict; +use warnings; +use Test::More; +use Class::MOP; + +do { + package Grandparent; + use metaclass; + + package Parent; + use metaclass; + use parent -norequire => 'Grandparent'; + + package Uncle; + use metaclass; + use parent -norequire => 'Grandparent'; + + package Son; + use metaclass; + use parent -norequire => 'Parent'; + + package Daughter; + use metaclass; + use parent -norequire => 'Parent'; + + package Cousin; + use metaclass; + use parent -norequire => 'Uncle'; +}; + +is_deeply([sort Grandparent->meta->subclasses], ['Cousin', 'Daughter', 'Parent', 'Son', 'Uncle']); +is_deeply([sort Parent->meta->subclasses], ['Daughter', 'Son']); +is_deeply([sort Uncle->meta->subclasses], ['Cousin']); +is_deeply([sort Son->meta->subclasses], []); +is_deeply([sort Daughter->meta->subclasses], []); +is_deeply([sort Cousin->meta->subclasses], []); + +is_deeply([sort Grandparent->meta->direct_subclasses], ['Parent', 'Uncle']); +is_deeply([sort Parent->meta->direct_subclasses], ['Daughter', 'Son']); +is_deeply([sort Uncle->meta->direct_subclasses], ['Cousin']); +is_deeply([sort Son->meta->direct_subclasses], []); +is_deeply([sort Daughter->meta->direct_subclasses], []); +is_deeply([sort Cousin->meta->direct_subclasses], []); + +done_testing; diff --git a/t/cmop/subname.t b/t/cmop/subname.t new file mode 100644 index 0000000..6c113cc --- /dev/null +++ b/t/cmop/subname.t @@ -0,0 +1,42 @@ +use strict; +use warnings; + +use Test::More; + +use Class::MOP; + +{ + + package Origin; + sub bar { ( caller(0) )[3] } + + package Foo; +} + +my $Foo = Class::MOP::Class->initialize('Foo'); + +$Foo->add_method( foo => sub { ( caller(0) )[3] } ); + +is_deeply( + [ Class::MOP::get_code_info( $Foo->get_method('foo')->body ) ], + [ "Foo", "foo" ], + "subname applied to anonymous method", +); + +is( Foo->foo, "Foo::foo", "caller() aggrees" ); + +$Foo->add_method( bar => \&Origin::bar ); + +is( Origin->bar, "Origin::bar", "normal caller() operation in unrelated class" ); + +is_deeply( + [ Class::MOP::get_code_info( $Foo->get_method('foo')->body ) ], + [ "Foo", "foo" ], + "subname not applied if a name already exists", +); + +is( Foo->bar, "Origin::bar", "caller aggrees" ); + +is( Origin->bar, "Origin::bar", "unrelated class untouched" ); + +done_testing; diff --git a/t/cmop/universal_methods.t b/t/cmop/universal_methods.t new file mode 100644 index 0000000..0d3d646 --- /dev/null +++ b/t/cmop/universal_methods.t @@ -0,0 +1,38 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; + +my $meta_class = Class::MOP::Class->create_anon_class; + +my %methods = map { $_->name => 1 } $meta_class->get_all_methods(); +my %method_names = map { $_ => 1 } $meta_class->get_all_method_names(); + +my @universal_methods = qw/isa can VERSION/; +push @universal_methods, 'DOES' if $] >= 5.010; + +for my $method (@universal_methods) { + ok( + $meta_class->find_method_by_name($method), + "find_method_by_name finds UNIVERSAL method $method" + ); + ok( + $meta_class->find_next_method_by_name($method), + "find_next_method_by_name finds UNIVERSAL method $method" + ); + ok( + scalar $meta_class->find_all_methods_by_name($method), + "find_all_methods_by_name finds UNIVERSAL method $method" + ); + ok( + $methods{$method}, + "get_all_methods includes $method from UNIVERSAL" + ); + ok( + $method_names{$method}, + "get_all_method_names includes $method from UNIVERSAL" + ); +} + +done_testing; diff --git a/t/compat/composite_metaroles.t b/t/compat/composite_metaroles.t new file mode 100644 index 0000000..3171624 --- /dev/null +++ b/t/compat/composite_metaroles.t @@ -0,0 +1,44 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; +use Test::Moose; + +{ + package Foo::Role; + use Moose::Role; +} + +{ + package Bar::Role; + use Moose::Role; +} + +{ + package Parent; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { class => ['Foo::Role'] }, + ); +} + +{ + package Child; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { class => ['Foo::Role', 'Bar::Role'] }, + ); + ::is( ::exception { extends 'Parent' }, undef ); +} + +with_immutable { + isa_ok('Child', 'Parent'); + isa_ok(Child->meta, Parent->meta->_real_ref_name); + does_ok(Parent->meta, 'Foo::Role'); + does_ok(Child->meta, 'Foo::Role'); + does_ok(Child->meta, 'Bar::Role'); +} 'Parent', 'Child'; + +done_testing; diff --git a/t/compat/extends_nonmoose_that_isa_moose_with_metarole.t b/t/compat/extends_nonmoose_that_isa_moose_with_metarole.t new file mode 100644 index 0000000..db5e4b0 --- /dev/null +++ b/t/compat/extends_nonmoose_that_isa_moose_with_metarole.t @@ -0,0 +1,204 @@ +use strict; +use warnings; +use Test::More; +use Class::MOP (); + +{ + package My::Role; + use Moose::Role; +} + +{ + package SomeClass; + use Moose -traits => 'My::Role'; +} + +{ + package SubClassUseBase; + use parent -norequire => 'SomeClass'; +} + +{ + package SubSubClassUseBase; + use Moose; + use Test::More; + use Test::Fatal; + is( exception { + extends 'SubClassUseBase'; + }, undef, 'Can extend non-Moose class with parent class that is a Moose class with a meta role' ); +} + +{ + ok( SubSubClassUseBase->meta->meta->can('does_role') + && SubSubClassUseBase->meta->meta->does_role('My::Role'), + 'SubSubClassUseBase meta metaclass does the My::Role role' ); +} + +# Note, remove metaclasses of the 'use base' classes after each test, +# so that they have to be re-initialized - otherwise latter tests +# would not demonstrate the original issue. +Class::MOP::remove_metaclass_by_name('SubClassUseBase'); + +{ + package OtherClass; + use Moose; +} + +{ + package OtherSubClassUseBase; + use parent -norequire => 'OtherClass'; +} + +{ + package MultiParent1; + use Moose; + use Test::More; + use Test::Fatal; + is( exception { + extends qw( SubClassUseBase OtherSubClassUseBase ); + }, undef, 'Can extend two non-Moose classes with parents that are different Moose metaclasses' ); +} + +{ + ok( MultiParent1->meta->meta->can('does_role') + && MultiParent1->meta->meta->does_role('My::Role'), + 'MultiParent1 meta metaclass does the My::Role role' ); +} + +Class::MOP::remove_metaclass_by_name($_) + for qw( SubClassUseBase OtherSubClassUseBase ); + +{ + package MultiParent2; + use Moose; + use Test::More; + use Test::Fatal; + is( exception { + extends qw( OtherSubClassUseBase SubClassUseBase ); + }, undef, 'Can extend two non-Moose classes with parents that are different Moose metaclasses (reverse order)' ); +} + +{ + ok( MultiParent2->meta->meta->can('does_role') + && MultiParent2->meta->meta->does_role('My::Role'), + 'MultiParent2 meta metaclass does the My::Role role' ); +} + +Class::MOP::remove_metaclass_by_name($_) + for qw( SubClassUseBase OtherSubClassUseBase ); + +{ + package MultiParent3; + use Moose; + use Test::More; + use Test::Fatal; + is( exception { + extends qw( OtherClass SubClassUseBase ); + }, undef, 'Can extend one Moose class and one non-Moose class' ); +} + +{ + ok( MultiParent3->meta->meta->can('does_role') + && MultiParent3->meta->meta->does_role('My::Role'), + 'MultiParent3 meta metaclass does the My::Role role' ); +} + +Class::MOP::remove_metaclass_by_name($_) + for qw( SubClassUseBase OtherSubClassUseBase ); + +{ + package MultiParent4; + use Moose; + use Test::More; + use Test::Fatal; + is( exception { + extends qw( SubClassUseBase OtherClass ); + }, undef, 'Can extend one non-Moose class and one Moose class' ); +} + +{ + ok( MultiParent4->meta->meta->can('does_role') + && MultiParent4->meta->meta->does_role('My::Role'), + 'MultiParent4 meta metaclass does the My::Role role' ); +} + +Class::MOP::remove_metaclass_by_name($_) + for qw( SubClassUseBase OtherSubClassUseBase ); + +{ + package MultiChild1; + use Moose; + use Test::More; + use Test::Fatal; + is( exception { + extends 'MultiParent1'; + }, undef, 'Can extend class that itself extends two non-Moose classes with Moose parents' ); +} + +{ + ok( MultiChild1->meta->meta->can('does_role') + && MultiChild1->meta->meta->does_role('My::Role'), + 'MultiChild1 meta metaclass does the My::Role role' ); +} + +Class::MOP::remove_metaclass_by_name($_) + for qw( SubClassUseBase OtherSubClassUseBase ); + +{ + package MultiChild2; + use Moose; + use Test::More; + use Test::Fatal; + is( exception { + extends 'MultiParent2'; + }, undef, 'Can extend class that itself extends two non-Moose classes with Moose parents (reverse order)' ); +} + +{ + ok( MultiChild2->meta->meta->can('does_role') + && MultiChild2->meta->meta->does_role('My::Role'), + 'MultiChild2 meta metaclass does the My::Role role' ); +} + +Class::MOP::remove_metaclass_by_name($_) + for qw( SubClassUseBase OtherSubClassUseBase ); + +{ + package MultiChild3; + use Moose; + use Test::More; + use Test::Fatal; + is( exception { + extends 'MultiParent3'; + }, undef, 'Can extend class that itself extends one Moose and one non-Moose parent' ); +} + +{ + ok( MultiChild3->meta->meta->can('does_role') + && MultiChild3->meta->meta->does_role('My::Role'), + 'MultiChild3 meta metaclass does the My::Role role' ); +} + +Class::MOP::remove_metaclass_by_name($_) + for qw( SubClassUseBase OtherSubClassUseBase ); + +{ + package MultiChild4; + use Moose; + use Test::More; + use Test::Fatal; + is( exception { + extends 'MultiParent4'; + }, undef, 'Can extend class that itself extends one non-Moose and one Moose parent' ); +} + +{ + ok( MultiChild4->meta->meta->can('does_role') + && MultiChild4->meta->meta->does_role('My::Role'), + 'MultiChild4 meta metaclass does the My::Role role' ); +} + +Class::MOP::remove_metaclass_by_name($_) + for qw( SubClassUseBase OtherSubClassUseBase ); + +done_testing; diff --git a/t/compat/foreign_inheritence.t b/t/compat/foreign_inheritence.t new file mode 100644 index 0000000..1d3b0d8 --- /dev/null +++ b/t/compat/foreign_inheritence.t @@ -0,0 +1,88 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + + package Elk; + use strict; + use warnings; + + sub new { + my $class = shift; + bless { no_moose => "Elk" } => $class; + } + + sub no_moose { $_[0]->{no_moose} } + + package Foo::Moose; + use Moose; + + extends 'Elk'; + + has 'moose' => ( is => 'ro', default => 'Foo' ); + + sub new { + my $class = shift; + my $super = $class->SUPER::new(@_); + return $class->meta->new_object( '__INSTANCE__' => $super, @_ ); + } + + __PACKAGE__->meta->make_immutable( inline_constructor => 0, debug => 0 ); + + package Bucket; + use metaclass 'Class::MOP::Class'; + + __PACKAGE__->meta->add_attribute( + 'squeegee' => ( accessor => 'squeegee' ) ); + + package Old::Bucket::Nose; + + # see http://www.moosefoundation.org/moose_facts.htm + use Moose; + + extends 'Bucket'; + + package MyBase; + sub foo { } + + package Custom::Meta1; + use parent 'Moose::Meta::Class'; + + package Custom::Meta2; + use parent 'Moose::Meta::Class'; + + package SubClass1; + use metaclass 'Custom::Meta1'; + use Moose; + + extends 'MyBase'; + + package SubClass2; + use metaclass 'Custom::Meta2'; + use Moose; + + # XXX FIXME subclassing meta-attrs and immutable-ing the subclass fails +} + +my $foo_moose = Foo::Moose->new(); +isa_ok( $foo_moose, 'Foo::Moose' ); +isa_ok( $foo_moose, 'Elk' ); + +is( $foo_moose->no_moose, 'Elk', + '... got the right value from the Elk method' ); +is( $foo_moose->moose, 'Foo', + '... got the right value from the Foo::Moose method' ); + +is( exception { + Old::Bucket::Nose->meta->make_immutable( debug => 0 ); +}, undef, 'Immutability on Moose class extending Class::MOP class ok' ); + +is( exception { + SubClass2->meta->superclasses('MyBase'); +}, undef, 'Can subclass the same non-Moose class twice with different metaclasses' ); + +done_testing; diff --git a/t/compat/inc_hash.t b/t/compat/inc_hash.t new file mode 100644 index 0000000..25f6b47 --- /dev/null +++ b/t/compat/inc_hash.t @@ -0,0 +1,101 @@ +use strict; +use warnings; +use Test::More; +use lib 't/lib'; + +use Moose (); +use Module::Runtime 'module_notional_filename'; + +sub inc_ok { + local $Test::Builder::Level = $Test::Builder::Level + 1; + my ($class) = @_; + is($INC{module_notional_filename($class)}, '(set by Moose)'); +} + +sub no_inc_ok { + local $Test::Builder::Level = $Test::Builder::Level + 1; + my ($class) = @_; + ok(!exists $INC{module_notional_filename($class)}); +} + +{ + no_inc_ok('Foo'); + my $meta = Moose::Meta::Class->create('Foo'); + inc_ok('Foo'); +} +inc_ok('Foo'); + +{ + no_inc_ok('Bar'); + ok(!exists $INC{module_notional_filename('Bar')}); + my $meta = Class::MOP::Package->create('Bar'); + inc_ok('Bar'); +} +inc_ok('Bar'); + +my $anon_name; +{ + my $meta = Moose::Meta::Class->create_anon_class; + $anon_name = $meta->name; + inc_ok($anon_name); +} +no_inc_ok($anon_name); + +{ + no_inc_ok('Real::Package'); + require Real::Package; + like($INC{module_notional_filename('Real::Package')}, qr{t.lib.Real.Package\.pm$}); + my $meta = Moose::Meta::Class->create('Real::Package'); + like($INC{module_notional_filename('Real::Package')}, qr{t.lib.Real.Package\.pm$}); +} +like($INC{module_notional_filename('Real::Package')}, qr{t.lib.Real.Package\.pm$}); + +BEGIN { no_inc_ok('UseMoose') } +{ + package UseMoose; + use Moose; +} +BEGIN { inc_ok('UseMoose') } + +BEGIN { no_inc_ok('UseMooseRole') } +{ + package UseMooseRole; + use Moose::Role; +} +BEGIN { inc_ok('UseMooseRole') } + +BEGIN { + package My::Custom::Moose; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + also => ['Moose'], + ); + $INC{::module_notional_filename(__PACKAGE__)} = __FILE__; +} + +BEGIN { no_inc_ok('UseMooseCustom') } +{ + package UseMooseCustom; + use My::Custom::Moose; +} +BEGIN { inc_ok('UseMooseCustom') } + +BEGIN { + package My::Custom::Moose::Role; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + also => ['Moose::Role'], + ); + $INC{::module_notional_filename(__PACKAGE__)} = __FILE__; +} + +BEGIN { no_inc_ok('UseMooseCustomRole') } +{ + package UseMooseCustomRole; + use My::Custom::Moose::Role; +} +BEGIN { inc_ok('UseMooseCustomRole') } + +done_testing; diff --git a/t/compat/module_refresh_compat.t b/t/compat/module_refresh_compat.t new file mode 100644 index 0000000..a3a627b --- /dev/null +++ b/t/compat/module_refresh_compat.t @@ -0,0 +1,88 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Test::More; +use Test::Fatal; + +use File::Spec; +use File::Temp 'tempdir'; + +use Test::Requires 'Module::Refresh'; # skip all if not installed + +=pod + +First lets test some of our simple example modules ... + +=cut + +my @modules = qw[Foo Bar MyMooseA MyMooseB MyMooseObject]; + +do { + use_ok($_); + + is($_->meta->name, $_, '... initialized the meta correctly'); + + is( exception { + Module::Refresh->new->refresh_module($_ . '.pm') + }, undef, '... successfully refreshed ' ); +} foreach @modules; + +=pod + +Now, lets try something a little trickier +and actually change the module itself. + +=cut + +my $dir = tempdir( "MooseTest-XXXXX", CLEANUP => 1, TMPDIR => 1 ); +push @INC, $dir; + +my $test_module_file = File::Spec->catdir($dir, 'TestBaz.pm'); + +my $test_module_source_1 = q| +package TestBaz; +use Moose; +has 'foo' => (is => 'ro', isa => 'Int'); +1; +|; + +my $test_module_source_2 = q| +package TestBaz; +use Moose; +extends 'Foo'; +has 'foo' => (is => 'rw', isa => 'Int'); +1; +|; + +{ + open FILE, ">", $test_module_file + || die "Could not open $test_module_file because $!"; + print FILE $test_module_source_1; + close FILE; +} + +use_ok('TestBaz'); +is(TestBaz->meta->name, 'TestBaz', '... initialized the meta correctly'); +ok(TestBaz->meta->has_attribute('foo'), '... it has the foo attribute as well'); +ok(!TestBaz->isa('Foo'), '... TestBaz is not a Foo'); + +{ + open FILE, ">", $test_module_file + || die "Could not open $test_module_file because $!"; + print FILE $test_module_source_2; + close FILE; +} + +is( exception { + Module::Refresh->new->refresh_module('TestBaz.pm') +}, undef, '... successfully refreshed ' ); + +is(TestBaz->meta->name, 'TestBaz', '... initialized the meta correctly'); +ok(TestBaz->meta->has_attribute('foo'), '... it has the foo attribute as well'); +ok(TestBaz->isa('Foo'), '... TestBaz is a Foo'); + +unlink $test_module_file; + +done_testing; diff --git a/t/compat/moose_respects_base.t b/t/compat/moose_respects_base.t new file mode 100644 index 0000000..84b9fda --- /dev/null +++ b/t/compat/moose_respects_base.t @@ -0,0 +1,46 @@ +use strict; +use warnings; + +use Test::More; + + +=pod + +This test demonstrates that Moose will respect +a previously set @ISA using use base, and not +try to add Moose::Object to it. + +However, this is extremely order sensitive as +this test also demonstrates. + +=cut + +{ + package Foo; + use strict; + use warnings; + + sub foo { 'Foo::foo' } + + package Bar; + use parent -norequire => 'Foo'; + use Moose; + + sub new { (shift)->meta->new_object(@_) } + + package Baz; + use Moose; + use parent -norequire => 'Foo'; +} + +my $bar = Bar->new; +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); +ok(!$bar->isa('Moose::Object'), '... Bar is not Moose::Object subclass'); + +my $baz = Baz->new; +isa_ok($baz, 'Baz'); +isa_ok($baz, 'Foo'); +isa_ok($baz, 'Moose::Object'); + +done_testing; diff --git a/t/examples/Child_Parent_attr_inherit.t b/t/examples/Child_Parent_attr_inherit.t new file mode 100644 index 0000000..c84cc25 --- /dev/null +++ b/t/examples/Child_Parent_attr_inherit.t @@ -0,0 +1,136 @@ +use strict; +use warnings; + +use Test::More; + +=pod + +Some examples of triggers and how they can +be used to manage parent-child relationships. + +=cut + +{ + + package Parent; + use Moose; + + has 'last_name' => ( + is => 'rw', + isa => 'Str', + trigger => sub { + my $self = shift; + + # if the parents last-name changes + # then so do all the childrens + foreach my $child ( @{ $self->children } ) { + $child->last_name( $self->last_name ); + } + } + ); + + has 'children' => + ( is => 'rw', isa => 'ArrayRef', default => sub { [] } ); +} +{ + + package Child; + use Moose; + + has 'parent' => ( + is => 'rw', + isa => 'Parent', + required => 1, + trigger => sub { + my $self = shift; + + # if the parent is changed,.. + # make sure we update + $self->last_name( $self->parent->last_name ); + } + ); + + has 'last_name' => ( + is => 'rw', + isa => 'Str', + lazy => 1, + default => sub { (shift)->parent->last_name } + ); + +} + +my $parent = Parent->new( last_name => 'Smith' ); +isa_ok( $parent, 'Parent' ); + +is( $parent->last_name, 'Smith', + '... the parent has the last name we expected' ); + +$parent->children( [ map { Child->new( parent => $parent ) } ( 0 .. 3 ) ] ); + +foreach my $child ( @{ $parent->children } ) { + is( $child->last_name, $parent->last_name, + '... parent and child have the same last name (' + . $parent->last_name + . ')' ); +} + +$parent->last_name('Jones'); +is( $parent->last_name, 'Jones', '... the parent has the new last name' ); + +foreach my $child ( @{ $parent->children } ) { + is( $child->last_name, $parent->last_name, + '... parent and child have the same last name (' + . $parent->last_name + . ')' ); +} + +# make a new parent + +my $parent2 = Parent->new( last_name => 'Brown' ); +isa_ok( $parent2, 'Parent' ); + +# orphan the child + +my $orphan = pop @{ $parent->children }; + +# and then the new parent adopts it + +$orphan->parent($parent2); + +foreach my $child ( @{ $parent->children } ) { + is( $child->last_name, $parent->last_name, + '... parent and child have the same last name (' + . $parent->last_name + . ')' ); +} + +isnt( $orphan->last_name, $parent->last_name, + '... the orphan child does not have the same last name anymore (' + . $parent2->last_name + . ')' ); +is( $orphan->last_name, $parent2->last_name, + '... parent2 and orphan child have the same last name (' + . $parent2->last_name + . ')' ); + +# make sure that changes still will not propagate + +$parent->last_name('Miller'); +is( $parent->last_name, 'Miller', + '... the parent has the new last name (again)' ); + +foreach my $child ( @{ $parent->children } ) { + is( $child->last_name, $parent->last_name, + '... parent and child have the same last name (' + . $parent->last_name + . ')' ); +} + +isnt( $orphan->last_name, $parent->last_name, + '... the orphan child is not affected by changes in the parent anymore' ); +is( $orphan->last_name, $parent2->last_name, + '... parent2 and orphan child have the same last name (' + . $parent2->last_name + . ')' ); + +done_testing; diff --git a/t/examples/example1.t b/t/examples/example1.t new file mode 100644 index 0000000..643b0cd --- /dev/null +++ b/t/examples/example1.t @@ -0,0 +1,125 @@ +use strict; +use warnings; + +use Test::More; + + +## Roles + +{ + package Constraint; + use Moose::Role; + + has 'value' => (isa => 'Num', is => 'ro'); + + around 'validate' => sub { + my $c = shift; + my ($self, $field) = @_; + return undef if $c->($self, $self->validation_value($field)); + return $self->error_message; + }; + + sub validation_value { + my ($self, $field) = @_; + return $field; + } + + sub error_message { confess "Abstract method!" } + + package Constraint::OnLength; + use Moose::Role; + + has 'units' => (isa => 'Str', is => 'ro'); + + override 'validation_value' => sub { + return length(super()); + }; + + override 'error_message' => sub { + my $self = shift; + return super() . ' ' . $self->units; + }; + +} + +## Classes + +{ + package Constraint::AtLeast; + use Moose; + + with 'Constraint'; + + sub validate { + my ($self, $field) = @_; + ($field >= $self->value); + } + + sub error_message { 'must be at least ' . (shift)->value; } + + package Constraint::NoMoreThan; + use Moose; + + with 'Constraint'; + + sub validate { + my ($self, $field) = @_; + ($field <= $self->value); + } + + sub error_message { 'must be no more than ' . (shift)->value; } + + package Constraint::LengthNoMoreThan; + use Moose; + + extends 'Constraint::NoMoreThan'; + with 'Constraint::OnLength'; + + package Constraint::LengthAtLeast; + use Moose; + + extends 'Constraint::AtLeast'; + with 'Constraint::OnLength'; +} + +my $no_more_than_10 = Constraint::NoMoreThan->new(value => 10); +isa_ok($no_more_than_10, 'Constraint::NoMoreThan'); + +ok($no_more_than_10->does('Constraint'), '... Constraint::NoMoreThan does Constraint'); + +ok(!defined($no_more_than_10->validate(1)), '... validated correctly'); +is($no_more_than_10->validate(11), 'must be no more than 10', '... validation failed correctly'); + +my $at_least_10 = Constraint::AtLeast->new(value => 10); +isa_ok($at_least_10, 'Constraint::AtLeast'); + +ok($at_least_10->does('Constraint'), '... Constraint::AtLeast does Constraint'); + +ok(!defined($at_least_10->validate(11)), '... validated correctly'); +is($at_least_10->validate(1), 'must be at least 10', '... validation failed correctly'); + +# onlength + +my $no_more_than_10_chars = Constraint::LengthNoMoreThan->new(value => 10, units => 'chars'); +isa_ok($no_more_than_10_chars, 'Constraint::LengthNoMoreThan'); +isa_ok($no_more_than_10_chars, 'Constraint::NoMoreThan'); + +ok($no_more_than_10_chars->does('Constraint'), '... Constraint::LengthNoMoreThan does Constraint'); +ok($no_more_than_10_chars->does('Constraint::OnLength'), '... Constraint::LengthNoMoreThan does Constraint::OnLength'); + +ok(!defined($no_more_than_10_chars->validate('foo')), '... validated correctly'); +is($no_more_than_10_chars->validate('foooooooooo'), + 'must be no more than 10 chars', + '... validation failed correctly'); + +my $at_least_10_chars = Constraint::LengthAtLeast->new(value => 10, units => 'chars'); +isa_ok($at_least_10_chars, 'Constraint::LengthAtLeast'); +isa_ok($at_least_10_chars, 'Constraint::AtLeast'); + +ok($at_least_10_chars->does('Constraint'), '... Constraint::LengthAtLeast does Constraint'); +ok($at_least_10_chars->does('Constraint::OnLength'), '... Constraint::LengthAtLeast does Constraint::OnLength'); + +ok(!defined($at_least_10_chars->validate('barrrrrrrrr')), '... validated correctly'); +is($at_least_10_chars->validate('bar'), 'must be at least 10 chars', '... validation failed correctly'); + +done_testing; diff --git a/t/examples/example2.t b/t/examples/example2.t new file mode 100644 index 0000000..fae26dd --- /dev/null +++ b/t/examples/example2.t @@ -0,0 +1,155 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +sub U { + my $f = shift; + sub { $f->($f, @_) }; +} + +sub Y { + my $f = shift; + U(sub { my $h = shift; sub { $f->(U($h)->())->(@_) } })->(); +} + +{ + package List; + use Moose::Role; + + has '_list' => ( + is => 'ro', + isa => 'ArrayRef', + init_arg => '::', + default => sub { [] } + ); + + sub head { (shift)->_list->[0] } + sub tail { + my $self = shift; + (ref $self)->new( + '::' => [ + @{$self->_list}[1 .. $#{$self->_list}] + ] + ); + } + + sub print { + join ", " => @{$_[0]->_list}; + } + + package List::Immutable; + use Moose::Role; + + requires 'head'; + requires 'tail'; + + sub is_empty { not defined ($_[0]->head) } + + sub length { + my $self = shift; + (::Y(sub { + my $redo = shift; + sub { + my ($list, $acc) = @_; + return $acc if $list->is_empty; + $redo->($list->tail, $acc + 1); + } + }))->($self, 0); + } + + sub apply { + my ($self, $function) = @_; + (::Y(sub { + my $redo = shift; + sub { + my ($list, $func, $acc) = @_; + return (ref $list)->new('::' => $acc) + if $list->is_empty; + $redo->( + $list->tail, + $func, + [ @{$acc}, $func->($list->head) ] + ); + } + }))->($self, $function, []); + } + + package My::List1; + use Moose; + + ::is( ::exception { + with 'List', 'List::Immutable'; + }, undef, '... successfully composed roles together' ); + + package My::List2; + use Moose; + + ::is( ::exception { + with 'List::Immutable', 'List'; + }, undef, '... successfully composed roles together' ); + +} + +{ + my $coll = My::List1->new; + isa_ok($coll, 'My::List1'); + + ok($coll->does('List'), '... $coll does List'); + ok($coll->does('List::Immutable'), '... $coll does List::Immutable'); + + ok($coll->is_empty, '... we have an empty collection'); + is($coll->length, 0, '... we have a length of 1 for the collection'); +} + +{ + my $coll = My::List2->new; + isa_ok($coll, 'My::List2'); + + ok($coll->does('List'), '... $coll does List'); + ok($coll->does('List::Immutable'), '... $coll does List::Immutable'); + + ok($coll->is_empty, '... we have an empty collection'); + is($coll->length, 0, '... we have a length of 1 for the collection'); +} + +{ + my $coll = My::List1->new('::' => [ 1 .. 10 ]); + isa_ok($coll, 'My::List1'); + + ok($coll->does('List'), '... $coll does List'); + ok($coll->does('List::Immutable'), '... $coll does List::Immutable'); + + ok(!$coll->is_empty, '... we do not have an empty collection'); + is($coll->length, 10, '... we have a length of 10 for the collection'); + + is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... got the right printed value'); + + my $coll2 = $coll->apply(sub { $_[0] * $_[0] }); + isa_ok($coll2, 'My::List1'); + + is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... original is still the same'); + is($coll2->print, '1, 4, 9, 16, 25, 36, 49, 64, 81, 100', '... new collection is changed'); +} + +{ + my $coll = My::List2->new('::' => [ 1 .. 10 ]); + isa_ok($coll, 'My::List2'); + + ok($coll->does('List'), '... $coll does List'); + ok($coll->does('List::Immutable'), '... $coll does List::Immutable'); + + ok(!$coll->is_empty, '... we do not have an empty collection'); + is($coll->length, 10, '... we have a length of 10 for the collection'); + + is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... got the right printed value'); + + my $coll2 = $coll->apply(sub { $_[0] * $_[0] }); + isa_ok($coll2, 'My::List2'); + + is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... original is still the same'); + is($coll2->print, '1, 4, 9, 16, 25, 36, 49, 64, 81, 100', '... new collection is changed'); +} + +done_testing; diff --git a/t/examples/example_Moose_POOP.t b/t/examples/example_Moose_POOP.t new file mode 100644 index 0000000..3da6a60 --- /dev/null +++ b/t/examples/example_Moose_POOP.t @@ -0,0 +1,428 @@ +use strict; +use warnings; + +use Test::More; + +use Test::Requires { + 'DBM::Deep' => '1.0003', # skip all if not installed + 'DateTime::Format::MySQL' => '0', +}; + +use Test::Fatal; + +BEGIN { + # in case there are leftovers + unlink('newswriter.db') if -e 'newswriter.db'; +} + +END { + unlink('newswriter.db') if -e 'newswriter.db'; +} + + +=pod + +This example creates a very basic Object Database which +links in the instances created with a backend store +(a DBM::Deep hash). It is by no means to be taken seriously +as a real-world ODB, but is a proof of concept of the flexibility +of the ::Instance protocol. + +=cut + +BEGIN { + + package MooseX::POOP::Meta::Instance; + use Moose; + + use DBM::Deep; + + extends 'Moose::Meta::Instance'; + + { + my %INSTANCE_COUNTERS; + + my $db = DBM::Deep->new({ + file => "newswriter.db", + autobless => 1, + locking => 1, + }); + + sub _reload_db { + #use Data::Dumper; + #warn Dumper $db; + $db = undef; + $db = DBM::Deep->new({ + file => "newswriter.db", + autobless => 1, + locking => 1, + }); + } + + sub create_instance { + my $self = shift; + my $class = $self->associated_metaclass->name; + my $oid = ++$INSTANCE_COUNTERS{$class}; + + $db->{$class}->[($oid - 1)] = {}; + + bless { + oid => $oid, + instance => $db->{$class}->[($oid - 1)] + }, $class; + } + + sub find_instance { + my ($self, $oid) = @_; + my $instance = $db->{$self->associated_metaclass->name}->[($oid - 1)]; + + bless { + oid => $oid, + instance => $instance, + }, $self->associated_metaclass->name; + } + + sub clone_instance { + my ($self, $instance) = @_; + + my $class = $self->{meta}->name; + my $oid = ++$INSTANCE_COUNTERS{$class}; + + my $clone = tied($instance)->clone; + + bless { + oid => $oid, + instance => $clone, + }, $class; + } + } + + sub get_instance_oid { + my ($self, $instance) = @_; + $instance->{oid}; + } + + sub get_slot_value { + my ($self, $instance, $slot_name) = @_; + return $instance->{instance}->{$slot_name}; + } + + sub set_slot_value { + my ($self, $instance, $slot_name, $value) = @_; + $instance->{instance}->{$slot_name} = $value; + } + + sub is_slot_initialized { + my ($self, $instance, $slot_name, $value) = @_; + exists $instance->{instance}->{$slot_name} ? 1 : 0; + } + + sub weaken_slot_value { + confess "Not sure how well DBM::Deep plays with weak refs, Rob says 'Write a test'"; + } + + sub inline_slot_access { + my ($self, $instance, $slot_name) = @_; + sprintf "%s->{instance}->{%s}", $instance, $slot_name; + } + + package MooseX::POOP::Meta::Class; + use Moose; + + extends 'Moose::Meta::Class'; + + override '_construct_instance' => sub { + my $class = shift; + my $params = @_ == 1 ? $_[0] : {@_}; + return $class->get_meta_instance->find_instance($params->{oid}) + if $params->{oid}; + super(); + }; + +} +{ + package MooseX::POOP::Object; + use metaclass 'MooseX::POOP::Meta::Class' => ( + instance_metaclass => 'MooseX::POOP::Meta::Instance' + ); + use Moose; + + sub oid { + my $self = shift; + $self->meta + ->get_meta_instance + ->get_instance_oid($self); + } + +} +{ + package Newswriter::Author; + use Moose; + + extends 'MooseX::POOP::Object'; + + has 'first_name' => (is => 'rw', isa => 'Str'); + has 'last_name' => (is => 'rw', isa => 'Str'); + + package Newswriter::Article; + use Moose; + use Moose::Util::TypeConstraints; + + use DateTime::Format::MySQL; + + extends 'MooseX::POOP::Object'; + + subtype 'Headline' + => as 'Str' + => where { length($_) < 100 }; + + subtype 'Summary' + => as 'Str' + => where { length($_) < 255 }; + + subtype 'DateTimeFormatString' + => as 'Str' + => where { DateTime::Format::MySQL->parse_datetime($_) }; + + enum 'Status' => [qw(draft posted pending archive)]; + + has 'headline' => (is => 'rw', isa => 'Headline'); + has 'summary' => (is => 'rw', isa => 'Summary'); + has 'article' => (is => 'rw', isa => 'Str'); + + has 'start_date' => (is => 'rw', isa => 'DateTimeFormatString'); + has 'end_date' => (is => 'rw', isa => 'DateTimeFormatString'); + + has 'author' => (is => 'rw', isa => 'Newswriter::Author'); + + has 'status' => (is => 'rw', isa => 'Status'); + + around 'start_date', 'end_date' => sub { + my $c = shift; + my $self = shift; + $c->($self, DateTime::Format::MySQL->format_datetime($_[0])) if @_; + DateTime::Format::MySQL->parse_datetime($c->($self) || return undef); + }; +} + +{ # check the meta stuff first + isa_ok(MooseX::POOP::Object->meta, 'MooseX::POOP::Meta::Class'); + isa_ok(MooseX::POOP::Object->meta, 'Moose::Meta::Class'); + isa_ok(MooseX::POOP::Object->meta, 'Class::MOP::Class'); + + is(MooseX::POOP::Object->meta->instance_metaclass, + 'MooseX::POOP::Meta::Instance', + '... got the right instance metaclass name'); + + isa_ok(MooseX::POOP::Object->meta->get_meta_instance, 'MooseX::POOP::Meta::Instance'); + + my $base = MooseX::POOP::Object->new; + isa_ok($base, 'MooseX::POOP::Object'); + isa_ok($base, 'Moose::Object'); + + isa_ok($base->meta, 'MooseX::POOP::Meta::Class'); + isa_ok($base->meta, 'Moose::Meta::Class'); + isa_ok($base->meta, 'Class::MOP::Class'); + + is($base->meta->instance_metaclass, + 'MooseX::POOP::Meta::Instance', + '... got the right instance metaclass name'); + + isa_ok($base->meta->get_meta_instance, 'MooseX::POOP::Meta::Instance'); +} + +my $article_oid; +{ + my $article; + is( exception { + $article = Newswriter::Article->new( + headline => 'Home Office Redecorated', + summary => 'The home office was recently redecorated to match the new company colors', + article => '...', + + author => Newswriter::Author->new( + first_name => 'Truman', + last_name => 'Capote' + ), + + status => 'pending' + ); + }, undef, '... created my article successfully' ); + isa_ok($article, 'Newswriter::Article'); + isa_ok($article, 'MooseX::POOP::Object'); + + is( exception { + $article->start_date(DateTime->new(year => 2006, month => 6, day => 10)); + $article->end_date(DateTime->new(year => 2006, month => 6, day => 17)); + }, undef, '... add the article date-time stuff' ); + + ## check some meta stuff + + isa_ok($article->meta, 'MooseX::POOP::Meta::Class'); + isa_ok($article->meta, 'Moose::Meta::Class'); + isa_ok($article->meta, 'Class::MOP::Class'); + + is($article->meta->instance_metaclass, + 'MooseX::POOP::Meta::Instance', + '... got the right instance metaclass name'); + + isa_ok($article->meta->get_meta_instance, 'MooseX::POOP::Meta::Instance'); + + ok($article->oid, '... got a oid for the article'); + + $article_oid = $article->oid; + + is($article->headline, + 'Home Office Redecorated', + '... got the right headline'); + is($article->summary, + 'The home office was recently redecorated to match the new company colors', + '... got the right summary'); + is($article->article, '...', '... got the right article'); + + isa_ok($article->start_date, 'DateTime'); + isa_ok($article->end_date, 'DateTime'); + + isa_ok($article->author, 'Newswriter::Author'); + is($article->author->first_name, 'Truman', '... got the right author first name'); + is($article->author->last_name, 'Capote', '... got the right author last name'); + + is($article->status, 'pending', '... got the right status'); +} + +MooseX::POOP::Meta::Instance->_reload_db(); + +my $article2_oid; +{ + my $article2; + is( exception { + $article2 = Newswriter::Article->new( + headline => 'Company wins Lottery', + summary => 'An email was received today that informed the company we have won the lottery', + article => 'WoW', + + author => Newswriter::Author->new( + first_name => 'Katie', + last_name => 'Couric' + ), + + status => 'posted' + ); + }, undef, '... created my article successfully' ); + isa_ok($article2, 'Newswriter::Article'); + isa_ok($article2, 'MooseX::POOP::Object'); + + $article2_oid = $article2->oid; + + is($article2->headline, + 'Company wins Lottery', + '... got the right headline'); + is($article2->summary, + 'An email was received today that informed the company we have won the lottery', + '... got the right summary'); + is($article2->article, 'WoW', '... got the right article'); + + ok(!$article2->start_date, '... these two dates are unassigned'); + ok(!$article2->end_date, '... these two dates are unassigned'); + + isa_ok($article2->author, 'Newswriter::Author'); + is($article2->author->first_name, 'Katie', '... got the right author first name'); + is($article2->author->last_name, 'Couric', '... got the right author last name'); + + is($article2->status, 'posted', '... got the right status'); + + ## orig-article + + my $article; + is( exception { + $article = Newswriter::Article->new(oid => $article_oid); + }, undef, '... (re)-created my article successfully' ); + isa_ok($article, 'Newswriter::Article'); + isa_ok($article, 'MooseX::POOP::Object'); + + is($article->oid, $article_oid, '... got a oid for the article'); + + is($article->headline, + 'Home Office Redecorated', + '... got the right headline'); + is($article->summary, + 'The home office was recently redecorated to match the new company colors', + '... got the right summary'); + is($article->article, '...', '... got the right article'); + + isa_ok($article->start_date, 'DateTime'); + isa_ok($article->end_date, 'DateTime'); + + isa_ok($article->author, 'Newswriter::Author'); + is($article->author->first_name, 'Truman', '... got the right author first name'); + is($article->author->last_name, 'Capote', '... got the right author last name'); + + is( exception { + $article->author->first_name('Dan'); + $article->author->last_name('Rather'); + }, undef, '... changed the value ok' ); + + is($article->author->first_name, 'Dan', '... got the changed author first name'); + is($article->author->last_name, 'Rather', '... got the changed author last name'); + + is($article->status, 'pending', '... got the right status'); +} + +MooseX::POOP::Meta::Instance->_reload_db(); + +{ + my $article; + is( exception { + $article = Newswriter::Article->new(oid => $article_oid); + }, undef, '... (re)-created my article successfully' ); + isa_ok($article, 'Newswriter::Article'); + isa_ok($article, 'MooseX::POOP::Object'); + + is($article->oid, $article_oid, '... got a oid for the article'); + + is($article->headline, + 'Home Office Redecorated', + '... got the right headline'); + is($article->summary, + 'The home office was recently redecorated to match the new company colors', + '... got the right summary'); + is($article->article, '...', '... got the right article'); + + isa_ok($article->start_date, 'DateTime'); + isa_ok($article->end_date, 'DateTime'); + + isa_ok($article->author, 'Newswriter::Author'); + is($article->author->first_name, 'Dan', '... got the changed author first name'); + is($article->author->last_name, 'Rather', '... got the changed author last name'); + + is($article->status, 'pending', '... got the right status'); + + my $article2; + is( exception { + $article2 = Newswriter::Article->new(oid => $article2_oid); + }, undef, '... (re)-created my article successfully' ); + isa_ok($article2, 'Newswriter::Article'); + isa_ok($article2, 'MooseX::POOP::Object'); + + is($article2->oid, $article2_oid, '... got a oid for the article'); + + is($article2->headline, + 'Company wins Lottery', + '... got the right headline'); + is($article2->summary, + 'An email was received today that informed the company we have won the lottery', + '... got the right summary'); + is($article2->article, 'WoW', '... got the right article'); + + ok(!$article2->start_date, '... these two dates are unassigned'); + ok(!$article2->end_date, '... these two dates are unassigned'); + + isa_ok($article2->author, 'Newswriter::Author'); + is($article2->author->first_name, 'Katie', '... got the right author first name'); + is($article2->author->last_name, 'Couric', '... got the right author last name'); + + is($article2->status, 'posted', '... got the right status'); + +} + +done_testing; diff --git a/t/examples/example_Protomoose.t b/t/examples/example_Protomoose.t new file mode 100644 index 0000000..59beadf --- /dev/null +++ b/t/examples/example_Protomoose.t @@ -0,0 +1,281 @@ +use strict; +use warnings; + +use Test::More; + +=pod + +This is an example of making Moose behave +more like a prototype based object system. + +Why? + +Well cause merlyn asked if it could :) + +=cut + +## ------------------------------------------------------------------ +## make some metaclasses + +{ + package ProtoMoose::Meta::Instance; + use Moose; + + BEGIN { extends 'Moose::Meta::Instance' }; + + # NOTE: + # do not let things be inlined by + # the attribute or accessor generator + sub is_inlinable { 0 } +} + +{ + package ProtoMoose::Meta::Method::Accessor; + use Moose; + + BEGIN { extends 'Moose::Meta::Method::Accessor' }; + + # customize the accessors to always grab + # the correct instance in the accessors + + sub find_instance { + my ($self, $candidate, $accessor_type) = @_; + + my $instance = $candidate; + my $attr = $self->associated_attribute; + + # if it is a class calling it ... + unless (blessed($instance)) { + # then grab the class prototype + $instance = $attr->associated_class->prototype_instance; + } + # if its an instance ... + else { + # and there is no value currently + # associated with the instance and + # we are trying to read it, then ... + if ($accessor_type eq 'r' && !defined($attr->get_value($instance))) { + # again, defer the prototype in + # the class in which is was defined + $instance = $attr->associated_class->prototype_instance; + } + # otherwise, you want to assign + # to your local copy ... + } + return $instance; + } + + sub _generate_accessor_method { + my $self = shift; + my $attr = $self->associated_attribute; + return sub { + if (scalar(@_) == 2) { + $attr->set_value( + $self->find_instance($_[0], 'w'), + $_[1] + ); + } + $attr->get_value($self->find_instance($_[0], 'r')); + }; + } + + sub _generate_reader_method { + my $self = shift; + my $attr = $self->associated_attribute; + return sub { + confess "Cannot assign a value to a read-only accessor" if @_ > 1; + $attr->get_value($self->find_instance($_[0], 'r')); + }; + } + + sub _generate_writer_method { + my $self = shift; + my $attr = $self->associated_attribute; + return sub { + $attr->set_value( + $self->find_instance($_[0], 'w'), + $_[1] + ); + }; + } + + # deal with these later ... + sub generate_predicate_method {} + sub generate_clearer_method {} + +} + +{ + package ProtoMoose::Meta::Attribute; + use Moose; + + BEGIN { extends 'Moose::Meta::Attribute' }; + + sub accessor_metaclass { 'ProtoMoose::Meta::Method::Accessor' } +} + +{ + package ProtoMoose::Meta::Class; + use Moose; + + BEGIN { extends 'Moose::Meta::Class' }; + + has 'prototype_instance' => ( + is => 'rw', + isa => 'Object', + predicate => 'has_prototypical_instance', + lazy => 1, + default => sub { (shift)->new_object } + ); + + sub initialize { + # NOTE: + # I am not sure why 'around' does + # not work here, have to investigate + # it later - SL + (shift)->SUPER::initialize(@_, + instance_metaclass => 'ProtoMoose::Meta::Instance', + attribute_metaclass => 'ProtoMoose::Meta::Attribute', + ); + } + + around '_construct_instance' => sub { + my $next = shift; + my $self = shift; + # NOTE: + # we actually have to do this here + # to tie-the-knot, if you take it + # out, then you get deep recursion + # several levels deep :) + $self->prototype_instance($next->($self, @_)) + unless $self->has_prototypical_instance; + return $self->prototype_instance; + }; + +} + +{ + package ProtoMoose::Object; + use metaclass 'ProtoMoose::Meta::Class'; + use Moose; + + sub new { + my $prototype = blessed($_[0]) + ? $_[0] + : $_[0]->meta->prototype_instance; + my (undef, %params) = @_; + my $self = $prototype->meta->clone_object($prototype, %params); + $self->BUILDALL(\%params); + return $self; + } +} + +## ------------------------------------------------------------------ +## make some classes now + +{ + package Foo; + use Moose; + + extends 'ProtoMoose::Object'; + + has 'bar' => (is => 'rw'); +} + +{ + package Bar; + use Moose; + + extends 'Foo'; + + has 'baz' => (is => 'rw'); +} + +## ------------------------------------------------------------------ + +## ------------------------------------------------------------------ +## Check that metaclasses are working/inheriting properly + +foreach my $class (qw/ProtoMoose::Object Foo Bar/) { + isa_ok($class->meta, + 'ProtoMoose::Meta::Class', + '... got the right metaclass for ' . $class . ' ->'); + + is($class->meta->instance_metaclass, + 'ProtoMoose::Meta::Instance', + '... got the right instance meta for ' . $class); + + is($class->meta->attribute_metaclass, + 'ProtoMoose::Meta::Attribute', + '... got the right attribute meta for ' . $class); +} + +## ------------------------------------------------------------------ + +# get the prototype for Foo +my $foo_prototype = Foo->meta->prototype_instance; +isa_ok($foo_prototype, 'Foo'); + +# set a value in the prototype +$foo_prototype->bar(100); +is($foo_prototype->bar, 100, '... got the value stored in the prototype'); + +# the "class" defers to the +# the prototype when asked +# about attributes +is(Foo->bar, 100, '... got the value stored in the prototype (through the Foo class)'); + +# now make an instance, which +# is basically a clone of the +# prototype +my $foo = Foo->new; +isa_ok($foo, 'Foo'); + +# the instance is *not* the prototype +isnt($foo, $foo_prototype, '... got a new instance of Foo'); + +# but it has the same values ... +is($foo->bar, 100, '... got the value stored in the instance (inherited from the prototype)'); + +# we can even change the values +# in the instance +$foo->bar(300); +is($foo->bar, 300, '... got the value stored in the instance (overwriting the one inherited from the prototype)'); + +# and not change the one in the prototype +is($foo_prototype->bar, 100, '... got the value stored in the prototype'); +is(Foo->bar, 100, '... got the value stored in the prototype (through the Foo class)'); + +## subclasses + +# now we can check that the subclass +# will seek out the correct prototypical +# value from its "parent" +is(Bar->bar, 100, '... got the value stored in the Foo prototype (through the Bar class)'); + +# we can then also set its local attrs +Bar->baz(50); +is(Bar->baz, 50, '... got the value stored in the prototype (through the Bar class)'); + +# now we clone the Bar prototype +my $bar = Bar->new; +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +# and we see that we got the right values +# in the instance/clone +is($bar->bar, 100, '... got the value stored in the instance (inherited from the Foo prototype)'); +is($bar->baz, 50, '... got the value stored in the instance (inherited from the Bar prototype)'); + +# nowe we can change the value +$bar->bar(200); +is($bar->bar, 200, '... got the value stored in the instance (overriding the one inherited from the Foo prototype)'); + +# and all our original and +# prototypical values are still +# the same +is($foo->bar, 300, '... still got the original value stored in the instance (inherited from the prototype)'); +is(Foo->bar, 100, '... still got the original value stored in the prototype (through the Foo class)'); +is(Bar->bar, 100, '... still got the original value stored in the prototype (through the Bar class)'); + +done_testing; diff --git a/t/examples/example_w_DCS.t b/t/examples/example_w_DCS.t new file mode 100644 index 0000000..eb78d8d --- /dev/null +++ b/t/examples/example_w_DCS.t @@ -0,0 +1,87 @@ +use strict; +use warnings; + +use Test::More; + +=pod + +This tests how well Moose type constraints +play with Declare::Constraints::Simple. + +Pretty well if I do say so myself :) + +=cut + +use Test::Requires 'Declare::Constraints::Simple'; # skip all if not installed +use Test::Fatal; + +{ + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + use Declare::Constraints::Simple -All; + + # define your own type ... + type( 'HashOfArrayOfObjects', + { + where => IsHashRef( + -keys => HasLength, + -values => IsArrayRef(IsObject) + ) + } ); + + has 'bar' => ( + is => 'rw', + isa => 'HashOfArrayOfObjects', + ); + + # inline the constraints as anon-subtypes + has 'baz' => ( + is => 'rw', + isa => subtype( { as => 'ArrayRef', where => IsArrayRef(IsInt) } ), + ); + + package Bar; + use Moose; +} + +my $hash_of_arrays_of_objs = { + foo1 => [ Bar->new ], + foo2 => [ Bar->new, Bar->new ], +}; + +my $array_of_ints = [ 1 .. 10 ]; + +my $foo; +is( exception { + $foo = Foo->new( + 'bar' => $hash_of_arrays_of_objs, + 'baz' => $array_of_ints, + ); +}, undef, '... construction succeeded' ); +isa_ok($foo, 'Foo'); + +is_deeply($foo->bar, $hash_of_arrays_of_objs, '... got our value correctly'); +is_deeply($foo->baz, $array_of_ints, '... got our value correctly'); + +isnt( exception { + $foo->bar([]); +}, undef, '... validation failed correctly' ); + +isnt( exception { + $foo->bar({ foo => 3 }); +}, undef, '... validation failed correctly' ); + +isnt( exception { + $foo->bar({ foo => [ 1, 2, 3 ] }); +}, undef, '... validation failed correctly' ); + +isnt( exception { + $foo->baz([ "foo" ]); +}, undef, '... validation failed correctly' ); + +isnt( exception { + $foo->baz({}); +}, undef, '... validation failed correctly' ); + +done_testing; diff --git a/t/examples/example_w_TestDeep.t b/t/examples/example_w_TestDeep.t new file mode 100644 index 0000000..caac9c6 --- /dev/null +++ b/t/examples/example_w_TestDeep.t @@ -0,0 +1,71 @@ +use strict; +use warnings; + +use Test::More; + +=pod + +This tests how well Moose type constraints +play with Test::Deep. + +Its not as pretty as Declare::Constraints::Simple, +but it is not completely horrid either. + +=cut + +use Test::Requires 'Test::Deep'; # skip all if not installed +use Test::Fatal; + +{ + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + use Test::Deep qw[ + eq_deeply array_each subhashof ignore + ]; + + # define your own type ... + type 'ArrayOfHashOfBarsAndRandomNumbers' + => where { + eq_deeply($_, + array_each( + subhashof({ + bar => Test::Deep::isa('Bar'), + random_number => ignore() + }) + ) + ) + }; + + has 'bar' => ( + is => 'rw', + isa => 'ArrayOfHashOfBarsAndRandomNumbers', + ); + + package Bar; + use Moose; +} + +my $array_of_hashes = [ + { bar => Bar->new, random_number => 10 }, + { bar => Bar->new }, +]; + +my $foo; +is( exception { + $foo = Foo->new('bar' => $array_of_hashes); +}, undef, '... construction succeeded' ); +isa_ok($foo, 'Foo'); + +is_deeply($foo->bar, $array_of_hashes, '... got our value correctly'); + +isnt( exception { + $foo->bar({}); +}, undef, '... validation failed correctly' ); + +isnt( exception { + $foo->bar([{ foo => 3 }]); +}, undef, '... validation failed correctly' ); + +done_testing; diff --git a/t/examples/record_set_iterator.t b/t/examples/record_set_iterator.t new file mode 100644 index 0000000..fe432b4 --- /dev/null +++ b/t/examples/record_set_iterator.t @@ -0,0 +1,114 @@ +use strict; +use warnings; + +use Test::More; + + +{ + package Record; + use Moose; + + has 'first_name' => (is => 'ro', isa => 'Str'); + has 'last_name' => (is => 'ro', isa => 'Str'); + + package RecordSet; + use Moose; + + has 'data' => ( + is => 'ro', + isa => 'ArrayRef[Record]', + default => sub { [] }, + ); + + has 'index' => ( + is => 'rw', + isa => 'Int', + default => sub { 0 }, + ); + + sub next { + my $self = shift; + my $i = $self->index; + $self->index($i + 1); + return $self->data->[$i]; + } + + package RecordSetIterator; + use Moose; + + has 'record_set' => ( + is => 'rw', + isa => 'RecordSet', + ); + + # list the fields you want to + # fetch from the current record + my @fields = Record->meta->get_attribute_list; + + has 'current_record' => ( + is => 'rw', + isa => 'Record', + lazy => 1, + default => sub { + my $self = shift; + $self->record_set->next() # grab the first one + }, + trigger => sub { + my $self = shift; + # whenever this attribute is + # updated, it will clear all + # the fields for you. + $self->$_() for map { '_clear_' . $_ } @fields; + } + ); + + # define the attributes + # for all the fields. + for my $field (@fields) { + has $field => ( + is => 'ro', + isa => 'Any', + lazy => 1, + default => sub { + my $self = shift; + # fetch the value from + # the current record + $self->current_record->$field(); + }, + # make sure they have a clearer .. + clearer => ('_clear_' . $field) + ); + } + + sub get_next_record { + my $self = shift; + $self->current_record($self->record_set->next()); + } +} + +my $rs = RecordSet->new( + data => [ + Record->new(first_name => 'Bill', last_name => 'Smith'), + Record->new(first_name => 'Bob', last_name => 'Jones'), + Record->new(first_name => 'Jim', last_name => 'Johnson'), + ] +); +isa_ok($rs, 'RecordSet'); + +my $rsi = RecordSetIterator->new(record_set => $rs); +isa_ok($rsi, 'RecordSetIterator'); + +is($rsi->first_name, 'Bill', '... got the right first name'); +is($rsi->last_name, 'Smith', '... got the right last name'); + +$rsi->get_next_record; + +is($rsi->first_name, 'Bob', '... got the right first name'); +is($rsi->last_name, 'Jones', '... got the right last name'); + +$rsi->get_next_record; + +is($rsi->first_name, 'Jim', '... got the right first name'); +is($rsi->last_name, 'Johnson', '... got the right last name'); + +done_testing; diff --git a/t/exceptions/attribute.t b/t/exceptions/attribute.t new file mode 100644 index 0000000..600f51f --- /dev/null +++ b/t/exceptions/attribute.t @@ -0,0 +1,1194 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +# tests for AccessorMustReadWrite +{ + use Moose; + + my $exception = exception { + has 'test' => ( + is => 'ro', + isa => 'Int', + accessor => 'bar', + ) + }; + + like( + $exception, + qr!Cannot define an accessor name on a read-only attribute, accessors are read/write!, + "Read-only attributes can't have accessor"); + + isa_ok( + $exception, + "Moose::Exception::AccessorMustReadWrite", + "Read-only attributes can't have accessor"); + + is( + $exception->attribute_name, + 'test', + "Read-only attributes can't have accessor"); +} + +# tests for AttributeIsRequired +{ + { + package Foo; + use Moose; + + has 'baz' => ( + is => 'ro', + isa => 'Int', + required => 1, + ); + } + + my $exception = exception { + Foo->new; + }; + + like( + $exception, + qr/\QAttribute (baz) is required/, + "... must supply all the required attribute"); + + isa_ok( + $exception, + "Moose::Exception::AttributeIsRequired", + "... must supply all the required attribute"); + + is( + $exception->attribute_name, + 'baz', + "... must supply all the required attribute"); + + isa_ok( + $exception->class_name, + 'Foo', + "... must supply all the required attribute"); +} + +# tests for invalid value for is +{ + my $exception = exception { + use Moose; + has 'foo' => ( + is => 'bar', + ); + }; + + like( + $exception, + qr/^\QI do not understand this option (is => bar) on attribute (foo)/, + "invalid value for is"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidValueForIs', + "invalid value for is"); +} + +{ + { + package Foo; + use Moose; + } + + my $exception = exception { + use Moose; + has 'bar' => ( + is => 'ro', + isa => 'Foo', + does => 'Not::A::Role' + ); + }; + + like( + $exception, + qr/^\QCannot have an isa option and a does option if the isa does not do the does on attribute (bar)/, + "isa option should does the role on the given attribute"); + + isa_ok( + $exception, + 'Moose::Exception::IsaDoesNotDoTheRole', + "isa option should does the role on the given attribute"); +} + +{ + { + package Foo; + use Moose; + } + + my $exception = exception { + has 'bar' => ( + is => 'ro', + isa => 'Not::A::Class', + does => 'Not::A::Role', + ); + }; + + like( + $exception, + qr/^\QCannot have an isa option which cannot ->does() on attribute (bar)/, + "isa option which is not a class cannot ->does the role specified in does"); + + isa_ok( + $exception, + 'Moose::Exception::IsaLacksDoesMethod', + "isa option which is not a class cannot ->does the role specified in does"); +} + +{ + my $exception = exception { + use Moose; + has 'bar' => ( + is => 'ro', + coerce => 1, + ); + }; + + like( + $exception, + qr/^\QYou cannot have coercion without specifying a type constraint on attribute (bar)/, + "cannot coerce if type constraint i.e. isa option is not given"); + + isa_ok( + $exception, + 'Moose::Exception::CoercionNeedsTypeConstraint', + "cannot coerce if type constraint i.e. isa option is not given"); +} + +{ + my $exception = exception { + use Moose; + has 'bar' => ( + is => 'ro', + isa => 'Int', + weak_ref => 1, + coerce => 1, + ); + }; + + like( + $exception, + qr/^\QYou cannot have a weak reference to a coerced value on attribute (bar)/, + "cannot coerce if attribute is a weak_ref"); + + isa_ok( + $exception, + 'Moose::Exception::CannotCoerceAWeakRef', + "cannot coerce if attribute is a weak_ref"); +} + +{ + my $exception = exception { + use Moose; + has 'bar' => ( + is => 'ro', + isa => 'Int', + trigger => "foo", + ); + }; + + like( + $exception, + qr/^\QTrigger must be a CODE ref on attribute (bar)/, + "Trigger must be a CODE ref"); + + isa_ok( + $exception, + 'Moose::Exception::TriggerMustBeACodeRef', + "Trigger must be a CODE ref"); +} + +{ + { + package Foo; + use Moose; + has 'baz' => ( + is => 'ro', + isa => 'Int', + builder => "_build_baz", + ); + } + + my $exception = exception { + Foo->new; + }; + + like( + $exception, + qr/^\QFoo does not support builder method '_build_baz' for attribute 'baz'/, + "Correct error when a builder method is not present"); + + isa_ok( + $exception, + 'Moose::Exception::BuilderDoesNotExist', + "Correct error when a builder method is not present"); + + isa_ok( + $exception->instance, + 'Foo', + "Correct error when a builder method is not present"); + + is( + $exception->attribute->name, + 'baz', + "Correct error when a builder method is not present"); + + is( + $exception->attribute->builder, + '_build_baz', + "Correct error when a builder method is not present"); +} + +# tests for CannotDelegateWithoutIsa +{ + my $exception = exception { + package Foo; + use Moose; + has 'bar' => ( + is => 'ro', + handles => qr/baz/, + ); + }; + + like( + $exception, + qr/\QCannot delegate methods based on a Regexp without a type constraint (isa)/, + "isa is required while delegating methods based on a Regexp"); + + isa_ok( + $exception, + 'Moose::Exception::CannotDelegateWithoutIsa', + "isa is required while delegating methods based on a Regexp"); +} + +{ + my $exception = exception { + package Foo; + use Moose; + has bar => ( + is => 'ro', + auto_deref => 1, + ); + }; + + like( + $exception, + qr/\QYou cannot auto-dereference without specifying a type constraint on attribute (bar)/, + "You cannot auto-dereference without specifying a type constraint on attribute"); + + isa_ok( + $exception, + 'Moose::Exception::CannotAutoDerefWithoutIsa', + "You cannot auto-dereference without specifying a type constraint on attribute"); + + is( + $exception->attribute_name, + 'bar', + "You cannot auto-dereference without specifying a type constraint on attribute"); +} + +{ + my $exception = exception { + package Foo; + use Moose; + has 'bar' => ( + is => 'ro', + required => 1, + init_arg => undef, + ); + }; + + like( + $exception, + qr/\QYou cannot have a required attribute (bar) without a default, builder, or an init_arg/, + "No default, builder or init_arg is given"); + + isa_ok( + $exception, + 'Moose::Exception::RequiredAttributeNeedsADefault', + "No default, builder or init_arg is given"); +} + +{ + my $exception = exception { + package Foo; + use Moose; + has 'bar' => ( + is => 'ro', + lazy => 1, + ); + }; + + like( + $exception, + qr/\QYou cannot have a lazy attribute (bar) without specifying a default value for it/, + "No default for a lazy attribute is given"); + + isa_ok( + $exception, + 'Moose::Exception::LazyAttributeNeedsADefault', + "No default for a lazy attribute is given"); +} + +{ + my $exception = exception { + package Foo; + use Moose; + has 'bar' => ( + is => 'ro', + isa => 'Int', + auto_deref => 1, + ); + }; + + like( + $exception, + qr/\QYou cannot auto-dereference anything other than a ArrayRef or HashRef on attribute (bar)/, + "auto_deref needs either HashRef or ArrayRef"); + + isa_ok( + $exception, + 'Moose::Exception::AutoDeRefNeedsArrayRefOrHashRef', + "auto_deref needs either HashRef or ArrayRef"); +} + +{ + my $exception = exception { + package Foo; + use Moose; + has 'bar' => ( + is => 'ro', + lazy_build => 1, + default => 1, + ); + }; + + like( + $exception, + qr/\QYou can not use lazy_build and default for the same attribute (bar)/, + "An attribute can't use lazy_build & default simultaneously"); + + isa_ok( + $exception, + 'Moose::Exception::CannotUseLazyBuildAndDefaultSimultaneously', + "An attribute can't use lazy_build & default simultaneously"); +} + +{ + my $exception = exception { + package Delegator; + use Moose; + + sub full { 1 } + sub stub; + + has d1 => ( + isa => 'X', + handles => ['full'], + ); + }; + + like( + $exception, + qr/\QYou cannot overwrite a locally defined method (full) with a delegation/, + 'got an error when trying to declare a delegation method that overwrites a local method'); + + isa_ok( + $exception, + 'Moose::Exception::CannotDelegateLocalMethodIsPresent', + "got an error when trying to declare a delegation method that overwrites a local method"); + + $exception = exception { + package Delegator; + use Moose; + + has d2 => ( + isa => 'X', + handles => ['stub'], + ); + }; + + is( + $exception, + undef, + 'no error when trying to declare a delegation method that overwrites a stub method'); +} + +{ + { + package Test; + use Moose; + has 'foo' => ( + is => 'rw', + clearer => 'clear_foo', + predicate => 'foo', + accessor => 'bar', + ); + } + + my $exception = exception { + package Test2; + use Moose; + extends 'Test'; + has '+foo' => ( + clearer => 'clear_foo1', + ); + }; + + like( + $exception, + qr/\QIllegal inherited options => (clearer)/, + "Illegal inherited option is given"); + + isa_ok( + $exception, + "Moose::Exception::IllegalInheritedOptions", + "Illegal inherited option is given"); + + $exception = exception { + package Test3; + use Moose; + extends 'Test'; + has '+foo' => ( + clearer => 'clear_foo1', + predicate => 'xyz', + accessor => 'bar2', + ); + }; + + like( + $exception, + qr/\QIllegal inherited options => (accessor, clearer, predicate)/, + "Illegal inherited option is given"); +} + +# tests for exception thrown is Moose::Meta::Attribute::set_value +{ + my $exception = exception { + { + package Foo1; + use Moose; + has 'bar' => ( + is => 'ro', + required => 1, + ); + } + + my $instance = Foo1->new(bar => "test"); + my $bar_attr = Foo1->meta->get_attribute('bar'); + my $bar_writer = $bar_attr->get_write_method_ref; + $bar_writer->($instance); + }; + + like( + $exception, + qr/\QAttribute (bar) is required/, + "... must supply all the required attribute"); + + isa_ok( + $exception, + "Moose::Exception::AttributeIsRequired", + "... must supply all the required attribute"); + + is( + $exception->attribute_name, + 'bar', + "... must supply all the required attribute"); + + isa_ok( + $exception->class_name, + 'Foo1', + "... must supply all the required attribute"); +} + +{ + my $exception = exception { + { + package Foo1; + use Moose; + has 'bar' => ( + is => 'ro', + handles => \*STDIN, + ); + } + }; + + my $handle = \*STDIN; + + like( + $exception, + qr/\QUnable to canonicalize the 'handles' option with $handle/, + "handles doesn't take file handle"); + #Unable to canonicalize the 'handles' option with GLOB(0x109d0b0) + + isa_ok( + $exception, + "Moose::Exception::UnableToCanonicalizeHandles", + "handles doesn't take file handle"); + +} + +{ + my $exception = exception { + { + package Foo1; + use Moose; + has 'bar' => ( + is => 'ro', + handles => 'Foo1', + ); + } + }; + + like( + $exception, + qr/\QUnable to canonicalize the 'handles' option with Foo1 because its metaclass is not a Moose::Meta::Role/, + "'Str' given to handles should be a metaclass of Moose::Meta::Role"); + + isa_ok( + $exception, + "Moose::Exception::UnableToCanonicalizeNonRolePackage", + "'Str' given to handles should be a metaclass of Moose::Meta::Role"); +} + +{ + my $exception = exception { + { + package Foo1; + use Moose; + has 'bar' => ( + is => 'ro', + isa => 'Not::Loaded', + handles => qr/xyz/, + ); + } + }; + + like( + $exception, + qr/\QThe bar attribute is trying to delegate to a class which has not been loaded - Not::Loaded/, + "You cannot delegate to a class which has not yet loaded"); + + isa_ok( + $exception, + "Moose::Exception::DelegationToAClassWhichIsNotLoaded", + "You cannot delegate to a class which has not yet loaded"); + + is( + $exception->attribute->name, + 'bar', + "You cannot delegate to a class which has not yet loaded" + ); + + is( + $exception->class_name, + 'Not::Loaded', + "You cannot delegate to a class which has not yet loaded" + ); +} + +{ + my $exception = exception { + { + package Foo1; + use Moose; + has bar => ( + is => 'ro', + does => 'Role', + handles => qr/Role/, + ); + } + }; + + like( + $exception, + qr/\QThe bar attribute is trying to delegate to a role which has not been loaded - Role/, + "You cannot delegate to a role which has not yet loaded"); + + isa_ok( + $exception, + "Moose::Exception::DelegationToARoleWhichIsNotLoaded", + "You cannot delegate to a role which has not yet loaded"); + + is( + $exception->attribute->name, + 'bar', + "You cannot delegate to a role which has not yet loaded" + ); + + is( + $exception->role_name, + 'Role', + "You cannot delegate to a role which has not yet loaded" + ); +} + + +{ + my $exception = exception { + { + package Foo1; + use Moose; + has 'bar' => ( + is => 'ro', + isa => 'Int', + handles => qr/xyz/, + ); + } + }; + + like( + $exception, + qr/\QThe bar attribute is trying to delegate to a type (Int) that is not backed by a class/, + "Delegating to a type that is not backed by a class"); + + isa_ok( + $exception, + "Moose::Exception::DelegationToATypeWhichIsNotAClass", + "Delegating to a type that is not backed by a class"); + + is( + $exception->attribute->name, + 'bar', + "Delegating to a type that is not backed by a class"); + + is( + $exception->attribute->type_constraint->name, + 'Int', + "Delegating to a type that is not backed by a class"); + + $exception = exception { + { + package Foo1; + use Moose; + use Moose::Util::TypeConstraints; + + subtype 'PositiveInt', + as 'Int', + where { $_ > 0 }; + + has 'bar' => ( + is => 'ro', + isa => 'PositiveInt', + handles => qr/xyz/, + ); + } + }; + + like( + $exception, + qr/\QThe bar attribute is trying to delegate to a type (PositiveInt) that is not backed by a class/, + "Delegating to a type that is not backed by a class"); + + isa_ok( + $exception, + "Moose::Exception::DelegationToATypeWhichIsNotAClass", + "Delegating to a type that is not backed by a class"); + + is( + $exception->attribute->type_constraint->name, + 'PositiveInt', + "Delegating to a type that is not backed by a class"); +} + +{ + my $exception = exception { + { + package Foo1; + use Moose; + has 'bar' => ( + is => 'ro', + does => '', + handles => qr/xyz/, + ); + } + }; + + like( + $exception, + qr/Cannot find delegate metaclass for attribute bar/, + "no does or isa is given"); + + isa_ok( + $exception, + "Moose::Exception::CannotFindDelegateMetaclass", + "no does or isa is given"); + + is( + $exception->attribute->name, + 'bar', + "no does or isa is given"); +} + +# tests for type coercions +{ + use Moose; + use Moose::Util::TypeConstraints; + subtype 'HexNum' => as 'Int', where { /[a-f0-9]/i }; + my $type_object = find_type_constraint 'HexNum'; + + my $exception = exception { + $type_object->coerce; + }; + + like( + $exception, + qr/Cannot coerce without a type coercion/, + "You cannot coerce a type unless coercion is supported by that type"); + + isa_ok( + $exception, + "Moose::Exception::CoercingWithoutCoercions", + "You cannot coerce a type unless coercion is supported by that type"); + + is( + $exception->type_name, + 'HexNum', + "You cannot coerce a type unless coercion is supported by that type"); +} + +{ + { + package Parent; + use Moose; + + has foo => ( + is => 'rw', + isa => 'Num', + default => 5.5, + ); + } + + { + package Child; + use Moose; + extends 'Parent'; + + has '+foo' => ( + isa => 'Int', + default => 100, + ); + } + + my $foo = Child->new; + my $exception = exception { + $foo->foo(10.5); + }; + + like( + $exception, + qr/\QAttribute (foo) does not pass the type constraint because: Validation failed for 'Int' with value 10.5/, + "10.5 is not an Int"); + + isa_ok( + $exception, + "Moose::Exception::ValidationFailedForInlineTypeConstraint", + "10.5 is not an Int"); + + is( + $exception->class_name, + "Child", + "10.5 is not an Int"); +} + +{ + { + package Foo2; + use Moose; + + has a4 => ( + traits => ['Array'], + is => 'rw', + isa => 'ArrayRef', + lazy => 1, + default => 'invalid', + clearer => '_clear_a4', + handles => { + get_a4 => 'get', + push_a4 => 'push', + accessor_a4 => 'accessor', + }, + ); + + has a5 => ( + traits => ['Array'], + is => 'rw', + isa => 'ArrayRef[Int]', + lazy => 1, + default => sub { [] }, + clearer => '_clear_a5', + handles => { + get_a5 => 'get', + push_a5 => 'push', + accessor_a5 => 'accessor', + }, + ); + } + + my $foo = Foo2->new; + + my $expect + = qr/\QAttribute (a4) does not pass the type constraint because: Validation failed for 'ArrayRef' with value \E.*invalid.*/; + + my $exception = exception { $foo->accessor_a4(0); }; + + like( + $exception, + $expect, + 'invalid default is caught when trying to read via accessor'); + #Attribute (a4) does not pass the type constraint because: Validation failed for 'ArrayRef' with value "invalid" + + isa_ok( + $exception, + "Moose::Exception::ValidationFailedForInlineTypeConstraint", + 'invalid default is caught when trying to read via accessor'); + + is( + $exception->class_name, + "Foo2", + 'invalid default is caught when trying to read via accessor'); + + $exception = exception { $foo->accessor_a4( 0 => 42 ); }; + + like( + $exception, + $expect, + 'invalid default is caught when trying to write via accessor'); + #Attribute (a4) does not pass the type constraint because: Validation failed for 'ArrayRef' with value "invalid" + + isa_ok( + $exception, + "Moose::Exception::ValidationFailedForInlineTypeConstraint", + 'invalid default is caught when trying to write via accessor'); + + is( + $exception->class_name, + "Foo2", + 'invalid default is caught when trying to write via accessor'); + + $exception = exception { $foo->push_a4(42); }; + + like( + $exception, + $expect, + 'invalid default is caught when trying to push'); + #Attribute (a4) does not pass the type constraint because: Validation failed for 'ArrayRef' with value "invalid" + + isa_ok( + $exception, + "Moose::Exception::ValidationFailedForInlineTypeConstraint", + 'invalid default is caught when trying to push'); + + is( + $exception->class_name, + "Foo2", + 'invalid default is caught when trying to push'); + + $exception = exception { $foo->get_a4(42); }; + + like( + $exception, + $expect, + 'invalid default is caught when trying to get'); + #Attribute (a4) does not pass the type constraint because: Validation failed for 'ArrayRef' with value "invalid" + + isa_ok( + $exception, + "Moose::Exception::ValidationFailedForInlineTypeConstraint", + 'invalid default is caught when trying to get'); + + is( + $exception->class_name, + "Foo2", + 'invalid default is caught when trying to get'); +} + +{ + my $class = Moose::Meta::Class->create("RedundantClass"); + my $attr = Moose::Meta::Attribute->new('foo', (auto_deref => 1, + isa => 'ArrayRef', + is => 'ro' + ) + ); + my $attr2 = $attr->clone_and_inherit_options( isa => 'Int'); + + my $exception = exception { + $attr2->get_value($class); + }; + + like( + $exception, + qr/Can not auto de-reference the type constraint 'Int'/, + "Cannot auto-deref with 'Int'"); + + isa_ok( + $exception, + "Moose::Exception::CannotAutoDereferenceTypeConstraint", + "Cannot auto-deref with 'Int'"); + + is( + $exception->attribute->name, + "foo", + "Cannot auto-deref with 'Int'"); + + is( + $exception->type_name, + "Int", + "Cannot auto-deref with 'Int'"); +} + +{ + { + my $parameterizable = subtype 'ParameterizableArrayRef', as 'ArrayRef'; + my $int = find_type_constraint('Int'); + my $from_parameterizable = $parameterizable->parameterize($int); + + { + package Parameterizable; + use Moose; + + has from_parameterizable => ( is => 'rw', isa => $from_parameterizable ); + } + } + + my $params = Parameterizable->new(); + my $exception = exception { + $params->from_parameterizable( 'Hello' ); + }; + + like( + $exception, + qr/\QAttribute (from_parameterizable) does not pass the type constraint because: Validation failed for 'ParameterizableArrayRef[Int]'\E with value "?Hello"?/, + "'Hello' is a Str"); + + isa_ok( + $exception, + "Moose::Exception::ValidationFailedForInlineTypeConstraint", + "'Hello' is a Str"); + + is( + $exception->class_name, + "Parameterizable", + "'Hello' is a Str"); + + is( + $exception->value, + "Hello", + "'Hello' is a Str"); + + is( + $exception->attribute_name, + "from_parameterizable", + "'Hello' is a Str"); +} + +{ + { + package Test::LazyBuild::Attribute; + use Moose; + + has 'fool' => ( lazy_build => 1, is => 'ro'); + } + + my $instance = Test::LazyBuild::Attribute->new; + + my $exception = exception { + $instance->fool; + }; + + like( + $exception, + qr/\QTest::LazyBuild::Attribute does not support builder method '_build_fool' for attribute 'fool' /, + "builder method _build_fool doesn't exist"); + + isa_ok( + $exception, + "Moose::Exception::BuilderMethodNotSupportedForInlineAttribute", + "builder method _build_fool doesn't exist"); + + is( + $exception->attribute_name, + "fool", + "builder method _build_fool doesn't exist"); + + is( + $exception->builder, + "_build_fool", + "builder method _build_fool doesn't exist"); + + is( + $exception->class_name, + "Test::LazyBuild::Attribute", + "builder method _build_fool doesn't exist"); +} + +{ + { + package Foo::Required; + use Moose; + + has 'foo_required' => ( + reader => 'get_foo_required', + writer => 'set_foo_required', + required => 1, + ); + } + + my $foo = Foo::Required->new(foo_required => "required"); + + my $exception = exception { + $foo->set_foo_required(); + }; + + like( + $exception, + qr/\QAttribute (foo_required) is required/, + "passing no value to set_foo_required"); + + isa_ok( + $exception, + "Moose::Exception::AttributeIsRequired", + "passing no value to set_foo_required"); + + is( + $exception->attribute_name, + 'foo_required', + "passing no value to set_foo_required"); + + isa_ok( + $exception->class_name, + 'Foo::Required', + "passing no value to set_foo_required"); +} + +{ + use Moose::Util::TypeConstraints; + + my $exception = exception { + { + package BadMetaClass; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => "Moose::Util::TypeConstraints", + handles => qr/hello/ + ); + } + }; + + like( + $exception, + qr/Unable to recognize the delegate metaclass 'Class::MOP::Package/, + "unable to recognize metaclass of Moose::Util::TypeConstraints"); + + isa_ok( + $exception, + "Moose::Exception::UnableToRecognizeDelegateMetaclass", + "unable to recognize metaclass of Moose::Util::TypeConstraints"); + + is( + $exception->attribute->name, + 'foo', + "unable to recognize metaclass of Moose::Util::TypeConstraints"); + + is( + $exception->delegate_metaclass->name, + 'Moose::Util::TypeConstraints', + "unable to recognize metaclass of Moose::Util::TypeConstraints"); +} + +{ + my $exception = exception { + package Foo::CannotCoerce::WithoutCoercion; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'Str', + coerce => 1 + ) + }; + + like( + $exception, + qr/\QYou cannot coerce an attribute (foo) unless its type (Str) has a coercion/, + "has throws error with odd number of attribute options"); + + isa_ok( + $exception, + "Moose::Exception::CannotCoerceAttributeWhichHasNoCoercion", + "has throws error with odd number of attribute options"); + + is( + $exception->attribute_name, + 'foo', + "has throws error with odd number of attribute options"); + + is( + $exception->type_name, + 'Str', + "has throws error with odd number of attribute options"); +} + +{ + my $exception = exception { + { + package Foo1; + use Moose; + has 'bar' => ( + is => + ); + } + }; + + like( + $exception, + qr/\QYou must pass an even number of attribute options/, + 'has throws exception with odd number of attribute options'); + + isa_ok( + $exception, + "Moose::Exception::MustPassEvenNumberOfAttributeOptions", + 'has throws exception with odd number of attribute options'); + + is( + $exception->attribute_name, + 'bar', + 'has throws exception with odd number of attribute options'); +} + +{ + my $exception = exception { + { + package Foo1; + use Moose; + has bar => ( + is => 'ro', + required => 1, + isa => 'Int', + ); + } + + Foo1->new(bar => "test"); + }; + + like( + $exception, + qr/^Attribute \(bar\) does not pass the type constraint because: Validation failed for 'Int' with value "?test"?/, + "bar is an 'Int' and 'Str' is given"); + #Attribute (bar) does not pass the type constraint because: Validation failed for 'Int' with value "test" + + isa_ok( + $exception, + "Moose::Exception::ValidationFailedForTypeConstraint", + "bar is an 'Int' and 'Str' is given"); +} + +done_testing; diff --git a/t/exceptions/class-mop-attribute.t b/t/exceptions/class-mop-attribute.t new file mode 100644 index 0000000..d710699 --- /dev/null +++ b/t/exceptions/class-mop-attribute.t @@ -0,0 +1,213 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + my $class = Class::MOP::Attribute->new; + }; + + like( + $exception, + qr/You must provide a name for the attribute/, + "no attribute name given to new"); + + isa_ok( + $exception, + "Moose::Exception::MOPAttributeNewNeedsAttributeName", + "no attribute name given to new"); +} + +{ + my $exception = exception { + Class::MOP::Attribute->new( "foo", ( builder => [123] )); + }; + + like( + $exception, + qr/builder must be a defined scalar value which is a method name/, + "an array ref is given as builder"); + + isa_ok( + $exception, + "Moose::Exception::BuilderMustBeAMethodName", + "an array ref is given as builder"); +} + +{ + my $exception = exception { + Class::MOP::Attribute->new( "foo", ( builder => "bar", default => "xyz" )); + }; + + like( + $exception, + qr/\QSetting both default and builder is not allowed./, + "builder & default, both are given"); + + isa_ok( + $exception, + "Moose::Exception::BothBuilderAndDefaultAreNotAllowed", + "builder & default, both are given"); +} + +{ + my $exception = exception { + Class::MOP::Attribute->new( "foo", ( default => [1] ) ); + }; + + like( + $exception, + qr/\QReferences are not allowed as default values, you must wrap the default of 'foo' in a CODE reference (ex: sub { [] } and not [])/, + "default value can't take references"); + + isa_ok( + $exception, + "Moose::Exception::ReferencesAreNotAllowedAsDefault", + "default value can't take references"); + + is( + $exception->attribute_name, + "foo", + "default value can't take references"); +} + +{ + my $exception = exception { + Class::MOP::Attribute->new( "foo", ( required => 1, init_arg => undef ) ); + }; + + like( + $exception, + qr/A required attribute must have either 'init_arg', 'builder', or 'default'/, + "no 'init_arg', 'builder' or 'default' is given"); + + isa_ok( + $exception, + "Moose::Exception::RequiredAttributeLacksInitialization", + "no 'init_arg', 'builder' or 'default' is given"); +} + +{ + my $exception = exception { + my $foo = Class::MOP::Attribute->new("bar", ( required => 1, init_arg => undef, builder => 'foo')); + $foo->initialize_instance_slot( $foo->meta, $foo ); + }; + + like( + $exception, + qr/\QClass::MOP::Attribute does not support builder method 'foo' for attribute 'bar'/, + "given builder method doesn't exist"); + + isa_ok( + $exception, + "Moose::Exception::BuilderMethodNotSupportedForAttribute", + "given builder method doesn't exist"); + + is( + $exception->attribute->name, + "bar", + "given builder method doesn't exist"); + + is( + $exception->attribute->builder, + "foo", + "given builder method doesn't exist"); +} + +{ + my $exception = exception { + my $foo = Class::MOP::Attribute->new("foo"); + $foo->attach_to_class( "Foo" ); + }; + + like( + $exception, + qr/\QYou must pass a Class::MOP::Class instance (or a subclass)/, + "attach_to_class expects an instance Class::MOP::Class or its subclass"); + + isa_ok( + $exception, + "Moose::Exception::AttachToClassNeedsAClassMOPClassInstanceOrASubclass", + "attach_to_class expects an instance Class::MOP::Class or its subclass"); + + is( + $exception->attribute->name, + "foo", + "attach_to_class expects an instance Class::MOP::Class or its subclass"); + + is( + $exception->class, + "Foo", + "attach_to_class expects an instance Class::MOP::Class or its subclass"); +} + +{ + my $array = ["foo"]; + my $bar = Class::MOP::Attribute->new("bar", ( is => 'ro', predicate => $array)); + my $exception = exception { + $bar->install_accessors; + }; + + like( + $exception, + qr!bad accessor/reader/writer/predicate/clearer format, must be a HASH ref!, + "an array reference is given to predicate"); + + isa_ok( + $exception, + "Moose::Exception::BadOptionFormat", + "an array reference is given to predicate"); + + is( + $exception->attribute->name, + "bar", + "an array reference is given to predicate"); + + is( + $exception->option_name, + "predicate", + "an array reference is given to predicate"); + + is( + $exception->option_value, + $array, + "an array reference is given to predicate"); +} + +{ + my $bar = Class::MOP::Attribute->new("bar", ( is => 'ro', predicate => "foo")); + my $exception = exception { + $bar->install_accessors; + }; + + like( + $exception, + qr/\QCould not create the 'predicate' method for bar because : Can't call method "name" on an undefined value/, + "Can't call method 'name' on an undefined value"); + + isa_ok( + $exception, + "Moose::Exception::CouldNotCreateMethod", + "Can't call method 'name' on an undefined value"); + + is( + $exception->attribute->name, + "bar", + "Can't call method 'name' on an undefined value"); + + is( + $exception->option_name, + "predicate", + "Can't call method 'name' on an undefined value"); + + is( + $exception->option_value, + "foo", + "Can't call method 'name' on an undefined value"); +} + +done_testing; diff --git a/t/exceptions/class-mop-class-immutable-trait.t b/t/exceptions/class-mop-class-immutable-trait.t new file mode 100644 index 0000000..abefba7 --- /dev/null +++ b/t/exceptions/class-mop-class-immutable-trait.t @@ -0,0 +1,57 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + package Foo; + use Moose; + __PACKAGE__->meta->make_immutable; + __PACKAGE__->meta->superclasses("Bar"); + }; + + like( + $exception, + qr/The 'superclasses' method is read-only when called on an immutable instance/, + "calling 'foo' on an immutable instance"); + + isa_ok( + $exception, + "Moose::Exception::CallingReadOnlyMethodOnAnImmutableInstance", + "calling 'foo' on an immutable instance"); + + is( + $exception->method_name, + "superclasses", + "calling 'foo' on an immutable instance"); +} + +{ + my $exception = exception { + package Foo; + use Moose; + __PACKAGE__->meta->make_immutable; + __PACKAGE__->meta->add_method( foo => sub { "foo" } ); + }; + + like( + $exception, + qr/The 'add_method' method cannot be called on an immutable instance/, + "calling 'add_method' on an immutable instance"); + + isa_ok( + $exception, + "Moose::Exception::CallingMethodOnAnImmutableInstance", + "calling 'add_method' on an immutable instance"); + + is( + $exception->method_name, + "add_method", + "calling 'add_method' on an immutable instance"); +} + +done_testing; diff --git a/t/exceptions/class-mop-class.t b/t/exceptions/class-mop-class.t new file mode 100644 index 0000000..7e4a447 --- /dev/null +++ b/t/exceptions/class-mop-class.t @@ -0,0 +1,685 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + my $class = Class::MOP::Class::initialize; + }; + + like( + $exception, + qr/You must pass a package name and it cannot be blessed/, + "no package name given to initialize"); + + isa_ok( + $exception, + "Moose::Exception::InitializeTakesUnBlessedPackageName", + "no package name given to initialize"); +} + +{ + my $exception = exception { + my $class = Class::MOP::Class::create("Foo" => ( superclasses => ('foo') )); + }; + + like( + $exception, + qr/You must pass an ARRAY ref of superclasses/, + "an Array is of superclasses is passed"); + + isa_ok( + $exception, + "Moose::Exception::CreateMOPClassTakesArrayRefOfSuperclasses", + "an Array is of superclasses is passed"); + + is( + $exception->class, + 'Foo', + "an Array is of superclasses is passed"); +} + + +{ + my $exception = exception { + my $class = Class::MOP::Class::create("Foo" => ( attributes => ('foo') )); + }; + + like( + $exception, + qr/You must pass an ARRAY ref of attributes/, + "an Array is of attributes is passed"); + + isa_ok( + $exception, + "Moose::Exception::CreateMOPClassTakesArrayRefOfAttributes", + "an Array is of attributes is passed"); + + is( + $exception->class, + 'Foo', + "an Array is of attributes is passed"); +} + +{ + my $exception = exception { + my $class = Class::MOP::Class::create("Foo" => ( methods => ('foo') ) ); + }; + + like( + $exception, + qr/You must pass an HASH ref of methods/, + "a Hash is of methods is passed"); + + isa_ok( + $exception, + "Moose::Exception::CreateMOPClassTakesHashRefOfMethods", + "a Hash is of methods is passed"); + + is( + $exception->class, + 'Foo', + "a Hash is of methods is passed"); +} + +{ + my $exception = exception { + my $class = Class::MOP::Class->create("Foo"); + $class->find_method_by_name; + }; + + like( + $exception, + qr/You must define a method name to find/, + "no method name given to find_method_by_name"); + + isa_ok( + $exception, + "Moose::Exception::MethodNameNotGiven", + "no method name given to find_method_by_name"); + + is( + $exception->class_name, + 'Foo', + "no method name given to find_method_by_name"); +} + +{ + my $exception = exception { + my $class = Class::MOP::Class->create("Foo"); + $class->find_all_methods_by_name; + }; + + like( + $exception, + qr/You must define a method name to find/, + "no method name given to find_all_methods_by_name"); + + isa_ok( + $exception, + "Moose::Exception::MethodNameNotGiven", + "no method name given to find_all_methods_by_name"); + + is( + $exception->class_name, + 'Foo', + "no method name given to find_all_methods_by_name"); +} + +{ + my $exception = exception { + my $class = Class::MOP::Class->create("Foo"); + $class->find_next_method_by_name; + }; + + like( + $exception, + qr/You must define a method name to find/, + "no method name given to find_next_method_by_name"); + + isa_ok( + $exception, + "Moose::Exception::MethodNameNotGiven", + "no method name given to find_next_method_by_name"); + + is( + $exception->class_name, + 'Foo', + "no method name given to find_next_method_by_name"); +} + +{ + my $class = Class::MOP::Class->create("Foo"); + my $foo = "foo"; + my $exception = exception { + $class->clone_object( $foo ); + }; + + like( + $exception, + qr/\QYou must pass an instance of the metaclass (Foo), not (foo)/, + "clone_object expects an instance of the metaclass"); + + isa_ok( + $exception, + "Moose::Exception::CloneObjectExpectsAnInstanceOfMetaclass", + "clone_object expects an instance of the metaclass"); + + is( + $exception->class_name, + 'Foo', + "clone_object expects an instance of the metaclass"); + + is( + $exception->instance, + 'foo', + "clone_object expects an instance of the metaclass"); +} + +{ + { + package Foo; + use Moose; + } + { + package Foo2; + use Moose; + } + my $foo2 = Foo2->new; + my $exception = exception { + Foo->meta->rebless_instance( $foo2 ); + }; + + like( + $exception, + qr/\QYou may rebless only into a subclass of (Foo2), of which (Foo) isn't./, + "you can rebless only into subclass"); + + isa_ok( + $exception, + "Moose::Exception::CanReblessOnlyIntoASubclass", + "you can rebless only into subclass"); + + is( + $exception->class_name, + 'Foo', + "you can rebless only into subclass"); + + is( + $exception->instance, + $foo2, + "you can rebless only into subclass"); +} + +{ + { + package Foo; + use Moose; + } + { + package Foo2; + use Moose; + } + my $foo = Foo->new; + my $exception = exception { + Foo2->meta->rebless_instance_back( $foo ); + }; + + like( + $exception, + qr/\QYou may rebless only into a superclass of (Foo), of which (Foo2) isn't./, + "you can rebless only into superclass"); + + isa_ok( + $exception, + "Moose::Exception::CanReblessOnlyIntoASuperclass", + "you can rebless only into superclass"); + + is( + $exception->instance, + $foo, + "you can rebless only into superclass"); + + is( + $exception->class_name, + "Foo2", + "you can rebless only into superclass"); +} + +{ + { + package Foo; + use Moose; + } + my $exception = exception { + Foo->meta->add_before_method_modifier; + }; + + like( + $exception, + qr/You must pass in a method name/, + "no method name passed to method modifier"); + + isa_ok( + $exception, + "Moose::Exception::MethodModifierNeedsMethodName", + "no method name passed to method modifier"); + + is( + $exception->class_name, + "Foo", + "no method name passed to method modifier"); +} + +{ + { + package Foo; + use Moose; + } + my $exception = exception { + Foo->meta->add_after_method_modifier; + }; + + like( + $exception, + qr/You must pass in a method name/, + "no method name passed to method modifier"); + + isa_ok( + $exception, + "Moose::Exception::MethodModifierNeedsMethodName", + "no method name passed to method modifier"); + + is( + $exception->class_name, + "Foo", + "no method name passed to method modifier"); +} + +{ + { + package Foo; + use Moose; + } + my $exception = exception { + Foo->meta->add_around_method_modifier; + }; + + like( + $exception, + qr/You must pass in a method name/, + "no method name passed to method modifier"); + + isa_ok( + $exception, + "Moose::Exception::MethodModifierNeedsMethodName", + "no method name passed to method modifier"); + + is( + $exception->class_name, + "Foo", + "no method name passed to method modifier"); +} + +{ + my $exception = exception { + my $class = Class::MOP::Class->_construct_class_instance; + }; + + like( + $exception, + qr/You must pass a package name/, + "no package name given to _construct_class_instance"); + + isa_ok( + $exception, + "Moose::Exception::ConstructClassInstanceTakesPackageName", + "no package name given to _construct_class_instance"); +} + +{ + my $class = Class::MOP::Class->create("Foo"); + my $exception = exception { + $class->add_before_method_modifier("foo"); + }; + + like( + $exception, + qr/The method 'foo' was not found in the inheritance hierarchy for Foo/, + 'method "foo" is not defined in class "Foo"'); + + isa_ok( + $exception, + "Moose::Exception::MethodNameNotFoundInInheritanceHierarchy", + 'method "foo" is not defined in class "Foo"'); + + is( + $exception->class_name, + 'Foo', + 'method "foo" is not defined in class "Foo"'); + + is( + $exception->method_name, + 'foo', + 'method "foo" is not defined in class "Foo"'); +} + +{ + { + package Bar; + use Moose; + } + my $bar = Bar->new; + my $class = Class::MOP::Class->create("Foo"); + my $exception = exception { + $class->new_object( ( __INSTANCE__ => $bar ) ); + }; + + like( + $exception, + qr/\QObjects passed as the __INSTANCE__ parameter must already be blessed into the correct class, but $bar is not a Foo/, + "__INSTANCE__ is not blessed correctly"); + #Objects passed as the __INSTANCE__ parameter must already be blessed into the correct class, but Bar=HASH(0x2d77528) is not a Foo + + isa_ok( + $exception, + "Moose::Exception::InstanceBlessedIntoWrongClass", + "__INSTANCE__ is not blessed correctly"); + + is( + $exception->class_name, + 'Foo', + "__INSTANCE__ is not blessed correctly"); + + is( + $exception->instance, + $bar, + "__INSTANCE__ is not blessed correctly"); +} + +{ + my $class = Class::MOP::Class->create("Foo"); + my $array = [1,2,3]; + my $exception = exception { + $class->new_object( ( __INSTANCE__ => $array ) ); + }; + + like( + $exception, + qr/\QThe __INSTANCE__ parameter must be a blessed reference, not $array/, + "__INSTANCE__ is not a blessed reference"); + #The __INSTANCE__ parameter must be a blessed reference, not ARRAY(0x1d75d40) + + isa_ok( + $exception, + "Moose::Exception::InstanceMustBeABlessedReference", + "__INSTANCE__ is not a blessed reference"); + + is( + $exception->class_name, + 'Foo', + "__INSTANCE__ is not a blessed reference"); + + is( + $exception->instance, + $array, + "__INSTANCE__ is not a blessed reference"); +} + +{ + my $array = [1, 2, 3]; + my $class = Class::MOP::Class->create("Foo"); + my $exception = exception { + $class->_clone_instance($array); + }; + + like( + $exception, + qr/\QYou can only clone instances, ($array) is not a blessed instance/, + "array reference was passed to _clone_instance instead of a blessed instance"); + #You can only clone instances, (ARRAY(0x2162350)) is not a blessed instance + + isa_ok( + $exception, + "Moose::Exception::OnlyInstancesCanBeCloned", + "array reference was passed to _clone_instance instead of a blessed instance"); + + is( + $exception->class_name, + "Foo", + "array reference was passed to _clone_instance instead of a blessed instance"); + + is( + $exception->instance, + $array, + "array reference was passed to _clone_instance instead of a blessed instance"); +} + +{ + { + package My::Role; + use Moose::Role; + } + + my $exception = exception { + Class::MOP::Class->create("My::Class", superclasses => ["My::Role"]); + }; + + like( + $exception, + qr/\QThe metaclass of My::Class (Class::MOP::Class) is not compatible with the metaclass of its superclass, My::Role (Moose::Meta::Role) /, + "Trying to inherit a Role"); + + isa_ok( + $exception, + "Moose::Exception::IncompatibleMetaclassOfSuperclass", + "Trying to inherit a Role"); + + is( + $exception->class_name, + "My::Class", + "Trying to inherit a Role"); + + is( + $exception->superclass_name, + "My::Role", + "Trying to inherit a Role"); +} + +{ + { + package Super::Class; + use Moose; + } + + my $class = Class::MOP::Class->create("TestClass", superclasses => ["Super::Class"]); + $class->immutable_trait(undef); + my $exception = exception { + $class->make_immutable( immutable_trait => ''); + }; + + like( + $exception, + qr/\Qno immutable trait specified for $class/, + "immutable_trait set to undef"); + #no immutable trait specified for Moose::Meta::Class=HASH(0x19a2280) + + isa_ok( + $exception, + "Moose::Exception::NoImmutableTraitSpecifiedForClass", + "immutable_trait set to undef"); + + is( + $exception->class_name, + "TestClass", + "immutable_trait set to undef"); +} + +{ + my $exception = exception { + package NoDestructorClass; + use Moose; + + __PACKAGE__->meta->make_immutable( destructor_class => undef, inline_destructor => 1 ); + }; + + like( + $exception, + qr/The 'inline_destructor' option is present, but no destructor class was specified/, + "destructor_class is set to undef"); + + isa_ok( + $exception, + "Moose::Exception::NoDestructorClassSpecified", + "destructor_class is set to undef"); + + is( + $exception->class_name, + "NoDestructorClass", + "destructor_class is set to undef"); +} + +{ + { + package Foo9::Meta::Role; + use Moose::Role; + } + + { + package Foo9::SuperClass::WithMetaRole; + use Moose -traits =>'Foo9::Meta::Role'; + } + + { + package Foo9::Meta::OtherRole; + use Moose::Role; + } + + { + package Foo9::SuperClass::After::Attribute; + use Moose -traits =>'Foo9::Meta::OtherRole'; + } + + my $exception = exception { + { + package Foo9; + use Moose; + my @superclasses = ('Foo9::SuperClass::WithMetaRole'); + extends @superclasses; + + has an_attribute_generating_methods => ( is => 'ro' ); + + push(@superclasses, 'Foo9::SuperClass::After::Attribute'); + + extends @superclasses; + } + }; + + like( + $exception, + qr/\QCan't fix metaclass incompatibility for Foo9 because it is not pristine./, + "cannot make metaclass compatible"); + + isa_ok( + $exception, + "Moose::Exception::CannotFixMetaclassCompatibility", + "cannot make metaclass compatible"); + + is( + $exception->class_name, + "Foo9", + "cannot make metaclass compatible"); +} + +{ + Class::MOP::Class->create( "Foo::Meta::Attribute", + superclasses => ["Class::MOP::Attribute"] + ); + + Class::MOP::Class->create( "Bar::Meta::Attribute", + superclasses => ["Class::MOP::Attribute"] + ); + + Class::MOP::Class->create( "Foo::Meta::Class", + superclasses => ["Class::MOP::Class"] + ); + + Foo::Meta::Class->create( + 'Foo::All', + attribute_metaclass => "Foo::Meta::Attribute", + ); + + { + Class::MOP::Class->create( + 'Foo::Unsafe', + attribute_metaclass => 'Foo::Meta::Attribute', + ); + + my $meta = Class::MOP::Class->create( + 'Foo::Unsafe::Sub', + ); + + $meta->add_attribute(foo => reader => 'foo'); + + my $exception = exception { + $meta->superclasses('Foo::Unsafe'); + }; + + like( + $exception, + qr/\QCan't fix metaclass incompatibility for Foo::Unsafe::Sub because it is not pristine./, + "cannot make metaclass compatible"); + + isa_ok( + $exception, + "Moose::Exception::CannotFixMetaclassCompatibility", + "cannot make metaclass compatible"); + + is( + $exception->class_name, + "Foo::Unsafe::Sub", + "cannot make metaclass compatible"); + } + + { + my $exception = exception { + Foo::Meta::Class->create( + "Foo::All::Sub::Attribute", + superclasses => ['Foo::All'], + attribute_metaclass => "Foo::Meta::Attribute", + attribute_metaclass => "Bar::Meta::Attribute", + ) + }; + + like( + $exception, + qr/\QThe attribute_metaclass metaclass for Foo::All::Sub::Attribute (Bar::Meta::Attribute) is not compatible with the attribute metaclass of its superclass, Foo::All (Foo::Meta::Attribute)/, + "incompatible attribute_metaclass"); + + isa_ok( + $exception, + "Moose::Exception::MetaclassTypeIncompatible", + "incompatible attribute_metaclass"); + + is( + $exception->class_name, + "Foo::All::Sub::Attribute", + "incompatible attribute_metaclass"); + + is( + $exception->superclass_name, + "Foo::All", + "incompatible attribute_metaclass"); + + is( + $exception->metaclass_type, + "attribute_metaclass", + "incompatible attribute_metaclass"); + } +} + +done_testing; diff --git a/t/exceptions/class-mop-method-accessor.t b/t/exceptions/class-mop-method-accessor.t new file mode 100644 index 0000000..b83a2df --- /dev/null +++ b/t/exceptions/class-mop-method-accessor.t @@ -0,0 +1,279 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + Class::MOP::Method::Accessor->new; + }; + + like( + $exception, + qr/\QYou must supply an attribute to construct with/, + "no attribute is given"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyAnAttributeToConstructWith", + "no attribute is given"); +} + +{ + my $exception = exception { + Class::MOP::Method::Accessor->new( attribute => "foo" ); + }; + + like( + $exception, + qr/\QYou must supply an accessor_type to construct with/, + "no accessor_type is given"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyAnAccessorTypeToConstructWith", + "no accessor_type is given"); +} + +{ + my $exception = exception { + Class::MOP::Method::Accessor->new( accessor_type => 'reader', attribute => "foo" ); + }; + + like( + $exception, + qr/\QYou must supply an attribute which is a 'Class::MOP::Attribute' instance/, + "attribute isn't an instance of Class::MOP::Attribute"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyAClassMOPAttributeInstance", + "attribute isn't an instance of Class::MOP::Attribute"); +} + +{ + my $attr = Class::MOP::Attribute->new("Foo", ( is => 'ro')); + my $exception = exception { + Class::MOP::Method::Accessor->new( accessor_type => "reader", attribute => $attr); + }; + + like( + $exception, + qr/\QYou must supply the package_name and name parameters/, + "no package_name and name is given"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyPackageNameAndName", + "no package_name and name is given"); +} + +{ + my $attr = Class::MOP::Attribute->new("foo", ( is => 'ro')); + my $accessor = Class::MOP::Method::Accessor->new( accessor_type => "reader", attribute => $attr, name => "foo", package_name => "Foo"); + my $exception = exception { + my $subr = $accessor->_generate_accessor_method_inline(); + }; + + like( + $exception, + qr/\QCould not generate inline accessor because : Can't call method "get_meta_instance" on an undefined value/, + "can't call get_meta_instance on an undefined value"); + + isa_ok( + $exception, + "Moose::Exception::CouldNotGenerateInlineAttributeMethod", + "can't call get_meta_instance on an undefined value"); + + is( + $exception->option, + "accessor", + "can't call get_meta_instance on an undefined value"); +} + +{ + my $attr = Class::MOP::Attribute->new("foo", ( is => 'ro')); + my $accessor = Class::MOP::Method::Accessor->new( accessor_type => "reader", attribute => $attr, name => "foo", package_name => "Foo"); + my $exception = exception { + my $subr = $accessor->_generate_reader_method_inline(); + }; + + like( + $exception, + qr/\QCould not generate inline reader because : Can't call method "get_meta_instance" on an undefined value/, + "can't call get_meta_instance on an undefined value"); + + isa_ok( + $exception, + "Moose::Exception::CouldNotGenerateInlineAttributeMethod", + "can't call get_meta_instance on an undefined value"); + + is( + $exception->option, + "reader", + "can't call get_meta_instance on an undefined value"); +} + +{ + my $attr = Class::MOP::Attribute->new("foo", ( is => 'ro')); + my $accessor = Class::MOP::Method::Accessor->new( accessor_type => "reader", attribute => $attr, name => "foo", package_name => "Foo"); + my $exception = exception { + my $subr = $accessor->_generate_writer_method_inline(); + }; + + like( + $exception, + qr/\QCould not generate inline writer because : Can't call method "get_meta_instance" on an undefined value/, + "can't call get_meta_instance on an undefined value"); + + isa_ok( + $exception, + "Moose::Exception::CouldNotGenerateInlineAttributeMethod", + "can't call get_meta_instance on an undefined value"); + + is( + $exception->option, + "writer", + "can't call get_meta_instance on an undefined value"); +} + +{ + my $attr = Class::MOP::Attribute->new("foo", ( is => 'ro')); + my $accessor = Class::MOP::Method::Accessor->new( accessor_type => "reader", attribute => $attr, name => "foo", package_name => "Foo"); + my $exception = exception { + my $subr = $accessor->_generate_predicate_method_inline(); + }; + + like( + $exception, + qr/\QCould not generate inline predicate because : Can't call method "get_meta_instance" on an undefined value/, + "can't call get_meta_instance on an undefined value"); + + isa_ok( + $exception, + "Moose::Exception::CouldNotGenerateInlineAttributeMethod", + "can't call get_meta_instance on an undefined value"); + + is( + $exception->option, + "predicate", + "can't call get_meta_instance on an undefined value"); +} + +{ + my $attr = Class::MOP::Attribute->new("foo", ( is => 'ro')); + my $accessor = Class::MOP::Method::Accessor->new( accessor_type => "reader", attribute => $attr, name => "foo", package_name => "Foo"); + my $exception = exception { + my $subr = $accessor->_generate_clearer_method_inline(); + }; + + like( + $exception, + qr/\QCould not generate inline clearer because : Can't call method "get_meta_instance" on an undefined value/, + "can't call get_meta_instance on an undefined value"); + + isa_ok( + $exception, + "Moose::Exception::CouldNotGenerateInlineAttributeMethod", + "can't call get_meta_instance on an undefined value"); + + is( + $exception->option, + "clearer", + "can't call get_meta_instance on an undefined value"); +} + +{ + { + package Foo::ReadOnlyAccessor; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'Int', + ); + } + + my $foo = Foo::ReadOnlyAccessor->new; + + my $exception = exception { + $foo->foo(120); + }; + + like( + $exception, + qr/Cannot assign a value to a read-only accessor/, + "foo is read only"); + + isa_ok( + $exception, + "Moose::Exception::CannotAssignValueToReadOnlyAccessor", + "foo is read only"); + + is( + $exception->class_name, + "Foo::ReadOnlyAccessor", + "foo is read only"); + + is( + $exception->attribute_name, + "foo", + "foo is read only"); + + is( + $exception->value, + 120, + "foo is read only"); +} + +{ + { + package Point; + use metaclass; + + Point->meta->add_attribute('x' => ( + reader => 'x', + init_arg => 'x' + )); + + sub new { + my $class = shift; + bless $class->meta->new_object(@_) => $class; + } + } + + my $point = Point->new(); + + my $exception = exception { + $point->x(120); + }; + + like( + $exception, + qr/Cannot assign a value to a read-only accessor/, + "x is read only"); + + isa_ok( + $exception, + "Moose::Exception::CannotAssignValueToReadOnlyAccessor", + "x is read only"); + + is( + $exception->class_name, + "Point", + "x is read only"); + + is( + $exception->attribute_name, + "x", + "x is read only"); + + is( + $exception->value, + 120, + "x is read only"); +} +done_testing; diff --git a/t/exceptions/class-mop-method-constructor.t b/t/exceptions/class-mop-method-constructor.t new file mode 100644 index 0000000..dd87f4a --- /dev/null +++ b/t/exceptions/class-mop-method-constructor.t @@ -0,0 +1,75 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + Class::MOP::Method::Constructor->new( is_inline => 1); + }; + + like( + $exception, + qr/\QYou must pass a metaclass instance if you want to inline/, + "no metaclass is given"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyAMetaclass", + "no metaclass is given"); +} + +{ + my $exception = exception { + Class::MOP::Method::Constructor->new; + }; + + like( + $exception, + qr/\QYou must supply the package_name and name parameters/, + "no package_name and name is given"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyPackageNameAndName", + "no package_name and name is given"); +} + +{ + BEGIN + { + { + package NewMetaClass; + use Moose; + extends 'Moose::Meta::Class'; + + sub _inline_new_object { + return 'print "xyz'; # this is a intentional syntax error, + } + } + }; + + { + package BadConstructorClass; + use Moose -metaclass => 'NewMetaClass'; + } + + my $exception = exception { + BadConstructorClass->meta->make_immutable(); + }; + + like( + $exception, + qr/Could not eval the constructor :/, + "syntax error in _inline_new_object"); + + isa_ok( + $exception, + "Moose::Exception::CouldNotEvalConstructor", + "syntax error in _inline_new_object"); +} + +done_testing; diff --git a/t/exceptions/class-mop-method-generated.t b/t/exceptions/class-mop-method-generated.t new file mode 100644 index 0000000..59a91b6 --- /dev/null +++ b/t/exceptions/class-mop-method-generated.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + Class::MOP::Method::Generated->new; + }; + + like( + $exception, + qr/\QClass::MOP::Method::Generated is an abstract base class, you must provide a constructor./, + "trying to call an abstract base class constructor"); + + isa_ok( + $exception, + "Moose::Exception::CannotCallAnAbstractBaseMethod", + "trying to call an abstract base class constructor"); +} + +{ + my $exception = exception { + Class::MOP::Method::Generated->_initialize_body; + }; + + like( + $exception, + qr/\QNo body to initialize, Class::MOP::Method::Generated is an abstract base class/, + "trying to call a method of an abstract class"); + + isa_ok( + $exception, + "Moose::Exception::NoBodyToInitializeInAnAbstractBaseClass", + "trying to call a method of an abstract class"); +} + +done_testing; diff --git a/t/exceptions/class-mop-method-meta.t b/t/exceptions/class-mop-method-meta.t new file mode 100644 index 0000000..ddd51aa --- /dev/null +++ b/t/exceptions/class-mop-method-meta.t @@ -0,0 +1,25 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + Class::MOP::Method::Meta->wrap("Foo", ( body => 'foo' )); + }; + + like( + $exception, + qr/\QOverriding the body of meta methods is not allowed/, + "body is given to Class::MOP::Method::Meta->wrap"); + + isa_ok( + $exception, + "Moose::Exception::CannotOverrideBodyOfMetaMethods", + "body is given to Class::MOP::Method::Meta->wrap"); +} + +done_testing; diff --git a/t/exceptions/class-mop-method-wrapped.t b/t/exceptions/class-mop-method-wrapped.t new file mode 100644 index 0000000..bf96dd8 --- /dev/null +++ b/t/exceptions/class-mop-method-wrapped.t @@ -0,0 +1,25 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + Class::MOP::Method::Wrapped->wrap("Foo"); + }; + + like( + $exception, + qr/\QCan only wrap blessed CODE/, + "no CODE is given to wrap"); + + isa_ok( + $exception, + "Moose::Exception::CanOnlyWrapBlessedCode", + "no CODE is given to wrap"); +} + +done_testing; diff --git a/t/exceptions/class-mop-method.t b/t/exceptions/class-mop-method.t new file mode 100644 index 0000000..c85cc7b --- /dev/null +++ b/t/exceptions/class-mop-method.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + Class::MOP::Method->wrap( "foo", ( name => "Bar")); + }; + + like( + $exception, + qr/\QYou must supply a CODE reference to bless, not (foo)/, + "first argument to wrap should be a CODE ref"); + + isa_ok( + $exception, + "Moose::Exception::WrapTakesACodeRefToBless", + "first argument to wrap should be a CODE ref"); +} + +{ + my $exception = exception { + Class::MOP::Method->wrap( sub { "foo" }, ()); + }; + + like( + $exception, + qr/You must supply the package_name and name parameters/, + "no package name is given to wrap"); + + isa_ok( + $exception, + "Moose::Exception::PackageNameAndNameParamsNotGivenToWrap", + "no package name is given to wrap"); +} + +done_testing; diff --git a/t/exceptions/class-mop-mixin-hasattributes.t b/t/exceptions/class-mop-mixin-hasattributes.t new file mode 100644 index 0000000..c498c4c --- /dev/null +++ b/t/exceptions/class-mop-mixin-hasattributes.t @@ -0,0 +1,98 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $xyz = bless [], "Bar"; + my $class; + my $exception = exception { + $class = Class::MOP::Class->create("Foo", (attributes => [$xyz])); + }; + + like( + $exception, + qr/\QYour attribute must be an instance of Class::MOP::Mixin::AttributeCore (or a subclass)/, + "an Array ref blessed into Bar is given to create"); + + isa_ok( + $exception, + "Moose::Exception::AttributeMustBeAnClassMOPMixinAttributeCoreOrSubclass", + "an Array ref blessed into Bar is given to create"); + + is( + $exception->attribute, + $xyz, + "an Array ref blessed into Bar is given to create"); +} + +{ + my $class = Class::MOP::Class->create("Foo"); + my $exception = exception { + $class->has_attribute; + }; + + like( + $exception, + qr/You must define an attribute name/, + "attribute name is not given"); + + isa_ok( + $exception, + "Moose::Exception::MustDefineAnAttributeName", + "attribute name is not given"); + + is( + $exception->class_name, + 'Foo', + "attribute name is not given"); +} + +{ + my $class = Class::MOP::Class->create("Foo"); + my $exception = exception { + $class->get_attribute; + }; + + like( + $exception, + qr/You must define an attribute name/, + "attribute name is not given"); + + isa_ok( + $exception, + "Moose::Exception::MustDefineAnAttributeName", + "attribute name is not given"); + + is( + $exception->class_name, + "Foo", + "attribute name is not given"); +} + +{ + my $class = Class::MOP::Class->create("Foo"); + my $exception = exception { + $class->remove_attribute; + }; + + like( + $exception, + qr/You must define an attribute name/, + "attribute name is not given"); + + isa_ok( + $exception, + "Moose::Exception::MustDefineAnAttributeName", + "attribute name is not given"); + + is( + $exception->class_name, + "Foo", + "attribute name is not given"); +} + +done_testing; diff --git a/t/exceptions/class-mop-mixin-hasmethods.t b/t/exceptions/class-mop-mixin-hasmethods.t new file mode 100644 index 0000000..d0d39dd --- /dev/null +++ b/t/exceptions/class-mop-mixin-hasmethods.t @@ -0,0 +1,141 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + { + package Foo; + use Moose::Role; + } + + my $exception = exception { + Foo->meta->has_method; + }; + + like( + $exception, + qr/\QYou must define a method name/, + "no method name is given"); + + isa_ok( + $exception, + "Moose::Exception::MustDefineAMethodName", + "no method name is given"); + + is( + $exception->instance, + Foo->meta, + "no method name is given"); +} + +{ + { + package Foo; + use Moose::Role; + } + + my $exception = exception { + Foo->meta->add_method; + }; + + like( + $exception, + qr/\QYou must define a method name/, + "no method name is given"); + + isa_ok( + $exception, + "Moose::Exception::MustDefineAMethodName", + "no method name is given"); + + is( + $exception->instance, + Foo->meta, + "no method name is given"); +} + +{ + { + package Foo; + use Moose::Role; + } + + my $exception = exception { + Foo->meta->get_method; + }; + + like( + $exception, + qr/\QYou must define a method name/, + "no method name is given"); + + isa_ok( + $exception, + "Moose::Exception::MustDefineAMethodName", + "no method name is given"); + + is( + $exception->instance, + Foo->meta, + "no method name is given"); +} + +{ + { + package Foo; + use Moose::Role; + } + + my $exception = exception { + Foo->meta->remove_method; + }; + + like( + $exception, + qr/\QYou must define a method name/, + "no method name is given"); + + isa_ok( + $exception, + "Moose::Exception::MustDefineAMethodName", + "no method name is given"); + + is( + $exception->instance, + Foo->meta, + "no method name is given"); +} + +{ + { + package Bar::Role; + use Moose::Role; + } + + my $meta = Bar::Role->meta; + + my $exception = exception { + $meta->wrap_method_body; + }; + + like( + $exception, + qr/Your code block must be a CODE reference/, + "no arguments passed to wrap_method_body"); + + isa_ok( + $exception, + "Moose::Exception::CodeBlockMustBeACodeRef", + "no arguments passed to wrap_method_body"); + + is( + $exception->instance, + $meta, + "no arguments passed to wrap_method_body"); +} + +done_testing; diff --git a/t/exceptions/class-mop-module.t b/t/exceptions/class-mop-module.t new file mode 100644 index 0000000..604fa88 --- /dev/null +++ b/t/exceptions/class-mop-module.t @@ -0,0 +1,25 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + Class::MOP::Module->create_anon(cache => 1); + }; + + like( + $exception, + qr/Modules are not cacheable/, + "can't cache anon packages"); + + isa_ok( + $exception, + "Moose::Exception::PackagesAndModulesAreNotCachable", + "can't cache anon packages"); +} + +done_testing; diff --git a/t/exceptions/class-mop-object.t b/t/exceptions/class-mop-object.t new file mode 100644 index 0000000..b41f93a --- /dev/null +++ b/t/exceptions/class-mop-object.t @@ -0,0 +1,109 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + my $exception = exception { + use Moose (); + # XXX call cmop version of throw_error here instead! + Moose->throw_error("Hello, I am an exception object"); + }; + + like( + $exception, + qr/Hello, I am an exception object/, + "throw_error stringifies to the message"); + + isa_ok( + $exception, + 'Moose::Exception::Legacy', + "exception"); +} + +{ + my $exception = exception { + use Moose (); + Moose->throw_error("Hello, ", "I am an ", "exception object"); + }; + + like( + $exception, + qr/Hello, I am an exception object/, + "throw_error stringifies to the full message"); + + isa_ok( + $exception, + 'Moose::Exception::Legacy', + "exception"); +} + +{ + BEGIN + { + { + package FooRole; + use Moose::Role; + + sub xyz { + print "In xyz method"; + } + } + + { + package FooMetaclass; + use Moose; + with 'FooRole'; + extends 'Moose::Meta::Class'; + + sub _inline_check_required_attr { + my $self = shift; + my ($attr) = @_; + + return unless defined $attr->init_arg; + return unless $attr->can('is_required') && $attr->is_required; + return if $attr->has_default || $attr->has_builder; + + return ( + 'if (!exists $params->{\'' . $attr->init_arg . '\'}) {', + $self->_inline_throw_error( + 'Legacy => '. + 'message => "An inline error" ' + ).';', + '}', + ); + } + } + } +}; + +{ + { + package Foo2; + use Moose -metaclass => 'FooMetaclass'; + + has 'baz' => ( + is => 'ro', + isa => 'Int', + required => 1, + ); + __PACKAGE__->meta->make_immutable; + } + + my $exception = exception { + my $test1 = Foo2->new; + }; + + like( + $exception, + qr/An inline error/, + "_inline_throw_error stringifies to the message"); + + isa_ok( + $exception, + 'Moose::Exception::Legacy', + "_inline_throw_error stringifies to the message"); +} + +done_testing(); diff --git a/t/exceptions/class-mop-package.t b/t/exceptions/class-mop-package.t new file mode 100644 index 0000000..4cf78e7 --- /dev/null +++ b/t/exceptions/class-mop-package.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + Class::MOP::Package->reinitialize; + }; + + like( + $exception, + qr/\QYou must pass a package name or an existing Class::MOP::Package instance/, + "no package name is given"); + + isa_ok( + $exception, + "Moose::Exception::MustPassAPackageNameOrAnExistingClassMOPPackageInstance", + "no package name is given"); +} + +{ + my $exception = exception { + Class::MOP::Package->create_anon(cache => 1); + }; + + like( + $exception, + qr/Packages are not cacheable/, + "can't cache anon packages"); + + isa_ok( + $exception, + "Moose::Exception::PackagesAndModulesAreNotCachable", + "can't cache anon packages"); +} + +done_testing; diff --git a/t/exceptions/class.t b/t/exceptions/class.t new file mode 100644 index 0000000..6adddc9 --- /dev/null +++ b/t/exceptions/class.t @@ -0,0 +1,304 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + my $exception = exception { + Moose::Meta::Class->create( + 'Made::Of::Fail', + superclasses => ['Class'], + roles => 'Foo', + ); + }; + + like( + $exception, + qr/You must pass an ARRAY ref of roles/, + "create takes an Array of roles"); + + isa_ok( + $exception, + "Moose::Exception::RolesInCreateTakesAnArrayRef", + "create takes an Array of roles"); +} + +{ + use Moose::Meta::Class; + + { + package Foo; + use Moose; + } + + my $exception = exception { + Foo->meta->add_role('Bar'); + }; + + like( + $exception, + qr/Roles must be instances of Moose::Meta::Role/, + "add_role takes an instance of Moose::Meta::Role"); + + isa_ok( + $exception, + 'Moose::Exception::AddRoleTakesAMooseMetaRoleInstance', + "add_role takes an instance of Moose::Meta::Role"); + + is( + $exception->class_name, + 'Foo', + "add_role to Moose::Meta::Role takes instances of Moose::Meta::Role"); + + is( + $exception->role_to_be_added, + "Bar", + "add_role to Moose::Meta::Role takes instances of Moose::Meta::Role"); +} + +{ + my $exception = exception { + package Foo; + use Moose; + Foo->meta->add_role_application(); + }; + + like( + $exception, + qr/Role applications must be instances of Moose::Meta::Role::Application::ToClass/, + "bar is not an instance of Moose::Meta::Role::Application::ToClass"); + + isa_ok( + $exception, + "Moose::Exception::InvalidRoleApplication", + "bar is not an instance of Moose::Meta::Role::Application::ToClass"); +} + +# tests for Moose::Meta::Class::does_role +{ + use Moose::Meta::Class; + + { + package Foo; + use Moose; + } + + my $exception = exception { + Foo->meta->does_role; + }; + + like( + $exception, + qr/You must supply a role name to look for/, + "Cannot call does_role without a role name"); + + isa_ok( + $exception, + 'Moose::Exception::RoleNameRequired', + "Cannot call does_role without a role name"); + + is( + $exception->class_name, + 'Foo', + "Cannot call does_role without a role name"); +} + +# tests for Moose::Meta::Class::excludes_role +{ + use Moose::Meta::Class; + + { + package Foo; + use Moose; + } + + my $exception = exception { + Foo->meta->excludes_role; + }; + + like( + $exception, + qr/You must supply a role name to look for/, + "Cannot call excludes_role without a role name"); + + isa_ok( + $exception, + 'Moose::Exception::RoleNameRequired', + "Cannot call excludes_role without a role name"); + + is( + $exception->class_name, + 'Foo', + "Cannot call excludes_role without a role name"); +} + +{ + my $exception = exception { + package Foo; + use Moose; + __PACKAGE__->meta->make_immutable; + Foo->new([]) + }; + + like( + $exception, + qr/^\QSingle parameters to new() must be a HASH ref/, + "A single non-hashref arg to a constructor throws an error"); + + isa_ok( + $exception, + "Moose::Exception::SingleParamsToNewMustBeHashRef", + "A single non-hashref arg to a constructor throws an error"); +} + +# tests for AttributeIsRequired for inline excpetions +{ + { + package Foo2; + use Moose; + + has 'baz' => ( + is => 'ro', + isa => 'Int', + required => 1, + ); + __PACKAGE__->meta->make_immutable; + } + + my $exception = exception { + my $test1 = Foo2->new; + }; + + like( + $exception, + qr/\QAttribute (baz) is required/, + "... must supply all the required attribute"); + + isa_ok( + $exception, + "Moose::Exception::AttributeIsRequired", + "... must supply all the required attribute"); + + is( + $exception->attribute_name, + 'baz', + "... must supply all the required attribute"); + + isa_ok( + $exception->class_name, + 'Foo2', + "... must supply all the required attribute"); +} + +{ + { + package Bar; + use Moose::Role; + } + + my $exception = exception { + package Foo3; + use Moose; + extends 'Bar'; + }; + + like( + $exception, + qr/^\QYou cannot inherit from a Moose Role (Bar)/, + "Class cannot extend a role"); + + isa_ok( + $exception, + 'Moose::Exception::CanExtendOnlyClasses', + "Class cannot extend a role"); + + is( + $exception->role_name, + 'Bar', + "Class cannot extend a role"); +} + +{ + my $exception = exception { + package Foo; + use Moose; + sub foo2 {} + override foo2 => sub {}; + }; + + like( + $exception, + qr/Cannot add an override method if a local method is already present/, + "there is already a method named foo2 defined in the class, so you can't override it"); + + isa_ok( + $exception, + 'Moose::Exception::CannotOverrideLocalMethodIsPresent', + "there is already a method named foo2 defined in the class, so you can't override it"); + + is( + $exception->class_name, + 'Foo', + "there is already a method named foo2 defined in the class, so you can't override it"); + + is( + $exception->method->name, + 'foo2', + "there is already a method named foo2 defined in the class, so you can't override it"); +} + +{ + my $exception = exception { + package Foo; + use Moose; + sub foo {} + augment foo => sub {}; + }; + + like( + $exception, + qr/Cannot add an augment method if a local method is already present/, + "there is already a method named foo defined in the class"); + + isa_ok( + $exception, + 'Moose::Exception::CannotAugmentIfLocalMethodPresent', + "there is already a method named foo defined in the class"); + + is( + $exception->class_name, + 'Foo', + "there is already a method named foo defined in the class"); + + is( + $exception->method->name, + 'foo', + "there is already a method named foo defined in the class"); +} + +{ + { + package Test; + use Moose; + } + + my $exception = exception { + package Test2; + use Moose; + extends 'Test'; + has '+bar' => ( default => 100 ); + }; + + like( + $exception, + qr/Could not find an attribute by the name of 'bar' to inherit from in Test2/, + "attribute 'bar' is not defined in the super class"); + + isa_ok( + $exception, + "Moose::Exception::NoAttributeFoundInSuperClass", + "attribute 'bar' is not defined in the super class"); +} + +done_testing; diff --git a/t/exceptions/cmop.t b/t/exceptions/cmop.t new file mode 100644 index 0000000..9021591 --- /dev/null +++ b/t/exceptions/cmop.t @@ -0,0 +1,20 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + my $exception = exception { + Class::MOP::Mixin->_throw_exception(Legacy => message => 'oh hai'); + }; + ok( + $exception->isa('Moose::Exception::Legacy'), + 'threw the right type', + ); + is($exception->message, 'oh hai', 'got the message attribute'); +} + +done_testing; diff --git a/t/exceptions/exception-lazyattributeneedsadefault.t b/t/exceptions/exception-lazyattributeneedsadefault.t new file mode 100644 index 0000000..c0eb4a2 --- /dev/null +++ b/t/exceptions/exception-lazyattributeneedsadefault.t @@ -0,0 +1,66 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util 'throw_exception'; + +{ + package Foo; + use Moose; + + has 'foo' => ( + is => 'ro' + ); + + has 'bar' => ( + is => 'ro' + ); +} + +{ + my $exception = exception { + throw_exception( LazyAttributeNeedsADefault => attribute_name => "foo", + attribute => Foo->meta->get_attribute("bar") + ); + }; + + like( + $exception, + qr/\Qattribute_name (foo) does not match attribute->name (bar)/, + "you have given attribute_name as 'foo' and attribute->name as 'bar'"); + + isa_ok( + $exception, + "Moose::Exception::AttributeNamesDoNotMatch", + "you have given attribute_name as 'foo' and attribute->name as 'bar'"); + + is( + $exception->attribute_name, + "foo", + "you have given attribute_name as 'foo' and attribute->name as 'bar'"); + + is( + $exception->attribute->name, + "bar", + "you have given attribute_name as 'foo' and attribute->name as 'bar'"); +} + +{ + my $exception = exception { + throw_exception("LazyAttributeNeedsADefault"); + }; + + like( + $exception, + qr/\QYou need to give attribute or attribute_name or both/, + "please give either attribute or attribute_name"); + + isa_ok( + $exception, + "Moose::Exception::NeitherAttributeNorAttributeNameIsGiven", + "please give either attribute or attribute_name"); +} + +done_testing; diff --git a/t/exceptions/frame-leak.t b/t/exceptions/frame-leak.t new file mode 100644 index 0000000..e11bd63 --- /dev/null +++ b/t/exceptions/frame-leak.t @@ -0,0 +1,23 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::Requires 'Test::Memory::Cycle'; + +BEGIN { + plan skip_all => 'Leak tests fail under Devel::Cover' if $INC{'Devel/Cover.pm'}; +} + +{ + package Foo; + use Moose; + has myattr => ( is => 'ro', required => 1 ); +} + +memory_cycle_ok( + exception { Foo->new() }, + 'exception objects do not leak arguments into Devel::StackTrace objects', +); + +done_testing; diff --git a/t/exceptions/meta-role.t b/t/exceptions/meta-role.t new file mode 100644 index 0000000..2fb1013 --- /dev/null +++ b/t/exceptions/meta-role.t @@ -0,0 +1,242 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + { + package JustATestRole; + use Moose::Role; + } + + { + package JustATestClass; + use Moose; + } + + my $class = JustATestClass->meta; + my $exception = exception { + JustATestRole->meta->add_attribute( $class ); + }; + + like( + $exception, + qr/\QCannot add a Moose::Meta::Class as an attribute to a role/, + "Roles cannot have a class as an attribute"); + + isa_ok( + $exception, + "Moose::Exception::CannotAddAsAnAttributeToARole", + "Roles cannot have a class as an attribute"); + + is( + $exception->role_name, + 'JustATestRole', + "Roles cannot have a class as an attribute"); + + is( + $exception->attribute_class, + "Moose::Meta::Class", + "Roles cannot have a class as an attribute"); +} + +{ + my $exception = exception { + package JustATestRole; + use Moose::Role; + + has '+attr' => ( + is => 'ro', + ); + }; + + like( + $exception, + qr/\Qhas '+attr' is not supported in roles/, + "Attribute Extension is not supported in roles"); + + isa_ok( + $exception, + "Moose::Exception::AttributeExtensionIsNotSupportedInRoles", + "Attribute Extension is not supported in roles"); + + is( + $exception->role_name, + 'JustATestRole', + "Attribute Extension is not supported in roles"); + + is( + $exception->attribute_name, + "+attr", + "Attribute Extension is not supported in roles"); +} + +{ + my $exception = exception { + package JustATestRole; + use Moose::Role; + + sub bar {} + + override bar => sub {}; + }; + + like( + $exception, + qr/\QCannot add an override of method 'bar' because there is a local version of 'bar'/, + "Cannot override bar, because it's a local method"); + + isa_ok( + $exception, + "Moose::Exception::CannotOverrideALocalMethod", + "Cannot override bar, because it's a local method"); + + is( + $exception->role_name, + 'JustATestRole', + "Cannot override bar, because it's a local method"); + + is( + $exception->method_name, + "bar", + "Cannot override bar, because it's a local method"); +} + +{ + { + package JustATestRole; + use Moose::Role; + } + + my $exception = exception { + JustATestRole->meta->add_role("xyz"); + }; + + like( + $exception, + qr/\QRoles must be instances of Moose::Meta::Role/, + "add_role to Moose::Meta::Role takes instances of Moose::Meta::Role"); + + isa_ok( + $exception, + "Moose::Exception::AddRoleToARoleTakesAMooseMetaRole", + "add_role to Moose::Meta::Role takes instances of Moose::Meta::Role"); + + is( + $exception->role_name, + 'JustATestRole', + "add_role to Moose::Meta::Role takes instances of Moose::Meta::Role"); + + is( + $exception->role_to_be_added, + "xyz", + "add_role to Moose::Meta::Role takes instances of Moose::Meta::Role"); +} + +{ + { + package Bar; + use Moose::Role; + } + + my $exception = exception { + Bar->meta->does_role; + }; + + like( + $exception, + qr/You must supply a role name to look for/, + "Cannot call does_role without a role name"); + + isa_ok( + $exception, + 'Moose::Exception::RoleNameRequiredForMooseMetaRole', + "Cannot call does_role without a role name"); + + is( + $exception->role_name, + 'Bar', + "Cannot call does_role without a role name"); +} + +{ + { + package Bar; + use Moose::Role; + } + + my $exception = exception { + Bar->meta->apply("xyz"); + }; + + like( + $exception, + qr/You must pass in an blessed instance/, + "apply takes a blessed instance"); + + isa_ok( + $exception, + 'Moose::Exception::ApplyTakesABlessedInstance', + "apply takes a blessed instance"); + + is( + $exception->role_name, + 'Bar', + "apply takes a blessed instance"); + + is( + $exception->param, + 'xyz', + "apply takes a blessed instance"); +} + +{ + my $exception = exception { + Moose::Meta::Role->create("TestRole", ( 'attributes' => 'bar')); + }; + + like( + $exception, + qr/You must pass a HASH ref of attributes/, + "create takes a HashRef of attributes"); + + isa_ok( + $exception, + "Moose::Exception::CreateTakesHashRefOfAttributes", + "create takes a HashRef of attributes"); +} + +{ + my $exception = exception { + Moose::Meta::Role->create("TestRole", ( 'methods' => 'bar')); + }; + + like( + $exception, + qr/You must pass a HASH ref of methods/, + "create takes a HashRef of methods"); + + isa_ok( + $exception, + "Moose::Exception::CreateTakesHashRefOfMethods", + "create takes a HashRef of methods"); +} + +{ + my $exception = exception { + Moose::Meta::Role->create("TestRole", ('roles', 'bar')); + }; + + like( + $exception, + qr/You must pass an ARRAY ref of roles/, + "create takes an ArrayRef of roles"); + + isa_ok( + $exception, + "Moose::Exception::CreateTakesArrayRefOfRoles", + "create takes an ArrayRef of roles"); +} + +done_testing; diff --git a/t/exceptions/metaclass.t b/t/exceptions/metaclass.t new file mode 100644 index 0000000..5492df1 --- /dev/null +++ b/t/exceptions/metaclass.t @@ -0,0 +1,34 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + { + package Foo; + use Moose; + } + + my $exception = exception { + require metaclass; + metaclass->import( ("Foo") ); + }; + + like( + $exception, + qr/\QThe metaclass (Foo) must be derived from Class::MOP::Class/, + "Foo is not derived from Class::MOP::Class"); + + isa_ok( + $exception, + "Moose::Exception::MetaclassMustBeDerivedFromClassMOPClass", + "Foo is not derived from Class::MOP::Class"); + + is( + $exception->class_name, + 'Foo', + "Foo is not derived from Class::MOP::Class"); +} + +done_testing; diff --git a/t/exceptions/moose-exporter.t b/t/exceptions/moose-exporter.t new file mode 100644 index 0000000..7852176 --- /dev/null +++ b/t/exceptions/moose-exporter.t @@ -0,0 +1,119 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + my $exception = exception { + package MooseX::NoAlso; + use Moose (); + + Moose::Exporter->setup_import_methods( + also => ['NoSuchThing'] + ); + }; + + like( + $exception, + qr/\QPackage in also (NoSuchThing) does not seem to use Moose::Exporter (is it loaded?)/, + 'a package which does not use Moose::Exporter in also dies with an error'); + + isa_ok( + $exception, + 'Moose::Exception::PackageDoesNotUseMooseExporter', + 'a package which does not use Moose::Exporter in also dies with an error'); + + is( + $exception->package, + "NoSuchThing", + 'a package which does not use Moose::Exporter in also dies with an error'); +} + +{ + my $exception = exception { + { + package MooseX::CircularAlso; + use Moose; + + Moose::Exporter->setup_import_methods( + also => [ 'Moose', 'MooseX::CircularAlso' ], + ); + } + }; + + like( + $exception, + qr/\QCircular reference in 'also' parameter to Moose::Exporter between MooseX::CircularAlso and MooseX::CircularAlso/, + 'a circular reference in also dies with an error'); + + isa_ok( + $exception, + 'Moose::Exception::CircularReferenceInAlso', + 'a circular reference in also dies with an error'); + + is( + $exception->also_parameter, + "MooseX::CircularAlso", + 'a circular reference in also dies with an error'); +} + +{ + { + package My::SimpleTrait; + use Moose::Role; + + sub simple { return 5 } + } + + use Moose::Util::TypeConstraints; + my $exception = exception { + Moose::Util::TypeConstraints->import( + -traits => 'My::SimpleTrait' ); + }; + + like( + $exception, + qr/\QCannot provide traits when Moose::Util::TypeConstraints does not have an init_meta() method/, + 'cannot provide -traits to an exporting module that does not init_meta'); + + isa_ok( + $exception, + "Moose::Exception::ClassDoesNotHaveInitMeta", + 'cannot provide -traits to an exporting module that does not init_meta'); + + is( + $exception->class_name, + "Moose::Util::TypeConstraints", + 'cannot provide -traits to an exporting module that does not init_meta'); +} + +{ + my $exception = exception { + { + package MooseX::BadTraits; + use Moose (); + + Moose::Exporter->setup_import_methods( + trait_aliases => [{hello => 1}] + ); + } + }; + + like( + $exception, + qr/HASH references are not valid arguments to the 'trait_aliases' option/, + "a HASH ref is given to trait_aliases"); + + isa_ok( + $exception, + "Moose::Exception::InvalidArgumentsToTraitAliases", + "a HASH ref is given to trait_aliases"); + + is( + $exception->package_name, + "MooseX::BadTraits", + "a HASH ref is given to trait_aliases"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-attribute-native-traits.t b/t/exceptions/moose-meta-attribute-native-traits.t new file mode 100644 index 0000000..64ba085 --- /dev/null +++ b/t/exceptions/moose-meta-attribute-native-traits.t @@ -0,0 +1,147 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose; + +{ + my $exception = exception { + { + package TestClass; + use Moose; + + has 'foo' => ( + traits => ['Array'], + is => 'ro', + isa => 'Int' + ); + } + }; + + like( + $exception, + qr/The type constraint for foo must be a subtype of ArrayRef but it's a Int/, + "isa is given as Int, but it should be ArrayRef"); + + isa_ok( + $exception, + 'Moose::Exception::WrongTypeConstraintGiven', + "isa is given as Int, but it should be ArrayRef"); + + is( + $exception->required_type, + "ArrayRef", + "isa is given as Int, but it should be ArrayRef"); + + is( + $exception->given_type, + "Int", + "isa is given as Int, but it should be ArrayRef"); + + is( + $exception->attribute_name, + "foo", + "isa is given as Int, but it should be ArrayRef"); +} + +{ + my $exception = exception { + { + package TestClass2; + use Moose; + + has 'foo' => ( + traits => ['Array'], + is => 'ro', + isa => 'ArrayRef', + handles => 'bar' + ); + } + }; + + like( + $exception, + qr/The 'handles' option must be a HASH reference, not bar/, + "'bar' is given as handles"); + + isa_ok( + $exception, + 'Moose::Exception::HandlesMustBeAHashRef', + "'bar' is given as handles"); + + is( + $exception->given_handles, + "bar", + "'bar' is given as handles"); +} + +{ + my $exception = exception { + { + package TraitTest; + use Moose::Role; + with 'Moose::Meta::Attribute::Native::Trait'; + + sub _helper_type { "ArrayRef" } + } + + { + package TestClass3; + use Moose; + + has 'foo' => ( + traits => ['TraitTest'], + is => 'ro', + isa => 'ArrayRef', + handles => { get_count => 'count' } + ); + } + }; + + like( + $exception, + qr/\QCannot calculate native type for Moose::Meta::Class::__ANON__::SERIAL::/, + "cannot calculate native type for the given trait"); + + isa_ok( + $exception, + 'Moose::Exception::CannotCalculateNativeType', + "cannot calculate native type for the given trait"); +} + +{ + my $regex = qr/bar/; + my $exception = exception { + { + package TestClass4; + use Moose; + + has 'foo' => ( + traits => ['Array'], + is => 'ro', + isa => 'ArrayRef', + handles => { get_count => $regex } + ); + } + }; + + like( + $exception, + qr/\QAll values passed to handles must be strings or ARRAY references, not $regex/, + "a Regexp is given to handles"); + #All values passed to handles must be strings or ARRAY references, not (?^:bar) + + isa_ok( + $exception, + 'Moose::Exception::InvalidHandleValue', + "a Regexp is given to handles"); + + is( + $exception->handle_value, + $regex, + "a Regexp is given to handles"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-class-immutable-trait.t b/t/exceptions/moose-meta-class-immutable-trait.t new file mode 100644 index 0000000..c355240 --- /dev/null +++ b/t/exceptions/moose-meta-class-immutable-trait.t @@ -0,0 +1,29 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + package Foo; + use Moose; + + __PACKAGE__->meta->make_immutable; + Foo->meta->does_role; + }; + + like( + $exception, + qr/You must supply a role name to look for/, + "no role_name supplied to does_role"); + + isa_ok( + $exception, + "Moose::Exception::RoleNameRequired", + "no role_name supplied to does_role"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-accessor-native-array.t b/t/exceptions/moose-meta-method-accessor-native-array.t new file mode 100644 index 0000000..d923935 --- /dev/null +++ b/t/exceptions/moose-meta-method-accessor-native-array.t @@ -0,0 +1,488 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + package Foo; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'ArrayRef', + traits => ['Array'], + handles => { + get => 'get', + first => 'first', + first_index => 'first_index', + grep => 'grep', + join => 'join', + map => 'map', + natatime => 'natatime', + reduce => 'reduce', + sort => 'sort', + sort_in_place => 'sort_in_place', + splice => 'splice' + }, + required => 1 + ); +} + +my $foo_obj; + +{ + + my $foo_obj = Foo->new( foo => [1, 2, 3] ); + my $exception = exception { + $foo_obj->get(1.1); + }; + + like( + $exception, + qr/The index passed to get must be an integer/, + "get takes integer argument"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "get takes integer argument"); + + is( + $exception->argument, + 1.1, + "get takes integer argument"); + + is( + $exception->method_name, + "get", + "get takes integer argument"); +} + +{ + $foo_obj = Foo->new( foo => [1, 2, 3] ); + my $arg = [12]; + + my $exception = exception { + $foo_obj->first( $arg ); + }; + + like( + $exception, + qr/The argument passed to first must be a code reference/, + "an ArrayRef passed to first"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an ArrayRef passed to first"); + + is( + $exception->method_name, + "first", + "an ArrayRef passed to first"); + + is( + $exception->argument, + $arg, + "an ArrayRef passed to first"); + + is( + $exception->type_of_argument, + "code reference", + "an ArrayRef passed to first"); + + is( + $exception->type, + "CodeRef", + "an ArrayRef passed to first"); +} + +{ + $foo_obj = Foo->new( foo => [1, 2, 3] ); + my $arg = [12]; + + my $exception = exception { + $foo_obj->first_index( $arg ); + }; + + like( + $exception, + qr/The argument passed to first_index must be a code reference/, + "an ArrayRef passed to first_index"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an ArrayRef passed to first_index"); + + is( + $exception->method_name, + "first_index", + "an ArrayRef passed to first_index"); + + is( + $exception->argument, + $arg, + "an ArrayRef passed to first_index"); + + is( + $exception->type_of_argument, + "code reference", + "an ArrayRef passed to first_index"); + + is( + $exception->type, + "CodeRef", + "an ArrayRef passed to first_index"); +} + +{ + $foo_obj = Foo->new( foo => [1, 2, 3] ); + my $arg = [12]; + + my $exception = exception { + $foo_obj->grep( $arg ); + }; + + like( + $exception, + qr/The argument passed to grep must be a code reference/, + "an ArrayRef passed to grep"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an ArrayRef passed to grep"); + + is( + $exception->method_name, + "grep", + "an ArrayRef passed to grep"); + + is( + $exception->argument, + $arg, + "an ArrayRef passed to grep"); + + is( + $exception->type_of_argument, + "code reference", + "an ArrayRef passed to grep"); + + is( + $exception->type, + "CodeRef", + "an ArrayRef passed to grep"); +} + +{ + $foo_obj = Foo->new( foo => [1, 2, 3] ); + my $arg = [12]; + + my $exception = exception { + $foo_obj->join( $arg ); + }; + + like( + $exception, + qr/The argument passed to join must be a string/, + "an ArrayRef passed to join"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an ArrayRef passed to join"); + + is( + $exception->method_name, + "join", + "an ArrayRef passed to join"); + + is( + $exception->argument, + $arg, + "an ArrayRef passed to join"); + + is( + $exception->type_of_argument, + "string", + "an ArrayRef passed to join"); + + is( + $exception->type, + "Str", + "an ArrayRef passed to join"); +} + +{ + $foo_obj = Foo->new( foo => [1, 2, 3] ); + my $arg = [12]; + + my $exception = exception { + $foo_obj->map( $arg ); + }; + + like( + $exception, + qr/The argument passed to map must be a code reference/, + "an ArrayRef passed to map"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an ArrayRef passed to map"); + + is( + $exception->method_name, + "map", + "an ArrayRef passed to map"); + + is( + $exception->argument, + $arg, + "an ArrayRef passed to map"); + + is( + $exception->type_of_argument, + "code reference", + "an ArrayRef passed to map"); + + is( + $exception->type, + "CodeRef", + "an ArrayRef passed to map"); +} + +{ + $foo_obj = Foo->new( foo => [1, 2, 3] ); + my $arg = [12]; + + my $exception = exception { + $foo_obj->natatime( $arg ); + }; + + like( + $exception, + qr/The n value passed to natatime must be an integer/, + "an ArrayRef passed to natatime"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an ArrayRef passed to natatime"); + + is( + $exception->method_name, + "natatime", + "an ArrayRef passed to natatime"); + + is( + $exception->argument, + $arg, + "an ArrayRef passed to natatime"); + + is( + $exception->type_of_argument, + "integer", + "an ArrayRef passed to natatime"); + + is( + $exception->type, + "Int", + "an ArrayRef passed to natatime"); + + $exception = exception { + $foo_obj->natatime( 1, $arg ); + }; + + like( + $exception, + qr/The second argument passed to natatime must be a code reference/, + "an ArrayRef passed to natatime"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an ArrayRef passed to natatime"); + + is( + $exception->method_name, + "natatime", + "an ArrayRef passed to natatime"); + + is( + $exception->argument, + $arg, + "an ArrayRef passed to natatime"); + + is( + $exception->type_of_argument, + "code reference", + "an ArrayRef passed to natatime"); + + is( + $exception->type, + "CodeRef", + "an ArrayRef passed to natatime"); +} + +{ + $foo_obj = Foo->new( foo => [1, 2, 3] ); + my $arg = [12]; + + my $exception = exception { + $foo_obj->reduce( $arg ); + }; + + like( + $exception, + qr/The argument passed to reduce must be a code reference/, + "an ArrayRef passed to reduce"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an ArrayRef passed to reduce"); + + is( + $exception->method_name, + "reduce", + "an ArrayRef passed to reduce"); + + is( + $exception->argument, + $arg, + "an ArrayRef passed to reduce"); + + is( + $exception->type_of_argument, + "code reference", + "an ArrayRef passed to reduce"); + + is( + $exception->type, + "CodeRef", + "an ArrayRef passed to reduce"); +} + +{ + $foo_obj = Foo->new( foo => [1, 2, 3] ); + my $arg = [12]; + + my $exception = exception { + $foo_obj->sort( $arg ); + }; + + like( + $exception, + qr/The argument passed to sort must be a code reference/, + "an ArrayRef passed to sort"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an ArrayRef passed to sort"); + + is( + $exception->method_name, + "sort", + "an ArrayRef passed to sort"); + + is( + $exception->argument, + $arg, + "an ArrayRef passed to sort"); + + is( + $exception->type_of_argument, + "code reference", + "an ArrayRef passed to sort"); + + is( + $exception->type, + "CodeRef", + "an ArrayRef passed to sort"); +} + +{ + $foo_obj = Foo->new( foo => [1, 2, 3] ); + my $arg = [12]; + + my $exception = exception { + $foo_obj->sort_in_place( $arg ); + }; + + like( + $exception, + qr/The argument passed to sort_in_place must be a code reference/, + "an ArrayRef passed to sort_in_place"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an ArrayRef passed to sort_in_place"); + + is( + $exception->method_name, + "sort_in_place", + "an ArrayRef passed to sort_in_place"); + + is( + $exception->argument, + $arg, + "an ArrayRef passed to sort_in_place"); + + is( + $exception->type_of_argument, + "code reference", + "an ArrayRef passed to sort_in_place"); + + is( + $exception->type, + "CodeRef", + "an ArrayRef passed to sort_in_place"); +} + +{ + $foo_obj = Foo->new( foo => [1, 2, 3] ); + my $arg = [12]; + + my $exception = exception { + $foo_obj->splice( 1, $arg ); + }; + + like( + $exception, + qr/The length argument passed to splice must be an integer/, + "an ArrayRef passed to splice"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an ArrayRef passed to splice"); + + is( + $exception->method_name, + "splice", + "an ArrayRef passed to splice"); + + is( + $exception->argument, + $arg, + "an ArrayRef passed to splice"); + + is( + $exception->type_of_argument, + "integer", + "an ArrayRef passed to splice"); + + is( + $exception->type, + "Int", + "an ArrayRef passed to splice"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-accessor-native-collection.t b/t/exceptions/moose-meta-method-accessor-native-collection.t new file mode 100644 index 0000000..00efb25 --- /dev/null +++ b/t/exceptions/moose-meta-method-accessor-native-collection.t @@ -0,0 +1,53 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + package Bar; + use Moose; + + has 'foo' => ( + is => 'rw', + isa => 'ArrayRef[Int]', + traits => ['Array'], + handles => { push => 'push'} + ); +} + +my $bar_obj = Bar->new; +{ + my $exception = exception { + $bar_obj->push(1.2); + }; + + like( + $exception, + qr/A new member value for foo does not pass its type constraint because: Validation failed for 'Int' with value 1.2/, + "trying to push a Float(1.2) to ArrayRef[Int]"); + + isa_ok( + $exception, + 'Moose::Exception::ValidationFailedForInlineTypeConstraint', + "trying to push a Float(1.2) to ArrayRef[Int]"); + + is( + $exception->attribute_name, + "foo", + "trying to push a Float(1.2) to ArrayRef[Int]"); + + is( + $exception->class_name, + "Bar", + "trying to push a Float(1.2) to ArrayRef[Int]"); + + is( + $exception->value, + 1.2, + "trying to push a Float(1.2) to ArrayRef[Int]"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-accessor-native-grep.t b/t/exceptions/moose-meta-method-accessor-native-grep.t new file mode 100644 index 0000000..6f20cb4 --- /dev/null +++ b/t/exceptions/moose-meta-method-accessor-native-grep.t @@ -0,0 +1,63 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + { + package Foo; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'ArrayRef', + traits => ['Array'], + handles => { + grep => 'grep' + }, + required => 1 + ); + } + + my $foo_obj = Foo->new( foo => [1, 2, 3] ); + my $arg = [12]; + + my $exception = exception { + $foo_obj->grep( $arg ); + }; + + like( + $exception, + qr/The argument passed to grep must be a code reference/, + "an ArrayRef passed to grep"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an ArrayRef passed to grep"); + + is( + $exception->method_name, + "grep", + "an ArrayRef passed to grep"); + + is( + $exception->argument, + $arg, + "an ArrayRef passed to grep"); + + is( + $exception->type_of_argument, + "code reference", + "an ArrayRef passed to grep"); + + is( + $exception->type, + "CodeRef", + "an ArrayRef passed to grep"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-accessor-native-hash-set.t b/t/exceptions/moose-meta-method-accessor-native-hash-set.t new file mode 100644 index 0000000..46f82cf --- /dev/null +++ b/t/exceptions/moose-meta-method-accessor-native-hash-set.t @@ -0,0 +1,70 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + { + package Foo; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'HashRef', + traits => ['Hash'], + handles => { + set => 'set', + }, + required => 1 + ); + } +} + +my $foo_obj = Foo->new( foo => { 1 => "one"} ); + +{ + my $exception = exception { + $foo_obj->set(1 => "foo", "bar"); + }; + + like( + $exception, + qr/You must pass an even number of arguments to set/, + "odd number of arguments passed to set"); + + isa_ok( + $exception, + 'Moose::Exception::MustPassEvenNumberOfArguments', + "odd number of arguments passed to set"); + + is( + $exception->method_name, + "set", + "odd number of arguments passed to set"); +} + +{ + my $exception = exception { + $foo_obj->set(undef, "foo"); + }; + + like( + $exception, + qr/Hash keys passed to set must be defined/, + "undef is passed to set"); + + isa_ok( + $exception, + 'Moose::Exception::UndefinedHashKeysPassedToMethod', + "undef is passed to set"); + + is( + $exception->method_name, + "set", + "undef is passed to set"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-accessor-native-hash.t b/t/exceptions/moose-meta-method-accessor-native-hash.t new file mode 100644 index 0000000..26105cb --- /dev/null +++ b/t/exceptions/moose-meta-method-accessor-native-hash.t @@ -0,0 +1,63 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + { + package Foo; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'HashRef', + traits => ['Hash'], + handles => { + exists => 'exists' + }, + required => 1 + ); + } + + my $foo_obj = Foo->new( foo => { 1 => "one"} ); + my $arg = undef; + + my $exception = exception { + $foo_obj->exists( undef ); + }; + + like( + $exception, + qr/The key passed to exists must be a defined value/, + "an undef is passed to exists"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an undef is passed to exists"); + + is( + $exception->method_name, + "exists", + "an undef is passed to exists"); + + is( + $exception->argument, + $arg, + "an undef is passed to exists"); + + is( + $exception->type_of_argument, + "defined value", + "an undef is passed to exists"); + + is( + $exception->type, + "Defined", + "an undef is passed to exists"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-accessor-native-string-match.t b/t/exceptions/moose-meta-method-accessor-native-string-match.t new file mode 100644 index 0000000..9ec9ce8 --- /dev/null +++ b/t/exceptions/moose-meta-method-accessor-native-string-match.t @@ -0,0 +1,63 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + package Foo; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'Str', + traits => ['String'], + handles => { + match => 'match' + }, + required => 1 + ); +} + +my $foo_obj = Foo->new( foo => 'hello' ); + +{ + my $arg = [12]; + my $exception = exception { + $foo_obj->match( $arg ); + }; + + like( + $exception, + qr/The argument passed to match must be a string or regexp reference/, + "an Array Ref passed to match"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an Array Ref passed to match"); + + is( + $exception->argument, + $arg, + "an Array Ref passed to match"); + + is( + $exception->type_of_argument, + "string or regexp reference", + "an Array Ref passed to match"); + + is( + $exception->method_name, + "match", + "an Array Ref passed to match"); + + is( + $exception->type, + "Str|RegexpRef", + "an Array Ref passed to match"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-accessor-native-string-replace.t b/t/exceptions/moose-meta-method-accessor-native-string-replace.t new file mode 100644 index 0000000..2ae1cb1 --- /dev/null +++ b/t/exceptions/moose-meta-method-accessor-native-string-replace.t @@ -0,0 +1,110 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + package Foo; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'Str', + traits => ['String'], + handles => { + replace => 'replace' + }, + required => 1 + ); +} + +my $foo_obj = Foo->new( foo => 'hello' ); + +{ + my $arg = [123]; + my $exception = exception { + $foo_obj->replace($arg); + }; + + like( + $exception, + qr/The first argument passed to replace must be a string or regexp reference/, + "an Array ref passed to replace"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an Array ref passed to replace"); + + is( + $exception->argument, + $arg, + "an Array ref passed to replace"); + + is( + $exception->ordinal, + "first", + "an Array ref passed to replace"); + + is( + $exception->type_of_argument, + "string or regexp reference", + "an Array ref passed to replace"); + + is( + $exception->method_name, + "replace", + "an Array ref passed to replace"); + + is( + $exception->type, + "Str|RegexpRef", + "an Array ref passed to replace"); +} + +{ + my $arg = [123]; + my $exception = exception { + $foo_obj->replace('h', $arg); + }; + + like( + $exception, + qr/The second argument passed to replace must be a string or code reference/, + "an Array ref passed to replace"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "an Array ref passed to replace"); + + is( + $exception->argument, + $arg, + "an Array ref passed to replace"); + + is( + $exception->ordinal, + "second", + "an Array ref passed to replace"); + + is( + $exception->type_of_argument, + "string or code reference", + "an Array ref passed to replace"); + + is( + $exception->method_name, + "replace", + "an Array ref passed to replace"); + + is( + $exception->type, + "Str|CodeRef", + "an Array ref passed to replace"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-accessor-native-string-substr.t b/t/exceptions/moose-meta-method-accessor-native-string-substr.t new file mode 100644 index 0000000..38c9fdf --- /dev/null +++ b/t/exceptions/moose-meta-method-accessor-native-string-substr.t @@ -0,0 +1,150 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + package Foo; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'Str', + traits => ['String'], + handles => { + substr => 'substr' + }, + required => 1 + ); +} + +my $foo_obj = Foo->new( foo => 'hello' ); + +{ + my $exception = exception { + $foo_obj->substr(1.1); + }; + + like( + $exception, + qr/The first argument passed to substr must be an integer/, + "substr takes integer as its first argument"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "substr takes integer as its first argument"); + + is( + $exception->argument, + 1.1, + "substr takes integer as its first argument"); + + is( + $exception->ordinal, + "first", + "substr takes integer as its first argument"); + + is( + $exception->type_of_argument, + "integer", + "substr takes integer as its first argument"); + + is( + $exception->method_name, + "substr", + "substr takes integer as its first argument"); + + is( + $exception->type, + "Int", + "substr takes integer as its first argument"); +} + +{ + my $exception = exception { + $foo_obj->substr(1, 1.2); + }; + + like( + $exception, + qr/The second argument passed to substr must be an integer/, + "substr takes integer as its second argument"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "substr takes integer as its second argument"); + + is( + $exception->argument, + 1.2, + "substr takes integer as its second argument"); + + is( + $exception->ordinal, + "second", + "substr takes integer as its second argument"); + + is( + $exception->type_of_argument, + "integer", + "substr takes integer as its second argument"); + + is( + $exception->method_name, + "substr", + "substr takes integer as its second argument"); + + is( + $exception->type, + "Int", + "substr takes integer as its second argument"); +} + +{ + my $arg = [122]; + my $exception = exception { + $foo_obj->substr(1, 2, $arg); + }; + + like( + $exception, + qr/The third argument passed to substr must be a string/, + "substr takes string as its third argument"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgumentToMethod', + "substr takes string as its third argument"); + + is( + $exception->argument, + $arg, + "substr takes string as its third argument"); + + is( + $exception->ordinal, + "third", + "substr takes string as its third argument"); + + is( + $exception->type_of_argument, + "string", + "substr takes string as its third argument"); + + is( + $exception->method_name, + "substr", + "substr takes string as its third argument"); + + is( + $exception->type, + "Str", + "substr takes string as its third argument"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-accessor-native.t b/t/exceptions/moose-meta-method-accessor-native.t new file mode 100644 index 0000000..4afc1af --- /dev/null +++ b/t/exceptions/moose-meta-method-accessor-native.t @@ -0,0 +1,138 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + { + package Foo; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'Str', + traits => ['String'], + handles => { + substr => 'substr', + }, + required => 1 + ); + } + + my $foo_obj = Foo->new( foo => 'hello' ); + + my $exception = exception { + $foo_obj->substr(1,2,3,3); + }; + + like( + $exception, + qr/Cannot call substr with more than 3 arguments/, + "substr doesn't take 4 arguments"); + + isa_ok( + $exception, + 'Moose::Exception::MethodExpectsFewerArgs', + "substr doesn't take 4 arguments"); + + is( + $exception->method_name, + "substr", + "substr doesn't take 4 arguments"); + + is( + $exception->maximum_args, + 3, + "substr doesn't take 4 arguments"); +} + +{ + { + package Bar; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'Str', + traits => ['String'], + handles => { + substr => 'substr', + }, + required => 1 + ); + } + + my $foo_obj = Bar->new( foo => 'hello' ); + + my $exception = exception { + $foo_obj->substr; + }; + + like( + $exception, + qr/Cannot call substr without at least 1 argument/, + "substr expects atleast 1 argument"); + + isa_ok( + $exception, + 'Moose::Exception::MethodExpectsMoreArgs', + "substr expects atleast 1 argument"); + + is( + $exception->method_name, + "substr", + "substr expects atleast 1 argument"); + + is( + $exception->minimum_args, + 1, + "substr expects atleast 1 argument"); +} + +{ + { + package Bar2; + use Moose; + with 'Moose::Meta::Method::Accessor::Native::Reader'; + + sub _return_value { + return 1; + } + + sub _get_value { + return 1 + } + + sub _inline_store_value { + return 1; + } + + sub _eval_environment { + return 1; + } + } + + my $exception = exception { + Bar2->new( curried_arguments => 'xyz' ); + }; + + like( + $exception, + qr/You must supply a curried_arguments which is an ARRAY reference/, + "curried arguments is 'xyz'"); + + isa_ok( + $exception, + 'Moose::Exception::MustSupplyArrayRefAsCurriedArguments', + "curried arguments is 'xyz'"); + + is( + $exception->class_name, + "Bar2", + "curried arguments is 'xyz'"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-accessor.t b/t/exceptions/moose-meta-method-accessor.t new file mode 100644 index 0000000..f42f4d2 --- /dev/null +++ b/t/exceptions/moose-meta-method-accessor.t @@ -0,0 +1,55 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + { + package Foo; + use Moose; + extends 'Moose::Meta::Method::Accessor'; + } + + my $attr = Class::MOP::Attribute->new("bar"); + Foo->meta->add_attribute($attr); + + my $foo; + my $exception = exception { + $foo = Foo->new( name => "new", + package_name => "Foo", + is_inline => 1, + attribute => $attr, + accessor_type => "writer" + ); + }; + + like( + $exception, + qr/\QCould not generate inline writer because : Could not create writer for 'bar' because Can't locate object method "_eval_environment" via package "Class::MOP::Attribute"/, + "cannot generate writer"); + + isa_ok( + $exception->error, + "Moose::Exception::CouldNotCreateWriter", + "cannot generate writer"); + + isa_ok( + $exception, + "Moose::Exception::CouldNotGenerateInlineAttributeMethod", + "cannot generate writer"); + + is( + $exception->error->attribute_name, + 'bar', + "cannot generate writer"); + + is( + ref($exception->error->instance), + "Foo", + "cannot generate writer"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-augmented.t b/t/exceptions/moose-meta-method-augmented.t new file mode 100644 index 0000000..c9d9677 --- /dev/null +++ b/t/exceptions/moose-meta-method-augmented.t @@ -0,0 +1,33 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + package Foo; + use Moose; + + augment 'foo' => sub {}; + }; + + like( + $exception, + qr/You cannot augment 'foo' because it has no super method/, + "'Foo' has no super class"); + + isa_ok( + $exception, + "Moose::Exception::CannotAugmentNoSuperMethod", + "'Foo' has no super class"); + + is( + $exception->method_name, + 'foo', + "'Foo' has no super class"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-constructor.t b/t/exceptions/moose-meta-method-constructor.t new file mode 100644 index 0000000..1780fda --- /dev/null +++ b/t/exceptions/moose-meta-method-constructor.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + my $method = Moose::Meta::Method::Constructor->new( options => (1,2,3)); + }; + + like( + $exception, + qr/You must pass a hash of options/, + "options is not a HASH ref"); + + isa_ok( + $exception, + "Moose::Exception::MustPassAHashOfOptions", + "options is not a HASH ref"); +} + +{ + my $exception = exception { + my $method = Moose::Meta::Method::Constructor->new( options => {}); + }; + + like( + $exception, + qr/You must supply the package_name and name parameters/, + "package_name and name are not given"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyPackageNameAndName", + "package_name and name are not given"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-delegation.t b/t/exceptions/moose-meta-method-delegation.t new file mode 100644 index 0000000..5da32e7 --- /dev/null +++ b/t/exceptions/moose-meta-method-delegation.t @@ -0,0 +1,173 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + Moose::Meta::Method::Delegation->new; + }; + + like( + $exception, + qr/You must supply an attribute to construct with/, + "no attribute is given"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyAnAttributeToConstructWith", + "no attribute is given"); +} + +{ + my $exception = exception { + Moose::Meta::Method::Delegation->new( attribute => "foo" ); + }; + + like( + $exception, + qr/\QYou must supply an attribute which is a 'Moose::Meta::Attribute' instance/, + "attribute is not an instance of Moose::Meta::Attribute"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyAMooseMetaAttributeInstance", + "attribute is not an instance of Moose::Meta::Attribute"); +} + +{ + my $attr = Moose::Meta::Attribute->new("foo"); + my $exception = exception { + Moose::Meta::Method::Delegation->new( attribute => $attr ); + }; + + like( + $exception, + qr/You must supply the package_name and name parameters/, + "package_name and name are not given"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyPackageNameAndName", + "package_name and name are not given"); +} + +{ + my $attr = Moose::Meta::Attribute->new("foo"); + my $exception = exception { + Moose::Meta::Method::Delegation->new( attribute => $attr, package_name => "Foo", name => "Foo" ); + }; + + like( + $exception, + qr/You must supply a delegate_to_method which is a method name or a CODE reference/, + "delegate_to_method is not given"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyADelegateToMethod", + "delegate_to_method is not given"); +} + +{ + my $attr = Moose::Meta::Attribute->new("foo"); + my $exception = exception { + Moose::Meta::Method::Delegation->new( attribute => $attr, + package_name => "Foo", + name => "Foo", + delegate_to_method => sub {}, + curried_arguments => {} ); + }; + + like( + $exception, + qr/You must supply a curried_arguments which is an ARRAY reference/, + "curried_arguments not given"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyArrayRefAsCurriedArguments", + "curried_arguments not given"); +} + +{ + { + package BadClass; + use Moose; + + has 'foo' => ( + is => 'ro', + handles => { get_count => 'count' } + ); + } + + my $object = BadClass->new; + + my $exception = exception { + $object->get_count; + }; + + like( + $exception, + qr/Cannot delegate get_count to count because the value of foo is not defined/, + "foo is not set"); + + isa_ok( + $exception, + "Moose::Exception::AttributeValueIsNotDefined", + "foo is not set"); + + is( + $exception->instance, + $object, + "foo is not set"); + + is( + $exception->attribute->name, + "foo", + "foo is not set"); +} + +{ + { + package BadClass2; + use Moose; + + has 'foo' => ( + is => 'ro', + handles => { get_count => 'count' } + ); + } + + my $array = [12]; + my $object = BadClass2->new( foo => $array ); + my $exception = exception { + $object->get_count; + }; + + like( + $exception, + qr/\QCannot delegate get_count to count because the value of foo is not an object (got '$array')/, + "value of foo is an ARRAY ref"); + #Cannot delegate get_count to count because the value of foo is not an object (got 'ARRAY(0x223f578)') + + isa_ok( + $exception, + "Moose::Exception::AttributeValueIsNotAnObject", + "value of foo is an ARRAY ref"); + + is( + $exception->given_value, + $array, + "value of foo is an ARRAY ref"); + + is( + $exception->attribute->name, + "foo", + "value of foo is an ARRAY ref"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-destructor.t b/t/exceptions/moose-meta-method-destructor.t new file mode 100644 index 0000000..6e72061 --- /dev/null +++ b/t/exceptions/moose-meta-method-destructor.t @@ -0,0 +1,94 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + my $method = Moose::Meta::Method::Destructor->new( options => (1,2,3)); + }; + + like( + $exception, + qr/You must pass a hash of options/, + "options is not a HASH ref"); + + isa_ok( + $exception, + "Moose::Exception::MustPassAHashOfOptions", + "options is not a HASH ref"); +} + +{ + my $exception = exception { + my $method = Moose::Meta::Method::Destructor->new( options => {}); + }; + + like( + $exception, + qr/You must supply the package_name and name parameters/, + "package_name and name are not given"); + + isa_ok( + $exception, + "Moose::Exception::MustSupplyPackageNameAndName", + "package_name and name are not given"); +} + +{ + my $exception = exception { + my $method = Moose::Meta::Method::Destructor->is_needed("foo"); + }; + + like( + $exception, + qr/The is_needed method expected a metaclass object as its arugment/, + "'foo' is not a metaclass"); + + isa_ok( + $exception, + "Moose::Exception::MethodExpectedAMetaclassObject", + "'foo' is not a metaclass"); + + is( + $exception->metaclass, + 'foo', + "'foo' is not a metaclass"); +} + +{ + { + package TestClass; + use Moose; + } + + { + package SubClassDestructor; + use Moose; + extends 'Moose::Meta::Method::Destructor'; + + sub _generate_DEMOLISHALL { + return "print 'xyz"; # this is an intentional syntax error + } + } + + my $methodDestructor; + my $exception = exception { + $methodDestructor = SubClassDestructor->new( name => "xyz", package_name => "Xyz", options => {}, metaclass => TestClass->meta); + }; + + like( + $exception, + qr/Could not eval the destructor/, + "syntax error in the return value of _generate_DEMOLISHALL"); + + isa_ok( + $exception, + "Moose::Exception::CouldNotEvalDestructor", + "syntax error in the return value of _generate_DEMOLISHALL"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-method-overridden.t b/t/exceptions/moose-meta-method-overridden.t new file mode 100644 index 0000000..a0831d6 --- /dev/null +++ b/t/exceptions/moose-meta-method-overridden.t @@ -0,0 +1,36 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + my $exception = exception { + package Foo; + use Moose; + + override foo => sub {} + }; + + like( + $exception, + qr/You cannot override 'foo' because it has no super method/, + "Foo class is not extending any class"); + + isa_ok( + $exception, + "Moose::Exception::CannotOverrideNoSuperMethod", + "Foo class is not extending any class"); + + is( + $exception->class, + "Moose::Meta::Method::Overridden", + "Foo class is not extending any class"); + + is( + $exception->method_name, + "foo", + "Foo class is not extending any class"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-role-application-rolesummation.t b/t/exceptions/moose-meta-role-application-rolesummation.t new file mode 100644 index 0000000..faa56c5 --- /dev/null +++ b/t/exceptions/moose-meta-role-application-rolesummation.t @@ -0,0 +1,215 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + { + package Foo1; + use Moose::Role; + excludes 'Bar1'; + } + + { + package Bar1; + use Moose::Role; + } + + my $exception = exception { + package CompositeRole; + use Moose::Role; + with 'Foo1', 'Bar1'; + }; + + like( + $exception, + qr/\QConflict detected: Role Foo1 excludes role 'Bar1'/, + "role Foo1 excludes role Bar1"); + + isa_ok( + $exception, + "Moose::Exception::RoleExclusionConflict", + "role Foo1 excludes role Bar1"); + + is( + $exception->role_name, + "Bar1", + "role Foo1 excludes role Bar1"); + + is_deeply( + $exception->roles, + ["Foo1"], + "role Foo1 excludes role Bar1"); + + { + package Baz1; + use Moose::Role; + excludes 'Bar1'; + } + + $exception = exception { + package CompositeRole1; + use Moose::Role; + with 'Foo1', 'Bar1', 'Baz1'; + }; + + like( + $exception, + qr/\QConflict detected: Roles Foo1, Baz1 exclude role 'Bar1'/, + "role Foo1 & Baz1 exclude role Bar1"); + + isa_ok( + $exception, + "Moose::Exception::RoleExclusionConflict", + "role Foo1 & Baz1 exclude role Bar1"); + + is( + $exception->role_name, + "Bar1", + "role Foo1 & Baz1 exclude role Bar1"); + + is_deeply( + $exception->roles, + ["Foo1", 'Baz1'], + "role Foo1 & Baz1 exclude role Bar1"); +} + +{ + { + package Foo2; + use Moose::Role; + + has 'foo' => ( isa => 'Int' ); + } + + { + package Bar2; + use Moose::Role; + + has 'foo' => ( isa => 'Int' ); + } + + my $exception = exception { + package CompositeRole2; + use Moose::Role; + with 'Foo2', 'Bar2'; + }; + + like( + $exception, + qr/\QWe have encountered an attribute conflict with 'foo' during role composition. This attribute is defined in both Foo2 and Bar2. This is a fatal error and cannot be disambiguated./, + "role Foo2 & Bar2, both have an attribute named foo"); + + isa_ok( + $exception, + "Moose::Exception::AttributeConflictInSummation", + "role Foo2 & Bar2, both have an attribute named foo"); + + is( + $exception->role_name, + "Foo2", + "role Foo2 & Bar2, both have an attribute named foo"); + + is( + $exception->second_role_name, + "Bar2", + "role Foo2 & Bar2, both have an attribute named foo"); + + is( + $exception->attribute_name, + "foo", + "role Foo2 & Bar2, both have an attribute named foo"); +} + +{ + { + package Foo3; + use Moose::Role; + + sub foo {} + } + + { + package Bar3; + use Moose::Role; + + override 'foo' => sub {} + } + + my $exception = exception { + package CompositeRole3; + use Moose::Role; + with 'Foo3', 'Bar3'; + }; + + like( + $exception, + qr/\QRole 'Foo3|Bar3' has encountered an 'override' method conflict during composition (A local method of the same name has been found). This is a fatal error./, + "role Foo3 has a local method 'foo' & role Bar3 is overriding that same method"); + + isa_ok( + $exception, + "Moose::Exception::OverrideConflictInSummation", + "role Foo3 has a local method 'foo' & role Bar3 is overriding that same method"); + + my @role_names = $exception->role_names; + my $role_names = join "|", @role_names; + is( + $role_names, + "Foo3|Bar3", + "role Foo3 has a local method 'foo' & role Bar3 is overriding that same method"); + + is( + $exception->method_name, + "foo", + "role Foo3 has a local method 'foo' & role Bar3 is overriding that same method"); +} + +{ + { + package Foo4; + use Moose::Role; + + override 'foo' => sub {}; + } + + { + package Bar4; + use Moose::Role; + + override 'foo' => sub {}; + } + + my $exception = exception { + package CompositeRole4; + use Moose::Role; + with 'Foo4', 'Bar4'; + }; + + like( + $exception, + qr/\QWe have encountered an 'override' method conflict during composition (Two 'override' methods of the same name encountered). This is a fatal error./, + "role Foo4 & Bar4, both are overriding the same method 'foo'"); + + isa_ok( + $exception, + "Moose::Exception::OverrideConflictInSummation", + "role Foo4 & Bar4, both are overriding the same method 'foo'"); + + my @role_names = $exception->role_names; + my $role_names = join "|", @role_names; + is( + $role_names, + "Foo4|Bar4", + "role Foo4 & Bar4, both are overriding the same method 'foo'"); + + is( + $exception->method_name, + "foo", + "role Foo4 & Bar4, both are overriding the same method 'foo'"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-role-application-toclass.t b/t/exceptions/moose-meta-role-application-toclass.t new file mode 100644 index 0000000..2a32e38 --- /dev/null +++ b/t/exceptions/moose-meta-role-application-toclass.t @@ -0,0 +1,432 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +use Moose::Util 'find_meta'; + +{ + { + package BarRole; + use Moose::Role; + } + + { + package RoleExcludingBarRole; + use Moose::Role; + excludes 'BarRole'; + } + + my $exception = exception { + { + package FooClass; + use Moose; + + with 'RoleExcludingBarRole'; + with 'BarRole'; + } + }; + + like( + $exception, + qr/\QConflict detected: FooClass excludes role 'BarRole'/, + 'class FooClass excludes Role BarRole'); + + isa_ok( + $exception, + "Moose::Exception::ConflictDetectedInCheckRoleExclusionsInToClass", + 'class FooClass excludes Role BarRole'); + + is( + $exception->class_name, + "FooClass", + 'class FooClass excludes Role BarRole'); + + is( + find_meta($exception->class_name), + FooClass->meta, + 'class FooClass excludes Role BarRole'); + + is( + $exception->role_name, + "BarRole", + 'class FooClass excludes Role BarRole'); + + is( + find_meta($exception->role_name), + BarRole->meta, + 'class FooClass excludes Role BarRole'); +} + +{ + { + package BarRole2; + use Moose::Role; + excludes 'ExcludedRole2'; + } + + { + package ExcludedRole2; + use Moose::Role; + } + + my $exception = exception { + { + package FooClass2; + use Moose; + + with 'ExcludedRole2'; + with 'BarRole2'; + } + }; + + like( + $exception, + qr/\QThe class FooClass2 does the excluded role 'ExcludedRole2'/, + 'Class FooClass2 does Role ExcludedRole2'); + + isa_ok( + $exception, + "Moose::Exception::ClassDoesTheExcludedRole", + 'Class FooClass2 does Role ExcludedRole2'); + + is( + $exception->role_name, + "BarRole2", + 'Class FooClass2 does Role ExcludedRole2'); + + is( + find_meta($exception->role_name), + BarRole2->meta, + 'Class FooClass2 does Role ExcludedRole2'); + + is( + $exception->excluded_role_name, + "ExcludedRole2", + 'Class FooClass2 does Role ExcludedRole2'); + + is( + find_meta($exception->excluded_role_name), + ExcludedRole2->meta, + 'Class FooClass2 does Role ExcludedRole2'); + + is( + $exception->class_name, + "FooClass2", + 'Class FooClass2 does Role ExcludedRole2'); + + is( + find_meta($exception->class_name), + FooClass2->meta, + 'Class FooClass2 does Role ExcludedRole2'); +} + +{ + { + package Foo5; + use Moose::Role; + + sub foo5 { "foo" } + } + + my $exception = exception { + { + package Bar5; + use Moose; + with 'Foo5' => { + -alias => { foo5 => 'foo_in_bar' } + }; + + sub foo_in_bar { "test in foo" } + } + }; + + like( + $exception, + qr/\QCannot create a method alias if a local method of the same name exists/, + "Class Bar5 already has a method named foo_in_bar"); + + isa_ok( + $exception, + "Moose::Exception::CannotCreateMethodAliasLocalMethodIsPresentInClass", + "Class Bar5 already has a method named foo_in_bar"); + + is( + $exception->role_name, + "Foo5", + "Class Bar5 already has a method named foo_in_bar"); + + is( + find_meta($exception->role_name), + Foo5->meta, + "Class Bar5 already has a method named foo_in_bar"); + + is( + $exception->class_name, + "Bar5", + "Class Bar5 already has a method named foo_in_bar"); + + is( + find_meta($exception->class_name), + Bar5->meta, + "Class Bar5 already has a method named foo_in_bar"); + + is( + $exception->aliased_method_name, + "foo_in_bar", + "Class Bar5 already has a method named foo_in_bar"); + + is( + $exception->method->name, + "foo5", + "Class Bar5 already has a method named foo_in_bar"); +} + +{ + { + package Foo::Role; + use Moose::Role; + + sub foo { 'Foo::Role::foo' } + } + + { + package Bar::Role; + use Moose::Role; + + sub foo { 'Bar::Role::foo' } + } + + { + package Baz::Role; + use Moose::Role; + + sub foo { 'Baz::Role::foo' } + } + + my $exception = exception { + { + package My::Foo::Class::Broken; + use Moose; + + with 'Foo::Role', + 'Bar::Role', + 'Baz::Role' => { -excludes => 'foo' }; + } + }; + + like( + $exception, + qr/\QDue to a method name conflict in roles 'Bar::Role' and 'Foo::Role', the method 'foo' must be implemented or excluded by 'My::Foo::Class::Broken'/, + 'Foo::Role, Bar::Role & Baz::Role, all three has a method named foo'); + + isa_ok( + $exception, + "Moose::Exception::MethodNameConflictInRoles", + 'Foo::Role, Bar::Role & Baz::Role, all three has a method named foo'); + + is( + $exception->class_name, + "My::Foo::Class::Broken", + 'Foo::Role, Bar::Role & Baz::Role, all three has a method named foo'); + + is( + find_meta($exception->class_name), + My::Foo::Class::Broken->meta, + 'Foo::Role, Bar::Role & Baz::Role, all three has a method named foo'); + + is( + $exception->get_method_at(0)->name, + "foo", + 'Foo::Role, Bar::Role & Baz::Role, all three has a method named foo'); + + is( + $exception->get_method_at(0)->roles_as_english_list, + "'Bar::Role' and 'Foo::Role'", + 'Foo::Role, Bar::Role & Baz::Role, all three has a method named foo'); +} + +{ + { + package Foo2::Role; + use Moose::Role; + + sub foo { 'Foo2::Role::foo' } + sub bar { 'Foo2::Role::bar' } + } + + { + package Bar2::Role; + use Moose::Role; + + sub foo { 'Bar2::Role::foo' } + sub bar { 'Bar2::Role::bar' } + } + + { + package Baz2::Role; + use Moose::Role; + + sub foo { 'Baz2::Role::foo' } + sub bar { 'Baz2::Role::bar' } + } + + my $exception = exception { + { + package My::Foo::Class::Broken2; + use Moose; + + with 'Foo2::Role', + 'Bar2::Role', + 'Baz2::Role'; + } + }; + + like( + $exception, + qr/\QDue to method name conflicts in roles 'Bar2::Role' and 'Foo2::Role', the methods 'bar' and 'foo' must be implemented or excluded by 'My::Foo::Class::Broken2'/, + 'Foo2::Role, Bar2::Role & Baz2::Role, all three has a methods named foo & bar'); + + isa_ok( + $exception, + "Moose::Exception::MethodNameConflictInRoles", + 'Foo2::Role, Bar2::Role & Baz2::Role, all three has a methods named foo & bar'); + + is( + $exception->class_name, + "My::Foo::Class::Broken2", + 'Foo2::Role, Bar2::Role & Baz2::Role, all three has a methods named foo & bar'); + + is( + find_meta($exception->class_name), + My::Foo::Class::Broken2->meta, + 'Foo2::Role, Bar2::Role & Baz2::Role, all three has a methods named foo & bar'); + + is( + $exception->get_method_at(0)->roles_as_english_list, + "'Bar2::Role' and 'Foo2::Role'", + 'Foo2::Role, Bar2::Role & Baz2::Role, all three has a methods named foo & bar'); +} + +{ + { + package Foo3::Role; + use Moose::Role; + requires 'foo'; + } + + { + package Bar3::Role; + use Moose::Role; + } + + { + package Baz3::Role; + use Moose::Role; + } + + my $exception = exception { + { + package My::Foo::Class::Broken3; + use Moose; + with 'Foo3::Role', + 'Bar3::Role', + 'Baz3::Role'; + } + }; + + like( + $exception, + qr/\Q'Foo3::Role|Bar3::Role|Baz3::Role' requires the method 'foo' to be implemented by 'My::Foo::Class::Broken3'/, + "foo is required by Foo3::Role, but it's not implemented by My::Foo::Class::Broken3"); + + isa_ok( + $exception, + "Moose::Exception::RequiredMethodsNotImplementedByClass", + "foo is required by Foo3::Role, but it's not implemented by My::Foo::Class::Broken3"); + + is( + $exception->class_name, + "My::Foo::Class::Broken3", + "foo is required by Foo3::Role, but it's not implemented by My::Foo::Class::Broken3"); + + is( + find_meta($exception->class_name), + My::Foo::Class::Broken3->meta, + "foo is required by Foo3::Role, but it's not implemented by My::Foo::Class::Broken3"); + + is( + $exception->role_name, + 'Foo3::Role|Bar3::Role|Baz3::Role', + "foo is required by Foo3::Role, but it's not implemented by My::Foo::Class::Broken3"); + + is( + $exception->get_method_at(0)->name, + "foo", + "foo is required by Foo3::Role, but it's not implemented by My::Foo::Class::Broken3"); +} + +{ + BEGIN { + package ExportsFoo; + use Sub::Exporter -setup => { + exports => ['foo'], + }; + + sub foo { 'FOO' } + + $INC{'ExportsFoo.pm'} = 1; + } + + { + package Foo4::Role; + use Moose::Role; + requires 'foo'; + } + + my $exception = exception { + { + package Class; + use Moose; + use ExportsFoo 'foo'; + with 'Foo4::Role'; + } + }; + + my $methodName = "\\&foo"; + + like( + $exception, + qr/\Q'Foo4::Role' requires the method 'foo' to be implemented by 'Class'. If you imported functions intending to use them as methods, you need to explicitly mark them as such, via Class->meta->add_method(foo => $methodName)/, + "foo is required by Foo4::Role and imported by Class"); + + isa_ok( + $exception, + "Moose::Exception::RequiredMethodsImportedByClass", + "foo is required by Foo4::Role and imported by Class"); + + is( + $exception->class_name, + "Class", + "foo is required by Foo4::Role and imported by Class"); + + is( + find_meta($exception->class_name), + Class->meta, + "foo is required by Foo4::Role and imported by Class"); + + is( + $exception->role_name, + 'Foo4::Role', + "foo is required by Foo4::Role and imported by Class"); + + is( + $exception->get_method_at(0)->name, + "foo", + "foo is required by Foo4::Role and imported by Class"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-role-application-torole.t b/t/exceptions/moose-meta-role-application-torole.t new file mode 100644 index 0000000..cd827f4 --- /dev/null +++ b/t/exceptions/moose-meta-role-application-torole.t @@ -0,0 +1,350 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util 'find_meta'; + +use Moose(); + +{ + { + package Foo; + use Moose::Role; + excludes 'Bar'; + } + + { + package Bar; + use Moose::Role; + } + + my $exception = exception { + Moose::Meta::Role::Application::ToRole->check_role_exclusions( Bar->meta, Foo->meta ); + }; + + like( + $exception, + qr/\QConflict detected: Foo excludes role 'Bar'/, + 'Role Foo excludes Role Bar'); + + isa_ok( + $exception, + "Moose::Exception::ConflictDetectedInCheckRoleExclusions", + 'Role Foo excludes Role Bar'); + + is( + $exception->role_name, + "Foo", + 'Role Foo excludes Role Bar'); + + is( + find_meta($exception->role_name), + Foo->meta, + 'Role Foo excludes Role Bar'); + + is( + $exception->excluded_role_name, + "Bar", + 'Role Foo excludes Role Bar'); + + is( + find_meta($exception->excluded_role_name), + Bar->meta, + 'Role Foo excludes Role Bar'); +} + +{ + { + package Foo2; + use Moose::Role; + excludes 'Bar3'; + } + + { + package Bar2; + use Moose::Role; + with 'Bar3'; + } + + { + package Bar3; + use Moose::Role; + } + + my $exception = exception { + Moose::Meta::Role::Application::ToRole->check_role_exclusions( Foo2->meta, Bar2->meta ); + }; + + like( + $exception, + qr/\QThe role Bar2 does the excluded role 'Bar3'/, + 'Role Bar2 does Role Bar3'); + + isa_ok( + $exception, + "Moose::Exception::RoleDoesTheExcludedRole", + 'Role Bar2 does Role Bar3'); + + is( + $exception->second_role_name, + "Foo2", + 'Role Bar2 does Role Bar3'); + + is( + find_meta($exception->second_role_name), + Foo2->meta, + 'Role Bar2 does Role Bar3'); + + is( + $exception->excluded_role_name, + "Bar3", + 'Role Bar2 does Role Bar3'); + + is( + find_meta($exception->excluded_role_name), + Bar3->meta, + 'Role Bar2 does Role Bar3'); + + is( + $exception->role_name, + "Bar2", + 'Role Bar2 does Role Bar3'); + + is( + find_meta($exception->role_name), + Bar2->meta, + 'Role Bar2 does Role Bar3'); +} + +{ + { + package Foo4; + use Moose::Role; + + has 'foo' => ( + is => 'ro', + isa => 'Int' + ); + } + + { + package Bar4; + use Moose::Role; + + has 'foo' => ( + is => 'ro', + isa => 'Int' + ); + } + + my $exception = exception { + Moose::Meta::Role::Application::ToRole->apply_attributes( Foo4->meta, Bar4->meta ); + }; + + like( + $exception, + qr/\QRole 'Foo4' has encountered an attribute conflict while being composed into 'Bar4'. This is a fatal error and cannot be disambiguated. The conflicting attribute is named 'foo'./, + 'Role Foo4 & Role Bar4 has one common attribute named "foo"'); + + isa_ok( + $exception, + "Moose::Exception::AttributeConflictInRoles", + 'Role Foo4 & Role Bar4 has one common attribute named "foo"'); + + is( + $exception->role_name, + "Foo4", + 'Role Foo4 & Role Bar4 has one common attribute named "foo"'); + + is( + find_meta($exception->role_name), + Foo4->meta, + 'Role Foo4 & Role Bar4 has one common attribute named "foo"'); + + is( + $exception->second_role_name, + "Bar4", + 'Role Foo4 & Role Bar4 has one common attribute named "foo"'); + + is( + find_meta($exception->second_role_name), + Bar4->meta, + 'Role Foo4 & Role Bar4 has one common attribute named "foo"'); + + is( + $exception->attribute_name, + 'foo', + 'Role Foo4 & Role Bar4 has one common attribute named "foo"'); +} + +{ + { + package Foo5; + use Moose::Role; + + sub foo5 { "foo" } + } + + my $exception = exception { + { + package Bar5; + use Moose::Role; + with 'Foo5' => { + -alias => { foo5 => 'foo_in_bar' } + }; + + sub foo_in_bar { "test in foo" } + } + }; + + like( + $exception, + qr/\QCannot create a method alias if a local method of the same name exists/, + "Role Bar5 already has a method named foo_in_bar"); + + isa_ok( + $exception, + "Moose::Exception::CannotCreateMethodAliasLocalMethodIsPresent", + "Role Bar5 already has a method named foo_in_bar"); + + is( + $exception->role_name, + "Bar5", + "Role Bar5 already has a method named foo_in_bar"); + + is( + find_meta($exception->role_name), + Bar5->meta, + "Role Bar5 already has a method named foo_in_bar"); + + is( + $exception->role_being_applied_name, + "Foo5", + "Role Bar5 already has a method named foo_in_bar"); + + is( + find_meta($exception->role_being_applied_name), + Foo5->meta, + "Role Bar5 already has a method named foo_in_bar"); + + is( + $exception->aliased_method_name, + "foo_in_bar", + "Role Bar5 already has a method named foo_in_bar"); + + is( + $exception->method->name, + "foo5", + "Role Bar5 already has a method named foo_in_bar"); +} + +{ + { + package Foo6; + use Moose::Role; + + override foo6 => sub { "override foo6" }; + } + + my $exception = exception { + { + package Bar6; + use Moose::Role; + with 'Foo6'; + + sub foo6 { "test in foo6" } + } + }; + + like( + $exception, + qr/\QRole 'Foo6' has encountered an 'override' method conflict during composition (A local method of the same name as been found). This is a fatal error./, + "Role Foo6 is overriding a method named foo6, which is a local method in Bar6"); + + isa_ok( + $exception, + "Moose::Exception::OverrideConflictInComposition", + "Role Foo6 is overriding a method named foo6, which is a local method in Bar6"); + + is( + $exception->role_name, + "Bar6", + "Role Foo6 is overriding a method named foo6, which is a local method in Bar6"); + + is( + find_meta($exception->role_name), + Bar6->meta, + "Role Foo6 is overriding a method named foo6, which is a local method in Bar6"); + + is( + $exception->role_being_applied_name, + "Foo6", + "Role Foo6 is overriding a method named foo6, which is a local method in Bar6"); + + is( + find_meta($exception->role_being_applied_name), + Foo6->meta, + "Role Foo6 is overriding a method named foo6, which is a local method in Bar6"); + + is( + $exception->method_name, + "foo6", + "Role Foo6 is overriding a method named foo6, which is a local method in Bar6"); +} + +{ + { + package Foo7; + use Moose::Role; + + override foo7 => sub { "override foo7" }; + } + + my $exception = exception { + { + package Bar7; + use Moose::Role; + override foo7 => sub { "override foo7 in Bar7" }; + with 'Foo7'; + } + }; + + like( + $exception, + qr/\QRole 'Foo7' has encountered an 'override' method conflict during composition (Two 'override' methods of the same name encountered). This is a fatal error./, + "Roles Foo7 & Bar7, both have override foo7"); + + isa_ok( + $exception, + "Moose::Exception::OverrideConflictInComposition", + "Roles Foo7 & Bar7, both have override foo7"); + + is( + $exception->role_name, + "Bar7", + "Roles Foo7 & Bar7, both have override foo7"); + + is( + find_meta($exception->role_name), + Bar7->meta, + "Roles Foo7 & Bar7, both have override foo7"); + + is( + $exception->role_being_applied_name, + "Foo7", + "Roles Foo7 & Bar7, both have override foo7"); + + is( + find_meta($exception->role_being_applied_name), + Foo7->meta, + "Roles Foo7 & Bar7, both have override foo7"); + + is( + $exception->method_name, + "foo7", + "Roles Foo7 & Bar7, both have override foo7"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-role-application.t b/t/exceptions/moose-meta-role-application.t new file mode 100644 index 0000000..b1ccf62 --- /dev/null +++ b/t/exceptions/moose-meta-role-application.t @@ -0,0 +1,121 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role::Application; + +{ + my $exception = exception { + Moose::Meta::Role::Application->check_role_exclusions; + }; + + like( + $exception, + qr/Abstract method/, + "cannot call an abstract method"); + + isa_ok( + $exception, + "Moose::Exception::CannotCallAnAbstractMethod", + "cannot call an abstract method"); +} + +{ + my $exception = exception { + Moose::Meta::Role::Application->check_required_methods; + }; + + like( + $exception, + qr/Abstract method/, + "cannot call an abstract method"); + + isa_ok( + $exception, + "Moose::Exception::CannotCallAnAbstractMethod", + "cannot call an abstract method"); +} + +{ + my $exception = exception { + Moose::Meta::Role::Application->check_required_attributes; + }; + + like( + $exception, + qr/Abstract method/, + "cannot call an abstract method"); + + isa_ok( + $exception, + "Moose::Exception::CannotCallAnAbstractMethod", + "cannot call an abstract method"); +} + +{ + my $exception = exception { + Moose::Meta::Role::Application->apply_attributes; + }; + + like( + $exception, + qr/Abstract method/, + "cannot call an abstract method"); + + isa_ok( + $exception, + "Moose::Exception::CannotCallAnAbstractMethod", + "cannot call an abstract method"); +} + +{ + my $exception = exception { + Moose::Meta::Role::Application->apply_methods; + }; + + like( + $exception, + qr/Abstract method/, + "cannot call an abstract method"); + + isa_ok( + $exception, + "Moose::Exception::CannotCallAnAbstractMethod", + "cannot call an abstract method"); +} + +{ + my $exception = exception { + Moose::Meta::Role::Application->apply_override_method_modifiers; + }; + + like( + $exception, + qr/Abstract method/, + "cannot call an abstract method"); + + isa_ok( + $exception, + "Moose::Exception::CannotCallAnAbstractMethod", + "cannot call an abstract method"); +} + +{ + my $exception = exception { + Moose::Meta::Role::Application->apply_method_modifiers; + }; + + like( + $exception, + qr/Abstract method/, + "cannot call an abstract method"); + + isa_ok( + $exception, + "Moose::Exception::CannotCallAnAbstractMethod", + "cannot call an abstract method"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-role-attribute.t b/t/exceptions/moose-meta-role-attribute.t new file mode 100644 index 0000000..f7c9008 --- /dev/null +++ b/t/exceptions/moose-meta-role-attribute.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + Moose::Meta::Role::Attribute->new; + }; + + like( + $exception, + qr/You must provide a name for the attribute/, + "no name is given"); + + isa_ok( + $exception, + "Moose::Exception::MustProvideANameForTheAttribute", + "no name is given"); +} + +{ + my $exception = exception { + Moose::Meta::Role::Attribute->attach_to_role; + }; + + like( + $exception, + qr/\QYou must pass a Moose::Meta::Role instance (or a subclass)/, + "no role is given to attach_to_role"); + + isa_ok( + $exception, + "Moose::Exception::MustPassAMooseMetaRoleInstanceOrSubclass", + "no role is given to attach_to_role"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-role-composite.t b/t/exceptions/moose-meta-role-composite.t new file mode 100644 index 0000000..05ae6ae --- /dev/null +++ b/t/exceptions/moose-meta-role-composite.t @@ -0,0 +1,84 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + my $rolesComp = Moose::Meta::Role::Composite->new(roles => ["foo"]); + }; + + like( + $exception, + qr/\QThe list of roles must be instances of Moose::Meta::Role, not foo/, + "'foo' is not an instance of Moose::Meta::Role"); + + isa_ok( + $exception, + "Moose::Exception::RolesListMustBeInstancesOfMooseMetaRole", + "'foo' is not an instance of Moose::Meta::Role"); + + is( + $exception->role, + "foo", + "'foo' is not an instance of Moose::Meta::Role"); +} + +{ + { + package Foo; + use Moose::Role; + } + + my $rolesComp = Moose::Meta::Role::Composite->new(roles => [Foo->meta]); + my $exception = exception { + $rolesComp->add_method; + }; + + like( + $exception, + qr/You must define a method name/, + "no method name given to add_method"); + + isa_ok( + $exception, + "Moose::Exception::MustDefineAMethodName", + "no method name given to add_method"); + + is( + $exception->instance, + $rolesComp, + "no method name given to add_method"); +} + +{ + { + package Foo; + use Moose::Role; + } + + my $rolesComp = Moose::Meta::Role::Composite->new(roles => [Foo->meta]); + my $exception = exception { + $rolesComp->reinitialize; + }; + + like( + $exception, + qr/Moose::Meta::Role::Composite instances can only be reinitialized from an existing metaclass instance/, + "no metaclass instance is given"); + + isa_ok( + $exception, + "Moose::Exception::CannotInitializeMooseMetaRoleComposite", + "no metaclass instance is given"); + + is( + $exception->role_composite, + $rolesComp, + "no metaclass instance is given"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-typecoercion-union.t b/t/exceptions/moose-meta-typecoercion-union.t new file mode 100644 index 0000000..3712165 --- /dev/null +++ b/t/exceptions/moose-meta-typecoercion-union.t @@ -0,0 +1,56 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose; +use Moose::Util::TypeConstraints; + +{ + my $exception = exception { + Moose::Meta::TypeCoercion::Union->new( type_constraint => find_type_constraint("Str") ); + }; + + like( + $exception, + qr/\QYou can only create a Moose::Meta::TypeCoercion::Union for a Moose::Meta::TypeConstraint::Union, not a Str/, + "'Str' is not a Moose::Meta::TypeConstraint::Union"); + + isa_ok( + $exception, + "Moose::Exception::NeedsTypeConstraintUnionForTypeCoercionUnion", + "'Str' is not a Moose::Meta::TypeConstraint::Union"); + + is( + $exception->type_name, + "Str", + "'Str' is not a Moose::Meta::TypeConstraint::Union"); +} + +{ + union 'StringOrInt', [qw( Str Int )]; + my $type = find_type_constraint("StringOrInt"); + my $tt = Moose::Meta::TypeCoercion::Union->new( type_constraint => $type ); + + my $exception = exception { + $tt->add_type_coercions("ArrayRef"); + }; + + like( + $exception, + qr/Cannot add additional type coercions to Union types/, + "trying to add ArrayRef to a Moose::Meta::TypeCoercion::Union object"); + + isa_ok( + $exception, + "Moose::Exception::CannotAddAdditionalTypeCoercionsToUnion", + "trying to add ArrayRef to a Moose::Meta::TypeCoercion::Union object"); + + is( + $exception->type_coercion_union_object, + $tt, + "trying to add ArrayRef to a Moose::Meta::TypeCoercion::Union object"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-typecoercion.t b/t/exceptions/moose-meta-typecoercion.t new file mode 100644 index 0000000..50a73ab --- /dev/null +++ b/t/exceptions/moose-meta-typecoercion.t @@ -0,0 +1,59 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +{ + subtype 'typeInt', + as 'Int'; + + my $exception = exception { + coerce 'typeInt', + from 'xyz'; + }; + + like( + $exception, + qr/\QCould not find the type constraint (xyz) to coerce from/, + "xyz is not a valid type constraint"); + + isa_ok( + $exception, + "Moose::Exception::CouldNotFindTypeConstraintToCoerceFrom", + "xyz is not a valid type constraint"); + + is( + $exception->constraint_name, + "xyz", + "xyz is not a valid type constraint"); +} + +{ + subtype 'typeInt', + as 'Int'; + + my $exception = exception { + coerce 'typeInt', from 'Int', via { "123" }; + coerce 'typeInt', from 'Int', via { 12 }; + }; + + like( + $exception, + qr/\QA coercion action already exists for 'Int'/, + "coercion already exists"); + + isa_ok( + $exception, + "Moose::Exception::CoercionAlreadyExists", + "coercion already exists"); + + is( + $exception->constraint_name, + "Int", + "coercion already exists"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-typeconstraint-enum.t b/t/exceptions/moose-meta-typeconstraint-enum.t new file mode 100644 index 0000000..4028212 --- /dev/null +++ b/t/exceptions/moose-meta-typeconstraint-enum.t @@ -0,0 +1,64 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +{ + my $exception = exception { + my $method = Moose::Meta::TypeConstraint::Enum->new( values => []); + }; + + like( + $exception, + qr/You must have at least one value to enumerate through/, + "an Array ref of zero length is given as values"); + + isa_ok( + $exception, + "Moose::Exception::MustHaveAtLeastOneValueToEnumerate", + "an Array ref of zero length is given as values"); +} + +{ + my $exception = exception { + my $method = Moose::Meta::TypeConstraint::Enum->new( values => [undef]); + }; + + like( + $exception, + qr/Enum values must be strings, not undef/, + "undef is given to values"); + + isa_ok( + $exception, + "Moose::Exception::EnumValuesMustBeString", + "undef is given to values"); +} + +{ + my $arrayRef = [1,2,3]; + my $exception = exception { + my $method = Moose::Meta::TypeConstraint::Enum->new( values => [$arrayRef]); + }; + + like( + $exception, + qr/\QEnum values must be strings, not '$arrayRef'/, + "an array ref is given instead of a string"); + #Enum values must be strings, not 'ARRAY(0x191d1b8)' + + isa_ok( + $exception, + "Moose::Exception::EnumValuesMustBeString", + "an array ref is given instead of a string"); + + is( + $exception->value, + $arrayRef, + "an array ref is given instead of a string"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-typeconstraint-parameterizable.t b/t/exceptions/moose-meta-typeconstraint-parameterizable.t new file mode 100644 index 0000000..5ae75fc --- /dev/null +++ b/t/exceptions/moose-meta-typeconstraint-parameterizable.t @@ -0,0 +1,67 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +{ + my $t = find_type_constraint('ArrayRef'); + my $intType = find_type_constraint("Int"); + my $type = Moose::Meta::TypeConstraint::Parameterizable->new( name => 'xyz', parent => $t); + + my $exception = exception { + $type->generate_inline_for( $intType, '$_[0]'); + }; + + like( + $exception, + qr/Can't generate an inline constraint for Int, since none was defined/, + "no inline constraint was defined for xyz"); + + isa_ok( + $exception, + "Moose::Exception::CannotGenerateInlineConstraint", + "no inline constraint was defined for xyz"); + + is( + $exception->type_name, + "Int", + "no inline constraint was defined for xyz"); + + is( + $exception->parameterizable_type_object_name, + $type->name, + "no inline constraint was defined for xyz"); +} + +{ + my $parameterizable = subtype 'parameterizable_arrayref', as 'ArrayRef[Float]'; + my $int = find_type_constraint('Int'); + my $exception = exception { + my $from_parameterizable = $parameterizable->parameterize("Int"); + }; + + like( + $exception, + qr/Int is not a subtype of Float/, + "Int is not a subtype of Float"); + + isa_ok( + $exception, + "Moose::Exception::ParameterIsNotSubtypeOfParent", + "Int is not a subtype of Float"); + + is( + $exception->type_name, + $parameterizable, + "Int is not a subtype of Float"); + + is( + $exception->type_parameter, + $int, + "Int is not a subtype of Float"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-typeconstraint-parameterized.t b/t/exceptions/moose-meta-typeconstraint-parameterized.t new file mode 100644 index 0000000..ae685a8 --- /dev/null +++ b/t/exceptions/moose-meta-typeconstraint-parameterized.t @@ -0,0 +1,83 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + my $exception = exception { + Moose::Meta::TypeConstraint::Parameterized->new( name => "TestType" ); + }; + + like( + $exception, + qr/You cannot create a Higher Order type without a type parameter/, + "type_parameter not given"); + + isa_ok( + $exception, + 'Moose::Exception::CannotCreateHigherOrderTypeWithoutATypeParameter', + "type_parameter not given"); + + is( + $exception->type_name, + "TestType", + "type_parameter not given"); +} + +{ + my $exception = exception { + Moose::Meta::TypeConstraint::Parameterized->new( name => "TestType2", + type_parameter => 'Int' + ); + }; + + like( + $exception, + qr/The type parameter must be a Moose meta type/, + "'Int' is not a Moose::Meta::TypeConstraint"); + + isa_ok( + $exception, + 'Moose::Exception::TypeParameterMustBeMooseMetaType', + "'Int' is not a Moose::Meta::TypeConstraint"); + + is( + $exception->type_name, + "TestType2", + "'Int' is not a Moose::Meta::TypeConstraint"); +} + +{ + my $exception = exception { + package Foo; + use Moose; + + has 'foo' => ( + is => 'ro', + isa => 'Int[Xyz]', + ); + }; + + like( + $exception, + qr/\QThe Int[Xyz] constraint cannot be used, because Int doesn't subtype or coerce from a parameterizable type./, + "invalid isa given to foo"); + + isa_ok( + $exception, + 'Moose::Exception::TypeConstraintCannotBeUsedForAParameterizableType', + "invalid isa given to foo"); + + is( + $exception->type_name, + "Int[Xyz]", + "invalid isa given to foo"); + + is( + $exception->parent_type_name, + 'Int', + "invalid isa given to foo"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-typeconstraint-registry.t b/t/exceptions/moose-meta-typeconstraint-registry.t new file mode 100644 index 0000000..fa20375 --- /dev/null +++ b/t/exceptions/moose-meta-typeconstraint-registry.t @@ -0,0 +1,27 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose; + +{ + my $tr = Moose::Meta::TypeConstraint::Registry->new(); + + my $exception = exception { + $tr->add_type_constraint('xyz'); + }; + + like( + $exception, + qr!No type supplied / type is not a valid type constraint!, + "'xyz' is not a Moose::Meta::TypeConstraint"); + + isa_ok( + $exception, + 'Moose::Exception::InvalidTypeConstraint', + "'xyz' is not a Moose::Meta::TypeConstraint"); +} + +done_testing; diff --git a/t/exceptions/moose-meta-typeconstraint.t b/t/exceptions/moose-meta-typeconstraint.t new file mode 100644 index 0000000..71e87d1 --- /dev/null +++ b/t/exceptions/moose-meta-typeconstraint.t @@ -0,0 +1,139 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; +use Moose(); + +# tests for type coercions +{ + subtype 'HexNum' => as 'Int', where { /[a-f0-9]/i }; + my $type_object = find_type_constraint 'HexNum'; + + my $exception = exception { + $type_object->coerce; + }; + + like( + $exception, + qr/Cannot coerce without a type coercion/, + "You cannot coerce a type unless coercion is supported by that type"); + + is( + $exception->type_name, + 'HexNum', + "You cannot coerce a type unless coercion is supported by that type"); + + isa_ok( + $exception, + "Moose::Exception::CoercingWithoutCoercions", + "You cannot coerce a type unless coercion is supported by that type"); +} + +{ + my $exception = exception { + Moose::Meta::TypeConstraint->new( message => "foo"); + }; + + like( + $exception, + qr/The 'message' parameter must be a coderef/, + "'foo' is not a CODE ref"); + + isa_ok( + $exception, + "Moose::Exception::MessageParameterMustBeCodeRef", + "'foo' is not a CODE ref"); +} + +{ + subtype 'NotInlinable', + as 'Str', + where { $_ !~ /Q/ }; + my $not_inlinable = find_type_constraint('NotInlinable'); + + my $exception = exception { + $not_inlinable->_inline_check('$foo'); + }; + + like( + $exception, + qr/Cannot inline a type constraint check for NotInlinable/, + "cannot inline NotInlinable"); + + isa_ok( + $exception, + "Moose::Exception::CannotInlineTypeConstraintCheck", + "cannot inline NotInlinable"); + + is( + $exception->type_name, + "NotInlinable", + "cannot inline NotInlinable"); + + is( + find_type_constraint( $exception->type_name ), + $not_inlinable, + "cannot inline NotInlinable"); +} + +{ + my $exception = exception { + Moose::Meta::TypeConstraint->new(name => "FooTypeConstraint", constraint => undef) + }; + + like( + $exception, + qr/Could not compile type constraint 'FooTypeConstraint' because no constraint check/, + "constraint is set to undef"); + + isa_ok( + $exception, + "Moose::Exception::NoConstraintCheckForTypeConstraint", + "constraint is set to undef"); + + is( + $exception->type_name, + "FooTypeConstraint", + "constraint is set to undef"); +} + +{ + subtype 'OnlyPositiveInts', + as 'Int', + where { $_ > 1 }; + my $onlyposint = find_type_constraint('OnlyPositiveInts'); + + my $exception = exception { + $onlyposint->assert_valid( -123 ); + }; + + like( + $exception, + qr/Validation failed for 'OnlyPositiveInts' with value -123/, + "-123 is not valid for OnlyPositiveInts"); + + isa_ok( + $exception, + "Moose::Exception::ValidationFailedForTypeConstraint", + "-123 is not valid for OnlyPositiveInts"); + + is( + $exception->type->name, + "OnlyPositiveInts", + "-123 is not valid for OnlyPositiveInts"); + + is( + $exception->type, + $onlyposint, + "-123 is not valid for OnlyPositiveInts"); + + is( + $exception->value, + -123, + "-123 is not valid for OnlyPositiveInts"); +} + +done_testing; diff --git a/t/exceptions/moose-role.t b/t/exceptions/moose-role.t new file mode 100644 index 0000000..a2200fb --- /dev/null +++ b/t/exceptions/moose-role.t @@ -0,0 +1,321 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose(); + +use Moose::Util 'find_meta'; + +{ + my $exception = exception { + package Bar; + use Moose::Role; + extends 'Foo'; + }; + + like( + $exception, + qr/\QRoles do not support 'extends' (you can use 'with' to specialize a role)/, + "Roles do not support extends"); + + isa_ok( + $exception, + "Moose::Exception::RolesDoNotSupportExtends", + "Roles do not support extends"); +} + +{ + my $exception = exception { + package Bar; + use Moose::Role; + requires; + }; + + like( + $exception, + qr/Must specify at least one method/, + "requires expects atleast one method name"); + + isa_ok( + $exception, + "Moose::Exception::MustSpecifyAtleastOneMethod", + "requires expects atleast one method name"); + + is( + $exception->role_name, + 'Bar', + 'requires expects atleast one method name'); +} + +{ + my $exception = exception { + package Bar; + use Moose::Role; + excludes; + }; + + like( + $exception, + qr/Must specify at least one role/, + "excludes expects atleast one role name"); + + isa_ok( + $exception, + "Moose::Exception::MustSpecifyAtleastOneRole", + "excludes expects atleast one role name"); + + is( + $exception->role_name, + 'Bar', + 'excludes expects atleast one role name'); +} + +{ + my $exception = exception { + package Bar; + use Moose::Role; + inner; + }; + + like( + $exception, + qr/Roles cannot support 'inner'/, + "Roles do not support 'inner'"); + + isa_ok( + $exception, + "Moose::Exception::RolesDoNotSupportInner", + "Roles do not support 'inner'"); +} + +{ + my $exception = exception { + package Bar; + use Moose::Role; + augment 'foo' => sub {}; + }; + + like( + $exception, + qr/Roles cannot support 'augment'/, + "Roles do not support 'augment'"); + + isa_ok( + $exception, + "Moose::Exception::RolesDoNotSupportAugment", + "Roles do not support 'augment'"); +} + +{ + my $exception = exception { + { + package Foo1; + use Moose::Role; + has 'bar' => ( + is => + ); + } + }; + + like( + $exception, + qr/\QUsage: has 'name' => ( key => value, ... )/, + "has takes a hash"); + + isa_ok( + $exception, + "Moose::Exception::InvalidHasProvidedInARole", + "has takes a hash"); + + is( + $exception->attribute_name, + 'bar', + "has takes a hash"); + + is( + $exception->role_name, + 'Foo1', + "has takes a hash"); +} + +{ + my $exception = exception { + use Moose::Role; + Moose::Role->init_meta; + }; + + like( + $exception, + qr/Cannot call init_meta without specifying a for_class/, + "for_class is not given"); + + isa_ok( + $exception, + "Moose::Exception::InitMetaRequiresClass", + "for_class is not given"); +} + +{ + my $exception = exception { + use Moose::Role; + Moose::Role->init_meta( (for_class => 'Foo2', metaclass => 'Foo2' )); + }; + + like( + $exception, + qr/\QThe Metaclass Foo2 must be loaded. (Perhaps you forgot to 'use Foo2'?)/, + "Foo2 is not loaded"); + + isa_ok( + $exception, + "Moose::Exception::MetaclassNotLoaded", + "Foo2 is not loaded"); + + is( + $exception->class_name, + "Foo2", + "Foo2 is not loaded"); +} + +{ + { + package Foo3; + use Moose; + } + + my $exception = exception { + use Moose::Role; + Moose::Role->init_meta( (for_class => 'Foo3', metaclass => 'Foo3' )); + }; + + like( + $exception, + qr/\QThe Metaclass Foo3 must be a subclass of Moose::Meta::Role./, + "Foo3 is a Moose::Role"); + + isa_ok( + $exception, + "Moose::Exception::MetaclassMustBeASubclassOfMooseMetaRole", + "Foo3 is a Moose::Role"); + + is( + $exception->role_name, + "Foo3", + "Foo3 is a Moose::Role"); +} + +{ + { + package Foo3; + use Moose; + } + + my $exception = exception { + use Moose::Role; + Moose::Role->init_meta( (for_class => 'Foo3' )); + }; + + my $foo3 = Foo3->meta; + + like( + $exception, + qr/\QFoo3 already has a metaclass, but it does not inherit Moose::Meta::Role ($foo3). You cannot make the same thing a role and a class. Remove either Moose or Moose::Role./, + "Foo3 is a Moose class"); + #Foo3 already has a metaclass, but it does not inherit Moose::Meta::Role (Moose::Meta::Class=HASH(0x2d5d160)). You cannot make the same thing a role and a class. Remove either Moose or Moose::Role. + + isa_ok( + $exception, + "Moose::Exception::MetaclassIsAClassNotASubclassOfGivenMetaclass", + "Foo3 is a Moose class"); + + is( + $exception->class_name, + "Foo3", + "Foo3 is a Moose class"); + + is( + find_meta($exception->class_name), + Foo3->meta, + "Foo3 is a Moose class"); + + is( + $exception->metaclass, + "Moose::Meta::Role", + "Foo3 is a Moose class"); +} + +{ + my $foo; + { + $foo = Class::MOP::Class->create("Foo4"); + } + + my $exception = exception { + use Moose::Role; + Moose::Role->init_meta( (for_class => 'Foo4' )); + }; + + like( + $exception, + qr/\QFoo4 already has a metaclass, but it does not inherit Moose::Meta::Role ($foo)./, + "Foo4 is a Class::MOP::Class, not a Moose::Meta::Role"); + #Foo4 already has a metaclass, but it does not inherit Moose::Meta::Role (Class::MOP::Class=HASH(0x2c385a8)). + + isa_ok( + $exception, + "Moose::Exception::MetaclassIsNotASubclassOfGivenMetaclass", + "Foo4 is a Class::MOP::Class, not a Moose::Meta::Role"); + + is( + $exception->class_name, + "Foo4", + "Foo4 is a Class::MOP::Class, not a Moose::Meta::Role"); + + is( + find_meta( $exception->class_name ), + $foo, + "Foo4 is a Class::MOP::Class, not a Moose::Meta::Role"); + + is( + $exception->metaclass, + "Moose::Meta::Role", + "Foo4 is a Class::MOP::Class, not a Moose::Meta::Role"); +} + +{ + my $exception = exception { + package Foo; + use Moose::Role; + + before qr/foo/; + }; + + like( + $exception, + qr/\QRoles do not currently support regex references for before method modifiers/, + "a regex reference is given to before"); + + isa_ok( + $exception, + "Moose::Exception::RolesDoNotSupportRegexReferencesForMethodModifiers", + "a regex reference is given to before"); + + is( + $exception->role_name, + "Foo", + "a regex reference is given to before"); + + is( + find_meta($exception->role_name), + Foo->meta, + "a regex reference is given to before"); + + is( + $exception->modifier_type, + "before", + "a regex reference is given to before"); +} + +done_testing; diff --git a/t/exceptions/moose-util-metarole.t b/t/exceptions/moose-util-metarole.t new file mode 100644 index 0000000..11e30af --- /dev/null +++ b/t/exceptions/moose-util-metarole.t @@ -0,0 +1,129 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + { + package Foo; + use Moose; + } + + my $foo = Foo->new; + my $blessed_foo = blessed $foo; + my %args = ( "for" => $foo ); + + my $exception = exception { + Moose::Util::MetaRole::apply_metaroles( %args ); + }; + + my $message = "When using Moose::Util::MetaRole, " + ."you must pass a Moose class name, role name, metaclass object, or metarole object." + ." You passed $foo, and we resolved this to a $blessed_foo object."; + + like( + $exception, + qr/\Q$message/, + "$foo is an object, not a class"); + #When using Moose::Util::MetaRole, you must pass a Moose class name, role name, metaclass object, or metarole object. You passed Foo=HASH(0x16adb58), and we resolved this to a Foo object. + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgPassedToMooseUtilMetaRole', + "$foo is an object, not a class"); + + is( + $exception->argument, + $foo, + "$foo is an object, not a class"); +} + +{ + my $array_ref = [1, 2, 3]; + my %args = ( "for" => $array_ref ); + + my $exception = exception { + Moose::Util::MetaRole::apply_metaroles( %args ); + }; + + my $message = "When using Moose::Util::MetaRole, " + ."you must pass a Moose class name, role name, metaclass object, or metarole object." + ." You passed $array_ref, and this did not resolve to a metaclass or metarole." + ." Maybe you need to call Moose->init_meta to initialize the metaclass first?"; + + like( + $exception, + qr/\Q$message/, + "an Array ref is passed to apply_metaroles"); + #When using Moose::Util::MetaRole, you must pass a Moose class name, role name, metaclass object, or metarole object. You passed ARRAY(0x21eb868), and this did not resolve to a metaclass or metarole. Maybe you need to call Moose->init_meta to initialize the metaclass first? + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgPassedToMooseUtilMetaRole', + "an Array ref is passed to apply_metaroles"); + + is( + $exception->argument, + $array_ref, + "an Array ref is passed to apply_metaroles"); +} + +{ + my %args = ( "for" => undef ); + + my $exception = exception { + Moose::Util::MetaRole::apply_metaroles( %args ); + }; + + my $message = "When using Moose::Util::MetaRole, " + ."you must pass a Moose class name, role name, metaclass object, or metarole object." + ." You passed undef, and this did not resolve to a metaclass or metarole." + ." Maybe you need to call Moose->init_meta to initialize the metaclass first?"; + + like( + $exception, + qr/\Q$message/, + "undef passed to apply_metaroles"); + #When using Moose::Util::MetaRole, you must pass a Moose class name, role name, metaclass object, or metarole object. You passed undef, and this did not resolve to a metaclass or metarole. Maybe you need to call Moose->init_meta to initialize the metaclass first? + + isa_ok( + $exception, + 'Moose::Exception::InvalidArgPassedToMooseUtilMetaRole', + "undef passed to apply_metaroles"); + + is( + $exception->argument, + undef, + "undef passed to apply_metaroles"); +} + +{ + { + package Foo::Role; + use Moose::Role; + } + + my %args = ('for' => "Foo::Role" ); + + my $exception = exception { + Moose::Util::MetaRole::apply_base_class_roles( %args ); + }; + + like( + $exception, + qr/\QYou can only apply base class roles to a Moose class, not a role./, + "Moose::Util::MetaRole::apply_base_class_roles expects a class for 'for'"); + + isa_ok( + $exception, + 'Moose::Exception::CannotApplyBaseClassRolesToRole', + "Moose::Util::MetaRole::apply_base_class_roles expects a class for 'for'"); + + is( + $exception->role_name, + 'Foo::Role', + "Moose::Util::MetaRole::apply_base_class_roles expects a class for 'for'"); +} + +done_testing; diff --git a/t/exceptions/moose-util-typeconstraints.t b/t/exceptions/moose-util-typeconstraints.t new file mode 100644 index 0000000..22ad7f2 --- /dev/null +++ b/t/exceptions/moose-util-typeconstraints.t @@ -0,0 +1,171 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +my $x = "123"; + +{ + my $default = [1, 2, 3]; + my $exception = exception { + match_on_type $x => ( 'Int' => + sub { "Action for Int"; } => + $default + ); + }; + + like( + $exception, + qr/\QDefault case must be a CODE ref, not $default/, + "an ArrayRef is passed as a default"); + #Default case must be a CODE ref, not ARRAY(0x14f6fc8) + + isa_ok( + $exception, + 'Moose::Exception::DefaultToMatchOnTypeMustBeCodeRef', + "an ArrayRef is passed as a default"); + + is( + $exception->default_action, + $default, + "an ArrayRef is passed as a default"); + + is( + $exception->to_match, + $x, + "an ArrayRef is passed as a default"); +} + +{ + my $exception = exception { + match_on_type $x => ( 'doesNotExist' => sub { "Action for Int"; } ); + }; + + like( + $exception, + qr/\QCannot find or parse the type 'doesNotExist'/, + "doesNotExist is not a valid type"); + + isa_ok( + $exception, + 'Moose::Exception::CannotFindTypeGivenToMatchOnType', + "doesNotExist is not a valid type"); + + is( + $exception->type, + "doesNotExist", + "doesNotExist is not a valid type"); + + is( + $exception->to_match, + $x, + "doesNotExist is not a valid type"); +} + +{ + my $action = [1, 2, 3]; + my $exception = exception { + match_on_type $x => ( Int => $action ); + }; + + like( + $exception, + qr/\QMatch action must be a CODE ref, not $action/, + "an ArrayRef is given as action"); + #Match action must be a CODE ref, not ARRAY(0x27a0748) + + isa_ok( + $exception, + 'Moose::Exception::MatchActionMustBeACodeRef', + "an ArrayRef is given as action"); + + is( + $exception->type_name, + "Int", + "an ArrayRef is given as action"); + + is( + $exception->to_match, + $x, + "an ArrayRef is given as action"); + + is( + $exception->action, + $action, + "an ArrayRef is given as action"); +} + +{ + my $exception = exception { + match_on_type $x => ( 'ArrayRef' => sub { "Action for Int"; } ); + }; + + like( + $exception, + qr/\QNo cases matched for $x/, + "$x is not an ArrayRef"); + #No cases matched for 123 + + isa_ok( + $exception, + 'Moose::Exception::NoCasesMatched', + "$x is not an ArrayRef"); + + is( + $exception->to_match, + $x, + "$x is not an ArrayRef"); +} + +{ + { + package TestType; + use Moose; + extends 'Moose::Meta::TypeConstraint'; + + sub name { + undef; + } + } + + my $tt = TestType->new; + my $exception = exception { + register_type_constraint( $tt ); + }; + + like( + $exception, + qr/can't register an unnamed type constraint/, + "name has been set to undef for TestType"); + + isa_ok( + $exception, + 'Moose::Exception::CannotRegisterUnnamedTypeConstraint', + "name has been set to undef for TestType"); +} + +{ + my $exception = exception { + union 'StrUndef', 'Str | Undef |'; + }; + + like( + $exception, + qr/\Q'Str | Undef |' didn't parse (parse-pos=11 and str-length=13)/, + "cannot parse 'Str| Undef |'"); + + isa_ok( + $exception, + 'Moose::Exception::CouldNotParseType', + "cannot parse 'Str| Undef |'"); + + is( + $exception->type, + 'Str | Undef |', + "cannot parse 'Str| Undef |'"); +} + +done_testing; diff --git a/t/exceptions/moose.t b/t/exceptions/moose.t new file mode 100644 index 0000000..fc5f0e5 --- /dev/null +++ b/t/exceptions/moose.t @@ -0,0 +1,173 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util 'find_meta'; + +# tests for extends without arguments +{ + my $exception = exception { + package SubClassNoSuperClass; + use Moose; + extends; + }; + + like( + $exception, + qr/Must derive at least one class/, + "extends requires at least one argument"); + + isa_ok( + $exception, + 'Moose::Exception::ExtendsMissingArgs', + "extends requires at least one argument"); +} + +{ + my $exception = exception { + use Moose; + Moose->init_meta; + }; + + like( + $exception, + qr/Cannot call init_meta without specifying a for_class/, + "for_class is not given"); + + isa_ok( + $exception, + "Moose::Exception::InitMetaRequiresClass", + "for_class is not given"); +} + +{ + my $exception = exception { + use Moose; + Moose->init_meta( (for_class => 'Foo2', metaclass => 'Foo2' )); + }; + + like( + $exception, + qr/\QThe Metaclass Foo2 must be loaded. (Perhaps you forgot to 'use Foo2'?)/, + "Foo2 is not loaded"); + + isa_ok( + $exception, + "Moose::Exception::MetaclassNotLoaded", + "Foo2 is not loaded"); + + is( + $exception->class_name, + "Foo2", + "Foo2 is not loaded"); +} + +{ + { + package Foo3; + use Moose::Role; + } + + my $exception = exception { + use Moose; + Moose->init_meta( (for_class => 'Foo3', metaclass => 'Foo3' )); + }; + + like( + $exception, + qr/\QThe Metaclass Foo3 must be a subclass of Moose::Meta::Class./, + "Foo3 is a Moose::Role"); + + isa_ok( + $exception, + "Moose::Exception::MetaclassMustBeASubclassOfMooseMetaClass", + "Foo3 is a Moose::Role"); + + is( + $exception->class_name, + "Foo3", + "Foo3 is a Moose::Role"); +} + +{ + { + package Foo3; + use Moose::Role; + } + + my $exception = exception { + use Moose; + Moose->init_meta( (for_class => 'Foo3' )); + }; + + my $foo3 = Foo3->meta; + + like( + $exception, + qr/\QFoo3 already has a metaclass, but it does not inherit Moose::Meta::Class ($foo3). You cannot make the same thing a role and a class. Remove either Moose or Moose::Role./, + "Foo3 is a Moose::Role"); + #Foo3 already has a metaclass, but it does not inherit Moose::Meta::Class (Moose::Meta::Role=HASH(0x29d3c78)). You cannot make the same thing a role and a class. Remove either Moose or Moose::Role. + + isa_ok( + $exception, + "Moose::Exception::MetaclassIsARoleNotASubclassOfGivenMetaclass", + "Foo3 is a Moose::Role"); + + is( + $exception->role_name, + "Foo3", + "Foo3 is a Moose::Role"); + + is( + find_meta($exception->role_name), + Foo3->meta, + "Foo3 is a Moose::Role"); + + is( + $exception->metaclass, + "Moose::Meta::Class", + "Foo3 is a Moose::Role"); +} + +{ + my $foo; + { + use Moose; + $foo = Class::MOP::Class->create("Foo4"); + } + + my $exception = exception { + use Moose; + Moose->init_meta( (for_class => 'Foo4' )); + }; + + like( + $exception, + qr/\QFoo4 already has a metaclass, but it does not inherit Moose::Meta::Class ($foo)./, + "Foo4 is a Class::MOP::Class, not a Moose::Meta::Class"); + #Foo4 already has a metaclass, but it does not inherit Moose::Meta::Class (Class::MOP::Class=HASH(0x278a4a0)). + + isa_ok( + $exception, + "Moose::Exception::MetaclassIsNotASubclassOfGivenMetaclass", + "Foo4 is a Class::MOP::Class, not a Moose::Meta::Class"); + + is( + $exception->class_name, + "Foo4", + "Foo4 is a Class::MOP::Class, not a Moose::Meta::Class"); + + is( + find_meta($exception->class_name), + $foo, + "Foo4 is a Class::MOP::Class, not a Moose::Meta::Class"); + + is( + $exception->metaclass, + "Moose::Meta::Class", + "Foo4 is a Class::MOP::Class, not a Moose::Meta::Class"); +} + +done_testing; diff --git a/t/exceptions/object.t b/t/exceptions/object.t new file mode 100644 index 0000000..71b78d4 --- /dev/null +++ b/t/exceptions/object.t @@ -0,0 +1,77 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +# tests for SingleParamsToNewMustBeHashRef +{ + { + package Foo; + use Moose; + } + + my $exception = exception { + Foo->new("hello") + }; + + like( + $exception, + qr/^\QSingle parameters to new() must be a HASH ref/, + "A single non-hashref arg to a constructor throws an error"); + + isa_ok( + $exception, + "Moose::Exception::SingleParamsToNewMustBeHashRef", + "A single non-hashref arg to a constructor throws an error"); +} + +# tests for DoesRequiresRoleName +{ + { + package Foo; + use Moose; + } + + my $foo = Foo->new; + + my $exception = exception { + $foo->does; + }; + + like( + $exception, + qr/^\QYou must supply a role name to does()/, + "Cannot call does() without a role name"); + + isa_ok( + $exception, + "Moose::Exception::DoesRequiresRoleName", + "Cannot call does() without a role name"); + + is( + $exception->class_name, + "Foo", + "Cannot call does() without a role name"); + + $exception = exception { + Foo->does; + }; + + like( + $exception, + qr/^\QYou must supply a role name to does()/, + "Cannot call does() without a role name"); + + isa_ok( + $exception, + "Moose::Exception::DoesRequiresRoleName", + "Cannot call does() without a role name"); + + is( + $exception->class_name, + "Foo", + "Cannot call does() without a role name"); +} + +done_testing; diff --git a/t/exceptions/overload.t b/t/exceptions/overload.t new file mode 100644 index 0000000..8d01e35 --- /dev/null +++ b/t/exceptions/overload.t @@ -0,0 +1,15 @@ +use strict; +use warnings; + +use Test::More; +use Moose::Exception; + +my $exception = Moose::Exception->new(message => 'barf!'); + +like($exception, qr/barf/, 'stringification for regex works'); + +ok($exception ne 'oh hai', 'direct string comparison works'); + +ok($exception, 'exception can be treated as a boolean'); + +done_testing; diff --git a/t/exceptions/rt-92818.t b/t/exceptions/rt-92818.t new file mode 100644 index 0000000..b504841 --- /dev/null +++ b/t/exceptions/rt-92818.t @@ -0,0 +1,45 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +# https://rt.cpan.org/Ticket/Display.html?id=92818 + +{ + package Parent; + use Moose; + has x => ( + is => 'rw', + required => 1, + ); +} + +{ + my $e = exception { my $obj = Parent->new }; + ok( + $e->isa('Moose::Exception::AttributeIsRequired'), + 'got the right exception', + ) + or note 'got exception ', ref($e), ': ', $e->message; +} + +{ + package Child; + use Moose; + extends 'Parent'; +} + +# the exception produced should be AttributeIsRequired, however +# AttributeIsRequired was throwing the exception ClassNamesDoNotMatch. + +{ + my $e = exception { my $obj = Child->new }; + ok( + $e->isa('Moose::Exception::AttributeIsRequired'), + 'got the right exception', + ) + or note 'got exception ', ref($e), ': ', $e->message; +} + +done_testing; diff --git a/t/exceptions/rt-94795.t b/t/exceptions/rt-94795.t new file mode 100644 index 0000000..2742407 --- /dev/null +++ b/t/exceptions/rt-94795.t @@ -0,0 +1,34 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +# https://rt.cpan.org/Ticket/Display.html?id=94795 + +# the exception produced should be AttributeIsRequired, however +# AttributeIsRequired was throwing the exception ClassNamesDoNotMatch. + +{ + package AAA; + use Moose; + has my_attr => ( + is => 'ro', + required => 1, + ); +} + +{ + package BBB; + use Moose; + extends qw/AAA/; +} + +my $e = exception { BBB->new }; +ok( + $e->isa('Moose::Exception::AttributeIsRequired'), + 'got the right exception', +) +or note 'got exception ', ref($e), ': ', $e->message; + +done_testing; diff --git a/t/exceptions/stringify.t b/t/exceptions/stringify.t new file mode 100644 index 0000000..7a7f0c4 --- /dev/null +++ b/t/exceptions/stringify.t @@ -0,0 +1,111 @@ +use strict; +use warnings; + +use Test::More; +use Try::Tiny; + +{ + my $e; + { + package Foo; + use Moose; + use Try::Tiny; + + try { + has '+foo' => ( is => 'ro' ); + } + catch { + $e = $_; + }; + } + + ok( $e, q{got an exception from a bad has '+foo' declaration} ); + like( + $e->as_string, + qr/\QCould not find an attribute by the name of 'foo' to inherit from in Foo/, + 'stringification includes the error message' + ); + like( + $e->as_string, + qr/\s+Moose::has/, + 'stringification includes the call to Moose::has' + ); + unlike( + $e->as_string, + qr/Moose::Meta/, + 'stringification does not include internal calls to Moose meta classes' + ); + + try { + Foo->meta->clone_object( [] ); + } + catch { + $e = $_; + }; + + like( + $e->as_string, + qr/Class::MOP::Class::clone_object/, + 'exception include first Class::MOP::Class frame' + ); + unlike( + $e->as_string, + qr/Class::MOP::Mixin::_throw_exception/, + 'exception does not include internal calls toClass::MOP::Class meta classes' + ); +} + +local $ENV{MOOSE_FULL_EXCEPTION} = 1; +{ + my $e; + { + package Bar; + use Moose; + use Try::Tiny; + + try { + has '+foo' => ( is => 'ro' ); + } + catch { + $e = $_; + }; + } + + ok( $e, q{got an exception from a bad has '+foo' declaration} ); + like( + $e->as_string, + qr/\QCould not find an attribute by the name of 'foo' to inherit from in Bar/, + 'stringification includes the error message' + ); + like( + $e->as_string, + qr/\s+Moose::has/, + 'stringification includes the call to Moose::has' + ); + like( + $e->as_string, + qr/Moose::Meta/, + 'stringification includes internal calls to Moose meta classes when MOOSE_FULL_EXCEPTION env var is true' + ); + + + try { + Foo->meta->clone_object( [] ); + } + catch { + $e = $_; + }; + + like( + $e->as_string, + qr/Class::MOP::Class::clone_object/, + 'exception include first Class::MOP::Class frame' + ); + like( + $e->as_string, + qr/Class::MOP::Mixin::_throw_exception/, + 'exception includes internal calls toClass::MOP::Class meta classes when MOOSE_FULL_EXCEPTION env var is true' + ); +} + +done_testing; diff --git a/t/exceptions/traits.t b/t/exceptions/traits.t new file mode 100644 index 0000000..2d2fad0 --- /dev/null +++ b/t/exceptions/traits.t @@ -0,0 +1,34 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +# this test taken from MooseX::ABC t/immutable.t, where it broke with Moose 2.1207 + +{ + package ABC; + use Moose::Role; + around new => sub { + my $orig = shift; + my $class = shift; + my $meta = Class::MOP::class_of($class); + $meta->throw_error("$class is abstract, it cannot be instantiated"); + $class->$orig(@_); + }; +} +{ + package MyApp::Base; + use Moose; + with 'ABC'; + __PACKAGE__->meta->make_immutable(inline_constructor => 0); +} + + +like( + exception { MyApp::Base->new }, + qr/MyApp::Base is abstract, it cannot be instantiated/, + 'instantiating abstract classes fails', +); + +done_testing; diff --git a/t/exceptions/typeconstraints.t b/t/exceptions/typeconstraints.t new file mode 100644 index 0000000..6c1e4e6 --- /dev/null +++ b/t/exceptions/typeconstraints.t @@ -0,0 +1,293 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +# tests for type/subtype name contain invalid characters +{ + my $exception = exception { + subtype 'Foo-Baz' => as 'Item' + }; + + like( + $exception, + qr/contains invalid characters/, + "Type names cannot contain a dash (via subtype sugar)"); + + isa_ok( + $exception, + "Moose::Exception::InvalidNameForType", + "Type names cannot contain a dash (via subtype sugar)"); +} + +{ + my $exception = exception { + Moose::Util::TypeConstraints::create_type_constraint_union(); + }; + + like( + $exception, + qr/You must pass in at least 2 type names to make a union/, + "Moose::Util::TypeConstraints::create_type_constraint_union takes atleast two arguments"); + + isa_ok( + $exception, + "Moose::Exception::UnionTakesAtleastTwoTypeNames", + "Moose::Util::TypeConstraints::create_type_constraint_union takes atleast two arguments"); +} + +{ + my $exception = exception { + Moose::Util::TypeConstraints::create_type_constraint_union('foo','bar'); + }; + + like( + $exception, + qr/\QCould not locate type constraint (foo) for the union/, + "invalid typeconstraint given to Moose::Util::TypeConstraints::create_type_constraint_union"); + + isa_ok( + $exception, + "Moose::Exception::CouldNotLocateTypeConstraintForUnion", + "invalid typeconstraint given to Moose::Util::TypeConstraints::create_type_constraint_union"); + + is( + $exception->type_name, + 'foo', + "invalid typeconstraint given to Moose::Util::TypeConstraints::create_type_constraint_union"); +} + +{ + my $exception = exception { + Moose::Util::TypeConstraints::create_parameterized_type_constraint("Foo"); + }; + + like( + $exception, + qr/\QCould not parse type name (Foo) correctly/, + "'Foo' is not a valid type constraint name"); + + isa_ok( + $exception, + "Moose::Exception::InvalidTypeGivenToCreateParameterizedTypeConstraint", + "'Foo' is not a valid type constraint name"); +} + +{ + my $exception = exception { + Moose::Util::TypeConstraints::create_parameterized_type_constraint("Foo[Int]"); + }; + + like( + $exception, + qr/\QCould not locate the base type (Foo)/, + "'Foo' is not a valid base type constraint name"); + + isa_ok( + $exception, + "Moose::Exception::InvalidBaseTypeGivenToCreateParameterizedTypeConstraint", + "'Foo' is not a valid base type constraint name"); +} + +{ + { + package Foo1; + use Moose::Role; + } + + my $exception = exception { + Moose::Util::TypeConstraints::class_type("Foo1"); + }; + + like( + $exception, + qr/\QThe type constraint 'Foo1' has already been created in Moose::Role and cannot be created again in main/, + "there is an already defined role of name 'Foo1'"); + + isa_ok( + $exception, + "Moose::Exception::TypeConstraintIsAlreadyCreated", + "there is an already defined role of name 'Foo1'"); + + is( + $exception->type_name, + 'Foo1', + "there is an already defined role of name 'Foo1'"); + + is( + (find_type_constraint($exception->type_name))->_package_defined_in, + 'Moose::Role', + "there is an already defined role of name 'Foo1'"); + + is( + $exception->package_defined_in, + 'main', + "there is an already defined role of name 'Foo1'"); +} + +{ + { + package Foo2; + use Moose; + } + + my $exception = exception { + Moose::Util::TypeConstraints::role_type("Foo2"); + }; + + like( + $exception, + qr/\QThe type constraint 'Foo2' has already been created in Moose and cannot be created again in main/, + "there is an already defined class of name 'Foo2'"); + + isa_ok( + $exception, + "Moose::Exception::TypeConstraintIsAlreadyCreated", + "there is an already defined class of name 'Foo2'"); + + is( + $exception->type_name, + 'Foo2', + "there is an already defined class of name 'Foo2'"); + + is( + (find_type_constraint($exception->type_name))->_package_defined_in, + 'Moose', + "there is an already defined class of name 'Foo2'"); + + is( + $exception->package_defined_in, + 'main', + "there is an already defined class of name 'Foo2'"); +} + +{ + my $exception = exception { + subtype 'Foo'; + }; + + like( + $exception, + qr/A subtype cannot consist solely of a name, it must have a parent/, + "no parent given to subtype"); + + isa_ok( + $exception, + "Moose::Exception::NoParentGivenToSubtype", + "no parent given to subtype"); + + is( + $exception->name, + 'Foo', + "no parent given to subtype"); +} + +{ + my $exception = exception { + enum [1,2,3], "foo"; + }; + + like( + $exception, + qr/\Qenum called with an array reference and additional arguments. Did you mean to parenthesize the enum call's parameters?/, + "enum expects either a name & an array or only an array"); + + isa_ok( + $exception, + "Moose::Exception::EnumCalledWithAnArrayRefAndAdditionalArgs", + "enum expects either a name & an array or only an array"); +} + +{ + my $exception = exception { + union [1,2,3], "foo"; + }; + + like( + $exception, + qr/union called with an array reference and additional arguments/, + "union expects either a name & an array or only an array"); + + isa_ok( + $exception, + "Moose::Exception::UnionCalledWithAnArrayRefAndAdditionalArgs", + "union expects either a name & an array or only an array"); +} + +{ + { + package Foo3; + use Moose; + } + + my $exception = exception { + Moose::Util::TypeConstraints::type("Foo3"); + }; + + like( + $exception, + qr/\QThe type constraint 'Foo3' has already been created in Moose and cannot be created again in main/, + "there is an already defined class of name 'Foo3'"); + + isa_ok( + $exception, + "Moose::Exception::TypeConstraintIsAlreadyCreated", + "there is an already defined class of name 'Foo3'"); + + is( + $exception->type_name, + 'Foo3', + "there is an already defined class of name 'Foo3'"); + + is( + find_type_constraint($exception->type_name)->_package_defined_in, + 'Moose', + "there is an already defined class of name 'Foo3'"); + + is( + $exception->package_defined_in, + 'main', + "there is an already defined class of name 'Foo3'"); +} + +{ + my $exception = exception { + Moose::Util::TypeConstraints::coerce "Foo"; + }; + + like( + $exception, + qr/Cannot find type 'Foo', perhaps you forgot to load it/, + "'Foo' is not a valid type"); + + isa_ok( + $exception, + "Moose::Exception::CannotFindType", + "'Foo' is not a valid type"); +} + +{ + my $exception = exception { + Moose::Util::TypeConstraints::add_parameterizable_type "Foo"; + }; + + like( + $exception, + qr/Type must be a Moose::Meta::TypeConstraint::Parameterizable not Foo/, + "'Foo' is not a parameterizable type"); + + isa_ok( + $exception, + "Moose::Exception::AddParameterizableTypeTakesParameterizableType", + "'Foo' is not a parameterizable type"); + + is( + $exception->type_name, + "Foo", + "'Foo' is not a parameterizable type"); +} + +done_testing; diff --git a/t/exceptions/util.t b/t/exceptions/util.t new file mode 100644 index 0000000..551e773 --- /dev/null +++ b/t/exceptions/util.t @@ -0,0 +1,188 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util qw/apply_all_roles add_method_modifier/; + +{ + { + package TestClass; + use Moose; + } + + my $test_object = TestClass->new; + + my $exception = exception { + apply_all_roles( $test_object ); + }; + + like( + $exception, + qr/\QMust specify at least one role to apply to $test_object/, + "apply_all_roles takes an object and a role to apply"); + #Must specify at least one role to apply to TestClass=HASH(0x2bee290) + + isa_ok( + $exception, + "Moose::Exception::MustSpecifyAtleastOneRoleToApplicant", + "apply_all_roles takes an object and a role to apply"); + + my $test_class = TestClass->meta; + + $exception = exception { + apply_all_roles( $test_class ); + }; + + like( + $exception, + qr/\QMust specify at least one role to apply to $test_class/, + "apply_all_roles takes a class and a role to apply"); + #Must specify at least one role to apply to Moose::Meta::Class=HASH(0x1a1f818) + + isa_ok( + $exception, + "Moose::Exception::MustSpecifyAtleastOneRoleToApplicant", + "apply_all_roles takes a class and a role to apply"); + + { + package TestRole; + use Moose::Role; + } + + my $test_role = TestRole->meta; + + $exception = exception { + apply_all_roles( $test_role ); + }; + + like( + $exception, + qr/\QMust specify at least one role to apply to $test_role/, + "apply_all_roles takes a role and a role to apply"); + #Must specify at least one role to apply to Moose::Meta::Role=HASH(0x1f22d40) + + isa_ok( + $exception, + "Moose::Exception::MustSpecifyAtleastOneRoleToApplicant", + "apply_all_roles takes a role and a role to apply"); +} + +# tests for class consuming a class, instead of role +{ + my $exception = exception { + package ClassConsumingClass; + use Moose; + use Module::Runtime; + with 'Module::Runtime'; + }; + + like( + $exception, + qr/You can only consume roles, Module::Runtime is not a Moose role/, + "You can't consume a class"); + + isa_ok( + $exception, + 'Moose::Exception::CanOnlyConsumeRole', + "You can't consume a class"); + + $exception = exception { + package foo; + use Moose; + use Module::Runtime; + with 'Not::A::Real::Package'; + }; + + like( + $exception, + qr!Can't locate Not/A/Real/Package\.pm in \@INC!, + "You can't consume a class which doesn't exist"); + + $exception = exception { + package foo; + use Moose; + use Module::Runtime; + with sub {}; + }; + + like( + $exception, + qr/argument is not a module name/, + "You can only consume a module"); +} + +{ + { + package Foo; + use Moose; + } + + my $exception = exception { + add_method_modifier(Foo->meta, "before", [{}, sub {"before";}]); + }; + + like( + $exception, + qr/\QMethods passed to before must be provided as a list, arrayref or regex, not HASH/, + "we gave a HashRef to before"); + + isa_ok( + $exception, + "Moose::Exception::IllegalMethodTypeToAddMethodModifier", + "we gave a HashRef to before"); + + is( + ref( $exception->params->[0] ), + "HASH", + "we gave a HashRef to before"); + + is( + $exception->modifier_name, + 'before', + "we gave a HashRef to before"); + + is( + $exception->class_or_object->name, + "Foo", + "we gave a HashRef to before"); +} + +{ + my $exception = exception { + package My::Class; + use Moose; + has 'attr' => ( + is => 'ro', + traits => [qw( Xyz )], + ); + }; + + like( + $exception, + qr/^Can't locate Moose::Meta::Attribute::Custom::Trait::Xyz or Xyz in \@INC \(\@INC contains:/, + "Cannot locate 'Xyz'"); + + isa_ok( + $exception, + "Moose::Exception::CannotLocatePackageInINC", + "Cannot locate 'Xyz'"); + + is( + $exception->type, + "Attribute", + "Cannot locate 'Xyz'"); + + is( + $exception->possible_packages, + 'Moose::Meta::Attribute::Custom::Trait::Xyz or Xyz', + "Cannot locate 'Xyz'"); + + is( + $exception->metaclass_name, + "Xyz", + "Cannot locate 'Xyz'"); +} + +done_testing; diff --git a/t/immutable/apply_roles_to_immutable.t b/t/immutable/apply_roles_to_immutable.t new file mode 100644 index 0000000..206cd16 --- /dev/null +++ b/t/immutable/apply_roles_to_immutable.t @@ -0,0 +1,38 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package My::Role; + use Moose::Role; + + around 'baz' => sub { + my $next = shift; + 'My::Role::baz(' . $next->(@_) . ')'; + }; +} + +{ + package Foo; + use Moose; + + sub baz { 'Foo::baz' } + + __PACKAGE__->meta->make_immutable(debug => 0); +} + +my $foo = Foo->new; +isa_ok($foo, 'Foo'); + +is($foo->baz, 'Foo::baz', '... got the right value'); + +is( exception { + My::Role->meta->apply($foo) +}, undef, '... successfully applied the role to immutable instance' ); + +is($foo->baz, 'My::Role::baz(Foo::baz)', '... got the right value'); + +done_testing; diff --git a/t/immutable/buildargs.t b/t/immutable/buildargs.t new file mode 100644 index 0000000..338e520 --- /dev/null +++ b/t/immutable/buildargs.t @@ -0,0 +1,45 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Foo; + use Moose; + + has bar => ( is => "rw" ); + has baz => ( is => "rw" ); + + sub BUILDARGS { + my ( $self, @args ) = @_; + unshift @args, "bar" if @args % 2 == 1; + return {@args}; + } + + __PACKAGE__->meta->make_immutable; + + package Bar; + use Moose; + + extends qw(Foo); + + __PACKAGE__->meta->make_immutable; +} + +foreach my $class (qw(Foo Bar)) { + is( $class->new->bar, undef, "no args" ); + is( $class->new( bar => 42 )->bar, 42, "normal args" ); + is( $class->new( 37 )->bar, 37, "single arg" ); + { + my $o = $class->new(bar => 42, baz => 47); + is($o->bar, 42, '... got the right bar'); + is($o->baz, 47, '... got the right bar'); + } + { + my $o = $class->new(42, baz => 47); + is($o->bar, 42, '... got the right bar'); + is($o->baz, 47, '... got the right bar'); + } +} + +done_testing; diff --git a/t/immutable/constructor_is_not_moose.t b/t/immutable/constructor_is_not_moose.t new file mode 100644 index 0000000..43e9ec9 --- /dev/null +++ b/t/immutable/constructor_is_not_moose.t @@ -0,0 +1,100 @@ +use strict; +use warnings; + +use Test::More; +use Test::Requires 'Test::Output'; # skip all if not installed + +{ + package NotMoose; + + sub new { + my $class = shift; + + return bless { not_moose => 1 }, $class; + } +} + +{ + package Foo; + use Moose; + + extends 'NotMoose'; + + ::stderr_like( + sub { Foo->meta->make_immutable }, + qr/\QNot inlining 'new' for Foo since it is not inheriting the default Moose::Object::new\E\s+\QIf you are certain you don't need to inline your constructor, specify inline_constructor => 0 in your call to Foo->meta->make_immutable/, + 'got a warning that Foo may not have an inlined constructor' + ); +} + +is( + Foo->meta->find_method_by_name('new')->body, + NotMoose->can('new'), + 'Foo->new is inherited from NotMoose' +); + +{ + package Bar; + use Moose; + + extends 'NotMoose'; + + ::stderr_is( + sub { Bar->meta->make_immutable( replace_constructor => 1 ) }, + q{}, + 'no warning when replace_constructor is true' + ); +} + +is( + Bar->meta->find_method_by_name('new')->package_name, + 'Bar', + 'Bar->new is inlined, and not inherited from NotMoose' +); + +{ + package Baz; + use Moose; + + Baz->meta->make_immutable; +} + +{ + package Quux; + use Moose; + + extends 'Baz'; + + ::stderr_is( + sub { Quux->meta->make_immutable }, + q{}, + 'no warning when inheriting from a class that has already made itself immutable' + ); +} + +{ + package My::Constructor; + use parent 'Moose::Meta::Method::Constructor'; +} + +{ + package CustomCons; + use Moose; + + CustomCons->meta->make_immutable( constructor_class => 'My::Constructor' ); +} + +{ + package Subclass; + use Moose; + + extends 'CustomCons'; + + ::stderr_is( + sub { Subclass->meta->make_immutable }, + q{}, + 'no warning when inheriting from a class that has already made itself immutable' + ); +} + +done_testing; diff --git a/t/immutable/constructor_is_wrapped.t b/t/immutable/constructor_is_wrapped.t new file mode 100644 index 0000000..820d7e9 --- /dev/null +++ b/t/immutable/constructor_is_wrapped.t @@ -0,0 +1,27 @@ +use strict; +use warnings; + +use Test::More; +use Test::Requires 'Test::Output'; # skip all if not installed + +{ + package ModdedNew; + use Moose; + + before 'new' => sub { }; +} + +{ + package Foo; + use Moose; + + extends 'ModdedNew'; + + ::stderr_like( + sub { Foo->meta->make_immutable }, + qr/\QNot inlining 'new' for Foo since it has method modifiers which would be lost if it were inlined/, + 'got a warning that Foo may not have an inlined constructor' + ); +} + +done_testing; diff --git a/t/immutable/default_values.t b/t/immutable/default_values.t new file mode 100644 index 0000000..81c57f7 --- /dev/null +++ b/t/immutable/default_values.t @@ -0,0 +1,79 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + + package Foo; + use Moose; + + has 'foo' => ( is => 'rw', default => q{'} ); + has 'bar' => ( is => 'rw', default => q{\\} ); + has 'baz' => ( is => 'rw', default => q{"} ); + has 'buz' => ( is => 'rw', default => q{"'\\} ); + has 'faz' => ( is => 'rw', default => qq{\0} ); + + ::is( ::exception { __PACKAGE__->meta->make_immutable }, undef, 'no errors making a package immutable when it has default values that could break quoting' ); +} + +my $foo = Foo->new; +is( $foo->foo, q{'}, + 'default value for foo attr' ); +is( $foo->bar, q{\\}, + 'default value for bar attr' ); +is( $foo->baz, q{"}, + 'default value for baz attr' ); +is( $foo->buz, q{"'\\}, + 'default value for buz attr' ); +is( $foo->faz, qq{\0}, + 'default value for faz attr' ); + + +# Lazy attrs were never broken, but it doesn't hurt to test that they +# won't be broken by any future changes. +# Also make sure that attributes stay lazy even after being immutable + +{ + + package Bar; + use Moose; + + has 'foo' => ( is => 'rw', default => q{'}, lazy => 1 ); + has 'bar' => ( is => 'rw', default => q{\\}, lazy => 1 ); + has 'baz' => ( is => 'rw', default => q{"}, lazy => 1 ); + has 'buz' => ( is => 'rw', default => q{"'\\}, lazy => 1 ); + has 'faz' => ( is => 'rw', default => qq{\0}, lazy => 1 ); + + { + my $bar = Bar->new; + ::ok(!$bar->meta->get_attribute($_)->has_value($bar), + "Attribute $_ has no value") + for qw(foo bar baz buz faz); + } + + ::is( ::exception { __PACKAGE__->meta->make_immutable }, undef, 'no errors making a package immutable when it has lazy default values that could break quoting' ); + + { + my $bar = Bar->new; + ::ok(!$bar->meta->get_attribute($_)->has_value($bar), + "Attribute $_ has no value (immutable)") + for(qw(foo bar baz buz faz)); + } + +} + +my $bar = Bar->new; +is( $bar->foo, q{'}, + 'default value for foo attr' ); +is( $bar->bar, q{\\}, + 'default value for bar attr' ); +is( $bar->baz, q{"}, + 'default value for baz attr' ); +is( $bar->buz, q{"'\\}, + 'default value for buz attr' ); +is( $bar->faz, qq{\0}, + 'default value for faz attr' ); + +done_testing; diff --git a/t/immutable/definition_context.t b/t/immutable/definition_context.t new file mode 100644 index 0000000..71482df --- /dev/null +++ b/t/immutable/definition_context.t @@ -0,0 +1,82 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +{ + use Moose::Util::TypeConstraints; + use Carp 'confess'; + subtype 'Death', as 'Int', where { $_ == 1 }; + coerce 'Death', from 'Any', via { confess }; +} + +{ + my ($attr_foo_line, $attr_bar_line, $ctor_line); + { + package Foo; + use Moose; + + has foo => ( + is => 'rw', + isa => 'Death', + coerce => 1, + ); + $attr_foo_line = __LINE__ - 5; + + has bar => ( + accessor => 'baz', + isa => 'Death', + coerce => 1, + ); + $attr_bar_line = __LINE__ - 5; + + __PACKAGE__->meta->make_immutable; + $ctor_line = __LINE__ - 1; + } + + like( + exception { Foo->new(foo => 2) }, + qr/\Qcalled at constructor Foo::new (defined at $0 line $ctor_line)\E/, + "got definition context for the constructor" + ); + + like( + exception { my $f = Foo->new(foo => 1); $f->foo(2) }, + qr/\Qcalled at accessor Foo::foo (defined at $0 line $attr_foo_line)\E/, + "got definition context for the accessor" + ); + + like( + exception { my $f = Foo->new(foo => 1); $f->baz(2) }, + qr/\Qcalled at accessor Foo::baz of attribute bar (defined at $0 line $attr_bar_line)\E/, + "got definition context for the accessor" + ); +} + +{ + my ($dtor_line); + { + package Bar; + use Moose; + + # just dying here won't work, because perl's exception handling is + # terrible + sub DEMOLISH { try { confess } catch { warn $_ } } + + __PACKAGE__->meta->make_immutable; + $dtor_line = __LINE__ - 1; + } + + { + my $warning = ''; + local $SIG{__WARN__} = sub { $warning .= $_[0] }; + { Bar->new } + like( + $warning, + qr/\Qcalled at destructor Bar::DESTROY (defined at $0 line $dtor_line)\E/, + "got definition context for the destructor" + ); + } +} + +done_testing; diff --git a/t/immutable/immutable_constructor_error.t b/t/immutable/immutable_constructor_error.t new file mode 100644 index 0000000..cb22171 --- /dev/null +++ b/t/immutable/immutable_constructor_error.t @@ -0,0 +1,30 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +=pod + +This tests to make sure that we provide the same error messages from +an immutable constructor as is provided by a non-immutable +constructor. + +=cut + +{ + package Foo; + use Moose; + + has 'foo' => (is => 'rw', isa => 'Int'); + + Foo->meta->make_immutable(debug => 0); +} + +my $scalar = 1; +like( exception { Foo->new($scalar) }, qr/\QSingle parameters to new() must be a HASH ref/, 'Non-ref provided to immutable constructor gives useful error message' ); +like( exception { Foo->new(\$scalar) }, qr/\QSingle parameters to new() must be a HASH ref/, 'Scalar ref provided to immutable constructor gives useful error message' ); +like( exception { Foo->new(undef) }, qr/\QSingle parameters to new() must be a HASH ref/, 'undef provided to immutable constructor gives useful error message' ); + +done_testing; diff --git a/t/immutable/immutable_destroy.t b/t/immutable/immutable_destroy.t new file mode 100644 index 0000000..8dfc3d3 --- /dev/null +++ b/t/immutable/immutable_destroy.t @@ -0,0 +1,21 @@ +use strict; +use warnings; +use Test::More; + +{ + package FooBar; + use Moose; + + has 'name' => ( is => 'ro' ); + + sub DESTROY { shift->name } + + local $SIG{__WARN__} = sub {}; + __PACKAGE__->meta->make_immutable; +} + +my $f = FooBar->new( name => 'SUSAN' ); + +is( $f->DESTROY, 'SUSAN', 'Did moose overload DESTROY?' ); + +done_testing; diff --git a/t/immutable/immutable_meta_class.t b/t/immutable/immutable_meta_class.t new file mode 100644 index 0000000..3c52d92 --- /dev/null +++ b/t/immutable/immutable_meta_class.t @@ -0,0 +1,25 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package My::Meta; + + use Moose; + + extends 'Moose::Meta::Class'; + + has 'meta_size' => ( + is => 'rw', + isa => 'Int', + ); +} + +is( exception { + My::Meta->meta()->make_immutable(debug => 0) +}, undef, '... can make a meta class immutable' ); + +done_testing; diff --git a/t/immutable/immutable_metaclass_with_traits.t b/t/immutable/immutable_metaclass_with_traits.t new file mode 100644 index 0000000..466a7c0 --- /dev/null +++ b/t/immutable/immutable_metaclass_with_traits.t @@ -0,0 +1,36 @@ +use strict; +use warnings; +use Test::More; + +{ + package FooTrait; + use Moose::Role; +} +{ + package Foo; + use Moose -traits => ['FooTrait']; +} + +is(Class::MOP::class_of('Foo'), Foo->meta, + "class_of and ->meta are the same on Foo"); +my $meta = Foo->meta; +is(Class::MOP::class_of($meta), $meta->meta, + "class_of and ->meta are the same on Foo's metaclass"); +isa_ok(Class::MOP::class_of($meta), 'Moose::Meta::Class'); +isa_ok($meta->meta, 'Moose::Meta::Class'); +ok($meta->is_mutable, "class is mutable"); +ok(Class::MOP::class_of($meta)->is_mutable, "metaclass is mutable"); +ok($meta->meta->does_role('FooTrait'), "does the trait"); +Foo->meta->make_immutable; +is(Class::MOP::class_of('Foo'), Foo->meta, + "class_of and ->meta are the same on Foo (immutable)"); +$meta = Foo->meta; +isa_ok($meta->meta, 'Moose::Meta::Class'); +ok($meta->is_immutable, "class is immutable"); +ok($meta->meta->is_immutable, "metaclass is immutable (immutable class)"); +is(Class::MOP::class_of($meta), $meta->meta, + "class_of and ->meta are the same on Foo's metaclass (immutable)"); +isa_ok(Class::MOP::class_of($meta), 'Moose::Meta::Class'); +ok($meta->meta->does_role('FooTrait'), "still does the trait after immutable"); + +done_testing; diff --git a/t/immutable/immutable_moose.t b/t/immutable/immutable_moose.t new file mode 100644 index 0000000..d77ea37 --- /dev/null +++ b/t/immutable/immutable_moose.t @@ -0,0 +1,84 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role; + + +{ + package FooRole; + our $VERSION = '0.01'; + sub foo {'FooRole::foo'} +} + +{ + package Foo; + use Moose; + + #two checks because the inlined methods are different when + #there is a TC present. + has 'foos' => ( is => 'ro', lazy_build => 1 ); + has 'bars' => ( isa => 'Str', is => 'ro', lazy_build => 1 ); + has 'bazes' => ( isa => 'Str', is => 'ro', builder => '_build_bazes' ); + sub _build_foos {"many foos"} + sub _build_bars {"many bars"} + sub _build_bazes {"many bazes"} +} + +{ + my $foo_role = Moose::Meta::Role->initialize('FooRole'); + my $meta = Foo->meta; + + is( exception { Foo->new }, undef, "lazy_build works" ); + is( Foo->new->foos, 'many foos', + "correct value for 'foos' before inlining constructor" ); + is( Foo->new->bars, 'many bars', + "correct value for 'bars' before inlining constructor" ); + is( Foo->new->bazes, 'many bazes', + "correct value for 'bazes' before inlining constructor" ); + is( exception { $meta->make_immutable }, undef, "Foo is imutable" ); + is( exception { $meta->identifier }, undef, "->identifier on metaclass lives" ); + isnt( exception { $meta->add_role($foo_role) }, undef, "Add Role is locked" ); + is( exception { Foo->new }, undef, "Inlined constructor works with lazy_build" ); + is( Foo->new->foos, 'many foos', + "correct value for 'foos' after inlining constructor" ); + is( Foo->new->bars, 'many bars', + "correct value for 'bars' after inlining constructor" ); + is( Foo->new->bazes, 'many bazes', + "correct value for 'bazes' after inlining constructor" ); + is( exception { $meta->make_mutable }, undef, "Foo is mutable" ); + is( exception { $meta->add_role($foo_role) }, undef, "Add Role is unlocked" ); + +} + +{ + package Bar; + + use Moose; + + sub BUILD { 'bar' } +} + +{ + package Baz; + + use Moose; + + extends 'Bar'; + + sub BUILD { 'baz' } +} + +is( exception { Bar->meta->make_immutable }, undef, 'Immutable meta with single BUILD' ); + +is( exception { Baz->meta->make_immutable }, undef, 'Immutable meta with multiple BUILDs' ); + +=pod + +Nothing here yet, but soon :) + +=cut + +done_testing; diff --git a/t/immutable/immutable_roundtrip.t b/t/immutable/immutable_roundtrip.t new file mode 100644 index 0000000..2f1bceb --- /dev/null +++ b/t/immutable/immutable_roundtrip.t @@ -0,0 +1,33 @@ +use strict; +use warnings; + +use Test::More; +use Test::Requires 'Test::Output'; # skip all if not installed + +{ + package Foo; + use Moose; + __PACKAGE__->meta->make_immutable; +} + +{ + package Bar; + use Moose; + + extends 'Foo'; + + __PACKAGE__->meta->make_immutable; + __PACKAGE__->meta->make_mutable; + + + # This actually is testing for a bug in Class::MOP that cause + # Moose::Meta::Method::Constructor to spit out a warning when it + # shouldn't have done so. The bug was fixed in CMOP 0.75. + ::stderr_unlike( + sub { Bar->meta->make_immutable }, + qr/Not inlining a constructor/, + 'no warning that Bar may not have an inlined constructor' + ); +} + +done_testing; diff --git a/t/immutable/immutable_trigger_from_constructor.t b/t/immutable/immutable_trigger_from_constructor.t new file mode 100644 index 0000000..799cecc --- /dev/null +++ b/t/immutable/immutable_trigger_from_constructor.t @@ -0,0 +1,36 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package AClass; + + use Moose; + + has 'foo' => (is => 'rw', isa => 'Maybe[Str]', trigger => sub { + die "Pulling the Foo trigger\n" + }); + + has 'bar' => (is => 'rw', isa => 'Maybe[Str]'); + + has 'baz' => (is => 'rw', isa => 'Maybe[Str]', trigger => sub { + die "Pulling the Baz trigger\n" + }); + + __PACKAGE__->meta->make_immutable; #(debug => 1); + + no Moose; +} + +eval { AClass->new(foo => 'bar') }; +like ($@, qr/^Pulling the Foo trigger/, "trigger from immutable constructor"); + +eval { AClass->new(baz => 'bar') }; +like ($@, qr/^Pulling the Baz trigger/, "trigger from immutable constructor"); + +is( exception { AClass->new(bar => 'bar') }, undef, '... no triggers called' ); + +done_testing; diff --git a/t/immutable/inline_close_over.t b/t/immutable/inline_close_over.t new file mode 100644 index 0000000..3b01504 --- /dev/null +++ b/t/immutable/inline_close_over.t @@ -0,0 +1,361 @@ +use strict; +use warnings; + +use Test::More; +use Test::Requires qw(Data::Visitor PadWalker); + +use Class::Load 'load_class'; +use Try::Tiny; + +my $can_partialdump = try { + load_class('Devel::PartialDump', { -version => 0.14 }); 1; +}; + +{ + package Test::Visitor; + use Moose; + use Moose::Util::TypeConstraints; + extends 'Data::Visitor'; + + has closed_over => ( + traits => ['Array'], + isa => 'ArrayRef', + default => sub { [] }, + handles => { + add_closed_over => 'push', + closed_over => 'elements', + pass => 'is_empty', + }, + ); + + before visit_code => sub { + my $self = shift; + my ($code) = @_; + my $closed_over = PadWalker::closed_over($code); + $self->visit_ref($closed_over); + }; + + after visit => sub { + my $self = shift; + my ($thing) = @_; + + $self->add_closed_over($thing) + unless $self->_is_okay_to_close_over($thing); + }; + + sub _is_okay_to_close_over { + my $self = shift; + my ($thing) = @_; + + match_on_type $thing => ( + 'RegexpRef' => sub { 1 }, + 'Object' => sub { 0 }, + 'GlobRef' => sub { 0 }, + 'FileHandle' => sub { 0 }, + 'Any' => sub { 1 }, + ); + } +} + +sub close_over_ok { + local $Test::Builder::Level = $Test::Builder::Level + 1; + my ($package, $method) = @_; + my $visitor = Test::Visitor->new; + my $code = $package->meta->find_method_by_name($method)->body; + $visitor->visit($code); + if ($visitor->pass) { + pass("${package}::${method} didn't close over anything complicated"); + } + else { + fail("${package}::${method} closed over some stuff:"); + my @closed_over = $visitor->closed_over; + for my $i (1..10) { + last unless @closed_over; + my $closed_over = shift @closed_over; + if ($can_partialdump) { + $closed_over = Devel::PartialDump->new->dump($closed_over); + } + diag($closed_over); + } + diag("... and " . scalar(@closed_over) . " more") + if @closed_over; + } +} + +{ + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + has foo => ( + is => 'ro', + isa => 'Str', + ); + + has bar => ( + is => 'ro', + isa => 'Int', + default => 1, + ); + + has baz => ( + is => 'rw', + isa => 'ArrayRef[Num]', + default => sub { [ 1.2 ] }, + trigger => sub { warn "blah" }, + ); + + subtype 'Thing', + as 'Int', + where { $_ < 5 }, + message { "must be less than 5" }; + has quux => ( + is => 'rw', + isa => 'Thing', + predicate => 'has_quux', + clearer => 'clear_quux', + ); + + __PACKAGE__->meta->make_immutable; +} + +close_over_ok('Foo', $_) for qw(new foo bar baz quux has_quux clear_quux); + +{ + package Foo::Sub; + use Moose; + extends 'Foo'; + + around foo => sub { + my $orig = shift; + my $self = shift; + $self->$orig(@_); + }; + + after bar => sub { }; + before baz => sub { }; + override quux => sub { super }; + + sub blah { inner } + + __PACKAGE__->meta->make_immutable; +} + +close_over_ok('Foo::Sub', $_) for qw(new foo bar baz quux blah); + +{ + package Foo::Sub::Sub; + use Moose; + extends 'Foo::Sub'; + + augment blah => { inner }; + + __PACKAGE__->meta->make_immutable; +} + +close_over_ok('Foo::Sub::Sub', $_) for qw(new blah); + +{ + my %handles = ( + Array => { + count => 'count', + elements => 'elements', + is_empty => 'is_empty', + push => 'push', + push_curried => [ push => 42, 84 ], + unshift => 'unshift', + unshift_curried => [ unshift => 42, 84 ], + pop => 'pop', + shift => 'shift', + get => 'get', + get_curried => [ get => 1 ], + set => 'set', + set_curried_1 => [ set => 1 ], + set_curried_2 => [ set => ( 1, 98 ) ], + accessor => 'accessor', + accessor_curried_1 => [ accessor => 1 ], + accessor_curried_2 => [ accessor => ( 1, 90 ) ], + clear => 'clear', + delete => 'delete', + delete_curried => [ delete => 1 ], + insert => 'insert', + insert_curried => [ insert => ( 1, 101 ) ], + splice => 'splice', + splice_curried_1 => [ splice => 1 ], + splice_curried_2 => [ splice => 1, 2 ], + splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ], + sort => 'sort', + sort_curried => [ sort => ( sub { $_[1] <=> $_[0] } ) ], + sort_in_place => 'sort_in_place', + sort_in_place_curried => + [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ], + map => 'map', + map_curried => [ map => ( sub { $_ + 1 } ) ], + grep => 'grep', + grep_curried => [ grep => ( sub { $_ < 5 } ) ], + first => 'first', + first_curried => [ first => ( sub { $_ % 2 } ) ], + join => 'join', + join_curried => [ join => '-' ], + shuffle => 'shuffle', + uniq => 'uniq', + reduce => 'reduce', + reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ], + natatime => 'natatime', + natatime_curried => [ natatime => 2 ], + }, + Hash => { + option_accessor => 'accessor', + quantity => [ accessor => 'quantity' ], + clear_options => 'clear', + num_options => 'count', + delete_option => 'delete', + is_defined => 'defined', + options_elements => 'elements', + has_option => 'exists', + get_option => 'get', + has_no_options => 'is_empty', + keys => 'keys', + values => 'values', + key_value => 'kv', + set_option => 'set', + }, + Counter => { + inc_counter => 'inc', + inc_counter_2 => [ inc => 2 ], + dec_counter => 'dec', + dec_counter_2 => [ dec => 2 ], + reset_counter => 'reset', + set_counter => 'set', + set_counter_42 => [ set => 42 ], + }, + Number => { + abs => 'abs', + add => 'add', + inc => [ add => 1 ], + div => 'div', + cut_in_half => [ div => 2 ], + mod => 'mod', + odd => [ mod => 2 ], + mul => 'mul', + set => 'set', + sub => 'sub', + dec => [ sub => 1 ], + }, + Bool => { + illuminate => 'set', + darken => 'unset', + flip_switch => 'toggle', + is_dark => 'not', + }, + String => { + inc => 'inc', + append => 'append', + append_curried => [ append => '!' ], + prepend => 'prepend', + prepend_curried => [ prepend => '-' ], + replace => 'replace', + replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ], + chop => 'chop', + chomp => 'chomp', + clear => 'clear', + match => 'match', + match_curried => [ match => qr/\D/ ], + length => 'length', + substr => 'substr', + substr_curried_1 => [ substr => (1) ], + substr_curried_2 => [ substr => ( 1, 3 ) ], + substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ], + }, + Code => { + execute => 'execute', + execute_method => 'execute_method', + }, + ); + + my %isa = ( + Array => 'ArrayRef[Str]', + Hash => 'HashRef[Int]', + Counter => 'Int', + Number => 'Num', + Bool => 'Bool', + String => 'Str', + Code => 'CodeRef', + ); + + my %default = ( + Array => [], + Hash => {}, + Counter => 0, + Number => 0.0, + Bool => 1, + String => '', + Code => sub { }, + ); + + for my $trait (keys %default) { + my $class_name = "Native::$trait"; + my $handles = $handles{$trait}; + my $attr_class = Moose::Util::with_traits( + 'Moose::Meta::Attribute', + "Moose::Meta::Attribute::Native::Trait::$trait", + ); + Moose::Meta::Class->create( + $class_name, + superclasses => ['Moose::Object'], + attributes => [ + $attr_class->new( + 'nonlazy', + is => 'ro', + isa => $isa{$trait}, + default => sub { $default{$trait} }, + handles => { + map {; "nonlazy_$_" => $handles->{$_} } keys %$handles + }, + ), + $attr_class->new( + 'lazy', + is => 'ro', + isa => $isa{$trait}, + lazy => 1, + default => sub { $default{$trait} }, + handles => { + map {; "lazy_$_" => $handles->{$_} } keys %$handles + }, + ), + ], + ); + close_over_ok($class_name, $_) for ( + 'new', + map {; "nonlazy_$_", "lazy_$_" } keys %$handles + ); + } +} + +{ + package WithInitializer; + use Moose; + + has foo => ( + is => 'ro', + isa => 'Str', + initializer => sub { }, + ); + + has bar => ( + is => 'ro', + isa => 'Str', + lazy => 1, + default => sub { 'a' }, + initializer => sub { }, + ); + + __PACKAGE__->meta->make_immutable; +} + +close_over_ok('WithInitializer', 'foo'); +{ local $TODO = "initializer still closes over things"; +close_over_ok('WithInitializer', $_) for qw(new bar); +} + +done_testing; diff --git a/t/immutable/inline_fallbacks.t b/t/immutable/inline_fallbacks.t new file mode 100644 index 0000000..362d60e --- /dev/null +++ b/t/immutable/inline_fallbacks.t @@ -0,0 +1,70 @@ +use strict; +use warnings; +use Test::More; + +{ + package Foo; + use Moose; + has foo => (is => 'ro'); +} + +{ + package Foo::Sub; + use Moose; + extends 'Foo'; + has bar => (is => 'ro'); +} + +{ + my $foo = Foo::Sub->new(foo => 12, bar => 25); + is($foo->foo, 12, 'got right value for foo'); + is($foo->bar, 25, 'got right value for bar'); +} + +Foo->meta->make_immutable; + +{ + package Foo::Sub2; + use Moose; + extends 'Foo'; + has baz => (is => 'ro'); + # not making immutable, inheriting Foo's inlined constructor +} + +{ + my $foo = Foo::Sub2->new(foo => 42, baz => 27); + is($foo->foo, 42, 'got right value for foo'); + is($foo->baz, 27, 'got right value for baz'); +} + +my $BAR = 0; +{ + package Bar; + use Moose; +} + +{ + package Bar::Sub; + use Moose; + extends 'Bar'; + sub DEMOLISH { $BAR++ } +} + +Bar::Sub->new; +is($BAR, 1, 'DEMOLISH in subclass was called'); +$BAR = 0; + +Bar->meta->make_immutable; + +{ + package Bar::Sub2; + use Moose; + extends 'Bar'; + sub DEMOLISH { $BAR++ } + # not making immutable, inheriting Bar's inlined destructor +} + +Bar::Sub2->new; +is($BAR, 1, 'DEMOLISH in subclass was called'); + +done_testing; diff --git a/t/immutable/inlined_constructors_n_types.t b/t/immutable/inlined_constructors_n_types.t new file mode 100644 index 0000000..3df1fb0 --- /dev/null +++ b/t/immutable/inlined_constructors_n_types.t @@ -0,0 +1,60 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +=pod + +This tests to make sure that the inlined constructor +has all the type constraints in order, even in the +cases when there is no type constraint available, such +as with a Class::MOP::Attribute object. + +=cut + +{ + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + coerce 'Int' => from 'Str' => via { length $_ ? $_ : 69 }; + + has 'foo' => (is => 'rw', isa => 'Int'); + has 'baz' => (is => 'rw', isa => 'Int'); + has 'zot' => (is => 'rw', isa => 'Int', init_arg => undef); + has 'moo' => (is => 'rw', isa => 'Int', coerce => 1, default => '', required => 1); + has 'boo' => (is => 'rw', isa => 'Int', coerce => 1, builder => '_build_boo', required => 1); + + sub _build_boo { '' } + + Foo->meta->add_attribute( + Class::MOP::Attribute->new( + 'bar' => ( + accessor => 'bar', + ) + ) + ); +} + +for (1..2) { + my $is_immutable = Foo->meta->is_immutable; + my $mutable_string = $is_immutable ? 'immutable' : 'mutable'; + is( exception { + my $f = Foo->new(foo => 10, bar => "Hello World", baz => 10, zot => 4); + is($f->moo, 69, "Type coercion works as expected on default ($mutable_string)"); + is($f->boo, 69, "Type coercion works as expected on builder ($mutable_string)"); + }, undef, "... this passes the constuctor correctly ($mutable_string)" ); + + is( exception { + Foo->new(foo => 10, bar => "Hello World", baz => 10, zot => "not an int"); + }, undef, "... the constructor doesn't care about 'zot' ($mutable_string)" ); + + isnt( exception { + Foo->new(foo => "Hello World", bar => 100, baz => "Hello World"); + }, undef, "... this fails the constuctor correctly ($mutable_string)" ); + + Foo->meta->make_immutable(debug => 0) unless $is_immutable; +} + +done_testing; diff --git a/t/immutable/multiple_demolish_inline.t b/t/immutable/multiple_demolish_inline.t new file mode 100644 index 0000000..e9727ac --- /dev/null +++ b/t/immutable/multiple_demolish_inline.t @@ -0,0 +1,45 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + + has 'foo' => (is => 'rw', isa => 'Int'); + + sub DEMOLISH { } +} + +{ + package Bar; + use Moose; + + extends qw(Foo); + has 'bar' => (is => 'rw', isa => 'Int'); + + sub DEMOLISH { } +} + +is( exception { + Bar->new(); +}, undef, 'Bar->new()' ); + +is( exception { + Bar->meta->make_immutable; +}, undef, 'Bar->meta->make_immutable' ); + +is( Bar->meta->get_method('DESTROY')->package_name, 'Bar', + 'Bar has a DESTROY method in the Bar class (not inherited)' ); + +is( exception { + Foo->meta->make_immutable; +}, undef, 'Foo->meta->make_immutable' ); + +is( Foo->meta->get_method('DESTROY')->package_name, 'Foo', + 'Foo has a DESTROY method in the Bar class (not inherited)' ); + +done_testing; diff --git a/t/lib/Bar.pm b/t/lib/Bar.pm new file mode 100644 index 0000000..b520c7a --- /dev/null +++ b/t/lib/Bar.pm @@ -0,0 +1,9 @@ +package Bar; +use Moose; +use Moose::Util::TypeConstraints; + +type Baz => where { 1 }; + +subtype Bling => as Baz => where { 1 }; + +1;
\ No newline at end of file diff --git a/t/lib/Bar7/Meta/Trait.pm b/t/lib/Bar7/Meta/Trait.pm new file mode 100644 index 0000000..aec769b --- /dev/null +++ b/t/lib/Bar7/Meta/Trait.pm @@ -0,0 +1,8 @@ +package Bar7::Meta::Trait; +use Moose::Role; + +around _immutable_options => sub { }; + +no Moose::Role; + +1; diff --git a/t/lib/Bar7/Meta/Trait2.pm b/t/lib/Bar7/Meta/Trait2.pm new file mode 100644 index 0000000..4f1b73f --- /dev/null +++ b/t/lib/Bar7/Meta/Trait2.pm @@ -0,0 +1,13 @@ +package Bar7::Meta::Trait2; +use Moose::Role; + +has foo => ( + traits => ['Array'], + handles => { + push_foo => 'push', + }, +); + +no Moose::Role; + +1; diff --git a/t/lib/Foo.pm b/t/lib/Foo.pm new file mode 100644 index 0000000..048870c --- /dev/null +++ b/t/lib/Foo.pm @@ -0,0 +1,6 @@ +package Foo; +use Moose; + +has 'bar' => (is => 'rw'); + +1; diff --git a/t/lib/Moose/Meta/Attribute/Custom/Bar.pm b/t/lib/Moose/Meta/Attribute/Custom/Bar.pm new file mode 100644 index 0000000..64dd230 --- /dev/null +++ b/t/lib/Moose/Meta/Attribute/Custom/Bar.pm @@ -0,0 +1,10 @@ +package Moose::Meta::Attribute::Custom::Bar; + +sub register_implementation { 'My::Bar' } + + +package My::Bar; + +use Moose::Role; + +1; diff --git a/t/lib/Moose/Meta/Attribute/Custom/Foo.pm b/t/lib/Moose/Meta/Attribute/Custom/Foo.pm new file mode 100644 index 0000000..49f7a01 --- /dev/null +++ b/t/lib/Moose/Meta/Attribute/Custom/Foo.pm @@ -0,0 +1,5 @@ +package Moose::Meta::Attribute::Custom::Foo; + +use Moose::Role; + +1; diff --git a/t/lib/Moose/Meta/Attribute/Custom/Trait/Bar.pm b/t/lib/Moose/Meta/Attribute/Custom/Trait/Bar.pm new file mode 100644 index 0000000..17412c1 --- /dev/null +++ b/t/lib/Moose/Meta/Attribute/Custom/Trait/Bar.pm @@ -0,0 +1,10 @@ +package Moose::Meta::Attribute::Custom::Trait::Bar; + +sub register_implementation { 'My::Trait::Bar' } + + +package My::Trait::Bar; + +use Moose::Role; + +1; diff --git a/t/lib/Moose/Meta/Attribute/Custom/Trait/Foo.pm b/t/lib/Moose/Meta/Attribute/Custom/Trait/Foo.pm new file mode 100644 index 0000000..682b61f --- /dev/null +++ b/t/lib/Moose/Meta/Attribute/Custom/Trait/Foo.pm @@ -0,0 +1,5 @@ +package Moose::Meta::Attribute::Custom::Trait::Foo; + +use Moose::Role; + +1; diff --git a/t/lib/MyExporter.pm b/t/lib/MyExporter.pm new file mode 100644 index 0000000..bda6f20 --- /dev/null +++ b/t/lib/MyExporter.pm @@ -0,0 +1,22 @@ +package MyExporter; +use Moose::Exporter; +use Test::More; + +Moose::Exporter->setup_import_methods( + with_meta => [qw(with_prototype)], + as_is => [qw(as_is_prototype)], +); + +sub with_prototype (&) { + my ($class, $code) = @_; + isa_ok($code, 'CODE', 'with_prototype received a coderef'); + $code->(); +} + +sub as_is_prototype (&) { + my ($code) = @_; + isa_ok($code, 'CODE', 'as_is_prototype received a coderef'); + $code->(); +} + +1; diff --git a/t/lib/MyMetaclassRole.pm b/t/lib/MyMetaclassRole.pm new file mode 100644 index 0000000..362265a --- /dev/null +++ b/t/lib/MyMetaclassRole.pm @@ -0,0 +1,4 @@ +package MyMetaclassRole; +use Moose::Role; + +1; diff --git a/t/lib/MyMooseA.pm b/t/lib/MyMooseA.pm new file mode 100644 index 0000000..9e520b9 --- /dev/null +++ b/t/lib/MyMooseA.pm @@ -0,0 +1,7 @@ +package MyMooseA; + +use Moose; + +has 'b' => (is => 'rw', isa => 'MyMooseB'); + +1;
\ No newline at end of file diff --git a/t/lib/MyMooseB.pm b/t/lib/MyMooseB.pm new file mode 100644 index 0000000..c772947 --- /dev/null +++ b/t/lib/MyMooseB.pm @@ -0,0 +1,5 @@ +package MyMooseB; + +use Moose; + +1;
\ No newline at end of file diff --git a/t/lib/MyMooseObject.pm b/t/lib/MyMooseObject.pm new file mode 100644 index 0000000..5f1a6f7 --- /dev/null +++ b/t/lib/MyMooseObject.pm @@ -0,0 +1,7 @@ +package MyMooseObject; + +use strict; +use warnings; +use parent 'Moose::Object'; + +1; diff --git a/t/lib/NoInlineAttribute.pm b/t/lib/NoInlineAttribute.pm new file mode 100644 index 0000000..af182dc --- /dev/null +++ b/t/lib/NoInlineAttribute.pm @@ -0,0 +1,29 @@ +package NoInlineAttribute; + +use Moose::Meta::Class; +use Moose::Role; + +around accessor_metaclass => sub { + my $orig = shift; + my $self = shift; + + my $class = $self->$orig(); + + return Moose::Meta::Class->create_anon_class( + superclasses => [$class], + roles => ['NoInlineAccessor'], + cache => 1, + )->name; +}; + +no Moose::Role; + +{ + package NoInlineAccessor; + + use Moose::Role; + + sub is_inline { 0 } +} + +1; diff --git a/t/lib/Overloading/ClassConsumesRoleConsumesOverloads.pm b/t/lib/Overloading/ClassConsumesRoleConsumesOverloads.pm new file mode 100644 index 0000000..2cfe5e1 --- /dev/null +++ b/t/lib/Overloading/ClassConsumesRoleConsumesOverloads.pm @@ -0,0 +1,7 @@ +package Overloading::ClassConsumesRoleConsumesOverloads; + +use Moose; + +with 'Overloading::RoleConsumesOverloads'; + +1; diff --git a/t/lib/Overloading/ClassWithCombiningRole.pm b/t/lib/Overloading/ClassWithCombiningRole.pm new file mode 100644 index 0000000..5e953f5 --- /dev/null +++ b/t/lib/Overloading/ClassWithCombiningRole.pm @@ -0,0 +1,7 @@ +package Overloading::ClassWithCombiningRole; + +use Moose; + +with 'Overloading::CombiningRole'; + +1; diff --git a/t/lib/Overloading/ClassWithOneRole.pm b/t/lib/Overloading/ClassWithOneRole.pm new file mode 100644 index 0000000..89d135a --- /dev/null +++ b/t/lib/Overloading/ClassWithOneRole.pm @@ -0,0 +1,7 @@ +package Overloading::ClassWithOneRole; + +use Moose; + +with 'Overloading::RoleWithOverloads'; + +1; diff --git a/t/lib/Overloading/CombiningClass.pm b/t/lib/Overloading/CombiningClass.pm new file mode 100644 index 0000000..524ef46 --- /dev/null +++ b/t/lib/Overloading/CombiningClass.pm @@ -0,0 +1,7 @@ +package Overloading::CombiningClass; + +use Moose; + +with 'Overloading::RoleWithOverloads', 'Overloading::RoleWithoutOverloads'; + +1; diff --git a/t/lib/Overloading/CombiningRole.pm b/t/lib/Overloading/CombiningRole.pm new file mode 100644 index 0000000..db523cb --- /dev/null +++ b/t/lib/Overloading/CombiningRole.pm @@ -0,0 +1,7 @@ +package Overloading::CombiningRole; + +use Moose::Role; + +with 'Overloading::RoleWithOverloads', 'Overloading::RoleWithoutOverloads'; + +1; diff --git a/t/lib/Overloading/RoleConsumesOverloads.pm b/t/lib/Overloading/RoleConsumesOverloads.pm new file mode 100644 index 0000000..0e0e476 --- /dev/null +++ b/t/lib/Overloading/RoleConsumesOverloads.pm @@ -0,0 +1,7 @@ +package Overloading::RoleConsumesOverloads; + +use Moose::Role; + +with 'Overloading::RoleWithOverloads'; + +1; diff --git a/t/lib/Overloading/RoleWithOverloads.pm b/t/lib/Overloading/RoleWithOverloads.pm new file mode 100644 index 0000000..31471cf --- /dev/null +++ b/t/lib/Overloading/RoleWithOverloads.pm @@ -0,0 +1,16 @@ +package Overloading::RoleWithOverloads; + +use Moose::Role; + +use overload + q{""} => 'as_string', + fallback => 1; + +has message => ( + is => 'rw', + isa => 'Str', +); + +sub as_string { shift->message } + +1; diff --git a/t/lib/Overloading/RoleWithoutOverloads.pm b/t/lib/Overloading/RoleWithoutOverloads.pm new file mode 100644 index 0000000..97d3e80 --- /dev/null +++ b/t/lib/Overloading/RoleWithoutOverloads.pm @@ -0,0 +1,5 @@ +package Overloading::RoleWithoutOverloads; + +use Moose::Role; + +1; diff --git a/t/lib/OverloadingTests.pm b/t/lib/OverloadingTests.pm new file mode 100644 index 0000000..d1ab195 --- /dev/null +++ b/t/lib/OverloadingTests.pm @@ -0,0 +1,47 @@ +package OverloadingTests; + +use strict; +use warnings; + +use Test::More 0.88; + +sub test_overloading_for_package { + my $package = shift; + + ok( + overload::Overloaded($package), + "$package is overloaded" + ); + ok( + overload::Method( $package, q{""} ), + "$package overloads stringification" + ); +} + +sub test_no_overloading_for_package { + my $package = shift; + + ok( + !overload::Overloaded($package), + "$package is not overloaded" + ); + ok( + !overload::Method( $package, q{""} ), + "$package does not overload stringification" + ); +} + +sub test_overloading_for_object { + my $class = shift; + my $thing = shift || "$class object"; + + my $object = ref $class ? $class : $class->new( { message => 'foo' } ); + + is( + "$object", + 'foo', + "$thing stringifies to value of message attribute" + ); +} + +1; diff --git a/t/lib/Real/Package.pm b/t/lib/Real/Package.pm new file mode 100644 index 0000000..98b3d47 --- /dev/null +++ b/t/lib/Real/Package.pm @@ -0,0 +1,7 @@ +package Real::Package; +use strict; +use warnings; + +sub foo { } + +1; diff --git a/t/lib/Role/BreakOnLoad.pm b/t/lib/Role/BreakOnLoad.pm new file mode 100644 index 0000000..48367a7 --- /dev/null +++ b/t/lib/Role/BreakOnLoad.pm @@ -0,0 +1,8 @@ +package Role::BreakOnLoad; +use Moose::Role; + +sub meth1 { } + +this role has a syntax error and should crash on load. + +1; diff --git a/t/lib/Role/Child.pm b/t/lib/Role/Child.pm new file mode 100644 index 0000000..4c70436 --- /dev/null +++ b/t/lib/Role/Child.pm @@ -0,0 +1,8 @@ +package Role::Child; +use Moose::Role; + +with 'Role::Parent' => { -alias => { meth1 => 'aliased_meth1', } }; + +sub meth1 { } + +1; diff --git a/t/lib/Role/Interface.pm b/t/lib/Role/Interface.pm new file mode 100644 index 0000000..025cf40 --- /dev/null +++ b/t/lib/Role/Interface.pm @@ -0,0 +1,6 @@ +package Role::Interface; +use Moose::Role; + +requires "meth2"; + +1; diff --git a/t/lib/Role/Parent.pm b/t/lib/Role/Parent.pm new file mode 100644 index 0000000..0f49427 --- /dev/null +++ b/t/lib/Role/Parent.pm @@ -0,0 +1,7 @@ +package Role::Parent; +use Moose::Role; + +sub meth2 { } +sub meth1 { } + +1; diff --git a/t/metaclasses/create_anon_with_required_attr.t b/t/metaclasses/create_anon_with_required_attr.t new file mode 100644 index 0000000..3a37773 --- /dev/null +++ b/t/metaclasses/create_anon_with_required_attr.t @@ -0,0 +1,86 @@ +use strict; +use warnings; + +# this functionality may be pushing toward parametric roles/classes +# it's off in a corner and may not be that important + +use Test::More; +use Test::Fatal; + +{ + package HasFoo; + use Moose::Role; + has 'foo' => ( + is => 'ro', + isa => 'Str', + required => 1, + ); + +} + +{ + package My::Metaclass; + use Moose; + extends 'Moose::Meta::Class'; + with 'HasFoo'; +} + +package main; + +my $anon; +is( exception { + $anon = My::Metaclass->create_anon_class( foo => 'this' ); +}, undef, 'create anon class with required attr' ); +isa_ok( $anon, 'My::Metaclass' ); +cmp_ok( $anon->foo, 'eq', 'this', 'foo is this' ); +isnt( exception { + $anon = My::Metaclass->create_anon_class(); +}, undef, 'failed to create anon class without required attr' ); + +my $meta; +is( exception { + $meta + = My::Metaclass->initialize( 'Class::Name1' => ( foo => 'that' ) ); +}, undef, 'initialize a class with required attr' ); +isa_ok( $meta, 'My::Metaclass' ); +cmp_ok( $meta->foo, 'eq', 'that', 'foo is that' ); +cmp_ok( $meta->name, 'eq', 'Class::Name1', 'for the correct class' ); +isnt( exception { + $meta + = My::Metaclass->initialize( 'Class::Name2' ); +}, undef, 'failed to initialize a class without required attr' ); + +is( exception { + eval qq{ + package Class::Name3; + use metaclass 'My::Metaclass' => ( + foo => 'another', + ); + use Moose; + }; + die $@ if $@; +}, undef, 'use metaclass with required attr' ); +$meta = Class::Name3->meta; +isa_ok( $meta, 'My::Metaclass' ); +cmp_ok( $meta->foo, 'eq', 'another', 'foo is another' ); +cmp_ok( $meta->name, 'eq', 'Class::Name3', 'for the correct class' ); +isnt( exception { + eval qq{ + package Class::Name4; + use metaclass 'My::Metaclass'; + use Moose; + }; + die $@ if $@; +}, undef, 'failed to use metaclass without required attr' ); + + +# how do we pass a required attribute to -traits? +isnt( exception { + eval qq{ + package Class::Name5; + use Moose -traits => 'HasFoo'; + }; + die $@ if $@; +}, undef, 'failed to use trait without required attr' ); + +done_testing; diff --git a/t/metaclasses/custom_attr_meta_as_role.t b/t/metaclasses/custom_attr_meta_as_role.t new file mode 100644 index 0000000..d1790d4 --- /dev/null +++ b/t/metaclasses/custom_attr_meta_as_role.t @@ -0,0 +1,20 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +is( exception { + package MooseX::Attribute::Test; + use Moose::Role; +}, undef, 'creating custom attribute "metarole" is okay' ); + +is( exception { + package Moose::Meta::Attribute::Custom::Test; + use Moose; + + extends 'Moose::Meta::Attribute'; + with 'MooseX::Attribute::Test'; +}, undef, 'custom attribute metaclass extending role is okay' ); + +done_testing; diff --git a/t/metaclasses/custom_attr_meta_with_roles.t b/t/metaclasses/custom_attr_meta_with_roles.t new file mode 100644 index 0000000..d6d43bc --- /dev/null +++ b/t/metaclasses/custom_attr_meta_with_roles.t @@ -0,0 +1,39 @@ +use strict; +use warnings; + +use Test::More; + + +{ + package My::Custom::Meta::Attr; + use Moose; + + extends 'Moose::Meta::Attribute'; +} + +{ + package My::Fancy::Role; + use Moose::Role; + + has 'bling_bling' => ( + metaclass => 'My::Custom::Meta::Attr', + is => 'rw', + isa => 'Str', + ); +} + +{ + package My::Class; + use Moose; + + with 'My::Fancy::Role'; +} + +my $c = My::Class->new; +isa_ok($c, 'My::Class'); + +ok($c->meta->has_attribute('bling_bling'), '... got the attribute'); + +isa_ok($c->meta->get_attribute('bling_bling'), 'My::Custom::Meta::Attr'); + +done_testing; diff --git a/t/metaclasses/easy_init_meta.t b/t/metaclasses/easy_init_meta.t new file mode 100644 index 0000000..b199b6a --- /dev/null +++ b/t/metaclasses/easy_init_meta.t @@ -0,0 +1,126 @@ +use strict; +use warnings; + +use Test::More; +use Test::Moose qw(does_ok); + +{ + package Foo::Trait::Class; + use Moose::Role; +} + +{ + package Foo::Trait::Attribute; + use Moose::Role; +} + +{ + package Foo::Role::Base; + use Moose::Role; +} + +{ + package Foo::Exporter; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + class_metaroles => { + class => ['Foo::Trait::Class'], + attribute => ['Foo::Trait::Attribute'], + }, + role_metaroles => { role => ['Foo::Trait::Class'] }, + base_class_roles => ['Foo::Role::Base'], + ); +} + +{ + package Foo; + use Moose; + Foo::Exporter->import; + + has foo => (is => 'ro'); + + ::does_ok(Foo->meta, 'Foo::Trait::Class'); + ::does_ok(Foo->meta->get_attribute('foo'), 'Foo::Trait::Attribute'); + ::does_ok('Foo', 'Foo::Role::Base'); +} + +{ + package Foo::Exporter::WithMoose; + use Moose (); + use Moose::Exporter; + + my ( $import, $unimport, $init_meta ) + = Moose::Exporter->build_import_methods( + also => 'Moose', + class_metaroles => { + class => ['Foo::Trait::Class'], + attribute => ['Foo::Trait::Attribute'], + }, + base_class_roles => ['Foo::Role::Base'], + install => [qw(import unimport)], + ); + + sub init_meta { + my $package = shift; + my %options = @_; + ::pass('custom init_meta was called'); + Moose->init_meta(%options); + return $package->$init_meta(%options); + } +} + +{ + package Foo2; + Foo::Exporter::WithMoose->import; + + has(foo => (is => 'ro')); + + ::isa_ok('Foo2', 'Moose::Object'); + ::isa_ok(Foo2->meta, 'Moose::Meta::Class'); + ::does_ok(Foo2->meta, 'Foo::Trait::Class'); + ::does_ok(Foo2->meta->get_attribute('foo'), 'Foo::Trait::Attribute'); + ::does_ok('Foo2', 'Foo::Role::Base'); +} + +{ + package Foo::Role; + use Moose::Role; + Foo::Exporter->import; + + ::does_ok(Foo::Role->meta, 'Foo::Trait::Class'); +} + +{ + package Foo::Exporter::WithMooseRole; + use Moose::Role (); + use Moose::Exporter; + + my ( $import, $unimport, $init_meta ) + = Moose::Exporter->build_import_methods( + also => 'Moose::Role', + role_metaroles => { + role => ['Foo::Trait::Class'], + attribute => ['Foo::Trait::Attribute'], + }, + install => [qw(import unimport)], + ); + + sub init_meta { + my $package = shift; + my %options = @_; + ::pass('custom init_meta was called'); + Moose::Role->init_meta(%options); + return $package->$init_meta(%options); + } +} + +{ + package Foo2::Role; + Foo::Exporter::WithMooseRole->import; + + ::isa_ok(Foo2::Role->meta, 'Moose::Meta::Role'); + ::does_ok(Foo2::Role->meta, 'Foo::Trait::Class'); +} + +done_testing; diff --git a/t/metaclasses/export_with_prototype.t b/t/metaclasses/export_with_prototype.t new file mode 100644 index 0000000..97227c6 --- /dev/null +++ b/t/metaclasses/export_with_prototype.t @@ -0,0 +1,22 @@ +use lib "t/lib"; +package MyExporter::User; +use MyExporter; + +use Test::More; +use Test::Fatal; + +is( exception { + with_prototype { + my $caller = caller(0); + is($caller, 'MyExporter', "With_caller prototype code gets called from MyMooseX"); + }; +}, undef, "check function with prototype" ); + +is( exception { + as_is_prototype { + my $caller = caller(0); + is($caller, 'MyExporter', "As-is prototype code gets called from MyMooseX"); + }; +}, undef, "check function with prototype" ); + +done_testing; diff --git a/t/metaclasses/exporter_also_with_trait.t b/t/metaclasses/exporter_also_with_trait.t new file mode 100644 index 0000000..ca79ceb --- /dev/null +++ b/t/metaclasses/exporter_also_with_trait.t @@ -0,0 +1,35 @@ +use strict; +use warnings; +use Test::More; +use Test::Moose; + +BEGIN { + package My::Meta::Role; + use Moose::Role; +} + +BEGIN { + package My::Exporter; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + also => ['Moose'], + class_metaroles => { + class => ['My::Meta::Role'], + }, + ); + $INC{'My/Exporter.pm'} = __FILE__; +} + +{ + package My::Class; + use My::Exporter; +} + +{ + my $meta = My::Class->meta; + isa_ok($meta, 'Moose::Meta::Class'); + does_ok($meta, 'My::Meta::Role'); +} + +done_testing; diff --git a/t/metaclasses/exporter_meta_lookup.t b/t/metaclasses/exporter_meta_lookup.t new file mode 100644 index 0000000..629b48b --- /dev/null +++ b/t/metaclasses/exporter_meta_lookup.t @@ -0,0 +1,62 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Class::Vacuum::Innards; + use Moose; + + package Class::Vacuum; + use Moose (); + use Moose::Exporter; + + sub meta_lookup { $_[0] } + + BEGIN { + Moose::Exporter->setup_import_methods( + also => 'Moose', + meta_lookup => sub { Class::MOP::class_of('Class::Vacuum::Innards') }, + with_meta => ['meta_lookup'], + ); + } +} + +{ + package Victim; + BEGIN { Class::Vacuum->import }; + + has star_rod => ( + is => 'ro', + ); + + ::is(meta_lookup, Class::Vacuum::Innards->meta, "right meta_lookup"); +} + +ok(Class::Vacuum::Innards->can('star_rod'), 'Vacuum stole the star_rod method'); +ok(!Victim->can('star_rod'), 'Victim does not get it at all'); + +{ + package Class::Vacuum::Reexport; + use Moose::Exporter; + + BEGIN { + Moose::Exporter->setup_import_methods(also => 'Class::Vacuum'); + } +} + +{ + package Victim2; + BEGIN { Class::Vacuum::Reexport->import } + + has parasol => ( + is => 'ro', + ); + + ::is(meta_lookup, Class::Vacuum::Innards->meta, "right meta_lookup"); +} + +ok(Class::Vacuum::Innards->can('parasol'), 'Vacuum stole the parasol method'); +ok(!Victim2->can('parasol'), 'Victim does not get it at all'); + +done_testing; diff --git a/t/metaclasses/exporter_sub_names.t b/t/metaclasses/exporter_sub_names.t new file mode 100644 index 0000000..628ed94 --- /dev/null +++ b/t/metaclasses/exporter_sub_names.t @@ -0,0 +1,47 @@ +use strict; +use warnings; + +use Test::CleanNamespaces; +use Test::More; + +diag "ALERT!!!!!! List::MoreUtils 0.407 is incompatible with Moose! You must upgrade or downgrade!" + if do { require List::MoreUtils; List::MoreUtils->VERSION eq '0.407' }; + +{ + package Metarole; + use Moose::Role; +} + +$::HAS_NC_AC = 0; + +{ + package Foo; + use Moose (); + use Moose::Exporter; + { + local $@; + eval 'use namespace::autoclean; $::HAS_NC_AC = 1'; + } + + Moose::Exporter->setup_import_methods( + also => 'Moose', + class_metaroles => { class => ['Metarole'] }, + ); + + my $meta = Class::MOP::Package->initialize(__PACKAGE__); + for my $name (qw( import unimport init_meta )) { + my $body = $meta->get_package_symbol( '&' . $name ); + my ( $package, $sub_name ) = Class::MOP::get_code_info($body); + + ::is( $package, __PACKAGE__, "$name sub is in Foo package" ); + ::is( $sub_name, $name, "$name sub has that name, not __ANON__" ); + } +} + +if ($::HAS_NC_AC) { + $INC{'Foo.pm'} = 1; + namespaces_clean('Foo'); +} + +done_testing(); + diff --git a/t/metaclasses/goto_moose_import.t b/t/metaclasses/goto_moose_import.t new file mode 100644 index 0000000..b6e70be --- /dev/null +++ b/t/metaclasses/goto_moose_import.t @@ -0,0 +1,80 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +# Some packages out in the wild cooperate with Moose by using goto +# &Moose::import. we want to make sure it still works. + +{ + package MooseAlike1; + + use strict; + use warnings; + + use Moose (); + + sub import { + goto &Moose::import; + } + + sub unimport { + goto &Moose::unimport; + } +} + +{ + package Foo; + + MooseAlike1->import(); + + ::is( ::exception { has( 'size', is => 'bare' ) }, undef, 'has was exported via MooseAlike1' ); + + MooseAlike1->unimport(); +} + +ok( ! Foo->can('has'), + 'No has sub in Foo after MooseAlike1 is unimported' ); +ok( Foo->can('meta'), + 'Foo has a meta method' ); +isa_ok( Foo->meta(), 'Moose::Meta::Class' ); + + +{ + package MooseAlike2; + + use strict; + use warnings; + + use Moose (); + + my $import = \&Moose::import; + sub import { + goto $import; + } + + my $unimport = \&Moose::unimport; + sub unimport { + goto $unimport; + } +} + +{ + package Bar; + + MooseAlike2->import(); + + ::is( ::exception { has( 'size', is => 'bare' ) }, undef, 'has was exported via MooseAlike2' ); + + MooseAlike2->unimport(); +} + + +ok( ! Bar->can('has'), + 'No has sub in Bar after MooseAlike2 is unimported' ); +ok( Bar->can('meta'), + 'Bar has a meta method' ); +isa_ok( Bar->meta(), 'Moose::Meta::Class' ); + +done_testing; diff --git a/t/metaclasses/immutable_metaclass_compat_bug.t b/t/metaclasses/immutable_metaclass_compat_bug.t new file mode 100644 index 0000000..67a4ffa --- /dev/null +++ b/t/metaclasses/immutable_metaclass_compat_bug.t @@ -0,0 +1,37 @@ +use strict; +use warnings; +use Test::More; + +{ + package Foo::Base::Meta::Trait; + use Moose::Role; +} + +{ + package Foo::Base; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { constructor => ['Foo::Base::Meta::Trait'] }, + ); + __PACKAGE__->meta->make_immutable; +} + +{ + package Foo::Meta::Trait; + use Moose::Role; +} + +{ + package Foo; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { constructor => ['Foo::Meta::Trait'] } + ); + ::ok(!Foo->meta->is_immutable); + extends 'Foo::Base'; + ::ok(!Foo->meta->is_immutable); +} + +done_testing; diff --git a/t/metaclasses/meta_name.t b/t/metaclasses/meta_name.t new file mode 100644 index 0000000..d947a18 --- /dev/null +++ b/t/metaclasses/meta_name.t @@ -0,0 +1,73 @@ +use strict; +use warnings; +use Test::More; + +{ + # so we don't pick up stuff from Moose::Object + package Base; + sub foo { } # touch it so that 'extends' doesn't try to load it +} + +{ + package Foo; + use Moose; + extends 'Base'; + no Moose; +} +can_ok('Foo', 'meta'); +is(Foo->meta, Class::MOP::class_of('Foo'), 'Foo is a class_of Foo, via Foo->meta'); +isa_ok(Foo->meta->get_method('meta'), 'Moose::Meta::Method::Meta'); + +{ + package Bar; + use Moose -meta_name => 'bar_meta'; + extends 'Base'; + no Moose; +} +ok(!Bar->can('meta'), q{Bar->cant('meta')}); +can_ok('Bar', 'bar_meta'); +is(Bar->bar_meta, Class::MOP::class_of('Bar'), 'Bar is a class_of Bar, via Bar->bar_meta'); +isa_ok(Bar->bar_meta->get_method('bar_meta'), 'Moose::Meta::Method::Meta'); + +{ + package Baz; + use Moose -meta_name => undef; + extends 'Base'; + no Moose; +} +ok(!Baz->can('meta'), q{Baz->cant('meta')}); + +my $universal_method_count = scalar Class::MOP::class_of('UNIVERSAL')->get_all_methods; +# 1 because of the dummy method we installed in Base +is( + ( scalar Class::MOP::class_of('Baz')->get_all_methods ) - $universal_method_count, + 1, + 'Baz has one method', +); + +{ + package Qux; + use Moose -meta_name => 'qux_meta'; +} + +can_ok('Qux', 'qux_meta'); +is(Qux->qux_meta, Class::MOP::class_of('Qux'), 'Qux is a class_of Qux, via Qux->qux_meta'); +isa_ok(Qux->qux_meta->get_method('qux_meta'), 'Moose::Meta::Method::Meta'); + +{ + package FooBar; + sub meta { 42 } + use Moose -meta_name => 'foo_bar_meta'; +} + +is(FooBar->meta, 42, 'FooBar->meta returns 42, not metaclass object'); + +{ + package FooBar::Child; + use Moose -meta_name => 'foo_bar_child_meta'; + extends 'FooBar'; +} + +is(FooBar::Child->meta, 42, 'FooBar::Child->meta returns 42, not metaclass object'); + +done_testing; diff --git a/t/metaclasses/metaclass_compat.t b/t/metaclasses/metaclass_compat.t new file mode 100644 index 0000000..8ef2343 --- /dev/null +++ b/t/metaclasses/metaclass_compat.t @@ -0,0 +1,304 @@ +use strict; +use warnings; +use lib 't/lib'; +use Test::More; +use Test::Fatal; + +our $called = 0; +{ + package Foo::Trait::Class; + use Moose::Role; + + around _inline_BUILDALL => sub { + my $orig = shift; + my $self = shift; + return ( + $self->$orig(@_), + '$::called++;' + ); + } +} + +{ + package Foo; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { + class => ['Foo::Trait::Class'], + } + ); +} + +Foo->new; +is($called, 0, "no calls before inlining"); +Foo->meta->make_immutable; + +Foo->new; +is($called, 1, "inlined constructor has trait modifications"); + +ok(Foo->meta->meta->does_role('Foo::Trait::Class'), + "class has correct traits"); + +{ + package Foo::Sub; + use Moose; + extends 'Foo'; +} + +$called = 0; + +Foo::Sub->new; +is($called, 0, "no calls before inlining"); + +Foo::Sub->meta->make_immutable; + +Foo::Sub->new; +is($called, 1, "inherits trait properly"); + +ok(Foo::Sub->meta->meta->can('does_role') +&& Foo::Sub->meta->meta->does_role('Foo::Trait::Class'), + "subclass inherits traits"); + +{ + package Foo2::Role; + use Moose::Role; +} +{ + package Foo2; + use Moose -traits => ['Foo2::Role']; +} +{ + package Bar2; + use Moose; +} +{ + package Baz2; + use Moose; + my $meta = __PACKAGE__->meta; + ::is( ::exception { $meta->superclasses('Foo2') }, undef, "can set superclasses once" ); + ::isa_ok($meta, Foo2->meta->meta->name); + ::is( ::exception { $meta->superclasses('Bar2') }, undef, "can still set superclasses" ); + ::isa_ok($meta, Bar2->meta->meta->name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo2::Role'], + "still have the role attached"); + ::ok(!$meta->is_immutable, + "immutable superclass doesn't make this class immutable"); + ::is( ::exception { $meta->make_immutable }, undef, "can still make immutable" ); +} +{ + package Foo3::Role; + use Moose::Role; +} +{ + package Bar3; + use Moose -traits => ['Foo3::Role']; +} +{ + package Baz3; + use Moose -traits => ['Foo3::Role']; + my $meta = __PACKAGE__->meta; + ::is( ::exception { $meta->superclasses('Foo2') }, undef, "can set superclasses once" ); + ::isa_ok($meta, Foo2->meta->meta->name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo2::Role', 'Foo3::Role'], + "reconciled roles correctly"); + ::is( ::exception { $meta->superclasses('Bar3') }, undef, "can still set superclasses" ); + ::isa_ok($meta, Bar3->meta->meta->name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo2::Role', 'Foo3::Role'], + "roles still the same"); + ::ok(!$meta->is_immutable, + "immutable superclass doesn't make this class immutable"); + ::is( ::exception { $meta->make_immutable }, undef, "can still make immutable" ); +} +{ + package Quux3; + use Moose; +} +{ + package Quuux3; + use Moose -traits => ['Foo3::Role']; + my $meta = __PACKAGE__->meta; + ::is( ::exception { $meta->superclasses('Foo2') }, undef, "can set superclasses once" ); + ::isa_ok($meta, Foo2->meta->meta->name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo2::Role', 'Foo3::Role'], + "reconciled roles correctly"); + ::is( ::exception { $meta->superclasses('Quux3') }, undef, "can still set superclasses" ); + ::isa_ok($meta, Quux3->meta->meta->name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo2::Role', 'Foo3::Role'], + "roles still the same"); + ::ok(!$meta->is_immutable, + "immutable superclass doesn't make this class immutable"); + ::is( ::exception { $meta->make_immutable }, undef, "can still make immutable" ); +} + +{ + package Foo4::Role; + use Moose::Role; +} +{ + package Foo4; + use Moose -traits => ['Foo4::Role']; + __PACKAGE__->meta->make_immutable; +} +{ + package Bar4; + use Moose; +} +{ + package Baz4; + use Moose; + my $meta = __PACKAGE__->meta; + ::is( ::exception { $meta->superclasses('Foo4') }, undef, "can set superclasses once" ); + ::isa_ok($meta, Foo4->meta->_get_mutable_metaclass_name); + ::is( ::exception { $meta->superclasses('Bar4') }, undef, "can still set superclasses" ); + ::isa_ok($meta, Bar4->meta->meta->name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo4::Role'], + "still have the role attached"); + ::ok(!$meta->is_immutable, + "immutable superclass doesn't make this class immutable"); + ::is( ::exception { $meta->make_immutable }, undef, "can still make immutable" ); +} +{ + package Foo5::Role; + use Moose::Role; +} +{ + package Bar5; + use Moose -traits => ['Foo5::Role']; +} +{ + package Baz5; + use Moose -traits => ['Foo5::Role']; + my $meta = __PACKAGE__->meta; + ::is( ::exception { $meta->superclasses('Foo4') }, undef, "can set superclasses once" ); + ::isa_ok($meta, Foo4->meta->_get_mutable_metaclass_name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo4::Role', 'Foo5::Role'], + "reconciled roles correctly"); + ::is( ::exception { $meta->superclasses('Bar5') }, undef, "can still set superclasses" ); + ::isa_ok($meta, Bar5->meta->meta->name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo4::Role', 'Foo5::Role'], + "roles still the same"); + ::ok(!$meta->is_immutable, + "immutable superclass doesn't make this class immutable"); + ::is( ::exception { $meta->make_immutable }, undef, "can still make immutable" ); +} +{ + package Quux5; + use Moose; +} +{ + package Quuux5; + use Moose -traits => ['Foo5::Role']; + my $meta = __PACKAGE__->meta; + ::is( ::exception { $meta->superclasses('Foo4') }, undef, "can set superclasses once" ); + ::isa_ok($meta, Foo4->meta->_get_mutable_metaclass_name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo4::Role', 'Foo5::Role'], + "reconciled roles correctly"); + ::is( ::exception { $meta->superclasses('Quux5') }, undef, "can still set superclasses" ); + ::isa_ok($meta, Quux5->meta->meta->name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo4::Role', 'Foo5::Role'], + "roles still the same"); + ::ok(!$meta->is_immutable, + "immutable superclass doesn't make this class immutable"); + ::is( ::exception { $meta->make_immutable }, undef, "can still make immutable" ); +} + +{ + package Foo5::Meta::Role; + use Moose::Role; +} +{ + package Foo5::SuperClass::WithMetaRole; + use Moose -traits =>'Foo5::Meta::Role'; +} +{ + package Foo5::SuperClass::After::Attribute; + use Moose; +} +{ + package Foo5; + use Moose; + my @superclasses = ('Foo5::SuperClass::WithMetaRole'); + extends @superclasses; + + has an_attribute_generating_methods => ( is => 'ro' ); + + push(@superclasses, 'Foo5::SuperClass::After::Attribute'); + + ::is( ::exception { + extends @superclasses; + }, undef, 'MI extends after_generated_methods with metaclass roles' ); + ::is( ::exception { + extends reverse @superclasses; + }, undef, 'MI extends after_generated_methods with metaclass roles (reverse)' ); +} + +{ + package Foo6::Meta::Role; + use Moose::Role; +} +{ + package Foo6::SuperClass::WithMetaRole; + use Moose -traits =>'Foo6::Meta::Role'; +} +{ + package Foo6::Meta::OtherRole; + use Moose::Role; +} +{ + package Foo6::SuperClass::After::Attribute; + use Moose -traits =>'Foo6::Meta::OtherRole'; +} +{ + package Foo6; + use Moose; + my @superclasses = ('Foo6::SuperClass::WithMetaRole'); + extends @superclasses; + + has an_attribute_generating_methods => ( is => 'ro' ); + + push(@superclasses, 'Foo6::SuperClass::After::Attribute'); + + ::like( ::exception { + extends @superclasses; + }, qr/compat.*pristine/, 'unsafe MI extends after_generated_methods with metaclass roles' ); + ::like( ::exception { + extends reverse @superclasses; + }, qr/compat.*pristine/, 'unsafe MI extends after_generated_methods with metaclass roles (reverse)' ); +} + +{ + package Foo7::Meta::Trait; + use Moose::Role; +} + +{ + package Foo7; + use Moose -traits => ['Foo7::Meta::Trait']; +} + +{ + package Bar7; + # in an external file + use Moose -traits => ['Bar7::Meta::Trait']; + ::is( ::exception { extends 'Foo7' }, undef, "role reconciliation works" ); +} + +{ + package Bar72; + # in an external file + use Moose -traits => ['Bar7::Meta::Trait2']; + ::is( ::exception { extends 'Foo7' }, undef, "role reconciliation works" ); +} + +done_testing; diff --git a/t/metaclasses/metaclass_compat_no_fixing_bug.t b/t/metaclasses/metaclass_compat_no_fixing_bug.t new file mode 100644 index 0000000..19ec76a --- /dev/null +++ b/t/metaclasses/metaclass_compat_no_fixing_bug.t @@ -0,0 +1,45 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +{ + package Foo::Meta::Constructor1; + use Moose::Role; +} + +{ + package Foo::Meta::Constructor2; + use Moose::Role; +} + +{ + package Foo; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { constructor => ['Foo::Meta::Constructor1'] }, + ); +} + +{ + package Foo::Sub; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { constructor => ['Foo::Meta::Constructor2'] }, + ); + extends 'Foo'; +} + +{ + package Foo::Sub::Sub; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { constructor => ['Foo::Meta::Constructor2'] }, + ); + ::is( ::exception { extends 'Foo::Sub' }, undef, "doesn't try to fix if nothing is needed" ); +} + +done_testing; diff --git a/t/metaclasses/metaclass_compat_role_conflicts.t b/t/metaclasses/metaclass_compat_role_conflicts.t new file mode 100644 index 0000000..13cd150 --- /dev/null +++ b/t/metaclasses/metaclass_compat_role_conflicts.t @@ -0,0 +1,63 @@ +use strict; +use warnings; +use Test::More; + +BEGIN { + package My::Meta::Role1; + use Moose::Role; + sub foo { 'Role1' } +} +BEGIN { + package My::Meta::Role2; + use Moose::Role; + with 'My::Meta::Role1'; + sub foo { 'Role2' } +} +BEGIN { + package My::Extension; + use Moose::Exporter; + Moose::Exporter->setup_import_methods( + class_metaroles => { + class => ['My::Meta::Role2'], + }, + ); + $INC{'My/Extension.pm'} = __FILE__; +} +BEGIN { + package My::Meta::Role3; + use Moose::Role; +} +BEGIN { + package My::Extension2; + use Moose::Exporter; + Moose::Exporter->setup_import_methods( + class_metaroles => { + class => ['My::Meta::Role3'], + }, + ); + $INC{'My/Extension2.pm'} = __FILE__; +} + +{ + package My::Class1; + use Moose; + use My::Extension; +} + +is(My::Class1->new->meta->foo, 'Role2'); + +{ + package My::Class2; + use Moose; + use My::Extension2; +} +{ + package My::Class3; + use Moose; + use My::Extension; + extends 'My::Class2'; +} + +is(My::Class3->new->meta->foo, 'Role2'); + +done_testing; diff --git a/t/metaclasses/metaclass_parameterized_traits.t b/t/metaclasses/metaclass_parameterized_traits.t new file mode 100644 index 0000000..ca4b5a9 --- /dev/null +++ b/t/metaclasses/metaclass_parameterized_traits.t @@ -0,0 +1,47 @@ +use strict; +use warnings; +use Test::More; + +{ + package My::Trait; + use Moose::Role; + + sub reversed_name { + my $self = shift; + scalar reverse $self->name; + } +} + +{ + package My::Class; + use Moose -traits => [ + 'My::Trait' => { + -alias => { + reversed_name => 'enam', + }, + }, + ]; +} + +{ + package My::Other::Class; + use Moose -traits => [ + 'My::Trait' => { + -alias => { + reversed_name => 'reversed', + }, + -excludes => 'reversed_name', + }, + ]; +} + +my $meta = My::Class->meta; +is($meta->enam, 'ssalC::yM', 'parameterized trait applied'); +ok(!$meta->can('reversed'), "the method was not installed under the other class' alias"); + +my $other_meta = My::Other::Class->meta; +is($other_meta->reversed, 'ssalC::rehtO::yM', 'parameterized trait applied'); +ok(!$other_meta->can('enam'), "the method was not installed under the other class' alias"); +ok(!$other_meta->can('reversed_name'), "the method was not installed under the original name when that was excluded"); + +done_testing; diff --git a/t/metaclasses/metaclass_traits.t b/t/metaclasses/metaclass_traits.t new file mode 100644 index 0000000..bcb9f90 --- /dev/null +++ b/t/metaclasses/metaclass_traits.t @@ -0,0 +1,224 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Test::More; +use Test::Fatal; + +{ + package My::SimpleTrait; + + use Moose::Role; + + sub simple { return 5 } +} + +{ + package Foo; + + use Moose -traits => [ 'My::SimpleTrait' ]; +} + +can_ok( Foo->meta(), 'simple' ); +is( Foo->meta()->simple(), 5, + 'Foo->meta()->simple() returns expected value' ); + +{ + package Bar; + + use Moose -traits => 'My::SimpleTrait'; +} + +can_ok( Bar->meta(), 'simple' ); +is( Bar->meta()->simple(), 5, + 'Foo->meta()->simple() returns expected value' ); + +{ + package My::SimpleTrait2; + + use Moose::Role; + + # This needs to happen at compile time so it happens before we + # apply traits to Bar + BEGIN { + has 'attr' => + ( is => 'ro', + default => 'something', + ); + } + + sub simple { return 5 } +} + +{ + package Bar; + + use Moose -traits => [ 'My::SimpleTrait2' ]; +} + +can_ok( Bar->meta(), 'simple' ); +is( Bar->meta()->simple(), 5, + 'Bar->meta()->simple() returns expected value' ); +can_ok( Bar->meta(), 'attr' ); +is( Bar->meta()->attr(), 'something', + 'Bar->meta()->attr() returns expected value' ); + +{ + package My::SimpleTrait3; + + use Moose::Role; + + BEGIN { + has 'attr2' => + ( is => 'ro', + default => 'something', + ); + } + + sub simple2 { return 55 } +} + +{ + package Baz; + + use Moose -traits => [ 'My::SimpleTrait2', 'My::SimpleTrait3' ]; +} + +can_ok( Baz->meta(), 'simple' ); +is( Baz->meta()->simple(), 5, + 'Baz->meta()->simple() returns expected value' ); +can_ok( Baz->meta(), 'attr' ); +is( Baz->meta()->attr(), 'something', + 'Baz->meta()->attr() returns expected value' ); +can_ok( Baz->meta(), 'simple2' ); +is( Baz->meta()->simple2(), 55, + 'Baz->meta()->simple2() returns expected value' ); +can_ok( Baz->meta(), 'attr2' ); +is( Baz->meta()->attr2(), 'something', + 'Baz->meta()->attr2() returns expected value' ); + +{ + package My::Trait::AlwaysRO; + + use Moose::Role; + + around '_process_new_attribute', '_process_inherited_attribute' => + sub { + my $orig = shift; + my ( $self, $name, %args ) = @_; + + $args{is} = 'ro'; + + return $self->$orig( $name, %args ); + }; +} + +{ + package Quux; + + use Moose -traits => [ 'My::Trait::AlwaysRO' ]; + + has 'size' => + ( is => 'rw', + isa => 'Int', + ); +} + +ok( Quux->meta()->has_attribute('size'), + 'Quux has size attribute' ); +ok( ! Quux->meta()->get_attribute('size')->writer(), + 'size attribute does not have a writer' ); + +{ + package My::Class::Whatever; + + use Moose::Role; + + sub whatever { 42 } + + package Moose::Meta::Class::Custom::Trait::Whatever; + + sub register_implementation { + return 'My::Class::Whatever'; + } +} + +{ + package RanOutOfNames; + + use Moose -traits => [ 'Whatever' ]; +} + +ok( RanOutOfNames->meta()->meta()->has_method('whatever'), + 'RanOutOfNames->meta() has whatever method' ); + +{ + package Role::Foo; + + use Moose::Role -traits => [ 'My::SimpleTrait' ]; +} + +can_ok( Role::Foo->meta(), 'simple' ); +is( Role::Foo->meta()->simple(), 5, + 'Role::Foo->meta()->simple() returns expected value' ); + +{ + require Moose::Util::TypeConstraints; + like( + exception { + Moose::Util::TypeConstraints->import( + -traits => 'My::SimpleTrait' ); + }, + qr/does not have an init_meta/, + 'cannot provide -traits to an exporting module that does not init_meta' + ); +} + +{ + package Foo::Subclass; + + use Moose -traits => [ 'My::SimpleTrait3' ]; + + extends 'Foo'; +} + +can_ok( Foo::Subclass->meta(), 'simple' ); +is( Foo::Subclass->meta()->simple(), 5, + 'Foo::Subclass->meta()->simple() returns expected value' ); +is( Foo::Subclass->meta()->simple2(), 55, + 'Foo::Subclass->meta()->simple2() returns expected value' ); +can_ok( Foo::Subclass->meta(), 'attr2' ); +is( Foo::Subclass->meta()->attr2(), 'something', + 'Foo::Subclass->meta()->attr2() returns expected value' ); + +{ + + package Class::WithAlreadyPresentTrait; + use Moose -traits => 'My::SimpleTrait'; + + has an_attr => ( is => 'ro' ); +} + +is( exception { + my $instance = Class::WithAlreadyPresentTrait->new( an_attr => 'value' ); + is( $instance->an_attr, 'value', 'Can get value' ); +}, undef, 'Can create instance and access attributes' ); + +{ + + package Class::WhichLoadsATraitFromDisk; + + # Any role you like here, the only important bit is that it gets + # loaded from disk and has not already been defined. + use Moose -traits => 'Role::Parent'; + + has an_attr => ( is => 'ro' ); +} + +is( exception { + my $instance = Class::WhichLoadsATraitFromDisk->new( an_attr => 'value' ); + is( $instance->an_attr, 'value', 'Can get value' ); +}, undef, 'Can create instance and access attributes' ); + +done_testing; diff --git a/t/metaclasses/metarole.t b/t/metaclasses/metarole.t new file mode 100644 index 0000000..40f2420 --- /dev/null +++ b/t/metaclasses/metarole.t @@ -0,0 +1,725 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Test::More; +use Test::Fatal; + +use Moose::Util::MetaRole; + + +{ + package My::Meta::Class; + use Moose; + extends 'Moose::Meta::Class'; +} + +{ + package Role::Foo; + use Moose::Role; + has 'foo' => ( is => 'ro', default => 10 ); +} + +{ + package My::Class; + + use Moose; +} + +{ + package My::Role; + use Moose::Role; +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => My::Class->meta, + class_metaroles => { class => ['Role::Foo'] }, + ); + + ok( My::Class->meta()->meta()->does_role('Role::Foo'), + 'apply Role::Foo to My::Class->meta()' ); + is( My::Class->meta()->foo(), 10, + '... and call foo() on that meta object' ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class', + class_metaroles => { attribute => ['Role::Foo'] }, + ); + + ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class->meta()'s attribute metaclass} ); + ok( My::Class->meta()->meta()->does_role('Role::Foo'), + '... My::Class->meta() still does Role::Foo' ); + + My::Class->meta()->add_attribute( 'size', is => 'ro' ); + is( My::Class->meta()->get_attribute('size')->foo(), 10, + '... call foo() on an attribute metaclass object' ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class', + class_metaroles => { method => ['Role::Foo'] }, + ); + + ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class->meta()'s method metaclass} ); + ok( My::Class->meta()->meta()->does_role('Role::Foo'), + '... My::Class->meta() still does Role::Foo' ); + ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), + q{... My::Class->meta()'s attribute metaclass still does Role::Foo} ); + + My::Class->meta()->add_method( 'bar' => sub { 'bar' } ); + is( My::Class->meta()->get_method('bar')->foo(), 10, + '... call foo() on a method metaclass object' ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class', + class_metaroles => { wrapped_method => ['Role::Foo'] }, + ); + + ok( My::Class->meta()->wrapped_method_metaclass()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class->meta()'s wrapped method metaclass} ); + ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'), + '... My::Class->meta() still does Role::Foo' ); + ok( My::Class->meta()->meta()->does_role('Role::Foo'), + '... My::Class->meta() still does Role::Foo' ); + ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), + q{... My::Class->meta()'s attribute metaclass still does Role::Foo} ); + + My::Class->meta()->add_after_method_modifier( 'bar' => sub { 'bar' } ); + is( My::Class->meta()->get_method('bar')->foo(), 10, + '... call foo() on a wrapped method metaclass object' ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class', + class_metaroles => { instance => ['Role::Foo'] }, + ); + + ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class->meta()'s instance metaclass} ); + ok( My::Class->meta()->meta()->does_role('Role::Foo'), + '... My::Class->meta() still does Role::Foo' ); + ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), + q{... My::Class->meta()'s attribute metaclass still does Role::Foo} ); + ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'), + q{... My::Class->meta()'s method metaclass still does Role::Foo} ); + + is( My::Class->meta()->get_meta_instance()->foo(), 10, + '... call foo() on an instance metaclass object' ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class', + class_metaroles => { constructor => ['Role::Foo'] }, + ); + + ok( My::Class->meta()->constructor_class()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class->meta()'s constructor class} ); + ok( My::Class->meta()->meta()->does_role('Role::Foo'), + '... My::Class->meta() still does Role::Foo' ); + ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), + q{... My::Class->meta()'s attribute metaclass still does Role::Foo} ); + ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'), + q{... My::Class->meta()'s method metaclass still does Role::Foo} ); + ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'), + q{... My::Class->meta()'s instance metaclass still does Role::Foo} ); + + # Actually instantiating the constructor class is too freaking hard! + ok( My::Class->meta()->constructor_class()->can('foo'), + '... constructor class has a foo method' ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class', + class_metaroles => { destructor => ['Role::Foo'] }, + ); + + ok( My::Class->meta()->destructor_class()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class->meta()'s destructor class} ); + ok( My::Class->meta()->meta()->does_role('Role::Foo'), + '... My::Class->meta() still does Role::Foo' ); + ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), + q{... My::Class->meta()'s attribute metaclass still does Role::Foo} ); + ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'), + q{... My::Class->meta()'s method metaclass still does Role::Foo} ); + ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'), + q{... My::Class->meta()'s instance metaclass still does Role::Foo} ); + ok( My::Class->meta()->constructor_class()->meta()->does_role('Role::Foo'), + q{... My::Class->meta()'s constructor class still does Role::Foo} ); + + # same problem as the constructor class + ok( My::Class->meta()->destructor_class()->can('foo'), + '... destructor class has a foo method' ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Role', + role_metaroles => { application_to_class => ['Role::Foo'] }, + ); + + ok( My::Role->meta->application_to_class_class->meta->does_role('Role::Foo'), + q{apply Role::Foo to My::Role->meta's application_to_class class} ); + + is( My::Role->meta->application_to_class_class->new->foo, 10, + q{... call foo() on an application_to_class instance} ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Role', + role_metaroles => { application_to_role => ['Role::Foo'] }, + ); + + ok( My::Role->meta->application_to_role_class->meta->does_role('Role::Foo'), + q{apply Role::Foo to My::Role->meta's application_to_role class} ); + ok( My::Role->meta->application_to_class_class->meta->does_role('Role::Foo'), + q{... My::Role->meta's application_to_class class still does Role::Foo} ); + + is( My::Role->meta->application_to_role_class->new->foo, 10, + q{... call foo() on an application_to_role instance} ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Role', + role_metaroles => { application_to_instance => ['Role::Foo'] }, + ); + + ok( My::Role->meta->application_to_instance_class->meta->does_role('Role::Foo'), + q{apply Role::Foo to My::Role->meta's application_to_instance class} ); + ok( My::Role->meta->application_to_role_class->meta->does_role('Role::Foo'), + q{... My::Role->meta's application_to_role class still does Role::Foo} ); + ok( My::Role->meta->application_to_class_class->meta->does_role('Role::Foo'), + q{... My::Role->meta's application_to_class class still does Role::Foo} ); + + is( My::Role->meta->application_to_instance_class->new->foo, 10, + q{... call foo() on an application_to_instance instance} ); +} + +{ + Moose::Util::MetaRole::apply_base_class_roles( + for => 'My::Class', + roles => ['Role::Foo'], + ); + + ok( My::Class->meta()->does_role('Role::Foo'), + 'apply Role::Foo to My::Class base class' ); + is( My::Class->new()->foo(), 10, + '... call foo() on a My::Class object' ); +} + +{ + package My::Class2; + + use Moose; +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class2', + class_metaroles => { + class => ['Role::Foo'], + attribute => ['Role::Foo'], + method => ['Role::Foo'], + instance => ['Role::Foo'], + constructor => ['Role::Foo'], + destructor => ['Role::Foo'], + }, + ); + + ok( My::Class2->meta()->meta()->does_role('Role::Foo'), + 'apply Role::Foo to My::Class2->meta()' ); + is( My::Class2->meta()->foo(), 10, + '... and call foo() on that meta object' ); + ok( My::Class2->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class2->meta()'s attribute metaclass} ); + My::Class2->meta()->add_attribute( 'size', is => 'ro' ); + + is( My::Class2->meta()->get_attribute('size')->foo(), 10, + '... call foo() on an attribute metaclass object' ); + + ok( My::Class2->meta()->method_metaclass()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class2->meta()'s method metaclass} ); + + My::Class2->meta()->add_method( 'bar' => sub { 'bar' } ); + is( My::Class2->meta()->get_method('bar')->foo(), 10, + '... call foo() on a method metaclass object' ); + + ok( My::Class2->meta()->instance_metaclass()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class2->meta()'s instance metaclass} ); + is( My::Class2->meta()->get_meta_instance()->foo(), 10, + '... call foo() on an instance metaclass object' ); + + ok( My::Class2->meta()->constructor_class()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class2->meta()'s constructor class} ); + ok( My::Class2->meta()->constructor_class()->can('foo'), + '... constructor class has a foo method' ); + + ok( My::Class2->meta()->destructor_class()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class2->meta()'s destructor class} ); + ok( My::Class2->meta()->destructor_class()->can('foo'), + '... destructor class has a foo method' ); +} + + +{ + package My::Meta; + + use Moose::Exporter; + Moose::Exporter->setup_import_methods( also => 'Moose' ); + + sub init_meta { + shift; + my %p = @_; + + Moose->init_meta( %p, metaclass => 'My::Meta::Class' ); + } +} + +{ + package My::Class3; + + My::Meta->import(); +} + + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class3', + class_metaroles => { class => ['Role::Foo'] }, + ); + + ok( My::Class3->meta()->meta()->does_role('Role::Foo'), + 'apply Role::Foo to My::Class3->meta()' ); + is( My::Class3->meta()->foo(), 10, + '... and call foo() on that meta object' ); + ok( ( grep { $_ eq 'My::Meta::Class' } My::Class3->meta()->meta()->superclasses() ), + 'apply_metaroles() does not interfere with metaclass set via Moose->init_meta()' ); +} + +{ + package Role::Bar; + use Moose::Role; + has 'bar' => ( is => 'ro', default => 200 ); +} + +{ + package My::Class4; + use Moose; +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class4', + class_metaroles => { class => ['Role::Foo'] }, + ); + + ok( My::Class4->meta()->meta()->does_role('Role::Foo'), + 'apply Role::Foo to My::Class4->meta()' ); + + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class4', + class_metaroles => { class => ['Role::Bar'] }, + ); + + ok( My::Class4->meta()->meta()->does_role('Role::Bar'), + 'apply Role::Bar to My::Class4->meta()' ); + ok( My::Class4->meta()->meta()->does_role('Role::Foo'), + '... and My::Class4->meta() still does Role::Foo' ); +} + +{ + package My::Class5; + use Moose; + + extends 'My::Class'; +} + +{ + ok( My::Class5->meta()->meta()->does_role('Role::Foo'), + q{My::Class5->meta()'s does Role::Foo because it extends My::Class} ); + ok( My::Class5->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), + q{My::Class5->meta()'s attribute metaclass also does Role::Foo} ); + ok( My::Class5->meta()->method_metaclass()->meta()->does_role('Role::Foo'), + q{My::Class5->meta()'s method metaclass also does Role::Foo} ); + ok( My::Class5->meta()->instance_metaclass()->meta()->does_role('Role::Foo'), + q{My::Class5->meta()'s instance metaclass also does Role::Foo} ); + ok( My::Class5->meta()->constructor_class()->meta()->does_role('Role::Foo'), + q{My::Class5->meta()'s constructor class also does Role::Foo} ); + ok( My::Class5->meta()->destructor_class()->meta()->does_role('Role::Foo'), + q{My::Class5->meta()'s destructor class also does Role::Foo} ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class5', + class_metaroles => { class => ['Role::Bar'] }, + ); + + ok( My::Class5->meta()->meta()->does_role('Role::Bar'), + q{apply Role::Bar My::Class5->meta()} ); + ok( My::Class5->meta()->meta()->does_role('Role::Foo'), + q{... and My::Class5->meta() still does Role::Foo} ); +} + +{ + package My::Class6; + use Moose; + + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class6', + class_metaroles => { class => ['Role::Bar'] }, + ); + + extends 'My::Class'; +} + +{ + ok( My::Class6->meta()->meta()->does_role('Role::Bar'), + q{apply Role::Bar My::Class6->meta() before extends} ); + ok( My::Class6->meta()->meta()->does_role('Role::Foo'), + q{... and My::Class6->meta() does Role::Foo because My::Class6 extends My::Class} ); +} + +# This is the hack that used to be needed to work around the +# _fix_metaclass_incompatibility problem. You called extends() (which +# in turn calls _fix_metaclass_imcompatibility) _before_ you apply +# more extensions in the subclass. We wabt to make sure this continues +# to work in the future. +{ + package My::Class7; + use Moose; + + # In real usage this would go in a BEGIN block so it happened + # before apply_metaroles was called by an extension. + extends 'My::Class'; + + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class7', + class_metaroles => { class => ['Role::Bar'] }, + ); +} + +{ + ok( My::Class7->meta()->meta()->does_role('Role::Bar'), + q{apply Role::Bar My::Class7->meta() before extends} ); + ok( My::Class7->meta()->meta()->does_role('Role::Foo'), + q{... and My::Class7->meta() does Role::Foo because My::Class7 extends My::Class} ); +} + +{ + package My::Class8; + use Moose; + + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class8', + class_metaroles => { + class => ['Role::Bar'], + attribute => ['Role::Bar'], + }, + ); + + extends 'My::Class'; +} + +{ + ok( My::Class8->meta()->meta()->does_role('Role::Bar'), + q{apply Role::Bar My::Class8->meta() before extends} ); + ok( My::Class8->meta()->meta()->does_role('Role::Foo'), + q{... and My::Class8->meta() does Role::Foo because My::Class8 extends My::Class} ); + ok( My::Class8->meta()->attribute_metaclass->meta()->does_role('Role::Bar'), + q{apply Role::Bar to My::Class8->meta()->attribute_metaclass before extends} ); + ok( My::Class8->meta()->attribute_metaclass->meta()->does_role('Role::Foo'), + q{... and My::Class8->meta()->attribute_metaclass does Role::Foo because My::Class8 extends My::Class} ); +} + + +{ + package My::Class9; + use Moose; + + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class9', + class_metaroles => { attribute => ['Role::Bar'] }, + ); + + extends 'My::Class'; +} + +{ + ok( My::Class9->meta()->meta()->does_role('Role::Foo'), + q{... and My::Class9->meta() does Role::Foo because My::Class9 extends My::Class} ); + ok( My::Class9->meta()->attribute_metaclass->meta()->does_role('Role::Bar'), + q{apply Role::Bar to My::Class9->meta()->attribute_metaclass before extends} ); + ok( My::Class9->meta()->attribute_metaclass->meta()->does_role('Role::Foo'), + q{... and My::Class9->meta()->attribute_metaclass does Role::Foo because My::Class9 extends My::Class} ); +} + +# This tests applying meta roles to a metaclass's metaclass. This is +# completely insane, but is exactly what happens with +# Fey::Meta::Class::Table. It's a subclass of Moose::Meta::Class +# itself, and then it _uses_ MooseX::ClassAttribute, so the metaclass +# for Fey::Meta::Class::Table does a role. +# +# At one point this caused a metaclass incompatibility error down +# below, when we applied roles to the metaclass of My::Class10. It's +# all madness but as long as the tests pass we're happy. +{ + package My::Meta::Class2; + use Moose; + extends 'Moose::Meta::Class'; + + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Meta::Class2', + class_metaroles => { class => ['Role::Foo'] }, + ); +} + +{ + package My::Object; + use Moose; + extends 'Moose::Object'; +} + +{ + package My::Meta2; + + use Moose::Exporter; + Moose::Exporter->setup_import_methods( also => 'Moose' ); + + sub init_meta { + shift; + my %p = @_; + + Moose->init_meta( + %p, + metaclass => 'My::Meta::Class2', + base_class => 'My::Object', + ); + } +} + +{ + package My::Class10; + My::Meta2->import; + + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class10', + class_metaroles => { class => ['Role::Bar'] }, + ); +} + +{ + ok( My::Class10->meta()->meta()->meta()->does_role('Role::Foo'), + q{My::Class10->meta()->meta() does Role::Foo } ); + ok( My::Class10->meta()->meta()->does_role('Role::Bar'), + q{My::Class10->meta()->meta() does Role::Bar } ); + ok( My::Class10->meta()->isa('My::Meta::Class2'), + q{... and My::Class10->meta still isa(My::Meta::Class2)} ); + ok( My::Class10->isa('My::Object'), + q{... and My::Class10 still isa(My::Object)} ); +} + +{ + package My::Constructor; + + use parent 'Moose::Meta::Method::Constructor'; +} + +{ + package My::Class11; + + use Moose; + + __PACKAGE__->meta->constructor_class('My::Constructor'); + + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class11', + class_metaroles => { class => ['Role::Foo'] }, + ); +} + +{ + ok( My::Class11->meta()->meta()->does_role('Role::Foo'), + q{My::Class11->meta()->meta() does Role::Foo } ); + is( My::Class11->meta()->constructor_class, 'My::Constructor', + q{... and explicitly set constructor_class value is unchanged)} ); +} + +{ + package ExportsMoose; + + Moose::Exporter->setup_import_methods( + also => 'Moose', + ); + + sub init_meta { + shift; + my %p = @_; + Moose->init_meta(%p); + return Moose::Util::MetaRole::apply_metaroles( + for => $p{for_class}, + # Causes us to recurse through init_meta, as we have to + # load MyMetaclassRole from disk. + class_metaroles => { class => [qw/MyMetaclassRole/] }, + ); + } +} + +is( exception { + package UsesExportedMoose; + ExportsMoose->import; +}, undef, 'import module which loads a role from disk during init_meta' ); + +{ + package Foo::Meta::Role; + + use Moose::Role; +} + +{ + package Foo::Role; + + Moose::Exporter->setup_import_methods( + also => 'Moose::Role', + ); + + sub init_meta { + shift; + my %p = @_; + + Moose::Role->init_meta(%p); + + return Moose::Util::MetaRole::apply_metaroles( + for => $p{for_class}, + role_metaroles => { method => ['Foo::Meta::Role'] }, + ); + } +} + +{ + package Role::Baz; + + Foo::Role->import; + + sub bla {} +} + +{ + package My::Class12; + + use Moose; + + with( 'Role::Baz' ); +} + +{ + ok( + My::Class12->meta->does_role( 'Role::Baz' ), + 'role applied' + ); + + my $method = My::Class12->meta->get_method( 'bla' ); + ok( + $method->meta->does_role( 'Foo::Meta::Role' ), + 'method_metaclass_role applied' + ); +} + +{ + package Parent; + use Moose; + + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { constructor => ['Role::Foo'] }, + ); +} + +{ + package Child; + + use Moose; + extends 'Parent'; +} + +{ + ok( + Parent->meta->constructor_class->meta->can('does_role') + && Parent->meta->constructor_class->meta->does_role('Role::Foo'), + 'Parent constructor class has metarole from Parent' + ); + + ok( + Child->meta->constructor_class->meta->can('does_role') + && Child->meta->constructor_class->meta->does_role( + 'Role::Foo'), + 'Child constructor class has metarole from Parent' + ); +} + +{ + package NotMoosey; + + use metaclass; +} + +{ + like( + exception { + Moose::Util::MetaRole::apply_metaroles( + for => 'Does::Not::Exist', + class_metaroles => { class => ['Role::Foo'] }, + ); + }, + qr/When using Moose::Util::MetaRole.+You passed Does::Not::Exist.+Maybe you need to call.+/, + 'useful error when apply metaroles to a class without a metaclass' + ); + + like( + exception { + Moose::Util::MetaRole::apply_metaroles( + for => 'NotMoosey', + class_metaroles => { class => ['Role::Foo'] }, + ); + }, + qr/When using Moose::Util::MetaRole.+You passed NotMoosey.+we resolved this to a Class::MOP::Class object.+/, + 'useful error when using apply metaroles to a class with a Class::MOP::Class metaclass' + ); + + like( + exception { + Moose::Util::MetaRole::apply_base_class_roles( + for => 'NotMoosey', + roles => { class => ['Role::Foo'] }, + ); + }, + qr/When using Moose::Util::MetaRole.+You passed NotMoosey.+we resolved this to a Class::MOP::Class object.+/, + 'useful error when applying base class to roles to a non-Moose class' + ); + + like( + exception { + Moose::Util::MetaRole::apply_base_class_roles( + for => 'My::Role', + roles => { class => ['Role::Foo'] }, + ); + }, + qr/You can only apply base class roles to a Moose class.+/, + 'useful error when applying base class to roles to a non-Moose class' + ); +} + +done_testing; diff --git a/t/metaclasses/metarole_combination.t b/t/metaclasses/metarole_combination.t new file mode 100644 index 0000000..31a8ed8 --- /dev/null +++ b/t/metaclasses/metarole_combination.t @@ -0,0 +1,238 @@ +use strict; +use warnings; +use Test::More; + +our @applications; + +{ + package CustomApplication; + use Moose::Role; + + after apply_methods => sub { + my ( $self, $role, $other ) = @_; + $self->apply_custom( $role, $other ); + }; + + sub apply_custom { + shift; + push @applications, [@_]; + } +} + +{ + package CustomApplication::ToClass; + use Moose::Role; + + with 'CustomApplication'; +} + +{ + package CustomApplication::ToRole; + use Moose::Role; + + with 'CustomApplication'; +} + +{ + package CustomApplication::ToInstance; + use Moose::Role; + + with 'CustomApplication'; +} + +{ + package CustomApplication::Composite; + use Moose::Role; + + with 'CustomApplication'; + + around apply_custom => sub { + my ( $next, $self, $composite, $other ) = @_; + for my $role ( @{ $composite->get_roles } ) { + $self->$next( $role, $other ); + } + }; +} + +{ + package CustomApplication::Composite::ToClass; + use Moose::Role; + + with 'CustomApplication::Composite'; +} + +{ + package CustomApplication::Composite::ToRole; + use Moose::Role; + + with 'CustomApplication::Composite'; +} + +{ + package CustomApplication::Composite::ToInstance; + use Moose::Role; + + with 'CustomApplication::Composite'; +} + +{ + package Role::Composite; + use Moose::Role; + + around apply_params => sub { + my ( $next, $self, @args ) = @_; + return Moose::Util::MetaRole::apply_metaroles( + for => $self->$next(@args), + role_metaroles => { + application_to_class => + ['CustomApplication::Composite::ToClass'], + application_to_role => + ['CustomApplication::Composite::ToRole'], + application_to_instance => + ['CustomApplication::Composite::ToInstance'], + }, + ); + }; +} + +{ + package Role::WithCustomApplication; + use Moose::Role; + + around composition_class_roles => sub { + my ($orig, $self) = @_; + return $self->$orig, 'Role::Composite'; + }; +} + +{ + package CustomRole; + Moose::Exporter->setup_import_methods( + also => 'Moose::Role', + ); + + sub init_meta { + my ( $self, %options ) = @_; + return Moose::Util::MetaRole::apply_metaroles( + for => Moose::Role->init_meta(%options), + role_metaroles => { + role => ['Role::WithCustomApplication'], + application_to_class => + ['CustomApplication::ToClass'], + application_to_role => ['CustomApplication::ToRole'], + application_to_instance => + ['CustomApplication::ToInstance'], + }, + ); + } +} + +{ + package My::Role::Normal; + use Moose::Role; +} + +{ + package My::Role::Special; + CustomRole->import; +} + +ok( My::Role::Normal->meta->isa('Moose::Meta::Role'), "sanity check" ); +ok( My::Role::Special->meta->isa('Moose::Meta::Role'), + "using custom application roles does not change the role metaobject's class" +); +ok( My::Role::Special->meta->meta->does_role('Role::WithCustomApplication'), + "the role's metaobject has custom applications" ); +is_deeply( [My::Role::Special->meta->composition_class_roles], + ['Role::Composite'], + "the role knows about the specified composition class" ); + +{ + package Foo; + use Moose; + + local @applications; + with 'My::Role::Special'; + + ::is( @applications, 1, 'one role application' ); + ::is( $applications[0]->[0]->name, 'My::Role::Special', + "the application's first role was My::Role::Special'" ); + ::is( $applications[0]->[1]->name, 'Foo', + "the application provided an additional role" ); +} + +{ + package Bar; + use Moose::Role; + + local @applications; + with 'My::Role::Special'; + + ::is( @applications, 1 ); + ::is( $applications[0]->[0]->name, 'My::Role::Special' ); + ::is( $applications[0]->[1]->name, 'Bar' ); +} + +{ + package Baz; + use Moose; + + my $i = Baz->new; + local @applications; + My::Role::Special->meta->apply($i); + + ::is( @applications, 1 ); + ::is( $applications[0]->[0]->name, 'My::Role::Special' ); + ::ok( $applications[0]->[1]->is_anon_class ); + ::ok( $applications[0]->[1]->name->isa('Baz') ); +} + +{ + package Corge; + use Moose; + + local @applications; + with 'My::Role::Normal', 'My::Role::Special'; + + ::is( @applications, 2 ); + ::is( $applications[0]->[0]->name, 'My::Role::Normal' ); + ::is( $applications[0]->[1]->name, 'Corge' ); + ::is( $applications[1]->[0]->name, 'My::Role::Special' ); + ::is( $applications[1]->[1]->name, 'Corge' ); +} + +{ + package Thud; + use Moose::Role; + + local @applications; + with 'My::Role::Normal', 'My::Role::Special'; + + ::is( @applications, 2 ); + ::is( $applications[0]->[0]->name, 'My::Role::Normal' ); + ::is( $applications[0]->[1]->name, 'Thud' ); + ::is( $applications[1]->[0]->name, 'My::Role::Special' ); + ::is( $applications[1]->[1]->name, 'Thud' ); +} + +{ + package Garply; + use Moose; + + my $i = Garply->new; + local @applications; + Moose::Meta::Role->combine( + [ 'My::Role::Normal' => undef ], + [ 'My::Role::Special' => undef ], + )->apply($i); + + ::is( @applications, 2 ); + ::is( $applications[0]->[0]->name, 'My::Role::Normal' ); + ::ok( $applications[0]->[1]->is_anon_class ); + ::ok( $applications[0]->[1]->name->isa('Garply') ); + ::is( $applications[1]->[0]->name, 'My::Role::Special' ); + ::ok( $applications[1]->[1]->is_anon_class ); + ::ok( $applications[1]->[1]->name->isa('Garply') ); +} + +done_testing; diff --git a/t/metaclasses/metarole_on_anon.t b/t/metaclasses/metarole_on_anon.t new file mode 100644 index 0000000..816e6b4 --- /dev/null +++ b/t/metaclasses/metarole_on_anon.t @@ -0,0 +1,51 @@ +use strict; +use warnings; + +use Test::More; + +use Moose (); +use Moose::Meta::Class; +use Moose::Util::MetaRole; + +{ + package Foo; + use Moose; +} + +{ + package Role::Bar; + use Moose::Role; +} + +my $anon_name; + +{ + my $anon_class = Moose::Meta::Class->create_anon_class( + superclasses => ['Foo'], + cache => 1, + ); + + $anon_name = $anon_class->name; + + ok( $anon_name->meta, 'anon class has a metaclass' ); +} + +ok( + $anon_name->meta, + 'cached anon class still has a metaclass after \$anon_class goes out of scope' +); + +Moose::Util::MetaRole::apply_metaroles( + for => $anon_name, + class_metaroles => { + class => ['Role::Bar'], + }, +); + +BAIL_OUT('Cannot continue if the anon class does not have a metaclass') + unless $anon_name->can('meta'); + +my $meta = $anon_name->meta; +ok( $meta, 'cached anon class still has a metaclass applying a metarole' ); + +done_testing; diff --git a/t/metaclasses/metarole_w_metaclass_pm.t b/t/metaclasses/metarole_w_metaclass_pm.t new file mode 100644 index 0000000..c47a208 --- /dev/null +++ b/t/metaclasses/metarole_w_metaclass_pm.t @@ -0,0 +1,111 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util::MetaRole; + +BEGIN +{ + package My::Meta::Class; + use Moose; + extends 'Moose::Meta::Class'; +} + +BEGIN +{ + package My::Meta::Attribute; + use Moose; + extends 'Moose::Meta::Attribute'; +} + +BEGIN +{ + package My::Meta::Method; + use Moose; + extends 'Moose::Meta::Method'; +} + +BEGIN +{ + package My::Meta::Instance; + use Moose; + extends 'Moose::Meta::Instance'; +} + +BEGIN +{ + package Role::Foo; + use Moose::Role; + has 'foo' => ( is => 'ro', default => 10 ); +} + +{ + package My::Class; + + use metaclass 'My::Meta::Class'; + use Moose; +} + +{ + package My::Class2; + + use metaclass 'My::Meta::Class' => ( + attribute_metaclass => 'My::Meta::Attribute', + method_metaclass => 'My::Meta::Method', + instance_metaclass => 'My::Meta::Instance', + ); + + use Moose; +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class', + class_metaroles => { class => ['Role::Foo'] }, + ); + + ok( My::Class->meta()->meta()->does_role('Role::Foo'), + 'apply Role::Foo to My::Class->meta()' ); + has_superclass( My::Class->meta(), 'My::Meta::Class', + 'apply_metaroles works with metaclass.pm' ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class2', + class_metaroles => { + attribute => ['Role::Foo'], + method => ['Role::Foo'], + instance => ['Role::Foo'], + }, + ); + + ok( My::Class2->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class2->meta()'s attribute metaclass} ); + has_superclass( My::Class2->meta()->attribute_metaclass(), 'My::Meta::Attribute', + '... and this does not interfere with attribute metaclass set via metaclass.pm' ); + ok( My::Class2->meta()->method_metaclass()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class2->meta()'s method metaclass} ); + has_superclass( My::Class2->meta()->method_metaclass(), 'My::Meta::Method', + '... and this does not interfere with method metaclass set via metaclass.pm' ); + ok( My::Class2->meta()->instance_metaclass()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class2->meta()'s instance metaclass} ); + has_superclass( My::Class2->meta()->instance_metaclass(), 'My::Meta::Instance', + '... and this does not interfere with instance metaclass set via metaclass.pm' ); +} + +# like isa_ok but works with a class name, not just refs +sub has_superclass { + my $thing = shift; + my $parent = shift; + my $desc = shift; + + my %supers = map { $_ => 1 } $thing->meta()->superclasses(); + + local $Test::Builder::Level = $Test::Builder::Level + 1; + + ok( $supers{$parent}, $desc ); +} + +done_testing; diff --git a/t/metaclasses/metaroles_of_metaroles.t b/t/metaclasses/metaroles_of_metaroles.t new file mode 100644 index 0000000..d8533c7 --- /dev/null +++ b/t/metaclasses/metaroles_of_metaroles.t @@ -0,0 +1,67 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +{ + package ApplicationMetaRole; + use Moose::Role; + use Moose::Util::MetaRole; + + after apply => sub { + my ($self, $role_source, $role_dest, $args) = @_; + Moose::Util::MetaRole::apply_metaroles + ( + for => $role_dest, + role_metaroles => + { + application_to_role => ['ApplicationMetaRole'], + } + ); + }; +} +{ + package MyMetaRole; + use Moose::Role; + use Moose::Util::MetaRole; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods(also => q<Moose::Role>); + + sub init_meta { + my ($class, %opts) = @_; + Moose::Role->init_meta(%opts); + Moose::Util::MetaRole::apply_metaroles + ( + for => $opts{for_class}, + role_metaroles => + { + application_to_role => ['ApplicationMetaRole'], + } + ); + return $opts{for_class}->meta(); + }; +} + +{ + package MyRole; + use Moose::Role; + + MyMetaRole->import; + + use Moose::Util::TypeConstraints; + + has schema => ( + is => 'ro', + coerce => 1, + ); +} + +{ + package MyTargetRole; + use Moose::Role; + ::is(::exception { with "MyRole" }, undef, + "apply a meta role to a role, which is then applied to yet another role"); +} + +done_testing; diff --git a/t/metaclasses/moose_exporter.t b/t/metaclasses/moose_exporter.t new file mode 100644 index 0000000..dde583a --- /dev/null +++ b/t/metaclasses/moose_exporter.t @@ -0,0 +1,677 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::Moose; +use Test::Requires 'Test::Output'; # skip all if not installed + +{ + package HasOwnImmutable; + + use Moose; + + no Moose; + + ::stderr_is( sub { eval q[sub make_immutable { return 'foo' }] }, + '', + 'no warning when defining our own make_immutable sub' ); +} + +{ + is( HasOwnImmutable->make_immutable(), 'foo', + 'HasOwnImmutable->make_immutable does not get overwritten' ); +} + +{ + package MooseX::Empty; + + use Moose (); + Moose::Exporter->setup_import_methods( also => 'Moose' ); +} + +{ + package WantsMoose; + + MooseX::Empty->import(); + + sub foo { 1 } + + ::can_ok( 'WantsMoose', 'has' ); + ::can_ok( 'WantsMoose', 'with' ); + ::can_ok( 'WantsMoose', 'foo' ); + + MooseX::Empty->unimport(); +} + +{ + # Note: it's important that these methods be out of scope _now_, + # after unimport was called. We tried a + # namespace::clean(0.08)-based solution, but had to abandon it + # because it cleans the namespace _later_ (when the file scope + # ends). + ok( ! WantsMoose->can('has'), 'WantsMoose::has() has been cleaned' ); + ok( ! WantsMoose->can('with'), 'WantsMoose::with() has been cleaned' ); + can_ok( 'WantsMoose', 'foo' ); + + # This makes sure that Moose->init_meta() happens properly + isa_ok( WantsMoose->meta(), 'Moose::Meta::Class' ); + isa_ok( WantsMoose->new(), 'Moose::Object' ); + +} + +{ + package MooseX::Sugar; + + use Moose (); + + sub wrapped1 { + my $meta = shift; + return $meta->name . ' called wrapped1'; + } + + Moose::Exporter->setup_import_methods( + with_meta => ['wrapped1'], + also => 'Moose', + ); +} + +{ + package WantsSugar; + + MooseX::Sugar->import(); + + sub foo { 1 } + + ::can_ok( 'WantsSugar', 'has' ); + ::can_ok( 'WantsSugar', 'with' ); + ::can_ok( 'WantsSugar', 'wrapped1' ); + ::can_ok( 'WantsSugar', 'foo' ); + ::is( wrapped1(), 'WantsSugar called wrapped1', + 'wrapped1 identifies the caller correctly' ); + + MooseX::Sugar->unimport(); +} + +{ + ok( ! WantsSugar->can('has'), 'WantsSugar::has() has been cleaned' ); + ok( ! WantsSugar->can('with'), 'WantsSugar::with() has been cleaned' ); + ok( ! WantsSugar->can('wrapped1'), 'WantsSugar::wrapped1() has been cleaned' ); + can_ok( 'WantsSugar', 'foo' ); +} + +{ + package MooseX::MoreSugar; + + use Moose (); + + sub wrapped2 { + my $caller = shift->name; + return $caller . ' called wrapped2'; + } + + sub as_is1 { + return 'as_is1'; + } + + Moose::Exporter->setup_import_methods( + with_meta => ['wrapped2'], + as_is => ['as_is1'], + also => 'MooseX::Sugar', + ); +} + +{ + package WantsMoreSugar; + + MooseX::MoreSugar->import(); + + sub foo { 1 } + + ::can_ok( 'WantsMoreSugar', 'has' ); + ::can_ok( 'WantsMoreSugar', 'with' ); + ::can_ok( 'WantsMoreSugar', 'wrapped1' ); + ::can_ok( 'WantsMoreSugar', 'wrapped2' ); + ::can_ok( 'WantsMoreSugar', 'as_is1' ); + ::can_ok( 'WantsMoreSugar', 'foo' ); + ::is( wrapped1(), 'WantsMoreSugar called wrapped1', + 'wrapped1 identifies the caller correctly' ); + ::is( wrapped2(), 'WantsMoreSugar called wrapped2', + 'wrapped2 identifies the caller correctly' ); + ::is( as_is1(), 'as_is1', + 'as_is1 works as expected' ); + + MooseX::MoreSugar->unimport(); +} + +{ + ok( ! WantsMoreSugar->can('has'), 'WantsMoreSugar::has() has been cleaned' ); + ok( ! WantsMoreSugar->can('with'), 'WantsMoreSugar::with() has been cleaned' ); + ok( ! WantsMoreSugar->can('wrapped1'), 'WantsMoreSugar::wrapped1() has been cleaned' ); + ok( ! WantsMoreSugar->can('wrapped2'), 'WantsMoreSugar::wrapped2() has been cleaned' ); + ok( ! WantsMoreSugar->can('as_is1'), 'WantsMoreSugar::as_is1() has been cleaned' ); + can_ok( 'WantsMoreSugar', 'foo' ); +} + +{ + package My::Metaclass; + use Moose; + BEGIN { extends 'Moose::Meta::Class' } + + package My::Object; + use Moose; + BEGIN { extends 'Moose::Object' } + + package HasInitMeta; + + use Moose (); + + sub init_meta { + shift; + return Moose->init_meta( @_, + metaclass => 'My::Metaclass', + base_class => 'My::Object', + ); + } + + Moose::Exporter->setup_import_methods( also => 'Moose' ); +} + +{ + package NewMeta; + + HasInitMeta->import(); +} + +{ + isa_ok( NewMeta->meta(), 'My::Metaclass' ); + isa_ok( NewMeta->new(), 'My::Object' ); +} + +{ + package MooseX::CircularAlso; + + use Moose (); + + ::like( + ::exception{ Moose::Exporter->setup_import_methods( + also => [ 'Moose', 'MooseX::CircularAlso' ], + ); + }, + qr/\QCircular reference in 'also' parameter to Moose::Exporter between MooseX::CircularAlso and MooseX::CircularAlso/, + 'a circular reference in also dies with an error' + ); +} + +{ + package MooseX::NoAlso; + + use Moose (); + + ::like( + ::exception{ Moose::Exporter->setup_import_methods( + also => ['NoSuchThing'], + ); + }, + qr/\QPackage in also (NoSuchThing) does not seem to use Moose::Exporter (is it loaded?) at /, + 'a package which does not use Moose::Exporter in also dies with an error' + ); +} + +{ + package MooseX::NotExporter; + + use Moose (); + + ::like( + ::exception{ Moose::Exporter->setup_import_methods( + also => ['Moose::Meta::Method'], + ); + }, + qr/\QPackage in also (Moose::Meta::Method) does not seem to use Moose::Exporter at /, + 'a package which does not use Moose::Exporter in also dies with an error' + ); +} + +{ + package MooseX::OverridingSugar; + + use Moose (); + + sub has { + my $caller = shift->name; + return $caller . ' called has'; + } + + Moose::Exporter->setup_import_methods( + with_meta => ['has'], + also => 'Moose', + ); +} + +{ + package WantsOverridingSugar; + + MooseX::OverridingSugar->import(); + + ::can_ok( 'WantsOverridingSugar', 'has' ); + ::can_ok( 'WantsOverridingSugar', 'with' ); + ::is( has('foo'), 'WantsOverridingSugar called has', + 'has from MooseX::OverridingSugar is called, not has from Moose' ); + + MooseX::OverridingSugar->unimport(); +} + +{ + ok( ! WantsOverridingSugar->can('has'), 'WantsSugar::has() has been cleaned' ); + ok( ! WantsOverridingSugar->can('with'), 'WantsSugar::with() has been cleaned' ); +} + +{ + package MooseX::OverridingSugar::PassThru; + + sub with { + my $caller = shift->name; + return $caller . ' called with'; + } + + Moose::Exporter->setup_import_methods( + with_meta => ['with'], + also => 'MooseX::OverridingSugar', + ); +} + +{ + + package WantsOverridingSugar::PassThru; + + MooseX::OverridingSugar::PassThru->import(); + + ::can_ok( 'WantsOverridingSugar::PassThru', 'has' ); + ::can_ok( 'WantsOverridingSugar::PassThru', 'with' ); + ::is( + has('foo'), + 'WantsOverridingSugar::PassThru called has', + 'has from MooseX::OverridingSugar is called, not has from Moose' + ); + + ::is( + with('foo'), + 'WantsOverridingSugar::PassThru called with', + 'with from MooseX::OverridingSugar::PassThru is called, not has from Moose' + ); + + + MooseX::OverridingSugar::PassThru->unimport(); +} + +{ + ok( ! WantsOverridingSugar::PassThru->can('has'), 'WantsOverridingSugar::PassThru::has() has been cleaned' ); + ok( ! WantsOverridingSugar::PassThru->can('with'), 'WantsOverridingSugar::PassThru::with() has been cleaned' ); +} + +{ + + package NonExistentExport; + + use Moose (); + + ::stderr_like { + Moose::Exporter->setup_import_methods( + also => ['Moose'], + with_meta => ['does_not_exist'], + ); + } qr/^Trying to export undefined sub NonExistentExport::does_not_exist/, + "warns when a non-existent method is requested to be exported"; +} + +{ + package WantsNonExistentExport; + + NonExistentExport->import; + + ::ok(!__PACKAGE__->can('does_not_exist'), + "undefined subs do not get exported"); +} + +{ + package AllOptions; + use Moose (); + use Moose::Deprecated -api_version => '0.88'; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + also => ['Moose'], + with_meta => [ 'with_meta1', 'with_meta2' ], + with_caller => [ 'with_caller1', 'with_caller2' ], + as_is => ['as_is1', \&Foreign::Class::as_is2, 'Foreign::Class::as_is3'], + ); + + sub with_caller1 { + return @_; + } + + sub with_caller2 (&) { + return @_; + } + + sub as_is1 {2} + + sub Foreign::Class::as_is2 { return 'as_is2' } + sub Foreign::Class::as_is3 { return 'as_is3' } + + sub with_meta1 { + return @_; + } + + sub with_meta2 (&) { + return @_; + } +} + +{ + package UseAllOptions; + + AllOptions->import(); +} + +{ + can_ok( 'UseAllOptions', $_ ) + for qw( with_meta1 with_meta2 with_caller1 with_caller2 as_is1 as_is2 as_is3 ); + + { + my ( $caller, $arg1 ) = UseAllOptions::with_caller1(42); + is( $caller, 'UseAllOptions', 'with_caller wrapped sub gets the right caller' ); + is( $arg1, 42, 'with_caller wrapped sub returns argument it was passed' ); + } + + { + my ( $meta, $arg1 ) = UseAllOptions::with_meta1(42); + isa_ok( $meta, 'Moose::Meta::Class', 'with_meta first argument' ); + is( $arg1, 42, 'with_meta1 returns argument it was passed' ); + } + + is( + prototype( UseAllOptions->can('with_caller2') ), + prototype( AllOptions->can('with_caller2') ), + 'using correct prototype on with_meta function' + ); + + is( + prototype( UseAllOptions->can('with_meta2') ), + prototype( AllOptions->can('with_meta2') ), + 'using correct prototype on with_meta function' + ); +} + +{ + package UseAllOptions; + AllOptions->unimport(); +} + +{ + ok( ! UseAllOptions->can($_), "UseAllOptions::$_ has been unimported" ) + for qw( with_meta1 with_meta2 with_caller1 with_caller2 as_is1 as_is2 as_is3 ); +} + +{ + package InitMetaError; + use Moose::Exporter; + use Moose (); + Moose::Exporter->setup_import_methods(also => ['Moose']); + sub init_meta { + my $package = shift; + my %options = @_; + Moose->init_meta(%options, metaclass => 'Not::Loaded'); + } +} + +{ + package InitMetaError::Role; + use Moose::Exporter; + use Moose::Role (); + Moose::Exporter->setup_import_methods(also => ['Moose::Role']); + sub init_meta { + my $package = shift; + my %options = @_; + Moose::Role->init_meta(%options, metaclass => 'Not::Loaded'); + } +} + +{ + package WantsInvalidMetaclass; + ::like( + ::exception { InitMetaError->import }, + qr/The Metaclass Not::Loaded must be loaded\. \(Perhaps you forgot to 'use Not::Loaded'\?\)/, + "error when wanting a nonexistent metaclass" + ); +} + +{ + package WantsInvalidMetaclass::Role; + ::like( + ::exception { InitMetaError::Role->import }, + qr/The Metaclass Not::Loaded must be loaded\. \(Perhaps you forgot to 'use Not::Loaded'\?\)/, + "error when wanting a nonexistent metaclass" + ); +} + +{ + my @init_metas_called; + + BEGIN { + package MultiLevelExporter1; + use Moose::Exporter; + + sub foo { 1 } + sub bar { 1 } + sub baz { 1 } + sub quux { 1 } + + Moose::Exporter->setup_import_methods( + with_meta => [qw(foo bar baz quux)], + ); + + sub init_meta { + push @init_metas_called, 1; + } + + $INC{'MultiLevelExporter1.pm'} = __FILE__; + } + + BEGIN { + package MultiLevelExporter2; + use Moose::Exporter; + + sub bar { 2 } + sub baz { 2 } + sub quux { 2 } + + Moose::Exporter->setup_import_methods( + also => ['MultiLevelExporter1'], + with_meta => [qw(bar baz quux)], + ); + + sub init_meta { + push @init_metas_called, 2; + } + + $INC{'MultiLevelExporter2.pm'} = __FILE__; + } + + BEGIN { + package MultiLevelExporter3; + use Moose::Exporter; + + sub baz { 3 } + sub quux { 3 } + + Moose::Exporter->setup_import_methods( + also => ['MultiLevelExporter2'], + with_meta => [qw(baz quux)], + ); + + sub init_meta { + push @init_metas_called, 3; + } + + $INC{'MultiLevelExporter3.pm'} = __FILE__; + } + + BEGIN { + package MultiLevelExporter4; + use Moose::Exporter; + + sub quux { 4 } + + Moose::Exporter->setup_import_methods( + also => ['MultiLevelExporter3'], + with_meta => [qw(quux)], + ); + + sub init_meta { + push @init_metas_called, 4; + } + + $INC{'MultiLevelExporter4.pm'} = __FILE__; + } + + BEGIN { @init_metas_called = () } + { + package UsesMulti1; + use Moose; + use MultiLevelExporter1; + ::is(foo(), 1); + ::is(bar(), 1); + ::is(baz(), 1); + ::is(quux(), 1); + } + use Data::Dumper; + BEGIN { is_deeply(\@init_metas_called, [ 1 ]) || diag(Dumper(\@init_metas_called)) } + + BEGIN { @init_metas_called = () } + { + package UsesMulti2; + use Moose; + use MultiLevelExporter2; + ::is(foo(), 1); + ::is(bar(), 2); + ::is(baz(), 2); + ::is(quux(), 2); + } + BEGIN { is_deeply(\@init_metas_called, [ 2, 1 ]) || diag(Dumper(\@init_metas_called)) } + + BEGIN { @init_metas_called = () } + { + package UsesMulti3; + use Moose; + use MultiLevelExporter3; + ::is(foo(), 1); + ::is(bar(), 2); + ::is(baz(), 3); + ::is(quux(), 3); + } + BEGIN { is_deeply(\@init_metas_called, [ 3, 2, 1 ]) || diag(Dumper(\@init_metas_called)) } + + BEGIN { @init_metas_called = () } + { + package UsesMulti4; + use Moose; + use MultiLevelExporter4; + ::is(foo(), 1); + ::is(bar(), 2); + ::is(baz(), 3); + ::is(quux(), 4); + } + BEGIN { is_deeply(\@init_metas_called, [ 4, 3, 2, 1 ]) || diag(Dumper(\@init_metas_called)) } +} + +# Using "also => [ 'MooseX::UsesAlsoMoose', 'MooseX::SomethingElse' ]" should +# continue to work. The init_meta order needs to be MooseX::CurrentExporter, +# MooseX::UsesAlsoMoose, Moose, MooseX::SomethingElse. This is a pretty ugly +# and messed up use case, but necessary until we come up with a better way to +# do it. + +{ + my @init_metas_called; + + BEGIN { + package AlsoTest::Role1; + use Moose::Role; + } + + BEGIN { + package AlsoTest1; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + also => [ 'Moose' ], + ); + + sub init_meta { + shift; + my %opts = @_; + ::ok(!Class::MOP::class_of($opts{for_class})); + push @init_metas_called, 1; + } + + $INC{'AlsoTest1.pm'} = __FILE__; + } + + BEGIN { + package AlsoTest2; + use Moose::Exporter; + use Moose::Util::MetaRole (); + + Moose::Exporter->setup_import_methods; + + sub init_meta { + shift; + my %opts = @_; + ::ok(Class::MOP::class_of($opts{for_class})); + Moose::Util::MetaRole::apply_metaroles( + for => $opts{for_class}, + class_metaroles => { + class => ['AlsoTest::Role1'], + }, + ); + push @init_metas_called, 2; + } + + $INC{'AlsoTest2.pm'} = __FILE__; + } + + BEGIN { + package AlsoTest3; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + also => [ 'AlsoTest1', 'AlsoTest2' ], + ); + + sub init_meta { + shift; + my %opts = @_; + ::ok(!Class::MOP::class_of($opts{for_class})); + push @init_metas_called, 3; + } + + $INC{'AlsoTest3.pm'} = __FILE__; + } + + BEGIN { @init_metas_called = () } + { + package UsesAlsoTest3; + use AlsoTest3; + } + use Data::Dumper; + BEGIN { + is_deeply(\@init_metas_called, [ 3, 1, 2 ]) + || diag(Dumper(\@init_metas_called)); + isa_ok(Class::MOP::class_of('UsesAlsoTest3'), 'Moose::Meta::Class'); + does_ok(Class::MOP::class_of('UsesAlsoTest3'), 'AlsoTest::Role1'); + } + +} + +done_testing; diff --git a/t/metaclasses/moose_exporter_trait_aliases.t b/t/metaclasses/moose_exporter_trait_aliases.t new file mode 100644 index 0000000..633674d --- /dev/null +++ b/t/metaclasses/moose_exporter_trait_aliases.t @@ -0,0 +1,88 @@ +use strict; +use warnings; +use Test::More; +use Test::Moose; + +{ + package Attribute::Trait::Awesome; + use Moose::Role; +} + +BEGIN { + package Awesome::Exporter; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + trait_aliases => ['Attribute::Trait::Awesome'], + ); +} + +{ + package Awesome; + use Moose; + BEGIN { Awesome::Exporter->import } + + has foo => ( + traits => [Awesome], + is => 'ro', + ); + ::does_ok(__PACKAGE__->meta->get_attribute('foo'), 'Attribute::Trait::Awesome'); + + no Moose; + BEGIN { Awesome::Exporter->unimport } + + my $val = eval "Awesome"; + ::like($@, qr/Bareword "Awesome" not allowed/, "unimported properly"); + ::is($val, undef, "unimported properly"); +} + +BEGIN { + package Awesome2::Exporter; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + trait_aliases => [ + [ 'Attribute::Trait::Awesome' => 'Awesome2' ], + ], + ); +} + +{ + package Awesome2; + use Moose; + BEGIN { Awesome2::Exporter->import } + + has foo => ( + traits => [Awesome2], + is => 'ro', + ); + ::does_ok(__PACKAGE__->meta->get_attribute('foo'), 'Attribute::Trait::Awesome'); + + BEGIN { Awesome2::Exporter->unimport } + + my $val = eval "Awesome2"; + ::like($@, qr/Bareword "Awesome2" not allowed/, "unimported properly"); + ::is($val, undef, "unimported properly"); +} + +{ + package Awesome2::Rename; + use Moose; + BEGIN { Awesome2::Exporter->import(Awesome2 => { -as => 'emosewA' }) } + + has foo => ( + traits => [emosewA], + is => 'ro', + ); + ::does_ok(__PACKAGE__->meta->get_attribute('foo'), 'Attribute::Trait::Awesome'); + + BEGIN { Awesome2::Exporter->unimport } + + { our $TODO; local $TODO = "unimporting renamed subs currently doesn't work"; + my $val = eval "emosewA"; + ::like($@, qr/Bareword "emosewA" not allowed/, "unimported properly"); + ::is($val, undef, "unimported properly"); + } +} + +done_testing; diff --git a/t/metaclasses/moose_for_meta.t b/t/metaclasses/moose_for_meta.t new file mode 100644 index 0000000..8956380 --- /dev/null +++ b/t/metaclasses/moose_for_meta.t @@ -0,0 +1,76 @@ +use strict; +use warnings; + +use Test::More; + + +=pod + +This test demonstrates the ability to extend +Moose meta-level classes using Moose itself. + +=cut + +{ + package My::Meta::Class; + use Moose; + + extends 'Moose::Meta::Class'; + + around 'create_anon_class' => sub { + my $next = shift; + my ($self, %options) = @_; + $options{superclasses} = [ 'Moose::Object' ] + unless exists $options{superclasses}; + $next->($self, %options); + }; +} + +my $anon = My::Meta::Class->create_anon_class(); +isa_ok($anon, 'My::Meta::Class'); +isa_ok($anon, 'Moose::Meta::Class'); +isa_ok($anon, 'Class::MOP::Class'); + +is_deeply( + [ $anon->superclasses ], + [ 'Moose::Object' ], + '... got the default superclasses'); + +{ + package My::Meta::Attribute::DefaultReadOnly; + use Moose; + + extends 'Moose::Meta::Attribute'; + + around 'new' => sub { + my $next = shift; + my ($self, $name, %options) = @_; + $options{is} = 'ro' + unless exists $options{is}; + $next->($self, $name, %options); + }; +} + +{ + my $attr = My::Meta::Attribute::DefaultReadOnly->new('foo'); + isa_ok($attr, 'My::Meta::Attribute::DefaultReadOnly'); + isa_ok($attr, 'Moose::Meta::Attribute'); + isa_ok($attr, 'Class::MOP::Attribute'); + + ok($attr->has_reader, '... the attribute has a reader (as expected)'); + ok(!$attr->has_writer, '... the attribute does not have a writer (as expected)'); + ok(!$attr->has_accessor, '... the attribute does not have an accessor (as expected)'); +} + +{ + my $attr = My::Meta::Attribute::DefaultReadOnly->new('foo', (is => 'rw')); + isa_ok($attr, 'My::Meta::Attribute::DefaultReadOnly'); + isa_ok($attr, 'Moose::Meta::Attribute'); + isa_ok($attr, 'Class::MOP::Attribute'); + + ok(!$attr->has_reader, '... the attribute does not have a reader (as expected)'); + ok(!$attr->has_writer, '... the attribute does not have a writer (as expected)'); + ok($attr->has_accessor, '... the attribute does have an accessor (as expected)'); +} + +done_testing; diff --git a/t/metaclasses/moose_nonmoose_metatrait_init_order.t b/t/metaclasses/moose_nonmoose_metatrait_init_order.t new file mode 100644 index 0000000..56f7b36 --- /dev/null +++ b/t/metaclasses/moose_nonmoose_metatrait_init_order.t @@ -0,0 +1,30 @@ +use strict; +use warnings; +{ + package My::Role; + use Moose::Role; +} +{ + package SomeClass; + use Moose -traits => 'My::Role'; +} +{ + package SubClassUseBase; + use parent -norequire => 'SomeClass'; +} +{ + package SubSubClassUseBase; + use parent -norequire => 'SubClassUseBase'; +} + +use Test::More; +use Moose::Util qw/find_meta does_role/; + +my $subsubclass_meta = Moose->init_meta( for_class => 'SubSubClassUseBase' ); +ok does_role($subsubclass_meta, 'My::Role'), + 'SubSubClass metaclass does role from grandparent metaclass'; +my $subclass_meta = find_meta('SubClassUseBase'); +ok does_role($subclass_meta, 'My::Role'), + 'SubClass metaclass does role from parent metaclass'; + +done_testing; diff --git a/t/metaclasses/moose_nonmoose_moose_chain_init_meta.t b/t/metaclasses/moose_nonmoose_moose_chain_init_meta.t new file mode 100644 index 0000000..31df803 --- /dev/null +++ b/t/metaclasses/moose_nonmoose_moose_chain_init_meta.t @@ -0,0 +1,24 @@ +use strict; +use warnings; +{ + package ParentClass; + use Moose; +} +{ + package SomeClass; + use parent -norequire => 'ParentClass'; +} +{ + package SubClassUseBase; + use parent -norequire => 'SomeClass'; + use Moose; +} + +use Test::More; +use Test::Fatal; + +is( exception { + Moose->init_meta(for_class => 'SomeClass'); +}, undef, 'Moose class => use parent => Moose Class, then Moose->init_meta on middle class ok' ); + +done_testing; diff --git a/t/metaclasses/moose_w_metaclass.t b/t/metaclasses/moose_w_metaclass.t new file mode 100644 index 0000000..41f9de0 --- /dev/null +++ b/t/metaclasses/moose_w_metaclass.t @@ -0,0 +1,54 @@ +use strict; +use warnings; + +use Test::More; + + +=pod + +This test demonstrates that Moose will respect +a metaclass previously set with the metaclass +pragma. + +It also checks an error condition where that +metaclass must be a Moose::Meta::Class subclass +in order to work. + +=cut + + +{ + package Foo::Meta; + use strict; + use warnings; + + use parent 'Moose::Meta::Class'; + + package Foo; + use strict; + use warnings; + use metaclass 'Foo::Meta'; + ::use_ok('Moose'); +} + +isa_ok(Foo->meta, 'Foo::Meta'); + +{ + package Bar::Meta; + use strict; + use warnings; + + use parent 'Class::MOP::Class'; + + package Bar; + use strict; + use warnings; + use metaclass 'Bar::Meta'; + eval 'use Moose;'; + ::ok($@, '... could not load moose without correct metaclass'); + ::like($@, + qr/^Bar already has a metaclass, but it does not inherit Moose::Meta::Class/, + '... got the right error too'); +} + +done_testing; diff --git a/t/metaclasses/new_metaclass.t b/t/metaclasses/new_metaclass.t new file mode 100644 index 0000000..7d439b1 --- /dev/null +++ b/t/metaclasses/new_metaclass.t @@ -0,0 +1,27 @@ +use strict; +use warnings; +use Test::More; + +do { + package My::Meta::Class; + use Moose; + BEGIN { extends 'Moose::Meta::Class' }; + + package Moose::Meta::Class::Custom::MyMetaClass; + sub register_implementation { 'My::Meta::Class' } +}; + +do { + package My::Class; + use Moose -metaclass => 'My::Meta::Class'; +}; + +do { + package My::Class::Aliased; + use Moose -metaclass => 'MyMetaClass'; +}; + +is(My::Class->meta->meta->name, 'My::Meta::Class'); +is(My::Class::Aliased->meta->meta->name, 'My::Meta::Class'); + +done_testing; diff --git a/t/metaclasses/new_object_BUILD.t b/t/metaclasses/new_object_BUILD.t new file mode 100644 index 0000000..22b37c8 --- /dev/null +++ b/t/metaclasses/new_object_BUILD.t @@ -0,0 +1,19 @@ +use strict; +use warnings; +use Test::More; + +my $called; +{ + package Foo; + use Moose; + + sub BUILD { $called++ } +} + +Foo->new; +is($called, 1, "BUILD called from ->new"); +$called = 0; +Foo->meta->new_object; +is($called, 1, "BUILD called from ->meta->new_object"); + +done_testing; diff --git a/t/metaclasses/overloading.t b/t/metaclasses/overloading.t new file mode 100644 index 0000000..31cd907 --- /dev/null +++ b/t/metaclasses/overloading.t @@ -0,0 +1,480 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Sub::Name qw( subname ); + +my $quote = qr/['`"]/; + +{ + package Foo; + use Moose; +} + +{ + my $meta = Foo->meta; + + subtest( + 'Foo class (not overloaded)', + sub { + ok( !$meta->is_overloaded, 'is not overloaded' ); + + ok( + !$meta->has_overloaded_operator('+'), + 'has no + overloading' + ); + ok( + !$meta->has_overloaded_operator('-'), + 'has no - overloading' + ); + + is_deeply( + [ $meta->get_overload_list ], [], + '->get_overload_list returns an empty list' + ); + + is_deeply( + [ $meta->get_all_overloaded_operators ], [], + '->get_all_overloaded_operators return an empty list' + ); + + is( + $meta->get_overloaded_operator('+'), undef, + 'get_overloaded_operator(+) returns undef' + ); + is( + $meta->get_overloaded_operator('-'), undef, + 'get_overloaded_operator(-) returns undef' + ); + } + ); +} + +my $plus = 0; +my $plus_impl; + +BEGIN { + $plus_impl = sub { $plus = 1; 42 } +} +{ + package Foo::Overloaded; + use Moose; + use overload '+' => $plus_impl; +} + +{ + my $meta = Foo::Overloaded->meta; + + subtest( + 'Foo::Overload class (overloaded with coderef)', + sub { + ok( $meta->is_overloaded, 'is overloaded' ); + + ok( + $meta->has_overloaded_operator('+'), + 'has + overloading' + ); + ok( + !$meta->has_overloaded_operator('-'), + 'has no - overloading' + ); + + is_deeply( + [ $meta->get_overload_list ], ['+'], + '->get_overload_list returns (+) ' + ); + + my @overloads = $meta->get_all_overloaded_operators; + is( + scalar(@overloads), 1, + '->get_all_overloaded_operators returns 1 operator' + ); + my $plus_overload = $overloads[0]; + isa_ok( + $plus_overload, 'Class::MOP::Overload', + 'overload object' + ); + is( $plus_overload->operator, '+', 'operator for overload is +' ); + is( + $plus_overload->coderef, $plus_impl, + 'coderef for overload matches sub we passed' + ); + is( + $plus_overload->coderef_package, 'main', + 'coderef package for overload is main' + ); + is( + $plus_overload->coderef_name, '__ANON__', + 'coderef name for overload is __ANON__' + ); + ok( + $plus_overload->is_anonymous, + 'overload is anonymous' + ); + ok( + !$plus_overload->has_method_name, + 'overload has no method name' + ); + ok( + !$plus_overload->has_method, + 'overload has no method' + ); + is( + $plus_overload->associated_metaclass, $meta, + 'overload is associated with expected metaclass' + ); + + my $plus_overload2 = $meta->get_overloaded_operator('+'); + is( + $plus_overload2, $plus_overload, + '->get_overloaded_operator(+) returns the same operator on each call' + ); + + is( $plus, 0, '+ overloading has not been called' ); + is( + Foo::Overloaded->new + Foo::Overloaded->new, 42, + '+ overloading returns 42' + ); + is( $plus, 1, '+ overloading was called once' ); + + ok( + $plus_overload->_is_equal_to($plus_overload2), + '_is_equal_to returns true for the exact same object' + ); + + my $plus_overload3 = Class::MOP::Overload->new( + operator => '+', + coderef => $plus_impl, + coderef_package => 'main', + coderef_name => '__ANON__', + ); + + ok( + $plus_overload->_is_equal_to($plus_overload3), + '_is_equal_to returns true for object with the same properties' + ); + + my $minus = 0; + my $minus_impl + = subname( 'overload_minus', sub { $minus = 1; -42 } ); + + like( + exception { Foo::Overloaded->new - Foo::Overloaded->new }, + qr/Operation $quote-$quote: no .+ found/, + 'trying to call - on objects fails' + ); + + $meta->add_overloaded_operator( '-' => $minus_impl ); + + ok( + $meta->has_overloaded_operator('-'), + 'has - operator after call to ->add_overloaded_operator' + ); + + is_deeply( + [ sort $meta->get_overload_list ], [ '+', '-' ], + '->get_overload_list returns (+, -)' + ); + + is( + scalar( $meta->get_all_overloaded_operators ), 2, + '->get_all_overloaded_operators returns 2 operators' + ); + + my $minus_overload = $meta->get_overloaded_operator('-'); + isa_ok( + $minus_overload, 'Class::MOP::Overload', + 'object for - overloading' + ); + is( + $minus_overload->operator, '-', + 'operator for overload is -' + ); + is( + $minus_overload->coderef, $minus_impl, + 'coderef for overload matches sub we passed' + ); + is( + $minus_overload->coderef_package, 'main', + 'coderef package for overload is main' + ); + is( + $minus_overload->coderef_name, 'overload_minus', + 'coderef name for overload is overload_minus' + ); + ok( + !$minus_overload->is_anonymous, + 'overload is not anonymous' + ); + is( + $minus_overload->associated_metaclass, $meta, + 'overload is associated with expected metaclass' + ); + + is( $minus, 0, '- overloading has not been called' ); + is( + Foo::Overloaded->new - Foo::Overloaded->new, -42, + '- overloading returns -42' + ); + is( $minus, 1, '+- overloading was called once' ); + + ok( + !$plus_overload->_is_equal_to($minus_overload), + '_is_equal_to returns false for objects with different properties' + ); + + $meta->remove_overloaded_operator('-'); + + like( + exception { Foo::Overloaded->new - Foo::Overloaded->new }, + qr/Operation $quote-$quote: no .+ found/, + 'trying to call - on objects fails after call to ->remove_overloaded_operator' + ); + } + ); +} + +my $times = 0; +my $divided = 0; +{ + package Foo::OverloadWithMethod; + use Moose; + use overload '*' => 'times'; + + sub times { $times = 1; 'times' } + sub divided { $divided = 1; 'divided' } +} + +{ + my $meta = Foo::OverloadWithMethod->meta; + + subtest( + 'Foo::OverloadWithMethod (overloaded via method)', + sub { + ok( + $meta->is_overloaded, + 'is overloaded' + ); + + ok( + $meta->has_overloaded_operator('*'), + 'overloads *' + ); + ok( + !$meta->has_overloaded_operator('/'), + 'does not overload /' + ); + + is_deeply( + [ $meta->get_overload_list ], ['*'], + '->get_overload_list returns (*)' + ); + + my @overloads = $meta->get_all_overloaded_operators; + is( + scalar(@overloads), 1, + '->get_all_overloaded_operators returns 1 item' + ); + my $times_overload = $overloads[0]; + isa_ok( + $times_overload, 'Class::MOP::Overload', + 'overload object' + ); + is( + $times_overload->operator, '*', + 'operator for overload is +' + ); + ok( + $times_overload->has_method_name, + 'overload has a method name' + ); + is( + $times_overload->method_name, 'times', + q{method name is 'times'} + ); + ok( + !$times_overload->has_coderef, + 'overload does not have a coderef' + ); + ok( + !$times_overload->has_coderef_package, + 'overload does not have a coderef package' + ); + ok( + !$times_overload->has_coderef_name, + 'overload does not have a coderef name' + ); + ok( + !$times_overload->is_anonymous, + 'overload is not anonymous' + ); + ok( + $times_overload->has_method, + 'overload has a method' + ); + is( + $times_overload->method, $meta->get_method('times'), + '->method returns method object for times method' + ); + is( + $times_overload->associated_metaclass, $meta, + 'overload is associated with expected metaclass' + ); + + is( $times, 0, '* overloading has not been called' ); + is( + Foo::OverloadWithMethod->new * Foo::OverloadWithMethod->new, + 'times', + q{* overloading returns 'times'} + ); + is( $times, 1, '* overloading was called once' ); + + my $times_overload2 = $meta->get_overloaded_operator('*'); + + ok( + $times_overload->_is_equal_to($times_overload2), + '_is_equal_to returns true for the exact same object' + ); + + my $times_overload3 = Class::MOP::Overload->new( + operator => '*', + method_name => 'times', + ); + + ok( + $times_overload->_is_equal_to($times_overload3), + '_is_equal_to returns true for object with the same properties' + ); + + like( + exception { + Foo::OverloadWithMethod->new + / Foo::OverloadWithMethod->new + }, + qr{Operation $quote/$quote: no .+ found}, + 'trying to call / on objects fails' + ); + + $meta->add_overloaded_operator( '/' => 'divided' ); + + ok( + $meta->has_overloaded_operator('/'), + 'has / operator after call to ->add_overloaded_operator' + ); + + is_deeply( + [ sort $meta->get_overload_list ], [ '*', '/' ], + '->get_overload_list returns (*, /)' + ); + + is( + scalar( $meta->get_all_overloaded_operators ), 2, + '->get_all_overloaded_operators returns 2 operators' + ); + + my $divided_overload = $meta->get_overloaded_operator('/'); + isa_ok( + $divided_overload, 'Class::MOP::Overload', + 'overload object' + ); + is( + $divided_overload->operator, '/', + 'operator for overload is /' + ); + is( + $divided_overload->method_name, 'divided', + q{method name is 'divided'} + ); + is( + $divided_overload->method, $meta->get_method('divided'), + '->method returns method object for divided method' + ); + is( + $divided_overload->associated_metaclass, $meta, + 'overload is associated with expected metaclass' + ); + + $meta->remove_overloaded_operator('/'); + + like( + exception { + Foo::OverloadWithMethod->new + / Foo::OverloadWithMethod->new + }, + qr{Operation $quote/$quote: no .+ found}, + 'trying to call / on objects fails after call to ->remove_overloaded_operator' + ); + } + ); +} + +{ + package Foo::UnimplementedOverload; + use Moose; + use overload '+' => 'plus'; +} + +{ + my $meta = Foo::UnimplementedOverload->meta; + + subtest( + 'Foo::UnimplementedOverload (overloaded via method that does not exist)', + sub { + ok( + $meta->is_overloaded, + 'is overloaded' + ); + + ok( + $meta->has_overloaded_operator('+'), + 'overloads +' + ); + + my $plus_overload = $meta->get_overloaded_operator('+'); + isa_ok( + $plus_overload, 'Class::MOP::Overload', + 'overload object' + ); + is( + $plus_overload->operator, '+', + 'operator for overload is +' + ); + ok( + $plus_overload->has_method_name, + 'overload has a method name' + ); + is( + $plus_overload->method_name, 'plus', + q{method name is 'plus'} + ); + ok( + !$plus_overload->has_coderef, + 'overload does not have a coderef' + ); + ok( + !$plus_overload->has_coderef_package, + 'overload does not have a coderef package' + ); + ok( + !$plus_overload->has_coderef_name, + 'overload does not have a coderef name' + ); + ok( + !$plus_overload->is_anonymous, + 'overload is not anonymous' + ); + ok( + !$plus_overload->has_method, + 'overload has no method object' + ); + is( + $plus_overload->associated_metaclass, $meta, + 'overload is associated with expected metaclass' + ); + } + ); +} + +done_testing; diff --git a/t/metaclasses/reinitialize.t b/t/metaclasses/reinitialize.t new file mode 100644 index 0000000..2e6020b --- /dev/null +++ b/t/metaclasses/reinitialize.t @@ -0,0 +1,320 @@ +use strict; +use warnings; +use Test::More; +use Test::Moose; +use Test::Fatal; + +sub check_meta_sanity { + my ($meta, $class) = @_; + local $Test::Builder::Level = $Test::Builder::Level + 1; + isa_ok($meta, 'Moose::Meta::Class'); + is($meta->name, $class); + ok($meta->has_method('foo')); + isa_ok($meta->get_method('foo'), 'Moose::Meta::Method'); + ok($meta->has_attribute('bar')); + isa_ok($meta->get_attribute('bar'), 'Moose::Meta::Attribute'); + + if ( $meta->name eq 'Foo' ) { + ok($meta->does_role('Role1'), 'does Role1'); + ok($meta->does_role('Role2'), 'does Role2'); + + is_deeply( + [ + map { [ $_->role->name, $_->class->name ] } + sort { $a->role->name cmp $b->role->name } + $meta->role_applications + ], + [ + [ 'Role1|Role2', 'Foo' ], + ], + 'role applications for Role1 and Role2' + ); + } +} + +{ + package Role1; + use Moose::Role; +} + +{ + package Role2; + use Moose::Role; +} + +{ + package Foo; + use Moose; + sub foo {} + with 'Role1', 'Role2'; + has bar => (is => 'ro'); +} + +check_meta_sanity(Foo->meta, 'Foo'); + +Moose::Meta::Class->reinitialize('Foo'); +check_meta_sanity(Foo->meta, 'Foo'); + +{ + package Foo::Role::Method; + use Moose::Role; + + has foo => (is => 'rw'); +} + +{ + package Foo::Role::Attribute; + use Moose::Role; + has oof => (is => 'rw'); +} + +Moose::Util::MetaRole::apply_metaroles( + for => 'Foo', + class_metaroles => { + method => ['Foo::Role::Method'], + attribute => ['Foo::Role::Attribute'], + }, +); +check_meta_sanity(Foo->meta, 'Foo'); +does_ok(Foo->meta->get_method('foo'), 'Foo::Role::Method'); +does_ok(Foo->meta->get_attribute('bar'), 'Foo::Role::Attribute'); + +Moose::Meta::Class->reinitialize('Foo'); +check_meta_sanity(Foo->meta, 'Foo'); +does_ok(Foo->meta->get_method('foo'), 'Foo::Role::Method'); +does_ok(Foo->meta->get_attribute('bar'), 'Foo::Role::Attribute'); + +Foo->meta->get_method('foo')->foo('TEST'); +Foo->meta->get_attribute('bar')->oof('TSET'); +is(Foo->meta->get_method('foo')->foo, 'TEST'); +is(Foo->meta->get_attribute('bar')->oof, 'TSET'); +Moose::Meta::Class->reinitialize('Foo'); +check_meta_sanity(Foo->meta, 'Foo'); +is(Foo->meta->get_method('foo')->foo, 'TEST'); +is(Foo->meta->get_attribute('bar')->oof, 'TSET'); + +{ + package Bar::Role::Method; + use Moose::Role; +} + +{ + package Bar::Role::Attribute; + use Moose::Role; +} + +{ + package Bar; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => 'Bar', + class_metaroles => { + method => ['Bar::Role::Method'], + attribute => ['Bar::Role::Attribute'], + }, + ); + sub foo {} + has bar => (is => 'ro'); +} + +check_meta_sanity(Bar->meta, 'Bar'); +does_ok(Bar->meta->get_method('foo'), 'Bar::Role::Method'); +does_ok(Bar->meta->get_attribute('bar'), 'Bar::Role::Attribute'); + +Moose::Meta::Class->reinitialize('Bar'); +check_meta_sanity(Bar->meta, 'Bar'); +does_ok(Bar->meta->get_method('foo'), 'Bar::Role::Method'); +does_ok(Bar->meta->get_attribute('bar'), 'Bar::Role::Attribute'); +ok(!Moose::Util::does_role(Bar->meta->get_method('foo'), 'Foo::Role::Method')); +ok(!Moose::Util::does_role(Bar->meta->get_attribute('bar'), 'Foo::Role::Attribute')); + +Moose::Util::MetaRole::apply_metaroles( + for => 'Bar', + class_metaroles => { + method => ['Foo::Role::Method'], + attribute => ['Foo::Role::Attribute'], + }, +); +check_meta_sanity(Bar->meta, 'Bar'); +does_ok(Bar->meta->get_method('foo'), 'Bar::Role::Method'); +does_ok(Bar->meta->get_attribute('bar'), 'Bar::Role::Attribute'); +does_ok(Bar->meta->get_method('foo'), 'Foo::Role::Method'); +does_ok(Bar->meta->get_attribute('bar'), 'Foo::Role::Attribute'); + +{ + package Bar::Meta::Method; + use Moose; + BEGIN { extends 'Moose::Meta::Method' }; +} + +{ + package Bar::Meta::Attribute; + use Moose; + BEGIN { extends 'Moose::Meta::Attribute' }; +} + +like( exception { + Moose::Meta::Class->reinitialize( + 'Bar', + method_metaclass => 'Bar::Meta::Method', + attribute_metaclass => 'Bar::Meta::Attribute', + ); +}, qr/\QAttribute (class_name) is required/ ); + +{ + package Baz::Meta::Class; + use Moose; + BEGIN { extends 'Moose::Meta::Class' }; + + sub initialize { + my $self = shift; + return $self->SUPER::initialize( + @_, + method_metaclass => 'Bar::Meta::Method', + attribute_metaclass => 'Bar::Meta::Attribute' + ); + } +} + +{ + package Baz; + use Moose -metaclass => 'Baz::Meta::Class'; + sub foo {} + has bar => (is => 'ro'); +} + +check_meta_sanity(Baz->meta, 'Baz'); +isa_ok(Baz->meta->get_method('foo'), 'Bar::Meta::Method'); +isa_ok(Baz->meta->get_attribute('bar'), 'Bar::Meta::Attribute'); +Moose::Meta::Class->reinitialize('Baz'); +check_meta_sanity(Baz->meta, 'Baz'); +isa_ok(Baz->meta->get_method('foo'), 'Bar::Meta::Method'); +isa_ok(Baz->meta->get_attribute('bar'), 'Bar::Meta::Attribute'); + +Moose::Util::MetaRole::apply_metaroles( + for => 'Baz', + class_metaroles => { + method => ['Foo::Role::Method'], + attribute => ['Foo::Role::Attribute'], + }, +); +check_meta_sanity(Baz->meta, 'Baz'); +isa_ok(Baz->meta->get_method('foo'), 'Bar::Meta::Method'); +isa_ok(Baz->meta->get_attribute('bar'), 'Bar::Meta::Attribute'); +does_ok(Baz->meta->get_method('foo'), 'Foo::Role::Method'); +does_ok(Baz->meta->get_attribute('bar'), 'Foo::Role::Attribute'); + +{ + package Baz::Meta::Method; + use Moose; + extends 'Moose::Meta::Method'; +} + +{ + package Baz::Meta::Attribute; + use Moose; + extends 'Moose::Meta::Attribute'; +} + +like( exception { + Moose::Meta::Class->reinitialize( + 'Baz', + method_metaclass => 'Baz::Meta::Method', + attribute_metaclass => 'Baz::Meta::Attribute', + ); +}, qr/\QAttribute (class_name) is required/ ); + +{ + package Quux; + use Moose; + sub foo { } + before foo => sub { }; + has bar => (is => 'ro'); + sub DEMOLISH { } + __PACKAGE__->meta->make_immutable; +} + +ok(Quux->meta->has_method('new')); +isa_ok(Quux->meta->get_method('new'), 'Moose::Meta::Method::Constructor'); +ok(Quux->meta->has_method('meta')); +isa_ok(Quux->meta->get_method('meta'), 'Moose::Meta::Method::Meta'); +ok(Quux->meta->has_method('foo')); +isa_ok(Quux->meta->get_method('foo'), 'Class::MOP::Method::Wrapped'); +ok(Quux->meta->has_method('bar')); +isa_ok(Quux->meta->get_method('bar'), 'Moose::Meta::Method::Accessor'); +ok(Quux->meta->has_method('DESTROY')); +isa_ok(Quux->meta->get_method('DESTROY'), 'Moose::Meta::Method::Destructor'); +ok(Quux->meta->has_method('DEMOLISH')); +isa_ok(Quux->meta->get_method('DEMOLISH'), 'Moose::Meta::Method'); + +Quux->meta->make_mutable; +Moose::Meta::Class->reinitialize('Quux'); +Quux->meta->make_immutable; + +ok(Quux->meta->has_method('new')); +isa_ok(Quux->meta->get_method('new'), 'Moose::Meta::Method::Constructor'); +ok(Quux->meta->has_method('meta')); +isa_ok(Quux->meta->get_method('meta'), 'Moose::Meta::Method::Meta'); +ok(Quux->meta->has_method('foo')); +isa_ok(Quux->meta->get_method('foo'), 'Class::MOP::Method::Wrapped'); +ok(Quux->meta->has_method('bar')); +isa_ok(Quux->meta->get_method('bar'), 'Moose::Meta::Method::Accessor'); +ok(Quux->meta->has_method('DESTROY')); +isa_ok(Quux->meta->get_method('DESTROY'), 'Moose::Meta::Method::Destructor'); +ok(Quux->meta->has_method('DEMOLISH')); +isa_ok(Quux->meta->get_method('DEMOLISH'), 'Moose::Meta::Method'); + +Quux->meta->make_mutable; +Moose::Util::MetaRole::apply_metaroles( + for => 'Quux', + class_metaroles => { + method => ['Foo::Role::Method'], + attribute => ['Foo::Role::Attribute'], + }, +); +Quux->meta->make_immutable; + +ok(Quux->meta->has_method('new')); +isa_ok(Quux->meta->get_method('new'), 'Moose::Meta::Method::Constructor'); +{ local $TODO = "constructor methods don't get metaroles yet"; +does_ok(Quux->meta->get_method('new'), 'Foo::Role::Method'); +} +ok(Quux->meta->has_method('meta')); +isa_ok(Quux->meta->get_method('meta'), 'Moose::Meta::Method::Meta'); +{ local $TODO = "meta methods don't get metaroles yet"; +does_ok(Quux->meta->get_method('meta'), 'Foo::Role::Method'); +} +ok(Quux->meta->has_method('foo')); +isa_ok(Quux->meta->get_method('foo'), 'Class::MOP::Method::Wrapped'); +{ local $TODO = "modified methods don't get metaroles yet"; +does_ok(Quux->meta->get_method('foo'), 'Foo::Role::Method'); +} +ok(Quux->meta->has_method('bar')); +isa_ok(Quux->meta->get_method('bar'), 'Moose::Meta::Method::Accessor'); +{ local $TODO = "accessor methods don't get metaroles yet"; +does_ok(Quux->meta->get_method('bar'), 'Foo::Role::Method'); +} +ok(Quux->meta->has_method('DESTROY')); +isa_ok(Quux->meta->get_method('DESTROY'), 'Moose::Meta::Method::Destructor'); +{ local $TODO = "destructor methods don't get metaroles yet"; +does_ok(Quux->meta->get_method('DESTROY'), 'Foo::Role::Method'); +} +ok(Quux->meta->has_method('DEMOLISH')); +isa_ok(Quux->meta->get_method('DEMOLISH'), 'Moose::Meta::Method'); +does_ok(Quux->meta->get_method('DEMOLISH'), 'Foo::Role::Method'); + +{ + package Role3; + use Moose::Role; + with 'Role1', 'Role2'; +} + +ok( Role3->meta->does_role('Role1'), 'Role3 does Role1' ); +ok( Role3->meta->does_role('Role2'), 'Role3 does Role2' ); + +Moose::Meta::Role->reinitialize('Role3'); + +ok( Role3->meta->does_role('Role1'), 'Role3 does Role1 after reinitialize' ); +ok( Role3->meta->does_role('Role2'), 'Role3 does Role2 after reinitialize' ); + +done_testing; diff --git a/t/metaclasses/use_base_of_moose.t b/t/metaclasses/use_base_of_moose.t new file mode 100644 index 0000000..fdcd601 --- /dev/null +++ b/t/metaclasses/use_base_of_moose.t @@ -0,0 +1,36 @@ +use strict; +use warnings; + +use Test::More; + +{ + package NoOpTrait; + use Moose::Role; +} + +{ + package Parent; + use Moose -traits => 'NoOpTrait'; + + has attr => ( + is => 'rw', + isa => 'Str', + ); +} + +{ + package Child; + use parent -norequire => 'Parent'; +} + +is(Child->meta->name, 'Child', "correct metaclass name"); + +my $child = Child->new(attr => "ibute"); +ok($child, "constructor works"); + +is($child->attr, "ibute", "getter inherited properly"); + +$child->attr("ition"); +is($child->attr, "ition", "setter inherited properly"); + +done_testing; diff --git a/t/moose_util/apply_roles.t b/t/moose_util/apply_roles.t new file mode 100644 index 0000000..48edea7 --- /dev/null +++ b/t/moose_util/apply_roles.t @@ -0,0 +1,71 @@ +use strict; +use warnings; + +use Test::More; +use Moose::Util qw( apply_all_roles ); + +{ + package Role::Foo; + use Moose::Role; +} + +{ + package Role::Bar; + use Moose::Role; +} + +{ + package Role::Baz; + use Moose::Role; +} + +{ + package Class::A; + use Moose; +} + +{ + package Class::B; + use Moose; +} + +{ + package Class::C; + use Moose; +} + +{ + package Class::D; + use Moose; +} + +{ + package Class::E; + use Moose; +} + +my @roles = qw( Role::Foo Role::Bar Role::Baz ); +apply_all_roles( 'Class::A', @roles ); +ok( Class::A->meta->does_role($_), "Class::A does $_" ) for @roles; + +apply_all_roles( 'Class::B', map { $_->meta } @roles ); +ok( Class::A->meta->does_role($_), + "Class::B does $_ (applied with meta role object)" ) + for @roles; + +@roles = qw( Role::Foo ); +apply_all_roles( 'Class::C', @roles ); +ok( Class::A->meta->does_role($_), "Class::C does $_" ) for @roles; + +apply_all_roles( 'Class::D', map { $_->meta } @roles ); +ok( Class::A->meta->does_role($_), + "Class::D does $_ (applied with meta role object)" ) + for @roles; + +@roles = qw( Role::Foo Role::Bar ), Role::Baz->meta; +apply_all_roles( 'Class::E', @roles ); +ok( Class::A->meta->does_role($_), + "Class::E does $_ (mix of names and meta role object)" ) + for @roles; + +done_testing; diff --git a/t/moose_util/create_alias.t b/t/moose_util/create_alias.t new file mode 100644 index 0000000..1f97104 --- /dev/null +++ b/t/moose_util/create_alias.t @@ -0,0 +1,102 @@ +use strict; +use warnings; + +use Test::More; +use Test::Moose qw(does_ok); + +BEGIN { + package Foo::Meta::Role; + use Moose::Role; + Moose::Util::meta_class_alias + FooRole => 'Foo::Meta::Role'; + + package Foo::Meta::Class; + use Moose; + extends 'Moose::Meta::Class'; + with 'Foo::Meta::Role'; + Moose::Util::meta_class_alias + FooClass => 'Foo::Meta::Class'; + + package Foo::Meta::Role::Attribute; + use Moose::Role; + Moose::Util::meta_attribute_alias + FooAttrRole => 'Foo::Meta::Role::Attribute'; + + package Foo::Meta::Attribute; + use Moose; + extends 'Moose::Meta::Attribute'; + with 'Foo::Meta::Role::Attribute'; + Moose::Util::meta_attribute_alias + FooAttrClass => 'Foo::Meta::Attribute'; + + package Bar::Meta::Role; + use Moose::Role; + Moose::Util::meta_class_alias 'BarRole'; + + package Bar::Meta::Class; + use Moose; + extends 'Moose::Meta::Class'; + with 'Bar::Meta::Role'; + Moose::Util::meta_class_alias 'BarClass'; + + package Bar::Meta::Role::Attribute; + use Moose::Role; + Moose::Util::meta_attribute_alias 'BarAttrRole'; + + package Bar::Meta::Attribute; + use Moose; + extends 'Moose::Meta::Attribute'; + with 'Bar::Meta::Role::Attribute'; + Moose::Util::meta_attribute_alias 'BarAttrClass'; +} + +package FooWithMetaClass; +use Moose -metaclass => 'FooClass'; + +has bar => ( + metaclass => 'FooAttrClass', + is => 'ro', +); + + +package FooWithMetaTrait; +use Moose -traits => 'FooRole'; + +has bar => ( + traits => [qw(FooAttrRole)], + is => 'ro', +); + +package BarWithMetaClass; +use Moose -metaclass => 'BarClass'; + +has bar => ( + metaclass => 'BarAttrClass', + is => 'ro', +); + + +package BarWithMetaTrait; +use Moose -traits => 'BarRole'; + +has bar => ( + traits => [qw(BarAttrRole)], + is => 'ro', +); + +package main; +my $fwmc_meta = FooWithMetaClass->meta; +my $fwmt_meta = FooWithMetaTrait->meta; +isa_ok($fwmc_meta, 'Foo::Meta::Class'); +isa_ok($fwmc_meta->get_attribute('bar'), 'Foo::Meta::Attribute'); +does_ok($fwmt_meta, 'Foo::Meta::Role'); +does_ok($fwmt_meta->get_attribute('bar'), 'Foo::Meta::Role::Attribute'); + +my $bwmc_meta = BarWithMetaClass->meta; +my $bwmt_meta = BarWithMetaTrait->meta; +isa_ok($bwmc_meta, 'Bar::Meta::Class'); +isa_ok($bwmc_meta->get_attribute('bar'), 'Bar::Meta::Attribute'); +does_ok($bwmt_meta, 'Bar::Meta::Role'); +does_ok($bwmt_meta->get_attribute('bar'), 'Bar::Meta::Role::Attribute'); + +done_testing; diff --git a/t/moose_util/ensure_all_roles.t b/t/moose_util/ensure_all_roles.t new file mode 100644 index 0000000..9888bfb --- /dev/null +++ b/t/moose_util/ensure_all_roles.t @@ -0,0 +1,62 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util ':all'; + +{ + package Foo; + use Moose::Role; +} + +{ + package Bar; + use Moose::Role; +} + +{ + package Quux; + use Moose; +} + +is_deeply( + Quux->meta->roles, + [], + "no roles yet", +); + +Foo->meta->apply(Quux->meta); + +is_deeply( + Quux->meta->roles, + [ Foo->meta ], + "applied Foo", +); + +Foo->meta->apply(Quux->meta); +Bar->meta->apply(Quux->meta); +is_deeply( + Quux->meta->roles, + [ Foo->meta, Foo->meta, Bar->meta ], + "duplicated Foo", +); + +is(does_role('Quux', 'Foo'), 1, "Quux does Foo"); +is(does_role('Quux', 'Bar'), 1, "Quux does Bar"); +ensure_all_roles('Quux', qw(Foo Bar)); +is_deeply( + Quux->meta->roles, + [ Foo->meta, Foo->meta, Bar->meta ], + "unchanged, since all roles are already applied", +); + +my $obj = Quux->new; +ensure_all_roles($obj, qw(Foo Bar)); +is_deeply( + $obj->meta->roles, + [ Foo->meta, Foo->meta, Bar->meta ], + "unchanged, since all roles are already applied", +); + +done_testing; diff --git a/t/moose_util/method_mod_args.t b/t/moose_util/method_mod_args.t new file mode 100644 index 0000000..c4536d8 --- /dev/null +++ b/t/moose_util/method_mod_args.t @@ -0,0 +1,31 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Moose::Util qw( add_method_modifier ); + +my $COUNT = 0; +{ + package Foo; + use Moose; + + sub foo { } + sub bar { } +} + +is( exception { + add_method_modifier('Foo', 'before', [ ['foo', 'bar'], sub { $COUNT++ } ]); +}, undef, 'method modifier with an arrayref' ); + +isnt( exception { + add_method_modifier('Foo', 'before', [ {'foo' => 'bar'}, sub { $COUNT++ } ]); +}, undef, 'method modifier with a hashref' ); + +my $foo = Foo->new; +$foo->foo; +$foo->bar; +is($COUNT, 2, "checking that the modifiers were installed."); + + +done_testing; diff --git a/t/moose_util/moose_util.t b/t/moose_util/moose_util.t new file mode 100644 index 0000000..3203f74 --- /dev/null +++ b/t/moose_util/moose_util.t @@ -0,0 +1,43 @@ +use strict; +use warnings; + +use Test::More; + +BEGIN { + use_ok('Moose::Util'); +} + +{ + package Moosey::Class; + use Moose; +} +{ + package Moosey::Role; + use Moose::Role; +} +{ + package Other; +} +{ + package Moosey::Composed; + use Moose; + with 'Moosey::Role'; +} + +use Moose::Util 'is_role'; + +{ + my $class = Moosey::Class->new; + my $composed = Moosey::Composed->new; + + ok(!is_role('Moosey::Class'), 'a moose class is not a role'); + ok(is_role('Moosey::Role'), 'a moose role is a role'); + ok(!is_role('Other'), 'something else is not a role'); + ok(!is_role('DoesNotExist'), 'non-existent namespace is not a role'); + ok(!is_role('Moosey::Composed'), 'a moose class that composes a role is not a role'); + + ok(!is_role($class), 'instantiated moose object is not a role'); + ok(!is_role($composed), 'instantiated moose object that does a role is not a role'); +} + +done_testing; diff --git a/t/moose_util/moose_util_does_role.t b/t/moose_util/moose_util_does_role.t new file mode 100644 index 0000000..916e3e7 --- /dev/null +++ b/t/moose_util/moose_util_does_role.t @@ -0,0 +1,92 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util ':all'; + +{ + package Foo; + + use Moose::Role; +} + +{ + package Bar; + + use Moose; + + with qw/Foo/; +} + +{ + package Baz; + + use Moose; +} + +{ + package Quux; + + use metaclass; +} + +{ + package Foo::Foo; + + use Moose::Role; + + with 'Foo'; +} + +{ + package DoesMethod; + use Moose; + + sub does { + my $self = shift; + my ($role) = @_; + return 1 if $role eq 'Something::Else'; + return $self->SUPER::does(@_); + } +} + +# Classes + +ok(does_role('Bar', 'Foo'), '... Bar does Foo'); + +ok(!does_role('Baz', 'Foo'), '... Baz doesnt do Foo'); + +# Objects + +my $bar = Bar->new; + +ok(does_role($bar, 'Foo'), '... $bar does Foo'); + +my $baz = Baz->new; + +ok(!does_role($baz, 'Foo'), '... $baz doesnt do Foo'); + +# Invalid values + +ok(!does_role(undef,'Foo'), '... undef doesnt do Foo'); + +ok(!does_role(1,'Foo'), '... 1 doesnt do Foo'); + +# non Moose metaclass + +ok(!does_role('Quux', 'Foo'), '... Quux doesnt do Foo (does not die tho)'); + +# overriding the does method works properly + +ok(does_role('DoesMethod', 'Something::Else'), '... can override the does method'); + +# Self + +ok(does_role('Foo', 'Foo'), '... Foo does do Foo'); + +# sub-Roles + +ok(does_role('Foo::Foo', 'Foo'), '... Foo::Foo does do Foo'); + +done_testing; diff --git a/t/moose_util/moose_util_search_class_by_role.t b/t/moose_util/moose_util_search_class_by_role.t new file mode 100644 index 0000000..3984757 --- /dev/null +++ b/t/moose_util/moose_util_search_class_by_role.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util ':all'; + +{ package SCBR::Role; + use Moose::Role; +} + +{ package SCBR::A; + use Moose; +} +is search_class_by_role('SCBR::A', 'SCBR::Role'), undef, '... not found role returns undef'; +is search_class_by_role('SCBR::A', SCBR::Role->meta), undef, '... not found role returns undef'; + +{ package SCBR::B; + use Moose; + extends 'SCBR::A'; + with 'SCBR::Role'; +} +is search_class_by_role('SCBR::B', 'SCBR::Role'), 'SCBR::B', '... class itself returned if it does role'; +is search_class_by_role('SCBR::B', SCBR::Role->meta), 'SCBR::B', '... class itself returned if it does role'; + +{ package SCBR::C; + use Moose; + extends 'SCBR::B'; +} +is search_class_by_role('SCBR::C', 'SCBR::Role'), 'SCBR::B', '... nearest class doing role returned'; +is search_class_by_role('SCBR::C', SCBR::Role->meta), 'SCBR::B', '... nearest class doing role returned'; + +{ package SCBR::D; + use Moose; + extends 'SCBR::C'; + with 'SCBR::Role'; +} +is search_class_by_role('SCBR::D', 'SCBR::Role'), 'SCBR::D', '... nearest class being direct class returned'; +is search_class_by_role('SCBR::D', SCBR::Role->meta), 'SCBR::D', '... nearest class being direct class returned'; + +done_testing; diff --git a/t/moose_util/resolve_alias.t b/t/moose_util/resolve_alias.t new file mode 100644 index 0000000..5b09b86 --- /dev/null +++ b/t/moose_util/resolve_alias.t @@ -0,0 +1,77 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util qw( resolve_metaclass_alias resolve_metatrait_alias ); + +use lib 't/lib'; + +# Doing each test twice is intended to make sure that the caching +# doesn't break name resolution. It doesn't actually test that +# anything is cached. +is( resolve_metaclass_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Foo' ), + 'Moose::Meta::Attribute::Custom::Foo', + 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Foo' ); + +is( resolve_metaclass_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Foo' ), + 'Moose::Meta::Attribute::Custom::Foo', + 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Foo second time' ); + +is( resolve_metaclass_alias( 'Attribute', 'Foo' ), + 'Moose::Meta::Attribute::Custom::Foo', + 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Foo via alias (Foo)' ); + +is( resolve_metaclass_alias( 'Attribute', 'Foo' ), + 'Moose::Meta::Attribute::Custom::Foo', + 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Foo via alias (Foo) a second time' ); + +is( resolve_metaclass_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Bar' ), + 'My::Bar', + 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Bar as My::Bar' ); + +is( resolve_metaclass_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Bar' ), + 'My::Bar', + 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Bar as My::Bar a second time' ); + +is( resolve_metaclass_alias( 'Attribute', 'Bar' ), + 'My::Bar', + 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Bar as My::Bar via alias (Bar)' ); + +is( resolve_metaclass_alias( 'Attribute', 'Bar' ), + 'My::Bar', + 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Bar as My::Bar via alias (Bar) a second time' ); + +is( resolve_metatrait_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Trait::Foo' ), + 'Moose::Meta::Attribute::Custom::Trait::Foo', + 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Foo' ); + +is( resolve_metatrait_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Trait::Foo' ), + 'Moose::Meta::Attribute::Custom::Trait::Foo', + 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Foo second time' ); + +is( resolve_metatrait_alias( 'Attribute', 'Foo' ), + 'Moose::Meta::Attribute::Custom::Trait::Foo', + 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Foo via alias (Foo)' ); + +is( resolve_metatrait_alias( 'Attribute', 'Foo' ), + 'Moose::Meta::Attribute::Custom::Trait::Foo', + 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Foo via alias (Foo) a second time' ); + +is( resolve_metatrait_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Trait::Bar' ), + 'My::Trait::Bar', + 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Bar as My::Trait::Bar' ); + +is( resolve_metatrait_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Trait::Bar' ), + 'My::Trait::Bar', + 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Bar as My::Trait::Bar a second time' ); + +is( resolve_metatrait_alias( 'Attribute', 'Bar' ), + 'My::Trait::Bar', + 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Bar as My::Trait::Bar via alias (Bar)' ); + +is( resolve_metatrait_alias( 'Attribute', 'Bar' ), + 'My::Trait::Bar', + 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Bar as My::Trait::Bar via alias (Bar) a second time' ); + +done_testing; diff --git a/t/moose_util/with_traits.t b/t/moose_util/with_traits.t new file mode 100644 index 0000000..6388eeb --- /dev/null +++ b/t/moose_util/with_traits.t @@ -0,0 +1,50 @@ +use strict; +use warnings; +use Test::More; +use Test::Moose; + +use Moose (); +use Moose::Util qw(with_traits); + +{ + package Foo; + use Moose; +} + +{ + package Foo::Role; + use Moose::Role; +} + +{ + package Foo::Role2; + use Moose::Role; +} + +{ + my $traited_class = with_traits('Foo', 'Foo::Role'); + ok($traited_class->meta->is_anon_class, "we get an anon class"); + isa_ok($traited_class, 'Foo'); + does_ok($traited_class, 'Foo::Role'); +} + +{ + my $traited_class = with_traits('Foo', 'Foo::Role', 'Foo::Role2'); + ok($traited_class->meta->is_anon_class, "we get an anon class"); + isa_ok($traited_class, 'Foo'); + does_ok($traited_class, 'Foo::Role'); + does_ok($traited_class, 'Foo::Role2'); +} + +{ + my $traited_class = with_traits('Foo'); + is($traited_class, 'Foo', "don't apply anything if we don't get any traits"); +} + +{ + my $traited_class = with_traits('Foo', 'Foo::Role'); + my $traited_class2 = with_traits('Foo', 'Foo::Role'); + is($traited_class, $traited_class2, "get the same class back when passing the same roles"); +} + +done_testing; diff --git a/t/native_traits/array_coerce.t b/t/native_traits/array_coerce.t new file mode 100644 index 0000000..301fd01 --- /dev/null +++ b/t/native_traits/array_coerce.t @@ -0,0 +1,235 @@ +use strict; +use warnings; + +use Test::More; + +{ + + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + subtype 'UCArray', as 'ArrayRef[Str]', where { + !grep {/[a-z]/} @{$_}; + }; + + coerce 'UCArray', from 'ArrayRef[Str]', via { + [ map { uc $_ } @{$_} ]; + }; + + has array => ( + traits => ['Array'], + is => 'rw', + isa => 'UCArray', + coerce => 1, + handles => { + push_array => 'push', + set_array => 'set', + }, + ); + + our @TriggerArgs; + + has lazy => ( + traits => ['Array'], + is => 'rw', + isa => 'UCArray', + coerce => 1, + lazy => 1, + default => sub { ['a'] }, + handles => { + push_lazy => 'push', + set_lazy => 'set', + }, + trigger => sub { @TriggerArgs = @_ }, + clearer => 'clear_lazy', + ); +} + +my $foo = Foo->new; + +{ + $foo->array( [qw( A B C )] ); + + $foo->push_array('d'); + + is_deeply( + $foo->array, [qw( A B C D )], + 'push coerces the array' + ); + + $foo->set_array( 1 => 'x' ); + + is_deeply( + $foo->array, [qw( A X C D )], + 'set coerces the array' + ); +} + +{ + $foo->push_lazy('d'); + + is_deeply( + $foo->lazy, [qw( A D )], + 'push coerces the array - lazy' + ); + + is_deeply( + \@Foo::TriggerArgs, + [ $foo, [qw( A D )], ['A'] ], + 'trigger receives expected arguments' + ); + + $foo->set_lazy( 2 => 'f' ); + + is_deeply( + $foo->lazy, [qw( A D F )], + 'set coerces the array - lazy' + ); + + is_deeply( + \@Foo::TriggerArgs, + [ $foo, [qw( A D F )], [qw( A D )] ], + 'trigger receives expected arguments' + ); +} + +{ + package Thing; + use Moose; + + has thing => ( + is => 'ro', + isa => 'Int', + ); +} + +{ + package Bar; + use Moose; + use Moose::Util::TypeConstraints; + + class_type 'Thing'; + + coerce 'Thing' + => from 'Int' + => via { Thing->new( thing => $_ ) }; + + subtype 'ArrayRefOfThings' + => as 'ArrayRef[Thing]'; + + coerce 'ArrayRefOfThings' + => from 'ArrayRef[Int]' + => via { [ map { Thing->new( thing => $_ ) } @{$_} ] }; + + coerce 'ArrayRefOfThings' + => from 'Int' + => via { [ Thing->new( thing => $_ ) ] }; + + has array => ( + traits => ['Array'], + is => 'rw', + isa => 'ArrayRefOfThings', + coerce => 1, + handles => { + push_array => 'push', + unshift_array => 'unshift', + set_array => 'set', + insert_array => 'insert', + }, + ); +} + +{ + my $bar = Bar->new( array => [ 1, 2, 3 ] ); + + $bar->push_array( 4, 5 ); + + is_deeply( + [ map { $_->thing } @{ $bar->array } ], + [ 1, 2, 3, 4, 5 ], + 'push coerces new members' + ); + + $bar->unshift_array( -1, 0 ); + + is_deeply( + [ map { $_->thing } @{ $bar->array } ], + [ -1, 0, 1, 2, 3, 4, 5 ], + 'unshift coerces new members' + ); + + $bar->set_array( 3 => 9 ); + + is_deeply( + [ map { $_->thing } @{ $bar->array } ], + [ -1, 0, 1, 9, 3, 4, 5 ], + 'set coerces new members' + ); + + $bar->insert_array( 3 => 42 ); + + is_deeply( + [ map { $_->thing } @{ $bar->array } ], + [ -1, 0, 1, 42, 9, 3, 4, 5 ], + 'insert coerces new members' + ); +} + +{ + package Baz; + use Moose; + use Moose::Util::TypeConstraints; + + subtype 'SmallArrayRef' + => as 'ArrayRef' + => where { @{$_} <= 2 }; + + coerce 'SmallArrayRef' + => from 'ArrayRef' + => via { [ @{$_}[ -2, -1 ] ] }; + + has array => ( + traits => ['Array'], + is => 'rw', + isa => 'SmallArrayRef', + coerce => 1, + handles => { + push_array => 'push', + set_array => 'set', + insert_array => 'insert', + }, + ); +} + +{ + my $baz = Baz->new( array => [ 1, 2, 3 ] ); + + is_deeply( + $baz->array, [ 2, 3 ], + 'coercion truncates array ref in constructor' + ); + + $baz->push_array(4); + + is_deeply( + $baz->array, [ 3, 4 ], + 'coercion truncates array ref on push' + ); + + $baz->insert_array( 1 => 5 ); + + is_deeply( + $baz->array, [ 5, 4 ], + 'coercion truncates array ref on insert' + ); + + $baz->push_array( 7, 8, 9 ); + + is_deeply( + $baz->array, [ 8, 9 ], + 'coercion truncates array ref on push' + ); +} + +done_testing; diff --git a/t/native_traits/array_from_role.t b/t/native_traits/array_from_role.t new file mode 100644 index 0000000..21d0a06 --- /dev/null +++ b/t/native_traits/array_from_role.t @@ -0,0 +1,44 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package Foo; + use Moose; + + has 'bar' => ( is => 'rw' ); + + package Stuffed::Role; + use Moose::Role; + + has 'options' => ( + traits => ['Array'], + is => 'ro', + isa => 'ArrayRef[Foo]', + ); + + package Bulkie::Role; + use Moose::Role; + + has 'stuff' => ( + traits => ['Array'], + is => 'ro', + isa => 'ArrayRef', + handles => { + get_stuff => 'get', + } + ); + + package Stuff; + use Moose; + + ::is( ::exception { with 'Stuffed::Role'; + }, undef, '... this should work correctly' ); + + ::is( ::exception { with 'Bulkie::Role'; + }, undef, '... this should work correctly' ); +} + +done_testing; diff --git a/t/native_traits/array_subtypes.t b/t/native_traits/array_subtypes.t new file mode 100644 index 0000000..d85c8f6 --- /dev/null +++ b/t/native_traits/array_subtypes.t @@ -0,0 +1,264 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +{ + use Moose::Util::TypeConstraints; + use List::Util qw(sum); + + subtype 'A1', as 'ArrayRef[Int]'; + subtype 'A2', as 'ArrayRef', where { @$_ < 2 }; + subtype 'A3', as 'ArrayRef[Int]', where { ( sum(@$_) || 0 ) < 5 }; + + subtype 'A5', as 'ArrayRef'; + coerce 'A5', from 'Str', via { [ $_ ] }; + + no Moose::Util::TypeConstraints; +} + +{ + package Foo; + use Moose; + + has array => ( + traits => ['Array'], + is => 'rw', + isa => 'ArrayRef', + handles => { + push_array => 'push', + }, + ); + + has array_int => ( + traits => ['Array'], + is => 'rw', + isa => 'ArrayRef[Int]', + handles => { + push_array_int => 'push', + }, + ); + + has a1 => ( + traits => ['Array'], + is => 'rw', + isa => 'A1', + handles => { + push_a1 => 'push', + }, + ); + + has a2 => ( + traits => ['Array'], + is => 'rw', + isa => 'A2', + handles => { + push_a2 => 'push', + }, + ); + + has a3 => ( + traits => ['Array'], + is => 'rw', + isa => 'A3', + handles => { + push_a3 => 'push', + }, + ); + + has a4 => ( + traits => ['Array'], + is => 'rw', + isa => 'ArrayRef', + lazy => 1, + default => 'invalid', + clearer => '_clear_a4', + handles => { + get_a4 => 'get', + push_a4 => 'push', + accessor_a4 => 'accessor', + }, + ); + + has a5 => ( + traits => ['Array'], + is => 'rw', + isa => 'A5', + coerce => 1, + lazy => 1, + default => 'invalid', + clearer => '_clear_a5', + handles => { + get_a5 => 'get', + push_a5 => 'push', + accessor_a5 => 'accessor', + }, + ); +} + +my $foo = Foo->new; + +{ + $foo->array( [] ); + is_deeply( $foo->array, [], "array - correct contents" ); + + $foo->push_array('foo'); + is_deeply( $foo->array, ['foo'], "array - correct contents" ); +} + +{ + $foo->array_int( [] ); + is_deeply( $foo->array_int, [], "array_int - correct contents" ); + + isnt( exception { $foo->push_array_int('foo') }, undef, "array_int - can't push wrong type" ); + is_deeply( $foo->array_int, [], "array_int - correct contents" ); + + $foo->push_array_int(1); + is_deeply( $foo->array_int, [1], "array_int - correct contents" ); +} + +{ + isnt( exception { $foo->push_a1('foo') }, undef, "a1 - can't push onto undef" ); + + $foo->a1( [] ); + is_deeply( $foo->a1, [], "a1 - correct contents" ); + + isnt( exception { $foo->push_a1('foo') }, undef, "a1 - can't push wrong type" ); + + is_deeply( $foo->a1, [], "a1 - correct contents" ); + + $foo->push_a1(1); + is_deeply( $foo->a1, [1], "a1 - correct contents" ); +} + +{ + isnt( exception { $foo->push_a2('foo') }, undef, "a2 - can't push onto undef" ); + + $foo->a2( [] ); + is_deeply( $foo->a2, [], "a2 - correct contents" ); + + $foo->push_a2('foo'); + is_deeply( $foo->a2, ['foo'], "a2 - correct contents" ); + + isnt( exception { $foo->push_a2('bar') }, undef, "a2 - can't push more than one element" ); + + is_deeply( $foo->a2, ['foo'], "a2 - correct contents" ); +} + +{ + isnt( exception { $foo->push_a3(1) }, undef, "a3 - can't push onto undef" ); + + $foo->a3( [] ); + is_deeply( $foo->a3, [], "a3 - correct contents" ); + + isnt( exception { $foo->push_a3('foo') }, undef, "a3 - can't push non-int" ); + + isnt( exception { $foo->push_a3(100) }, undef, "a3 - can't violate overall type constraint" ); + + is_deeply( $foo->a3, [], "a3 - correct contents" ); + + $foo->push_a3(1); + is_deeply( $foo->a3, [1], "a3 - correct contents" ); + + isnt( exception { $foo->push_a3(100) }, undef, "a3 - can't violate overall type constraint" ); + + is_deeply( $foo->a3, [1], "a3 - correct contents" ); + + $foo->push_a3(3); + is_deeply( $foo->a3, [ 1, 3 ], "a3 - correct contents" ); +} + +{ + my $expect + = qr/\QAttribute (a4) does not pass the type constraint because: Validation failed for 'ArrayRef' with value \E.*invalid.*/; + + like( + exception { $foo->accessor_a4(0); }, + $expect, + 'invalid default is caught when trying to read via accessor' + ); + + like( + exception { $foo->accessor_a4( 0 => 42 ); }, + $expect, + 'invalid default is caught when trying to write via accessor' + ); + + like( + exception { $foo->push_a4(42); }, + $expect, + 'invalid default is caught when trying to push' + ); + + like( + exception { $foo->get_a4(42); }, + $expect, + 'invalid default is caught when trying to get' + ); +} + +{ + my $foo = Foo->new; + + is( + $foo->accessor_a5(0), 'invalid', + 'lazy default is coerced when trying to read via accessor' + ); + + $foo->_clear_a5; + + $foo->accessor_a5( 1 => 'thing' ); + + is_deeply( + $foo->a5, + [ 'invalid', 'thing' ], + 'lazy default is coerced when trying to write via accessor' + ); + + $foo->_clear_a5; + + $foo->push_a5('thing'); + + is_deeply( + $foo->a5, + [ 'invalid', 'thing' ], + 'lazy default is coerced when trying to push' + ); + + $foo->_clear_a5; + + is( + $foo->get_a5(0), 'invalid', + 'lazy default is coerced when trying to get' + ); +} + +{ + package Bar; + use Moose; +} + +{ + package HasArray; + use Moose; + + has objects => ( + isa => 'ArrayRef[Foo]', + traits => ['Array'], + handles => { + push_objects => 'push', + }, + ); +} + +{ + my $ha = HasArray->new(); + + like( + exception { $ha->push_objects( Bar->new ) }, + qr/\QValidation failed for 'Foo'/, + 'got expected error when pushing an object of the wrong class onto an array ref' + ); +} + +done_testing; diff --git a/t/native_traits/array_trigger.t b/t/native_traits/array_trigger.t new file mode 100644 index 0000000..419c303 --- /dev/null +++ b/t/native_traits/array_trigger.t @@ -0,0 +1,53 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Foo; + use Moose; + + our @TriggerArgs; + + has array => ( + traits => ['Array'], + is => 'rw', + isa => 'ArrayRef', + handles => { + push_array => 'push', + set_array => 'set', + }, + clearer => 'clear_array', + trigger => sub { @TriggerArgs = @_ }, + ); +} + +my $foo = Foo->new; + +{ + $foo->array( [ 1, 2, 3 ] ); + + is_deeply( + \@Foo::TriggerArgs, + [ $foo, [ 1, 2, 3 ] ], + 'trigger was called for normal writer' + ); + + $foo->push_array(5); + + is_deeply( + \@Foo::TriggerArgs, + [ $foo, [ 1, 2, 3, 5 ], [ 1, 2, 3 ] ], + 'trigger was called on push' + ); + + $foo->set_array( 1, 42 ); + + is_deeply( + \@Foo::TriggerArgs, + [ $foo, [ 1, 42, 3, 5 ], [ 1, 2, 3, 5 ] ], + 'trigger was called on set' + ); +} + +done_testing; diff --git a/t/native_traits/collection_with_roles.t b/t/native_traits/collection_with_roles.t new file mode 100644 index 0000000..6d75675 --- /dev/null +++ b/t/native_traits/collection_with_roles.t @@ -0,0 +1,122 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Subject; + + use Moose::Role; + + has observers => ( + traits => ['Array'], + is => 'ro', + isa => 'ArrayRef[Observer]', + auto_deref => 1, + default => sub { [] }, + handles => { + 'add_observer' => 'push', + 'count_observers' => 'count', + }, + ); + + sub notify { + my ($self) = @_; + foreach my $observer ( $self->observers() ) { + $observer->update($self); + } + } +} + +{ + package Observer; + + use Moose::Role; + + requires 'update'; +} + +{ + package Counter; + + use Moose; + + with 'Subject'; + + has count => ( + traits => ['Counter'], + is => 'ro', + isa => 'Int', + default => 0, + handles => { + inc_counter => 'inc', + dec_counter => 'dec', + }, + ); + + after qw(inc_counter dec_counter) => sub { + my ($self) = @_; + $self->notify(); + }; +} + +{ + + package Display; + + use Test::More; + + use Moose; + + with 'Observer'; + + sub update { + my ( $self, $subject ) = @_; + like $subject->count, qr{^-?\d+$}, + 'Observed number ' . $subject->count; + } +} + +package main; + +my $count = Counter->new(); + +ok( $count->can('add_observer'), 'add_observer method added' ); + +ok( $count->can('count_observers'), 'count_observers method added' ); + +ok( $count->can('inc_counter'), 'inc_counter method added' ); + +ok( $count->can('dec_counter'), 'dec_counter method added' ); + +$count->add_observer( Display->new() ); + +is( $count->count_observers, 1, 'Only one observer' ); + +is( $count->count, 0, 'Default to zero' ); + +$count->inc_counter; + +is( $count->count, 1, 'Increment to one ' ); + +$count->inc_counter for ( 1 .. 6 ); + +is( $count->count, 7, 'Increment up to seven' ); + +$count->dec_counter; + +is( $count->count, 6, 'Decrement to 6' ); + +$count->dec_counter for ( 1 .. 5 ); + +is( $count->count, 1, 'Decrement to 1' ); + +$count->dec_counter for ( 1 .. 2 ); + +is( $count->count, -1, 'Negative numbers' ); + +$count->inc_counter; + +is( $count->count, 0, 'Back to zero' ); + +done_testing; diff --git a/t/native_traits/custom_instance.t b/t/native_traits/custom_instance.t new file mode 100644 index 0000000..0b08339 --- /dev/null +++ b/t/native_traits/custom_instance.t @@ -0,0 +1,246 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; +use Test::Moose; + +{ + package ValueContainer; + use Moose; + + has value => ( + is => 'rw', + ); +} + +{ + package Foo::Meta::Instance; + use Moose::Role; + + around get_slot_value => sub { + my $orig = shift; + my $self = shift; + my ($instance, $slot_name) = @_; + my $value = $self->$orig(@_); + if ($value->isa('ValueContainer')) { + $value = $value->value; + } + return $value; + }; + + around inline_get_slot_value => sub { + my $orig = shift; + my $self = shift; + my $value = $self->$orig(@_); + return q[do {] . "\n" + . q[ my $value = ] . $value . q[;] . "\n" + . q[ if ($value->isa('ValueContainer')) {] . "\n" + . q[ $value = $value->value;] . "\n" + . q[ }] . "\n" + . q[ $value] . "\n" + . q[}]; + }; + + sub inline_get_is_lvalue { 0 } +} + +{ + package Foo; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { + instance => ['Foo::Meta::Instance'], + } + ); + + ::is( ::exception { + has array => ( + traits => ['Array'], + isa => 'ArrayRef', + default => sub { [] }, + handles => { + array_count => 'count', + array_elements => 'elements', + array_is_empty => 'is_empty', + array_push => 'push', + array_push_curried => [ push => 42, 84 ], + array_unshift => 'unshift', + array_unshift_curried => [ unshift => 42, 84 ], + array_pop => 'pop', + array_shift => 'shift', + array_get => 'get', + array_get_curried => [ get => 1 ], + array_set => 'set', + array_set_curried_1 => [ set => 1 ], + array_set_curried_2 => [ set => ( 1, 98 ) ], + array_accessor => 'accessor', + array_accessor_curried_1 => [ accessor => 1 ], + array_accessor_curried_2 => [ accessor => ( 1, 90 ) ], + array_clear => 'clear', + array_delete => 'delete', + array_delete_curried => [ delete => 1 ], + array_insert => 'insert', + array_insert_curried => [ insert => ( 1, 101 ) ], + array_splice => 'splice', + array_splice_curried_1 => [ splice => 1 ], + array_splice_curried_2 => [ splice => 1, 2 ], + array_splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ], + array_sort => 'sort', + array_sort_curried => + [ sort => ( sub { $_[1] <=> $_[0] } ) ], + array_sort_in_place => 'sort_in_place', + array_sort_in_place_curried => + [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ], + array_map => 'map', + array_map_curried => [ map => ( sub { $_ + 1 } ) ], + array_grep => 'grep', + array_grep_curried => [ grep => ( sub { $_ < 5 } ) ], + array_first => 'first', + array_first_curried => [ first => ( sub { $_ % 2 } ) ], + array_join => 'join', + array_join_curried => [ join => '-' ], + array_shuffle => 'shuffle', + array_uniq => 'uniq', + array_reduce => 'reduce', + array_reduce_curried => + [ reduce => ( sub { $_[0] * $_[1] } ) ], + array_natatime => 'natatime', + array_natatime_curried => [ natatime => 2 ], + }, + ); + }, undef, "native array trait inlines properly" ); + + ::is( ::exception { + has bool => ( + traits => ['Bool'], + isa => 'Bool', + default => 0, + handles => { + bool_illuminate => 'set', + bool_darken => 'unset', + bool_flip_switch => 'toggle', + bool_is_dark => 'not', + }, + ); + }, undef, "native bool trait inlines properly" ); + + ::is( ::exception { + has code => ( + traits => ['Code'], + isa => 'CodeRef', + default => sub { sub { } }, + handles => { + code_execute => 'execute', + code_execute_method => 'execute_method', + }, + ); + }, undef, "native code trait inlines properly" ); + + ::is( ::exception { + has counter => ( + traits => ['Counter'], + isa => 'Int', + default => 0, + handles => { + inc_counter => 'inc', + inc_counter_2 => [ inc => 2 ], + dec_counter => 'dec', + dec_counter_2 => [ dec => 2 ], + reset_counter => 'reset', + set_counter => 'set', + set_counter_42 => [ set => 42 ], + }, + ); + }, undef, "native counter trait inlines properly" ); + + ::is( ::exception { + has hash => ( + traits => ['Hash'], + isa => 'HashRef', + default => sub { {} }, + handles => { + hash_option_accessor => 'accessor', + hash_quantity => [ accessor => 'quantity' ], + hash_clear_options => 'clear', + hash_num_options => 'count', + hash_delete_option => 'delete', + hash_is_defined => 'defined', + hash_options_elements => 'elements', + hash_has_option => 'exists', + hash_get_option => 'get', + hash_has_no_options => 'is_empty', + hash_key_value => 'kv', + hash_set_option => 'set', + }, + ); + }, undef, "native hash trait inlines properly" ); + + ::is( ::exception { + has number => ( + traits => ['Number'], + isa => 'Num', + default => 0, + handles => { + num_abs => 'abs', + num_add => 'add', + num_inc => [ add => 1 ], + num_div => 'div', + num_cut_in_half => [ div => 2 ], + num_mod => 'mod', + num_odd => [ mod => 2 ], + num_mul => 'mul', + num_set => 'set', + num_sub => 'sub', + num_dec => [ sub => 1 ], + }, + ); + }, undef, "native number trait inlines properly" ); + + ::is( ::exception { + has string => ( + traits => ['String'], + is => 'ro', + isa => 'Str', + default => '', + handles => { + string_inc => 'inc', + string_append => 'append', + string_append_curried => [ append => '!' ], + string_prepend => 'prepend', + string_prepend_curried => [ prepend => '-' ], + string_replace => 'replace', + string_replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ], + string_chop => 'chop', + string_chomp => 'chomp', + string_clear => 'clear', + string_match => 'match', + string_match_curried => [ match => qr/\D/ ], + string_length => 'length', + string_substr => 'substr', + string_substr_curried_1 => [ substr => (1) ], + string_substr_curried_2 => [ substr => ( 1, 3 ) ], + string_substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ], + }, + ); + }, undef, "native string trait inlines properly" ); +} + +with_immutable { + { + my $foo = Foo->new(string => 'a'); + is($foo->string, 'a'); + $foo->string_append('b'); + is($foo->string, 'ab'); + } + + { + my $foo = Foo->new(string => ''); + $foo->{string} = ValueContainer->new(value => 'a'); + is($foo->string, 'a'); + $foo->string_append('b'); + is($foo->string, 'ab'); + } +} 'Foo'; + +done_testing; diff --git a/t/native_traits/hash_coerce.t b/t/native_traits/hash_coerce.t new file mode 100644 index 0000000..23d4093 --- /dev/null +++ b/t/native_traits/hash_coerce.t @@ -0,0 +1,148 @@ +use strict; +use warnings; + +use Test::More; + +{ + + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + subtype 'UCHash', as 'HashRef[Str]', where { + !grep {/[a-z]/} values %{$_}; + }; + + coerce 'UCHash', from 'HashRef[Str]', via { + $_ = uc $_ for values %{$_}; + $_; + }; + + has hash => ( + traits => ['Hash'], + is => 'rw', + isa => 'UCHash', + coerce => 1, + handles => { + set_key => 'set', + }, + ); + + our @TriggerArgs; + + has lazy => ( + traits => ['Hash'], + is => 'rw', + isa => 'UCHash', + coerce => 1, + lazy => 1, + default => sub { { x => 'a' } }, + handles => { + set_lazy => 'set', + }, + trigger => sub { @TriggerArgs = @_ }, + clearer => 'clear_lazy', + ); +} + +my $foo = Foo->new; + +{ + $foo->hash( { x => 'A', y => 'B' } ); + + $foo->set_key( z => 'c' ); + + is_deeply( + $foo->hash, { x => 'A', y => 'B', z => 'C' }, + 'set coerces the hash' + ); +} + +{ + $foo->set_lazy( y => 'b' ); + + is_deeply( + $foo->lazy, { x => 'A', y => 'B' }, + 'set coerces the hash - lazy' + ); + + is_deeply( + \@Foo::TriggerArgs, + [ $foo, { x => 'A', y => 'B' }, { x => 'A' } ], + 'trigger receives expected arguments' + ); +} + +{ + package Thing; + use Moose; + + has thing => ( + is => 'ro', + isa => 'Str', + ); +} + +{ + package Bar; + use Moose; + use Moose::Util::TypeConstraints; + + class_type 'Thing'; + + coerce 'Thing' + => from 'Str' + => via { Thing->new( thing => $_ ) }; + + subtype 'HashRefOfThings' + => as 'HashRef[Thing]'; + + coerce 'HashRefOfThings' + => from 'HashRef[Str]' + => via { + my %new; + for my $k ( keys %{$_} ) { + $new{$k} = Thing->new( thing => $_->{$k} ); + } + return \%new; + }; + + coerce 'HashRefOfThings' + => from 'Str' + => via { [ Thing->new( thing => $_ ) ] }; + + has hash => ( + traits => ['Hash'], + is => 'rw', + isa => 'HashRefOfThings', + coerce => 1, + handles => { + set_hash => 'set', + get_hash => 'get', + }, + ); +} + +{ + my $bar = Bar->new( hash => { foo => 1, bar => 2 } ); + + is( + $bar->get_hash('foo')->thing, 1, + 'constructor coerces hash reference' + ); + + $bar->set_hash( baz => 3, quux => 4 ); + + is( + $bar->get_hash('baz')->thing, 3, + 'set coerces new hash values' + ); + + is( + $bar->get_hash('quux')->thing, 4, + 'set coerces new hash values' + ); +} + + +done_testing; diff --git a/t/native_traits/hash_subtypes.t b/t/native_traits/hash_subtypes.t new file mode 100644 index 0000000..ff7eb96 --- /dev/null +++ b/t/native_traits/hash_subtypes.t @@ -0,0 +1,204 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + use Moose::Util::TypeConstraints; + use List::Util qw( sum ); + + subtype 'H1', as 'HashRef[Int]'; + subtype 'H2', as 'HashRef', where { scalar keys %{$_} < 2 }; + subtype 'H3', as 'HashRef[Int]', + where { ( sum( values %{$_} ) || 0 ) < 5 }; + + subtype 'H5', as 'HashRef'; + coerce 'H5', from 'Str', via { { key => $_ } }; + + no Moose::Util::TypeConstraints; +} + +{ + + package Foo; + use Moose; + + has hash_int => ( + traits => ['Hash'], + is => 'rw', + isa => 'HashRef[Int]', + handles => { + set_hash_int => 'set', + }, + ); + + has h1 => ( + traits => ['Hash'], + is => 'rw', + isa => 'H1', + handles => { + set_h1 => 'set', + }, + ); + + has h2 => ( + traits => ['Hash'], + is => 'rw', + isa => 'H2', + handles => { + set_h2 => 'set', + }, + ); + + has h3 => ( + traits => ['Hash'], + is => 'rw', + isa => 'H3', + handles => { + set_h3 => 'set', + }, + ); + + has h4 => ( + traits => ['Hash'], + is => 'rw', + isa => 'HashRef', + lazy => 1, + default => 'invalid', + clearer => '_clear_h4', + handles => { + get_h4 => 'get', + accessor_h4 => 'accessor', + }, + ); + + has h5 => ( + traits => ['Hash'], + is => 'rw', + isa => 'H5', + coerce => 1, + lazy => 1, + default => 'invalid', + clearer => '_clear_h5', + handles => { + get_h5 => 'get', + accessor_h5 => 'accessor', + }, + ); +} + +my $foo = Foo->new; + +{ + $foo->hash_int( {} ); + is_deeply( $foo->hash_int, {}, "hash_int - correct contents" ); + + isnt( exception { $foo->set_hash_int( x => 'foo' ) }, undef, "hash_int - can't set wrong type" ); + is_deeply( $foo->hash_int, {}, "hash_int - correct contents" ); + + $foo->set_hash_int( x => 1 ); + is_deeply( $foo->hash_int, { x => 1 }, "hash_int - correct contents" ); +} + +{ + isnt( exception { $foo->set_h1('foo') }, undef, "h1 - can't set onto undef" ); + + $foo->h1( {} ); + is_deeply( $foo->h1, {}, "h1 - correct contents" ); + + isnt( exception { $foo->set_h1( x => 'foo' ) }, undef, "h1 - can't set wrong type" ); + + is_deeply( $foo->h1, {}, "h1 - correct contents" ); + + $foo->set_h1( x => 1 ); + is_deeply( $foo->h1, { x => 1 }, "h1 - correct contents" ); +} + +{ + isnt( exception { $foo->set_h2('foo') }, undef, "h2 - can't set onto undef" ); + + $foo->h2( {} ); + is_deeply( $foo->h2, {}, "h2 - correct contents" ); + + $foo->set_h2( x => 'foo' ); + is_deeply( $foo->h2, { x => 'foo' }, "h2 - correct contents" ); + + isnt( exception { $foo->set_h2( y => 'bar' ) }, undef, "h2 - can't set more than one element" ); + + is_deeply( $foo->h2, { x => 'foo' }, "h2 - correct contents" ); +} + +{ + isnt( exception { $foo->set_h3(1) }, undef, "h3 - can't set onto undef" ); + + $foo->h3( {} ); + is_deeply( $foo->h3, {}, "h3 - correct contents" ); + + isnt( exception { $foo->set_h3( x => 'foo' ) }, undef, "h3 - can't set non-int" ); + + isnt( exception { $foo->set_h3( x => 100 ) }, undef, "h3 - can't violate overall type constraint" ); + + is_deeply( $foo->h3, {}, "h3 - correct contents" ); + + $foo->set_h3( x => 1 ); + is_deeply( $foo->h3, { x => 1 }, "h3 - correct contents" ); + + isnt( exception { $foo->set_h3( x => 100 ) }, undef, "h3 - can't violate overall type constraint" ); + + is_deeply( $foo->h3, { x => 1 }, "h3 - correct contents" ); + + $foo->set_h3( y => 3 ); + is_deeply( $foo->h3, { x => 1, y => 3 }, "h3 - correct contents" ); +} + +{ + my $expect + = qr/\QAttribute (h4) does not pass the type constraint because: Validation failed for 'HashRef' with value \E.*invalid.*/; + + like( + exception { $foo->accessor_h4('key'); }, + $expect, + 'invalid default is caught when trying to read via accessor' + ); + + like( + exception { $foo->accessor_h4( size => 42 ); }, + $expect, + 'invalid default is caught when trying to write via accessor' + ); + + like( + exception { $foo->get_h4(42); }, + $expect, + 'invalid default is caught when trying to get' + ); +} + +{ + my $foo = Foo->new; + + is( + $foo->accessor_h5('key'), 'invalid', + 'lazy default is coerced when trying to read via accessor' + ); + + $foo->_clear_h5; + + $foo->accessor_h5( size => 42 ); + + is_deeply( + $foo->h5, + { key => 'invalid', size => 42 }, + 'lazy default is coerced when trying to write via accessor' + ); + + $foo->_clear_h5; + + is( + $foo->get_h5('key'), 'invalid', + 'lazy default is coerced when trying to get' + ); +} + +done_testing; diff --git a/t/native_traits/hash_trigger.t b/t/native_traits/hash_trigger.t new file mode 100644 index 0000000..1618f3c --- /dev/null +++ b/t/native_traits/hash_trigger.t @@ -0,0 +1,54 @@ +use strict; +use warnings; + +use Test::More; + +{ + + package Foo; + use Moose; + + our @TriggerArgs; + + has hash => ( + traits => ['Hash'], + is => 'rw', + isa => 'HashRef', + handles => { + delete_key => 'delete', + set_key => 'set', + }, + clearer => 'clear_key', + trigger => sub { @TriggerArgs = @_ }, + ); +} + +my $foo = Foo->new; + +{ + $foo->hash( { x => 1, y => 2 } ); + + is_deeply( + \@Foo::TriggerArgs, + [ $foo, { x => 1, y => 2 } ], + 'trigger was called for normal writer' + ); + + $foo->set_key( z => 5 ); + + is_deeply( + \@Foo::TriggerArgs, + [ $foo, { x => 1, y => 2, z => 5 }, { x => 1, y => 2 } ], + 'trigger was called on set' + ); + + $foo->delete_key('y'); + + is_deeply( + \@Foo::TriggerArgs, + [ $foo, { x => 1, z => 5 }, { x => 1, y => 2, z => 5 } ], + 'trigger was called on delete' + ); +} + +done_testing; diff --git a/t/native_traits/remove_attribute.t b/t/native_traits/remove_attribute.t new file mode 100644 index 0000000..f1c7cbe --- /dev/null +++ b/t/native_traits/remove_attribute.t @@ -0,0 +1,48 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package MyHomePage; + use Moose; + + has 'counter' => ( + traits => ['Counter'], + is => 'ro', + isa => 'Int', + default => 0, + handles => { + inc_counter => 'inc', + dec_counter => 'dec', + reset_counter => 'reset', + } + ); +} + +my $page = MyHomePage->new(); +isa_ok( $page, 'MyHomePage' ); + +can_ok( $page, $_ ) for qw[ + counter + dec_counter + inc_counter + reset_counter +]; + +is( exception { + $page->meta->remove_attribute('counter'); +}, undef, '... removed the counter attribute okay' ); + +ok( !$page->meta->has_attribute('counter'), + '... no longer has the attribute' ); + +ok( !$page->can($_), "... our class no longer has the $_ method" ) for qw[ + counter + dec_counter + inc_counter + reset_counter +]; + +done_testing; diff --git a/t/native_traits/shallow_clone.t b/t/native_traits/shallow_clone.t new file mode 100644 index 0000000..6f25a3f --- /dev/null +++ b/t/native_traits/shallow_clone.t @@ -0,0 +1,42 @@ +use strict; +use warnings; + +use Test::More; +use Scalar::Util qw(refaddr); + +{ + package Foo; + use Moose; + + has 'array' => ( + traits => ['Array'], + is => 'ro', + handles => { array_clone => 'shallow_clone' }, + ); + + has 'hash' => ( + traits => ['Hash'], + is => 'ro', + handles => { hash_clone => 'shallow_clone' }, + ); + + no Moose; +} + +my $array = [ 1, 2, 3 ]; +my $hash = { a => 1, b => 2 }; + +my $obj = Foo->new({ + array => $array, + hash => $hash, +}); + +my $array_clone = $obj->array_clone; +my $hash_clone = $obj->hash_clone; + +isnt(refaddr($array), refaddr($array_clone), "array clone refers to new copy"); +is_deeply($array_clone, $array, "...but contents are the same"); +isnt(refaddr($hash), refaddr($hash_clone), "hash clone refers to new copy"); +is_deeply($hash_clone, $hash, "...but contents are the same"); + +done_testing; diff --git a/t/native_traits/trait_array.t b/t/native_traits/trait_array.t new file mode 100644 index 0000000..0435583 --- /dev/null +++ b/t/native_traits/trait_array.t @@ -0,0 +1,740 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Moose (); +use Moose::Util::TypeConstraints; +use NoInlineAttribute; +use Test::More; +use Test::Fatal; +use Test::Moose; + +{ + my %handles = ( + count => 'count', + elements => 'elements', + is_empty => 'is_empty', + push => 'push', + push_curried => + [ push => 42, 84 ], + unshift => 'unshift', + unshift_curried => + [ unshift => 42, 84 ], + pop => 'pop', + shift => 'shift', + get => 'get', + get_curried => [ get => 1 ], + set => 'set', + set_curried_1 => [ set => 1 ], + set_curried_2 => [ set => ( 1, 98 ) ], + accessor => 'accessor', + accessor_curried_1 => [ accessor => 1 ], + accessor_curried_2 => [ accessor => ( 1, 90 ) ], + clear => 'clear', + delete => 'delete', + delete_curried => [ delete => 1 ], + insert => 'insert', + insert_curried => [ insert => ( 1, 101 ) ], + splice => 'splice', + splice_curried_1 => [ splice => 1 ], + splice_curried_2 => [ splice => 1, 2 ], + splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ], + sort => 'sort', + sort_curried => [ sort => ( sub { $_[1] <=> $_[0] } ) ], + sort_in_place => 'sort_in_place', + sort_in_place_curried => + [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ], + map => 'map', + map_curried => [ map => ( sub { $_ + 1 } ) ], + grep => 'grep', + grep_curried => [ grep => ( sub { $_ < 5 } ) ], + first => 'first', + first_curried => [ first => ( sub { $_ % 2 } ) ], + first_index => 'first_index', + first_index_curried => [ first_index => ( sub { $_ % 2 } ) ], + join => 'join', + join_curried => [ join => '-' ], + shuffle => 'shuffle', + uniq => 'uniq', + reduce => 'reduce', + reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ], + natatime => 'natatime', + natatime_curried => [ natatime => 2 ], + ); + + my $name = 'Foo1'; + + sub build_class { + my %attr = @_; + + my $class = Moose::Meta::Class->create( + $name++, + superclasses => ['Moose::Object'], + ); + + my @traits = 'Array'; + push @traits, 'NoInlineAttribute' + if delete $attr{no_inline}; + + $class->add_attribute( + _values => ( + traits => \@traits, + is => 'rw', + isa => 'ArrayRef[Int]', + default => sub { [] }, + handles => \%handles, + clearer => '_clear_values', + %attr, + ), + ); + + return ( $class->name, \%handles ); + } +} + +{ + package Overloader; + + use overload + '&{}' => sub { ${ $_[0] } }, + bool => sub {1}; + + sub new { + bless \$_[1], $_[0]; + } +} + +{ + package OverloadStr; + use overload + q{""} => sub { ${ $_[0] } }, + fallback => 1; + + sub new { + my $class = shift; + my $str = shift; + return bless \$str, $class; + } +} + +{ + run_tests(build_class); + run_tests( build_class( lazy => 1, default => sub { [ 42, 84 ] } ) ); + run_tests( build_class( trigger => sub { } ) ); + run_tests( build_class( no_inline => 1 ) ); + + # Will force the inlining code to check the entire arrayref when it is modified. + subtype 'MyArrayRef', as 'ArrayRef', where { 1 }; + + run_tests( build_class( isa => 'MyArrayRef' ) ); + + coerce 'MyArrayRef', from 'ArrayRef', via { $_ }; + + run_tests( build_class( isa => 'MyArrayRef', coerce => 1 ) ); +} + +sub run_tests { + my ( $class, $handles ) = @_; + + can_ok( $class, $_ ) for sort keys %{$handles}; + + with_immutable { + my $obj = $class->new( _values => [ 10, 12, 42 ] ); + + is_deeply( + $obj->_values, [ 10, 12, 42 ], + 'values can be set in constructor' + ); + + ok( !$obj->is_empty, 'values is not empty' ); + is( $obj->count, 3, 'count returns 3' ); + + like( exception { $obj->count(22) }, qr/Cannot call count with any arguments/, 'throws an error when passing an argument passed to count' ); + + is( exception { $obj->push( 1, 2, 3 ) }, undef, 'pushed three new values and lived' ); + + is( exception { $obj->push() }, undef, 'call to push without arguments lives' ); + + is( exception { + is( $obj->unshift( 101, 22 ), 8, + 'unshift returns size of the new array' ); + }, undef, 'unshifted two values and lived' ); + + is_deeply( + $obj->_values, [ 101, 22, 10, 12, 42, 1, 2, 3 ], + 'unshift changed the value of the array in the object' + ); + + is( exception { $obj->unshift() }, undef, 'call to unshift without arguments lives' ); + + is( $obj->pop, 3, 'pop returns the last value in the array' ); + + is_deeply( + $obj->_values, [ 101, 22, 10, 12, 42, 1, 2 ], + 'pop changed the value of the array in the object' + ); + + like( exception { $obj->pop(42) }, qr/Cannot call pop with any arguments/, 'call to pop with arguments dies' ); + + is( $obj->shift, 101, 'shift returns the first value' ); + + like( exception { $obj->shift(42) }, qr/Cannot call shift with any arguments/, 'call to shift with arguments dies' ); + + is_deeply( + $obj->_values, [ 22, 10, 12, 42, 1, 2 ], + 'shift changed the value of the array in the object' + ); + + is_deeply( + [ $obj->elements ], [ 22, 10, 12, 42, 1, 2 ], + 'call to elements returns values as a list' + ); + + is(scalar($obj->elements), 6, 'elements accessor in scalar context returns the number of elements in the list'); + + like( exception { $obj->elements(22) }, qr/Cannot call elements with any arguments/, 'throws an error when passing an argument passed to elements' ); + + $obj->_values( [ 1, 2, 3 ] ); + + is( $obj->get(0), 1, 'get values at index 0' ); + is( $obj->get(1), 2, 'get values at index 1' ); + is( $obj->get(2), 3, 'get values at index 2' ); + is( $obj->get_curried, 2, 'get_curried returns value at index 1' ); + + like( exception { $obj->get() }, qr/Cannot call get without at least 1 argument/, 'throws an error when get is called without any arguments' ); + + like( exception { $obj->get( {} ) }, qr/The index passed to get must be an integer/, 'throws an error when get is called with an invalid argument' ); + + like( exception { $obj->get(2.2) }, qr/The index passed to get must be an integer/, 'throws an error when get is called with an invalid argument' ); + + like( exception { $obj->get('foo') }, qr/The index passed to get must be an integer/, 'throws an error when get is called with an invalid argument' ); + + like( exception { $obj->get_curried(2) }, qr/Cannot call get with more than 1 argument/, 'throws an error when get_curried is called with an argument' ); + + is( exception { + is( $obj->set( 1, 100 ), 100, 'set returns new value' ); + }, undef, 'set value at index 1 lives' ); + + is( $obj->get(1), 100, 'get value at index 1 returns new value' ); + + + like( exception { $obj->set( 1, 99, 42 ) }, qr/Cannot call set with more than 2 arguments/, 'throws an error when set is called with three arguments' ); + + is( exception { $obj->set_curried_1(99) }, undef, 'set_curried_1 lives' ); + + is( $obj->get(1), 99, 'get value at index 1 returns new value' ); + + like( exception { $obj->set_curried_1( 99, 42 ) }, qr/Cannot call set with more than 2 arguments/, 'throws an error when set_curried_1 is called with two arguments' ); + + is( exception { $obj->set_curried_2 }, undef, 'set_curried_2 lives' ); + + is( $obj->get(1), 98, 'get value at index 1 returns new value' ); + + like( exception { $obj->set_curried_2(42) }, qr/Cannot call set with more than 2 arguments/, 'throws an error when set_curried_2 is called with one argument' ); + + is( + $obj->accessor(1), 98, + 'accessor with one argument returns value at index 1' + ); + + is( exception { + is( $obj->accessor( 1 => 97 ), 97, 'accessor returns new value' ); + }, undef, 'accessor as writer lives' ); + + like( + exception { + $obj->accessor; + }, + qr/Cannot call accessor without at least 1 argument/, + 'throws an error when accessor is called without arguments' + ); + + is( + $obj->get(1), 97, + 'accessor set value at index 1' + ); + + like( exception { $obj->accessor( 1, 96, 42 ) }, qr/Cannot call accessor with more than 2 arguments/, 'throws an error when accessor is called with three arguments' ); + + is( + $obj->accessor_curried_1, 97, + 'accessor_curried_1 returns expected value when called with no arguments' + ); + + is( exception { $obj->accessor_curried_1(95) }, undef, 'accessor_curried_1 as writer lives' ); + + is( + $obj->get(1), 95, + 'accessor_curried_1 set value at index 1' + ); + + like( exception { $obj->accessor_curried_1( 96, 42 ) }, qr/Cannot call accessor with more than 2 arguments/, 'throws an error when accessor_curried_1 is called with two arguments' ); + + is( exception { $obj->accessor_curried_2 }, undef, 'accessor_curried_2 as writer lives' ); + + is( + $obj->get(1), 90, + 'accessor_curried_2 set value at index 1' + ); + + like( exception { $obj->accessor_curried_2(42) }, qr/Cannot call accessor with more than 2 arguments/, 'throws an error when accessor_curried_2 is called with one argument' ); + + is( exception { $obj->clear }, undef, 'clear lives' ); + + ok( $obj->is_empty, 'values is empty after call to clear' ); + + is( exception { + is( $obj->shift, undef, + 'shift returns undef on an empty array' ); + }, undef, 'shifted from an empty array and lived' ); + + $obj->set( 0 => 42 ); + + like( exception { $obj->clear(50) }, qr/Cannot call clear with any arguments/, 'throws an error when clear is called with an argument' ); + + ok( + !$obj->is_empty, + 'values is not empty after failed call to clear' + ); + + like( exception { $obj->is_empty(50) }, qr/Cannot call is_empty with any arguments/, 'throws an error when is_empty is called with an argument' ); + + $obj->clear; + is( + $obj->push( 1, 5, 10, 42 ), 4, + 'pushed 4 elements, got number of elements in the array back' + ); + + is( exception { + is( $obj->delete(2), 10, 'delete returns deleted value' ); + }, undef, 'delete lives' ); + + is_deeply( + $obj->_values, [ 1, 5, 42 ], + 'delete removed the specified element' + ); + + like( exception { $obj->delete( 2, 3 ) }, qr/Cannot call delete with more than 1 argument/, 'throws an error when delete is called with two arguments' ); + + is( exception { $obj->delete_curried }, undef, 'delete_curried lives' ); + + is_deeply( + $obj->_values, [ 1, 42 ], + 'delete removed the specified element' + ); + + like( exception { $obj->delete_curried(2) }, qr/Cannot call delete with more than 1 argument/, 'throws an error when delete_curried is called with one argument' ); + + is( exception { $obj->insert( 1, 21 ) }, undef, 'insert lives' ); + + is_deeply( + $obj->_values, [ 1, 21, 42 ], + 'insert added the specified element' + ); + + like( exception { $obj->insert( 1, 22, 44 ) }, qr/Cannot call insert with more than 2 arguments/, 'throws an error when insert is called with three arguments' ); + + is( exception { + is_deeply( + [ $obj->splice( 1, 0, 2, 3 ) ], + [], + 'return value of splice is empty list when not removing elements' + ); + }, undef, 'splice lives' ); + + is_deeply( + $obj->_values, [ 1, 2, 3, 21, 42 ], + 'splice added the specified elements' + ); + + is( exception { + is_deeply( + [ $obj->splice( 1, 2, 99 ) ], + [ 2, 3 ], + 'splice returns list of removed values' + ); + }, undef, 'splice lives' ); + + is_deeply( + $obj->_values, [ 1, 99, 21, 42 ], + 'splice added the specified elements' + ); + + like( exception { $obj->splice() }, qr/Cannot call splice without at least 1 argument/, 'throws an error when splice is called with no arguments' ); + + like( exception { $obj->splice( 1, 'foo', ) }, qr/The length argument passed to splice must be an integer/, 'throws an error when splice is called with an invalid length' ); + + is( exception { $obj->splice_curried_1( 2, 101 ) }, undef, 'splice_curried_1 lives' ); + + is_deeply( + $obj->_values, [ 1, 101, 42 ], + 'splice added the specified elements' + ); + + is( exception { $obj->splice_curried_2(102) }, undef, 'splice_curried_2 lives' ); + + is_deeply( + $obj->_values, [ 1, 102 ], + 'splice added the specified elements' + ); + + is( exception { $obj->splice_curried_all }, undef, 'splice_curried_all lives' ); + + is_deeply( + $obj->_values, [ 1, 3, 4, 5 ], + 'splice added the specified elements' + ); + + is_deeply( + scalar $obj->splice( 1, 2 ), + 4, + 'splice in scalar context returns last element removed' + ); + + is_deeply( + scalar $obj->splice( 1, 0, 42 ), + undef, + 'splice in scalar context returns undef when no elements are removed' + ); + + $obj->_values( [ 3, 9, 5, 22, 11 ] ); + + is_deeply( + [ $obj->sort ], [ 11, 22, 3, 5, 9 ], + 'sort returns sorted values' + ); + + is(scalar($obj->sort), 5, 'sort accessor in scalar context returns the number of elements in the list'); + + is_deeply( + [ $obj->sort( sub { $_[0] <=> $_[1] } ) ], [ 3, 5, 9, 11, 22 ], + 'sort returns values sorted by provided function' + ); + + is(scalar($obj->sort( sub { $_[0] <=> $_[1] } )), 5, 'sort accessor with sort sub in scalar context returns the number of elements in the list'); + + like( exception { $obj->sort(1) }, qr/The argument passed to sort must be a code reference/, 'throws an error when passing a non coderef to sort' ); + + like( exception { + $obj->sort( sub { }, 27 ); + }, qr/Cannot call sort with more than 1 argument/, 'throws an error when passing two arguments to sort' ); + + $obj->_values( [ 3, 9, 5, 22, 11 ] ); + + $obj->sort_in_place; + + is_deeply( + $obj->_values, [ 11, 22, 3, 5, 9 ], + 'sort_in_place sorts values' + ); + + $obj->sort_in_place( sub { $_[0] <=> $_[1] } ); + + is_deeply( + $obj->_values, [ 3, 5, 9, 11, 22 ], + 'sort_in_place with function sorts values' + ); + + like( exception { + $obj->sort_in_place( 27 ); + }, qr/The argument passed to sort_in_place must be a code reference/, 'throws an error when passing a non coderef to sort_in_place' ); + + like( exception { + $obj->sort_in_place( sub { }, 27 ); + }, qr/Cannot call sort_in_place with more than 1 argument/, 'throws an error when passing two arguments to sort_in_place' ); + + $obj->_values( [ 3, 9, 5, 22, 11 ] ); + + $obj->sort_in_place_curried; + + is_deeply( + $obj->_values, [ 22, 11, 9, 5, 3 ], + 'sort_in_place_curried sorts values' + ); + + like( exception { $obj->sort_in_place_curried(27) }, qr/Cannot call sort_in_place with more than 1 argument/, 'throws an error when passing one argument passed to sort_in_place_curried' ); + + $obj->_values( [ 1 .. 5 ] ); + + is_deeply( + [ $obj->map( sub { $_ + 1 } ) ], + [ 2 .. 6 ], + 'map returns the expected values' + ); + + like( exception { $obj->map }, qr/Cannot call map without at least 1 argument/, 'throws an error when passing no arguments to map' ); + + like( exception { + $obj->map( sub { }, 2 ); + }, qr/Cannot call map with more than 1 argument/, 'throws an error when passing two arguments to map' ); + + like( exception { $obj->map( {} ) }, qr/The argument passed to map must be a code reference/, 'throws an error when passing a non coderef to map' ); + + $obj->_values( [ 1 .. 5 ] ); + + is_deeply( + [ $obj->map_curried ], + [ 2 .. 6 ], + 'map_curried returns the expected values' + ); + + like( exception { + $obj->map_curried( sub { } ); + }, qr/Cannot call map with more than 1 argument/, 'throws an error when passing one argument passed to map_curried' ); + + $obj->_values( [ 2 .. 9 ] ); + + is_deeply( + [ $obj->grep( sub { $_ < 5 } ) ], + [ 2 .. 4 ], + 'grep returns the expected values' + ); + + like( exception { $obj->grep }, qr/Cannot call grep without at least 1 argument/, 'throws an error when passing no arguments to grep' ); + + like( exception { + $obj->grep( sub { }, 2 ); + }, qr/Cannot call grep with more than 1 argument/, 'throws an error when passing two arguments to grep' ); + + like( exception { $obj->grep( {} ) }, qr/The argument passed to grep must be a code reference/, 'throws an error when passing a non coderef to grep' ); + + my $overloader = Overloader->new( sub { $_ < 5 } ); + is_deeply( + [ $obj->grep($overloader) ], + [ 2 .. 4 ], + 'grep works with obj that overload code dereferencing' + ); + + is_deeply( + [ $obj->grep_curried ], + [ 2 .. 4 ], + 'grep_curried returns the expected values' + ); + + like( exception { + $obj->grep_curried( sub { } ); + }, qr/Cannot call grep with more than 1 argument/, 'throws an error when passing one argument passed to grep_curried' ); + + $obj->_values( [ 2, 4, 22, 99, 101, 6 ] ); + + is( + $obj->first( sub { $_ % 2 } ), + 99, + 'first returns expected value' + ); + + like( exception { $obj->first }, qr/Cannot call first without at least 1 argument/, 'throws an error when passing no arguments to first' ); + + like( exception { + $obj->first( sub { }, 2 ); + }, qr/Cannot call first with more than 1 argument/, 'throws an error when passing two arguments to first' ); + + like( exception { $obj->first( {} ) }, qr/The argument passed to first must be a code reference/, 'throws an error when passing a non coderef to first' ); + + is( + $obj->first_curried, + 99, + 'first_curried returns expected value' + ); + + like( exception { + $obj->first_curried( sub { } ); + }, qr/Cannot call first with more than 1 argument/, 'throws an error when passing one argument passed to first_curried' ); + + + is( + $obj->first_index( sub { $_ % 2 } ), + 3, + 'first_index returns expected value' + ); + + like( exception { $obj->first_index }, qr/Cannot call first_index without at least 1 argument/, 'throws an error when passing no arguments to first_index' ); + + like( exception { + $obj->first_index( sub { }, 2 ); + }, qr/Cannot call first_index with more than 1 argument/, 'throws an error when passing two arguments to first_index' ); + + like( exception { $obj->first_index( {} ) }, qr/The argument passed to first_index must be a code reference/, 'throws an error when passing a non coderef to first_index' ); + + is( + $obj->first_index_curried, + 3, + 'first_index_curried returns expected value' + ); + + like( exception { + $obj->first_index_curried( sub { } ); + }, qr/Cannot call first_index with more than 1 argument/, 'throws an error when passing one argument passed to first_index_curried' ); + + + $obj->_values( [ 1 .. 4 ] ); + + is( + $obj->join('-'), '1-2-3-4', + 'join returns expected result' + ); + + is( + $obj->join(q{}), '1234', + 'join returns expected result when joining with empty string' + ); + + is( + $obj->join( OverloadStr->new(q{}) ), '1234', + 'join returns expected result when joining with empty string' + ); + + like( exception { $obj->join }, qr/Cannot call join without at least 1 argument/, 'throws an error when passing no arguments to join' ); + + like( exception { $obj->join( '-', 2 ) }, qr/Cannot call join with more than 1 argument/, 'throws an error when passing two arguments to join' ); + + like( exception { $obj->join( {} ) }, qr/The argument passed to join must be a string/, 'throws an error when passing a non string to join' ); + + is_deeply( + [ sort $obj->shuffle ], + [ 1 .. 4 ], + 'shuffle returns all values (cannot check for a random order)' + ); + + like( exception { $obj->shuffle(2) }, qr/Cannot call shuffle with any arguments/, 'throws an error when passing an argument passed to shuffle' ); + + $obj->_values( [ 1 .. 4, 2, 5, 3, 7, 3, 3, 1 ] ); + + is_deeply( + [ $obj->uniq ], + [ 1 .. 4, 5, 7 ], + 'uniq returns expected values (in original order)' + ); + + like( exception { $obj->uniq(2) }, qr/Cannot call uniq with any arguments/, 'throws an error when passing an argument passed to uniq' ); + + $obj->_values( [ 1 .. 5 ] ); + + is( + $obj->reduce( sub { $_[0] * $_[1] } ), + 120, + 'reduce returns expected value' + ); + + like( exception { $obj->reduce }, qr/Cannot call reduce without at least 1 argument/, 'throws an error when passing no arguments to reduce' ); + + like( exception { + $obj->reduce( sub { }, 2 ); + }, qr/Cannot call reduce with more than 1 argument/, 'throws an error when passing two arguments to reduce' ); + + like( exception { $obj->reduce( {} ) }, qr/The argument passed to reduce must be a code reference/, 'throws an error when passing a non coderef to reduce' ); + + is( + $obj->reduce_curried, + 120, + 'reduce_curried returns expected value' + ); + + like( exception { + $obj->reduce_curried( sub { } ); + }, qr/Cannot call reduce with more than 1 argument/, 'throws an error when passing one argument passed to reduce_curried' ); + + $obj->_values( [ 1 .. 6 ] ); + + my $it = $obj->natatime(2); + my @nat; + while ( my @v = $it->() ) { + push @nat, \@v; + } + + is_deeply( + [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], + \@nat, + 'natatime returns expected iterator' + ); + + @nat = (); + $obj->natatime( 2, sub { push @nat, [@_] } ); + + is_deeply( + [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], + \@nat, + 'natatime with function returns expected value' + ); + + like( exception { $obj->natatime( {} ) }, qr/The n value passed to natatime must be an integer/, 'throws an error when passing a non integer to natatime' ); + + like( exception { $obj->natatime( 2, {} ) }, qr/The second argument passed to natatime must be a code reference/, 'throws an error when passing a non code ref to natatime' ); + + $it = $obj->natatime_curried(); + @nat = (); + while ( my @v = $it->() ) { + push @nat, \@v; + } + + is_deeply( + [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], + \@nat, + 'natatime_curried returns expected iterator' + ); + + @nat = (); + $obj->natatime_curried( sub { push @nat, [@_] } ); + + is_deeply( + [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], + \@nat, + 'natatime_curried with function returns expected value' + ); + + like( exception { $obj->natatime_curried( {} ) }, qr/The second argument passed to natatime must be a code reference/, 'throws an error when passing a non code ref to natatime_curried' ); + + if ( $class->meta->get_attribute('_values')->is_lazy ) { + my $obj = $class->new; + + is( $obj->count, 2, 'count is 2 (lazy init)' ); + + $obj->_clear_values; + + is_deeply( + [ $obj->elements ], [ 42, 84 ], + 'elements contains default with lazy init' + ); + + $obj->_clear_values; + + $obj->push(2); + + is_deeply( + $obj->_values, [ 42, 84, 2 ], + 'push works with lazy init' + ); + + $obj->_clear_values; + + $obj->unshift( 3, 4 ); + + is_deeply( + $obj->_values, [ 3, 4, 42, 84 ], + 'unshift works with lazy init' + ); + } + } + $class; +} + +{ + my ( $class, $handles ) = build_class( isa => 'ArrayRef' ); + my $obj = $class->new; + with_immutable { + is( + exception { $obj->accessor( 0, undef ) }, + undef, + 'can use accessor to set value to undef' + ); + is( + exception { $obj->accessor_curried_1(undef) }, + undef, + 'can use curried accessor to set value to undef' + ); + } + $class; +} + +done_testing; diff --git a/t/native_traits/trait_bool.t b/t/native_traits/trait_bool.t new file mode 100644 index 0000000..7a416da --- /dev/null +++ b/t/native_traits/trait_bool.t @@ -0,0 +1,101 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Moose (); +use Moose::Util::TypeConstraints; +use NoInlineAttribute; +use Test::More; +use Test::Fatal; +use Test::Moose; + +{ + my %handles = ( + illuminate => 'set', + darken => 'unset', + flip_switch => 'toggle', + is_dark => 'not', + ); + + my $name = 'Foo1'; + + sub build_class { + my %attr = @_; + + my $class = Moose::Meta::Class->create( + $name++, + superclasses => ['Moose::Object'], + ); + + my @traits = 'Bool'; + push @traits, 'NoInlineAttribute' + if delete $attr{no_inline}; + + $class->add_attribute( + is_lit => ( + traits => \@traits, + is => 'rw', + isa => 'Bool', + default => 0, + handles => \%handles, + clearer => '_clear_is_list', + %attr, + ), + ); + + return ( $class->name, \%handles ); + } +} + +{ + run_tests(build_class); + run_tests( build_class( lazy => 1 ) ); + run_tests( build_class( trigger => sub { } ) ); + run_tests( build_class( no_inline => 1 ) ); + + # Will force the inlining code to check the entire hashref when it is modified. + subtype 'MyBool', as 'Bool', where { 1 }; + + run_tests( build_class( isa => 'MyBool' ) ); + + coerce 'MyBool', from 'Bool', via { $_ }; + + run_tests( build_class( isa => 'MyBool', coerce => 1 ) ); +} + +sub run_tests { + my ( $class, $handles ) = @_; + + can_ok( $class, $_ ) for sort keys %{$handles}; + + with_immutable { + my $obj = $class->new; + + ok( $obj->illuminate, 'set returns true' ); + ok( $obj->is_lit, 'set is_lit to 1 using ->illuminate' ); + ok( !$obj->is_dark, 'check if is_dark does the right thing' ); + + like( exception { $obj->illuminate(1) }, qr/Cannot call set with any arguments/, 'set throws an error when an argument is passed' ); + + ok( !$obj->darken, 'unset returns false' ); + ok( !$obj->is_lit, 'set is_lit to 0 using ->darken' ); + ok( $obj->is_dark, 'check if is_dark does the right thing' ); + + like( exception { $obj->darken(1) }, qr/Cannot call unset with any arguments/, 'unset throws an error when an argument is passed' ); + + ok( $obj->flip_switch, 'toggle returns new value' ); + ok( $obj->is_lit, 'toggle is_lit back to 1 using ->flip_switch' ); + ok( !$obj->is_dark, 'check if is_dark does the right thing' ); + + like( exception { $obj->flip_switch(1) }, qr/Cannot call toggle with any arguments/, 'toggle throws an error when an argument is passed' ); + + $obj->flip_switch; + ok( !$obj->is_lit, + 'toggle is_lit back to 0 again using ->flip_switch' ); + ok( $obj->is_dark, 'check if is_dark does the right thing' ); + } + $class; +} + +done_testing; diff --git a/t/native_traits/trait_code.t b/t/native_traits/trait_code.t new file mode 100644 index 0000000..1590963 --- /dev/null +++ b/t/native_traits/trait_code.t @@ -0,0 +1,113 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Moose (); +use NoInlineAttribute; +use Test::More; +use Test::Moose; + +{ + my $name = 'Foo1'; + + sub build_class { + my ( $attr1, $attr2, $attr3, $no_inline ) = @_; + + my $class = Moose::Meta::Class->create( + $name++, + superclasses => ['Moose::Object'], + ); + + my @traits = 'Code'; + push @traits, 'NoInlineAttribute' + if $no_inline; + + $class->add_attribute( + callback => ( + traits => \@traits, + isa => 'CodeRef', + required => 1, + handles => { 'invoke_callback' => 'execute' }, + %{ $attr1 || {} }, + ) + ); + + $class->add_attribute( + callback_method => ( + traits => \@traits, + isa => 'CodeRef', + required => 1, + handles => { 'invoke_method_callback' => 'execute_method' }, + %{ $attr2 || {} }, + ) + ); + + $class->add_attribute( + multiplier => ( + traits => \@traits, + isa => 'CodeRef', + required => 1, + handles => { 'multiply' => 'execute' }, + %{ $attr3 || {} }, + ) + ); + + return $class->name; + } +} + +{ + my $i; + + my %subs = ( + callback => sub { ++$i }, + callback_method => sub { shift->multiply(@_) }, + multiplier => sub { $_[0] * 2 }, + ); + + run_tests( build_class, \$i, \%subs ); + + run_tests( build_class( undef, undef, undef, 1 ), \$i, \%subs ); + + run_tests( + build_class( + { + lazy => 1, default => sub { $subs{callback} } + }, { + lazy => 1, default => sub { $subs{callback_method} } + }, { + lazy => 1, default => sub { $subs{multiplier} } + }, + ), + \$i, + ); +} + +sub run_tests { + my ( $class, $iref, @args ) = @_; + + ok( + !$class->can($_), + "Code trait didn't create reader method for $_" + ) for qw(callback callback_method multiplier); + + with_immutable { + ${$iref} = 0; + my $obj = $class->new(@args); + + $obj->invoke_callback; + + is( ${$iref}, 1, '$i is 1 after invoke_callback' ); + + is( + $obj->invoke_method_callback(3), 6, + 'invoke_method_callback calls multiply with @_' + ); + + is( $obj->multiply(3), 6, 'multiple double value' ); + } + $class; +} + +done_testing; diff --git a/t/native_traits/trait_counter.t b/t/native_traits/trait_counter.t new file mode 100644 index 0000000..9a9901c --- /dev/null +++ b/t/native_traits/trait_counter.t @@ -0,0 +1,170 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Moose (); +use Moose::Util::TypeConstraints; +use NoInlineAttribute; +use Test::Fatal; +use Test::More; +use Test::Moose; + +{ + my %handles = ( + inc_counter => 'inc', + inc_counter_2 => [ inc => 2 ], + dec_counter => 'dec', + dec_counter_2 => [ dec => 2 ], + reset_counter => 'reset', + set_counter => 'set', + set_counter_42 => [ set => 42 ], + ); + + my $name = 'Foo1'; + + sub build_class { + my %attr = @_; + + my $class = Moose::Meta::Class->create( + $name++, + superclasses => ['Moose::Object'], + ); + + my @traits = 'Counter'; + push @traits, 'NoInlineAttribute' + if delete $attr{no_inline}; + + $class->add_attribute( + counter => ( + traits => \@traits, + is => 'ro', + isa => 'Int', + default => 0, + handles => \%handles, + clearer => '_clear_counter', + %attr, + ), + ); + + return ( $class->name, \%handles ); + } +} + +{ + run_tests(build_class); + run_tests( build_class( lazy => 1 ) ); + run_tests( build_class( trigger => sub { } ) ); + run_tests( build_class( no_inline => 1 ) ); + + # Will force the inlining code to check the entire hashref when it is modified. + subtype 'MyInt', as 'Int', where { 1 }; + + run_tests( build_class( isa => 'MyInt' ) ); + + coerce 'MyInt', from 'Int', via { $_ }; + + run_tests( build_class( isa => 'MyInt', coerce => 1 ) ); +} + +sub run_tests { + my ( $class, $handles ) = @_; + + can_ok( $class, $_ ) for sort keys %{$handles}; + + with_immutable { + my $obj = $class->new(); + + is( $obj->counter, 0, '... got the default value' ); + + is( $obj->inc_counter, 1, 'inc returns new value' ); + is( $obj->counter, 1, '... got the incremented value' ); + + is( $obj->inc_counter, 2, 'inc returns new value' ); + is( $obj->counter, 2, '... got the incremented value (again)' ); + + like( exception { $obj->inc_counter( 1, 2 ) }, qr/Cannot call inc with more than 1 argument/, 'inc throws an error when two arguments are passed' ); + + is( $obj->dec_counter, 1, 'dec returns new value' ); + is( $obj->counter, 1, '... got the decremented value' ); + + like( exception { $obj->dec_counter( 1, 2 ) }, qr/Cannot call dec with more than 1 argument/, 'dec throws an error when two arguments are passed' ); + + is( $obj->reset_counter, 0, 'reset returns new value' ); + is( $obj->counter, 0, '... got the original value' ); + + like( exception { $obj->reset_counter(2) }, qr/Cannot call reset with any arguments/, 'reset throws an error when an argument is passed' ); + + is( $obj->set_counter(5), 5, 'set returns new value' ); + is( $obj->counter, 5, '... set the value' ); + + like( exception { $obj->set_counter( 1, 2 ) }, qr/Cannot call set with more than 1 argument/, 'set throws an error when two arguments are passed' ); + + $obj->inc_counter(2); + is( $obj->counter, 7, '... increment by arg' ); + + $obj->dec_counter(5); + is( $obj->counter, 2, '... decrement by arg' ); + + $obj->inc_counter_2; + is( $obj->counter, 4, '... curried increment' ); + + $obj->dec_counter_2; + is( $obj->counter, 2, '... curried deccrement' ); + + $obj->set_counter_42; + is( $obj->counter, 42, '... curried set' ); + + if ( $class->meta->get_attribute('counter')->is_lazy ) { + my $obj = $class->new; + + $obj->inc_counter; + is( $obj->counter, 1, 'inc increments - with lazy default' ); + + $obj->_clear_counter; + + $obj->dec_counter; + is( $obj->counter, -1, 'dec decrements - with lazy default' ); + } + } + $class; +} + +{ + package WithBuilder; + use Moose; + + has nonlazy => ( + traits => ['Counter'], + is => 'rw', + isa => 'Int', + builder => '_builder', + handles => { + reset_nonlazy => 'reset', + }, + ); + + has lazy => ( + traits => ['Counter'], + is => 'rw', + isa => 'Int', + lazy => 1, + builder => '_builder', + handles => { + reset_lazy => 'reset', + }, + ); + + sub _builder { 1 } +} + +for my $attr ('lazy', 'nonlazy') { + my $obj = WithBuilder->new; + is($obj->$attr, 1, "built properly"); + $obj->$attr(0); + is($obj->$attr, 0, "can be manually set"); + $obj->${\"reset_$attr"}; + is($obj->$attr, 1, "reset resets it to its default value"); +} + +done_testing; diff --git a/t/native_traits/trait_hash.t b/t/native_traits/trait_hash.t new file mode 100644 index 0000000..c957108 --- /dev/null +++ b/t/native_traits/trait_hash.t @@ -0,0 +1,329 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Moose (); +use Moose::Util::TypeConstraints; +use NoInlineAttribute; +use Test::Fatal; +use Test::More; +use Test::Moose; + +{ + my %handles = ( + option_accessor => 'accessor', + quantity => [ accessor => 'quantity' ], + clear_options => 'clear', + num_options => 'count', + delete_option => 'delete', + is_defined => 'defined', + options_elements => 'elements', + has_option => 'exists', + get_option => 'get', + has_no_options => 'is_empty', + keys => 'keys', + values => 'values', + key_value => 'kv', + set_option => 'set', + ); + + my $name = 'Foo1'; + + sub build_class { + my %attr = @_; + + my $class = Moose::Meta::Class->create( + $name++, + superclasses => ['Moose::Object'], + ); + + my @traits = 'Hash'; + push @traits, 'NoInlineAttribute' + if delete $attr{no_inline}; + + $class->add_attribute( + options => ( + traits => \@traits, + is => 'rw', + isa => 'HashRef[Str]', + default => sub { {} }, + handles => \%handles, + clearer => '_clear_options', + %attr, + ), + ); + + return ( $class->name, \%handles ); + } +} + +{ + run_tests(build_class); + run_tests( build_class( lazy => 1, default => sub { { x => 1 } } ) ); + run_tests( build_class( trigger => sub { } ) ); + run_tests( build_class( no_inline => 1 ) ); + + # Will force the inlining code to check the entire hashref when it is modified. + subtype 'MyHashRef', as 'HashRef[Str]', where { 1 }; + + run_tests( build_class( isa => 'MyHashRef' ) ); + + coerce 'MyHashRef', from 'HashRef', via { $_ }; + + run_tests( build_class( isa => 'MyHashRef', coerce => 1 ) ); +} + +sub run_tests { + my ( $class, $handles ) = @_; + + can_ok( $class, $_ ) for sort keys %{$handles}; + + with_immutable { + my $obj = $class->new( options => {} ); + + ok( $obj->has_no_options, '... we have no options' ); + is( $obj->num_options, 0, '... we have no options' ); + + is_deeply( $obj->options, {}, '... no options yet' ); + ok( !$obj->has_option('foo'), '... we have no foo option' ); + + is( exception { + is( + $obj->set_option( foo => 'bar' ), + 'bar', + 'set return single new value in scalar context' + ); + }, undef, '... set the option okay' ); + + like( + exception { $obj->set_option( foo => 'bar', 'baz' ) }, + qr/You must pass an even number of arguments to set/, + 'exception with odd number of arguments' + ); + + like( + exception { $obj->set_option( undef, 'bar' ) }, + qr/Hash keys passed to set must be defined/, + 'exception when using undef as a key' + ); + + ok( $obj->is_defined('foo'), '... foo is defined' ); + + ok( !$obj->has_no_options, '... we have options' ); + is( $obj->num_options, 1, '... we have 1 option(s)' ); + ok( $obj->has_option('foo'), '... we have a foo option' ); + is_deeply( $obj->options, { foo => 'bar' }, '... got options now' ); + + is( exception { + $obj->set_option( bar => 'baz' ); + }, undef, '... set the option okay' ); + + is( $obj->num_options, 2, '... we have 2 option(s)' ); + is_deeply( + $obj->options, { foo => 'bar', bar => 'baz' }, + '... got more options now' + ); + + is( $obj->get_option('foo'), 'bar', '... got the right option' ); + + is_deeply( + [ $obj->get_option(qw(foo bar)) ], [qw(bar baz)], + "get multiple options at once" + ); + + is( + scalar( $obj->get_option(qw( foo bar)) ), "baz", + '... got last option in scalar context' + ); + + is( exception { + $obj->set_option( oink => "blah", xxy => "flop" ); + }, undef, '... set the option okay' ); + + is( $obj->num_options, 4, "4 options" ); + is_deeply( + [ $obj->get_option(qw(foo bar oink xxy)) ], + [qw(bar baz blah flop)], "get multiple options at once" + ); + + is( exception { + is( scalar $obj->delete_option('bar'), 'baz', + 'delete returns deleted value' ); + }, undef, '... deleted the option okay' ); + + is( exception { + is_deeply( + [ $obj->delete_option( 'oink', 'xxy' ) ], + [ 'blah', 'flop' ], + 'delete returns all deleted values in list context' + ); + }, undef, '... deleted multiple option okay' ); + + is( $obj->num_options, 1, '... we have 1 option(s)' ); + is_deeply( + $obj->options, { foo => 'bar' }, + '... got more options now' + ); + + $obj->clear_options; + + is_deeply( $obj->options, {}, "... cleared options" ); + + is( exception { + $obj->quantity(4); + }, undef, '... options added okay with defaults' ); + + is( $obj->quantity, 4, 'reader part of curried accessor works' ); + + is( + $obj->option_accessor('quantity'), 4, + 'accessor as reader' + ); + + is_deeply( + $obj->options, { quantity => 4 }, + '... returns what we expect' + ); + + $obj->option_accessor( size => 42 ); + + like( + exception { + $obj->option_accessor; + }, + qr/Cannot call accessor without at least 1 argument/, + 'error when calling accessor with no arguments' + ); + + like( + exception { $obj->option_accessor( undef, 'bar' ) }, + qr/Hash keys passed to accessor must be defined/, + 'exception when using undef as a key' + ); + + is_deeply( + $obj->options, { quantity => 4, size => 42 }, + 'accessor as writer' + ); + + is( exception { + $class->new( options => { foo => 'BAR' } ); + }, undef, '... good constructor params' ); + + isnt( exception { + $obj->set_option( bar => {} ); + }, undef, '... could not add a hash ref where an string is expected' ); + + isnt( exception { + $class->new( options => { foo => [] } ); + }, undef, '... bad constructor params' ); + + $obj->options( {} ); + + is_deeply( + [ $obj->set_option( oink => "blah", xxy => "flop" ) ], + [ 'blah', 'flop' ], + 'set returns newly set values in order of keys provided' + ); + + is_deeply( + [ sort $obj->keys ], + [ 'oink', 'xxy' ], + 'keys returns expected keys' + ); + + is_deeply( + [ sort $obj->values ], + [ 'blah', 'flop' ], + 'values returns expected values' + ); + + my @key_value = sort { $a->[0] cmp $b->[0] } $obj->key_value; + is_deeply( + \@key_value, + [ + sort { $a->[0] cmp $b->[0] }[ 'xxy', 'flop' ], + [ 'oink', 'blah' ] + ], + '... got the right key value pairs' + ) + or do { + require Data::Dumper; + diag( Data::Dumper::Dumper( \@key_value ) ); + }; + + my %options_elements = $obj->options_elements; + is_deeply( + \%options_elements, { + 'oink' => 'blah', + 'xxy' => 'flop' + }, + '... got the right hash elements' + ); + + if ( $class->meta->get_attribute('options')->is_lazy ) { + my $obj = $class->new; + + $obj->set_option( y => 2 ); + + is_deeply( + $obj->options, { x => 1, y => 2 }, + 'set_option with lazy default' + ); + + $obj->_clear_options; + + ok( + $obj->has_option('x'), + 'key for x exists - lazy default' + ); + + $obj->_clear_options; + + ok( + $obj->is_defined('x'), + 'key for x is defined - lazy default' + ); + + $obj->_clear_options; + + is_deeply( + [ $obj->key_value ], + [ [ x => 1 ] ], + 'kv returns lazy default' + ); + + $obj->_clear_options; + + $obj->option_accessor( y => 2 ); + + is_deeply( + [ sort $obj->keys ], + [ 'x', 'y' ], + 'accessor triggers lazy default generator' + ); + } + } + $class; +} + +{ + my ( $class, $handles ) = build_class( isa => 'HashRef' ); + my $obj = $class->new; + with_immutable { + is( + exception { $obj->option_accessor( 'foo', undef ) }, + undef, + 'can use accessor to set value to undef' + ); + is( + exception { $obj->quantity(undef) }, + undef, + 'can use accessor to set value to undef' + ); + } + $class; +} + +done_testing; diff --git a/t/native_traits/trait_number.t b/t/native_traits/trait_number.t new file mode 100644 index 0000000..addf4bf --- /dev/null +++ b/t/native_traits/trait_number.t @@ -0,0 +1,161 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Moose (); +use Moose::Util::TypeConstraints; +use NoInlineAttribute; +use Test::Fatal; +use Test::More; +use Test::Moose; + +{ + my %handles = ( + abs => 'abs', + add => 'add', + inc => [ add => 1 ], + div => 'div', + cut_in_half => [ div => 2 ], + mod => 'mod', + odd => [ mod => 2 ], + mul => 'mul', + set => 'set', + sub => 'sub', + dec => [ sub => 1 ], + ); + + my $name = 'Foo1'; + + sub build_class { + my %attr = @_; + + my $class = Moose::Meta::Class->create( + $name++, + superclasses => ['Moose::Object'], + ); + + my @traits = 'Number'; + push @traits, 'NoInlineAttribute' + if delete $attr{no_inline}; + + $class->add_attribute( + integer => ( + traits => \@traits, + is => 'ro', + isa => 'Int', + default => 5, + handles => \%handles, + clearer => '_clear_integer', + %attr, + ), + ); + + return ( $class->name, \%handles ); + } +} + +{ + run_tests(build_class); + run_tests( build_class( lazy => 1 ) ); + run_tests( build_class( trigger => sub { } ) ); + run_tests( build_class( no_inline => 1 ) ); + + # Will force the inlining code to check the entire hashref when it is modified. + subtype 'MyInt', as 'Int', where { 1 }; + + run_tests( build_class( isa => 'MyInt' ) ); + + coerce 'MyInt', from 'Int', via { $_ }; + + run_tests( build_class( isa => 'MyInt', coerce => 1 ) ); +} + +sub run_tests { + my ( $class, $handles ) = @_; + + can_ok( $class, $_ ) for sort keys %{$handles}; + + with_immutable { + my $obj = $class->new; + + is( $obj->integer, 5, 'Default to five' ); + + is( $obj->add(10), 15, 'add returns new value' ); + + is( $obj->integer, 15, 'Add ten for fithteen' ); + + like( exception { $obj->add( 10, 2 ) }, qr/Cannot call add with more than 1 argument/, 'add throws an error when 2 arguments are passed' ); + + is( $obj->sub(3), 12, 'sub returns new value' ); + + is( $obj->integer, 12, 'Subtract three for 12' ); + + like( exception { $obj->sub( 10, 2 ) }, qr/Cannot call sub with more than 1 argument/, 'sub throws an error when 2 arguments are passed' ); + + is( $obj->set(10), 10, 'set returns new value' ); + + is( $obj->integer, 10, 'Set to ten' ); + + like( exception { $obj->set( 10, 2 ) }, qr/Cannot call set with more than 1 argument/, 'set throws an error when 2 arguments are passed' ); + + is( $obj->div(2), 5, 'div returns new value' ); + + is( $obj->integer, 5, 'divide by 2' ); + + like( exception { $obj->div( 10, 2 ) }, qr/Cannot call div with more than 1 argument/, 'div throws an error when 2 arguments are passed' ); + + is( $obj->mul(2), 10, 'mul returns new value' ); + + is( $obj->integer, 10, 'multiplied by 2' ); + + like( exception { $obj->mul( 10, 2 ) }, qr/Cannot call mul with more than 1 argument/, 'mul throws an error when 2 arguments are passed' ); + + is( $obj->mod(2), 0, 'mod returns new value' ); + + is( $obj->integer, 0, 'Mod by 2' ); + + like( exception { $obj->mod( 10, 2 ) }, qr/Cannot call mod with more than 1 argument/, 'mod throws an error when 2 arguments are passed' ); + + $obj->set(7); + + $obj->mod(5); + + is( $obj->integer, 2, 'Mod by 5' ); + + $obj->set(-1); + + is( $obj->abs, 1, 'abs returns new value' ); + + like( exception { $obj->abs(10) }, qr/Cannot call abs with any arguments/, 'abs throws an error when an argument is passed' ); + + is( $obj->integer, 1, 'abs 1' ); + + $obj->set(12); + + $obj->inc; + + is( $obj->integer, 13, 'inc 12' ); + + $obj->dec; + + is( $obj->integer, 12, 'dec 13' ); + + if ( $class->meta->get_attribute('integer')->is_lazy ) { + my $obj = $class->new; + + $obj->add(2); + + is( $obj->integer, 7, 'add with lazy default' ); + + $obj->_clear_integer; + + $obj->mod(2); + + is( $obj->integer, 1, 'mod with lazy default' ); + } + } + $class; +} + +done_testing; diff --git a/t/native_traits/trait_string.t b/t/native_traits/trait_string.t new file mode 100644 index 0000000..7f834f5 --- /dev/null +++ b/t/native_traits/trait_string.t @@ -0,0 +1,303 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Moose (); +use Moose::Util::TypeConstraints; +use NoInlineAttribute; +use Test::More; +use Test::Fatal; +use Test::Moose; + +{ + my %handles = ( + inc => 'inc', + append => 'append', + append_curried => [ append => '!' ], + prepend => 'prepend', + prepend_curried => [ prepend => '-' ], + replace => 'replace', + replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ], + chop => 'chop', + chomp => 'chomp', + clear => 'clear', + match => 'match', + match_curried => [ match => qr/\D/ ], + length => 'length', + substr => 'substr', + substr_curried_1 => [ substr => (1) ], + substr_curried_2 => [ substr => ( 1, 3 ) ], + substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ], + ); + + my $name = 'Foo1'; + + sub build_class { + my %attr = @_; + + my $class = Moose::Meta::Class->create( + $name++, + superclasses => ['Moose::Object'], + ); + + my @traits = 'String'; + push @traits, 'NoInlineAttribute' + if delete $attr{no_inline}; + + $class->add_attribute( + _string => ( + traits => \@traits, + is => 'rw', + isa => 'Str', + default => q{}, + handles => \%handles, + clearer => '_clear_string', + %attr, + ), + ); + + return ( $class->name, \%handles ); + } +} + +{ + run_tests(build_class); + run_tests( build_class( lazy => 1, default => q{} ) ); + run_tests( build_class( trigger => sub { } ) ); + run_tests( build_class( no_inline => 1 ) ); + + # Will force the inlining code to check the entire hashref when it is modified. + subtype 'MyStr', as 'Str', where { 1 }; + + run_tests( build_class( isa => 'MyStr' ) ); + + coerce 'MyStr', from 'Str', via { $_ }; + + run_tests( build_class( isa => 'MyStr', coerce => 1 ) ); +} + +sub run_tests { + my ( $class, $handles ) = @_; + + can_ok( $class, $_ ) for sort keys %{$handles}; + + with_immutable { + my $obj = $class->new(); + + is( $obj->length, 0, 'length returns zero' ); + + $obj->_string('a'); + is( $obj->length, 1, 'length returns 1 for new string' ); + + like( exception { $obj->length(42) }, qr/Cannot call length with any arguments/, 'length throws an error when an argument is passed' ); + + is( $obj->inc, 'b', 'inc returns new value' ); + is( $obj->_string, 'b', 'a becomes b after inc' ); + + like( exception { $obj->inc(42) }, qr/Cannot call inc with any arguments/, 'inc throws an error when an argument is passed' ); + + is( $obj->append('foo'), 'bfoo', 'append returns new value' ); + is( $obj->_string, 'bfoo', 'appended to the string' ); + + like( exception { $obj->append( 'foo', 2 ) }, qr/Cannot call append with more than 1 argument/, 'append throws an error when two arguments are passed' ); + + $obj->append_curried; + is( $obj->_string, 'bfoo!', 'append_curried appended to the string' ); + + like( exception { $obj->append_curried('foo') }, qr/Cannot call append with more than 1 argument/, 'append_curried throws an error when two arguments are passed' ); + + $obj->_string("has nl$/"); + is( $obj->chomp, 1, 'chomp returns number of characters removed' ); + is( $obj->_string, 'has nl', 'chomped string' ); + + is( $obj->chomp, 0, 'chomp returns number of characters removed' ); + is( + $obj->_string, 'has nl', + 'chomp is a no-op when string has no line ending' + ); + + like( exception { $obj->chomp(42) }, qr/Cannot call chomp with any arguments/, 'chomp throws an error when an argument is passed' ); + + is( $obj->chop, 'l', 'chop returns character removed' ); + is( $obj->_string, 'has n', 'chopped string' ); + + like( exception { $obj->chop(42) }, qr/Cannot call chop with any arguments/, 'chop throws an error when an argument is passed' ); + + $obj->_string('x'); + is( $obj->prepend('bar'), 'barx', 'prepend returns new value' ); + is( $obj->_string, 'barx', 'prepended to string' ); + + $obj->prepend_curried; + is( $obj->_string, '-barx', 'prepend_curried prepended to string' ); + + is( + $obj->replace( qr/([ao])/, sub { uc($1) } ), + '-bArx', + 'replace returns new value' + ); + + is( + $obj->_string, '-bArx', + 'substitution using coderef for replacement' + ); + + $obj->replace( qr/A/, 'X' ); + is( + $obj->_string, '-bXrx', + 'substitution using string as replacement' + ); + + $obj->_string('foo'); + $obj->replace( qr/oo/, q{} ); + + is( $obj->_string, 'f', + 'replace accepts an empty string as second argument' ); + + $obj->replace( q{}, 'a' ); + + is( $obj->_string, 'af', + 'replace accepts an empty string as first argument' ); + + like( exception { $obj->replace( {}, 'x' ) }, qr/The first argument passed to replace must be a string or regexp reference/, 'replace throws an error when the first argument is not a string or regexp' ); + + like( exception { $obj->replace( qr/x/, {} ) }, qr/The second argument passed to replace must be a string or code reference/, 'replace throws an error when the first argument is not a string or regexp' ); + + $obj->_string('Moosex'); + $obj->replace_curried; + is( $obj->_string, 'MooseX', 'capitalize last' ); + + $obj->_string('abcdef'); + + is_deeply( + [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ], + 'match -barx against /[aq]/ returns matches' + ); + + is_deeply( + [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ], + 'match -barx against /[aq]/ returns matches' + ); + + ok( + scalar $obj->match('b'), + 'match with string as argument returns true' + ); + + ok( + scalar $obj->match(q{}), + 'match with empty string as argument returns true' + ); + + like( exception { $obj->match }, qr/Cannot call match without at least 1 argument/, 'match throws an error when no arguments are passed' ); + + like( exception { $obj->match( {} ) }, qr/The argument passed to match must be a string or regexp reference/, 'match throws an error when an invalid argument is passed' ); + + $obj->_string('1234'); + ok( !$obj->match_curried, 'match_curried returns false' ); + + $obj->_string('one two three four'); + ok( $obj->match_curried, 'match curried returns true' ); + + $obj->clear; + is( $obj->_string, q{}, 'clear' ); + + like( exception { $obj->clear(42) }, qr/Cannot call clear with any arguments/, 'clear throws an error when an argument is passed' ); + + $obj->_string('some long string'); + is( + $obj->substr(1), 'ome long string', + 'substr as getter with one argument' + ); + + $obj->_string('some long string'); + is( + $obj->substr( 1, 3 ), 'ome', + 'substr as getter with two arguments' + ); + + is( + $obj->substr( 1, 3, 'ong' ), + 'ome', + 'substr as setter returns replaced string' + ); + + is( + $obj->_string, 'song long string', + 'substr as setter with three arguments' + ); + + $obj->substr( 1, 3, '' ); + + is( + $obj->_string, 's long string', + 'substr as setter with three arguments, replacment is empty string' + ); + + like( exception { $obj->substr }, qr/Cannot call substr without at least 1 argument/, 'substr throws an error when no argumemts are passed' ); + + like( exception { $obj->substr( 1, 2, 3, 4 ) }, qr/Cannot call substr with more than 3 arguments/, 'substr throws an error when four argumemts are passed' ); + + like( exception { $obj->substr( {} ) }, qr/The first argument passed to substr must be an integer/, 'substr throws an error when first argument is not an integer' ); + + like( exception { $obj->substr( 1, {} ) }, qr/The second argument passed to substr must be an integer/, 'substr throws an error when second argument is not an integer' ); + + like( exception { $obj->substr( 1, 2, {} ) }, qr/The third argument passed to substr must be a string/, 'substr throws an error when third argument is not a string' ); + + $obj->_string('some long string'); + + is( + $obj->substr_curried_1, 'ome long string', + 'substr_curried_1 returns expected value' + ); + + is( + $obj->substr_curried_1(3), 'ome', + 'substr_curried_1 with one argument returns expected value' + ); + + $obj->substr_curried_1( 3, 'ong' ); + + is( + $obj->_string, 'song long string', + 'substr_curried_1 as setter with two arguments' + ); + + $obj->_string('some long string'); + + is( + $obj->substr_curried_2, 'ome', + 'substr_curried_2 returns expected value' + ); + + $obj->substr_curried_2('ong'); + + is( + $obj->_string, 'song long string', + 'substr_curried_2 as setter with one arguments' + ); + + $obj->_string('some long string'); + + $obj->substr_curried_3; + + is( + $obj->_string, 'song long string', + 'substr_curried_3 as setter' + ); + + if ( $class->meta->get_attribute('_string')->is_lazy ) { + my $obj = $class->new; + + $obj->append('foo'); + + is( + $obj->_string, 'foo', + 'append with lazy default' + ); + } + } + $class; +} + +done_testing; diff --git a/t/recipes/basics_bankaccount_methodmodifiersandsubclassing.t b/t/recipes/basics_bankaccount_methodmodifiersandsubclassing.t new file mode 100644 index 0000000..8cf7bf3 --- /dev/null +++ b/t/recipes/basics_bankaccount_methodmodifiersandsubclassing.t @@ -0,0 +1,154 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + + package BankAccount; + use Moose; + + has 'balance' => ( isa => 'Int', is => 'rw', default => 0 ); + + sub deposit { + my ( $self, $amount ) = @_; + $self->balance( $self->balance + $amount ); + } + + sub withdraw { + my ( $self, $amount ) = @_; + my $current_balance = $self->balance(); + ( $current_balance >= $amount ) + || confess "Account overdrawn"; + $self->balance( $current_balance - $amount ); + } + + package CheckingAccount; + use Moose; + + extends 'BankAccount'; + + has 'overdraft_account' => ( isa => 'BankAccount', is => 'rw' ); + + before 'withdraw' => sub { + my ( $self, $amount ) = @_; + my $overdraft_amount = $amount - $self->balance(); + if ( $self->overdraft_account && $overdraft_amount > 0 ) { + $self->overdraft_account->withdraw($overdraft_amount); + $self->deposit($overdraft_amount); + } + }; +} + + + +# =begin testing +{ +my $savings_account; + +{ + $savings_account = BankAccount->new( balance => 250 ); + isa_ok( $savings_account, 'BankAccount' ); + + is( $savings_account->balance, 250, '... got the right savings balance' ); + is( + exception { + $savings_account->withdraw(50); + }, + undef, + '... withdrew from savings successfully' + ); + is( $savings_account->balance, 200, + '... got the right savings balance after withdrawal' ); + + $savings_account->deposit(150); + is( $savings_account->balance, 350, + '... got the right savings balance after deposit' ); +} + +{ + my $checking_account = CheckingAccount->new( + balance => 100, + overdraft_account => $savings_account + ); + isa_ok( $checking_account, 'CheckingAccount' ); + isa_ok( $checking_account, 'BankAccount' ); + + is( $checking_account->overdraft_account, $savings_account, + '... got the right overdraft account' ); + + is( $checking_account->balance, 100, + '... got the right checkings balance' ); + + is( + exception { + $checking_account->withdraw(50); + }, + undef, + '... withdrew from checking successfully' + ); + is( $checking_account->balance, 50, + '... got the right checkings balance after withdrawal' ); + is( $savings_account->balance, 350, + '... got the right savings balance after checking withdrawal (no overdraft)' + ); + + is( + exception { + $checking_account->withdraw(200); + }, + undef, + '... withdrew from checking successfully' + ); + is( $checking_account->balance, 0, + '... got the right checkings balance after withdrawal' ); + is( $savings_account->balance, 200, + '... got the right savings balance after overdraft withdrawal' ); +} + +{ + my $checking_account = CheckingAccount->new( + balance => 100 + + # no overdraft account + ); + isa_ok( $checking_account, 'CheckingAccount' ); + isa_ok( $checking_account, 'BankAccount' ); + + is( $checking_account->overdraft_account, undef, + '... no overdraft account' ); + + is( $checking_account->balance, 100, + '... got the right checkings balance' ); + + is( + exception { + $checking_account->withdraw(50); + }, + undef, + '... withdrew from checking successfully' + ); + is( $checking_account->balance, 50, + '... got the right checkings balance after withdrawal' ); + + isnt( + exception { + $checking_account->withdraw(200); + }, + undef, + '... withdrawal failed due to attempted overdraft' + ); + is( $checking_account->balance, 50, + '... got the right checkings balance after withdrawal failure' ); +} +} + + + + +1; diff --git a/t/recipes/basics_binarytree_attributefeatures.t b/t/recipes/basics_binarytree_attributefeatures.t new file mode 100644 index 0000000..87222fd --- /dev/null +++ b/t/recipes/basics_binarytree_attributefeatures.t @@ -0,0 +1,174 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + + package BinaryTree; + use Moose; + + has 'node' => ( is => 'rw', isa => 'Any' ); + + has 'parent' => ( + is => 'rw', + isa => 'BinaryTree', + predicate => 'has_parent', + weak_ref => 1, + ); + + has 'left' => ( + is => 'rw', + isa => 'BinaryTree', + predicate => 'has_left', + lazy => 1, + default => sub { BinaryTree->new( parent => $_[0] ) }, + trigger => \&_set_parent_for_child + ); + + has 'right' => ( + is => 'rw', + isa => 'BinaryTree', + predicate => 'has_right', + lazy => 1, + default => sub { BinaryTree->new( parent => $_[0] ) }, + trigger => \&_set_parent_for_child + ); + + sub _set_parent_for_child { + my ( $self, $child ) = @_; + + confess "You cannot insert a tree which already has a parent" + if $child->has_parent; + + $child->parent($self); + } +} + + + +# =begin testing +{ +use Scalar::Util 'isweak'; + +my $root = BinaryTree->new(node => 'root'); +isa_ok($root, 'BinaryTree'); + +is($root->node, 'root', '... got the right node value'); + +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'); + +# make a left node + +my $left = $root->left; +isa_ok($left, 'BinaryTree'); + +is($root->left, $left, '... got the same node (and it is $left)'); +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'); + +ok(!$left->has_left, '... $left no left node yet'); +ok(!$left->has_right, '... $left no right node yet'); + +is($left->node, undef, '... left has got no node value'); + +is( + exception { + $left->node('left'); + }, + undef, + '... assign to lefts node' +); + +is($left->node, 'left', '... left now has a node value'); + +# make a right node + +ok(!$root->has_right, '... still no right node yet'); + +is($root->right->node, undef, '... right has got no node value'); + +ok($root->has_right, '... now we have a right node'); + +my $right = $root->right; +isa_ok($right, 'BinaryTree'); + +is( + exception { + $right->node('right'); + }, + undef, + '... assign to rights node' +); + +is($right->node, 'right', '... left now has a node value'); + +is($root->right, $right, '... got the same node (and it is $right)'); +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'); + +# make a left node of the left node + +my $left_left = $left->left; +isa_ok($left_left, 'BinaryTree'); + +ok($left_left->has_parent, '... left does have a parent'); + +is($left_left->parent, $left, '... got a parent node (and it is $left)'); +ok($left->has_left, '... we have a left node now'); +is($left->left, $left_left, '... got a left node (and it is $left_left)'); + +ok(isweak($left_left->{parent}), '... parent is a weakened ref'); + +# make a right node of the left node + +my $left_right = BinaryTree->new; +isa_ok($left_right, 'BinaryTree'); + +is( + exception { + $left->right($left_right); + }, + undef, + '... assign to rights node' +); + +ok($left_right->has_parent, '... left does have a parent'); + +is($left_right->parent, $left, '... got a parent node (and it is $left)'); +ok($left->has_right, '... we have a left node now'); +is($left->right, $left_right, '... got a left node (and it is $left_left)'); + +ok(isweak($left_right->{parent}), '... parent is a weakened ref'); + +# and check the error + +isnt( + exception { + $left_right->right($left_left); + }, + undef, + '... cannot assign a node which already has a parent' +); +} + + + + +1; diff --git a/t/recipes/basics_company_subtypes.t b/t/recipes/basics_company_subtypes.t new file mode 100644 index 0000000..89c76ee --- /dev/null +++ b/t/recipes/basics_company_subtypes.t @@ -0,0 +1,356 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +use Test::Requires { + 'Locale::US' => '0', + 'Regexp::Common' => '0', +}; + + + +# =begin testing SETUP +{ + + package Address; + use Moose; + use Moose::Util::TypeConstraints; + + use Locale::US; + use Regexp::Common 'zip'; + + my $STATES = Locale::US->new; + subtype 'USState' + => as Str + => where { + ( exists $STATES->{code2state}{ uc($_) } + || exists $STATES->{state2code}{ uc($_) } ); + }; + + subtype 'USZipCode' + => as Value + => where { + /^$RE{zip}{US}{-extended => 'allow'}$/; + }; + + has 'street' => ( is => 'rw', isa => 'Str' ); + has 'city' => ( is => 'rw', isa => 'Str' ); + has 'state' => ( is => 'rw', isa => 'USState' ); + has 'zip_code' => ( is => 'rw', isa => 'USZipCode' ); + + package Company; + use Moose; + use Moose::Util::TypeConstraints; + + has 'name' => ( is => 'rw', isa => 'Str', required => 1 ); + has 'address' => ( is => 'rw', isa => 'Address' ); + has 'employees' => ( + is => 'rw', + isa => 'ArrayRef[Employee]', + default => sub { [] }, + ); + + sub BUILD { + my ( $self, $params ) = @_; + foreach my $employee ( @{ $self->employees } ) { + $employee->employer($self); + } + } + + after 'employees' => sub { + my ( $self, $employees ) = @_; + return unless $employees; + foreach my $employee ( @$employees ) { + $employee->employer($self); + } + }; + + package Person; + use Moose; + + has 'first_name' => ( is => 'rw', isa => 'Str', required => 1 ); + has 'last_name' => ( is => 'rw', isa => 'Str', required => 1 ); + has 'middle_initial' => ( + is => 'rw', isa => 'Str', + predicate => 'has_middle_initial' + ); + has 'address' => ( is => 'rw', isa => 'Address' ); + + sub full_name { + my $self = shift; + return $self->first_name + . ( + $self->has_middle_initial + ? ' ' . $self->middle_initial . '. ' + : ' ' + ) . $self->last_name; + } + + package Employee; + use Moose; + + extends 'Person'; + + has 'title' => ( is => 'rw', isa => 'Str', required => 1 ); + has 'employer' => ( is => 'rw', isa => 'Company', weak_ref => 1 ); + + override 'full_name' => sub { + my $self = shift; + super() . ', ' . $self->title; + }; +} + + + +# =begin testing +{ +{ + package Company; + + sub get_employee_count { scalar @{(shift)->employees} } +} + +use Scalar::Util 'isweak'; + +my $ii; +is( + exception { + $ii = Company->new( + { + name => 'Infinity Interactive', + address => Address->new( + street => '565 Plandome Rd., Suite 307', + city => 'Manhasset', + state => 'NY', + zip_code => '11030' + ), + employees => [ + Employee->new( + first_name => 'Jeremy', + last_name => 'Shao', + title => 'President / Senior Consultant', + address => Address->new( + city => 'Manhasset', state => 'NY' + ) + ), + Employee->new( + first_name => 'Tommy', + last_name => 'Lee', + title => 'Vice President / Senior Developer', + address => + Address->new( city => 'New York', state => 'NY' ) + ), + Employee->new( + first_name => 'Stevan', + middle_initial => 'C', + last_name => 'Little', + title => 'Senior Developer', + address => + Address->new( city => 'Madison', state => 'CT' ) + ), + ] + } + ); + }, + undef, + '... created the entire company successfully' +); + +isa_ok( $ii, 'Company' ); + +is( $ii->name, 'Infinity Interactive', + '... got the right name for the company' ); + +isa_ok( $ii->address, 'Address' ); +is( $ii->address->street, '565 Plandome Rd., Suite 307', + '... got the right street address' ); +is( $ii->address->city, 'Manhasset', '... got the right city' ); +is( $ii->address->state, 'NY', '... got the right state' ); +is( $ii->address->zip_code, 11030, '... got the zip code' ); + +is( $ii->get_employee_count, 3, '... got the right employee count' ); + +# employee #1 + +isa_ok( $ii->employees->[0], 'Employee' ); +isa_ok( $ii->employees->[0], 'Person' ); + +is( $ii->employees->[0]->first_name, 'Jeremy', + '... got the right first name' ); +is( $ii->employees->[0]->last_name, 'Shao', '... got the right last name' ); +ok( !$ii->employees->[0]->has_middle_initial, '... no middle initial' ); +is( $ii->employees->[0]->middle_initial, undef, + '... got the right middle initial value' ); +is( $ii->employees->[0]->full_name, + 'Jeremy Shao, President / Senior Consultant', + '... got the right full name' ); +is( $ii->employees->[0]->title, 'President / Senior Consultant', + '... got the right title' ); +is( $ii->employees->[0]->employer, $ii, '... got the right company' ); +ok( isweak( $ii->employees->[0]->{employer} ), + '... the company is a weak-ref' ); + +isa_ok( $ii->employees->[0]->address, 'Address' ); +is( $ii->employees->[0]->address->city, 'Manhasset', + '... got the right city' ); +is( $ii->employees->[0]->address->state, 'NY', '... got the right state' ); + +# employee #2 + +isa_ok( $ii->employees->[1], 'Employee' ); +isa_ok( $ii->employees->[1], 'Person' ); + +is( $ii->employees->[1]->first_name, 'Tommy', + '... got the right first name' ); +is( $ii->employees->[1]->last_name, 'Lee', '... got the right last name' ); +ok( !$ii->employees->[1]->has_middle_initial, '... no middle initial' ); +is( $ii->employees->[1]->middle_initial, undef, + '... got the right middle initial value' ); +is( $ii->employees->[1]->full_name, + 'Tommy Lee, Vice President / Senior Developer', + '... got the right full name' ); +is( $ii->employees->[1]->title, 'Vice President / Senior Developer', + '... got the right title' ); +is( $ii->employees->[1]->employer, $ii, '... got the right company' ); +ok( isweak( $ii->employees->[1]->{employer} ), + '... the company is a weak-ref' ); + +isa_ok( $ii->employees->[1]->address, 'Address' ); +is( $ii->employees->[1]->address->city, 'New York', + '... got the right city' ); +is( $ii->employees->[1]->address->state, 'NY', '... got the right state' ); + +# employee #3 + +isa_ok( $ii->employees->[2], 'Employee' ); +isa_ok( $ii->employees->[2], 'Person' ); + +is( $ii->employees->[2]->first_name, 'Stevan', + '... got the right first name' ); +is( $ii->employees->[2]->last_name, 'Little', '... got the right last name' ); +ok( $ii->employees->[2]->has_middle_initial, '... got middle initial' ); +is( $ii->employees->[2]->middle_initial, 'C', + '... got the right middle initial value' ); +is( $ii->employees->[2]->full_name, 'Stevan C. Little, Senior Developer', + '... got the right full name' ); +is( $ii->employees->[2]->title, 'Senior Developer', + '... got the right title' ); +is( $ii->employees->[2]->employer, $ii, '... got the right company' ); +ok( isweak( $ii->employees->[2]->{employer} ), + '... the company is a weak-ref' ); + +isa_ok( $ii->employees->[2]->address, 'Address' ); +is( $ii->employees->[2]->address->city, 'Madison', '... got the right city' ); +is( $ii->employees->[2]->address->state, 'CT', '... got the right state' ); + +# create new company + +my $new_company + = Company->new( name => 'Infinity Interactive International' ); +isa_ok( $new_company, 'Company' ); + +my $ii_employees = $ii->employees; +foreach my $employee (@$ii_employees) { + is( $employee->employer, $ii, '... has the ii company' ); +} + +$new_company->employees($ii_employees); + +foreach my $employee ( @{ $new_company->employees } ) { + is( $employee->employer, $new_company, + '... has the different company now' ); +} + +## check some error conditions for the subtypes + +isnt( + exception { + Address->new( street => {} ),; + }, + undef, + '... we die correctly with bad args' +); + +isnt( + exception { + Address->new( city => {} ),; + }, + undef, + '... we die correctly with bad args' +); + +isnt( + exception { + Address->new( state => 'British Columbia' ),; + }, + undef, + '... we die correctly with bad args' +); + +is( + exception { + Address->new( state => 'Connecticut' ),; + }, + undef, + '... we live correctly with good args' +); + +isnt( + exception { + Address->new( zip_code => 'AF5J6$' ),; + }, + undef, + '... we die correctly with bad args' +); + +is( + exception { + Address->new( zip_code => '06443' ),; + }, + undef, + '... we live correctly with good args' +); + +isnt( + exception { + Company->new(),; + }, + undef, + '... we die correctly without good args' +); + +is( + exception { + Company->new( name => 'Foo' ),; + }, + undef, + '... we live correctly without good args' +); + +isnt( + exception { + Company->new( name => 'Foo', employees => [ Person->new ] ),; + }, + undef, + '... we die correctly with good args' +); + +is( + exception { + Company->new( name => 'Foo', employees => [] ),; + }, + undef, + '... we live correctly with good args' +); +} + + + + +1; diff --git a/t/recipes/basics_datetime_extendingnonmooseparent.t b/t/recipes/basics_datetime_extendingnonmooseparent.t new file mode 100644 index 0000000..cf55a62 --- /dev/null +++ b/t/recipes/basics_datetime_extendingnonmooseparent.t @@ -0,0 +1,68 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +# because MooseX::NonMoose has a version requirement +BEGIN { $Moose::Role::VERSION = 9999 unless $Moose::Role::VERSION } + +use Test::Requires { + 'DateTime' => '0', + 'DateTime::Calendar::Mayan' => '0', + 'MooseX::NonMoose' => '0.25', +}; + + + +# =begin testing SETUP +{ + + package My::DateTime; + + use Moose; + use MooseX::NonMoose; + use DateTime::Calendar::Mayan; + extends qw( DateTime ); + + has 'mayan_date' => ( + is => 'ro', + isa => 'DateTime::Calendar::Mayan', + init_arg => undef, + lazy => 1, + builder => '_build_mayan_date', + clearer => '_clear_mayan_date', + predicate => 'has_mayan_date', + ); + + after 'set' => sub { + $_[0]->_clear_mayan_date; + }; + + sub _build_mayan_date { + DateTime::Calendar::Mayan->from_object( object => $_[0] ); + } +} + + + +# =begin testing +{ +my $dt = My::DateTime->new( year => 1970, month => 2, day => 24 ); + +can_ok( $dt, 'mayan_date' ); +isa_ok( $dt->mayan_date, 'DateTime::Calendar::Mayan' ); +is( $dt->mayan_date->date, '12.17.16.9.19', 'got expected mayan date' ); + +$dt->set( year => 2009 ); +ok( ! $dt->has_mayan_date, 'mayan_date is cleared after call to ->set' ); +} + + + + +1; diff --git a/t/recipes/basics_document_augmentandinner.t b/t/recipes/basics_document_augmentandinner.t new file mode 100644 index 0000000..dc59b06 --- /dev/null +++ b/t/recipes/basics_document_augmentandinner.t @@ -0,0 +1,84 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + + package Document::Page; + use Moose; + + has 'body' => ( is => 'rw', isa => 'Str', default => sub {''} ); + + sub create { + my $self = shift; + $self->open_page; + inner(); + $self->close_page; + } + + sub append_body { + my ( $self, $appendage ) = @_; + $self->body( $self->body . $appendage ); + } + + sub open_page { (shift)->append_body('<page>') } + sub close_page { (shift)->append_body('</page>') } + + package Document::PageWithHeadersAndFooters; + use Moose; + + extends 'Document::Page'; + + augment 'create' => sub { + my $self = shift; + $self->create_header; + inner(); + $self->create_footer; + }; + + sub create_header { (shift)->append_body('<header/>') } + sub create_footer { (shift)->append_body('<footer/>') } + + package TPSReport; + use Moose; + + extends 'Document::PageWithHeadersAndFooters'; + + augment 'create' => sub { + my $self = shift; + $self->create_tps_report; + inner(); + }; + + sub create_tps_report { + (shift)->append_body('<report type="tps"/>'); + } + + # <page><header/><report type="tps"/><footer/></page> + my $report_xml = TPSReport->new->create; +} + + + +# =begin testing +{ +my $tps_report = TPSReport->new; +isa_ok( $tps_report, 'TPSReport' ); + +is( + $tps_report->create, + q{<page><header/><report type="tps"/><footer/></page>}, + '... got the right TPS report' +); +} + + + + +1; diff --git a/t/recipes/basics_genome_overloadingsubtypesandcoercion.t b/t/recipes/basics_genome_overloadingsubtypesandcoercion.t new file mode 100644 index 0000000..4283986 --- /dev/null +++ b/t/recipes/basics_genome_overloadingsubtypesandcoercion.t @@ -0,0 +1,219 @@ +use strict; +use warnings; + +use Test::More; + + +{ + package Human; + + use Moose; + use Moose::Util::TypeConstraints; + + subtype 'Sex' + => as 'Str' + => where { $_ =~ m{^[mf]$}s }; + + has 'sex' => ( is => 'ro', isa => 'Sex', required => 1 ); + + has 'mother' => ( is => 'ro', isa => 'Human' ); + has 'father' => ( is => 'ro', isa => 'Human' ); + + use overload '+' => \&_overload_add, fallback => 1; + + sub _overload_add { + my ( $one, $two ) = @_; + + die('Only male and female humans may create children') + if ( $one->sex() eq $two->sex() ); + + my ( $mother, $father ) + = ( $one->sex eq 'f' ? ( $one, $two ) : ( $two, $one ) ); + + my $sex = 'f'; + $sex = 'm' if ( rand() >= 0.5 ); + + return Human->new( + sex => $sex, + eye_color => ( $one->eye_color() + $two->eye_color() ), + mother => $mother, + father => $father, + ); + } + + use List::MoreUtils qw( zip ); + + coerce 'Human::EyeColor' + => from 'ArrayRef' + => via { my @genes = qw( bey2_1 bey2_2 gey_1 gey_2 ); + return Human::EyeColor->new( zip( @genes, @{$_} ) ); }; + + has 'eye_color' => ( + is => 'ro', + isa => 'Human::EyeColor', + coerce => 1, + required => 1, + ); + +} + +{ + package Human::Gene::bey2; + + use Moose; + use Moose::Util::TypeConstraints; + + type 'bey2_color' => where { $_ =~ m{^(?:brown|blue)$} }; + + has 'color' => ( is => 'ro', isa => 'bey2_color' ); +} + +{ + package Human::Gene::gey; + + use Moose; + use Moose::Util::TypeConstraints; + + type 'gey_color' => where { $_ =~ m{^(?:green|blue)$} }; + + has 'color' => ( is => 'ro', isa => 'gey_color' ); +} + +{ + package Human::EyeColor; + + use Moose; + use Moose::Util::TypeConstraints; + + coerce 'Human::Gene::bey2' + => from 'Str' + => via { Human::Gene::bey2->new( color => $_ ) }; + + coerce 'Human::Gene::gey' + => from 'Str' + => via { Human::Gene::gey->new( color => $_ ) }; + + has [qw( bey2_1 bey2_2 )] => + ( is => 'ro', isa => 'Human::Gene::bey2', coerce => 1 ); + + has [qw( gey_1 gey_2 )] => + ( is => 'ro', isa => 'Human::Gene::gey', coerce => 1 ); + + sub color { + my ($self) = @_; + + return 'brown' + if ( $self->bey2_1->color() eq 'brown' + or $self->bey2_2->color() eq 'brown' ); + + return 'green' + if ( $self->gey_1->color() eq 'green' + or $self->gey_2->color() eq 'green' ); + + return 'blue'; + } + + use overload '""' => \&color, fallback => 1; + + use overload '+' => \&_overload_add, fallback => 1; + + sub _overload_add { + my ( $one, $two ) = @_; + + my $one_bey2 = 'bey2_' . _rand2(); + my $two_bey2 = 'bey2_' . _rand2(); + + my $one_gey = 'gey_' . _rand2(); + my $two_gey = 'gey_' . _rand2(); + + return Human::EyeColor->new( + bey2_1 => $one->$one_bey2->color(), + bey2_2 => $two->$two_bey2->color(), + gey_1 => $one->$one_gey->color(), + gey_2 => $two->$two_gey->color(), + ); + } + + sub _rand2 { + return 1 + int( rand(2) ); + } +} + +my $gene_color_sets = [ + [ qw( blue blue blue blue ) => 'blue' ], + [ qw( blue blue green blue ) => 'green' ], + [ qw( blue blue blue green ) => 'green' ], + [ qw( blue blue green green ) => 'green' ], + [ qw( brown blue blue blue ) => 'brown' ], + [ qw( brown brown green green ) => 'brown' ], + [ qw( blue brown green blue ) => 'brown' ], +]; + +foreach my $set (@$gene_color_sets) { + my $expected_color = pop(@$set); + + my $person = Human->new( + sex => 'f', + eye_color => $set, + ); + + is( + $person->eye_color(), + $expected_color, + 'gene combination ' + . join( ',', @$set ) + . ' produces ' + . $expected_color + . ' eye color', + ); +} + +my $parent_sets = [ + [ + [qw( blue blue blue blue )], + [qw( blue blue blue blue )] => 'blue' + ], + [ + [qw( blue blue blue blue )], + [qw( brown brown green blue )] => 'brown' + ], + [ + [qw( blue blue green green )], + [qw( blue blue green green )] => 'green' + ], +]; + +foreach my $set (@$parent_sets) { + my $expected_color = pop(@$set); + + my $mother = Human->new( + sex => 'f', + eye_color => shift(@$set), + ); + + my $father = Human->new( + sex => 'm', + eye_color => shift(@$set), + ); + + my $child = $mother + $father; + + is( + $child->eye_color(), + $expected_color, + 'mother ' + . $mother->eye_color() + . ' + father ' + . $father->eye_color() + . ' = child ' + . $expected_color, + ); +} + +# Hmm, not sure how to test for random selection of genes since +# I could theoretically run an infinite number of iterations and +# never find proof that a child has inherited a particular gene. + +# AUTHOR: Aran Clary Deltac <bluefeet@cpan.org> + +done_testing; diff --git a/t/recipes/basics_http_subtypesandcoercion.t b/t/recipes/basics_http_subtypesandcoercion.t new file mode 100644 index 0000000..f697d75 --- /dev/null +++ b/t/recipes/basics_http_subtypesandcoercion.t @@ -0,0 +1,148 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +use Test::Requires { + 'HTTP::Headers' => '0', + 'Params::Coerce' => '0', + 'URI' => '0', +}; + + + +# =begin testing SETUP +{ + + package Request; + use Moose; + use Moose::Util::TypeConstraints; + + use HTTP::Headers (); + use Params::Coerce (); + use URI (); + + subtype 'My::Types::HTTP::Headers' => as class_type('HTTP::Headers'); + + coerce 'My::Types::HTTP::Headers' + => from 'ArrayRef' + => via { HTTP::Headers->new( @{$_} ) } + => from 'HashRef' + => via { HTTP::Headers->new( %{$_} ) }; + + subtype 'My::Types::URI' => as class_type('URI'); + + coerce 'My::Types::URI' + => from 'Object' + => via { $_->isa('URI') + ? $_ + : Params::Coerce::coerce( 'URI', $_ ); } + => from 'Str' + => via { URI->new( $_, 'http' ) }; + + subtype 'Protocol' + => as 'Str' + => where { /^HTTP\/[0-9]\.[0-9]$/ }; + + has 'base' => ( is => 'rw', isa => 'My::Types::URI', coerce => 1 ); + has 'uri' => ( is => 'rw', isa => 'My::Types::URI', coerce => 1 ); + has 'method' => ( is => 'rw', isa => 'Str' ); + has 'protocol' => ( is => 'rw', isa => 'Protocol' ); + has 'headers' => ( + is => 'rw', + isa => 'My::Types::HTTP::Headers', + coerce => 1, + default => sub { HTTP::Headers->new } + ); +} + + + +# =begin testing +{ +my $r = Request->new; +isa_ok( $r, 'Request' ); + +{ + my $header = $r->headers; + isa_ok( $header, 'HTTP::Headers' ); + + is( $r->headers->content_type, '', + '... got no content type in the header' ); + + $r->headers( { content_type => 'text/plain' } ); + + my $header2 = $r->headers; + isa_ok( $header2, 'HTTP::Headers' ); + isnt( $header, $header2, '... created a new HTTP::Header object' ); + + is( $header2->content_type, 'text/plain', + '... got the right content type in the header' ); + + $r->headers( [ content_type => 'text/html' ] ); + + my $header3 = $r->headers; + isa_ok( $header3, 'HTTP::Headers' ); + isnt( $header2, $header3, '... created a new HTTP::Header object' ); + + is( $header3->content_type, 'text/html', + '... got the right content type in the header' ); + + $r->headers( HTTP::Headers->new( content_type => 'application/pdf' ) ); + + my $header4 = $r->headers; + isa_ok( $header4, 'HTTP::Headers' ); + isnt( $header3, $header4, '... created a new HTTP::Header object' ); + + is( $header4->content_type, 'application/pdf', + '... got the right content type in the header' ); + + isnt( + exception { + $r->headers('Foo'); + }, + undef, + '... dies when it gets bad params' + ); +} + +{ + is( $r->protocol, undef, '... got nothing by default' ); + + is( + exception { + $r->protocol('HTTP/1.0'); + }, + undef, + '... set the protocol correctly' + ); + + is( $r->protocol, 'HTTP/1.0', '... got nothing by default' ); + + isnt( + exception { + $r->protocol('http/1.0'); + }, + undef, + '... the protocol died with bar params correctly' + ); +} + +{ + $r->base('http://localhost/'); + isa_ok( $r->base, 'URI' ); + + $r->uri('http://localhost/'); + isa_ok( $r->uri, 'URI' ); +} +} + + + + +1; diff --git a/t/recipes/basics_point_attributesandsubclassing.t b/t/recipes/basics_point_attributesandsubclassing.t new file mode 100644 index 0000000..4ba63c2 --- /dev/null +++ b/t/recipes/basics_point_attributesandsubclassing.t @@ -0,0 +1,251 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + + package Point; + use Moose; + + has 'x' => (isa => 'Int', is => 'rw', required => 1); + has 'y' => (isa => 'Int', is => 'rw', required => 1); + + sub clear { + my $self = shift; + $self->x(0); + $self->y(0); + } + + package Point3D; + use Moose; + + extends 'Point'; + + has 'z' => (isa => 'Int', is => 'rw', required => 1); + + after 'clear' => sub { + my $self = shift; + $self->z(0); + }; + + package main; + + # hash or hashrefs are ok for the constructor + my $point1 = Point->new(x => 5, y => 7); + my $point2 = Point->new({x => 5, y => 7}); + + my $point3d = Point3D->new(x => 5, y => 42, z => -5); +} + + + +# =begin testing +{ +my $point = Point->new( x => 1, y => 2 ); +isa_ok( $point, 'Point' ); +isa_ok( $point, 'Moose::Object' ); + +is( $point->x, 1, '... got the right value for x' ); +is( $point->y, 2, '... got the right value for y' ); + +$point->y(10); +is( $point->y, 10, '... got the right (changed) value for y' ); + +isnt( + exception { + $point->y('Foo'); + }, + undef, + '... cannot assign a non-Int to y' +); + +isnt( + exception { + Point->new(); + }, + undef, + '... must provide required attributes to new' +); + +$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 + +is( + exception { + Point->new( x => 0, y => 0 ); + }, + undef, + '... can assign a 0 to x and y' +); + +isnt( + exception { + Point->new( x => 10, y => 'Foo' ); + }, + undef, + '... cannot assign a non-Int to y' +); + +isnt( + exception { + Point->new( x => 'Foo', y => 10 ); + }, + undef, + '... 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' ); +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' ); + +$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' ); + +isnt( + exception { + Point3D->new( x => 10, y => 'Foo', z => 3 ); + }, + undef, + '... cannot assign a non-Int to y' +); + +isnt( + exception { + Point3D->new( x => 'Foo', y => 10, z => 3 ); + }, + undef, + '... cannot assign a non-Int to x' +); + +isnt( + exception { + Point3D->new( x => 0, y => 10, z => 'Bar' ); + }, + undef, + '... cannot assign a non-Int to z' +); + +isnt( + exception { + Point3D->new( x => 10, y => 3 ); + }, + undef, + '... z is a required attribute for Point3D' +); + +# test some class introspection + +can_ok( 'Point', 'meta' ); +isa_ok( Point->meta, 'Moose::Meta::Class' ); + +can_ok( 'Point3D', 'meta' ); +isa_ok( Point3D->meta, 'Moose::Meta::Class' ); + +isnt( + Point->meta, Point3D->meta, + '... they are different metaclasses as well' +); + +# poke at Point + +is_deeply( + [ Point->meta->superclasses ], + ['Moose::Object'], + '... Point got the automagic base class' +); + +my @Point_methods = qw(meta 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 . '"' ); +} + +foreach my $attr_name (@Point_attrs) { + ok( Point->meta->has_attribute($attr_name), + '... Point has the attribute "' . $attr_name . '"' ); + my $attr = Point->meta->get_attribute($attr_name); + ok( $attr->has_type_constraint, + '... Attribute ' . $attr_name . ' has a type constraint' ); + isa_ok( $attr->type_constraint, 'Moose::Meta::TypeConstraint' ); + is( $attr->type_constraint->name, 'Int', + '... Attribute ' . $attr_name . ' has an Int type constraint' ); +} + +# poke at Point3D + +is_deeply( + [ Point3D->meta->superclasses ], + ['Point'], + '... Point3D gets the parent given to it' +); + +my @Point3D_methods = qw( meta z 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 . '"' ); +} + +foreach my $attr_name (@Point3D_attrs) { + ok( Point3D->meta->has_attribute($attr_name), + '... Point3D has the attribute "' . $attr_name . '"' ); + my $attr = Point3D->meta->get_attribute($attr_name); + ok( $attr->has_type_constraint, + '... Attribute ' . $attr_name . ' has a type constraint' ); + isa_ok( $attr->type_constraint, 'Moose::Meta::TypeConstraint' ); + is( $attr->type_constraint->name, 'Int', + '... Attribute ' . $attr_name . ' has an Int type constraint' ); +} +} + + + + +1; diff --git a/t/recipes/extending_debugging_baseclassrole.t b/t/recipes/extending_debugging_baseclassrole.t new file mode 100644 index 0000000..a05181f --- /dev/null +++ b/t/recipes/extending_debugging_baseclassrole.t @@ -0,0 +1,59 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +use Test::Requires 'Test::Output'; + + + +# =begin testing SETUP +{ + + package MooseX::Debugging; + + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + base_class_roles => ['MooseX::Debugging::Role::Object'], + ); + + package MooseX::Debugging::Role::Object; + + use Moose::Role; + + sub BUILD {} + after BUILD => sub { + my $self = shift; + + warn "Made a new " . ( ref $self ) . " object\n"; + }; +} + + + +# =begin testing +{ +{ + package Debugged; + + use Moose; + MooseX::Debugging->import; +} + +stderr_is( + sub { Debugged->new }, + "Made a new Debugged object\n", + 'got expected output from debugging role' +); +} + + + + +1; diff --git a/t/recipes/extending_mooseish_moosesugar.t b/t/recipes/extending_mooseish_moosesugar.t new file mode 100644 index 0000000..fd003c9 --- /dev/null +++ b/t/recipes/extending_mooseish_moosesugar.t @@ -0,0 +1,66 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + + package MyApp::Mooseish; + + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + with_meta => ['has_table'], + class_metaroles => { + class => ['MyApp::Meta::Class::Trait::HasTable'], + }, + ); + + sub has_table { + my $meta = shift; + $meta->table(shift); + } + + package MyApp::Meta::Class::Trait::HasTable; + use Moose::Role; + + has table => ( + is => 'rw', + isa => 'Str', + ); +} + + + +# =begin testing +{ +{ + package MyApp::User; + + use Moose; + MyApp::Mooseish->import; + + has_table( 'User' ); + + has( 'username' => ( is => 'ro' ) ); + has( 'password' => ( is => 'ro' ) ); + + sub login { } +} + +can_ok( MyApp::User->meta, 'table' ); +is( MyApp::User->meta->table, 'User', + 'MyApp::User->meta->table returns User' ); +ok( MyApp::User->can('username'), + 'MyApp::User has username method' ); +} + + + + +1; diff --git a/t/recipes/legacy_debugging_baseclassreplacement.t b/t/recipes/legacy_debugging_baseclassreplacement.t new file mode 100644 index 0000000..9d653c3 --- /dev/null +++ b/t/recipes/legacy_debugging_baseclassreplacement.t @@ -0,0 +1,68 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + + package MyApp::Base; + use Moose; + + extends 'Moose::Object'; + + before 'new' => sub { warn "Making a new " . $_[0] }; + + no Moose; + + package MyApp::UseMyBase; + use Moose (); + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( also => 'Moose' ); + + sub init_meta { + shift; + return Moose->init_meta( @_, base_class => 'MyApp::Base' ); + } +} + + + +# =begin testing SETUP +use Test::Requires 'Test::Output'; + + + +# =begin testing +{ +{ + package Foo; + + MyApp::UseMyBase->import; + + has( 'size' => ( is => 'rw' ) ); +} + +ok( Foo->isa('MyApp::Base'), 'Foo isa MyApp::Base' ); + +ok( Foo->can('size'), 'Foo has a size method' ); + +my $foo; +stderr_like( + sub { $foo = Foo->new( size => 2 ) }, + qr/^Making a new Foo/, + 'got expected warning when calling Foo->new' +); + +is( $foo->size(), 2, '$foo->size is 2' ); +} + + + + +1; diff --git a/t/recipes/legacy_labeled_attributemetaclass.t b/t/recipes/legacy_labeled_attributemetaclass.t new file mode 100644 index 0000000..e8d93e9 --- /dev/null +++ b/t/recipes/legacy_labeled_attributemetaclass.t @@ -0,0 +1,86 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + + package MyApp::Meta::Attribute::Labeled; + use Moose; + extends 'Moose::Meta::Attribute'; + + has label => ( + is => 'rw', + isa => 'Str', + predicate => 'has_label', + ); + + package Moose::Meta::Attribute::Custom::Labeled; + sub register_implementation {'MyApp::Meta::Attribute::Labeled'} + + package MyApp::Website; + use Moose; + + has url => ( + metaclass => 'Labeled', + is => 'rw', + isa => 'Str', + label => "The site's URL", + ); + + has name => ( + is => 'rw', + isa => 'Str', + ); + + sub dump { + my $self = shift; + + my $meta = $self->meta; + + my $dump = ''; + + for my $attribute ( map { $meta->get_attribute($_) } + sort $meta->get_attribute_list ) { + + if ( $attribute->isa('MyApp::Meta::Attribute::Labeled') + && $attribute->has_label ) { + $dump .= $attribute->label; + } + else { + $dump .= $attribute->name; + } + + my $reader = $attribute->get_read_method; + $dump .= ": " . $self->$reader . "\n"; + } + + return $dump; + } + + package main; + + my $app = MyApp::Website->new( url => "http://google.com", name => "Google" ); +} + + + +# =begin testing +{ +my $app = MyApp::Website->new( url => "http://google.com", name => "Google" ); +is( + $app->dump, q{name: Google +The site's URL: http://google.com +}, '... got the expected dump value' +); +} + + + + +1; diff --git a/t/recipes/meta_globref_instancemetaclass.t b/t/recipes/meta_globref_instancemetaclass.t new file mode 100644 index 0000000..b02c0eb --- /dev/null +++ b/t/recipes/meta_globref_instancemetaclass.t @@ -0,0 +1,153 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + + package My::Meta::Instance; + + use Scalar::Util qw( weaken ); + use Symbol qw( gensym ); + + use Moose::Role; + + sub create_instance { + my $self = shift; + my $sym = gensym(); + bless $sym, $self->_class_name; + } + + sub clone_instance { + my ( $self, $instance ) = @_; + + my $new_sym = gensym(); + %{*$new_sym} = %{*$instance}; + + bless $new_sym, $self->_class_name; + } + + sub get_slot_value { + my ( $self, $instance, $slot_name ) = @_; + return *$instance->{$slot_name}; + } + + sub set_slot_value { + my ( $self, $instance, $slot_name, $value ) = @_; + *$instance->{$slot_name} = $value; + } + + sub deinitialize_slot { + my ( $self, $instance, $slot_name ) = @_; + delete *$instance->{$slot_name}; + } + + sub is_slot_initialized { + my ( $self, $instance, $slot_name ) = @_; + exists *$instance->{$slot_name}; + } + + sub weaken_slot_value { + my ( $self, $instance, $slot_name ) = @_; + weaken *$instance->{$slot_name}; + } + + sub inline_create_instance { + my ( $self, $class_variable ) = @_; + return 'do { my $sym = Symbol::gensym(); bless $sym, ' . $class_variable . ' }'; + } + + sub inline_slot_access { + my ( $self, $instance, $slot_name ) = @_; + return '*{' . $instance . '}->{' . $slot_name . '}'; + } + + package MyApp::User; + + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { + instance => ['My::Meta::Instance'], + }, + ); + + has 'name' => ( + is => 'rw', + isa => 'Str', + ); + + has 'email' => ( + is => 'rw', + isa => 'Str', + ); +} + + + +# =begin testing +{ +{ + package MyApp::Employee; + + use Moose; + extends 'MyApp::User'; + + has 'employee_number' => ( is => 'rw' ); +} + +for my $x ( 0 .. 1 ) { + MyApp::User->meta->make_immutable if $x; + + my $user = MyApp::User->new( + name => 'Faye', + email => 'faye@example.com', + ); + + ok( eval { *{$user} }, 'user object is an glob ref with some values' ); + + is( $user->name, 'Faye', 'check name' ); + is( $user->email, 'faye@example.com', 'check email' ); + + $user->name('Ralph'); + is( $user->name, 'Ralph', 'check name after changing it' ); + + $user->email('ralph@example.com'); + is( $user->email, 'ralph@example.com', 'check email after changing it' ); +} + +for my $x ( 0 .. 1 ) { + MyApp::Employee->meta->make_immutable if $x; + + my $emp = MyApp::Employee->new( + name => 'Faye', + email => 'faye@example.com', + employee_number => $x, + ); + + ok( eval { *{$emp} }, 'employee object is an glob ref with some values' ); + + is( $emp->name, 'Faye', 'check name' ); + is( $emp->email, 'faye@example.com', 'check email' ); + is( $emp->employee_number, $x, 'check employee_number' ); + + $emp->name('Ralph'); + is( $emp->name, 'Ralph', 'check name after changing it' ); + + $emp->email('ralph@example.com'); + is( $emp->email, 'ralph@example.com', 'check email after changing it' ); + + $emp->employee_number(42); + is( $emp->employee_number, 42, 'check employee_number after changing it' ); +} +} + + + + +1; diff --git a/t/recipes/meta_labeled_attributetrait.t b/t/recipes/meta_labeled_attributetrait.t new file mode 100644 index 0000000..48e3215 --- /dev/null +++ b/t/recipes/meta_labeled_attributetrait.t @@ -0,0 +1,84 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + + package MyApp::Meta::Attribute::Trait::Labeled; + use Moose::Role; + Moose::Util::meta_attribute_alias('Labeled'); + + has label => ( + is => 'rw', + isa => 'Str', + predicate => 'has_label', + ); + + package MyApp::Website; + use Moose; + + has url => ( + traits => [qw/Labeled/], + is => 'rw', + isa => 'Str', + label => "The site's URL", + ); + + has name => ( + is => 'rw', + isa => 'Str', + ); + + sub dump { + my $self = shift; + + my $meta = $self->meta; + + my $dump = ''; + + for my $attribute ( map { $meta->get_attribute($_) } + sort $meta->get_attribute_list ) { + + if ( $attribute->does('MyApp::Meta::Attribute::Trait::Labeled') + && $attribute->has_label ) { + $dump .= $attribute->label; + } + else { + $dump .= $attribute->name; + } + + my $reader = $attribute->get_read_method; + $dump .= ": " . $self->$reader . "\n"; + } + + return $dump; + } + + package main; + + my $app = MyApp::Website->new( url => "http://google.com", name => "Google" ); +} + + + +# =begin testing +{ +my $app + = MyApp::Website->new( url => 'http://google.com', name => 'Google' ); +is( + $app->dump, q{name: Google +The site's URL: http://google.com +}, '... got the expected dump value' +); +} + + + + +1; diff --git a/t/recipes/meta_privateorpublic_methodmetaclass.t b/t/recipes/meta_privateorpublic_methodmetaclass.t new file mode 100644 index 0000000..20650c7 --- /dev/null +++ b/t/recipes/meta_privateorpublic_methodmetaclass.t @@ -0,0 +1,109 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + + package MyApp::Meta::Method::PrivateOrPublic; + + use Moose; + use Moose::Util::TypeConstraints; + + extends 'Moose::Meta::Method'; + + has '_policy' => ( + is => 'ro', + isa => enum( [ qw( public private ) ] ), + default => 'public', + init_arg => 'policy', + ); + + sub new { + my $class = shift; + my %options = @_; + + my $self = $class->SUPER::wrap(%options); + + $self->{_policy} = $options{policy}; + + $self->_add_policy_wrapper; + + return $self; + } + + sub _add_policy_wrapper { + my $self = shift; + + return if $self->is_public; + + my $name = $self->name; + my $package = $self->package_name; + my $real_body = $self->body; + + my $body = sub { + die "The $package\::$name method is private" + unless ( scalar caller() ) eq $package; + + goto &{$real_body}; + }; + + $self->{body} = $body; + } + + sub is_public { $_[0]->_policy eq 'public' } + sub is_private { $_[0]->_policy eq 'private' } + + package MyApp::User; + + use Moose; + + has 'password' => ( is => 'rw' ); + + __PACKAGE__->meta()->add_method( + '_reset_password', + MyApp::Meta::Method::PrivateOrPublic->new( + name => '_reset_password', + package_name => __PACKAGE__, + body => sub { $_[0]->password('reset') }, + policy => 'private', + ) + ); +} + + + +# =begin testing +{ +package main; +use strict; +use warnings; + +use Test::Fatal; + +my $user = MyApp::User->new( password => 'foo!' ); + +like( exception { $user->_reset_password }, +qr/The MyApp::User::_reset_password method is private/, + '_reset_password method dies if called outside MyApp::User class'); + +{ + package MyApp::User; + + sub run_reset { $_[0]->_reset_password } +} + +$user->run_reset; + +is( $user->password, 'reset', 'password has been reset' ); +} + + + + +1; diff --git a/t/recipes/meta_table_metaclasstrait.t b/t/recipes/meta_table_metaclasstrait.t new file mode 100644 index 0000000..b396220 --- /dev/null +++ b/t/recipes/meta_table_metaclasstrait.t @@ -0,0 +1,55 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +BEGIN { + package MyApp::Meta::Class::Trait::HasTable; + use Moose::Role; + Moose::Util::meta_class_alias('HasTable'); + + has table => ( + is => 'rw', + isa => 'Str', + ); +} + + + +# =begin testing SETUP +{ + + # in lib/MyApp/Meta/Class/Trait/HasTable.pm + package MyApp::Meta::Class::Trait::HasTable; + use Moose::Role; + Moose::Util::meta_class_alias('HasTable'); + + has table => ( + is => 'rw', + isa => 'Str', + ); + + # in lib/MyApp/User.pm + package MyApp::User; + use Moose -traits => 'HasTable'; + + __PACKAGE__->meta->table('User'); +} + + + +# =begin testing +{ +can_ok( MyApp::User->meta, 'table' ); +is( MyApp::User->meta->table, 'User', 'My::User table is User' ); +} + + + + +1; diff --git a/t/recipes/roles_applicationtoinstance.t b/t/recipes/roles_applicationtoinstance.t new file mode 100644 index 0000000..53e3210 --- /dev/null +++ b/t/recipes/roles_applicationtoinstance.t @@ -0,0 +1,96 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + # Not in the recipe, but needed for writing tests. + package Employee; + + use Moose; + + has 'name' => ( + is => 'ro', + isa => 'Str', + required => 1, + ); + + has 'work' => ( + is => 'rw', + isa => 'Str', + predicate => 'has_work', + ); +} + + + +# =begin testing SETUP +{ + + package MyApp::Role::Job::Manager; + + use List::Util qw( first ); + + use Moose::Role; + + has 'employees' => ( + is => 'rw', + isa => 'ArrayRef[Employee]', + ); + + sub assign_work { + my $self = shift; + my $work = shift; + + my $employee = first { !$_->has_work } @{ $self->employees }; + + die 'All my employees have work to do!' unless $employee; + + $employee->work($work); + } + + package main; + + my $lisa = Employee->new( name => 'Lisa' ); + MyApp::Role::Job::Manager->meta->apply($lisa); + + my $homer = Employee->new( name => 'Homer' ); + my $bart = Employee->new( name => 'Bart' ); + my $marge = Employee->new( name => 'Marge' ); + + $lisa->employees( [ $homer, $bart, $marge ] ); + $lisa->assign_work('mow the lawn'); +} + + + +# =begin testing +{ +{ + my $lisa = Employee->new( name => 'Lisa' ); + MyApp::Role::Job::Manager->meta->apply($lisa); + + my $homer = Employee->new( name => 'Homer' ); + my $bart = Employee->new( name => 'Bart' ); + my $marge = Employee->new( name => 'Marge' ); + + $lisa->employees( [ $homer, $bart, $marge ] ); + $lisa->assign_work('mow the lawn'); + + ok( $lisa->does('MyApp::Role::Job::Manager'), + 'lisa now does the manager role' ); + + is( $homer->work, 'mow the lawn', + 'homer was assigned a task by lisa' ); +} +} + + + + +1; diff --git a/t/recipes/roles_comparable_codereuse.t b/t/recipes/roles_comparable_codereuse.t new file mode 100644 index 0000000..677a8ce --- /dev/null +++ b/t/recipes/roles_comparable_codereuse.t @@ -0,0 +1,202 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + + package Eq; + use Moose::Role; + + requires 'equal_to'; + + sub not_equal_to { + my ( $self, $other ) = @_; + not $self->equal_to($other); + } + + package Comparable; + use Moose::Role; + + with 'Eq'; + + requires 'compare'; + + sub equal_to { + my ( $self, $other ) = @_; + $self->compare($other) == 0; + } + + sub greater_than { + my ( $self, $other ) = @_; + $self->compare($other) == 1; + } + + sub less_than { + my ( $self, $other ) = @_; + $self->compare($other) == -1; + } + + sub greater_than_or_equal_to { + my ( $self, $other ) = @_; + $self->greater_than($other) || $self->equal_to($other); + } + + sub less_than_or_equal_to { + my ( $self, $other ) = @_; + $self->less_than($other) || $self->equal_to($other); + } + + package Printable; + use Moose::Role; + + requires 'to_string'; + + package US::Currency; + use Moose; + + with 'Comparable', 'Printable'; + + has 'amount' => ( is => 'rw', isa => 'Num', default => 0 ); + + sub compare { + my ( $self, $other ) = @_; + $self->amount <=> $other->amount; + } + + sub to_string { + my $self = shift; + sprintf '$%0.2f USD' => $self->amount; + } +} + + + +# =begin testing +{ +ok( US::Currency->does('Comparable'), '... US::Currency does Comparable' ); +ok( US::Currency->does('Eq'), '... US::Currency does Eq' ); +ok( US::Currency->does('Printable'), '... US::Currency does Printable' ); + +my $hundred = US::Currency->new( amount => 100.00 ); +isa_ok( $hundred, 'US::Currency' ); + +ok( $hundred->DOES("US::Currency"), "UNIVERSAL::DOES for class" ); +ok( $hundred->DOES("Comparable"), "UNIVERSAL::DOES for role" ); + +can_ok( $hundred, 'amount' ); +is( $hundred->amount, 100, '... got the right amount' ); + +can_ok( $hundred, 'to_string' ); +is( $hundred->to_string, '$100.00 USD', + '... got the right stringified value' ); + +ok( $hundred->does('Comparable'), '... US::Currency does Comparable' ); +ok( $hundred->does('Eq'), '... US::Currency does Eq' ); +ok( $hundred->does('Printable'), '... US::Currency does Printable' ); + +my $fifty = US::Currency->new( amount => 50.00 ); +isa_ok( $fifty, 'US::Currency' ); + +can_ok( $fifty, 'amount' ); +is( $fifty->amount, 50, '... got the right amount' ); + +can_ok( $fifty, 'to_string' ); +is( $fifty->to_string, '$50.00 USD', '... got the right stringified value' ); + +ok( $hundred->greater_than($fifty), '... 100 gt 50' ); +ok( $hundred->greater_than_or_equal_to($fifty), '... 100 ge 50' ); +ok( !$hundred->less_than($fifty), '... !100 lt 50' ); +ok( !$hundred->less_than_or_equal_to($fifty), '... !100 le 50' ); +ok( !$hundred->equal_to($fifty), '... !100 eq 50' ); +ok( $hundred->not_equal_to($fifty), '... 100 ne 50' ); + +ok( !$fifty->greater_than($hundred), '... !50 gt 100' ); +ok( !$fifty->greater_than_or_equal_to($hundred), '... !50 ge 100' ); +ok( $fifty->less_than($hundred), '... 50 lt 100' ); +ok( $fifty->less_than_or_equal_to($hundred), '... 50 le 100' ); +ok( !$fifty->equal_to($hundred), '... !50 eq 100' ); +ok( $fifty->not_equal_to($hundred), '... 50 ne 100' ); + +ok( !$fifty->greater_than($fifty), '... !50 gt 50' ); +ok( $fifty->greater_than_or_equal_to($fifty), '... !50 ge 50' ); +ok( !$fifty->less_than($fifty), '... 50 lt 50' ); +ok( $fifty->less_than_or_equal_to($fifty), '... 50 le 50' ); +ok( $fifty->equal_to($fifty), '... 50 eq 50' ); +ok( !$fifty->not_equal_to($fifty), '... !50 ne 50' ); + +## ... check some meta-stuff + +# Eq + +my $eq_meta = Eq->meta; +isa_ok( $eq_meta, 'Moose::Meta::Role' ); + +ok( $eq_meta->has_method('not_equal_to'), '... Eq has_method not_equal_to' ); +ok( $eq_meta->requires_method('equal_to'), + '... Eq requires_method not_equal_to' ); + +# Comparable + +my $comparable_meta = Comparable->meta; +isa_ok( $comparable_meta, 'Moose::Meta::Role' ); + +ok( $comparable_meta->does_role('Eq'), '... Comparable does Eq' ); + +foreach my $method_name ( + qw( + equal_to not_equal_to + greater_than greater_than_or_equal_to + less_than less_than_or_equal_to + ) + ) { + ok( $comparable_meta->has_method($method_name), + '... Comparable has_method ' . $method_name ); +} + +ok( $comparable_meta->requires_method('compare'), + '... Comparable requires_method compare' ); + +# Printable + +my $printable_meta = Printable->meta; +isa_ok( $printable_meta, 'Moose::Meta::Role' ); + +ok( $printable_meta->requires_method('to_string'), + '... Printable requires_method to_string' ); + +# US::Currency + +my $currency_meta = US::Currency->meta; +isa_ok( $currency_meta, 'Moose::Meta::Class' ); + +ok( $currency_meta->does_role('Comparable'), + '... US::Currency does Comparable' ); +ok( $currency_meta->does_role('Eq'), '... US::Currency does Eq' ); +ok( $currency_meta->does_role('Printable'), + '... US::Currency does Printable' ); + +foreach my $method_name ( + qw( + amount + equal_to not_equal_to + compare + greater_than greater_than_or_equal_to + less_than less_than_or_equal_to + to_string + ) + ) { + ok( $currency_meta->has_method($method_name), + '... US::Currency has_method ' . $method_name ); +} +} + + + + +1; diff --git a/t/recipes/roles_restartable_advancedcomposition.t b/t/recipes/roles_restartable_advancedcomposition.t new file mode 100644 index 0000000..8b2fdf4 --- /dev/null +++ b/t/recipes/roles_restartable_advancedcomposition.t @@ -0,0 +1,118 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Fatal; +$| = 1; + + + +# =begin testing SETUP +{ + + package Restartable; + use Moose::Role; + + has 'is_paused' => ( + is => 'rw', + isa => 'Bool', + default => 0, + ); + + requires 'save_state', 'load_state'; + + sub stop { 1 } + + sub start { 1 } + + package Restartable::ButUnreliable; + use Moose::Role; + + with 'Restartable' => { + -alias => { + stop => '_stop', + start => '_start' + }, + -excludes => [ 'stop', 'start' ], + }; + + sub stop { + my $self = shift; + + $self->explode() if rand(1) > .5; + + $self->_stop(); + } + + sub start { + my $self = shift; + + $self->explode() if rand(1) > .5; + + $self->_start(); + } + + package Restartable::ButBroken; + use Moose::Role; + + with 'Restartable' => { -excludes => [ 'stop', 'start' ] }; + + sub stop { + my $self = shift; + + $self->explode(); + } + + sub start { + my $self = shift; + + $self->explode(); + } +} + + + +# =begin testing +{ +{ + my $unreliable = Moose::Meta::Class->create_anon_class( + superclasses => [], + roles => [qw/Restartable::ButUnreliable/], + methods => { + explode => sub { }, # nop. + 'save_state' => sub { }, + 'load_state' => sub { }, + }, + )->new_object(); + ok( $unreliable, 'made anon class with Restartable::ButUnreliable role' ); + can_ok( $unreliable, qw/start stop/ ); +} + +{ + my $cnt = 0; + my $broken = Moose::Meta::Class->create_anon_class( + superclasses => [], + roles => [qw/Restartable::ButBroken/], + methods => { + explode => sub { $cnt++ }, + 'save_state' => sub { }, + 'load_state' => sub { }, + }, + )->new_object(); + + ok( $broken, 'made anon class with Restartable::ButBroken role' ); + + $broken->start(); + + is( $cnt, 1, '... start called explode' ); + + $broken->stop(); + + is( $cnt, 2, '... stop also called explode' ); +} +} + + + + +1; diff --git a/t/roles/anonymous_roles.t b/t/roles/anonymous_roles.t new file mode 100644 index 0000000..53bfb34 --- /dev/null +++ b/t/roles/anonymous_roles.t @@ -0,0 +1,68 @@ +use strict; +use warnings; +use Test::More; +use Moose (); + +use Class::Load qw(is_class_loaded); + +my $role = Moose::Meta::Role->create_anon_role( + attributes => { + is_worn => { + is => 'rw', + isa => 'Bool', + }, + }, + methods => { + remove => sub { shift->is_worn(0) }, + }, +); + +my $class = Moose::Meta::Class->create('MyItem::Armor::Helmet'); +$role->apply($class); +# XXX: Moose::Util::apply_all_roles doesn't cope with references yet + +my $visored = $class->new_object(is_worn => 0); +ok(!$visored->is_worn, "attribute, accessor was consumed"); +$visored->is_worn(1); +ok($visored->is_worn, "accessor was consumed"); +$visored->remove; +ok(!$visored->is_worn, "method was consumed"); + +like($role->name, qr/^Moose::Meta::Role::__ANON__::SERIAL::\d+$/, ""); +ok($role->is_anon_role, "the role knows it's anonymous"); + +ok(is_class_loaded(Moose::Meta::Role->create_anon_role->name), "creating an anonymous role satisifes is_class_loaded"); +ok(Class::MOP::class_of(Moose::Meta::Role->create_anon_role->name), "creating an anonymous role satisifes class_of"); + +{ + my $role; + { + my $meta = Moose::Meta::Role->create_anon_role( + methods => { + foo => sub { 'FOO' }, + }, + ); + + $role = $meta->name; + can_ok($role, 'foo'); + } + ok(!$role->can('foo')); +} + +{ + my $role; + { + my $meta = Moose::Meta::Role->create_anon_role( + methods => { + foo => sub { 'FOO' }, + }, + ); + + $role = $meta->name; + can_ok($role, 'foo'); + Class::MOP::remove_metaclass_by_name($role); + } + ok(!$role->can('foo')); +} + +done_testing; diff --git a/t/roles/application_toclass.t b/t/roles/application_toclass.t new file mode 100644 index 0000000..b07bc80 --- /dev/null +++ b/t/roles/application_toclass.t @@ -0,0 +1,75 @@ +use strict; +use warnings; +use Test::More; + +do { + package Role::Foo; + use Moose::Role; + + sub foo { } + + + package Consumer::Basic; + use Moose; + + with 'Role::Foo'; + + package Consumer::Excludes; + use Moose; + + with 'Role::Foo' => { -excludes => 'foo' }; + + package Consumer::Aliases; + use Moose; + + with 'Role::Foo' => { -alias => { 'foo' => 'role_foo' } }; + + package Consumer::Overrides; + use Moose; + + with 'Role::Foo'; + + sub foo { } +}; + +my @basic = Consumer::Basic->meta->role_applications; +my @excludes = Consumer::Excludes->meta->role_applications; +my @aliases = Consumer::Aliases->meta->role_applications; +my @overrides = Consumer::Overrides->meta->role_applications; + +is(@basic, 1); +is(@excludes, 1); +is(@aliases, 1); +is(@overrides, 1); + +my $basic = $basic[0]; +my $excludes = $excludes[0]; +my $aliases = $aliases[0]; +my $overrides = $overrides[0]; + +isa_ok($basic, 'Moose::Meta::Role::Application::ToClass'); +isa_ok($excludes, 'Moose::Meta::Role::Application::ToClass'); +isa_ok($aliases, 'Moose::Meta::Role::Application::ToClass'); +isa_ok($overrides, 'Moose::Meta::Role::Application::ToClass'); + +is($basic->role, Role::Foo->meta); +is($excludes->role, Role::Foo->meta); +is($aliases->role, Role::Foo->meta); +is($overrides->role, Role::Foo->meta); + +is($basic->class, Consumer::Basic->meta); +is($excludes->class, Consumer::Excludes->meta); +is($aliases->class, Consumer::Aliases->meta); +is($overrides->class, Consumer::Overrides->meta); + +is_deeply($basic->get_method_aliases, {}); +is_deeply($excludes->get_method_aliases, {}); +is_deeply($aliases->get_method_aliases, { foo => 'role_foo' }); +is_deeply($overrides->get_method_aliases, {}); + +is_deeply($basic->get_method_exclusions, []); +is_deeply($excludes->get_method_exclusions, ['foo']); +is_deeply($aliases->get_method_exclusions, []); +is_deeply($overrides->get_method_exclusions, []); + +done_testing; diff --git a/t/roles/apply_role.t b/t/roles/apply_role.t new file mode 100644 index 0000000..d811d03 --- /dev/null +++ b/t/roles/apply_role.t @@ -0,0 +1,227 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package FooRole; + use Moose::Role; + + our $VERSION = 23; + + has 'bar' => ( is => 'rw', isa => 'FooClass' ); + has 'baz' => ( is => 'ro' ); + + sub goo {'FooRole::goo'} + sub foo {'FooRole::foo'} + + override 'boo' => sub { 'FooRole::boo -> ' . super() }; + + around 'blau' => sub { + my $c = shift; + 'FooRole::blau -> ' . $c->(); + }; +} + +{ + package BarRole; + use Moose::Role; + sub woot {'BarRole::woot'} +} + +{ + package BarClass; + use Moose; + + sub boo {'BarClass::boo'} + sub foo {'BarClass::foo'} # << the role overrides this ... +} + +{ + package FooClass; + use Moose; + + extends 'BarClass'; + + ::like( ::exception { with 'FooRole' => { -version => 42 } }, qr/FooRole version 42 required--this is only version 23/, 'applying role with unsatisfied version requirement' ); + + ::is( ::exception { with 'FooRole' => { -version => 13 } }, undef, 'applying role with satisfied version requirement' ); + + sub blau {'FooClass::blau'} # << the role wraps this ... + + sub goo {'FooClass::goo'} # << overrides the one from the role ... +} + +{ + package FooBarClass; + use Moose; + + extends 'FooClass'; + with 'FooRole', 'BarRole'; +} + +{ + package PlainJane; + sub new { return bless {}, __PACKAGE__; } +} + +my $foo_class_meta = FooClass->meta; +isa_ok( $foo_class_meta, 'Moose::Meta::Class' ); + +my $foobar_class_meta = FooBarClass->meta; +isa_ok( $foobar_class_meta, 'Moose::Meta::Class' ); + +isnt( exception { + $foo_class_meta->does_role(); +}, undef, '... does_role requires a role name' ); + +isnt( exception { + $foo_class_meta->add_role(); +}, undef, '... apply_role requires a role' ); + +isnt( exception { + $foo_class_meta->add_role( bless( {} => 'Fail' ) ); +}, undef, '... apply_role requires a role' ); + +ok( $foo_class_meta->does_role('FooRole'), + '... the FooClass->meta does_role FooRole' ); +ok( !$foo_class_meta->does_role('OtherRole'), + '... the FooClass->meta !does_role OtherRole' ); + +ok( $foobar_class_meta->does_role('FooRole'), + '... the FooBarClass->meta does_role FooRole' ); +ok( $foobar_class_meta->does_role('BarRole'), + '... the FooBarClass->meta does_role BarRole' ); +ok( !$foobar_class_meta->does_role('OtherRole'), + '... the FooBarClass->meta !does_role OtherRole' ); + +foreach my $method_name (qw(bar baz foo boo blau goo)) { + ok( $foo_class_meta->has_method($method_name), + '... FooClass has the method ' . $method_name ); + ok( $foobar_class_meta->has_method($method_name), + '... FooBarClass has the method ' . $method_name ); +} + +ok( !$foo_class_meta->has_method('woot'), + '... FooClass lacks the method woot' ); +ok( $foobar_class_meta->has_method('woot'), + '... FooBarClass has the method woot' ); + +foreach my $attr_name (qw(bar baz)) { + ok( $foo_class_meta->has_attribute($attr_name), + '... FooClass has the attribute ' . $attr_name ); + ok( $foobar_class_meta->has_attribute($attr_name), + '... FooBarClass has the attribute ' . $attr_name ); +} + +can_ok( 'FooClass', 'does' ); +ok( FooClass->does('FooRole'), '... the FooClass does FooRole' ); +ok( !FooClass->does('BarRole'), '... the FooClass does not do BarRole' ); +ok( !FooClass->does('OtherRole'), '... the FooClass does not do OtherRole' ); + +can_ok( 'FooBarClass', 'does' ); +ok( FooBarClass->does('FooRole'), '... the FooClass does FooRole' ); +ok( FooBarClass->does('BarRole'), '... the FooBarClass does FooBarRole' ); +ok( !FooBarClass->does('OtherRole'), + '... the FooBarClass does not do OtherRole' ); + +my $foo = FooClass->new(); +isa_ok( $foo, 'FooClass' ); + +my $foobar = FooBarClass->new(); +isa_ok( $foobar, 'FooBarClass' ); + +is( $foo->goo, 'FooClass::goo', '... got the right value of goo' ); +is( $foobar->goo, 'FooRole::goo', '... got the right value of goo' ); + +is( $foo->boo, 'FooRole::boo -> BarClass::boo', + '... got the right value from ->boo' ); +is( $foobar->boo, 'FooRole::boo -> FooRole::boo -> BarClass::boo', + '... got the right value from ->boo (double wrapped)' ); + +is( $foo->blau, 'FooRole::blau -> FooClass::blau', + '... got the right value from ->blau' ); +is( $foobar->blau, 'FooRole::blau -> FooRole::blau -> FooClass::blau', + '... got the right value from ->blau' ); + +foreach my $foo ( $foo, $foobar ) { + can_ok( $foo, 'does' ); + ok( $foo->does('FooRole'), '... an instance of FooClass does FooRole' ); + ok( !$foo->does('OtherRole'), + '... and instance of FooClass does not do OtherRole' ); + + can_ok( $foobar, 'does' ); + ok( $foobar->does('FooRole'), + '... an instance of FooBarClass does FooRole' ); + ok( $foobar->does('BarRole'), + '... an instance of FooBarClass does BarRole' ); + ok( !$foobar->does('OtherRole'), + '... and instance of FooBarClass does not do OtherRole' ); + + for my $method (qw/bar baz foo boo goo blau/) { + can_ok( $foo, $method ); + } + + is( $foo->foo, 'FooRole::foo', '... got the right value of foo' ); + + ok( !defined( $foo->baz ), '... $foo->baz is undefined' ); + ok( !defined( $foo->bar ), '... $foo->bar is undefined' ); + + isnt( exception { + $foo->baz(1); + }, undef, '... baz is a read-only accessor' ); + + isnt( exception { + $foo->bar(1); + }, undef, '... bar is a read-write accessor with a type constraint' ); + + my $foo2 = FooClass->new(); + isa_ok( $foo2, 'FooClass' ); + + is( exception { + $foo->bar($foo2); + }, undef, '... bar is a read-write accessor with a type constraint' ); + + is( $foo->bar, $foo2, '... got the right value for bar now' ); +} + +{ + { + package MRole; + use Moose::Role; + sub meth { } + } + + { + package MRole2; + use Moose::Role; + sub meth2 { } + } + + { + use Moose::Meta::Class; + use Moose::Object; + use Moose::Util qw(apply_all_roles); + + my $class = Moose::Meta::Class->create( 'Class' => ( + superclasses => [ 'Moose::Object' ], + )); + + apply_all_roles($class, MRole->meta, MRole2->meta); + + ok(Class->can('meth'), "can meth"); + ok(Class->can('meth2'), "can meth2"); + } +} + +{ + ok(!Moose::Util::find_meta('PlainJane'), 'not initialized'); + Moose::Util::apply_all_roles('PlainJane', 'BarRole'); + ok(Moose::Util::find_meta('PlainJane'), 'initialized'); + ok(Moose::Util::find_meta('PlainJane')->does_role('BarRole'), 'does BarRole'); + my $pj = PlainJane->new(); + ok($pj->can('woot'), 'can woot'); +} + +done_testing; diff --git a/t/roles/build.t b/t/roles/build.t new file mode 100644 index 0000000..8094b90 --- /dev/null +++ b/t/roles/build.t @@ -0,0 +1,77 @@ +use strict; +use warnings; + +use Test::More; +use Test::Requires 'Test::Output'; # skip all if not installed + +# this test script ensures that my idiom of: +# role: sub BUILD, after BUILD +# continues to work to run code after object initialization, whether the class +# has a BUILD method or not + +my @CALLS; + +do { + package TestRole; + use Moose::Role; + + sub BUILD { push @CALLS, 'TestRole::BUILD' } + before BUILD => sub { push @CALLS, 'TestRole::BUILD:before' }; + after BUILD => sub { push @CALLS, 'TestRole::BUILD:after' }; +}; + +do { + package ClassWithBUILD; + use Moose; + + ::stderr_is { + with 'TestRole'; + } ''; + + sub BUILD { push @CALLS, 'ClassWithBUILD::BUILD' } +}; + +do { + package ExplicitClassWithBUILD; + use Moose; + + ::stderr_is { + with 'TestRole' => { -excludes => 'BUILD' }; + } ''; + + sub BUILD { push @CALLS, 'ExplicitClassWithBUILD::BUILD' } +}; + +do { + package ClassWithoutBUILD; + use Moose; + with 'TestRole'; +}; + +{ + is_deeply([splice @CALLS], [], "no calls to BUILD yet"); + + ClassWithBUILD->new; + + is_deeply([splice @CALLS], [ + 'TestRole::BUILD:before', + 'ClassWithBUILD::BUILD', + 'TestRole::BUILD:after', + ]); + + ClassWithoutBUILD->new; + + is_deeply([splice @CALLS], [ + 'TestRole::BUILD:before', + 'TestRole::BUILD', + 'TestRole::BUILD:after', + ]); + + if (ClassWithBUILD->meta->is_mutable) { + ClassWithBUILD->meta->make_immutable; + ClassWithoutBUILD->meta->make_immutable; + redo; + } +} + +done_testing; diff --git a/t/roles/conflict_many_methods.t b/t/roles/conflict_many_methods.t new file mode 100644 index 0000000..af149d7 --- /dev/null +++ b/t/roles/conflict_many_methods.t @@ -0,0 +1,47 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package Bomb; + use Moose::Role; + + sub fuse { } + sub explode { } + + package Spouse; + use Moose::Role; + + sub fuse { } + sub explode { } + + package Caninish; + use Moose::Role; + + sub bark { } + + package Treeve; + use Moose::Role; + + sub bark { } +} + +{ + package PracticalJoke; + use Moose; + + ::like( ::exception { + with 'Bomb', 'Spouse'; + }, qr/Due to method name conflicts in roles 'Bomb' and 'Spouse', the methods 'explode' and 'fuse' must be implemented or excluded by 'PracticalJoke'/ ); + + ::like( ::exception { + with ( + 'Bomb', 'Spouse', + 'Caninish', 'Treeve', + ); + }, qr/Due to a method name conflict in roles 'Caninish' and 'Treeve', the method 'bark' must be implemented or excluded by 'PracticalJoke'/ ); +} + +done_testing; diff --git a/t/roles/create_role.t b/t/roles/create_role.t new file mode 100644 index 0000000..ce70465 --- /dev/null +++ b/t/roles/create_role.t @@ -0,0 +1,39 @@ +use strict; +use warnings; +use Test::More; +use Moose (); + +my $role = Moose::Meta::Role->create( + 'MyItem::Role::Equipment', + attributes => { + is_worn => { + is => 'rw', + isa => 'Bool', + }, + }, + methods => { + remove => sub { shift->is_worn(0) }, + }, +); + +my $class = Moose::Meta::Class->create('MyItem::Armor::Helmet' => + roles => ['MyItem::Role::Equipment'], +); + +my $visored = $class->new_object(is_worn => 0); +ok(!$visored->is_worn, "attribute, accessor was consumed"); +$visored->is_worn(1); +ok($visored->is_worn, "accessor was consumed"); +$visored->remove; +ok(!$visored->is_worn, "method was consumed"); + +ok(!$role->is_anon_role, "the role is not anonymous"); + +my $composed_role = Moose::Meta::Role->create( + 'MyItem::Role::Equipment2', + roles => [ $role ], +); + +ok($composed_role->does_role('MyItem::Role::Equipment2'), "Role composed into role"); + +done_testing; diff --git a/t/roles/create_role_subclass.t b/t/roles/create_role_subclass.t new file mode 100644 index 0000000..c5795cb --- /dev/null +++ b/t/roles/create_role_subclass.t @@ -0,0 +1,26 @@ +use strict; +use warnings; +use Test::More; +use Moose (); + +do { + package My::Meta::Role; + use Moose; + extends 'Moose::Meta::Role'; + + has test_serial => ( + is => 'ro', + isa => 'Int', + default => 1, + ); + + no Moose; +}; + +my $role = My::Meta::Role->create_anon_role; +is($role->test_serial, 1, "default value for the serial attribute"); + +my $nine_role = My::Meta::Role->create_anon_role(test_serial => 9); +is($nine_role->test_serial, 9, "parameter value for the serial attribute"); + +done_testing; diff --git a/t/roles/empty_method_modifiers_meta_bug.t b/t/roles/empty_method_modifiers_meta_bug.t new file mode 100644 index 0000000..28f9274 --- /dev/null +++ b/t/roles/empty_method_modifiers_meta_bug.t @@ -0,0 +1,29 @@ +use strict; +use warnings; + +use Test::More; + +# test role and class +package SomeRole; +use Moose::Role; + +requires 'foo'; + +package SomeClass; +use Moose; +has 'foo' => (is => 'rw'); +with 'SomeRole'; + +package main; + +#my $c = SomeClass->new; +#isa_ok( $c, 'SomeClass'); + +for my $modifier_type (qw[ before around after ]) { + my $get_func = "get_${modifier_type}_method_modifiers"; + my @mms = eval{ SomeRole->meta->$get_func('foo') }; + is($@, '', "$get_func for no method mods does not die"); + is(scalar(@mms),0,'is an empty list'); +} + +done_testing; diff --git a/t/roles/extending_role_attrs.t b/t/roles/extending_role_attrs.t new file mode 100644 index 0000000..d1841ab --- /dev/null +++ b/t/roles/extending_role_attrs.t @@ -0,0 +1,184 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +=pod + +This basically just makes sure that using +name +on role attributes works right. + +=cut + +{ + package Foo::Role; + use Moose::Role; + + has 'bar' => ( + is => 'rw', + isa => 'Int', + default => sub { 10 }, + ); + + package Foo; + use Moose; + + with 'Foo::Role'; + + ::is( ::exception { + has '+bar' => (default => sub { 100 }); + }, undef, '... extended the attribute successfully' ); +} + +my $foo = Foo->new; +isa_ok($foo, 'Foo'); + +is($foo->bar, 100, '... got the extended attribute'); + + +{ + package Bar::Role; + use Moose::Role; + + has 'foo' => ( + is => 'rw', + isa => 'Str | Int', + ); + + package Bar; + use Moose; + + with 'Bar::Role'; + + ::is( ::exception { + has '+foo' => ( + isa => 'Int', + ) + }, undef, "... narrowed the role's type constraint successfully" ); +} + +my $bar = Bar->new(foo => 42); +isa_ok($bar, 'Bar'); +is($bar->foo, 42, '... got the extended attribute'); +$bar->foo(100); +is($bar->foo, 100, "... can change the attribute's value to an Int"); + +like( exception { $bar->foo("baz") }, qr/^Attribute \(foo\) does not pass the type constraint because: Validation failed for 'Int' with value .*baz.* at / ); +is($bar->foo, 100, "... still has the old Int value"); + + +{ + package Baz::Role; + use Moose::Role; + + has 'baz' => ( + is => 'rw', + isa => 'Value', + ); + + package Baz; + use Moose; + + with 'Baz::Role'; + + ::is( ::exception { + has '+baz' => ( + isa => 'Int | ClassName', + ) + }, undef, "... narrowed the role's type constraint successfully" ); +} + +my $baz = Baz->new(baz => 99); +isa_ok($baz, 'Baz'); +is($baz->baz, 99, '... got the extended attribute'); +$baz->baz('Foo'); +is($baz->baz, 'Foo', "... can change the attribute's value to a ClassName"); + +like( exception { $baz->baz("zonk") }, qr/^Attribute \(baz\) does not pass the type constraint because: Validation failed for 'ClassName\|Int' with value .*zonk.* at / ); +is_deeply($baz->baz, 'Foo', "... still has the old ClassName value"); + + +{ + package Quux::Role; + use Moose::Role; + + has 'quux' => ( + is => 'rw', + isa => 'Str | Int | Ref', + ); + + package Quux; + use Moose; + use Moose::Util::TypeConstraints; + + with 'Quux::Role'; + + subtype 'Positive' + => as 'Int' + => where { $_ > 0 }; + + ::is( ::exception { + has '+quux' => ( + isa => 'Positive | ArrayRef', + ) + }, undef, "... narrowed the role's type constraint successfully" ); +} + +my $quux = Quux->new(quux => 99); +isa_ok($quux, 'Quux'); +is($quux->quux, 99, '... got the extended attribute'); +$quux->quux(100); +is($quux->quux, 100, "... can change the attribute's value to an Int"); +$quux->quux(["hi"]); +is_deeply($quux->quux, ["hi"], "... can change the attribute's value to an ArrayRef"); + +like( exception { $quux->quux("quux") }, qr/^Attribute \(quux\) does not pass the type constraint because: Validation failed for 'ArrayRef\|Positive' with value .*quux.* at / ); +is_deeply($quux->quux, ["hi"], "... still has the old ArrayRef value"); + +like( exception { $quux->quux({a => 1}) }, qr/^Attribute \(quux\) does not pass the type constraint because: Validation failed for 'ArrayRef\|Positive' with value .+ at / ); +is_deeply($quux->quux, ["hi"], "... still has the old ArrayRef value"); + + +{ + package Err::Role; + use Moose::Role; + + for (1..3) { + has "err$_" => ( + isa => 'Str | Int', + is => 'bare', + ); + } + + package Err; + use Moose; + + with 'Err::Role'; + + ::is( ::exception { + has '+err1' => (isa => 'Defined'); + }, undef, "can get less specific in the subclass" ); + + ::is( ::exception { + has '+err2' => (isa => 'Bool'); + }, undef, "or change the type completely" ); + + ::is( ::exception { + has '+err3' => (isa => 'Str | ArrayRef'); + }, undef, "or add new types to the union" ); +} + +{ + package Role::With::PlusAttr; + use Moose::Role; + + with 'Foo::Role'; + + ::like( ::exception { + has '+bar' => ( is => 'ro' ); + }, qr/has '\+attr' is not supported in roles/, "Test has '+attr' in roles explodes" ); +} + +done_testing; diff --git a/t/roles/free_anonymous_roles.t b/t/roles/free_anonymous_roles.t new file mode 100644 index 0000000..98ce5dc --- /dev/null +++ b/t/roles/free_anonymous_roles.t @@ -0,0 +1,62 @@ +use strict; +use warnings; +use Test::More; +use Moose (); +use Scalar::Util 'weaken'; + +my $weak; +my $name; +do { + my $anon_class; + + do { + my $role = Moose::Meta::Role->create_anon_role( + methods => { + improperly_freed => sub { 1 }, + }, + ); + weaken($weak = $role); + + $name = $role->name; + + $anon_class = Moose::Meta::Class->create_anon_class( + roles => [ $role->name ], + ); + }; + + ok($weak, "we still have the role metaclass because the anonymous class that consumed it is still alive"); + ok($name->can('improperly_freed'), "we have not blown away the role's symbol table"); +}; + +ok(!$weak, "the role metaclass is freed after its last reference (from a consuming anonymous class) is freed"); + +ok(!$name->can('improperly_freed'), "we blew away the role's symbol table entries"); + +do { + my $anon_class; + + do { + my $role = Moose::Meta::Role->create_anon_role( + methods => { + improperly_freed => sub { 1 }, + }, + weaken => 0, + ); + weaken($weak = $role); + + $name = $role->name; + + $anon_class = Moose::Meta::Class->create_anon_class( + roles => [ $role->name ], + ); + }; + + ok($weak, "we still have the role metaclass because the anonymous class that consumed it is still alive"); + ok($name->can('improperly_freed'), "we have not blown away the role's symbol table"); +}; + +ok($weak, "the role metaclass still exists because we told it not to weaken"); + +ok($name->can('improperly_freed'), "the symbol table still exists too"); + +done_testing; diff --git a/t/roles/imported_required_method.t b/t/roles/imported_required_method.t new file mode 100644 index 0000000..4c2e080 --- /dev/null +++ b/t/roles/imported_required_method.t @@ -0,0 +1,58 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; +use Test::Moose; + +BEGIN { + package ExportsFoo; + use Sub::Exporter -setup => { + exports => ['foo'], + }; + + sub foo { 'FOO' } + + $INC{'ExportsFoo.pm'} = 1; +} + +{ + package Foo; + use Moose::Role; + requires 'foo'; +} + +{ + package Bar; + use Moose::Role; + requires 'bar'; +} + +{ + package Class; + use Moose; + use ExportsFoo 'foo'; + + # The grossness near the end of the regex works around a bug with \Q not + # escaping \& properly with perl 5.8.x + ::like( + ::exception { with 'Foo' }, + qr/^\Q'Foo' requires the method 'foo' to be implemented by 'Class'. If you imported functions intending to use them as methods, you need to explicitly mark them as such, via Class->meta->add_method(foo => \E\\\&foo\)/, + "imported 'method' isn't seen" + ); + Class->meta->add_method(foo => \&foo); + ::is( + ::exception { with 'Foo' }, + undef, + "now it's a method" + ); + + ::like( + ::exception { with 'Bar' }, + qr/^\Q'Bar' requires the method 'bar' to be implemented by 'Class' at/, + "requirement isn't imported, so don't give the extra info in the error" + ); +} + +does_ok('Class', 'Foo'); + +done_testing; diff --git a/t/roles/meta_role.t b/t/roles/meta_role.t new file mode 100644 index 0000000..284d28b --- /dev/null +++ b/t/roles/meta_role.t @@ -0,0 +1,111 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role; +use Moose::Util::TypeConstraints (); + +{ + package FooRole; + + our $VERSION = '0.01'; + + sub foo { 'FooRole::foo' } +} + +my $foo_role = Moose::Meta::Role->initialize('FooRole'); +isa_ok($foo_role, 'Moose::Meta::Role'); +isa_ok($foo_role, 'Class::MOP::Module'); + +is($foo_role->name, 'FooRole', '... got the right name of FooRole'); +is($foo_role->version, '0.01', '... got the right version of FooRole'); + +# methods ... + +ok($foo_role->has_method('foo'), '... FooRole has the foo method'); +is($foo_role->get_method('foo')->body, \&FooRole::foo, '... FooRole got the foo method'); + +isa_ok($foo_role->get_method('foo'), 'Moose::Meta::Role::Method'); + +is_deeply( + [ $foo_role->get_method_list() ], + [ 'foo' ], + '... got the right method list'); + +# attributes ... + +is_deeply( + [ $foo_role->get_attribute_list() ], + [], + '... got the right attribute list'); + +ok(!$foo_role->has_attribute('bar'), '... FooRole does not have the bar attribute'); + +is( exception { + $foo_role->add_attribute('bar' => (is => 'rw', isa => 'Foo')); +}, undef, '... added the bar attribute okay' ); + +is_deeply( + [ $foo_role->get_attribute_list() ], + [ 'bar' ], + '... got the right attribute list'); + +ok($foo_role->has_attribute('bar'), '... FooRole does have the bar attribute'); + +my $bar = $foo_role->get_attribute('bar'); +is_deeply( $bar->original_options, { is => 'rw', isa => 'Foo' }, + 'original options for bar attribute' ); +my $bar_for_class = $bar->attribute_for_class('Moose::Meta::Attribute'); +is( + $bar_for_class->type_constraint, + Moose::Util::TypeConstraints::class_type('Foo'), + 'bar has a Foo class type' +); + +is( exception { + $foo_role->add_attribute('baz' => (is => 'ro')); +}, undef, '... added the baz attribute okay' ); + +is_deeply( + [ sort $foo_role->get_attribute_list() ], + [ 'bar', 'baz' ], + '... got the right attribute list'); + +ok($foo_role->has_attribute('baz'), '... FooRole does have the baz attribute'); + +my $baz = $foo_role->get_attribute('baz'); +is_deeply( $baz->original_options, { is => 'ro' }, + 'original options for baz attribute' ); + +is( exception { + $foo_role->remove_attribute('bar'); +}, undef, '... removed the bar attribute okay' ); + +is_deeply( + [ $foo_role->get_attribute_list() ], + [ 'baz' ], + '... got the right attribute list'); + +ok(!$foo_role->has_attribute('bar'), '... FooRole does not have the bar attribute'); +ok($foo_role->has_attribute('baz'), '... FooRole does still have the baz attribute'); + +# method modifiers + +ok(!$foo_role->has_before_method_modifiers('boo'), '... no boo:before modifier'); + +my $method = sub { "FooRole::boo:before" }; +is( exception { + $foo_role->add_before_method_modifier('boo' => $method); +}, undef, '... added a method modifier okay' ); + +ok($foo_role->has_before_method_modifiers('boo'), '... now we have a boo:before modifier'); +is(($foo_role->get_before_method_modifiers('boo'))[0], $method, '... got the right method back'); + +is_deeply( + [ $foo_role->get_method_modifier_list('before') ], + [ 'boo' ], + '... got the right list of before method modifiers'); + +done_testing; diff --git a/t/roles/method_aliasing_in_composition.t b/t/roles/method_aliasing_in_composition.t new file mode 100644 index 0000000..c94fad9 --- /dev/null +++ b/t/roles/method_aliasing_in_composition.t @@ -0,0 +1,206 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package My::Role; + use Moose::Role; + + sub foo { 'Foo::foo' } + sub bar { 'Foo::bar' } + sub baz { 'Foo::baz' } + + requires 'role_bar'; + + package My::Class; + use Moose; + + ::is( ::exception { + with 'My::Role' => { -alias => { bar => 'role_bar' } }; + }, undef, '... this succeeds' ); + + package My::Class::Failure; + use Moose; + + ::like( ::exception { + with 'My::Role' => { -alias => { bar => 'role_bar' } }; + }, qr/Cannot create a method alias if a local method of the same name exists/, '... this succeeds' ); + + sub role_bar { 'FAIL' } +} + +ok(My::Class->meta->has_method($_), "we have a $_ method") for qw(foo baz bar role_bar); + +{ + package My::OtherRole; + use Moose::Role; + + ::is( ::exception { + with 'My::Role' => { -alias => { bar => 'role_bar' } }; + }, undef, '... this succeeds' ); + + sub bar { 'My::OtherRole::bar' } + + package My::OtherRole::Failure; + use Moose::Role; + + ::like( ::exception { + with 'My::Role' => { -alias => { bar => 'role_bar' } }; + }, qr/Cannot create a method alias if a local method of the same name exists/, '... cannot alias to a name that exists' ); + + sub role_bar { 'FAIL' } +} + +ok(My::OtherRole->meta->has_method($_), "we have a $_ method") for qw(foo baz role_bar); +ok(!My::OtherRole->meta->requires_method('bar'), '... and the &bar method is not required'); +ok(!My::OtherRole->meta->requires_method('role_bar'), '... and the &role_bar method is not required'); + +{ + package My::AliasingRole; + use Moose::Role; + + ::is( ::exception { + with 'My::Role' => { -alias => { bar => 'role_bar' } }; + }, undef, '... this succeeds' ); +} + +ok(My::AliasingRole->meta->has_method($_), "we have a $_ method") for qw(foo baz role_bar); +ok(!My::AliasingRole->meta->requires_method('bar'), '... and the &bar method is not required'); + +{ + package Foo::Role; + use Moose::Role; + + sub foo { 'Foo::Role::foo' } + + package Bar::Role; + use Moose::Role; + + sub foo { 'Bar::Role::foo' } + + package Baz::Role; + use Moose::Role; + + sub foo { 'Baz::Role::foo' } + + package My::Foo::Class; + use Moose; + + ::is( ::exception { + with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, + 'Bar::Role' => { -alias => { 'foo' => 'bar_foo' }, -excludes => 'foo' }, + 'Baz::Role'; + }, undef, '... composed our roles correctly' ); + + package My::Foo::Class::Broken; + use Moose; + + ::like( ::exception { + with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, + 'Bar::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, + 'Baz::Role'; + }, qr/Due to a method name conflict in roles 'Bar::Role' and 'Foo::Role', the method 'foo_foo' must be implemented or excluded by 'My::Foo::Class::Broken'/, '... composed our roles correctly' ); +} + +{ + my $foo = My::Foo::Class->new; + isa_ok($foo, 'My::Foo::Class'); + can_ok($foo, $_) for qw/foo foo_foo bar_foo/; + is($foo->foo, 'Baz::Role::foo', '... got the right method'); + is($foo->foo_foo, 'Foo::Role::foo', '... got the right method'); + is($foo->bar_foo, 'Bar::Role::foo', '... got the right method'); +} + +{ + package My::Foo::Role; + use Moose::Role; + + ::is( ::exception { + with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, + 'Bar::Role' => { -alias => { 'foo' => 'bar_foo' }, -excludes => 'foo' }, + 'Baz::Role'; + }, undef, '... composed our roles correctly' ); +} + +ok(My::Foo::Role->meta->has_method($_), "we have a $_ method") for qw/foo foo_foo bar_foo/;; +ok(!My::Foo::Role->meta->requires_method('foo'), '... and the &foo method is not required'); + + +{ + package My::Foo::Role::Other; + use Moose::Role; + + ::is( ::exception { + with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, + 'Bar::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, + 'Baz::Role'; + }, undef, '... composed our roles correctly' ); +} + +ok(!My::Foo::Role::Other->meta->has_method('foo_foo'), "we dont have a foo_foo method"); +ok(My::Foo::Role::Other->meta->requires_method('foo_foo'), '... and the &foo method is required'); + +{ + package My::Foo::AliasOnly; + use Moose; + + ::is( ::exception { + with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' } }, + }, undef, '... composed our roles correctly' ); +} + +ok(My::Foo::AliasOnly->meta->has_method('foo'), 'we have a foo method'); +ok(My::Foo::AliasOnly->meta->has_method('foo_foo'), '.. and the aliased foo_foo method'); + +{ + package Role::Foo; + use Moose::Role; + + sub x1 {} + sub y1 {} +} + +{ + package Role::Bar; + use Moose::Role; + + ::is( ::exception { + with 'Role::Foo' => { + -alias => { x1 => 'foo_x1' }, + -excludes => ['y1'], + }; + }, undef, 'Compose Role::Foo into Role::Bar with alias and exclude' ); + + sub x1 {} + sub y1 {} +} + +{ + my $bar = Role::Bar->meta; + ok( $bar->has_method($_), "has $_ method" ) + for qw( x1 y1 foo_x1 ); +} + +{ + package Role::Baz; + use Moose::Role; + + ::is( ::exception { + with 'Role::Foo' => { + -alias => { x1 => 'foo_x1' }, + -excludes => ['y1'], + }; + }, undef, 'Compose Role::Foo into Role::Baz with alias and exclude' ); +} + +{ + my $baz = Role::Baz->meta; + ok( $baz->has_method($_), "has $_ method" ) + for qw( x1 foo_x1 ); + ok( ! $baz->has_method('y1'), 'Role::Baz has no y1 method' ); +} + +done_testing; diff --git a/t/roles/method_exclusion_in_composition.t b/t/roles/method_exclusion_in_composition.t new file mode 100644 index 0000000..ce7e233 --- /dev/null +++ b/t/roles/method_exclusion_in_composition.t @@ -0,0 +1,110 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package My::Role; + use Moose::Role; + + sub foo { 'Foo::foo' } + sub bar { 'Foo::bar' } + sub baz { 'Foo::baz' } + + package My::Class; + use Moose; + + with 'My::Role' => { -excludes => 'bar' }; +} + +ok(My::Class->meta->has_method($_), "we have a $_ method") for qw(foo baz); +ok(!My::Class->meta->has_method('bar'), '... but we excluded bar'); + +{ + package My::OtherRole; + use Moose::Role; + + with 'My::Role' => { -excludes => 'foo' }; + + sub foo { 'My::OtherRole::foo' } + sub bar { 'My::OtherRole::bar' } +} + +ok(My::OtherRole->meta->has_method($_), "we have a $_ method") for qw(foo bar baz); + +ok(!My::OtherRole->meta->requires_method('foo'), '... and the &foo method is not required'); +ok(!My::OtherRole->meta->requires_method('bar'), '... and the &bar method is not required'); + +{ + package Foo::Role; + use Moose::Role; + + sub foo { 'Foo::Role::foo' } + + package Bar::Role; + use Moose::Role; + + sub foo { 'Bar::Role::foo' } + + package Baz::Role; + use Moose::Role; + + sub foo { 'Baz::Role::foo' } + + package My::Foo::Class; + use Moose; + + ::is( ::exception { + with 'Foo::Role' => { -excludes => 'foo' }, + 'Bar::Role' => { -excludes => 'foo' }, + 'Baz::Role'; + }, undef, '... composed our roles correctly' ); + + package My::Foo::Class::Broken; + use Moose; + + ::like( ::exception { + with 'Foo::Role', + 'Bar::Role' => { -excludes => 'foo' }, + 'Baz::Role'; + }, qr/Due to a method name conflict in roles 'Baz::Role' and 'Foo::Role', the method 'foo' must be implemented or excluded by 'My::Foo::Class::Broken'/, '... composed our roles correctly' ); +} + +{ + my $foo = My::Foo::Class->new; + isa_ok($foo, 'My::Foo::Class'); + can_ok($foo, 'foo'); + is($foo->foo, 'Baz::Role::foo', '... got the right method'); +} + +{ + package My::Foo::Role; + use Moose::Role; + + ::is( ::exception { + with 'Foo::Role' => { -excludes => 'foo' }, + 'Bar::Role' => { -excludes => 'foo' }, + 'Baz::Role'; + }, undef, '... composed our roles correctly' ); +} + +ok(My::Foo::Role->meta->has_method('foo'), "we have a foo method"); +ok(!My::Foo::Role->meta->requires_method('foo'), '... and the &foo method is not required'); + +{ + package My::Foo::Role::Other; + use Moose::Role; + + ::is( ::exception { + with 'Foo::Role', + 'Bar::Role' => { -excludes => 'foo' }, + 'Baz::Role'; + }, undef, '... composed our roles correctly' ); +} + +ok(!My::Foo::Role::Other->meta->has_method('foo'), "we dont have a foo method"); +ok(My::Foo::Role::Other->meta->requires_method('foo'), '... and the &foo method is required'); + +done_testing; diff --git a/t/roles/method_modifiers.t b/t/roles/method_modifiers.t new file mode 100644 index 0000000..b3076a6 --- /dev/null +++ b/t/roles/method_modifiers.t @@ -0,0 +1,89 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +my $FooRole; +{ + package Foo::Role; + use Moose::Role; + after foo => sub { $FooRole++ }; +} + +{ + package Foo; + use Moose; + with 'Foo::Role'; + sub foo { } +} + +Foo->foo; +is($FooRole, 1, "modifier called"); + +my $BarRole; +{ + package Bar::Role; + use Moose::Role; + after ['foo', 'bar'] => sub { $BarRole++ }; +} + +{ + package Bar; + use Moose; + with 'Bar::Role'; + sub foo { } + sub bar { } +} + +Bar->foo; +is($BarRole, 1, "modifier called"); +Bar->bar; +is($BarRole, 2, "modifier called"); + +my $BazRole; +{ + package Baz::Role; + use Moose::Role; + after 'foo', 'bar' => sub { $BazRole++ }; +} + +{ + package Baz; + use Moose; + with 'Baz::Role'; + sub foo { } + sub bar { } +} + +Baz->foo; +is($BazRole, 1, "modifier called"); +Baz->bar; +is($BazRole, 2, "modifier called"); + +my $QuuxRole; +{ + package Quux::Role; + use Moose::Role; + { our $TODO; local $TODO = "can't handle regexes yet"; + ::is( ::exception { + after qr/foo|bar/ => sub { $QuuxRole++ } + }, undef ); + } +} + +{ + package Quux; + use Moose; + with 'Quux::Role'; + sub foo { } + sub bar { } +} + +{ local $TODO = "can't handle regexes yet"; +Quux->foo; +is($QuuxRole, 1, "modifier called"); +Quux->bar; +is($QuuxRole, 2, "modifier called"); +} + +done_testing; diff --git a/t/roles/methods.t b/t/roles/methods.t new file mode 100644 index 0000000..b401d1c --- /dev/null +++ b/t/roles/methods.t @@ -0,0 +1,46 @@ +use strict; +use warnings; + +use Test::More; +use Moose::Role (); + +my $test1 = Moose::Meta::Role->create_anon_role; +$test1->add_method( 'foo1', sub { } ); + +ok( $test1->has_method('foo1'), 'anon role has a foo1 method' ); + +my $t1_am = $test1->get_method('foo1')->associated_metaclass; + +ok( $t1_am, 'associated_metaclass is defined' ); + +isa_ok( + $t1_am, 'Moose::Meta::Role', + 'associated_metaclass is correct class' +); + +like( $t1_am->name(), qr/::__ANON__::/, + 'associated_metaclass->name looks like an anonymous class' ); + +{ + package Test2; + + use Moose::Role; + + sub foo2 { } +} + +ok( Test2->meta->has_method('foo2'), 'Test2 role has a foo2 method' ); + +my $t2_am = Test2->meta->get_method('foo2')->associated_metaclass; + +ok( $t2_am, 'associated_metaclass is defined' ); + +isa_ok( + $t2_am, 'Moose::Meta::Role', + 'associated_metaclass is correct class' +); + +is( $t2_am->name(), 'Test2', + 'associated_metaclass->name is Test2' ); + +done_testing; diff --git a/t/roles/more_alias_and_exclude.t b/t/roles/more_alias_and_exclude.t new file mode 100644 index 0000000..18b0f18 --- /dev/null +++ b/t/roles/more_alias_and_exclude.t @@ -0,0 +1,88 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose::Role; + + sub foo { 'Foo::foo' } + sub bar { 'Foo::bar' } + sub baz { 'Foo::baz' } + sub gorch { 'Foo::gorch' } + + package Bar; + use Moose::Role; + + sub foo { 'Bar::foo' } + sub bar { 'Bar::bar' } + sub baz { 'Bar::baz' } + sub gorch { 'Bar::gorch' } + + package Baz; + use Moose::Role; + + sub foo { 'Baz::foo' } + sub bar { 'Baz::bar' } + sub baz { 'Baz::baz' } + sub gorch { 'Baz::gorch' } + + package Gorch; + use Moose::Role; + + sub foo { 'Gorch::foo' } + sub bar { 'Gorch::bar' } + sub baz { 'Gorch::baz' } + sub gorch { 'Gorch::gorch' } +} + +{ + package My::Class; + use Moose; + + ::is( ::exception { + with 'Foo' => { -excludes => [qw/bar baz gorch/], -alias => { gorch => 'foo_gorch' } }, + 'Bar' => { -excludes => [qw/foo baz gorch/] }, + 'Baz' => { -excludes => [qw/foo bar gorch/], -alias => { foo => 'baz_foo', bar => 'baz_bar' } }, + 'Gorch' => { -excludes => [qw/foo bar baz/] }; + }, undef, '... everything works out all right' ); +} + +my $c = My::Class->new; +isa_ok($c, 'My::Class'); + +is($c->foo, 'Foo::foo', '... got the right method'); +is($c->bar, 'Bar::bar', '... got the right method'); +is($c->baz, 'Baz::baz', '... got the right method'); +is($c->gorch, 'Gorch::gorch', '... got the right method'); + +is($c->foo_gorch, 'Foo::gorch', '... got the right method'); +is($c->baz_foo, 'Baz::foo', '... got the right method'); +is($c->baz_bar, 'Baz::bar', '... got the right method'); + +{ + package Splunk; + + use Moose::Role; + + sub baz { 'Splunk::baz' } + sub gorch { 'Splunk::gorch' } + + ::is(::exception { with 'Foo' }, undef, 'role to role application works'); + + package My::Class2; + + use Moose; + + ::is(::exception { with 'Splunk' }, undef, 'and the role can be consumed'); +} + +is(My::Class2->foo, 'Foo::foo', '... got the right method'); +is(My::Class2->bar, 'Foo::bar', '... got the right method'); +is(My::Class2->baz, 'Splunk::baz', '... got the right method'); +is(My::Class2->gorch, 'Splunk::gorch', '... got the right method'); + +done_testing; diff --git a/t/roles/more_role_edge_cases.t b/t/roles/more_role_edge_cases.t new file mode 100644 index 0000000..870c09f --- /dev/null +++ b/t/roles/more_role_edge_cases.t @@ -0,0 +1,255 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + # NOTE: + # this tests that repeated role + # composition will not cause + # a conflict between two methods + # which are actually the same anyway + + { + package RootA; + use Moose::Role; + + sub foo { "RootA::foo" } + + package SubAA; + use Moose::Role; + + with "RootA"; + + sub bar { "SubAA::bar" } + + package SubAB; + use Moose; + + ::is( ::exception { + with "SubAA", "RootA"; + }, undef, '... role was composed as expected' ); + } + + ok( SubAB->does("SubAA"), "does SubAA"); + ok( SubAB->does("RootA"), "does RootA"); + + isa_ok( my $i = SubAB->new, "SubAB" ); + + can_ok( $i, "bar" ); + is( $i->bar, "SubAA::bar", "... got thr right bar rv" ); + + can_ok( $i, "foo" ); + my $foo_rv; + is( exception { + $foo_rv = $i->foo; + }, undef, '... called foo successfully' ); + is($foo_rv, "RootA::foo", "... got the right foo rv"); +} + +{ + # NOTE: + # this edge cases shows the application of + # an after modifier over a method which + # was added during role composotion. + # The way this will work is as follows: + # role SubBA will consume RootB and + # get a local copy of RootB::foo, it + # will also store a deferred after modifier + # to be applied to whatever class SubBA is + # composed into. + # When class SubBB comsumed role SubBA, the + # RootB::foo method is added to SubBB, then + # the deferred after modifier from SubBA is + # applied to it. + # It is important to note that the application + # of the after modifier does not happen until + # role SubBA is composed into SubAA. + + { + package RootB; + use Moose::Role; + + sub foo { "RootB::foo" } + + package SubBA; + use Moose::Role; + + with "RootB"; + + has counter => ( + isa => "Num", + is => "rw", + default => 0, + ); + + after foo => sub { + $_[0]->counter( $_[0]->counter + 1 ); + }; + + package SubBB; + use Moose; + + ::is( ::exception { + with "SubBA"; + }, undef, '... composed the role successfully' ); + } + + ok( SubBB->does("SubBA"), "BB does SubBA" ); + ok( SubBB->does("RootB"), "BB does RootB" ); + + isa_ok( my $i = SubBB->new, "SubBB" ); + + can_ok( $i, "foo" ); + + my $foo_rv; + is( exception { + $foo_rv = $i->foo + }, undef, '... called foo successfully' ); + is( $foo_rv, "RootB::foo", "foo rv" ); + is( $i->counter, 1, "after hook called" ); + + is( exception { $i->foo }, undef, '... called foo successfully (again)' ); + is( $i->counter, 2, "after hook called (again)" ); + + ok(SubBA->meta->has_method('foo'), '... this has the foo method'); + #my $subba_foo_rv; + #lives_ok { + # $subba_foo_rv = SubBA::foo(); + #} '... called the sub as a function correctly'; + #is($subba_foo_rv, 'RootB::foo', '... the SubBA->foo is still the RootB version'); +} + +{ + # NOTE: + # this checks that an override method + # does not try to trample over a locally + # composed in method. In this case the + # RootC::foo, which is composed into + # SubCA cannot be trampled with an + # override of 'foo' + { + package RootC; + use Moose::Role; + + sub foo { "RootC::foo" } + + package SubCA; + use Moose::Role; + + with "RootC"; + + ::isnt( ::exception { + override foo => sub { "overridden" }; + }, undef, '... cannot compose an override over a local method' ); + } +} + +# NOTE: +# need to talk to Yuval about the motivation behind +# this test, I am not sure we are testing anything +# useful here (although more tests cant hurt) + +{ + use List::Util qw/shuffle/; + + { + package Abstract; + use Moose::Role; + + requires "method"; + requires "other"; + + sub another { "abstract" } + + package ConcreteA; + use Moose::Role; + with "Abstract"; + + sub other { "concrete a" } + + package ConcreteB; + use Moose::Role; + with "Abstract"; + + sub method { "concrete b" } + + package ConcreteC; + use Moose::Role; + with "ConcreteA"; + + # NOTE: + # this was originally override, but + # that wont work (see above set of tests) + # so I switched it to around. + # However, this may not be testing the + # same thing that was originally intended + around other => sub { + return ( (shift)->() . " + c" ); + }; + + package SimpleClassWithSome; + use Moose; + + eval { with ::shuffle qw/ConcreteA ConcreteB/ }; + ::ok( !$@, "simple composition without abstract" ) || ::diag $@; + + package SimpleClassWithAll; + use Moose; + + eval { with ::shuffle qw/ConcreteA ConcreteB Abstract/ }; + ::ok( !$@, "simple composition with abstract" ) || ::diag $@; + } + + foreach my $class (qw/SimpleClassWithSome SimpleClassWithAll/) { + foreach my $role (qw/Abstract ConcreteA ConcreteB/) { + ok( $class->does($role), "$class does $role"); + } + + foreach my $method (qw/method other another/) { + can_ok( $class, $method ); + } + + is( eval { $class->another }, "abstract", "provided by abstract" ); + is( eval { $class->other }, "concrete a", "provided by concrete a" ); + is( eval { $class->method }, "concrete b", "provided by concrete b" ); + } + + { + package ClassWithSome; + use Moose; + + eval { with ::shuffle qw/ConcreteC ConcreteB/ }; + ::ok( !$@, "composition without abstract" ) || ::diag $@; + + package ClassWithAll; + use Moose; + + eval { with ::shuffle qw/ConcreteC Abstract ConcreteB/ }; + ::ok( !$@, "composition with abstract" ) || ::diag $@; + + package ClassWithEverything; + use Moose; + + eval { with ::shuffle qw/ConcreteC Abstract ConcreteA ConcreteB/ }; # this should clash + ::ok( !$@, "can compose ConcreteA and ConcreteC together" ); + } + + foreach my $class (qw/ClassWithSome ClassWithAll ClassWithEverything/) { + foreach my $role (qw/Abstract ConcreteA ConcreteB ConcreteC/) { + ok( $class->does($role), "$class does $role"); + } + + foreach my $method (qw/method other another/) { + can_ok( $class, $method ); + } + + is( eval { $class->another }, "abstract", "provided by abstract" ); + is( eval { $class->other }, "concrete a + c", "provided by concrete c + a" ); + is( eval { $class->method }, "concrete b", "provided by concrete b" ); + } +} + +done_testing; diff --git a/t/roles/new_meta_role.t b/t/roles/new_meta_role.t new file mode 100644 index 0000000..964c3eb --- /dev/null +++ b/t/roles/new_meta_role.t @@ -0,0 +1,18 @@ +use strict; +use warnings; +use Test::More; + +do { + package My::Meta::Role; + use Moose; + BEGIN { extends 'Moose::Meta::Role' }; +}; + +do { + package My::Role; + use Moose::Role -metaclass => 'My::Meta::Role'; +}; + +is(My::Role->meta->meta->name, 'My::Meta::Role'); + +done_testing; diff --git a/t/roles/overloading_combine_to_class.t b/t/roles/overloading_combine_to_class.t new file mode 100644 index 0000000..e749248 --- /dev/null +++ b/t/roles/overloading_combine_to_class.t @@ -0,0 +1,33 @@ +use strict; +use warnings; + +use Test::More 0.96; +use Test::Warnings; +use overload (); + +use lib 't/lib'; + +use OverloadingTests; +use Overloading::CombiningClass; + +for my $role ( + qw( Overloading::RoleWithOverloads Overloading::RoleWithoutOverloads )) { + + ok( + Overloading::CombiningClass->DOES($role), + "Overloading::CombiningClass does $role role" + ); +} + +OverloadingTests::test_overloading_for_package($_) for qw( + Overloading::RoleWithOverloads + Overloading::CombiningClass +); + +OverloadingTests::test_no_overloading_for_package( + 'Overloading::RoleWithoutOverloads'); + +OverloadingTests::test_overloading_for_package( + 'Overloading::CombiningClass'); + +done_testing(); diff --git a/t/roles/overloading_combine_to_instance.t b/t/roles/overloading_combine_to_instance.t new file mode 100644 index 0000000..73c4ebf --- /dev/null +++ b/t/roles/overloading_combine_to_instance.t @@ -0,0 +1,39 @@ +use strict; +use warnings; + +use Test::More 0.88; +use Test::Warnings; +use overload (); + +use lib 't/lib'; + +use OverloadingTests; +use Overloading::RoleWithOverloads; +use Overloading::RoleWithoutOverloads; + +{ + package MyClass; + use Moose; +} + +my $object = MyClass->new; + +Moose::Meta::Role->combine( + [ 'Overloading::RoleWithOverloads' => undef ], + [ 'Overloading::RoleWithoutOverloads' => undef ], +)->apply($object); + +OverloadingTests::test_overloading_for_package($_) + for 'Overloading::RoleWithOverloads', ref $object; + +OverloadingTests::test_no_overloading_for_package( + 'Overloading::RoleWithoutOverloads'); + +$object->message('foo'); + +OverloadingTests::test_overloading_for_object( + $object, + 'object with Overloading::RoleWithOverloads and Overloading::RoleWithoutOverloads combined and applied to instance' +); + +done_testing(); diff --git a/t/roles/overloading_combine_to_role.t b/t/roles/overloading_combine_to_role.t new file mode 100644 index 0000000..72eb9c4 --- /dev/null +++ b/t/roles/overloading_combine_to_role.t @@ -0,0 +1,33 @@ +use strict; +use warnings; + +use Test::More 0.88; +use Test::Warnings; +use overload (); + +use lib 't/lib'; + +use OverloadingTests; +use Overloading::ClassWithCombiningRole; + +for my $role ( + qw( Overloading::RoleWithOverloads Overloading::RoleWithoutOverloads )) { + + ok( + Overloading::ClassWithCombiningRole->DOES($role), + "Overloading::ClassWithCombiningRole does $role role" + ); +} + +OverloadingTests::test_overloading_for_package($_) for qw( + Overloading::RoleWithOverloads + Overloading::ClassWithCombiningRole +); + +OverloadingTests::test_no_overloading_for_package( + 'Overloading::RoleWithoutOverloads'); + +OverloadingTests::test_overloading_for_package( + 'Overloading::ClassWithCombiningRole'); + +done_testing(); diff --git a/t/roles/overloading_composition_errors.t b/t/roles/overloading_composition_errors.t new file mode 100644 index 0000000..75e79ca --- /dev/null +++ b/t/roles/overloading_composition_errors.t @@ -0,0 +1,156 @@ +use strict; +use warnings; + +use Test::More 0.88; +use Test::Fatal; +use Test::Warnings; + +use lib 't/lib'; + +{ + package Role::HasFallback; + use Moose::Role; + + use overload + q{""} => '_stringify', + fallback => 1; + + sub _stringify { __PACKAGE__ } +} + +{ + package Role::NoFallback; + use Moose::Role; + + use overload + '0+' => '_numify', + fallback => 0; + + sub _numify { 42 } +} + +{ + package Class1; + use Moose; + ::like( + ::exception { with qw( Role::HasFallback Role::NoFallback ) }, + qr/\QWe have encountered an overloading conflict for the fallback during composition. This is a fatal error./, + 'exception from fallback conflict during role summation' + ); +} + +{ + package Role::NoOverloading; + use Moose::Role; + + sub foo { 42 } +} + +{ + package Class2; + use Moose; + ::like( + ::exception { with qw( Role::HasFallback Role::NoFallback Role::NoOverloading ) }, + qr/\QWe have encountered an overloading conflict for the fallback during composition. This is a fatal error./, + 'exception from fallback conflict during role summation including role without overloading' + ); +} + +{ + package Role::StringifiesViaSubref1; + use Moose::Role; + + use overload q{""} => sub { 'foo' }; +} + +{ + package Role::StringifiesViaSubref2; + use Moose::Role; + + use overload q{""} => sub { 'bar' }; +} + +{ + package Class3; + use Moose; + ::like( + ::exception { with qw( Role::StringifiesViaSubref1 Role::StringifiesViaSubref2 ) }, + qr/\QThe two roles both overload the '""' operator. This is a fatal error./, + 'exception when two roles with different subref overloading conflict during role summation' + ); +} + +{ + package Class4; + use Moose; + ::like( + ::exception { with qw( Role::StringifiesViaSubref1 Role::StringifiesViaSubref2 Role::NoOverloading ) }, + qr/\QThe two roles both overload the '""' operator. This is a fatal error./, + 'exception when two roles with different subref overloading conflict during role summation including role without overloading' + ); +} + +{ + package Role::StringifiesViaMethod1; + use Moose::Role; + + use overload q{""} => '_stringify1'; + sub _stringify1 { 'foo' } +} + +{ + package Role::StringifiesViaMethod2; + use Moose::Role; + + use overload q{""} => '_stringify2'; + sub _stringify2 { 'foo' } +} + +{ + package Class5; + use Moose; + ::like( + ::exception { with qw( Role::StringifiesViaMethod1 Role::StringifiesViaMethod2 ) }, + qr/\QThe two roles both overload the '""' operator. This is a fatal error./, + 'exception when two roles with different method overloading conflict during role summation' + ); +} + +{ + package Class6; + use Moose; + ::like( + ::exception { with qw( Role::StringifiesViaMethod1 Role::StringifiesViaMethod2 Role::NoOverloading ) }, + qr/\QThe two roles both overload the '""' operator. This is a fatal error./, + 'exception when two roles with different method overloading conflict during role summation including role without overloading' + ); +} + +{ + { + package R1; + use Moose::Role; + + use overload '&{}' => 'as_code'; + + sub as_code { } + } + + { + package R2; + use Moose::Role; + with 'R1'; + } + + { + package C1; + use Moose; + ::is( + ::exception { with 'R1', 'R2' }, + undef, + 'no conflict when class consumes multiple roles with the same overloading' + ); + } +} + +done_testing(); diff --git a/t/roles/overloading_remove_attributes_bug.t b/t/roles/overloading_remove_attributes_bug.t new file mode 100644 index 0000000..15f6cc9 --- /dev/null +++ b/t/roles/overloading_remove_attributes_bug.t @@ -0,0 +1,36 @@ +use strict; +use warnings; + +use Test::More 0.88; +use Test::Warnings; + +use lib 't/lib'; + +use OverloadingTests; + +{ + package MyRole; + use Moose::Role; + + has foo => ( is => 'ro' ); + + # Note ordering here. If metaclass reinitialization nukes attributes, this + # breaks. + with 'Overloading::RoleWithOverloads'; +} + +{ + package MyClass; + use Moose; + + with 'MyRole'; +} + +my $object = MyClass->new( foo => 21, message => 'foo' ); + +OverloadingTests::test_overloading_for_object( $object, 'MyClass object' ); + +is( $object->foo(), 21, + 'foo attribute in MyClass is still present (from MyRole)' ); + +done_testing(); diff --git a/t/roles/overloading_to_class.t b/t/roles/overloading_to_class.t new file mode 100644 index 0000000..16972a7 --- /dev/null +++ b/t/roles/overloading_to_class.t @@ -0,0 +1,66 @@ +use strict; +use warnings; + +use Test::More 0.88; +use Test::Warnings; +use overload (); + +use lib 't/lib'; + +use OverloadingTests; +use Overloading::ClassWithOneRole; + +ok( + Overloading::ClassWithOneRole->DOES('Overloading::RoleWithOverloads'), + 'Overloading::ClassWithOneRole consumed Overloading::RoleWithOverloads', +); + +OverloadingTests::test_overloading_for_package($_) for qw( + Overloading::RoleWithOverloads + Overloading::ClassWithOneRole +); + +OverloadingTests::test_overloading_for_object( + 'Overloading::ClassWithOneRole'); + +{ + package Role1; + use Moose::Role; + use overload + q{""} => '_role1_stringify', + q{+} => '_role1_plus', + fallback => 0; + sub _role1_stringify {__PACKAGE__} + sub _role1_plus {42} +} + +{ + package Class1; + use Moose; + use overload + q{""} => '_class1_stringify', + fallback => 1; + with 'Role1'; + sub _class1_stringify {__PACKAGE__} +} + +is( + Class1->meta->get_overload_fallback_value, + 1, + 'fallback setting for class overrides setting in composed role' +); + +is( + Class1->new . q{}, + 'Class1', + 'overload method for class overrides method in composed role' +); + +my $overload = Class1->meta->get_overloaded_operator(q{+}); +is( + $overload->original_overload->associated_metaclass->name, + 'Role1', + '+ overloading for Class1 originally came from Role1' +); + +done_testing(); diff --git a/t/roles/overloading_to_instance.t b/t/roles/overloading_to_instance.t new file mode 100644 index 0000000..7edbc22 --- /dev/null +++ b/t/roles/overloading_to_instance.t @@ -0,0 +1,31 @@ +use strict; +use warnings; + +use Test::More 0.88; +use Test::Warnings; +use overload (); + +use lib 't/lib'; + +use OverloadingTests; +use Overloading::RoleWithOverloads; + +{ + package MyClass; + use Moose; +} + +my $object = MyClass->new; +Overloading::RoleWithOverloads->meta->apply($object); + +OverloadingTests::test_overloading_for_package($_) + for 'Overloading::RoleWithOverloads', ref $object; + +$object->message('foo'); + +OverloadingTests::test_overloading_for_object( + $object, + 'object with Overloading::RoleWithOverloads applied to instance' +); + +done_testing(); diff --git a/t/roles/overloading_to_role.t b/t/roles/overloading_to_role.t new file mode 100644 index 0000000..f0fa326 --- /dev/null +++ b/t/roles/overloading_to_role.t @@ -0,0 +1,58 @@ +use strict; +use warnings; + +use Test::More 0.88; +use Test::Warnings; +use overload (); + +use lib 't/lib'; + +use OverloadingTests; +use Overloading::ClassConsumesRoleConsumesOverloads; + +for my $role ( + qw( Overloading::RoleWithOverloads Overloading::RoleConsumesOverloads )) { + + ok( + Overloading::ClassConsumesRoleConsumesOverloads->DOES($role), + "Overloading::ClassConsumesRoleConsumesOverloads does $role role" + ); +} + +OverloadingTests::test_overloading_for_package($_) for qw( + Overloading::RoleWithOverloads + Overloading::RoleConsumesOverloads + Overloading::ClassConsumesRoleConsumesOverloads +); + +OverloadingTests::test_overloading_for_object( + 'Overloading::ClassConsumesRoleConsumesOverloads'); + +# These tests failed on 5.18+ in MXRWO - the key issue was the lack of a +# "fallback" key being passed to overload.pm +{ + package MyRole1; + use Moose::Role; + use overload q{""} => '_stringify'; + sub _stringify {__PACKAGE__} +} + +{ + package MyRole2; + use Moose::Role; + with 'MyRole1'; +} + +{ + package Class1; + use Moose; + with 'MyRole2'; +} + +is( + Class1->new . q{}, + 'MyRole1', + 'stringification overloading is passed through all roles' +); + +done_testing(); diff --git a/t/roles/overriding.t b/t/roles/overriding.t new file mode 100644 index 0000000..dbaa443 --- /dev/null +++ b/t/roles/overriding.t @@ -0,0 +1,214 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + # test no conflicts here + package Role::A; + use Moose::Role; + + sub bar { 'Role::A::bar' } + + package Role::B; + use Moose::Role; + + sub xxy { 'Role::B::xxy' } + + package Role::C; + use Moose::Role; + + ::is( ::exception { + with qw(Role::A Role::B); # no conflict here + }, undef, "define role C" ); + + sub foo { 'Role::C::foo' } + sub zot { 'Role::C::zot' } + + package Class::A; + use Moose; + + ::is( ::exception { + with qw(Role::C); + }, undef, "define class A" ); + + sub zot { 'Class::A::zot' } +} + +can_ok( Class::A->new, qw(foo bar xxy zot) ); + +is( Class::A->new->foo, "Role::C::foo", "... got the right foo method" ); +is( Class::A->new->zot, "Class::A::zot", "... got the right zot method" ); +is( Class::A->new->bar, "Role::A::bar", "... got the right bar method" ); +is( Class::A->new->xxy, "Role::B::xxy", "... got the right xxy method" ); + +{ + # check that when a role is added to another role + # that the consumer's method shadows just like for classes. + + package Role::A::Shadow; + use Moose::Role; + + with 'Role::A'; + + sub bar { 'Role::A::Shadow::bar' } + + package Class::A::Shadow; + use Moose; + + ::is( ::exception { + with 'Role::A::Shadow'; + }, undef, '... did fufill the requirement of &bar method' ); +} + +can_ok( Class::A::Shadow->new, qw(bar) ); + +is( Class::A::Shadow->new->bar, 'Role::A::Shadow::bar', "... got the right bar method" ); + +{ + # check that when two roles are composed, they conflict + # but the composing role can resolve that conflict + + package Role::D; + use Moose::Role; + + sub foo { 'Role::D::foo' } + sub bar { 'Role::D::bar' } + + package Role::E; + use Moose::Role; + + sub foo { 'Role::E::foo' } + sub xxy { 'Role::E::xxy' } + + package Role::F; + use Moose::Role; + + ::is( ::exception { + with qw(Role::D Role::E); # conflict between 'foo's here + }, undef, "define role Role::F" ); + + sub foo { 'Role::F::foo' } + sub zot { 'Role::F::zot' } + + package Class::B; + use Moose; + + ::is( ::exception { + with qw(Role::F); + }, undef, "define class Class::B" ); + + sub zot { 'Class::B::zot' } +} + +can_ok( Class::B->new, qw(foo bar xxy zot) ); + +is( Class::B->new->foo, "Role::F::foo", "... got the &foo method okay" ); +is( Class::B->new->zot, "Class::B::zot", "... got the &zot method okay" ); +is( Class::B->new->bar, "Role::D::bar", "... got the &bar method okay" ); +is( Class::B->new->xxy, "Role::E::xxy", "... got the &xxy method okay" ); + +ok(!Role::F->meta->requires_method('foo'), '... Role::F fufilled the &foo requirement'); + +{ + # check that a conflict can be resolved + # by a role, but also new ones can be + # created just as easily ... + + package Role::D::And::E::NoConflict; + use Moose::Role; + + ::is( ::exception { + with qw(Role::D Role::E); # conflict between 'foo's here + }, undef, "... define role Role::D::And::E::NoConflict" ); + + sub foo { 'Role::D::And::E::NoConflict::foo' } # this overrides ... + + sub xxy { 'Role::D::And::E::NoConflict::xxy' } # and so do these ... + sub bar { 'Role::D::And::E::NoConflict::bar' } + +} + +ok(!Role::D::And::E::NoConflict->meta->requires_method('foo'), '... Role::D::And::E::NoConflict fufilled the &foo requirement'); +ok(!Role::D::And::E::NoConflict->meta->requires_method('xxy'), '... Role::D::And::E::NoConflict fulfilled the &xxy requirement'); +ok(!Role::D::And::E::NoConflict->meta->requires_method('bar'), '... Role::D::And::E::NoConflict fulfilled the &bar requirement'); + +{ + # conflict propagation + + package Role::H; + use Moose::Role; + + sub foo { 'Role::H::foo' } + sub bar { 'Role::H::bar' } + + package Role::J; + use Moose::Role; + + sub foo { 'Role::J::foo' } + sub xxy { 'Role::J::xxy' } + + package Role::I; + use Moose::Role; + + ::is( ::exception { + with qw(Role::J Role::H); # conflict between 'foo's here + }, undef, "define role Role::I" ); + + sub zot { 'Role::I::zot' } + sub zzy { 'Role::I::zzy' } + + package Class::C; + use Moose; + + ::like( ::exception { + with qw(Role::I); + }, qr/Due to a method name conflict in roles 'Role::H' and 'Role::J', the method 'foo' must be implemented or excluded by 'Class::C'/, "defining class Class::C fails" ); + + sub zot { 'Class::C::zot' } + + package Class::E; + use Moose; + + ::is( ::exception { + with qw(Role::I); + }, undef, "resolved with method" ); + + sub foo { 'Class::E::foo' } + sub zot { 'Class::E::zot' } +} + +can_ok( Class::E->new, qw(foo bar xxy zot) ); + +is( Class::E->new->foo, "Class::E::foo", "... got the right &foo method" ); +is( Class::E->new->zot, "Class::E::zot", "... got the right &zot method" ); +is( Class::E->new->bar, "Role::H::bar", "... got the right &bar method" ); +is( Class::E->new->xxy, "Role::J::xxy", "... got the right &xxy method" ); + +ok(Role::I->meta->requires_method('foo'), '... Role::I still have the &foo requirement'); + +{ + is( exception { + package Class::D; + use Moose; + + has foo => ( default => __PACKAGE__ . "::foo", is => "rw" ); + + sub zot { 'Class::D::zot' } + + with qw(Role::I); + + }, undef, "resolved with attr" ); + + can_ok( Class::D->new, qw(foo bar xxy zot) ); + is( eval { Class::D->new->bar }, "Role::H::bar", "bar" ); + is( eval { Class::D->new->zzy }, "Role::I::zzy", "zzy" ); + + is( eval { Class::D->new->foo }, "Class::D::foo", "foo" ); + is( eval { Class::D->new->zot }, "Class::D::zot", "zot" ); + +} + +done_testing; diff --git a/t/roles/reinitialize_anon_role.t b/t/roles/reinitialize_anon_role.t new file mode 100644 index 0000000..2554f2e --- /dev/null +++ b/t/roles/reinitialize_anon_role.t @@ -0,0 +1,30 @@ +use strict; +use warnings; +use Test::More; + +{ + package Role::Metarole; + use Moose::Role; +} + +my ($role2); +{ + my $role1 = Moose::Meta::Role->create_anon_role( + methods => { + foo => sub { }, + }, + ); + ok($role1->has_method('foo'), "role has method foo"); + $role2 = Moose::Util::MetaRole::apply_metaroles( + for => $role1->name, + role_metaroles => { role => ['Role::Metarole'] }, + ); + isnt($role1, $role2, "anon role was reinitialized"); + is($role1->name, $role2->name, "but it's the same anon role"); + is_deeply([sort $role2->get_method_list], ['foo', 'meta'], + "has the right methods"); +} +is_deeply([sort $role2->get_method_list], ['foo', 'meta'], + "still has the right methods"); + +done_testing; diff --git a/t/roles/role.t b/t/roles/role.t new file mode 100644 index 0000000..083e5ac --- /dev/null +++ b/t/roles/role.t @@ -0,0 +1,154 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +=pod + +NOTE: + +Should we be testing here that the has & override +are injecting their methods correctly? In other +words, should 'has_method' return true for them? + +=cut + +{ + package FooRole; + use Moose::Role; + + our $VERSION = '0.01'; + + has 'bar' => (is => 'rw', isa => 'Foo'); + has 'baz' => (is => 'ro'); + + sub foo { 'FooRole::foo' } + sub boo { 'FooRole::boo' } + + before 'boo' => sub { "FooRole::boo:before" }; + + after 'boo' => sub { "FooRole::boo:after1" }; + after 'boo' => sub { "FooRole::boo:after2" }; + + around 'boo' => sub { "FooRole::boo:around" }; + + override 'bling' => sub { "FooRole::bling:override" }; + override 'fling' => sub { "FooRole::fling:override" }; + + ::isnt( ::exception { extends() }, undef, '... extends() is not supported' ); + ::isnt( ::exception { augment() }, undef, '... augment() is not supported' ); + ::isnt( ::exception { inner() }, undef, '... inner() is not supported' ); + + no Moose::Role; +} + +my $foo_role = FooRole->meta; +isa_ok($foo_role, 'Moose::Meta::Role'); +isa_ok($foo_role, 'Class::MOP::Module'); + +is($foo_role->name, 'FooRole', '... got the right name of FooRole'); +is($foo_role->version, '0.01', '... got the right version of FooRole'); + +# methods ... + +ok($foo_role->has_method('foo'), '... FooRole has the foo method'); +is($foo_role->get_method('foo')->body, \&FooRole::foo, '... FooRole got the foo method'); + +isa_ok($foo_role->get_method('foo'), 'Moose::Meta::Role::Method'); + +ok($foo_role->has_method('boo'), '... FooRole has the boo method'); +is($foo_role->get_method('boo')->body, \&FooRole::boo, '... FooRole got the boo method'); + +isa_ok($foo_role->get_method('boo'), 'Moose::Meta::Role::Method'); + +is_deeply( + [ sort $foo_role->get_method_list() ], + [ 'boo', 'foo', 'meta' ], + '... got the right method list'); + +ok(FooRole->can('foo'), "locally defined methods are still there"); +ok(!FooRole->can('has'), "sugar was unimported"); + +# attributes ... + +is_deeply( + [ sort $foo_role->get_attribute_list() ], + [ 'bar', 'baz' ], + '... got the right attribute list'); + +ok($foo_role->has_attribute('bar'), '... FooRole does have the bar attribute'); + +my $bar_attr = $foo_role->get_attribute('bar'); +is($bar_attr->{is}, 'rw', + 'bar attribute is rw'); +is($bar_attr->{isa}, 'Foo', + 'bar attribute isa Foo'); +is(ref($bar_attr->{definition_context}), 'HASH', + 'bar\'s definition context is a hash'); +is($bar_attr->{definition_context}->{package}, 'FooRole', + 'bar was defined in FooRole'); + +ok($foo_role->has_attribute('baz'), '... FooRole does have the baz attribute'); + +my $baz_attr = $foo_role->get_attribute('baz'); +is($baz_attr->{is}, 'ro', + 'baz attribute is ro'); +is(ref($baz_attr->{definition_context}), 'HASH', + 'bar\'s definition context is a hash'); +is($baz_attr->{definition_context}->{package}, 'FooRole', + 'baz was defined in FooRole'); + +# method modifiers + +ok($foo_role->has_before_method_modifiers('boo'), '... now we have a boo:before modifier'); +is(($foo_role->get_before_method_modifiers('boo'))[0]->(), + "FooRole::boo:before", + '... got the right method back'); + +is_deeply( + [ $foo_role->get_method_modifier_list('before') ], + [ 'boo' ], + '... got the right list of before method modifiers'); + +ok($foo_role->has_after_method_modifiers('boo'), '... now we have a boo:after modifier'); +is(($foo_role->get_after_method_modifiers('boo'))[0]->(), + "FooRole::boo:after1", + '... got the right method back'); +is(($foo_role->get_after_method_modifiers('boo'))[1]->(), + "FooRole::boo:after2", + '... got the right method back'); + +is_deeply( + [ $foo_role->get_method_modifier_list('after') ], + [ 'boo' ], + '... got the right list of after method modifiers'); + +ok($foo_role->has_around_method_modifiers('boo'), '... now we have a boo:around modifier'); +is(($foo_role->get_around_method_modifiers('boo'))[0]->(), + "FooRole::boo:around", + '... got the right method back'); + +is_deeply( + [ $foo_role->get_method_modifier_list('around') ], + [ 'boo' ], + '... got the right list of around method modifiers'); + +## overrides + +ok($foo_role->has_override_method_modifier('bling'), '... now we have a bling:override modifier'); +is($foo_role->get_override_method_modifier('bling')->(), + "FooRole::bling:override", + '... got the right method back'); + +ok($foo_role->has_override_method_modifier('fling'), '... now we have a fling:override modifier'); +is($foo_role->get_override_method_modifier('fling')->(), + "FooRole::fling:override", + '... got the right method back'); + +is_deeply( + [ sort $foo_role->get_method_modifier_list('override') ], + [ 'bling', 'fling' ], + '... got the right list of override method modifiers'); + +done_testing; diff --git a/t/roles/role_attr_application.t b/t/roles/role_attr_application.t new file mode 100644 index 0000000..05720e9 --- /dev/null +++ b/t/roles/role_attr_application.t @@ -0,0 +1,291 @@ +use strict; +use warnings; +use Test::More; +use Test::Moose; +use Moose::Util qw( does_role ); + +{ + package Foo::Meta::Attribute; + use Moose::Role; +} + +{ + package Foo::Meta::Attribute2; + use Moose::Role; +} + +{ + package Foo::Role; + use Moose::Role; + + has foo => (is => 'ro'); +} + +{ + package Foo; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { attribute => ['Foo::Meta::Attribute'] }, + role_metaroles => { applied_attribute => ['Foo::Meta::Attribute2'] }, + ); + with 'Foo::Role'; + + has bar => (is => 'ro'); +} + +ok(Moose::Util::does_role(Foo->meta->get_attribute('bar'), 'Foo::Meta::Attribute'), "attrs defined in the class get the class metarole applied"); +ok(!Moose::Util::does_role(Foo->meta->get_attribute('bar'), 'Foo::Meta::Attribute2'), "attrs defined in the class don't get the role metarole applied"); +ok(!Moose::Util::does_role(Foo->meta->get_attribute('foo'), 'Foo::Meta::Attribute'), "attrs defined in the role don't get the metarole applied"); +ok(!Moose::Util::does_role(Foo->meta->get_attribute('foo'), 'Foo::Meta::Attribute'), "attrs defined in the role don't get the role metarole defined in the class applied"); + +{ + package Bar::Meta::Attribute; + use Moose::Role; +} + +{ + package Bar::Meta::Attribute2; + use Moose::Role; +} + +{ + package Bar::Role; + use Moose::Role; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { attribute => ['Bar::Meta::Attribute'] }, + role_metaroles => { applied_attribute => ['Bar::Meta::Attribute2'] }, + ); + + has foo => (is => 'ro'); +} + +{ + package Bar; + use Moose; + with 'Bar::Role'; + + has bar => (is => 'ro'); +} + +ok(!Moose::Util::does_role(Bar->meta->get_attribute('bar'), 'Bar::Meta::Attribute'), "attrs defined in the class don't get the class metarole from the role applied"); +ok(!Moose::Util::does_role(Bar->meta->get_attribute('bar'), 'Bar::Meta::Attribute2'), "attrs defined in the class don't get the role metarole applied"); +ok(Moose::Util::does_role(Bar->meta->get_attribute('foo'), 'Bar::Meta::Attribute2'), "attrs defined in the role get the role metarole applied"); +ok(!Moose::Util::does_role(Bar->meta->get_attribute('foo'), 'Bar::Meta::Attribute'), "attrs defined in the role don't get the class metarole applied"); + +{ + package Baz::Meta::Attribute; + use Moose::Role; +} + +{ + package Baz::Meta::Attribute2; + use Moose::Role; +} + +{ + package Baz::Role; + use Moose::Role; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { attribute => ['Baz::Meta::Attribute'] }, + role_metaroles => { applied_attribute => ['Baz::Meta::Attribute2'] }, + ); + + has foo => (is => 'ro'); +} + +{ + package Baz; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { attribute => ['Baz::Meta::Attribute'] }, + role_metaroles => { applied_attribute => ['Baz::Meta::Attribute2'] }, + ); + with 'Baz::Role'; + + has bar => (is => 'ro'); +} + +ok(Moose::Util::does_role(Baz->meta->get_attribute('bar'), 'Baz::Meta::Attribute'), "attrs defined in the class get the class metarole applied"); +ok(!Moose::Util::does_role(Baz->meta->get_attribute('bar'), 'Baz::Meta::Attribute2'), "attrs defined in the class don't get the role metarole applied"); +ok(Moose::Util::does_role(Baz->meta->get_attribute('foo'), 'Baz::Meta::Attribute2'), "attrs defined in the role get the role metarole applied"); +ok(!Moose::Util::does_role(Baz->meta->get_attribute('foo'), 'Baz::Meta::Attribute'), "attrs defined in the role don't get the class metarole applied"); + +{ + package Accessor::Modifying::Role; + use Moose::Role; + + around _process_options => sub { + my $orig = shift; + my $self = shift; + my ($name, $params) = @_; + $self->$orig(@_); + $params->{reader} .= '_foo'; + }; +} + +{ + package Plain::Role; + use Moose::Role; + + has foo => ( + is => 'ro', + isa => 'Str', + ); +} + +{ + package Class::With::Trait; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { + attribute => ['Accessor::Modifying::Role'], + }, + ); + with 'Plain::Role'; + + has bar => ( + is => 'ro', + isa => 'Str', + ); +} + +{ + can_ok('Class::With::Trait', 'foo'); + can_ok('Class::With::Trait', 'bar_foo'); +} + +{ + package Role::With::Trait; + use Moose::Role; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + role_metaroles => { + applied_attribute => ['Accessor::Modifying::Role'], + }, + ); + with 'Plain::Role'; + + has foo => ( + is => 'ro', + isa => 'Str', + ); + + sub foo_test { + my $self = shift; + return $self->can('foo_foo'); + } +} + +{ + package Class::With::Role::With::Trait; + use Moose; + with 'Role::With::Trait'; + + has bar => ( + is => 'ro', + isa => 'Str', + ); + + sub bar_test { + my $self = shift; + return $self->can('bar'); + } +} + +{ + can_ok('Class::With::Role::With::Trait', 'foo_foo'); + can_ok('Class::With::Role::With::Trait', 'bar'); +} + +{ + package Quux::Meta::Role::Attribute; + use Moose::Role; +} + +{ + package Quux::Role1; + use Moose::Role; + + has foo => (traits => ['Quux::Meta::Role::Attribute'], is => 'ro'); + has baz => (is => 'ro'); +} + +{ + package Quux::Role2; + use Moose::Role; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + role_metaroles => { + applied_attribute => ['Quux::Meta::Role::Attribute'] + }, + ); + + has bar => (is => 'ro'); +} + +{ + package Quux; + use Moose; + with 'Quux::Role1', 'Quux::Role2'; +} + +{ + my $foo = Quux->meta->get_attribute('foo'); + does_ok($foo, 'Quux::Meta::Role::Attribute', + "individual attribute trait applied correctly"); + + my $baz = Quux->meta->get_attribute('baz'); + ok(! does_role($baz, 'Quux::Meta::Role::Attribute'), + "applied_attribute traits do not end up applying to attributes from other roles during composition"); + + my $bar = Quux->meta->get_attribute('bar'); + does_ok($bar, 'Quux::Meta::Role::Attribute', + "attribute metarole applied correctly"); +} + +{ + package HasMeta; + use Moose::Role; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + role_metaroles => { + applied_attribute => ['Quux::Meta::Role::Attribute'] + }, + ); + + has foo => (is => 'ro'); +} + +{ + package NoMeta; + use Moose::Role; + + with 'HasMeta'; + + has bar => (is => 'ro'); +} + +{ + package ConsumesBoth; + use Moose; + with 'HasMeta', 'NoMeta'; +} + +{ + my $foo = ConsumesBoth->meta->get_attribute('foo'); + does_ok($foo, 'Quux::Meta::Role::Attribute', + 'applied_attribute traits are preserved when one role consumes another'); + + my $bar = ConsumesBoth->meta->get_attribute('bar'); + ok(! does_role($bar, 'Quux::Meta::Role::Attribute'), + "applied_attribute traits do not spill over from consumed role"); +} + + + +done_testing; diff --git a/t/roles/role_attribute_conflict.t b/t/roles/role_attribute_conflict.t new file mode 100644 index 0000000..d4ad4c5 --- /dev/null +++ b/t/roles/role_attribute_conflict.t @@ -0,0 +1,28 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package My::Role1; + use Moose::Role; + + has foo => ( + is => 'ro', + ); + +} + +{ + package My::Role2; + use Moose::Role; + + has foo => ( + is => 'ro', + ); + + ::like( ::exception { with 'My::Role1' }, qr/attribute conflict.+My::Role2.+foo/, 'attribute conflict when composing one role into another' ); +} + +done_testing; diff --git a/t/roles/role_attrs.t b/t/roles/role_attrs.t new file mode 100644 index 0000000..6c1ea8b --- /dev/null +++ b/t/roles/role_attrs.t @@ -0,0 +1,53 @@ +use strict; +use warnings; + +use Test::More; + +use Moose (); +use Moose::Meta::Role; +use Moose::Util; + +my $role1 = Moose::Meta::Role->initialize('Foo'); +$role1->add_attribute( foo => ( is => 'ro' ) ); + +ok( $role1->has_attribute('foo'), 'Foo role has a foo attribute' ); + +my $foo_attr = $role1->get_attribute('foo'); +is( + $foo_attr->associated_role->name, 'Foo', + 'associated_role for foo attr is Foo role' +); + +isa_ok( + $foo_attr->attribute_for_class('Moose::Meta::Attribute'), + 'Moose::Meta::Attribute', + 'attribute returned by ->attribute_for_class' +); + +my $role2 = Moose::Meta::Role->initialize('Bar'); +$role1->apply($role2); + +ok( $role2->has_attribute('foo'), 'Bar role has a foo attribute' ); + +is( + $foo_attr->associated_role->name, 'Foo', + 'associated_role for foo attr is still Foo role' +); + +isa_ok( + $foo_attr->attribute_for_class('Moose::Meta::Attribute'), + 'Moose::Meta::Attribute', + 'attribute returned by ->attribute_for_class' +); + +my $role3 = Moose::Meta::Role->initialize('Baz'); +my $combined = Moose::Meta::Role->combine( [ $role1->name ], [ $role3->name ] ); + +ok( $combined->has_attribute('foo'), 'combined role has a foo attribute' ); + +is( + $foo_attr->associated_role->name, 'Foo', + 'associated_role for foo attr is still Foo role' +); + +done_testing; diff --git a/t/roles/role_compose_requires.t b/t/roles/role_compose_requires.t new file mode 100644 index 0000000..06337ff --- /dev/null +++ b/t/roles/role_compose_requires.t @@ -0,0 +1,132 @@ +use strict; +use warnings; + +# See https://rt.cpan.org/Ticket/Display.html?id=46347 + +use Test::More; +use Test::Fatal; + +{ + package My::Role1; + use Moose::Role; + requires 'test_output'; +} + +{ + package My::Role2; + use Moose::Role; + has test_output => ( is => 'rw' ); + with 'My::Role1'; +} + +{ + package My::Role3; + use Moose::Role; + sub test_output { } + with 'My::Role1'; +} + +{ + package My::Role4; + use Moose::Role; + has test_output => ( is => 'rw' ); +} + +{ + package My::Role5; + use Moose::Role; + sub test_output { } +} + +{ + package My::Base1; + use Moose; + has test_output => ( is => 'rw' ); +} + +{ + package My::Base2; + use Moose; + sub test_output { } +} + +# Roles providing attributes/methods should satisfy requires() of other +# roles they consume. +{ + local $TODO = "role attributes don't satisfy method requirements"; + is( exception { package My::Test1; use Moose; with 'My::Role2'; }, undef, 'role2(provides attribute) consumes role1' ); +} + +is( exception { package My::Test2; use Moose; with 'My::Role3'; }, undef, 'role3(provides method) consumes role1' ); + +# As I understand the design, Roles composed in the same with() statement +# should NOT demonstrate ordering dependency. Alter these tests if that +# assumption is false. -Vince Veselosky +{ + local $TODO = "role attributes don't satisfy method requirements"; + is( exception { package My::Test3; use Moose; with 'My::Role4', 'My::Role1'; }, undef, 'class consumes role4(provides attribute), role1' ); +} + +{ + local $TODO = "role attributes don't satisfy method requirements"; + is( exception { package My::Test4; use Moose; with 'My::Role1', 'My::Role4'; }, undef, 'class consumes role1, role4(provides attribute)' ); +} + +is( exception { package My::Test5; use Moose; with 'My::Role5', 'My::Role1'; }, undef, 'class consumes role5(provides method), role1' ); + +is( exception { package My::Test6; use Moose; with 'My::Role1', 'My::Role5'; }, undef, 'class consumes role1, role5(provides method)' ); + +# Inherited methods/attributes should satisfy requires(), as long as +# extends() comes first in code order. +is( exception { + package My::Test7; + use Moose; + extends 'My::Base1'; + with 'My::Role1'; +}, undef, 'class extends base1(provides attribute), consumes role1' ); + +is( exception { + package My::Test8; + use Moose; + extends 'My::Base2'; + with 'My::Role1'; +}, undef, 'class extends base2(provides method), consumes role1' ); + +# Attributes/methods implemented in class should satisfy requires() +is( exception { + + package My::Test9; + use Moose; + has 'test_output', is => 'rw'; + with 'My::Role1'; +}, undef, 'class provides attribute, consumes role1' ); + +is( exception { + + package My::Test10; + use Moose; + sub test_output { } + with 'My::Role1'; +}, undef, 'class provides method, consumes role1' ); + +# Roles composed in separate with() statements SHOULD demonstrate ordering +# dependency. See comment with tests 3-6 above. +is( exception { + package My::Test11; + use Moose; + with 'My::Role4'; + with 'My::Role1'; +}, undef, 'class consumes role4(provides attribute); consumes role1' ); + +isnt( exception { package My::Test12; use Moose; with 'My::Role1'; with 'My::Role4'; }, undef, 'class consumes role1; consumes role4(provides attribute)' ); + +is( exception { + package My::Test13; + use Moose; + with 'My::Role5'; + with 'My::Role1'; +}, undef, 'class consumes role5(provides method); consumes role1' ); + +isnt( exception { package My::Test14; use Moose; with 'My::Role1'; with 'My::Role5'; }, undef, 'class consumes role1; consumes role5(provides method)' ); + +done_testing; diff --git a/t/roles/role_composite.t b/t/roles/role_composite.t new file mode 100644 index 0000000..f3c52aa --- /dev/null +++ b/t/roles/role_composite.t @@ -0,0 +1,84 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role::Application::RoleSummation; +use Moose::Meta::Role::Composite; + +{ + package Role::Foo; + use Moose::Role; + + package Role::Bar; + use Moose::Role; + + package Role::Baz; + use Moose::Role; + + package Role::Gorch; + use Moose::Role; +} + +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + Role::Baz->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::Bar|Role::Baz', '... got the composite role name'); + + is_deeply($c->get_roles, [ + Role::Foo->meta, + Role::Bar->meta, + Role::Baz->meta, + ], '... got the right roles'); + + ok($c->does_role($_), '... our composite does the role ' . $_) + for qw( + Role::Foo + Role::Bar + Role::Baz + ); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this composed okay' ); + + ok(!$c->is_anon, '... composite is not anonymous'); + + ##... now nest 'em + { + my $c2 = Moose::Meta::Role::Composite->new( + roles => [ + $c, + Role::Gorch->meta, + ] + ); + isa_ok($c2, 'Moose::Meta::Role::Composite'); + + is($c2->name, 'Role::Foo|Role::Bar|Role::Baz|Role::Gorch', '... got the composite role name'); + + is_deeply($c2->get_roles, [ + $c, + Role::Gorch->meta, + ], '... got the right roles'); + + ok($c2->does_role($_), '... our composite does the role ' . $_) + for qw( + Role::Foo + Role::Bar + Role::Baz + Role::Gorch + ); + + ok(!$c2->is_anon, '... composite is not anonymous'); + } +} + +done_testing; diff --git a/t/roles/role_composite_exclusion.t b/t/roles/role_composite_exclusion.t new file mode 100644 index 0000000..ed44308 --- /dev/null +++ b/t/roles/role_composite_exclusion.t @@ -0,0 +1,107 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role::Application::RoleSummation; +use Moose::Meta::Role::Composite; + +{ + package Role::Foo; + use Moose::Role; + + package Role::Bar; + use Moose::Role; + + package Role::ExcludesFoo; + use Moose::Role; + excludes 'Role::Foo'; + + package Role::DoesExcludesFoo; + use Moose::Role; + with 'Role::ExcludesFoo'; + + package Role::DoesFoo; + use Moose::Role; + with 'Role::Foo'; +} + +ok(Role::ExcludesFoo->meta->excludes_role('Role::Foo'), '... got the right exclusions'); +ok(Role::DoesExcludesFoo->meta->excludes_role('Role::Foo'), '... got the right exclusions'); + +# test simple exclusion +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::ExcludesFoo->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + +# test no conflicts +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this lives as expected' ); +} + +# test no conflicts w/exclusion +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Bar->meta, + Role::ExcludesFoo->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Bar|Role::ExcludesFoo', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this lives as expected' ); + + is_deeply([$c->get_excluded_roles_list], ['Role::Foo'], '... has excluded roles'); +} + + +# test conflict with an "inherited" exclusion +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::DoesExcludesFoo->meta, + ] + ) + ); + +}, undef, '... this fails as expected' ); + +# test conflict with an "inherited" exclusion of an "inherited" role +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::DoesFoo->meta, + Role::DoesExcludesFoo->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + +done_testing; diff --git a/t/roles/role_composition_attributes.t b/t/roles/role_composition_attributes.t new file mode 100644 index 0000000..f11a0c5 --- /dev/null +++ b/t/roles/role_composition_attributes.t @@ -0,0 +1,93 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role::Application::RoleSummation; +use Moose::Meta::Role::Composite; + +{ + package Role::Foo; + use Moose::Role; + has 'foo' => (is => 'rw'); + + package Role::Bar; + use Moose::Role; + has 'bar' => (is => 'rw'); + + package Role::FooConflict; + use Moose::Role; + has 'foo' => (is => 'rw'); + + package Role::BarConflict; + use Moose::Role; + has 'bar' => (is => 'rw'); + + package Role::AnotherFooConflict; + use Moose::Role; + with 'Role::FooConflict'; +} + +# test simple attributes +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_attribute_list ], + [ 'bar', 'foo' ], + '... got the right list of attributes' + ); +} + +# test simple conflict +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::FooConflict->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + +# test complex conflict +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + Role::FooConflict->meta, + Role::BarConflict->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + +# test simple conflict +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::AnotherFooConflict->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + +done_testing; diff --git a/t/roles/role_composition_conflict_detection.t b/t/roles/role_composition_conflict_detection.t new file mode 100644 index 0000000..d2b693a --- /dev/null +++ b/t/roles/role_composition_conflict_detection.t @@ -0,0 +1,44 @@ +use strict; +use warnings; + +use Test::More; +use Moose::Util qw( find_meta ); + +{ + package RoleA; + use Moose::Role; + + sub foo { 42 } +} + +{ + package RoleB; + use Moose::Role; + + with 'RoleA'; +} + +{ + package RoleC; + use Moose::Role; + + sub foo { 84 } +} + +{ + my $composite + = Moose::Meta::Role->combine( map { [ find_meta($_) => {} ] } + qw( RoleA RoleB RoleC ) ); + ok( $composite->requires_method('foo'), 'Composite of [ABC] requires a foo method' ); + ok( ! $composite->has_method('foo'), 'Composite of [ABC] does not also have a foo method' ); +} + +{ + my $composite + = Moose::Meta::Role->combine( map { [ find_meta($_) => {} ] } + qw( RoleA RoleC RoleB ) ); + ok( $composite->requires_method('foo'), 'Composite of [ACB] requires a foo method' ); + ok( ! $composite->has_method('foo'), 'Composite of [ACB] does not also have a foo method' ); +} + +done_testing; diff --git a/t/roles/role_composition_errors.t b/t/roles/role_composition_errors.t new file mode 100644 index 0000000..8fe9178 --- /dev/null +++ b/t/roles/role_composition_errors.t @@ -0,0 +1,141 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + + package Foo::Role; + use Moose::Role; + + requires 'foo'; +} + +is_deeply( + [ sort Foo::Role->meta->get_required_method_list ], + ['foo'], + '... the Foo::Role has a required method (foo)' +); + +# classes which does not implement required method +{ + + package Foo::Class; + use Moose; + + ::isnt( ::exception { with('Foo::Role') }, undef, '... no foo method implemented by Foo::Class' ); +} + +# class which does implement required method +{ + + package Bar::Class; + use Moose; + + ::isnt( ::exception { with('Foo::Class') }, undef, '... cannot consume a class, it must be a role' ); + ::is( ::exception { with('Foo::Role') }, undef, '... has a foo method implemented by Bar::Class' ); + + sub foo {'Bar::Class::foo'} +} + +# role which does implement required method +{ + + package Bar::Role; + use Moose::Role; + + ::is( ::exception { with('Foo::Role') }, undef, '... has a foo method implemented by Bar::Role' ); + + sub foo {'Bar::Role::foo'} +} + +is_deeply( + [ sort Bar::Role->meta->get_required_method_list ], + [], + '... the Bar::Role has not inherited the required method from Foo::Role' +); + +# role which does not implement required method +{ + + package Baz::Role; + use Moose::Role; + + ::is( ::exception { with('Foo::Role') }, undef, '... no foo method implemented by Baz::Role' ); +} + +is_deeply( + [ sort Baz::Role->meta->get_required_method_list ], + ['foo'], + '... the Baz::Role has inherited the required method from Foo::Role' +); + +# classes which does not implement required method +{ + + package Baz::Class; + use Moose; + + ::isnt( ::exception { with('Baz::Role') }, undef, '... no foo method implemented by Baz::Class2' ); +} + +# class which does implement required method +{ + + package Baz::Class2; + use Moose; + + ::is( ::exception { with('Baz::Role') }, undef, '... has a foo method implemented by Baz::Class2' ); + + sub foo {'Baz::Class2::foo'} +} + + +{ + package Quux::Role; + use Moose::Role; + + requires qw( meth1 meth2 meth3 meth4 ); +} + +# RT #41119 +{ + + package Quux::Class; + use Moose; + + ::like( ::exception { with('Quux::Role') }, qr/\Q'Quux::Role' requires the methods 'meth1', 'meth2', 'meth3', and 'meth4' to be implemented by 'Quux::Class'/, 'exception mentions all the missing required methods at once' ); +} + +{ + package Quux::Class2; + use Moose; + + sub meth1 { } + + ::like( ::exception { with('Quux::Role') }, qr/'Quux::Role' requires the methods 'meth2', 'meth3', and 'meth4' to be implemented by 'Quux::Class2'/, 'exception mentions all the missing required methods at once, but not the one that exists' ); +} + +{ + package Quux::Class3; + use Moose; + + has 'meth1' => ( is => 'ro' ); + has 'meth2' => ( is => 'ro' ); + + ::like( ::exception { with('Quux::Role') }, qr/'Quux::Role' requires the methods 'meth3' and 'meth4' to be implemented by 'Quux::Class3'/, 'exception mentions all the missing methods at once, but not the accessors' ); +} + +{ + package Quux::Class4; + use Moose; + + sub meth1 { } + has 'meth2' => ( is => 'ro' ); + + ::like( ::exception { with('Quux::Role') }, qr/'Quux::Role' requires the methods 'meth3' and 'meth4' to be implemented by 'Quux::Class4'/, 'exception mentions all the require methods that are accessors at once, as well as missing methods, but not the one that exists' ); +} + +done_testing; diff --git a/t/roles/role_composition_method_mods.t b/t/roles/role_composition_method_mods.t new file mode 100644 index 0000000..8f9e4fc --- /dev/null +++ b/t/roles/role_composition_method_mods.t @@ -0,0 +1,86 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role::Application::RoleSummation; +use Moose::Meta::Role::Composite; + +{ + package Role::Foo; + use Moose::Role; + + before foo => sub { 'Role::Foo::foo' }; + around foo => sub { 'Role::Foo::foo' }; + after foo => sub { 'Role::Foo::foo' }; + around baz => sub { [ 'Role::Foo', @{shift->(@_)} ] }; + + package Role::Bar; + use Moose::Role; + + before bar => sub { 'Role::Bar::bar' }; + around bar => sub { 'Role::Bar::bar' }; + after bar => sub { 'Role::Bar::bar' }; + + package Role::Baz; + use Moose::Role; + + with 'Role::Foo'; + around baz => sub { [ 'Role::Baz', @{shift->(@_)} ] }; + +} + +{ + package Class::FooBar; + use Moose; + + with 'Role::Baz'; + sub foo { 'placeholder' } + sub baz { ['Class::FooBar'] } +} + +#test modifier call order +{ + is_deeply( + Class::FooBar->baz, + ['Role::Baz','Role::Foo','Class::FooBar'] + ); +} + +# test simple overrides +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_method_modifier_list('before') ], + [ 'bar', 'foo' ], + '... got the right list of methods' + ); + + is_deeply( + [ sort $c->get_method_modifier_list('after') ], + [ 'bar', 'foo' ], + '... got the right list of methods' + ); + + is_deeply( + [ sort $c->get_method_modifier_list('around') ], + [ 'bar', 'baz', 'foo' ], + '... got the right list of methods' + ); +} + +done_testing; diff --git a/t/roles/role_composition_methods.t b/t/roles/role_composition_methods.t new file mode 100644 index 0000000..62d70c8 --- /dev/null +++ b/t/roles/role_composition_methods.t @@ -0,0 +1,150 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role::Application::RoleSummation; +use Moose::Meta::Role::Composite; + +{ + package Role::Foo; + use Moose::Role; + + sub foo { 'Role::Foo::foo' } + + package Role::Bar; + use Moose::Role; + + sub bar { 'Role::Bar::bar' } + + package Role::FooConflict; + use Moose::Role; + + sub foo { 'Role::FooConflict::foo' } + + package Role::BarConflict; + use Moose::Role; + + sub bar { 'Role::BarConflict::bar' } + + package Role::AnotherFooConflict; + use Moose::Role; + with 'Role::FooConflict'; + + sub baz { 'Role::AnotherFooConflict::baz' } +} + +# test simple attributes +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_method_list ], + [ 'bar', 'foo' ], + '... got the right list of methods' + ); +} + +# test simple conflict +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::FooConflict->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::FooConflict', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_method_list ], + [], + '... got the right list of methods' + ); + + is_deeply( + [ sort $c->get_required_method_list ], + [ 'foo' ], + '... got the right list of required methods' + ); +} + +# test complex conflict +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + Role::FooConflict->meta, + Role::BarConflict->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::Bar|Role::FooConflict|Role::BarConflict', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_method_list ], + [], + '... got the right list of methods' + ); + + is_deeply( + [ sort $c->get_required_method_list ], + [ 'bar', 'foo' ], + '... got the right list of required methods' + ); +} + +# test simple conflict +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::AnotherFooConflict->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::AnotherFooConflict', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_method_list ], + [ 'baz' ], + '... got the right list of methods' + ); + + is_deeply( + [ sort $c->get_required_method_list ], + [ 'foo' ], + '... got the right list of required methods' + ); +} + +done_testing; diff --git a/t/roles/role_composition_override.t b/t/roles/role_composition_override.t new file mode 100644 index 0000000..dcabe76 --- /dev/null +++ b/t/roles/role_composition_override.t @@ -0,0 +1,168 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role::Application::RoleSummation; +use Moose::Meta::Role::Composite; + +{ + package Role::Foo; + use Moose::Role; + + override foo => sub { 'Role::Foo::foo' }; + + package Role::Bar; + use Moose::Role; + + override bar => sub { 'Role::Bar::bar' }; + + package Role::FooConflict; + use Moose::Role; + + override foo => sub { 'Role::FooConflict::foo' }; + + package Role::FooMethodConflict; + use Moose::Role; + + sub foo { 'Role::FooConflict::foo' } + + package Role::BarMethodConflict; + use Moose::Role; + + sub bar { 'Role::BarConflict::bar' } +} + +# test simple overrides +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this lives ok' ); + + is_deeply( + [ sort $c->get_method_modifier_list('override') ], + [ 'bar', 'foo' ], + '... got the right list of methods' + ); +} + +# test simple overrides w/ conflicts +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::FooConflict->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + +# test simple overrides w/ conflicts +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::FooMethodConflict->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + + +# test simple overrides w/ conflicts +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + Role::FooConflict->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + + +# test simple overrides w/ conflicts +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + Role::FooMethodConflict->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + +{ + { + package Foo; + use Moose::Role; + + override test => sub { print "override test in Foo" }; + } + + my $exception = exception { + { + package Bar; + use Moose::Role; + + override test => sub { print "override test in Bar" }; + with 'Foo'; + } + }; + + like( + $exception, + qr/\QRole 'Foo' has encountered an 'override' method conflict during composition (Two 'override' methods of the same name encountered). This is a fatal error./, + "Foo & Bar, both roles are overriding test method"); +} + +{ + { + package Role::A; + use Moose::Role; + + override a_method => sub { "a method in A" }; + } + + { + package Role::B; + use Moose::Role; + with 'Role::A'; + } + + { + package Role::C; + use Moose::Role; + with 'Role::A' + } + + my $exception = exception { + { + package Role::D; + use Moose::Role; + with 'Role::B'; + with 'Role::C'; + } + }; + + is( $exception, undef, "this works fine"); +} + +done_testing; diff --git a/t/roles/role_composition_req_methods.t b/t/roles/role_composition_req_methods.t new file mode 100644 index 0000000..7209aa9 --- /dev/null +++ b/t/roles/role_composition_req_methods.t @@ -0,0 +1,123 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role::Application::RoleSummation; +use Moose::Meta::Role::Composite; + +{ + package Role::Foo; + use Moose::Role; + requires 'foo'; + + package Role::Bar; + use Moose::Role; + requires 'bar'; + + package Role::ProvidesFoo; + use Moose::Role; + sub foo { 'Role::ProvidesFoo::foo' } + + package Role::ProvidesBar; + use Moose::Role; + sub bar { 'Role::ProvidesBar::bar' } +} + +# test simple requirement +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_required_method_list ], + [ 'bar', 'foo' ], + '... got the right list of required methods' + ); +} + +# test requirement satisfied +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::ProvidesFoo->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::ProvidesFoo', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_required_method_list ], + [], + '... got the right list of required methods' + ); +} + +# test requirement satisfied +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::ProvidesFoo->meta, + Role::Bar->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::ProvidesFoo|Role::Bar', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_required_method_list ], + [ 'bar' ], + '... got the right list of required methods' + ); +} + +# test requirement satisfied +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::ProvidesFoo->meta, + Role::ProvidesBar->meta, + Role::Bar->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::ProvidesFoo|Role::ProvidesBar|Role::Bar', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_required_method_list ], + [ ], + '... got the right list of required methods' + ); +} + +done_testing; diff --git a/t/roles/role_conflict_detection.t b/t/roles/role_conflict_detection.t new file mode 100644 index 0000000..0f80f55 --- /dev/null +++ b/t/roles/role_conflict_detection.t @@ -0,0 +1,595 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +=pod + +Mutually recursive roles. + +=cut + +{ + package Role::Foo; + use Moose::Role; + + requires 'foo'; + + sub bar { 'Role::Foo::bar' } + + package Role::Bar; + use Moose::Role; + + requires 'bar'; + + sub foo { 'Role::Bar::foo' } +} + +{ + package My::Test1; + use Moose; + + ::is( ::exception { + with 'Role::Foo', 'Role::Bar'; + }, undef, '... our mutually recursive roles combine okay' ); + + package My::Test2; + use Moose; + + ::is( ::exception { + with 'Role::Bar', 'Role::Foo'; + }, undef, '... our mutually recursive roles combine okay (no matter what order)' ); +} + +my $test1 = My::Test1->new; +isa_ok($test1, 'My::Test1'); + +ok($test1->does('Role::Foo'), '... $test1 does Role::Foo'); +ok($test1->does('Role::Bar'), '... $test1 does Role::Bar'); + +can_ok($test1, 'foo'); +can_ok($test1, 'bar'); + +is($test1->foo, 'Role::Bar::foo', '... $test1->foo worked'); +is($test1->bar, 'Role::Foo::bar', '... $test1->bar worked'); + +my $test2 = My::Test2->new; +isa_ok($test2, 'My::Test2'); + +ok($test2->does('Role::Foo'), '... $test2 does Role::Foo'); +ok($test2->does('Role::Bar'), '... $test2 does Role::Bar'); + +can_ok($test2, 'foo'); +can_ok($test2, 'bar'); + +is($test2->foo, 'Role::Bar::foo', '... $test2->foo worked'); +is($test2->bar, 'Role::Foo::bar', '... $test2->bar worked'); + +# check some meta-stuff + +ok(Role::Foo->meta->has_method('bar'), '... it still has the bar method'); +ok(Role::Foo->meta->requires_method('foo'), '... it still has the required foo method'); + +ok(Role::Bar->meta->has_method('foo'), '... it still has the foo method'); +ok(Role::Bar->meta->requires_method('bar'), '... it still has the required bar method'); + +=pod + +Role method conflicts + +=cut + +{ + package Role::Bling; + use Moose::Role; + + sub bling { 'Role::Bling::bling' } + + package Role::Bling::Bling; + use Moose::Role; + + sub bling { 'Role::Bling::Bling::bling' } +} + +{ + package My::Test3; + use Moose; + + ::like( ::exception { + with 'Role::Bling', 'Role::Bling::Bling'; + }, qr/Due to a method name conflict in roles 'Role::Bling' and 'Role::Bling::Bling', the method 'bling' must be implemented or excluded by 'My::Test3'/, '... role methods conflict and method was required' ); + + package My::Test4; + use Moose; + + ::is( ::exception { + with 'Role::Bling'; + with 'Role::Bling::Bling'; + }, undef, '... role methods didnt conflict when manually combined' ); + + package My::Test5; + use Moose; + + ::is( ::exception { + with 'Role::Bling::Bling'; + with 'Role::Bling'; + }, undef, '... role methods didnt conflict when manually combined (in opposite order)' ); + + package My::Test6; + use Moose; + + ::is( ::exception { + with 'Role::Bling::Bling', 'Role::Bling'; + }, undef, '... role methods didnt conflict when manually resolved' ); + + sub bling { 'My::Test6::bling' } + + package My::Test7; + use Moose; + + ::is( ::exception { + with 'Role::Bling::Bling', { -excludes => ['bling'] }, 'Role::Bling'; + }, undef, '... role methods didnt conflict when one of the conflicting methods is excluded' ); + + package My::Test8; + use Moose; + + ::is( ::exception { + with 'Role::Bling::Bling', { -excludes => ['bling'], -alias => { bling => 'bling_bling' } }, 'Role::Bling'; + }, undef, '... role methods didnt conflict when one of the conflicting methods is excluded and aliased' ); +} + +ok(!My::Test3->meta->has_method('bling'), '... we didnt get any methods in the conflict'); +ok(My::Test4->meta->has_method('bling'), '... we did get the method when manually dealt with'); +ok(My::Test5->meta->has_method('bling'), '... we did get the method when manually dealt with'); +ok(My::Test6->meta->has_method('bling'), '... we did get the method when manually dealt with'); +ok(My::Test7->meta->has_method('bling'), '... we did get the method when manually dealt with'); +ok(My::Test8->meta->has_method('bling'), '... we did get the method when manually dealt with'); +ok(My::Test8->meta->has_method('bling_bling'), '... we did get the aliased method too'); + +ok(!My::Test3->does('Role::Bling'), '... our class does() the correct roles'); +ok(!My::Test3->does('Role::Bling::Bling'), '... our class does() the correct roles'); +ok(My::Test4->does('Role::Bling'), '... our class does() the correct roles'); +ok(My::Test4->does('Role::Bling::Bling'), '... our class does() the correct roles'); +ok(My::Test5->does('Role::Bling'), '... our class does() the correct roles'); +ok(My::Test5->does('Role::Bling::Bling'), '... our class does() the correct roles'); +ok(My::Test6->does('Role::Bling'), '... our class does() the correct roles'); +ok(My::Test6->does('Role::Bling::Bling'), '... our class does() the correct roles'); +ok(My::Test7->does('Role::Bling'), '... our class does() the correct roles'); +ok(My::Test7->does('Role::Bling::Bling'), '... our class does() the correct roles'); +ok(My::Test8->does('Role::Bling'), '... our class does() the correct roles'); +ok(My::Test8->does('Role::Bling::Bling'), '... our class does() the correct roles'); + +is(My::Test4->bling, 'Role::Bling::bling', '... and we got the first method that was added'); +is(My::Test5->bling, 'Role::Bling::Bling::bling', '... and we got the first method that was added'); +is(My::Test6->bling, 'My::Test6::bling', '... and we got the local method'); +is(My::Test7->bling, 'Role::Bling::bling', '... and we got the non-excluded method'); +is(My::Test8->bling, 'Role::Bling::bling', '... and we got the non-excluded/aliased method'); +is(My::Test8->bling_bling, 'Role::Bling::Bling::bling', '... and the aliased method comes from the correct role'); + +# check how this affects role compostion + +{ + package Role::Bling::Bling::Bling; + use Moose::Role; + + with 'Role::Bling::Bling'; + + sub bling { 'Role::Bling::Bling::Bling::bling' } +} + +ok(Role::Bling::Bling->meta->has_method('bling'), '... still got the bling method in Role::Bling::Bling'); +ok(Role::Bling::Bling->meta->does_role('Role::Bling::Bling'), '... our role correctly does() the other role'); +ok(Role::Bling::Bling::Bling->meta->has_method('bling'), '... dont have the bling method in Role::Bling::Bling::Bling'); +is(Role::Bling::Bling::Bling->meta->get_method('bling')->(), + 'Role::Bling::Bling::Bling::bling', + '... still got the bling method in Role::Bling::Bling::Bling'); + + +=pod + +Role attribute conflicts + +=cut + +{ + package Role::Boo; + use Moose::Role; + + has 'ghost' => (is => 'ro', default => 'Role::Boo::ghost'); + + package Role::Boo::Hoo; + use Moose::Role; + + has 'ghost' => (is => 'ro', default => 'Role::Boo::Hoo::ghost'); +} + +{ + package My::Test7; + use Moose; + + ::like( ::exception { + with 'Role::Boo', 'Role::Boo::Hoo'; + }, qr/We have encountered an attribute conflict.+ghost/ ); + + package My::Test8; + use Moose; + + ::is( ::exception { + with 'Role::Boo'; + with 'Role::Boo::Hoo'; + }, undef, '... role attrs didnt conflict when manually combined' ); + + package My::Test9; + use Moose; + + ::is( ::exception { + with 'Role::Boo::Hoo'; + with 'Role::Boo'; + }, undef, '... role attrs didnt conflict when manually combined' ); + + package My::Test10; + use Moose; + + has 'ghost' => (is => 'ro', default => 'My::Test10::ghost'); + + ::like( ::exception { + with 'Role::Boo', 'Role::Boo::Hoo'; + }, qr/We have encountered an attribute conflict/, '... role attrs conflict and cannot be manually disambiguted' ); + +} + +ok(!My::Test7->meta->has_attribute('ghost'), '... we didnt get any attributes in the conflict'); +ok(My::Test8->meta->has_attribute('ghost'), '... we did get an attributes when manually composed'); +ok(My::Test9->meta->has_attribute('ghost'), '... we did get an attributes when manually composed'); +ok(My::Test10->meta->has_attribute('ghost'), '... we did still have an attribute ghost (conflict does not mess with class)'); + +ok(!My::Test7->does('Role::Boo'), '... our class does() the correct roles'); +ok(!My::Test7->does('Role::Boo::Hoo'), '... our class does() the correct roles'); +ok(My::Test8->does('Role::Boo'), '... our class does() the correct roles'); +ok(My::Test8->does('Role::Boo::Hoo'), '... our class does() the correct roles'); +ok(My::Test9->does('Role::Boo'), '... our class does() the correct roles'); +ok(My::Test9->does('Role::Boo::Hoo'), '... our class does() the correct roles'); +ok(!My::Test10->does('Role::Boo'), '... our class does() the correct roles'); +ok(!My::Test10->does('Role::Boo::Hoo'), '... our class does() the correct roles'); + +can_ok('My::Test8', 'ghost'); +can_ok('My::Test9', 'ghost'); +can_ok('My::Test10', 'ghost'); + +is(My::Test8->new->ghost, 'Role::Boo::ghost', '... got the expected default attr value'); +is(My::Test9->new->ghost, 'Role::Boo::Hoo::ghost', '... got the expected default attr value'); +is(My::Test10->new->ghost, 'My::Test10::ghost', '... got the expected default attr value'); + +=pod + +Role override method conflicts + +=cut + +{ + package Role::Plot; + use Moose::Role; + + override 'twist' => sub { + super() . ' -> Role::Plot::twist'; + }; + + package Role::Truth; + use Moose::Role; + + override 'twist' => sub { + super() . ' -> Role::Truth::twist'; + }; +} + +{ + package My::Test::Base; + use Moose; + + sub twist { 'My::Test::Base::twist' } + + package My::Test11; + use Moose; + + extends 'My::Test::Base'; + + ::is( ::exception { + with 'Role::Truth'; + }, undef, '... composed the role with override okay' ); + + package My::Test12; + use Moose; + + extends 'My::Test::Base'; + + ::is( ::exception { + with 'Role::Plot'; + }, undef, '... composed the role with override okay' ); + + package My::Test13; + use Moose; + + ::isnt( ::exception { + with 'Role::Plot'; + }, undef, '... cannot compose it because we have no superclass' ); + + package My::Test14; + use Moose; + + extends 'My::Test::Base'; + + ::like( ::exception { + with 'Role::Plot', 'Role::Truth'; + }, qr/Two \'override\' methods of the same name encountered/, '... cannot compose it because we have no superclass' ); +} + +ok(My::Test11->meta->has_method('twist'), '... the twist method has been added'); +ok(My::Test12->meta->has_method('twist'), '... the twist method has been added'); +ok(!My::Test13->meta->has_method('twist'), '... the twist method has not been added'); +ok(!My::Test14->meta->has_method('twist'), '... the twist method has not been added'); + +ok(!My::Test11->does('Role::Plot'), '... our class does() the correct roles'); +ok(My::Test11->does('Role::Truth'), '... our class does() the correct roles'); +ok(!My::Test12->does('Role::Truth'), '... our class does() the correct roles'); +ok(My::Test12->does('Role::Plot'), '... our class does() the correct roles'); +ok(!My::Test13->does('Role::Plot'), '... our class does() the correct roles'); +ok(!My::Test14->does('Role::Truth'), '... our class does() the correct roles'); +ok(!My::Test14->does('Role::Plot'), '... our class does() the correct roles'); + +is(My::Test11->twist(), 'My::Test::Base::twist -> Role::Truth::twist', '... got the right method return'); +is(My::Test12->twist(), 'My::Test::Base::twist -> Role::Plot::twist', '... got the right method return'); +ok(!My::Test13->can('twist'), '... no twist method here at all'); +is(My::Test14->twist(), 'My::Test::Base::twist', '... got the right method return (from superclass)'); + +{ + package Role::Reality; + use Moose::Role; + + ::like( ::exception { + with 'Role::Plot'; + }, qr/A local method of the same name as been found/, '... could not compose roles here, it dies' ); + + sub twist { + 'Role::Reality::twist'; + } +} + +ok(Role::Reality->meta->has_method('twist'), '... the twist method has not been added'); +#ok(!Role::Reality->meta->does_role('Role::Plot'), '... our role does() the correct roles'); +is(Role::Reality->meta->get_method('twist')->(), + 'Role::Reality::twist', + '... the twist method returns the right value'); + +# Ovid's test case from rt.cpan.org #44 +{ + package Role1; + use Moose::Role; + + sub foo {} +} +{ + package Role2; + use Moose::Role; + + sub foo {} +} +{ + package Conflicts; + use Moose; + + ::like( ::exception { + with qw(Role1 Role2); + }, qr/Due to a method name conflict in roles 'Role1' and 'Role2', the method 'foo' must be implemented or excluded by 'Conflicts'/ ); +} + +=pod + +Role conflicts between attributes and methods + +[15:23] <kolibrie> when class defines method and role defines method, class wins +[15:24] <kolibrie> when class 'has' method and role defines method, class wins +[15:24] <kolibrie> when class defines method and role 'has' method, role wins +[15:24] <kolibrie> when class 'has' method and role 'has' method, role wins +[15:24] <kolibrie> which means when class 'has' method and two roles 'has' method, no tiebreak is detected +[15:24] <perigrin> this is with role and has declaration in the exact same order in every case? +[15:25] <kolibrie> yes +[15:25] <perigrin> interesting +[15:25] <kolibrie> that's what I thought +[15:26] <kolibrie> does that sound like something I should write a test for? +[15:27] <perigrin> stevan, ping? +[15:27] <perigrin> I'm not sure what the right answer for composition is. +[15:27] <perigrin> who should win +[15:27] <perigrin> if I were to guess I'd say the class should always win. +[15:27] <kolibrie> that would be my guess, but I thought I would ask to make sure +[15:29] <stevan> kolibrie: please write a test +[15:29] <stevan> I am not exactly sure who should win either,.. but I suspect it is not working correctly right now +[15:29] <stevan> I know exactly why it is doing what it is doing though + +Now I have to decide actually what happens, and how to fix it. +- SL + +{ + package Role::Method; + use Moose::Role; + + sub ghost { 'Role::Method::ghost' } + + package Role::Method2; + use Moose::Role; + + sub ghost { 'Role::Method2::ghost' } + + package Role::Attribute; + use Moose::Role; + + has 'ghost' => (is => 'ro', default => 'Role::Attribute::ghost'); + + package Role::Attribute2; + use Moose::Role; + + has 'ghost' => (is => 'ro', default => 'Role::Attribute2::ghost'); +} + +{ + package My::Test15; + use Moose; + + ::lives_ok { + with 'Role::Method'; + } '... composed the method role into the method class'; + + sub ghost { 'My::Test15::ghost' } + + package My::Test16; + use Moose; + + ::lives_ok { + with 'Role::Method'; + } '... composed the method role into the attribute class'; + + has 'ghost' => (is => 'ro', default => 'My::Test16::ghost'); + + package My::Test17; + use Moose; + + ::lives_ok { + with 'Role::Attribute'; + } '... composed the attribute role into the method class'; + + sub ghost { 'My::Test17::ghost' } + + package My::Test18; + use Moose; + + ::lives_ok { + with 'Role::Attribute'; + } '... composed the attribute role into the attribute class'; + + has 'ghost' => (is => 'ro', default => 'My::Test18::ghost'); + + package My::Test19; + use Moose; + + ::lives_ok { + with 'Role::Method', 'Role::Method2'; + } '... composed method roles into class with method tiebreaker'; + + sub ghost { 'My::Test19::ghost' } + + package My::Test20; + use Moose; + + ::lives_ok { + with 'Role::Method', 'Role::Method2'; + } '... composed method roles into class with attribute tiebreaker'; + + has 'ghost' => (is => 'ro', default => 'My::Test20::ghost'); + + package My::Test21; + use Moose; + + ::lives_ok { + with 'Role::Attribute', 'Role::Attribute2'; + } '... composed attribute roles into class with method tiebreaker'; + + sub ghost { 'My::Test21::ghost' } + + package My::Test22; + use Moose; + + ::lives_ok { + with 'Role::Attribute', 'Role::Attribute2'; + } '... composed attribute roles into class with attribute tiebreaker'; + + has 'ghost' => (is => 'ro', default => 'My::Test22::ghost'); + + package My::Test23; + use Moose; + + ::lives_ok { + with 'Role::Method', 'Role::Attribute'; + } '... composed method and attribute role into class with method tiebreaker'; + + sub ghost { 'My::Test23::ghost' } + + package My::Test24; + use Moose; + + ::lives_ok { + with 'Role::Method', 'Role::Attribute'; + } '... composed method and attribute role into class with attribute tiebreaker'; + + has 'ghost' => (is => 'ro', default => 'My::Test24::ghost'); + + package My::Test25; + use Moose; + + ::lives_ok { + with 'Role::Attribute', 'Role::Method'; + } '... composed attribute and method role into class with method tiebreaker'; + + sub ghost { 'My::Test25::ghost' } + + package My::Test26; + use Moose; + + ::lives_ok { + with 'Role::Attribute', 'Role::Method'; + } '... composed attribute and method role into class with attribute tiebreaker'; + + has 'ghost' => (is => 'ro', default => 'My::Test26::ghost'); +} + +my $test15 = My::Test15->new; +isa_ok($test15, 'My::Test15'); +is($test15->ghost, 'My::Test15::ghost', '... we access the method from the class and ignore the role method'); + +my $test16 = My::Test16->new; +isa_ok($test16, 'My::Test16'); +is($test16->ghost, 'My::Test16::ghost', '... we access the attribute from the class and ignore the role method'); + +my $test17 = My::Test17->new; +isa_ok($test17, 'My::Test17'); +is($test17->ghost, 'My::Test17::ghost', '... we access the method from the class and ignore the role attribute'); + +my $test18 = My::Test18->new; +isa_ok($test18, 'My::Test18'); +is($test18->ghost, 'My::Test18::ghost', '... we access the attribute from the class and ignore the role attribute'); + +my $test19 = My::Test19->new; +isa_ok($test19, 'My::Test19'); +is($test19->ghost, 'My::Test19::ghost', '... we access the method from the class and ignore the role methods'); + +my $test20 = My::Test20->new; +isa_ok($test20, 'My::Test20'); +is($test20->ghost, 'My::Test20::ghost', '... we access the attribute from the class and ignore the role methods'); + +my $test21 = My::Test21->new; +isa_ok($test21, 'My::Test21'); +is($test21->ghost, 'My::Test21::ghost', '... we access the method from the class and ignore the role attributes'); + +my $test22 = My::Test22->new; +isa_ok($test22, 'My::Test22'); +is($test22->ghost, 'My::Test22::ghost', '... we access the attribute from the class and ignore the role attributes'); + +my $test23 = My::Test23->new; +isa_ok($test23, 'My::Test23'); +is($test23->ghost, 'My::Test23::ghost', '... we access the method from the class and ignore the role method and attribute'); + +my $test24 = My::Test24->new; +isa_ok($test24, 'My::Test24'); +is($test24->ghost, 'My::Test24::ghost', '... we access the attribute from the class and ignore the role method and attribute'); + +my $test25 = My::Test25->new; +isa_ok($test25, 'My::Test25'); +is($test25->ghost, 'My::Test25::ghost', '... we access the method from the class and ignore the role attribute and method'); + +my $test26 = My::Test26->new; +isa_ok($test26, 'My::Test26'); +is($test26->ghost, 'My::Test26::ghost', '... we access the attribute from the class and ignore the role attribute and method'); + +=cut + +done_testing; diff --git a/t/roles/role_conflict_edge_cases.t b/t/roles/role_conflict_edge_cases.t new file mode 100644 index 0000000..5fb87e0 --- /dev/null +++ b/t/roles/role_conflict_edge_cases.t @@ -0,0 +1,188 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +=pod + +Check for repeated inheritance causing +a method conflict (which is not really +a conflict) + +=cut + +{ + package Role::Base; + use Moose::Role; + + sub foo { 'Role::Base::foo' } + + package Role::Derived1; + use Moose::Role; + + with 'Role::Base'; + + package Role::Derived2; + use Moose::Role; + + with 'Role::Base'; + + package My::Test::Class1; + use Moose; + + ::is( ::exception { + with 'Role::Derived1', 'Role::Derived2'; + }, undef, '... roles composed okay (no conflicts)' ); +} + +ok(Role::Base->meta->has_method('foo'), '... have the method foo as expected'); +ok(Role::Derived1->meta->has_method('foo'), '... have the method foo as expected'); +ok(Role::Derived2->meta->has_method('foo'), '... have the method foo as expected'); +ok(My::Test::Class1->meta->has_method('foo'), '... have the method foo as expected'); + +is(My::Test::Class1->foo, 'Role::Base::foo', '... got the right value from method'); + +=pod + +Check for repeated inheritance causing +a method conflict with method modifiers +(which is not really a conflict) + +=cut + +{ + package Role::Base2; + use Moose::Role; + + override 'foo' => sub { super() . ' -> Role::Base::foo' }; + + package Role::Derived3; + use Moose::Role; + + with 'Role::Base2'; + + package Role::Derived4; + use Moose::Role; + + with 'Role::Base2'; + + package My::Test::Class2::Base; + use Moose; + + sub foo { 'My::Test::Class2::Base' } + + package My::Test::Class2; + use Moose; + + extends 'My::Test::Class2::Base'; + + ::is( ::exception { + with 'Role::Derived3', 'Role::Derived4'; + }, undef, '... roles composed okay (no conflicts)' ); +} + +ok(Role::Base2->meta->has_override_method_modifier('foo'), '... have the method foo as expected'); +ok(Role::Derived3->meta->has_override_method_modifier('foo'), '... have the method foo as expected'); +ok(Role::Derived4->meta->has_override_method_modifier('foo'), '... have the method foo as expected'); +ok(My::Test::Class2->meta->has_method('foo'), '... have the method foo as expected'); +isa_ok(My::Test::Class2->meta->get_method('foo'), 'Moose::Meta::Method::Overridden'); +ok(My::Test::Class2::Base->meta->has_method('foo'), '... have the method foo as expected'); +isa_ok(My::Test::Class2::Base->meta->get_method('foo'), 'Class::MOP::Method'); + +is(My::Test::Class2::Base->foo, 'My::Test::Class2::Base', '... got the right value from method'); +is(My::Test::Class2->foo, 'My::Test::Class2::Base -> Role::Base::foo', '... got the right value from method'); + +=pod + +Check for repeated inheritance of the +same code. There are no conflicts with +before/around/after method modifiers. + +This tests around, but should work the +same for before/afters as well + +=cut + +{ + package Role::Base3; + use Moose::Role; + + around 'foo' => sub { 'Role::Base::foo(' . (shift)->() . ')' }; + + package Role::Derived5; + use Moose::Role; + + with 'Role::Base3'; + + package Role::Derived6; + use Moose::Role; + + with 'Role::Base3'; + + package My::Test::Class3::Base; + use Moose; + + sub foo { 'My::Test::Class3::Base' } + + package My::Test::Class3; + use Moose; + + extends 'My::Test::Class3::Base'; + + ::is( ::exception { + with 'Role::Derived5', 'Role::Derived6'; + }, undef, '... roles composed okay (no conflicts)' ); +} + +ok(Role::Base3->meta->has_around_method_modifiers('foo'), '... have the method foo as expected'); +ok(Role::Derived5->meta->has_around_method_modifiers('foo'), '... have the method foo as expected'); +ok(Role::Derived6->meta->has_around_method_modifiers('foo'), '... have the method foo as expected'); +ok(My::Test::Class3->meta->has_method('foo'), '... have the method foo as expected'); +isa_ok(My::Test::Class3->meta->get_method('foo'), 'Class::MOP::Method::Wrapped'); +ok(My::Test::Class3::Base->meta->has_method('foo'), '... have the method foo as expected'); +isa_ok(My::Test::Class3::Base->meta->get_method('foo'), 'Class::MOP::Method'); + +is(My::Test::Class3::Base->foo, 'My::Test::Class3::Base', '... got the right value from method'); +is(My::Test::Class3->foo, 'Role::Base::foo(My::Test::Class3::Base)', '... got the right value from method'); + +=pod + +Check for repeated inheritance causing +a attr conflict (which is not really +a conflict) + +=cut + +{ + package Role::Base4; + use Moose::Role; + + has 'foo' => (is => 'ro', default => 'Role::Base::foo'); + + package Role::Derived7; + use Moose::Role; + + with 'Role::Base4'; + + package Role::Derived8; + use Moose::Role; + + with 'Role::Base4'; + + package My::Test::Class4; + use Moose; + + ::is( ::exception { + with 'Role::Derived7', 'Role::Derived8'; + }, undef, '... roles composed okay (no conflicts)' ); +} + +ok(Role::Base4->meta->has_attribute('foo'), '... have the attribute foo as expected'); +ok(Role::Derived7->meta->has_attribute('foo'), '... have the attribute foo as expected'); +ok(Role::Derived8->meta->has_attribute('foo'), '... have the attribute foo as expected'); +ok(My::Test::Class4->meta->has_attribute('foo'), '... have the attribute foo as expected'); + +is(My::Test::Class4->new->foo, 'Role::Base::foo', '... got the right value from method'); + +done_testing; diff --git a/t/roles/role_consumers.t b/t/roles/role_consumers.t new file mode 100644 index 0000000..13707f3 --- /dev/null +++ b/t/roles/role_consumers.t @@ -0,0 +1,54 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Foo::Role; + use Moose::Role; +} + +{ + package Bar::Role; + use Moose::Role; +} + +{ + package Foo; + use Moose; + with 'Foo::Role'; +} + +{ + package Bar; + use Moose; + extends 'Foo'; + with 'Bar::Role'; +} + +{ + package FooBar; + use Moose; + with 'Foo::Role', 'Bar::Role'; +} + +{ + package Foo::Role::User; + use Moose::Role; + with 'Foo::Role'; +} + +{ + package Foo::User; + use Moose; + with 'Foo::Role::User'; +} + +is_deeply([sort Foo::Role->meta->consumers], + ['Bar', 'Foo', 'Foo::Role::User', 'Foo::User', 'FooBar']); +is_deeply([sort Bar::Role->meta->consumers], + ['Bar', 'FooBar']); +is_deeply([sort Foo::Role::User->meta->consumers], + ['Foo::User']); + +done_testing; diff --git a/t/roles/role_exclusion.t b/t/roles/role_exclusion.t new file mode 100644 index 0000000..d6cb80a --- /dev/null +++ b/t/roles/role_exclusion.t @@ -0,0 +1,119 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +=pod + +The idea and examples for this feature are taken +from the Fortress spec. + +http://research.sun.com/projects/plrg/fortress0903.pdf + +trait OrganicMolecule extends Molecule + excludes { InorganicMolecule } +end +trait InorganicMolecule extends Molecule end + +=cut + +{ + package Molecule; + use Moose::Role; + + package Molecule::Organic; + use Moose::Role; + + with 'Molecule'; + excludes 'Molecule::Inorganic'; + + package Molecule::Inorganic; + use Moose::Role; + + with 'Molecule'; +} + +ok(Molecule::Organic->meta->excludes_role('Molecule::Inorganic'), '... Molecule::Organic exludes Molecule::Inorganic'); +is_deeply( + [ Molecule::Organic->meta->get_excluded_roles_list() ], + [ 'Molecule::Inorganic' ], + '... Molecule::Organic exludes Molecule::Inorganic'); + +=pod + +Check some basic conflicts when combining +the roles into the same class + +=cut + +{ + package My::Test1; + use Moose; + + ::is( ::exception { + with 'Molecule::Organic'; + }, undef, '... adding the role (w/ excluded roles) okay' ); + + package My::Test2; + use Moose; + + ::like( ::exception { + with 'Molecule::Organic', 'Molecule::Inorganic'; + }, qr/Conflict detected: Role Molecule::Organic excludes role 'Molecule::Inorganic'/, '... adding the role w/ excluded role conflict dies okay' ); + + package My::Test3; + use Moose; + + ::is( ::exception { + with 'Molecule::Organic'; + }, undef, '... adding the role (w/ excluded roles) okay' ); + + ::like( ::exception { + with 'Molecule::Inorganic'; + }, qr/Conflict detected: My::Test3 excludes role 'Molecule::Inorganic'/, '... adding the role w/ excluded role conflict dies okay' ); +} + +ok(My::Test1->does('Molecule::Organic'), '... My::Test1 does Molecule::Organic'); +ok(My::Test1->does('Molecule'), '... My::Test1 does Molecule'); +ok(My::Test1->meta->excludes_role('Molecule::Inorganic'), '... My::Test1 excludes Molecule::Organic'); + +ok(!My::Test2->does('Molecule::Organic'), '... ! My::Test2 does Molecule::Organic'); +ok(!My::Test2->does('Molecule::Inorganic'), '... ! My::Test2 does Molecule::Inorganic'); + +ok(My::Test3->does('Molecule::Organic'), '... My::Test3 does Molecule::Organic'); +ok(My::Test3->does('Molecule'), '... My::Test1 does Molecule'); +ok(My::Test3->meta->excludes_role('Molecule::Inorganic'), '... My::Test3 excludes Molecule::Organic'); +ok(!My::Test3->does('Molecule::Inorganic'), '... ! My::Test3 does Molecule::Inorganic'); + +=pod + +Check some basic conflicts when combining +the roles into the a superclass + +=cut + +{ + package Methane; + use Moose; + + with 'Molecule::Organic'; + + package My::Test4; + use Moose; + + extends 'Methane'; + + ::like( ::exception { + with 'Molecule::Inorganic'; + }, qr/Conflict detected: My::Test4 excludes role \'Molecule::Inorganic\'/, '... cannot add exculded role into class which extends Methane' ); +} + +ok(Methane->does('Molecule::Organic'), '... Methane does Molecule::Organic'); +ok(My::Test4->isa('Methane'), '... My::Test4 isa Methane'); +ok(My::Test4->does('Molecule::Organic'), '... My::Test4 does Molecule::Organic'); +ok(My::Test4->meta->does_role('Molecule::Organic'), '... My::Test4 meat does_role Molecule::Organic'); +ok(My::Test4->meta->excludes_role('Molecule::Inorganic'), '... My::Test4 meta excludes Molecule::Organic'); +ok(!My::Test4->does('Molecule::Inorganic'), '... My::Test4 does Molecule::Inorganic'); + +done_testing; diff --git a/t/roles/role_exclusion_and_alias_bug.t b/t/roles/role_exclusion_and_alias_bug.t new file mode 100644 index 0000000..dc4b0a5 --- /dev/null +++ b/t/roles/role_exclusion_and_alias_bug.t @@ -0,0 +1,67 @@ +use strict; +use warnings; + +use Test::More; +use Test::Moose; + +{ + package My::Role; + use Moose::Role; + + sub foo { "FOO" } + sub bar { "BAR" } +} + +{ + package My::Class; + use Moose; + + with 'My::Role' => { + -alias => { foo => 'baz', bar => 'gorch' }, + -excludes => ['foo', 'bar'], + }; +} + +{ + my $x = My::Class->new; + isa_ok($x, 'My::Class'); + does_ok($x, 'My::Role'); + + can_ok($x, $_) for qw[baz gorch]; + + ok(!$x->can($_), '... cant call method ' . $_) for qw[foo bar]; + + is($x->baz, 'FOO', '... got the right value'); + is($x->gorch, 'BAR', '... got the right value'); +} + +{ + package My::Role::Again; + use Moose::Role; + + with 'My::Role' => { + -alias => { foo => 'baz', bar => 'gorch' }, + -excludes => ['foo', 'bar'], + }; + + package My::Class::Again; + use Moose; + + with 'My::Role::Again'; +} + +{ + my $x = My::Class::Again->new; + isa_ok($x, 'My::Class::Again'); + does_ok($x, 'My::Role::Again'); + does_ok($x, 'My::Role'); + + can_ok($x, $_) for qw[baz gorch]; + + ok(!$x->can($_), '... cant call method ' . $_) for qw[foo bar]; + + is($x->baz, 'FOO', '... got the right value'); + is($x->gorch, 'BAR', '... got the right value'); +} + +done_testing; diff --git a/t/roles/role_for_combination.t b/t/roles/role_for_combination.t new file mode 100644 index 0000000..d4a1684 --- /dev/null +++ b/t/roles/role_for_combination.t @@ -0,0 +1,45 @@ +use strict; +use warnings; +use Test::More; + +my $OPTS; +do { + package My::Singleton::Role; + use Moose::Role; + + sub foo { 'My::Singleton::Role' } + + package My::Role::Metaclass; + use Moose; + BEGIN { extends 'Moose::Meta::Role' }; + + sub _role_for_combination { + my ($self, $opts) = @_; + $OPTS = $opts; + return My::Singleton::Role->meta; + } + + package My::Special::Role; + use Moose::Role -metaclass => 'My::Role::Metaclass'; + + sub foo { 'My::Special::Role' } + + package My::Usual::Role; + use Moose::Role; + + sub bar { 'My::Usual::Role' } + + package My::Class; + use Moose; + + with ( + 'My::Special::Role' => { number => 1 }, + 'My::Usual::Role' => { number => 2 }, + ); +}; + +is(My::Class->foo, 'My::Singleton::Role', 'role_for_combination applied'); +is(My::Class->bar, 'My::Usual::Role', 'collateral role'); +is_deeply($OPTS, { number => 1 }); + +done_testing; diff --git a/t/roles/roles_and_method_cloning.t b/t/roles/roles_and_method_cloning.t new file mode 100644 index 0000000..1624a98 --- /dev/null +++ b/t/roles/roles_and_method_cloning.t @@ -0,0 +1,77 @@ +use strict; +use warnings; + +use Test::More; + + +{ + package Role::Foo; + use Moose::Role; + + sub foo { (caller(0))[3] } +} + +{ + package ClassA; + use Moose; + + with 'Role::Foo'; +} + +{ + my $meth = ClassA->meta->get_method('foo'); + ok( $meth, 'ClassA has a foo method' ); + isa_ok( $meth, 'Moose::Meta::Method' ); + is( $meth->original_method, Role::Foo->meta->get_method('foo'), + 'ClassA->foo was cloned from Role::Foo->foo' ); + is( $meth->fully_qualified_name, 'ClassA::foo', + 'fq name is ClassA::foo' ); + is( $meth->original_fully_qualified_name, 'Role::Foo::foo', + 'original fq name is Role::Foo::foo' ); +} + +{ + package Role::Bar; + use Moose::Role; + with 'Role::Foo'; + + sub bar { } +} + +{ + my $meth = Role::Bar->meta->get_method('foo'); + ok( $meth, 'Role::Bar has a foo method' ); + is( $meth->original_method, Role::Foo->meta->get_method('foo'), + 'Role::Bar->foo was cloned from Role::Foo->foo' ); + is( $meth->fully_qualified_name, 'Role::Bar::foo', + 'fq name is Role::Bar::foo' ); + is( $meth->original_fully_qualified_name, 'Role::Foo::foo', + 'original fq name is Role::Foo::foo' ); +} + +{ + package ClassB; + use Moose; + + with 'Role::Bar'; +} + +{ + my $meth = ClassB->meta->get_method('foo'); + ok( $meth, 'ClassB has a foo method' ); + is( $meth->original_method, Role::Bar->meta->get_method('foo'), + 'ClassA->foo was cloned from Role::Bar->foo' ); + is( $meth->original_method->original_method, Role::Foo->meta->get_method('foo'), + '... which in turn was cloned from Role::Foo->foo' ); + is( $meth->fully_qualified_name, 'ClassB::foo', + 'fq name is ClassA::foo' ); + is( $meth->original_fully_qualified_name, 'Role::Foo::foo', + 'original fq name is Role::Foo::foo' ); +} + +isnt( ClassA->foo, "ClassB::foo", "ClassA::foo is not confused with ClassB::foo"); + +is( ClassB->foo, 'Role::Foo::foo', 'ClassB::foo knows its name' ); +is( ClassA->foo, 'Role::Foo::foo', 'ClassA::foo knows its name' ); + +done_testing; diff --git a/t/roles/roles_and_req_method_edge_cases.t b/t/roles/roles_and_req_method_edge_cases.t new file mode 100644 index 0000000..601dbf1 --- /dev/null +++ b/t/roles/roles_and_req_method_edge_cases.t @@ -0,0 +1,277 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +=pod + +NOTE: +A fair amount of these tests will likely be irrelevant +once we have more fine grained control over the class +building process. A lot of the edge cases tested here +are actually related to class construction order and +not any real functionality. +- SL + +Role which requires a method implemented +in another role as an override (it does +not remove the requirement) + +=cut + +{ + package Role::RequireFoo; + use strict; + use warnings; + use Moose::Role; + + requires 'foo'; + + package Role::ProvideFoo; + use strict; + use warnings; + use Moose::Role; + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method will not exist yet (but we will live)' ); + + override 'foo' => sub { 'Role::ProvideFoo::foo' }; +} + +is_deeply( + [ Role::ProvideFoo->meta->get_required_method_list ], + [ 'foo' ], + '... foo method is still required for Role::ProvideFoo'); + +=pod + +Role which requires a method implemented +in the consuming class as an override. +It will fail since method modifiers are +second class citizens. + +=cut + +{ + package Class::ProvideFoo::Base; + use Moose; + + sub foo { 'Class::ProvideFoo::Base::foo' } + + package Class::ProvideFoo::Override1; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method will be found in the superclass' ); + + override 'foo' => sub { 'Class::ProvideFoo::foo' }; + + package Class::ProvideFoo::Override2; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + override 'foo' => sub { 'Class::ProvideFoo::foo' }; + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method exists, although it is overriden locally' ); + +} + +=pod + +Now same thing, but with a before +method modifier. + +=cut + +{ + package Class::ProvideFoo::Before1; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method will be found in the superclass' ); + + before 'foo' => sub { 'Class::ProvideFoo::foo:before' }; + + package Class::ProvideFoo::Before2; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + before 'foo' => sub { 'Class::ProvideFoo::foo:before' }; + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method exists, although it is a before modifier locally' ); + + package Class::ProvideFoo::Before3; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + sub foo { 'Class::ProvideFoo::foo' } + before 'foo' => sub { 'Class::ProvideFoo::foo:before' }; + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method exists locally, and it is modified locally' ); + + package Class::ProvideFoo::Before4; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + sub foo { 'Class::ProvideFoo::foo' } + before 'foo' => sub { 'Class::ProvideFoo::foo:before' }; + + ::isa_ok(__PACKAGE__->meta->get_method('foo'), 'Class::MOP::Method::Wrapped'); + ::is(__PACKAGE__->meta->get_method('foo')->get_original_method->package_name, __PACKAGE__, + '... but the original method is from our package'); + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method exists in the symbol table (and we will live)' ); + +} + +=pod + +Now same thing, but with a method from an attribute +method modifier. + +=cut + +{ + + package Class::ProvideFoo::Attr1; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method will be found in the superclass (but then overriden)' ); + + has 'foo' => (is => 'ro'); + + package Class::ProvideFoo::Attr2; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + has 'foo' => (is => 'ro'); + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method exists, and is an accessor' ); +} + +# ... +# a method required in a role, but then +# implemented in the superclass (as an +# attribute accessor too) + +{ + package Foo::Class::Base; + use Moose; + + has 'bar' => ( + isa => 'Int', + is => 'rw', + default => sub { 1 } + ); +} +{ + package Foo::Role; + use Moose::Role; + + requires 'bar'; + + has 'foo' => ( + isa => 'Int', + is => 'rw', + lazy => 1, + default => sub { (shift)->bar + 1 } + ); +} +{ + package Foo::Class::Child; + use Moose; + extends 'Foo::Class::Base'; + + ::is( ::exception { + with 'Foo::Role'; + }, undef, '... our role combined successfully' ); +} + +# a method required in a role and implemented in a superclass, with a method +# modifier in the subclass. this should live, but dies in 0.26 -- hdp, +# 2007-10-11 + +{ + package Bar::Class::Base; + use Moose; + + sub bar { "hello!" } +} +{ + package Bar::Role; + use Moose::Role; + requires 'bar'; +} +{ + package Bar::Class::Child; + use Moose; + extends 'Bar::Class::Base'; + after bar => sub { "o noes" }; + # technically we could run lives_ok here, too, but putting it into a + # grandchild class makes it more obvious why this matters. +} +{ + package Bar::Class::Grandchild; + use Moose; + extends 'Bar::Class::Child'; + ::is( ::exception { + with 'Bar::Role'; + }, undef, 'required method exists in superclass as non-modifier, so we live' ); +} + +{ + package Bar2::Class::Base; + use Moose; + + sub bar { "hello!" } +} +{ + package Bar2::Role; + use Moose::Role; + requires 'bar'; +} +{ + package Bar2::Class::Child; + use Moose; + extends 'Bar2::Class::Base'; + override bar => sub { "o noes" }; + # technically we could run lives_ok here, too, but putting it into a + # grandchild class makes it more obvious why this matters. +} +{ + package Bar2::Class::Grandchild; + use Moose; + extends 'Bar2::Class::Child'; + ::is( ::exception { + with 'Bar2::Role'; + }, undef, 'required method exists in superclass as non-modifier, so we live' ); +} + +done_testing; diff --git a/t/roles/roles_applied_in_create.t b/t/roles/roles_applied_in_create.t new file mode 100644 index 0000000..9f617ad --- /dev/null +++ b/t/roles/roles_applied_in_create.t @@ -0,0 +1,23 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Moose::Meta::Class; +use Moose::Util; + +use lib 't/lib'; + + +# Note that this test passed (pre svn #5543) if we inlined the role +# definitions in this file, as it was very timing sensitive. +is( exception { + my $builder_meta = Moose::Meta::Class->create( + 'YATTA' => ( + superclass => 'Moose::Meta::Class', + roles => [qw( Role::Interface Role::Child )], + ) + ); +}, undef, 'Create a new class with several roles' ); + +done_testing; diff --git a/t/roles/run_time_role_composition.t b/t/roles/run_time_role_composition.t new file mode 100644 index 0000000..c847df3 --- /dev/null +++ b/t/roles/run_time_role_composition.t @@ -0,0 +1,111 @@ +use strict; +use warnings; + +use Test::More; + +use Scalar::Util qw(blessed); + + +=pod + +This test can be used as a basis for the runtime role composition. +Apparently it is not as simple as just making an anon class. One of +the problems is the way that anon classes are DESTROY-ed, which is +not very compatible with how instances are dealt with. + +=cut + +{ + package Bark; + use Moose::Role; + + sub talk { 'woof' } + + package Sleeper; + use Moose::Role; + + sub sleep { 'snore' } + sub talk { 'zzz' } + + package My::Class; + use Moose; + + sub sleep { 'nite-nite' } +} + +my $obj = My::Class->new; +isa_ok($obj, 'My::Class'); + +my $obj2 = My::Class->new; +isa_ok($obj2, 'My::Class'); + +{ + ok(!$obj->can( 'talk' ), "... the role is not composed yet"); + + ok(!$obj->does('Bark'), '... we do not do any roles yet'); + + Bark->meta->apply($obj); + + ok($obj->does('Bark'), '... we now do the Bark role'); + ok(!My::Class->does('Bark'), '... the class does not do the Bark role'); + + isa_ok($obj, 'My::Class'); + isnt(blessed($obj), 'My::Class', '... but it is no longer blessed into My::Class'); + + ok(!My::Class->can('talk'), "... the role is not composed at the class level"); + ok($obj->can('talk'), "... the role is now composed at the object level"); + + is($obj->talk, 'woof', '... got the right return value for the newly composed method'); +} + +{ + ok(!$obj2->does('Sleeper'), '... we do not do any roles yet'); + + Sleeper->meta->apply($obj2); + + ok($obj2->does('Sleeper'), '... we now do the Sleeper role'); + isnt(blessed($obj), blessed($obj2), '... they DO NOT share the same anon-class/role thing'); +} + +{ + is($obj->sleep, 'nite-nite', '... the original method responds as expected'); + + ok(!$obj->does('Sleeper'), '... we do not do the Sleeper role'); + + Sleeper->meta->apply($obj); + + ok($obj->does('Bark'), '... we still do the Bark role'); + ok($obj->does('Sleeper'), '... we now do the Sleeper role too'); + + ok(!My::Class->does('Sleeper'), '... the class does not do the Sleeper role'); + + isnt(blessed($obj), blessed($obj2), '... they still don\'t share the same anon-class/role thing'); + + isa_ok($obj, 'My::Class'); + + is(My::Class->sleep, 'nite-nite', '... the original method still responds as expected'); + + is($obj->sleep, 'snore', '... got the right return value for the newly composed method'); + is($obj->talk, 'zzz', '... got the right return value for the newly composed method'); +} + +{ + ok(!$obj2->does('Bark'), '... we do not do Bark yet'); + + Bark->meta->apply($obj2); + + ok($obj2->does('Bark'), '... we now do the Bark role'); + isnt(blessed($obj), blessed($obj2), '... they still don\'t share the same anon-class/role thing'); +} + +# test that anon classes are equivalent after role composition in the same order +{ + foreach ($obj, $obj2) { + $_ = My::Class->new; + Bark->meta->apply($_); + Sleeper->meta->apply($_); + } + is(blessed($obj), blessed($obj2), '... they now share the same anon-class/role thing'); +} + +done_testing; diff --git a/t/roles/runtime_roles_and_attrs.t b/t/roles/runtime_roles_and_attrs.t new file mode 100644 index 0000000..ef5c06c --- /dev/null +++ b/t/roles/runtime_roles_and_attrs.t @@ -0,0 +1,54 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Dog; + use Moose::Role; + + sub talk { 'woof' } + + has fur => ( + isa => "Str", + is => "rw", + default => "dirty", + ); + + package Foo; + use Moose; + + has 'dog' => ( + is => 'rw', + does => 'Dog', + ); +} + +my $obj = Foo->new; +isa_ok($obj, 'Foo'); + +ok(!$obj->can( 'talk' ), "... the role is not composed yet"); +ok(!$obj->can( 'fur' ), 'ditto'); +ok(!$obj->does('Dog'), '... we do not do any roles yet'); + +isnt( exception { + $obj->dog($obj) +}, undef, '... and setting the accessor fails (not a Dog yet)' ); + +Dog->meta->apply($obj); + +ok($obj->does('Dog'), '... we now do the Bark role'); +ok($obj->can('talk'), "... the role is now composed at the object level"); +ok($obj->can('fur'), "it has fur"); + +is($obj->talk, 'woof', '... got the right return value for the newly composed method'); + +is( exception { + $obj->dog($obj) +}, undef, '... and setting the accessor is okay' ); + +is($obj->fur, "dirty", "role attr initialized"); + +done_testing; diff --git a/t/roles/runtime_roles_and_nonmoose.t b/t/roles/runtime_roles_and_nonmoose.t new file mode 100644 index 0000000..4365eb6 --- /dev/null +++ b/t/roles/runtime_roles_and_nonmoose.t @@ -0,0 +1,53 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Dog; + use Moose::Role; + + sub talk { 'woof' } + + package Foo; + use Moose; + + has 'dog' => ( + is => 'rw', + does => 'Dog', + ); + + no Moose; + + package Bar; + + sub new { + return bless {}, shift; + } +} + +my $bar = Bar->new; +isa_ok($bar, 'Bar'); + +my $foo = Foo->new; +isa_ok($foo, 'Foo'); + +ok(!$bar->can( 'talk' ), "... the role is not composed yet"); + +isnt( exception { + $foo->dog($bar) +}, undef, '... and setting the accessor fails (not a Dog yet)' ); + +Dog->meta->apply($bar); + +ok($bar->can('talk'), "... the role is now composed at the object level"); + +is($bar->talk, 'woof', '... got the right return value for the newly composed method'); + +is( exception { + $foo->dog($bar) +}, undef, '... and setting the accessor is okay' ); + +done_testing; diff --git a/t/roles/runtime_roles_w_params.t b/t/roles/runtime_roles_w_params.t new file mode 100644 index 0000000..6d5353f --- /dev/null +++ b/t/roles/runtime_roles_w_params.t @@ -0,0 +1,70 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + has 'bar' => (is => 'ro'); + + package Bar; + use Moose::Role; + + has 'baz' => (is => 'ro', default => 'BAZ'); +} + +# normal ... +{ + my $foo = Foo->new(bar => 'BAR'); + isa_ok($foo, 'Foo'); + + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + + is( exception { + Bar->meta->apply($foo) + }, undef, '... this works' ); + + is($foo->bar, 'BAR', '... got the expect value'); + ok($foo->can('baz'), '... we have baz method now'); + is($foo->baz, 'BAZ', '... got the expect value'); +} + +# with extra params ... +{ + my $foo = Foo->new(bar => 'BAR'); + isa_ok($foo, 'Foo'); + + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + + is( exception { + Bar->meta->apply($foo, (rebless_params => { baz => 'FOO-BAZ' })) + }, undef, '... this works' ); + + is($foo->bar, 'BAR', '... got the expect value'); + ok($foo->can('baz'), '... we have baz method now'); + is($foo->baz, 'FOO-BAZ', '... got the expect value'); +} + +# with extra params ... +{ + my $foo = Foo->new(bar => 'BAR'); + isa_ok($foo, 'Foo'); + + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + + is( exception { + Bar->meta->apply($foo, (rebless_params => { bar => 'FOO-BAR', baz => 'FOO-BAZ' })) + }, undef, '... this works' ); + + is($foo->bar, 'FOO-BAR', '... got the expect value'); + ok($foo->can('baz'), '... we have baz method now'); + is($foo->baz, 'FOO-BAZ', '... got the expect value'); +} + +done_testing; diff --git a/t/roles/use_base_does.t b/t/roles/use_base_does.t new file mode 100644 index 0000000..a3d5b41 --- /dev/null +++ b/t/roles/use_base_does.t @@ -0,0 +1,42 @@ +use strict; +use warnings; +use Test::More; + +{ + package Foo::Role; + use Moose::Role; +} + +{ + package Foo; + use Moose; + + with 'Foo::Role'; +} + +{ + package Foo::Sub; + use parent -norequire => 'Foo'; +} + +{ + package Foo::Sub2; + use parent -norequire => 'Foo'; +} + +{ + package Foo::Sub3; + use parent -norequire => 'Foo'; +} + +{ + package Foo::Sub4; + use parent -norequire => 'Foo'; +} + +ok(Foo::Sub->does('Foo::Role'), "class does Foo::Role"); +ok(Foo::Sub2->new->does('Foo::Role'), "object does Foo::Role"); +ok(!Foo::Sub3->does('Bar::Role'), "class doesn't do Bar::Role"); +ok(!Foo::Sub4->new->does('Bar::Role'), "object doesn't do Bar::Role"); + +done_testing; diff --git a/t/test_moose/test_moose.t b/t/test_moose/test_moose.t new file mode 100644 index 0000000..e277cfa --- /dev/null +++ b/t/test_moose/test_moose.t @@ -0,0 +1,10 @@ +use strict; +use warnings; + +use Test::More; + +BEGIN { + use_ok('Test::Moose'); +} + +done_testing; diff --git a/t/test_moose/test_moose_does_ok.t b/t/test_moose/test_moose_does_ok.t new file mode 100644 index 0000000..9ba5b68 --- /dev/null +++ b/t/test_moose/test_moose_does_ok.t @@ -0,0 +1,58 @@ +use strict; +use warnings; + +use Test::Builder::Tester; +use Test::More; + +use Test::Moose; + +{ + package Foo; + use Moose::Role; +} + +{ + package Bar; + use Moose; + + with qw/Foo/; +} + +{ + package Baz; + use Moose; +} + +# class ok + +test_out('ok 1 - does_ok class'); + +does_ok('Bar','Foo','does_ok class'); + +# class fail + +test_out ('not ok 2 - does_ok class fail'); +test_fail (+2); + +does_ok('Baz','Foo','does_ok class fail'); + +# object ok + +my $bar = Bar->new; + +test_out ('ok 3 - does_ok object'); + +does_ok ($bar,'Foo','does_ok object'); + +# object fail + +my $baz = Baz->new; + +test_out ('not ok 4 - does_ok object fail'); +test_fail (+2); + +does_ok ($baz,'Foo','does_ok object fail'); + +test_test ('does_ok'); + +done_testing; diff --git a/t/test_moose/test_moose_has_attribute_ok.t b/t/test_moose/test_moose_has_attribute_ok.t new file mode 100644 index 0000000..9e77dd4 --- /dev/null +++ b/t/test_moose/test_moose_has_attribute_ok.t @@ -0,0 +1,45 @@ +use strict; +use warnings; + +use Test::Builder::Tester; +use Test::More; + +use Test::Moose; + +{ + package Foo; + use Moose; + + has 'foo', is => 'bare'; +} + +{ + package Bar; + use Moose; + + extends 'Foo'; + + has 'bar', is => 'bare'; +} + + +test_out('ok 1 - ... has_attribute_ok(Foo, foo) passes'); + +has_attribute_ok('Foo', 'foo', '... has_attribute_ok(Foo, foo) passes'); + +test_out ('not ok 2 - ... has_attribute_ok(Foo, bar) fails'); +test_fail (+2); + +has_attribute_ok('Foo', 'bar', '... has_attribute_ok(Foo, bar) fails'); + +test_out('ok 3 - ... has_attribute_ok(Bar, foo) passes'); + +has_attribute_ok('Bar', 'foo', '... has_attribute_ok(Bar, foo) passes'); + +test_out('ok 4 - ... has_attribute_ok(Bar, bar) passes'); + +has_attribute_ok('Bar', 'bar', '... has_attribute_ok(Bar, bar) passes'); + +test_test ('has_attribute_ok'); + +done_testing; diff --git a/t/test_moose/test_moose_meta_ok.t b/t/test_moose/test_moose_meta_ok.t new file mode 100644 index 0000000..1556379 --- /dev/null +++ b/t/test_moose/test_moose_meta_ok.t @@ -0,0 +1,29 @@ +use strict; +use warnings; + +use Test::Builder::Tester; +use Test::More; + +use Test::Moose; + +{ + package Foo; + use Moose; +} + +{ + package Bar; +} + +test_out('ok 1 - ... meta_ok(Foo) passes'); + +meta_ok('Foo', '... meta_ok(Foo) passes'); + +test_out ('not ok 2 - ... meta_ok(Bar) fails'); +test_fail (+2); + +meta_ok('Bar', '... meta_ok(Bar) fails'); + +test_test ('meta_ok'); + +done_testing; diff --git a/t/test_moose/with_immutable.t b/t/test_moose/with_immutable.t new file mode 100644 index 0000000..6536e70 --- /dev/null +++ b/t/test_moose/with_immutable.t @@ -0,0 +1,36 @@ +use strict; +use warnings; + +use Test::Builder::Tester; +use Test::More; + +use Test::Moose; + +{ + package Foo; + use Moose; +} + +{ + package Bar; + use Moose; +} + +package main; + +test_out("ok 1", "not ok 2"); +test_fail(+2); +my $ret = with_immutable { + ok(Foo->meta->is_mutable); +} qw(Foo); +test_test('with_immutable failure'); +ok(!$ret, "one of our tests failed"); + +test_out("ok 1", "ok 2"); +$ret = with_immutable { + ok(Bar->meta->find_method_by_name('new')); +} qw(Bar); +test_test('with_immutable success'); +ok($ret, "all tests succeeded"); + +done_testing; diff --git a/t/todo_tests/exception_reflects_failed_constraint.t b/t/todo_tests/exception_reflects_failed_constraint.t new file mode 100644 index 0000000..6375fab --- /dev/null +++ b/t/todo_tests/exception_reflects_failed_constraint.t @@ -0,0 +1,31 @@ +use strict; +use warnings; + +# In the case where a child type constraint's parent constraint fails, +# the exception should reference the parent type constraint that actually +# failed instead of always referencing the child'd type constraint + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +is( exception { + subtype 'ParentConstraint' => as 'Str' => where {0}; +}, undef, 'specified parent type constraint' ); + +my $tc; +is( exception { + $tc = subtype 'ChildConstraint' => as 'ParentConstraint' => where {1}; +}, undef, 'specified child type constraint' ); + +{ + my $errmsg = $tc->validate(); + + TODO: { + local $TODO = 'Not yet supported'; + ok($errmsg !~ /Validation failed for 'ChildConstraint'/, 'exception references failing parent constraint'); + }; +} + +done_testing; diff --git a/t/todo_tests/immutable_n_around.t b/t/todo_tests/immutable_n_around.t new file mode 100644 index 0000000..04d3980 --- /dev/null +++ b/t/todo_tests/immutable_n_around.t @@ -0,0 +1,52 @@ +use strict; +use warnings; + +use Test::More; + +# if make_immutable is removed from the following code the tests pass + +{ + package Foo; + use Moose; + + has foo => ( is => "ro" ); + + package Bar; + use Moose; + + extends qw(Foo); + + around new => sub { + my $next = shift; + my ( $self, @args ) = @_; + $self->$next( foo => 42 ); + }; + + package Gorch; + use Moose; + + extends qw(Bar); + + package Zoink; + use Moose; + + extends qw(Gorch); + +} + +my @classes = qw(Foo Bar Gorch Zoink); + +tests: { + is( Foo->new->foo, undef, "base class (" . (Foo->meta->is_immutable ? "immutable" : "mutable") . ")" ); + is( Bar->new->foo, 42, "around new called on Bar->new (" . (Bar->meta->is_immutable ? "immutable" : "mutable") . ")" ); + is( Gorch->new->foo, 42, "around new called on Gorch->new (" . (Gorch->meta->is_immutable ? "immutable" : "mutable") . ")" ); + is( Zoink->new->foo, 42, "around new called Zoink->new (" . (Zoink->meta->is_immutable ? "immutable" : "mutable") . ")" ); + + if ( @classes ) { + local $SIG{__WARN__} = sub {}; + ( shift @classes )->meta->make_immutable; + redo tests; + } +} + +done_testing; diff --git a/t/todo_tests/moose_and_threads.t b/t/todo_tests/moose_and_threads.t new file mode 100644 index 0000000..a0316fe --- /dev/null +++ b/t/todo_tests/moose_and_threads.t @@ -0,0 +1,38 @@ +use strict; +use warnings; + +use Test::More; + + +=pod + +See this for some details: + +http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=476579 + +Here is the basic test case, it segfaults, so I am going +to leave it commented out. Basically it seems that there +is some bad interaction between the ??{} construct that +is used in the "parser" for type definitions and threading +so probably the fix would involve removing the ??{} usage +for something else. + +use threads; + +{ + package Foo; + use Moose; + has "bar" => (is => 'rw', isa => "Str | Num"); +} + +my $thr = threads->create(sub {}); +$thr->join(); + +=cut + +{ + local $TODO = 'This is just a stub for the test, see the POD'; + fail('Moose type constraints and threads dont get along'); +} + +done_testing; diff --git a/t/todo_tests/replacing_super_methods.t b/t/todo_tests/replacing_super_methods.t new file mode 100644 index 0000000..eef494a --- /dev/null +++ b/t/todo_tests/replacing_super_methods.t @@ -0,0 +1,42 @@ +use strict; +use warnings; +use Test::More; + +my ($super_called, $sub_called, $new_super_called) = (0, 0, 0); +{ + package Foo; + use Moose; + + sub foo { $super_called++ } +} + +{ + package Foo::Sub; + use Moose; + extends 'Foo'; + + override foo => sub { + $sub_called++; + super(); + }; +} + +Foo::Sub->new->foo; +is($super_called, 1, "super called"); +is($new_super_called, 0, "new super not called"); +is($sub_called, 1, "sub called"); + +($super_called, $sub_called, $new_super_called) = (0, 0, 0); + +Foo->meta->add_method(foo => sub { + $new_super_called++; +}); + +Foo::Sub->new->foo; +{ local $TODO = "super doesn't get replaced"; +is($super_called, 0, "super not called"); +is($new_super_called, 1, "new super called"); +} +is($sub_called, 1, "sub called"); + +done_testing; diff --git a/t/todo_tests/required_role_accessors.t b/t/todo_tests/required_role_accessors.t new file mode 100644 index 0000000..d25f6e8 --- /dev/null +++ b/t/todo_tests/required_role_accessors.t @@ -0,0 +1,57 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +{ + package Foo::API; + use Moose::Role; + + requires 'foo'; +} + +{ + package Foo; + use Moose::Role; + + has foo => (is => 'ro'); + + with 'Foo::API'; +} + +{ + package Foo::Class; + use Moose; + { our $TODO; local $TODO = "role accessors don't satisfy other role requires"; + ::is( ::exception { with 'Foo' }, undef, 'requirements are satisfied properly' ); + } +} + +{ + package Bar; + use Moose::Role; + + requires 'baz'; + + has bar => (is => 'ro'); +} + +{ + package Baz; + use Moose::Role; + + requires 'bar'; + + has baz => (is => 'ro'); +} + +{ + package BarBaz; + use Moose; + + { our $TODO; local $TODO = "role accessors don't satisfy other role requires"; + ::is( ::exception { with qw(Bar Baz) }, undef, 'requirements are satisfied properly' ); + } +} + +done_testing; diff --git a/t/todo_tests/role_attr_methods_original_package.t b/t/todo_tests/role_attr_methods_original_package.t new file mode 100644 index 0000000..ca0f7ce --- /dev/null +++ b/t/todo_tests/role_attr_methods_original_package.t @@ -0,0 +1,45 @@ +use strict; +use warnings; + +use Test::More 0.88; + +{ + package Some::Role; + use Moose::Role; + + has 'thing' => ( + is => 'ro', + ); + + sub foo { 42 } +} + +{ + package Some::Class; + use Moose; + + with 'Some::Role'; +} + +my $attr = Some::Class->meta()->get_attribute('thing'); + +# See RT #84563 +for my $method ( @{ $attr->associated_methods() } ) { +TODO: { + local $TODO + = q{Methods generated from role-provided attributes don't know their original package}; + is( + $method->original_package_name(), + 'Some::Role', + 'original_package_name for methods generated from role attribute should match the role' + ); + } +} + +is( + Some::Class->meta()->get_method('foo')->original_package_name(), + 'Some::Role', + 'original_package_name for methods from role should match the role' +); + +done_testing(); diff --git a/t/todo_tests/role_insertion_order.t b/t/todo_tests/role_insertion_order.t new file mode 100644 index 0000000..151c26e --- /dev/null +++ b/t/todo_tests/role_insertion_order.t @@ -0,0 +1,41 @@ +use strict; +use warnings; +use Test::More; + +{ + package Foo::Role; + use Moose::Role; + has 'a' => (is => 'ro'); + has 'b' => (is => 'ro'); + has 'c' => (is => 'ro'); +} + +{ + package Foo; + use Moose; + has 'd' => (is => 'ro'); + with 'Foo::Role'; + has 'e' => (is => 'ro'); +} + +my %role_insertion_order = ( + a => 0, + b => 1, + c => 2, +); + +is_deeply({ map { $_->name => $_->insertion_order } map { Foo::Role->meta->get_attribute($_) } Foo::Role->meta->get_attribute_list }, \%role_insertion_order, "right insertion order within the role"); + +my %class_insertion_order = ( + d => 0, + a => 1, + b => 2, + c => 3, + e => 4, +); + +{ local $TODO = "insertion order is lost during role application"; +is_deeply({ map { $_->name => $_->insertion_order } Foo->meta->get_all_attributes }, \%class_insertion_order, "right insertion order within the class"); +} + +done_testing; diff --git a/t/todo_tests/various_role_features.t b/t/todo_tests/various_role_features.t new file mode 100644 index 0000000..b8a3c4a --- /dev/null +++ b/t/todo_tests/various_role_features.t @@ -0,0 +1,271 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +sub req_or_has ($$) { + my ( $role, $method ) = @_; + local $Test::Builder::Level = $Test::Builder::Level + 1; + if ( $role ) { + ok( + $role->has_method($method) || $role->requires_method($method), + $role->name . " has or requires method $method" + ); + } else { + fail("role has or requires method $method"); + } +} + +{ + package Bar; + use Moose::Role; + + # this role eventually adds three methods, qw(foo bar xxy), but only one is + # known when it's still a role + + has foo => ( is => "rw" ); + + has gorch => ( reader => "bar" ); + + sub xxy { "BAAAD" } + + package Gorch; + use Moose::Role; + + # similarly this role gives attr and gorch_method + + has attr => ( is => "rw" ); + + sub gorch_method { "gorch method" } + + around dandy => sub { shift->(@_) . "bar" }; + + package Quxx; + use Moose; + + sub dandy { "foo" } + + # this object will be used in an attr of Foo to test that Foo can do the + # Gorch interface + + with qw(Gorch); + + package Dancer; + use Moose::Role; + + requires "twist"; + + package Dancer::Ballerina; + use Moose; + + with qw(Dancer); + + sub twist { } + + sub pirouette { } + + package Dancer::Robot; + use Moose::Role; + + # this doesn't fail but it produces a requires in the role + # the order doesn't matter + has twist => ( is => "rw" ); + ::is( ::exception { with qw(Dancer) }, undef ); + + package Dancer::Something; + use Moose; + + # this fail even though the method already exists + + has twist => ( is => "rw" ); + + { + ::is( ::exception { with qw(Dancer) }, undef ); + } + + package Dancer::80s; + use Moose; + + # this should pass because ::Robot has the attribute to fill in the requires + # but due to the deferrence logic that doesn't actually work + { + local our $TODO = "attribute accessor in role doesn't satisfy role requires"; + ::is( ::exception { with qw(Dancer::Robot) }, undef ); + } + + package Foo; + use Moose; + + with qw(Bar); + + has oink => ( + is => "rw", + handles => "Gorch", # should handles take the same arguments as 'with'? Meta::Role::Application::Delegation? + default => sub { Quxx->new }, + ); + + has dancer => ( + is => "rw", + does => "Dancer", + handles => "Dancer", + default => sub { Dancer::Ballerina->new }, + ); + + sub foo { 42 } + + sub bar { 33 } + + sub xxy { 7 } + + package Tree; + use Moose::Role; + + has bark => ( is => "rw" ); + + package Dog; + use Moose::Role; + + sub bark { warn "woof!" }; + + package EntPuppy; + use Moose; + + { + local our $TODO = "attrs and methods from a role should clash"; + ::isnt( ::exception { with qw(Tree Dog) }, undef ); + } +} + +# these fail because of the deferral logic winning over actual methods +# this might be tricky to fix due to the 'sub foo {}; has foo => ( )' hack +# we've been doing for a long while, though I doubt people relied on it for +# anything other than fulfilling 'requires' +{ + local $TODO = "attributes from role overwrite class methods"; + is( Foo->new->foo, 42, "attr did not zap overriding method" ); + is( Foo->new->bar, 33, "attr did not zap overriding method" ); +} +is( Foo->new->xxy, 7, "method did not zap overriding method" ); # duh + +# these pass, simple delegate +# mostly they are here to contrast the next blck +can_ok( Foo->new->oink, "dandy" ); +can_ok( Foo->new->oink, "attr" ); +can_ok( Foo->new->oink, "gorch_method" ); + +ok( Foo->new->oink->does("Gorch"), "Quxx does Gorch" ); + + +# these are broken because 'attr' is not technically part of the interface +can_ok( Foo->new, "gorch_method" ); +{ + local $TODO = "accessor methods from a role are omitted in handles role"; + can_ok( Foo->new, "attr" ); +} + +{ + local $TODO = "handles role doesn't add the role to the ->does of the delegate's parent class"; + ok( Foo->new->does("Gorch"), "Foo does Gorch" ); +} + + +# these work +can_ok( Foo->new->dancer, "pirouette" ); +can_ok( Foo->new->dancer, "twist" ); + +can_ok( Foo->new, "twist" ); +ok( !Foo->new->can("pirouette"), "can't pirouette, not part of the iface" ); + +{ + local $TODO = "handles role doesn't add the role to the ->does of the delegate's parent class"; + ok( Foo->new->does("Dancer") ); +} + + + + +my $gorch = Gorch->meta; + +isa_ok( $gorch, "Moose::Meta::Role" ); + +ok( $gorch->has_attribute("attr"), "has attribute 'attr'" ); +isa_ok( $gorch->get_attribute("attr"), "Moose::Meta::Role::Attribute" ); + +req_or_has($gorch, "gorch_method"); +ok( $gorch->has_method("gorch_method"), "has_method gorch_method" ); +ok( !$gorch->requires_method("gorch_method"), "requires gorch method" ); +isa_ok( $gorch->get_method("gorch_method"), "Moose::Meta::Method" ); + +{ + local $TODO = "method modifier doesn't yet create a method requirement or meta object"; + req_or_has($gorch, "dandy" ); + + # this specific test is maybe not backwards compat, but in theory it *does* + # require that method to exist + ok( $gorch->requires_method("dandy"), "requires the dandy method for the modifier" ); +} + +{ + local $TODO = "attribute related methods are not yet known by the role"; + # we want this to be a part of the interface, somehow + req_or_has($gorch, "attr"); + ok( $gorch->has_method("attr"), "has_method attr" ); + isa_ok( $gorch->get_method("attr"), "Moose::Meta::Method" ); + isa_ok( $gorch->get_method("attr"), "Moose::Meta::Method::Accessor" ); +} + +my $robot = Dancer::Robot->meta; + +isa_ok( $robot, "Moose::Meta::Role" ); + +ok( $robot->has_attribute("twist"), "has attr 'twist'" ); +isa_ok( $robot->get_attribute("twist"), "Moose::Meta::Role::Attribute" ); + +{ + req_or_has($robot, "twist"); + + local $TODO = "attribute related methods are not yet known by the role"; + ok( $robot->has_method("twist"), "has twist method" ); + isa_ok( $robot->get_method("twist"), "Moose::Meta::Method" ); + isa_ok( $robot->get_method("twist"), "Moose::Meta::Method::Accessor" ); +} + +done_testing; + +__END__ + +I think Attribute needs to be refactored in some way to better support roles. + +There are several possible ways to do this, all of them seem plausible to me. + +The first approach would be to change the attribute class to allow it to be +queried about the methods it would install. + +Then we instantiate the attribute in the role, and instead of deferring the +arguments, we just make an C<unpack>ish method. + +Then we can interrogate the attr when adding it to the role, and generate stub +methods for all the methods it would produce. + +A second approach is kinda like the Immutable hack: wrap the attr in an +anonmyous class that disables part of its interface. + +A third method would be to create an Attribute::Partial object that would +provide a more role-ish behavior, and to do this independently of the actual +Attribute class. + +Something similar can be done for method modifiers, but I think that's even simpler. + + + +The benefits of doing this are: + +* Much better introspection of roles + +* More correctness in many cases (in my opinion anyway) + +* More roles are more usable as interface declarations, without having to split + them into two pieces (one for the interface with a bunch of requires(), and + another for the actual impl with the problematic attrs (and stub methods to + fix the accessors) and method modifiers (dunno if this can even work at all) diff --git a/t/todo_tests/wrong-inner.t b/t/todo_tests/wrong-inner.t new file mode 100644 index 0000000..5160ca4 --- /dev/null +++ b/t/todo_tests/wrong-inner.t @@ -0,0 +1,37 @@ +use strict; +use warnings; + +use Test::More; + +# see RT#89397 + +{ + package A; + use Moose; + sub run { + my $self = shift; + inner(); + $self->cleanup; + } + sub cleanup { + inner(); + } +} + +{ + package B; + our $run; + use Moose; + extends 'A'; + augment run => sub { + my $self = shift; + $run++; + }; +} + +B->new->run(); + +local $TODO = 'wtf is going on here??'; +is($B::run, 1, 'B::run is only called once'); + +done_testing; diff --git a/t/type_constraints/advanced_type_creation.t b/t/type_constraints/advanced_type_creation.t new file mode 100644 index 0000000..b12a75d --- /dev/null +++ b/t/type_constraints/advanced_type_creation.t @@ -0,0 +1,95 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util::TypeConstraints; +use Moose::Meta::TypeConstraint::Parameterized; + +my $r = Moose::Util::TypeConstraints->get_type_constraint_registry; + +## Containers in unions ... + +# Array of Ints or Strings + +my $array_of_ints_or_strings = Moose::Util::TypeConstraints::create_parameterized_type_constraint('ArrayRef[Int|Str]'); +isa_ok($array_of_ints_or_strings, 'Moose::Meta::TypeConstraint::Parameterized'); + +ok($array_of_ints_or_strings->check([ 1, 'two', 3 ]), '... this passed the type check'); +ok($array_of_ints_or_strings->check([ 1, 2, 3 ]), '... this passed the type check'); +ok($array_of_ints_or_strings->check([ 'one', 'two', 'three' ]), '... this passed the type check'); + +ok(!$array_of_ints_or_strings->check([ 1, [], 'three' ]), '... this didnt pass the type check'); + +$r->add_type_constraint($array_of_ints_or_strings); + +# Array of Ints or HashRef + +my $array_of_ints_or_hash_ref = Moose::Util::TypeConstraints::create_parameterized_type_constraint('ArrayRef[Int | HashRef]'); +isa_ok($array_of_ints_or_hash_ref, 'Moose::Meta::TypeConstraint::Parameterized'); + +ok($array_of_ints_or_hash_ref->check([ 1, {}, 3 ]), '... this passed the type check'); +ok($array_of_ints_or_hash_ref->check([ 1, 2, 3 ]), '... this passed the type check'); +ok($array_of_ints_or_hash_ref->check([ {}, {}, {} ]), '... this passed the type check'); + +ok(!$array_of_ints_or_hash_ref->check([ {}, [], 3 ]), '... this didnt pass the type check'); + +$r->add_type_constraint($array_of_ints_or_hash_ref); + +# union of Arrays of Str | Int or Arrays of Int | Hash + +# we can't build this using the simplistic parser +# we have, so we have to do it by hand - SL + +my $pure_insanity = Moose::Util::TypeConstraints::create_type_constraint_union('ArrayRef[Int|Str] | ArrayRef[Int | HashRef]'); +isa_ok($pure_insanity, 'Moose::Meta::TypeConstraint::Union'); + +ok($pure_insanity->check([ 1, {}, 3 ]), '... this passed the type check'); +ok($pure_insanity->check([ 1, 'Str', 3 ]), '... this passed the type check'); + +ok(!$pure_insanity->check([ 1, {}, 'foo' ]), '... this didnt pass the type check'); +ok(!$pure_insanity->check([ [], {}, 1 ]), '... this didnt pass the type check'); + +## Nested Containers ... + +# Array of Ints + +my $array_of_ints = Moose::Util::TypeConstraints::create_parameterized_type_constraint('ArrayRef[Int]'); +isa_ok($array_of_ints, 'Moose::Meta::TypeConstraint::Parameterized'); +isa_ok($array_of_ints, 'Moose::Meta::TypeConstraint'); + +ok($array_of_ints->check([ 1, 2, 3, 4 ]), '... [ 1, 2, 3, 4 ] passed successfully'); +ok(!$array_of_ints->check([qw/foo bar baz/]), '... [qw/foo bar baz/] failed successfully'); +ok(!$array_of_ints->check([ 1, 2, 3, qw/foo bar/]), '... [ 1, 2, 3, qw/foo bar/] failed successfully'); + +ok(!$array_of_ints->check(1), '... 1 failed successfully'); +ok(!$array_of_ints->check({}), '... {} failed successfully'); +ok(!$array_of_ints->check(sub { () }), '... sub { () } failed successfully'); + +# Array of Array of Ints + +my $array_of_array_of_ints = Moose::Util::TypeConstraints::create_parameterized_type_constraint('ArrayRef[ArrayRef[Int]]'); +isa_ok($array_of_array_of_ints, 'Moose::Meta::TypeConstraint::Parameterized'); +isa_ok($array_of_array_of_ints, 'Moose::Meta::TypeConstraint'); + +ok($array_of_array_of_ints->check( + [[ 1, 2, 3 ], [ 4, 5, 6 ]] +), '... [[ 1, 2, 3 ], [ 4, 5, 6 ]] passed successfully'); +ok(!$array_of_array_of_ints->check( + [[ 1, 2, 3 ], [ qw/foo bar/ ]] +), '... [[ 1, 2, 3 ], [ qw/foo bar/ ]] failed successfully'); + +# Array of Array of Array of Ints + +my $array_of_array_of_array_of_ints = Moose::Util::TypeConstraints::create_parameterized_type_constraint('ArrayRef[ArrayRef[ArrayRef[Int]]]'); +isa_ok($array_of_array_of_array_of_ints, 'Moose::Meta::TypeConstraint::Parameterized'); +isa_ok($array_of_array_of_array_of_ints, 'Moose::Meta::TypeConstraint'); + +ok($array_of_array_of_array_of_ints->check( + [[[ 1, 2, 3 ], [ 4, 5, 6 ]], [[ 7, 8, 9 ]]] +), '... [[[ 1, 2, 3 ], [ 4, 5, 6 ]], [[ 7, 8, 9 ]]] passed successfully'); +ok(!$array_of_array_of_array_of_ints->check( + [[[ 1, 2, 3 ]], [[ qw/foo bar/ ]]] +), '... [[[ 1, 2, 3 ]], [[ qw/foo bar/ ]]] failed successfully'); + +done_testing; diff --git a/t/type_constraints/class_subtypes.t b/t/type_constraints/class_subtypes.t new file mode 100644 index 0000000..bc90209 --- /dev/null +++ b/t/type_constraints/class_subtypes.t @@ -0,0 +1,141 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; +use Moose::Meta::TypeConstraint; + + +## Create a subclass with a custom method + +{ + package Test::Moose::Meta::TypeConstraint::AnySubType; + use Moose; + extends 'Moose::Meta::TypeConstraint'; + + sub my_custom_method { + return 1; + } +} + +my $Int = find_type_constraint('Int'); +ok $Int, 'Got a good type constraint'; + +my $parent = Test::Moose::Meta::TypeConstraint::AnySubType->new({ + name => "Test::Moose::Meta::TypeConstraint::AnySubType" , + parent => $Int, +}); + +ok $parent, 'Created type constraint'; +ok $parent->check(1), 'Correctly passed'; +ok ! $parent->check('a'), 'correctly failed'; +ok $parent->my_custom_method, 'found the custom method'; + +my $subtype1 = subtype 'another_subtype' => as $parent; + +ok $subtype1, 'Created type constraint'; +ok $subtype1->check(1), 'Correctly passed'; +ok ! $subtype1->check('a'), 'correctly failed'; +ok $subtype1->my_custom_method, 'found the custom method'; + + +my $subtype2 = subtype 'another_subtype' => as $subtype1 => where { $_ < 10 }; + +ok $subtype2, 'Created type constraint'; +ok $subtype2->check(1), 'Correctly passed'; +ok ! $subtype2->check('a'), 'correctly failed'; +ok ! $subtype2->check(100), 'correctly failed'; + +ok $subtype2->my_custom_method, 'found the custom method'; + + +{ + package Foo; + + use Moose; +} + +{ + package Bar; + + use Moose; + + extends 'Foo'; +} + +{ + package Baz; + + use Moose; +} + +my $foo = class_type 'Foo'; +my $isa_foo = subtype 'IsaFoo' => as $foo; + +ok $isa_foo, 'Created subtype of Foo type'; +ok $isa_foo->check( Foo->new ), 'Foo passes check'; +ok $isa_foo->check( Bar->new ), 'Bar passes check'; +ok ! $isa_foo->check( Baz->new ), 'Baz does not pass check'; +like $foo->get_message( Baz->new ), qr/^Validation failed for 'Foo' with value .*Baz.* \(not isa Foo\)/, 'Better validation message'; + +# Maybe in the future this *should* inherit? +like $isa_foo->get_message( Baz->new ), qr/^Validation failed for 'IsaFoo' with value .*Baz.*/, "Subtypes do not automatically inherit parent type's message"; + + +# Implicit types +{ + package Quux; + + use Moose; + + has age => ( + isa => 'Positive', + is => 'bare', + ); +} + +like( exception { + Quux->new(age => 3) +}, qr/^Attribute \(age\) does not pass the type constraint because: Validation failed for 'Positive' with value 3 \(not isa Positive\)/ ); + +is( exception { + Quux->new(age => (bless {}, 'Positive')); +}, undef ); + +eval " + package Positive; + use Moose; +"; + +like( exception { + Quux->new(age => 3) +}, qr/^Attribute \(age\) does not pass the type constraint because: Validation failed for 'Positive' with value 3 \(not isa Positive\)/ ); + +is( exception { + Quux->new(age => Positive->new) +}, undef ); + +class_type 'Negative' => message { "$_ is not a Negative Nancy" }; + +{ + package Quux::Ier; + + use Moose; + + has age => ( + isa => 'Negative', + is => 'bare', + ); +} + +like( exception { + Quux::Ier->new(age => 3) +}, qr/^Attribute \(age\) does not pass the type constraint because: 3 is not a Negative Nancy / ); + +is( exception { + Quux::Ier->new(age => (bless {}, 'Negative')) +}, undef ); + +done_testing; diff --git a/t/type_constraints/class_type_constraint.t b/t/type_constraints/class_type_constraint.t new file mode 100644 index 0000000..c4f4afc --- /dev/null +++ b/t/type_constraints/class_type_constraint.t @@ -0,0 +1,125 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +{ + package Gorch; + use Moose; + + package Bar; + use Moose; + + package Foo; + use Moose; + + extends qw(Bar Gorch); + +} + +is( exception { class_type 'Beep' }, undef, 'class_type keyword works' ); +is( exception { class_type('Boop', message { "${_} is not a Boop" }) }, undef, 'class_type keywork works with message' ); + +{ + my $type = find_type_constraint("Foo"); + + is( $type->class, "Foo", "class attribute" ); + + ok( !$type->is_subtype_of('Foo'), "Foo is not subtype of Foo" ); + ok( !$type->is_subtype_of($type), '$foo_type is not subtype of $foo_type' ); + + ok( $type->is_subtype_of("Gorch"), "subtype of gorch" ); + + ok( $type->is_subtype_of("Bar"), "subtype of bar" ); + + ok( $type->is_subtype_of("Object"), "subtype of Object" ); + + ok( !$type->is_subtype_of("ThisTypeDoesNotExist"), "not subtype of undefined type" ); + ok( !$type->is_a_type_of("ThisTypeDoesNotExist"), "not type of undefined type" ); + + ok( find_type_constraint("Bar")->check(Foo->new), "Foo passes Bar" ); + ok( find_type_constraint("Bar")->check(Bar->new), "Bar passes Bar" ); + ok( !find_type_constraint("Gorch")->check(Bar->new), "but Bar doesn't pass Gorch"); + + ok( find_type_constraint("Beep")->check( bless {} => 'Beep' ), "Beep passes Beep" ); + my $boop = find_type_constraint("Boop"); + ok( $boop->has_message, 'Boop has a message'); + my $error = $boop->get_message(Foo->new); + like( $error, qr/is not a Boop/, 'boop gives correct error message'); + + + ok( $type->equals($type), "equals self" ); + ok( $type->equals(Moose::Meta::TypeConstraint::Class->new( name => "__ANON__", class => "Foo" )), "equals anon constraint of same value" ); + ok( $type->equals(Moose::Meta::TypeConstraint::Class->new( name => "Oink", class => "Foo" )), "equals differently named constraint of same value" ); + ok( !$type->equals(Moose::Meta::TypeConstraint::Class->new( name => "__ANON__", class => "Bar" )), "doesn't equal other anon constraint" ); + ok( $type->is_subtype_of(Moose::Meta::TypeConstraint::Class->new( name => "__ANON__", class => "Bar" )), "subtype of other anon constraint" ); +} + +{ + is( exception { class_type 'FooType', { class => 'Foo' } }, undef, 'class_type keyword with custom type name' ); + my $type = find_type_constraint('FooType'); + is( $type->class, 'Foo', "class attribute" ); + ok( !$type->is_subtype_of('Foo'), "FooType is not subtype of Foo" ); + ok( !$type->is_subtype_of($type), '$foo_type is not subtype of $foo_type' ); +} + + +{ + package Parent; + sub parent { } +} + +{ + package Child; + use parent -norequire => 'Parent'; +} + +{ + my $parent = Moose::Meta::TypeConstraint::Class->new( + name => 'Parent', + class => 'Parent', + ); + ok($parent->is_a_type_of('Parent')); + ok(!$parent->is_subtype_of('Parent')); + ok($parent->is_a_type_of($parent)); + ok(!$parent->is_subtype_of($parent)); + + my $child = Moose::Meta::TypeConstraint::Class->new( + name => 'Child', + class => 'Child', + ); + ok($child->is_a_type_of('Child')); + ok(!$child->is_subtype_of('Child')); + ok($child->is_a_type_of($child)); + ok(!$child->is_subtype_of($child)); + ok($child->is_a_type_of('Parent')); + ok($child->is_subtype_of('Parent')); + ok($child->is_a_type_of($parent)); + ok($child->is_subtype_of($parent)); +} + +{ + my $type; + is( exception { $type = class_type 'MyExampleClass' }, undef, 'Make initial class_type' ); + coerce 'MyExampleClass', from 'Str', via { bless {}, 'MyExampleClass' }; + # We test class_type keeping the existing type (not making a new one) here. + is( exception { is(class_type('MyExampleClass'), $type, 're-running class_type gives same type') }, undef, 'No exception making duplicate class_type' );; + + # Next define a class which needs this type and it's original coercion + # Note this has to be after the 2nd class_type call to test the bug as M::M::Attribute grabs + # the type constraint which is there at the time the attribute decleration runs. + { + package HoldsExample; + use Moose; + + has foo => ( isa => 'MyExampleClass', is => 'ro', coerce => 1, required => 1 ); + no Moose; + } + + is( exception { isa_ok(HoldsExample->new(foo => "bar")->foo, 'MyExampleClass') }, undef, 'class_type coercion works' ); +} + +done_testing; diff --git a/t/type_constraints/coerced_parameterized_types.t b/t/type_constraints/coerced_parameterized_types.t new file mode 100644 index 0000000..10e3910 --- /dev/null +++ b/t/type_constraints/coerced_parameterized_types.t @@ -0,0 +1,55 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; +use Moose::Meta::TypeConstraint::Parameterized; + +BEGIN { + package MyList; + sub new { + my $class = shift; + bless { items => \@_ }, $class; + } + + sub items { + my $self = shift; + return @{ $self->{items} }; + } +} + +subtype 'MyList' => as 'Object' => where { $_->isa('MyList') }; + +is( exception { + coerce 'ArrayRef' + => from 'MyList' + => via { [ $_->items ] } +}, undef, '... created the coercion okay' ); + +my $mylist = Moose::Util::TypeConstraints::find_or_parse_type_constraint('MyList[Int]'); + +ok($mylist->check(MyList->new(10, 20, 30)), '... validated it correctly (pass)'); +ok(!$mylist->check(MyList->new(10, "two")), '... validated it correctly (fail)'); +ok(!$mylist->check([10]), '... validated it correctly (fail)'); + +subtype 'EvenList' => as 'MyList' => where { $_->items % 2 == 0 }; + +# XXX: get this to work *without* the declaration. I suspect it'll be a new +# method in Moose::Meta::TypeCoercion that will look at the parents of the +# coerced type as well. but will that be too "action at a distance"-ey? +is( exception { + coerce 'ArrayRef' + => from 'EvenList' + => via { [ $_->items ] } +}, undef, '... created the coercion okay' ); + +my $evenlist = Moose::Util::TypeConstraints::find_or_parse_type_constraint('EvenList[Int]'); + +ok(!$evenlist->check(MyList->new(10, 20, 30)), '... validated it correctly (fail)'); +ok($evenlist->check(MyList->new(10, 20, 30, 40)), '... validated it correctly (pass)'); +ok(!$evenlist->check(MyList->new(10, "two")), '... validated it correctly (fail)'); +ok(!$evenlist->check([10, 20]), '... validated it correctly (fail)'); + +done_testing; diff --git a/t/type_constraints/container_type_coercion.t b/t/type_constraints/container_type_coercion.t new file mode 100644 index 0000000..8ccb1bb --- /dev/null +++ b/t/type_constraints/container_type_coercion.t @@ -0,0 +1,63 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util::TypeConstraints; +use Moose::Meta::TypeConstraint::Parameterized; + +my $r = Moose::Util::TypeConstraints->get_type_constraint_registry; + +# Array of Ints + +my $array_of_ints = Moose::Meta::TypeConstraint::Parameterized->new( + name => 'ArrayRef[Int]', + parent => find_type_constraint('ArrayRef'), + type_parameter => find_type_constraint('Int'), +); +isa_ok($array_of_ints, 'Moose::Meta::TypeConstraint::Parameterized'); +isa_ok($array_of_ints, 'Moose::Meta::TypeConstraint'); + +$r->add_type_constraint($array_of_ints); + +is(find_type_constraint('ArrayRef[Int]'), $array_of_ints, '... found the type we just added'); + +# Hash of Ints + +my $hash_of_ints = Moose::Meta::TypeConstraint::Parameterized->new( + name => 'HashRef[Int]', + parent => find_type_constraint('HashRef'), + type_parameter => find_type_constraint('Int'), +); +isa_ok($hash_of_ints, 'Moose::Meta::TypeConstraint::Parameterized'); +isa_ok($hash_of_ints, 'Moose::Meta::TypeConstraint'); + +$r->add_type_constraint($hash_of_ints); + +is(find_type_constraint('HashRef[Int]'), $hash_of_ints, '... found the type we just added'); + +## now attempt a coercion + +{ + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + coerce 'ArrayRef[Int]' + => from 'HashRef[Int]' + => via { [ values %$_ ] }; + + has 'bar' => ( + is => 'ro', + isa => 'ArrayRef[Int]', + coerce => 1, + ); + +} + +my $foo = Foo->new(bar => { one => 1, two => 2, three => 3 }); +isa_ok($foo, 'Foo'); + +is_deeply([ sort @{$foo->bar} ], [ 1, 2, 3 ], '... our coercion worked!'); + +done_testing; diff --git a/t/type_constraints/container_type_constraint.t b/t/type_constraints/container_type_constraint.t new file mode 100644 index 0000000..a7120c5 --- /dev/null +++ b/t/type_constraints/container_type_constraint.t @@ -0,0 +1,70 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util::TypeConstraints; +use Moose::Meta::TypeConstraint::Parameterized; + +# Array of Ints + +my $array_of_ints = Moose::Meta::TypeConstraint::Parameterized->new( + name => 'ArrayRef[Int]', + parent => find_type_constraint('ArrayRef'), + type_parameter => find_type_constraint('Int'), +); +isa_ok($array_of_ints, 'Moose::Meta::TypeConstraint::Parameterized'); +isa_ok($array_of_ints, 'Moose::Meta::TypeConstraint'); + +ok($array_of_ints->check([ 1, 2, 3, 4 ]), '... [ 1, 2, 3, 4 ] passed successfully'); +ok(!$array_of_ints->check([qw/foo bar baz/]), '... [qw/foo bar baz/] failed successfully'); +ok(!$array_of_ints->check([ 1, 2, 3, qw/foo bar/]), '... [ 1, 2, 3, qw/foo bar/] failed successfully'); + +ok(!$array_of_ints->check(1), '... 1 failed successfully'); +ok(!$array_of_ints->check({}), '... {} failed successfully'); +ok(!$array_of_ints->check(sub { () }), '... sub { () } failed successfully'); + +# Hash of Ints + +my $hash_of_ints = Moose::Meta::TypeConstraint::Parameterized->new( + name => 'HashRef[Int]', + parent => find_type_constraint('HashRef'), + type_parameter => find_type_constraint('Int'), +); +isa_ok($hash_of_ints, 'Moose::Meta::TypeConstraint::Parameterized'); +isa_ok($hash_of_ints, 'Moose::Meta::TypeConstraint'); + +ok($hash_of_ints->check({ one => 1, two => 2, three => 3 }), '... { one => 1, two => 2, three => 3 } passed successfully'); +ok(!$hash_of_ints->check({ 1 => 'one', 2 => 'two', 3 => 'three' }), '... { 1 => one, 2 => two, 3 => three } failed successfully'); +ok(!$hash_of_ints->check({ 1 => 'one', 2 => 'two', three => 3 }), '... { 1 => one, 2 => two, three => 3 } failed successfully'); + +ok(!$hash_of_ints->check(1), '... 1 failed successfully'); +ok(!$hash_of_ints->check([]), '... [] failed successfully'); +ok(!$hash_of_ints->check(sub { () }), '... sub { () } failed successfully'); + +# Array of Array of Ints + +my $array_of_array_of_ints = Moose::Meta::TypeConstraint::Parameterized->new( + name => 'ArrayRef[ArrayRef[Int]]', + parent => find_type_constraint('ArrayRef'), + type_parameter => $array_of_ints, +); +isa_ok($array_of_array_of_ints, 'Moose::Meta::TypeConstraint::Parameterized'); +isa_ok($array_of_array_of_ints, 'Moose::Meta::TypeConstraint'); + +ok($array_of_array_of_ints->check( + [[ 1, 2, 3 ], [ 4, 5, 6 ]] +), '... [[ 1, 2, 3 ], [ 4, 5, 6 ]] passed successfully'); +ok(!$array_of_array_of_ints->check( + [[ 1, 2, 3 ], [ qw/foo bar/ ]] +), '... [[ 1, 2, 3 ], [ qw/foo bar/ ]] failed successfully'); + +{ + my $anon_type = Moose::Util::TypeConstraints::find_or_parse_type_constraint('ArrayRef[Foo]'); + isa_ok( $anon_type, 'Moose::Meta::TypeConstraint::Parameterized' ); + + my $param_type = $anon_type->type_parameter; + isa_ok( $param_type, 'Moose::Meta::TypeConstraint::Class' ); +} + +done_testing; diff --git a/t/type_constraints/custom_parameterized_types.t b/t/type_constraints/custom_parameterized_types.t new file mode 100644 index 0000000..ebe320c --- /dev/null +++ b/t/type_constraints/custom_parameterized_types.t @@ -0,0 +1,83 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; +use Moose::Meta::TypeConstraint::Parameterized; + +is( exception { + subtype 'AlphaKeyHash' => as 'HashRef' + => where { + # no keys match non-alpha + (grep { /[^a-zA-Z]/ } keys %$_) == 0 + }; +}, undef, '... created the subtype special okay' ); + +is( exception { + subtype 'Trihash' => as 'AlphaKeyHash' + => where { + keys(%$_) == 3 + }; +}, undef, '... created the subtype special okay' ); + +is( exception { + subtype 'Noncon' => as 'Item'; +}, undef, '... created the subtype special okay' ); + +{ + my $t = find_type_constraint('AlphaKeyHash'); + isa_ok($t, 'Moose::Meta::TypeConstraint'); + + is($t->name, 'AlphaKeyHash', '... name is correct'); + + my $p = $t->parent; + isa_ok($p, 'Moose::Meta::TypeConstraint'); + + is($p->name, 'HashRef', '... parent name is correct'); + + ok($t->check({ one => 1, two => 2 }), '... validated it correctly'); + ok(!$t->check({ one1 => 1, two2 => 2 }), '... validated it correctly'); + + ok( $t->equals($t), "equals to self" ); + ok( !$t->equals($t->parent), "not equal to parent" ); +} + +my $hoi = Moose::Util::TypeConstraints::find_or_parse_type_constraint('AlphaKeyHash[Int]'); + +ok($hoi->check({ one => 1, two => 2 }), '... validated it correctly'); +ok(!$hoi->check({ one1 => 1, two2 => 2 }), '... validated it correctly'); +ok(!$hoi->check({ one => 'uno', two => 'dos' }), '... validated it correctly'); +ok(!$hoi->check({ one1 => 'un', two2 => 'deux' }), '... validated it correctly'); + +ok( $hoi->equals($hoi), "equals to self" ); +ok( !$hoi->equals($hoi->parent), "equals to self" ); +ok( !$hoi->equals(find_type_constraint('AlphaKeyHash')), "not equal to unparametrized self" ); +ok( $hoi->equals( Moose::Meta::TypeConstraint::Parameterized->new( name => "Blah", parent => find_type_constraint("AlphaKeyHash"), type_parameter => find_type_constraint("Int") ) ), "equal to clone" ); +ok( !$hoi->equals( Moose::Meta::TypeConstraint::Parameterized->new( name => "Oink", parent => find_type_constraint("AlphaKeyHash"), type_parameter => find_type_constraint("Str") ) ), "not equal to different parameter" ); + +my $th = Moose::Util::TypeConstraints::find_or_parse_type_constraint('Trihash[Bool]'); + +ok(!$th->check({ one => 1, two => 1 }), '... validated it correctly'); +ok($th->check({ one => 1, two => 0, three => 1 }), '... validated it correctly'); +ok(!$th->check({ one => 1, two => 2, three => 1 }), '... validated it correctly'); +ok(!$th->check({foo1 => 1, bar2 => 0, baz3 => 1}), '... validated it correctly'); + +isnt( exception { + Moose::Meta::TypeConstraint::Parameterized->new( + name => 'Str[Int]', + parent => find_type_constraint('Str'), + type_parameter => find_type_constraint('Int'), + ); +}, undef, 'non-containers cannot be parameterized' ); + +isnt( exception { + Moose::Meta::TypeConstraint::Parameterized->new( + name => 'Noncon[Int]', + parent => find_type_constraint('Noncon'), + type_parameter => find_type_constraint('Int'), + ); +}, undef, 'non-containers cannot be parameterized' ); + +done_testing; diff --git a/t/type_constraints/custom_type_errors.t b/t/type_constraints/custom_type_errors.t new file mode 100644 index 0000000..21cf981 --- /dev/null +++ b/t/type_constraints/custom_type_errors.t @@ -0,0 +1,45 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package Animal; + use Moose; + use Moose::Util::TypeConstraints; + + subtype 'Natural' => as 'Int' => where { $_ > 0 } => + message {"This number ($_) is not a positive integer!"}; + + subtype 'NaturalLessThanTen' => as 'Natural' => where { $_ < 10 } => + message {"This number ($_) is not less than ten!"}; + + has leg_count => ( + is => 'rw', + isa => 'NaturalLessThanTen', + lazy => 1, + default => 0, + ); +} + +is( exception { my $goat = Animal->new( leg_count => 4 ) }, undef, '... no errors thrown, value is good' ); +is( exception { my $spider = Animal->new( leg_count => 8 ) }, undef, '... no errors thrown, value is good' ); + +like( exception { my $fern = Animal->new( leg_count => 0 ) }, qr/This number \(0\) is not less than ten!/, 'gave custom supertype error message on new' ); + +like( exception { my $centipede = Animal->new( leg_count => 30 ) }, qr/This number \(30\) is not less than ten!/, 'gave custom subtype error message on new' ); + +my $chimera; +is( exception { $chimera = Animal->new( leg_count => 4 ) }, undef, '... no errors thrown, value is good' ); + +like( exception { $chimera->leg_count(0) }, qr/This number \(0\) is not less than ten!/, 'gave custom supertype error message on set to 0' ); + +like( exception { $chimera->leg_count(16) }, qr/This number \(16\) is not less than ten!/, 'gave custom subtype error message on set to 16' ); + +my $gimp = eval { Animal->new() }; +is( $@, '', '... no errors thrown, value is good' ); + +like( exception { $gimp->leg_count }, qr/This number \(0\) is not less than ten!/, 'gave custom supertype error message on lazy set to 0' ); + +done_testing; diff --git a/t/type_constraints/define_type_twice_throws.t b/t/type_constraints/define_type_twice_throws.t new file mode 100644 index 0000000..a9b9b83 --- /dev/null +++ b/t/type_constraints/define_type_twice_throws.t @@ -0,0 +1,23 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +{ + package Some::Class; + use Moose::Util::TypeConstraints; + + subtype 'MySubType' => as 'Int' => where { 1 }; +} + +like( exception { + package Some::Other::Class; + use Moose::Util::TypeConstraints; + + subtype 'MySubType' => as 'Int' => where { 1 }; +}, qr/cannot be created again/, 'Trying to create same type twice throws' ); + +done_testing; diff --git a/t/type_constraints/duck_type_handles.t b/t/type_constraints/duck_type_handles.t new file mode 100644 index 0000000..d8dcf18 --- /dev/null +++ b/t/type_constraints/duck_type_handles.t @@ -0,0 +1,45 @@ +use strict; +use warnings; + +use Test::More; + +my @phonograph; +{ + package Duck; + use Moose; + + sub walk { + push @phonograph, 'footsteps', + } + + sub quack { + push @phonograph, 'quack'; + } + + package Swan; + use Moose; + + sub honk { + push @phonograph, 'honk'; + } + + package DucktypeTest; + use Moose; + use Moose::Util::TypeConstraints; + + my $ducktype = duck_type 'DuckType' => [qw(walk quack)]; + + has duck => ( + isa => $ducktype, + handles => $ducktype, + ); +} + +my $t = DucktypeTest->new(duck => Duck->new); +$t->quack; +is_deeply([splice @phonograph], ['quack']); + +$t->walk; +is_deeply([splice @phonograph], ['footsteps']); + +done_testing; diff --git a/t/type_constraints/duck_types.t b/t/type_constraints/duck_types.t new file mode 100644 index 0000000..d13d862 --- /dev/null +++ b/t/type_constraints/duck_types.t @@ -0,0 +1,85 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + + package Duck; + use Moose; + + sub quack { } + +} + +{ + + package Swan; + use Moose; + + sub honk { } + +} + +{ + + package RubberDuck; + use Moose; + + sub quack { } + +} + +{ + + package DucktypeTest; + use Moose; + use Moose::Util::TypeConstraints; + + duck_type 'DuckType' => [qw(quack)]; + duck_type 'SwanType' => [qw(honk)]; + + has duck => ( + isa => 'DuckType', + is => 'ro', + lazy_build => 1, + ); + + sub _build_duck { Duck->new } + + has swan => ( + isa => duck_type( [qw(honk)] ), + is => 'ro', + ); + + has other_swan => ( + isa => 'SwanType', + is => 'ro', + ); + +} + +# try giving it a duck +is( exception { DucktypeTest->new( duck => Duck->new ) }, undef, 'the Duck lives okay' ); + +# try giving it a swan which is like a duck, but not close enough +like( exception { DucktypeTest->new( duck => Swan->new ) }, qr/Swan is missing methods 'quack'/, "the Swan doesn't quack" ); + +# try giving it a rubber RubberDuckey +is( exception { DucktypeTest->new( swan => Swan->new ) }, undef, 'but a Swan can honk' ); + +# try giving it a rubber RubberDuckey +is( exception { DucktypeTest->new( duck => RubberDuck->new ) }, undef, 'the RubberDuck lives okay' ); + +# try with the other constraint form +is( exception { DucktypeTest->new( other_swan => Swan->new ) }, undef, 'but a Swan can honk' ); + +my $re = qr/Validation failed for 'DuckType' with value/; + +like( exception { DucktypeTest->new( duck => undef ) }, $re, 'Exception for undef' ); +like( exception { DucktypeTest->new( duck => [] ) }, $re, 'Exception for arrayref' ); +like( exception { DucktypeTest->new( duck => {} ) }, $re, 'Exception for hashref' ); +like( exception { DucktypeTest->new( duck => \'foo' ) }, $re, 'Exception for scalar ref' ); + +done_testing; diff --git a/t/type_constraints/enum.t b/t/type_constraints/enum.t new file mode 100644 index 0000000..74fd064 --- /dev/null +++ b/t/type_constraints/enum.t @@ -0,0 +1,85 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Scalar::Util (); + +use Moose::Util::TypeConstraints; + +enum Letter => ['a'..'z', 'A'..'Z']; +enum Language => ['Perl 5', 'Perl 6', 'PASM', 'PIR']; # any others? ;) +enum Metacharacter => ['*', '+', '?', '.', '|', '(', ')', '[', ']', '\\']; + +my @valid_letters = ('a'..'z', 'A'..'Z'); + +my @invalid_letters = qw/ab abc abcd/; +push @invalid_letters, qw/0 4 9 ~ @ $ %/; +push @invalid_letters, qw/l33t st3v4n 3num/; + +my @valid_languages = ('Perl 5', 'Perl 6', 'PASM', 'PIR'); +my @invalid_languages = ('perl 5', 'Python', 'Ruby', 'Perl 666', 'PASM++'); +# note that "perl 5" is invalid because case now matters + +my @valid_metacharacters = (qw/* + ? . | ( ) [ ] /, '\\'); +my @invalid_metacharacters = qw/< > & % $ @ ! ~ `/; +push @invalid_metacharacters, qw/.* fish(sticks)? atreides/; +push @invalid_metacharacters, '^1?$|^(11+?)\1+$'; + +Moose::Util::TypeConstraints->export_type_constraints_as_functions(); + +ok(Letter($_), "'$_' is a letter") for @valid_letters; +ok(!Letter($_), "'$_' is not a letter") for @invalid_letters; + +ok(Language($_), "'$_' is a language") for @valid_languages; +ok(!Language($_), "'$_' is not a language") for @invalid_languages; + +ok(Metacharacter($_), "'$_' is a metacharacter") for @valid_metacharacters; +ok(!Metacharacter($_), "'$_' is not a metacharacter") + for @invalid_metacharacters; + +# check anon enums + +my $anon_enum = enum \@valid_languages; +isa_ok($anon_enum, 'Moose::Meta::TypeConstraint'); + +is($anon_enum->name, '__ANON__', '... got the right name'); +is($anon_enum->parent->name, 'Str', '... got the right parent name'); + +ok($anon_enum->check($_), "'$_' is a language") for @valid_languages; + + +ok( !$anon_enum->equals( enum [qw(foo bar)] ), "doesn't equal a diff enum" ); +ok( $anon_enum->equals( $anon_enum ), "equals itself" ); +ok( $anon_enum->equals( enum \@valid_languages ), "equals duplicate" ); + +ok( !$anon_enum->is_subtype_of('Object'), 'enum not a subtype of Object'); +ok( !$anon_enum->is_a_type_of('Object'), 'enum not type of Object'); + +ok( !$anon_enum->is_subtype_of('ThisTypeDoesNotExist'), 'enum not a subtype of nonexistant type'); +ok( !$anon_enum->is_a_type_of('ThisTypeDoesNotExist'), 'enum not type of nonexistant type'); + +# validation +like( exception { Moose::Meta::TypeConstraint::Enum->new(name => 'ZeroValues', values => []) }, qr/You must have at least one value to enumerate through/ ); + +is( exception { Moose::Meta::TypeConstraint::Enum->new(name => 'OneValue', values => [ 'a' ]) }, undef); + +like( exception { Moose::Meta::TypeConstraint::Enum->new(name => 'ReferenceInEnum', values => [ 'a', {} ]) }, qr/Enum values must be strings, not 'HASH\(0x\w+\)'/ ); + +like( exception { Moose::Meta::TypeConstraint::Enum->new(name => 'UndefInEnum', values => [ 'a', undef ]) }, qr/Enum values must be strings, not undef/ ); + +like( exception { + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + has error => ( + is => 'ro', + isa => enum ['a', 'aa', 'aaa'], # should be parenthesized! + default => 'aa', + ); +}, qr/enum called with an array reference and additional arguments\. Did you mean to parenthesize the enum call's parameters\?/ ); + + +done_testing; diff --git a/t/type_constraints/inlining.t b/t/type_constraints/inlining.t new file mode 100644 index 0000000..b14ae75 --- /dev/null +++ b/t/type_constraints/inlining.t @@ -0,0 +1,197 @@ +use strict; +use warnings; + +use Test::Fatal; +use Test::More; + +use List::Util 1.33 (); +use Moose::Util::TypeConstraints; + +#<<< +subtype 'Inlinable', + as 'Str', + where { $_ !~ /Q/ }, + inline_as { "defined $_[1] && ! ref $_[1] && $_[1] !~ /Q/" }; + +subtype 'NotInlinable', + as 'Str', + where { $_ !~ /Q/ }; +#>>> + +my $inlinable = find_type_constraint('Inlinable'); +my $not_inlinable = find_type_constraint('NotInlinable'); + +{ + ok( + $inlinable->can_be_inlined, + 'Inlinable returns true for can_be_inlined' + ); + + is( + $inlinable->_inline_check('$foo'), + '( do { defined $foo && ! ref $foo && $foo !~ /Q/ } )', + 'got expected inline code for Inlinable constraint' + ); + + ok( + !$not_inlinable->can_be_inlined, + 'NotInlinable returns false for can_be_inlined' + ); + + like( + exception { $not_inlinable->_inline_check('$foo') }, + qr/Cannot inline a type constraint check for NotInlinable/, + 'threw an exception when asking for inlinable code from type which cannot be inlined' + ); +} + +{ + my $aofi = Moose::Util::TypeConstraints::find_or_create_type_constraint( + 'ArrayRef[Inlinable]'); + + ok( + $aofi->can_be_inlined, + 'ArrayRef[Inlinable] returns true for can_be_inlined' + ); + + is( + $aofi->_inline_check('$foo'), + q{( do { do {my $check = $foo;ref($check) eq "ARRAY" && &List::Util::all(sub { ( do { defined $_ && ! ref $_ && $_ !~ /Q/ } ) }, @{$check})} } )}, + 'got expected inline code for ArrayRef[Inlinable] constraint' + ); + + my $aofni = Moose::Util::TypeConstraints::find_or_create_type_constraint( + 'ArrayRef[NotInlinable]'); + + ok( + !$aofni->can_be_inlined, + 'ArrayRef[NotInlinable] returns false for can_be_inlined' + ); +} + +subtype 'ArrayOfInlinable', + as 'ArrayRef[Inlinable]'; + +subtype 'ArrayOfNotInlinable', + as 'ArrayRef[NotInlinable]'; +{ + my $aofi = Moose::Util::TypeConstraints::find_or_create_type_constraint( + 'ArrayOfInlinable'); + + ok( + $aofi->can_be_inlined, + 'ArrayOfInlinable returns true for can_be_inlined' + ); + + is( + $aofi->_inline_check('$foo'), + q{( do { do {my $check = $foo;ref($check) eq "ARRAY" && &List::Util::all(sub { ( do { defined $_ && ! ref $_ && $_ !~ /Q/ } ) }, @{$check})} } )}, + 'got expected inline code for ArrayOfInlinable constraint' + ); + + my $aofni = Moose::Util::TypeConstraints::find_or_create_type_constraint( + 'ArrayOfNotInlinable'); + + ok( + !$aofni->can_be_inlined, + 'ArrayOfNotInlinable returns false for can_be_inlined' + ); +} + +{ + my $hoaofi = Moose::Util::TypeConstraints::find_or_create_type_constraint( + 'HashRef[ArrayRef[Inlinable]]'); + + ok( + $hoaofi->can_be_inlined, + 'HashRef[ArrayRef[Inlinable]] returns true for can_be_inlined' + ); + + is( + $hoaofi->_inline_check('$foo'), + q{( do { do {my $check = $foo;ref($check) eq "HASH" && &List::Util::all(sub { ( do { do {my $check = $_;ref($check) eq "ARRAY" && &List::Util::all(sub { ( do { defined $_ && ! ref $_ && $_ !~ /Q/ } ) }, @{$check})} } ) }, values %{$check})} } )}, + 'got expected inline code for HashRef[ArrayRef[Inlinable]] constraint' + ); + + my $hoaofni = Moose::Util::TypeConstraints::find_or_create_type_constraint( + 'HashRef[ArrayRef[NotInlinable]]'); + + ok( + !$hoaofni->can_be_inlined, + 'HashRef[ArrayRef[NotInlinable]] returns false for can_be_inlined' + ); +} + +{ + my $iunion = Moose::Util::TypeConstraints::find_or_create_type_constraint( + 'Inlinable | Object'); + + ok( + $iunion->can_be_inlined, + 'Inlinable | Object returns true for can_be_inlined' + ); + + is( + $iunion->_inline_check('$foo'), + '((( do { defined $foo && ! ref $foo && $foo !~ /Q/ } )) || (( do { Scalar::Util::blessed($foo) } )))', + 'got expected inline code for Inlinable | Object constraint' + ); + + my $niunion = Moose::Util::TypeConstraints::find_or_create_type_constraint( + 'NotInlinable | Object'); + + ok( + !$niunion->can_be_inlined, + 'NotInlinable | Object returns false for can_be_inlined' + ); +} + +{ + my $iunion = Moose::Util::TypeConstraints::find_or_create_type_constraint( + 'Object | Inlinable'); + + ok( + $iunion->can_be_inlined, + 'Object | Inlinable returns true for can_be_inlined' + ); + + is( + $iunion->_inline_check('$foo'), + '((( do { Scalar::Util::blessed($foo) } )) || (( do { defined $foo && ! ref $foo && $foo !~ /Q/ } )))', + 'got expected inline code for Object | Inlinable constraint' + ); + + my $niunion = Moose::Util::TypeConstraints::find_or_create_type_constraint( + 'Object | NotInlinable'); + + ok( + !$niunion->can_be_inlined, + 'Object | NotInlinable returns false for can_be_inlined' + ); +} + +{ + my $iunion = Moose::Util::TypeConstraints::find_or_create_type_constraint( + 'Object | Inlinable | CodeRef'); + + ok( + $iunion->can_be_inlined, + 'Object | Inlinable | CodeRef returns true for can_be_inlined' + ); + + is( + $iunion->_inline_check('$foo'), + q{((( do { Scalar::Util::blessed($foo) } )) || (( do { defined $foo && ! ref $foo && $foo !~ /Q/ } )) || (( do { ref($foo) eq "CODE" } )))}, + 'got expected inline code for Object | Inlinable | CodeRef constraint' + ); + + my $niunion = Moose::Util::TypeConstraints::find_or_create_type_constraint( + 'Object | NotInlinable | CodeRef'); + + ok( + !$niunion->can_be_inlined, + 'Object | NotInlinable | CodeRef returns false for can_be_inlined' + ); +} + +done_testing; diff --git a/t/type_constraints/match_type_operator.t b/t/type_constraints/match_type_operator.t new file mode 100644 index 0000000..016646a --- /dev/null +++ b/t/type_constraints/match_type_operator.t @@ -0,0 +1,227 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +# some simple type dispatching ... + +subtype 'Null' + => as 'ArrayRef' + => where { scalar @{$_} == 0 }; + +sub head { + match_on_type @_ => + Null => sub { die "Cannot get the head of Null" }, + ArrayRef => sub { $_->[0] }; +} + +sub tail { + match_on_type @_ => + Null => sub { die "Cannot get the tail of Null" }, + ArrayRef => sub { [ @{ $_ }[ 1 .. $#{ $_ } ] ] }; +} + +sub len { + match_on_type @_ => + Null => sub { 0 }, + ArrayRef => sub { len( tail( $_ ) ) + 1 }; +} + +sub rev { + match_on_type @_ => + Null => sub { [] }, + ArrayRef => sub { [ @{ rev( tail( $_ ) ) }, head( $_ ) ] }; +} + +is( len( [] ), 0, '... got the right length'); +is( len( [ 1 ] ), 1, '... got the right length'); +is( len( [ 1 .. 5 ] ), 5, '... got the right length'); +is( len( [ 1 .. 50 ] ), 50, '... got the right length'); + +is_deeply( + rev( [ 1 .. 5 ] ), + [ reverse 1 .. 5 ], + '... got the right reversed value' +); + +# break down a Maybe Type ... + +sub break_it_down { + match_on_type shift, + 'Maybe[Str]' => sub { + match_on_type $_ => + 'Undef' => sub { 'undef' }, + 'Str' => sub { $_ } + }, + sub { 'default' } +} + + +is( break_it_down( 'FOO' ), 'FOO', '... got the right value'); +is( break_it_down( [] ), 'default', '... got the right value'); +is( break_it_down( undef ), 'undef', '... got the right value'); +is( break_it_down(), 'undef', '... got the right value'); + +# checking against enum types + +enum RGB => [qw[ red green blue ]]; +enum CMYK => [qw[ cyan magenta yellow black ]]; + +sub is_acceptable_color { + match_on_type shift, + 'RGB' => sub { 'RGB' }, + 'CMYK' => sub { 'CMYK' }, + sub { die "bad color $_" }; +} + +is( is_acceptable_color( 'blue' ), 'RGB', '... got the right value'); +is( is_acceptable_color( 'green' ), 'RGB', '... got the right value'); +is( is_acceptable_color( 'red' ), 'RGB', '... got the right value'); +is( is_acceptable_color( 'cyan' ), 'CMYK', '... got the right value'); +is( is_acceptable_color( 'magenta' ), 'CMYK', '... got the right value'); +is( is_acceptable_color( 'yellow' ), 'CMYK', '... got the right value'); +is( is_acceptable_color( 'black' ), 'CMYK', '... got the right value'); + +isnt( exception { + is_acceptable_color( 'orange' ) +}, undef, '... got the exception' ); + +## using it in an OO context + +{ + package LinkedList; + use Moose; + use Moose::Util::TypeConstraints; + + has 'next' => ( + is => 'ro', + isa => __PACKAGE__, + lazy => 1, + default => sub { __PACKAGE__->new }, + predicate => 'has_next' + ); + + sub pprint { + my $list = shift; + match_on_type $list => + subtype( + as 'LinkedList', + where { ! $_->has_next } + ) => sub { '[]' }, + 'LinkedList' => sub { '[' . $_->next->pprint . ']' }; + } +} + +my $l = LinkedList->new; +is($l->pprint, '[]', '... got the right pprint'); +$l->next; +is($l->pprint, '[[]]', '... got the right pprint'); +$l->next->next; +is($l->pprint, '[[[]]]', '... got the right pprint'); +$l->next->next->next; +is($l->pprint, '[[[[]]]]', '... got the right pprint'); + +# basic data dumper + +{ + package Foo; + use Moose; + + sub to_string { 'Foo()' } +} + +use B; + +sub ppprint { + my $x = shift; + match_on_type $x => + HashRef => sub { + my $hash = shift; + '{ ' . (join ", " => map { + $_ . ' => ' . ppprint( $hash->{ $_ } ) + } sort keys %$hash ) . ' }' }, + ArrayRef => sub { + my $array = shift; + '[ ' . (join ", " => map { ppprint( $_ ) } @$array ) . ' ]' }, + CodeRef => sub { 'sub { ... }' }, + RegexpRef => sub { 'qr/' . $_ . '/' }, + GlobRef => sub { '*' . B::svref_2object($_)->NAME }, + Object => sub { $_->can('to_string') ? $_->to_string : $_ }, + ScalarRef => sub { '\\' . ppprint( ${$_} ) }, + Num => sub { $_ }, + Str => sub { '"'. $_ . '"' }, + Undef => sub { 'undef' }, + => sub { die "I don't know what $_ is" }; +} + +# The stringification of qr// has changed in 5.13.5+ +my $re_prefix = qr/x/ =~ /\(\?\^/ ? '(?^:' :'(?-xism:'; + +is( + ppprint( + { + one => [ 1, 2, "three", 4, "five", \(my $x = "six") ], + two => undef, + three => sub { "OH HAI" }, + four => qr/.*?/, + five => \*ppprint, + six => Foo->new, + } + ), + qq~{ five => *ppprint, four => qr/$re_prefix.*?)/, one => [ 1, 2, "three", 4, "five", \\"six" ], six => Foo(), three => sub { ... }, two => undef }~, + '... got the right pretty printed values' +); + +# simple JSON serializer + +sub to_json { + my $x = shift; + match_on_type $x => + HashRef => sub { + my $hash = shift; + '{ ' . (join ", " => map { + '"' . $_ . '" : ' . to_json( $hash->{ $_ } ) + } sort keys %$hash ) . ' }' }, + ArrayRef => sub { + my $array = shift; + '[ ' . (join ", " => map { to_json( $_ ) } @$array ) . ' ]' }, + Num => sub { $_ }, + Str => sub { '"'. $_ . '"' }, + Undef => sub { 'null' }, + => sub { die "$_ is not acceptable json type" }; +} + +is( + to_json( { one => 1, two => 2 } ), + '{ "one" : 1, "two" : 2 }', + '... got our valid JSON' +); + +is( + to_json( { + one => [ 1, 2, 3, 4 ], + two => undef, + three => "Hello World" + } ), + '{ "one" : [ 1, 2, 3, 4 ], "three" : "Hello World", "two" : null }', + '... got our valid JSON' +); + + +# some error cases + +sub not_enough_matches { + my $x = shift; + match_on_type $x => + Undef => sub { 'hello undef world' }, + CodeRef => sub { $_->('Hello code ref world') }; +} + +like( exception { + not_enough_matches( [] ) +}, qr/No cases matched for /, '... not enough matches' ); + +done_testing; diff --git a/t/type_constraints/maybe_type_constraint.t b/t/type_constraints/maybe_type_constraint.t new file mode 100644 index 0000000..3bbdba2 --- /dev/null +++ b/t/type_constraints/maybe_type_constraint.t @@ -0,0 +1,129 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +my $type = Moose::Util::TypeConstraints::find_or_parse_type_constraint('Maybe[Int]'); +isa_ok($type, 'Moose::Meta::TypeConstraint'); +isa_ok($type, 'Moose::Meta::TypeConstraint::Parameterized'); + +ok( $type->equals($type), "equals self" ); +ok( !$type->equals($type->parent), "not equal to parent" ); +ok( !$type->equals(find_type_constraint("Maybe")), "not equal to Maybe" ); +ok( $type->parent->equals(find_type_constraint("Maybe")), "parent is Maybe" ); +ok( $type->equals( Moose::Meta::TypeConstraint::Parameterized->new( name => "__ANON__", parent => find_type_constraint("Maybe"), type_parameter => find_type_constraint("Int") ) ), "equal to clone" ); +ok( !$type->equals( Moose::Meta::TypeConstraint::Parameterized->new( name => "__ANON__", parent => find_type_constraint("Maybe"), type_parameter => find_type_constraint("Str") ) ), "not equal to clone with diff param" ); +ok( !$type->equals( Moose::Util::TypeConstraints::find_or_parse_type_constraint('Maybe[Str]') ), "not equal to declarative version of diff param" ); + +ok($type->check(10), '... checked type correctly (pass)'); +ok($type->check(undef), '... checked type correctly (pass)'); +ok(!$type->check('Hello World'), '... checked type correctly (fail)'); +ok(!$type->check([]), '... checked type correctly (fail)'); + +{ + package Bar; + use Moose; + + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + has 'arr' => (is => 'rw', isa => 'Maybe[ArrayRef]', required => 1); + has 'bar' => (is => 'rw', isa => class_type('Bar')); + has 'maybe_bar' => (is => 'rw', isa => maybe_type(class_type('Bar'))); +} + +is( exception { + Foo->new(arr => [], bar => Bar->new); +}, undef, '... Bar->new isa Bar' ); + +isnt( exception { + Foo->new(arr => [], bar => undef); +}, undef, '... undef isnta Bar' ); + +is( exception { + Foo->new(arr => [], maybe_bar => Bar->new); +}, undef, '... Bar->new isa maybe(Bar)' ); + +is( exception { + Foo->new(arr => [], maybe_bar => undef); +}, undef, '... undef isa maybe(Bar)' ); + +isnt( exception { + Foo->new(arr => [], maybe_bar => 1); +}, undef, '... 1 isnta maybe(Bar)' ); + +is( exception { + Foo->new(arr => []); +}, undef, '... it worked!' ); + +is( exception { + Foo->new(arr => undef); +}, undef, '... it worked!' ); + +isnt( exception { + Foo->new(arr => 100); +}, undef, '... failed the type check' ); + +isnt( exception { + Foo->new(arr => 'hello world'); +}, undef, '... failed the type check' ); + + +{ + package Test::MooseX::Types::Maybe; + use Moose; + + has 'Maybe_Int' => (is=>'rw', isa=>'Maybe[Int]'); + has 'Maybe_ArrayRef' => (is=>'rw', isa=>'Maybe[ArrayRef]'); + has 'Maybe_HashRef' => (is=>'rw', isa=>'Maybe[HashRef]'); + has 'Maybe_ArrayRefInt' => (is=>'rw', isa=>'Maybe[ArrayRef[Int]]'); + has 'Maybe_HashRefInt' => (is=>'rw', isa=>'Maybe[HashRef[Int]]'); +} + +ok my $obj = Test::MooseX::Types::Maybe->new + => 'Create good test object'; + +## Maybe[Int] + +ok my $Maybe_Int = Moose::Util::TypeConstraints::find_or_parse_type_constraint('Maybe[Int]') + => 'made TC Maybe[Int]'; + +ok $Maybe_Int->check(1) + => 'passed (1)'; + +ok $obj->Maybe_Int(1) + => 'assigned (1)'; + +ok $Maybe_Int->check() + => 'passed ()'; + +ok $obj->Maybe_Int() + => 'assigned ()'; + +ok $Maybe_Int->check(0) + => 'passed (0)'; + +ok defined $obj->Maybe_Int(0) + => 'assigned (0)'; + +ok $Maybe_Int->check(undef) + => 'passed (undef)'; + +ok sub {$obj->Maybe_Int(undef); 1}->() + => 'assigned (undef)'; + +ok !$Maybe_Int->check("") + => 'failed ("")'; + +like( exception { $obj->Maybe_Int("") }, qr/Attribute \(Maybe_Int\) does not pass the type constraint/, 'failed assigned ("")' ); + +ok !$Maybe_Int->check("a") + => 'failed ("a")'; + +like( exception { $obj->Maybe_Int("a") }, qr/Attribute \(Maybe_Int\) does not pass the type constraint/, 'failed assigned ("a")' ); + +done_testing; diff --git a/t/type_constraints/misc_type_tests.t b/t/type_constraints/misc_type_tests.t new file mode 100644 index 0000000..e2413ab --- /dev/null +++ b/t/type_constraints/misc_type_tests.t @@ -0,0 +1,85 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Scalar::Util qw(refaddr); + +use Moose::Util::TypeConstraints; + +# subtype 'aliasing' ... + +is( exception { + subtype 'Numb3rs' => as 'Num'; +}, undef, '... create bare subtype fine' ); + +my $numb3rs = find_type_constraint('Numb3rs'); +isa_ok($numb3rs, 'Moose::Meta::TypeConstraint'); + +# subtype with unions + +{ + package Test::Moose::Meta::TypeConstraint::Union; + + use overload '""' => sub {'Broken|Test'}, fallback => 1; + use Moose; + + extends 'Moose::Meta::TypeConstraint'; +} + +my $dummy_instance = Test::Moose::Meta::TypeConstraint::Union->new; + +ok $dummy_instance => "Created Instance"; + +isa_ok $dummy_instance, + 'Test::Moose::Meta::TypeConstraint::Union' => 'isa correct type'; + +is "$dummy_instance", "Broken|Test" => + 'Got expected stringification result'; + +my $subtype1 = subtype 'New1' => as $dummy_instance; + +ok $subtype1 => 'made a subtype from our type object'; + +my $subtype2 = subtype 'New2' => as $subtype1; + +ok $subtype2 => 'made a subtype of our subtype'; + +# assert_valid + +{ + my $type = find_type_constraint('Num'); + + my $ok_1 = eval { $type->assert_valid(1); }; + ok($ok_1, "we can assert_valid that 1 is of type $type"); + + my $ok_2 = eval { $type->assert_valid('foo'); }; + my $error = $@; + ok(! $ok_2, "'foo' is not of type $type"); + like( + $error, + qr{validation failed for .\Q$type\E.}i, + "correct error thrown" + ); +} + +{ + for my $t (qw(Bar Foo)) { + my $tc = Moose::Meta::TypeConstraint->new({ + name => $t, + }); + + Moose::Util::TypeConstraints::register_type_constraint($tc); + } + + my $foo = Moose::Util::TypeConstraints::find_type_constraint('Foo'); + my $bar = Moose::Util::TypeConstraints::find_type_constraint('Bar'); + + ok(!$foo->equals($bar), "Foo type is not equal to Bar type"); + ok( $foo->equals($foo), "Foo equals Foo"); + ok( 0+$foo == refaddr($foo), "overloading works"); +} + +ok $subtype1, "type constraint boolean overload works"; + +done_testing; diff --git a/t/type_constraints/name_conflicts.t b/t/type_constraints/name_conflicts.t new file mode 100644 index 0000000..1b52b5e --- /dev/null +++ b/t/type_constraints/name_conflicts.t @@ -0,0 +1,112 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +{ + package Types; + use Moose::Util::TypeConstraints; + + type 'Foo1'; + subtype 'Foo2', as 'Str'; + class_type 'Foo3'; + role_type 'Foo4'; + + { package Foo5; use Moose; } + { package Foo6; use Moose::Role; } + { package IsaAttr; use Moose; has foo => (is => 'ro', isa => 'Foo7'); } + { package DoesAttr; use Moose; has foo => (is => 'ro', does => 'Foo8'); } +} + +{ + my $anon = 0; + my @checks = ( + [1, sub { type $_[0] }, 'type'], + [1, sub { subtype $_[0], as 'Str' }, 'subtype'], + [1, sub { class_type $_[0] }, 'class_type'], + [1, sub { role_type $_[0] }, 'role_type'], + # should these two die? + [0, sub { eval "package $_[0]; use Moose; 1" || die $@ }, 'use Moose'], + [0, sub { eval "package $_[0]; use Moose::Role; 1" || die $@ }, 'use Moose::Role'], + [0, sub { + $anon++; + eval <<CLASS || die $@; + package Anon$anon; + use Moose; + has foo => (is => 'ro', isa => '$_[0]'); + 1 +CLASS + }, 'isa => "Thing"'], + [0, sub { + $anon++; + eval <<CLASS || die $@; + package Anon$anon; + use Moose; + has foo => (is => 'ro', does => '$_[0]'); + 1 +CLASS + }, 'does => "Thing"'], + ); + + sub check_conflicts { + my ($type_name) = @_; + my $type = find_type_constraint($type_name); + for my $check (@checks) { + my ($should_fail, $code, $desc) = @$check; + + $should_fail = 0 + if overriding_with_equivalent_type($type, $desc); + unload_class($type_name); + + if ($should_fail) { + like( + exception { $code->($type_name) }, + qr/^The type constraint '$type_name' has already been created in [\w:]+ and cannot be created again in [\w:]+/, + "trying to override $type_name via '$desc' should die" + ); + } + else { + is( + exception { $code->($type_name) }, + undef, + "trying to override $type_name via '$desc' should do nothing" + ); + } + is($type, find_type_constraint($type_name), "type didn't change"); + } + } + + sub unload_class { + my ($class) = @_; + my $meta = Class::MOP::class_of($class); + return unless $meta; + $meta->add_package_symbol('@ISA', []); + $meta->remove_package_symbol('&'.$_) + for $meta->list_all_package_symbols('CODE'); + undef $meta; + Class::MOP::remove_metaclass_by_name($class); + } + + sub overriding_with_equivalent_type { + my ($type, $desc) = @_; + if ($type->isa('Moose::Meta::TypeConstraint::Class')) { + return 1 if $desc eq 'use Moose' + || $desc eq 'class_type' + || $desc eq 'isa => "Thing"'; + } + if ($type->isa('Moose::Meta::TypeConstraint::Role')) { + return 1 if $desc eq 'use Moose::Role' + || $desc eq 'role_type' + || $desc eq 'does => "Thing"'; + } + return; + } +} + +{ + check_conflicts($_) for map { "Foo$_" } 1..8; +} + +done_testing; diff --git a/t/type_constraints/normalize_type_name.t b/t/type_constraints/normalize_type_name.t new file mode 100644 index 0000000..406f59c --- /dev/null +++ b/t/type_constraints/normalize_type_name.t @@ -0,0 +1,148 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util::TypeConstraints; + +## First, we check that the new regex parsing works + +ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint( + 'ArrayRef[Str]') => 'detected correctly'; + +is_deeply + [ + Moose::Util::TypeConstraints::_parse_parameterized_type_constraint( + 'ArrayRef[Str]') + ], + [ "ArrayRef", "Str" ] => 'Correctly parsed ArrayRef[Str]'; + +ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint( + 'ArrayRef[Str ]') => 'detected correctly'; + +is_deeply + [ + Moose::Util::TypeConstraints::_parse_parameterized_type_constraint( + 'ArrayRef[Str ]') + ], + [ "ArrayRef", "Str" ] => 'Correctly parsed ArrayRef[Str ]'; + +ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint( + 'ArrayRef[ Str]') => 'detected correctly'; + +is_deeply + [ + Moose::Util::TypeConstraints::_parse_parameterized_type_constraint( + 'ArrayRef[ Str]') + ], + [ "ArrayRef", "Str" ] => 'Correctly parsed ArrayRef[ Str]'; + +ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint( + 'ArrayRef[ Str ]') => 'detected correctly'; + +is_deeply + [ + Moose::Util::TypeConstraints::_parse_parameterized_type_constraint( + 'ArrayRef[ Str ]') + ], + [ "ArrayRef", "Str" ] => 'Correctly parsed ArrayRef[ Str ]'; + +ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint( + 'ArrayRef[ HashRef[Int] ]') => 'detected correctly'; + +is_deeply + [ + Moose::Util::TypeConstraints::_parse_parameterized_type_constraint( + 'ArrayRef[ HashRef[Int] ]') + ], + [ "ArrayRef", "HashRef[Int]" ] => + 'Correctly parsed ArrayRef[ HashRef[Int] ]'; + +ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint( + 'ArrayRef[ HashRef[Int ] ]') => 'detected correctly'; + +is_deeply + [ + Moose::Util::TypeConstraints::_parse_parameterized_type_constraint( + 'ArrayRef[ HashRef[Int ] ]') + ], + [ "ArrayRef", "HashRef[Int ]" ] => + 'Correctly parsed ArrayRef[ HashRef[Int ] ]'; + +ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint( + 'ArrayRef[Int|Str]') => 'detected correctly'; + +is_deeply + [ + Moose::Util::TypeConstraints::_parse_parameterized_type_constraint( + 'ArrayRef[Int|Str]') + ], + [ "ArrayRef", "Int|Str" ] => 'Correctly parsed ArrayRef[Int|Str]'; + +ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint( + 'ArrayRef[ArrayRef[Int]|Str]') => 'detected correctly'; + +is_deeply + [ + Moose::Util::TypeConstraints::_parse_parameterized_type_constraint( + 'ArrayRef[ArrayRef[Int]|Str]') + ], + [ "ArrayRef", "ArrayRef[Int]|Str" ] => + 'Correctly parsed ArrayRef[ArrayRef[Int]|Str]'; + +## creating names via subtype + +ok my $r = Moose::Util::TypeConstraints->get_type_constraint_registry => + 'Got registry object'; + +ok my $subtype_a1 + = subtype( 'subtype_a1' => as 'HashRef[Int]' ), => 'created subtype_a1'; + +ok my $subtype_a2 + = subtype( 'subtype_a2' => as 'HashRef[ Int]' ), => 'created subtype_a2'; + +ok my $subtype_a3 + = subtype( 'subtype_a2' => as 'HashRef[Int ]' ), => 'created subtype_a2'; + +ok my $subtype_a4 = subtype( 'subtype_a2' => as 'HashRef[ Int ]' ), => + 'created subtype_a2'; + +is $subtype_a1->parent->name, $subtype_a2->parent->name => 'names match'; + +is $subtype_a1->parent->name, $subtype_a3->parent->name => 'names match'; + +is $subtype_a1->parent->name, $subtype_a4->parent->name => 'names match'; + +ok my $subtype_b1 = subtype( 'subtype_b1' => as 'HashRef[Int|Str]' ), => + 'created subtype_b1'; + +ok my $subtype_b2 = subtype( 'subtype_b2' => as 'HashRef[Int | Str]' ), => + 'created subtype_b2'; + +ok my $subtype_b3 = subtype( 'subtype_b3' => as 'HashRef[Str|Int]' ), => + 'created subtype_b3'; + +is $subtype_b1->parent->name, $subtype_b2->parent->name => 'names match'; + +is $subtype_b1->parent->name, $subtype_b3->parent->name => 'names match'; + +is $subtype_b2->parent->name, $subtype_b3->parent->name => 'names match'; + +## testing via add_constraint + +ok my $union1 = Moose::Util::TypeConstraints::create_type_constraint_union( + 'ArrayRef[Int|Str] | ArrayRef[Int | HashRef]') => 'Created Union1'; + +ok my $union2 = Moose::Util::TypeConstraints::create_type_constraint_union( + 'ArrayRef[ Int|Str] | ArrayRef[Int | HashRef]') => 'Created Union2'; + +ok my $union3 = Moose::Util::TypeConstraints::create_type_constraint_union( + 'ArrayRef[Int |Str ] | ArrayRef[Int | HashRef ]') => 'Created Union3'; + +is $union1->name, $union2->name, 'names match'; + +is $union1->name, $union3->name, 'names match'; + +is $union2->name, $union3->name, 'names match'; + +done_testing; diff --git a/t/type_constraints/parameterize_from.t b/t/type_constraints/parameterize_from.t new file mode 100644 index 0000000..8c2485c --- /dev/null +++ b/t/type_constraints/parameterize_from.t @@ -0,0 +1,74 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +# testing the parameterize method + +{ + my $parameterizable = subtype 'parameterizable_hashref', as 'HashRef'; + + my $parameterized = subtype 'parameterized_hashref', as 'HashRef[Int]'; + + my $int = Moose::Util::TypeConstraints::find_type_constraint('Int'); + + my $from_parameterizable = $parameterizable->parameterize($int); + + isa_ok $parameterizable, + 'Moose::Meta::TypeConstraint::Parameterizable', => + 'Got expected type instance'; + + package Test::Moose::Meta::TypeConstraint::Parameterizable; + use Moose; + + has parameterizable => ( is => 'rw', isa => $parameterizable ); + has parameterized => ( is => 'rw', isa => $parameterized ); + has from_parameterizable => ( is => 'rw', isa => $from_parameterizable ); +} + +# Create and check a dummy object + +ok my $params = Test::Moose::Meta::TypeConstraint::Parameterizable->new() => + 'Create Dummy object for testing'; + +isa_ok $params, 'Test::Moose::Meta::TypeConstraint::Parameterizable' => + 'isa correct type'; + +# test parameterizable + +is( exception { + $params->parameterizable( { a => 'Hello', b => 'World' } ); +}, undef, 'No problem setting parameterizable' ); + +is_deeply $params->parameterizable, + { a => 'Hello', b => 'World' } => 'Got expected values'; + +# test parameterized + +is( exception { + $params->parameterized( { a => 1, b => 2 } ); +}, undef, 'No problem setting parameterized' ); + +is_deeply $params->parameterized, { a => 1, b => 2 } => 'Got expected values'; + +like( exception { + $params->parameterized( { a => 'Hello', b => 'World' } ); + }, qr/Attribute \(parameterized\) does not pass the type constraint/, 'parameterized throws expected error' ); + +# test from_parameterizable + +is( exception { + $params->from_parameterizable( { a => 1, b => 2 } ); +}, undef, 'No problem setting from_parameterizable' ); + +is_deeply $params->from_parameterizable, + { a => 1, b => 2 } => 'Got expected values'; + +like( exception { + $params->from_parameterizable( { a => 'Hello', b => 'World' } ); + }, qr/Attribute \(from_parameterizable\) does not pass the type constraint/, 'from_parameterizable throws expected error' ); + +done_testing; diff --git a/t/type_constraints/role_type_constraint.t b/t/type_constraints/role_type_constraint.t new file mode 100644 index 0000000..3da8204 --- /dev/null +++ b/t/type_constraints/role_type_constraint.t @@ -0,0 +1,69 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +{ + package Gorch; + use Moose::Role; + + package Bar; + use Moose::Role; + + package Foo; + use Moose::Role; + + with qw(Bar Gorch); + + package FooC; + use Moose; + with qw(Foo); + + package BarC; + use Moose; + with qw(Bar); + +} + +is( exception { role_type('Boop', message { "${_} is not a Boop" }) }, undef, 'role_type keywork works with message' ); + +my $type = find_type_constraint("Foo"); + +is( $type->role, "Foo", "role attribute" ); + +ok( $type->is_subtype_of("Gorch"), "subtype of gorch" ); + +ok( $type->is_subtype_of("Bar"), "subtype of bar" ); + +ok( $type->is_subtype_of("Object"), "subtype of Object" ); + +ok( !$type->is_subtype_of("ThisTypeDoesNotExist"), "not subtype of unknown type name" ); +ok( !$type->is_a_type_of("ThisTypeDoesNotExist"), "not type of unknown type name" ); + +ok( find_type_constraint("Bar")->check(FooC->new), "Foo passes Bar" ); +ok( find_type_constraint("Bar")->check(BarC->new), "Bar passes Bar" ); +ok( !find_type_constraint("Gorch")->check(BarC->new), "but Bar doesn't pass Gorch"); + +my $boop = find_type_constraint("Boop"); +ok( $boop->has_message, 'Boop has a message'); +my $error = $boop->get_message(FooC->new); +like( $error, qr/is not a Boop/, 'boop gives correct error message'); + + +ok( $type->equals($type), "equals self" ); +ok( $type->equals(Moose::Meta::TypeConstraint::Role->new( name => "__ANON__", role => "Foo" )), "equals anon constraint of same value" ); +ok( $type->equals(Moose::Meta::TypeConstraint::Role->new( name => "Oink", role => "Foo" )), "equals differently named constraint of same value" ); +ok( !$type->equals(Moose::Meta::TypeConstraint::Role->new( name => "__ANON__", role => "Bar" )), "doesn't equal other anon constraint" ); +ok( $type->is_subtype_of(Moose::Meta::TypeConstraint::Role->new( name => "__ANON__", role => "Bar" )), "subtype of other anon constraint" ); + +{ # See block comment in t/type_constraints/class_type_constraint.t + my $type; + is( exception { $type = role_type 'MyExampleRole' }, undef, 'Make initial role_type' ); + is( exception { is(role_type('MyExampleRole'), $type, 're-running role_type gives same type') }, undef, 'No exception making duplicate role_type' );; + is( exception { ok( ! $type->is_subtype_of('Bar'), 'MyExampleRole is not a subtype of Bar' ) }, undef, 'No exception for is_subtype_of undefined role' ); +} + +done_testing; diff --git a/t/type_constraints/subtype_auto_vivify_parent.t b/t/type_constraints/subtype_auto_vivify_parent.t new file mode 100644 index 0000000..e5cd2e9 --- /dev/null +++ b/t/type_constraints/subtype_auto_vivify_parent.t @@ -0,0 +1,31 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util::TypeConstraints; + + +{ + package Foo; + + sub new { + my $class = shift; + + return bless {@_}, $class; + } +} + +subtype 'FooWithSize' + => as 'Foo' + => where { $_[0]->{size} }; + + +my $type = find_type_constraint('FooWithSize'); +ok( $type, 'made a FooWithSize constraint' ); +ok( $type->parent, 'type has a parent type' ); +is( $type->parent->name, 'Foo', 'parent type is Foo' ); +isa_ok( $type->parent, 'Moose::Meta::TypeConstraint::Class', + 'parent type constraint is a class type' ); + +done_testing; diff --git a/t/type_constraints/subtyping_parameterized_types.t b/t/type_constraints/subtyping_parameterized_types.t new file mode 100644 index 0000000..faee937 --- /dev/null +++ b/t/type_constraints/subtyping_parameterized_types.t @@ -0,0 +1,127 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +is( exception { + subtype 'MySpecialHash' => as 'HashRef[Int]'; +}, undef, '... created the subtype special okay' ); + +{ + my $t = find_type_constraint('MySpecialHash'); + isa_ok($t, 'Moose::Meta::TypeConstraint'); + + is($t->name, 'MySpecialHash', '... name is correct'); + + my $p = $t->parent; + isa_ok($p, 'Moose::Meta::TypeConstraint::Parameterized'); + isa_ok($p, 'Moose::Meta::TypeConstraint'); + + is($p->name, 'HashRef[Int]', '... parent name is correct'); + + ok($t->check({ one => 1, two => 2 }), '... validated {one=>1, two=>2} correctly'); + ok(!$t->check({ one => "ONE", two => "TWO" }), '... validated it correctly'); + + ok( $t->equals($t), "equals to self" ); + ok( !$t->equals( $t->parent ), "not equal to parent" ); + ok( $t->parent->equals( $t->parent ), "parent equals to self" ); + + ok( !$t->is_a_type_of("ThisTypeDoesNotExist"), "not a non existant type" ); + ok( !$t->is_subtype_of("ThisTypeDoesNotExist"), "not a subtype of a non existant type" ); +} + +is( exception { + subtype 'MySpecialHashExtended' + => as 'HashRef[Int]' + => where { + # all values are less then 10 + (scalar grep { $_ < 10 } values %{$_}) ? 1 : undef + }; +}, undef, '... created the subtype special okay' ); + +{ + my $t = find_type_constraint('MySpecialHashExtended'); + isa_ok($t, 'Moose::Meta::TypeConstraint'); + + is($t->name, 'MySpecialHashExtended', '... name is correct'); + + my $p = $t->parent; + isa_ok($p, 'Moose::Meta::TypeConstraint::Parameterized'); + isa_ok($p, 'Moose::Meta::TypeConstraint'); + + is($p->name, 'HashRef[Int]', '... parent name is correct'); + + ok($t->check({ one => 1, two => 2 }), '... validated it correctly'); + ok(!$t->check({ zero => 10, one => 11, two => 12 }), '... validated { zero => 10, one => 11, two => 12 } correctly'); + ok(!$t->check({ one => "ONE", two => "TWO" }), '... validated it correctly'); +} + +is( exception { + subtype 'MyNonSpecialHash' + => as "HashRef" + => where { keys %$_ == 3 }; +}, undef ); + +{ + my $t = find_type_constraint('MyNonSpecialHash'); + + isa_ok($t, 'Moose::Meta::TypeConstraint'); + isa_ok($t, 'Moose::Meta::TypeConstraint::Parameterizable'); + + ok( $t->check({ one => 1, two => "foo", three => [] }), "validated" ); + ok( !$t->check({ one => 1 }), "failed" ); +} + +{ + my $t = Moose::Util::TypeConstraints::find_or_parse_type_constraint('MyNonSpecialHash[Int]'); + + isa_ok($t, 'Moose::Meta::TypeConstraint'); + + ok( $t->check({ one => 1, two => 2, three => 3 }), "validated" ); + ok( !$t->check({ one => 1, two => "foo", three => [] }), "failed" ); + ok( !$t->check({ one => 1 }), "failed" ); +} + +{ + ## Because to throw errors in M:M:Parameterizable needs Moose loaded in + ## order to throw errors. In theory the use Moose belongs to that class + ## but when I put it there causes all sorts or trouble. In theory this is + ## never a real problem since you are likely to use Moose somewhere when you + ## are creating type constraints. + use Moose (); + + my $MyArrayRefInt = subtype 'MyArrayRefInt', + as 'ArrayRef[Int]'; + + my $BiggerInt = subtype 'BiggerInt', + as 'Int', + where {$_>10}; + + my $SubOfMyArrayRef = subtype 'SubOfMyArrayRef', + as 'MyArrayRefInt[BiggerInt]'; + + ok $MyArrayRefInt->check([1,2,3]), '[1,2,3] is okay'; + ok ! $MyArrayRefInt->check(["a","b"]), '["a","b"] is not'; + ok $BiggerInt->check(100), '100 is big enough'; + ok ! $BiggerInt->check(5), '5 is big enough'; + ok $SubOfMyArrayRef->check([15,20,25]), '[15,20,25] is a bunch of big ints'; + ok ! $SubOfMyArrayRef->check([15,5,25]), '[15,5,25] is NOT a bunch of big ints'; + + like( exception { + my $SubOfMyArrayRef = subtype 'SubSubOfMyArrayRef', + as 'SubOfMyArrayRef[Str]'; + }, qr/Str is not a subtype of BiggerInt/, 'Failed to parameterize with a bad type parameter' ); +} + +{ + my $RefToInt = subtype as 'ScalarRef[Int]'; + + ok $RefToInt->check(\1), '\1 is okay'; + ok !$RefToInt->check(1), '1 is not'; + ok !$RefToInt->check(\"foo"), '\"foo" is not'; +} + +done_testing; diff --git a/t/type_constraints/subtyping_union_types.t b/t/type_constraints/subtyping_union_types.t new file mode 100644 index 0000000..d2a514f --- /dev/null +++ b/t/type_constraints/subtyping_union_types.t @@ -0,0 +1,108 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +is( exception { + subtype 'MyCollections' => as 'ArrayRef | HashRef'; +}, undef, '... created the subtype special okay' ); + +{ + my $t = find_type_constraint('MyCollections'); + isa_ok($t, 'Moose::Meta::TypeConstraint'); + + is($t->name, 'MyCollections', '... name is correct'); + + my $p = $t->parent; + isa_ok($p, 'Moose::Meta::TypeConstraint::Union'); + isa_ok($p, 'Moose::Meta::TypeConstraint'); + + is($p->name, 'ArrayRef|HashRef', '... parent name is correct'); + + ok($t->check([]), '... validated it correctly'); + ok($t->check({}), '... validated it correctly'); + ok(!$t->check(1), '... validated it correctly'); +} + +is( exception { + subtype 'MyCollectionsExtended' + => as 'ArrayRef|HashRef' + => where { + if (ref($_) eq 'ARRAY') { + return if scalar(@$_) < 2; + } + elsif (ref($_) eq 'HASH') { + return if scalar(keys(%$_)) < 2; + } + 1; + }; +}, undef, '... created the subtype special okay' ); + +{ + my $t = find_type_constraint('MyCollectionsExtended'); + isa_ok($t, 'Moose::Meta::TypeConstraint'); + + is($t->name, 'MyCollectionsExtended', '... name is correct'); + + my $p = $t->parent; + isa_ok($p, 'Moose::Meta::TypeConstraint::Union'); + isa_ok($p, 'Moose::Meta::TypeConstraint'); + + is($p->name, 'ArrayRef|HashRef', '... parent name is correct'); + + ok(!$t->check([]), '... validated it correctly'); + ok($t->check([1, 2]), '... validated it correctly'); + + ok(!$t->check({}), '... validated it correctly'); + ok($t->check({ one => 1, two => 2 }), '... validated it correctly'); + + ok(!$t->check(1), '... validated it correctly'); +} + +{ + my $union = Moose::Util::TypeConstraints::find_or_create_type_constraint('Int|ArrayRef[Int]'); + subtype 'UnionSub', as 'Int|ArrayRef[Int]'; + + my $subtype = find_type_constraint('UnionSub'); + + ok( + !$union->is_a_type_of('Ref'), + 'Int|ArrayRef[Int] is not a type of Ref' + ); + ok( + !$subtype->is_a_type_of('Ref'), + 'subtype of Int|ArrayRef[Int] is not a type of Ref' + ); + + ok( + $union->is_a_type_of('Defined'), + 'Int|ArrayRef[Int] is a type of Defined' + ); + ok( + $subtype->is_a_type_of('Defined'), + 'subtype of Int|ArrayRef[Int] is a type of Defined' + ); + + ok( + !$union->is_subtype_of('Ref'), + 'Int|ArrayRef[Int] is not a subtype of Ref' + ); + ok( + !$subtype->is_subtype_of('Ref'), + 'subtype of Int|ArrayRef[Int] is not a subtype of Ref' + ); + + ok( + $union->is_subtype_of('Defined'), + 'Int|ArrayRef[Int] is a subtype of Defined' + ); + ok( + $subtype->is_subtype_of('Defined'), + 'subtype of Int|ArrayRef[Int] is a subtype of Defined' + ); +} + +done_testing; diff --git a/t/type_constraints/throw_error.t b/t/type_constraints/throw_error.t new file mode 100644 index 0000000..662d327 --- /dev/null +++ b/t/type_constraints/throw_error.t @@ -0,0 +1,14 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util::TypeConstraints; + + +eval { Moose::Util::TypeConstraints::create_type_constraint_union() }; + +like( $@, qr/\QYou must pass in at least 2 type names to make a union/, + 'can throw a proper error without Moose being loaded by the caller' ); + +done_testing; diff --git a/t/type_constraints/type_coersion_on_lazy_attributes.t b/t/type_constraints/type_coersion_on_lazy_attributes.t new file mode 100644 index 0000000..c8943fe --- /dev/null +++ b/t/type_constraints/type_coersion_on_lazy_attributes.t @@ -0,0 +1,32 @@ +use strict; +use warnings; + +use Test::More; + +{ + package SomeClass; + use Moose; + use Moose::Util::TypeConstraints; + + subtype 'DigitSix' => as 'Num' + => where { /^6$/ }; + subtype 'TextSix' => as 'Str' + => where { /Six/i }; + coerce 'TextSix' + => from 'DigitSix' + => via { confess("Cannot live without 6 ($_)") unless /^6$/; 'Six' }; + + has foo => ( + is => 'ro', + isa => 'TextSix', + coerce => 1, + default => 6, + lazy => 1 + ); +} + +my $attr = SomeClass->meta->get_attribute('foo'); +is($attr->get_value(SomeClass->new()), 'Six'); +is(SomeClass->new()->foo, 'Six'); + +done_testing; diff --git a/t/type_constraints/type_names.t b/t/type_constraints/type_names.t new file mode 100644 index 0000000..bc4dcaf --- /dev/null +++ b/t/type_constraints/type_names.t @@ -0,0 +1,46 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::TypeConstraint; +use Moose::Util::TypeConstraints; + + +TODO: +{ + local $TODO = 'type names are not validated in the TC metaclass'; + + # Test written in this way to avoid a warning from like(undef, qr...); + # -- rjbs, 2010-10-25 + my $error = exception { + Moose::Meta::TypeConstraint->new( name => 'Foo-Bar' ) + }; + + if (defined $error) { + like( + $error, + qr/contains invalid characters/, + 'Type names cannot contain a dash', + ); + } else { + fail("Type names cannot contain a dash"); + } +} + +is( exception { Moose::Meta::TypeConstraint->new( name => 'Foo.Bar::Baz' ) }, undef, 'Type names can contain periods and colons' ); + +like( exception { subtype 'Foo-Baz' => as 'Item' }, qr/contains invalid characters/, 'Type names cannot contain a dash (via subtype sugar)' ); + +is( exception { subtype 'Foo.Bar::Baz' => as 'Item' }, undef, 'Type names can contain periods and colons (via subtype sugar)' ); + +is( Moose::Util::TypeConstraints::find_or_parse_type_constraint('ArrayRef[In-valid]'), + undef, + 'find_or_parse_type_constraint returns undef on an invalid name' ); + +is( Moose::Util::TypeConstraints::find_or_parse_type_constraint('ArrayRef[Va.lid]'), + 'ArrayRef[Va.lid]', + 'find_or_parse_type_constraint returns name for valid name' ); + +done_testing; diff --git a/t/type_constraints/type_notation_parser.t b/t/type_constraints/type_notation_parser.t new file mode 100644 index 0000000..66720a4 --- /dev/null +++ b/t/type_constraints/type_notation_parser.t @@ -0,0 +1,103 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util::TypeConstraints; + +=pod + +This is a good candidate for LectroTest +Volunteers welcome :) + +=cut + +## check the containers + +ok(Moose::Util::TypeConstraints::_detect_parameterized_type_constraint($_), + '... this correctly detected a container (' . $_ . ')') + for ( + 'ArrayRef[Foo]', + 'ArrayRef[Foo | Int]', + 'ArrayRef[ArrayRef[Int]]', + 'ArrayRef[ArrayRef[Int | Foo]]', + 'ArrayRef[ArrayRef[Int|Str]]', +); + +ok(!Moose::Util::TypeConstraints::_detect_parameterized_type_constraint($_), + '... this correctly detected a non-container (' . $_ . ')') + for ( + 'ArrayRef[]', + 'ArrayRef[Foo]Bar', +); + +{ + my %split_tests = ( + 'ArrayRef[Foo]' => [ 'ArrayRef', 'Foo' ], + 'ArrayRef[Foo | Int]' => [ 'ArrayRef', 'Foo | Int' ], + 'ArrayRef[Foo|Int]' => [ 'ArrayRef', 'Foo|Int' ], + # these will get processed with recusion, + # so we only need to detect it once + 'ArrayRef[ArrayRef[Int]]' => [ 'ArrayRef', 'ArrayRef[Int]' ], + 'ArrayRef[ArrayRef[Int | Foo]]' => [ 'ArrayRef', 'ArrayRef[Int | Foo]' ], + 'ArrayRef[ArrayRef[Int|Str]]' => [ 'ArrayRef', 'ArrayRef[Int|Str]' ], + ); + + is_deeply( + [ Moose::Util::TypeConstraints::_parse_parameterized_type_constraint($_) ], + $split_tests{$_}, + '... this correctly split the container (' . $_ . ')' + ) for keys %split_tests; +} + +## now for the unions + +ok(Moose::Util::TypeConstraints::_detect_type_constraint_union($_), + '... this correctly detected union (' . $_ . ')') + for ( + 'Int | Str', + 'Int|Str', + 'ArrayRef[Foo] | Int', + 'ArrayRef[Foo]|Int', + 'Int | ArrayRef[Foo]', + 'Int|ArrayRef[Foo]', + 'ArrayRef[Foo | Int] | Str', + 'ArrayRef[Foo|Int]|Str', + 'Str | ArrayRef[Foo | Int]', + 'Str|ArrayRef[Foo|Int]', + 'Some|Silly|Name|With|Pipes | Int', + 'Some|Silly|Name|With|Pipes|Int', +); + +ok(!Moose::Util::TypeConstraints::_detect_type_constraint_union($_), + '... this correctly detected a non-union (' . $_ . ')') + for ( + 'Int', + 'ArrayRef[Foo | Int]', + 'ArrayRef[Foo|Int]', +); + +{ + my %split_tests = ( + 'Int | Str' => [ 'Int', 'Str' ], + 'Int|Str' => [ 'Int', 'Str' ], + 'ArrayRef[Foo] | Int' => [ 'ArrayRef[Foo]', 'Int' ], + 'ArrayRef[Foo]|Int' => [ 'ArrayRef[Foo]', 'Int' ], + 'Int | ArrayRef[Foo]' => [ 'Int', 'ArrayRef[Foo]' ], + 'Int|ArrayRef[Foo]' => [ 'Int', 'ArrayRef[Foo]' ], + 'ArrayRef[Foo | Int] | Str' => [ 'ArrayRef[Foo | Int]', 'Str' ], + 'ArrayRef[Foo|Int]|Str' => [ 'ArrayRef[Foo|Int]', 'Str' ], + 'Str | ArrayRef[Foo | Int]' => [ 'Str', 'ArrayRef[Foo | Int]' ], + 'Str|ArrayRef[Foo|Int]' => [ 'Str', 'ArrayRef[Foo|Int]' ], + 'Some|Silly|Name|With|Pipes | Int' => [ 'Some', 'Silly', 'Name', 'With', 'Pipes', 'Int' ], + 'Some|Silly|Name|With|Pipes|Int' => [ 'Some', 'Silly', 'Name', 'With', 'Pipes', 'Int' ], + ); + + is_deeply( + [ Moose::Util::TypeConstraints::_parse_type_constraint_union($_) ], + $split_tests{$_}, + '... this correctly split the union (' . $_ . ')' + ) for keys %split_tests; +} + +done_testing; diff --git a/t/type_constraints/types_and_undef.t b/t/type_constraints/types_and_undef.t new file mode 100644 index 0000000..5fdff67 --- /dev/null +++ b/t/type_constraints/types_and_undef.t @@ -0,0 +1,108 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + + use Scalar::Util (); + + type Number + => where { defined($_) && !ref($_) && Scalar::Util::looks_like_number($_) }; + + type String + => where { defined($_) && !ref($_) && !Scalar::Util::looks_like_number($_) }; + + has vUndef => ( is => 'rw', isa => 'Undef' ); + has vDefined => ( is => 'rw', isa => 'Defined' ); + has vInt => ( is => 'rw', isa => 'Int' ); + has vNumber => ( is => 'rw', isa => 'Number' ); + has vStr => ( is => 'rw', isa => 'Str' ); + has vString => ( is => 'rw', isa => 'String' ); + + has v_lazy_Undef => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'Undef' ); + has v_lazy_Defined => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'Defined' ); + has v_lazy_Int => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'Int' ); + has v_lazy_Number => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'Number' ); + has v_lazy_Str => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'Str' ); + has v_lazy_String => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'String' ); +} + +# EXPORT TYPE CONSTRAINTS +# +Moose::Util::TypeConstraints->export_type_constraints_as_functions; + +ok( Undef(undef), '... undef is a Undef'); +ok(!Defined(undef), '... undef is NOT a Defined'); +ok(!Int(undef), '... undef is NOT an Int'); +ok(!Number(undef), '... undef is NOT a Number'); +ok(!Str(undef), '... undef is NOT a Str'); +ok(!String(undef), '... undef is NOT a String'); + +ok(!Undef(5), '... 5 is a NOT a Undef'); +ok(Defined(5), '... 5 is a Defined'); +ok(Int(5), '... 5 is an Int'); +ok(Number(5), '... 5 is a Number'); +ok(Str(5), '... 5 is a Str'); +ok(!String(5), '... 5 is NOT a String'); + +ok(!Undef(0.5), '... 0.5 is a NOT a Undef'); +ok(Defined(0.5), '... 0.5 is a Defined'); +ok(!Int(0.5), '... 0.5 is NOT an Int'); +ok(Number(0.5), '... 0.5 is a Number'); +ok(Str(0.5), '... 0.5 is a Str'); +ok(!String(0.5), '... 0.5 is NOT a String'); + +ok(!Undef('Foo'), '... "Foo" is NOT a Undef'); +ok(Defined('Foo'), '... "Foo" is a Defined'); +ok(!Int('Foo'), '... "Foo" is NOT an Int'); +ok(!Number('Foo'), '... "Foo" is NOT a Number'); +ok(Str('Foo'), '... "Foo" is a Str'); +ok(String('Foo'), '... "Foo" is a String'); + + +my $foo = Foo->new; + +is( exception { $foo->vUndef(undef) }, undef, '... undef is a Foo->Undef' ); +isnt( exception { $foo->vDefined(undef) }, undef, '... undef is NOT a Foo->Defined' ); +isnt( exception { $foo->vInt(undef) }, undef, '... undef is NOT a Foo->Int' ); +isnt( exception { $foo->vNumber(undef) }, undef, '... undef is NOT a Foo->Number' ); +isnt( exception { $foo->vStr(undef) }, undef, '... undef is NOT a Foo->Str' ); +isnt( exception { $foo->vString(undef) }, undef, '... undef is NOT a Foo->String' ); + +isnt( exception { $foo->vUndef(5) }, undef, '... 5 is NOT a Foo->Undef' ); +is( exception { $foo->vDefined(5) }, undef, '... 5 is a Foo->Defined' ); +is( exception { $foo->vInt(5) }, undef, '... 5 is a Foo->Int' ); +is( exception { $foo->vNumber(5) }, undef, '... 5 is a Foo->Number' ); +is( exception { $foo->vStr(5) }, undef, '... 5 is a Foo->Str' ); +isnt( exception { $foo->vString(5) }, undef, '... 5 is NOT a Foo->String' ); + +isnt( exception { $foo->vUndef(0.5) }, undef, '... 0.5 is NOT a Foo->Undef' ); +is( exception { $foo->vDefined(0.5) }, undef, '... 0.5 is a Foo->Defined' ); +isnt( exception { $foo->vInt(0.5) }, undef, '... 0.5 is NOT a Foo->Int' ); +is( exception { $foo->vNumber(0.5) }, undef, '... 0.5 is a Foo->Number' ); +is( exception { $foo->vStr(0.5) }, undef, '... 0.5 is a Foo->Str' ); +isnt( exception { $foo->vString(0.5) }, undef, '... 0.5 is NOT a Foo->String' ); + +isnt( exception { $foo->vUndef('Foo') }, undef, '... "Foo" is NOT a Foo->Undef' ); +is( exception { $foo->vDefined('Foo') }, undef, '... "Foo" is a Foo->Defined' ); +isnt( exception { $foo->vInt('Foo') }, undef, '... "Foo" is NOT a Foo->Int' ); +isnt( exception { $foo->vNumber('Foo') }, undef, '... "Foo" is NOT a Foo->Number' ); +is( exception { $foo->vStr('Foo') }, undef, '... "Foo" is a Foo->Str' ); +is( exception { $foo->vString('Foo') }, undef, '... "Foo" is a Foo->String' ); + +# the lazy tests + +is( exception { $foo->v_lazy_Undef() }, undef, '... undef is a Foo->Undef' ); +isnt( exception { $foo->v_lazy_Defined() }, undef, '... undef is NOT a Foo->Defined' ); +isnt( exception { $foo->v_lazy_Int() }, undef, '... undef is NOT a Foo->Int' ); +isnt( exception { $foo->v_lazy_Number() }, undef, '... undef is NOT a Foo->Number' ); +isnt( exception { $foo->v_lazy_Str() }, undef, '... undef is NOT a Foo->Str' ); +isnt( exception { $foo->v_lazy_String() }, undef, '... undef is NOT a Foo->String' ); + +done_testing; diff --git a/t/type_constraints/union_is_a_type_of.t b/t/type_constraints/union_is_a_type_of.t new file mode 100644 index 0000000..60b6ef7 --- /dev/null +++ b/t/type_constraints/union_is_a_type_of.t @@ -0,0 +1,49 @@ +use strict; +use warnings; + +use Test::Fatal; +use Test::More; + +use Moose::Util::TypeConstraints 'find_type_constraint'; + +use Moose::Meta::TypeConstraint::Union; + +my ( $item, $int, $classname, $num ) + = map { find_type_constraint($_) } qw{Item Int ClassName Num}; + +ok( $int->is_subtype_of($item), 'Int is subtype of Item' ); +ok( $classname->is_subtype_of($item), 'ClassName is subtype of Item' ); +ok( + ( not $int->is_subtype_of($classname) ), + 'Int is not subtype of ClassName' +); +ok( + ( not $classname->is_subtype_of($int) ), + 'ClassName is not subtype of Int' +); + +my $union = Moose::Meta::TypeConstraint::Union->new( + type_constraints => [ $int, $classname ] ); + +my @domain_values = qw( 85439 Moose::Meta::TypeConstraint ); +is( + exception { $union->assert_valid($_) }, + undef, + qq{Union accepts "$_".} +) for @domain_values; + +ok( + $union->is_subtype_of( find_type_constraint($_) ), + "Int|ClassName is a subtype of $_" +) for qw{Item Defined Value Str}; + +ok( + ( not $union->is_subtype_of( find_type_constraint($_) ) ), + "Int|ClassName is not a subtype of $_" +) for qw{Num Int ClassName}; + +ok( + ( not $union->is_a_type_of( find_type_constraint($_) ) ), + "Int|ClassName is not a type of $_" +) for qw{Int ClassName}; +done_testing; diff --git a/t/type_constraints/union_types.t b/t/type_constraints/union_types.t new file mode 100644 index 0000000..276492c --- /dev/null +++ b/t/type_constraints/union_types.t @@ -0,0 +1,195 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util::TypeConstraints; + +my $Str = find_type_constraint('Str'); +isa_ok( $Str, 'Moose::Meta::TypeConstraint' ); + +my $Undef = find_type_constraint('Undef'); +isa_ok( $Undef, 'Moose::Meta::TypeConstraint' ); + +ok( !$Str->check(undef), '... Str cannot accept an Undef value' ); +ok( $Str->check('String'), '... Str can accept an String value' ); +ok( !$Undef->check('String'), '... Undef cannot accept an Str value' ); +ok( $Undef->check(undef), '... Undef can accept an Undef value' ); + +my $Str_or_Undef = Moose::Meta::TypeConstraint::Union->new( + type_constraints => [ $Str, $Undef ] ); +isa_ok( $Str_or_Undef, 'Moose::Meta::TypeConstraint::Union' ); + +ok( + $Str_or_Undef->check(undef), + '... (Str | Undef) can accept an Undef value' +); +ok( + $Str_or_Undef->check('String'), + '... (Str | Undef) can accept a String value' +); + +ok( !$Str_or_Undef->is_a_type_of($Str), "not a subtype of Str" ); +ok( !$Str_or_Undef->is_a_type_of($Undef), "not a subtype of Undef" ); + +cmp_ok( + $Str_or_Undef->find_type_for('String'), 'eq', 'Str', + 'find_type_for Str' +); +cmp_ok( + $Str_or_Undef->find_type_for(undef), 'eq', 'Undef', + 'find_type_for Undef' +); +ok( + !defined( $Str_or_Undef->find_type_for( sub { } ) ), + 'no find_type_for CodeRef' +); + +ok( !$Str_or_Undef->equals($Str), "not equal to Str" ); +ok( $Str_or_Undef->equals($Str_or_Undef), "equal to self" ); +ok( + $Str_or_Undef->equals( + Moose::Meta::TypeConstraint::Union->new( + type_constraints => [ $Str, $Undef ] + ) + ), + "equal to clone" +); +ok( + $Str_or_Undef->equals( + Moose::Meta::TypeConstraint::Union->new( + type_constraints => [ $Undef, $Str ] + ) + ), + "equal to reversed clone" +); + +ok( + !$Str_or_Undef->is_a_type_of("ThisTypeDoesNotExist"), + "not type of non existent type" +); +ok( + !$Str_or_Undef->is_subtype_of("ThisTypeDoesNotExist"), + "not subtype of non existent type" +); + +is( + $Str_or_Undef->parent, + find_type_constraint('Item'), + 'parent of Str|Undef is Item' +); + +is_deeply( + [$Str_or_Undef->parents], + [find_type_constraint('Item')], + 'parents of Str|Undef is Item' +); + +# another .... + +my $ArrayRef = find_type_constraint('ArrayRef'); +isa_ok( $ArrayRef, 'Moose::Meta::TypeConstraint' ); + +my $HashRef = find_type_constraint('HashRef'); +isa_ok( $HashRef, 'Moose::Meta::TypeConstraint' ); + +ok( $ArrayRef->check( [] ), '... ArrayRef can accept an [] value' ); +ok( !$ArrayRef->check( {} ), '... ArrayRef cannot accept an {} value' ); +ok( $HashRef->check( {} ), '... HashRef can accept an {} value' ); +ok( !$HashRef->check( [] ), '... HashRef cannot accept an [] value' ); + +my $ArrayRef_or_HashRef = Moose::Meta::TypeConstraint::Union->new( + type_constraints => [ $ArrayRef, $HashRef ] ); +isa_ok( $ArrayRef_or_HashRef, 'Moose::Meta::TypeConstraint::Union' ); + +ok( $ArrayRef_or_HashRef->check( [] ), + '... (ArrayRef | HashRef) can accept []' ); +ok( $ArrayRef_or_HashRef->check( {} ), + '... (ArrayRef | HashRef) can accept {}' ); + +ok( + !$ArrayRef_or_HashRef->check( \( my $var1 ) ), + '... (ArrayRef | HashRef) cannot accept scalar refs' +); +ok( + !$ArrayRef_or_HashRef->check( sub { } ), + '... (ArrayRef | HashRef) cannot accept code refs' +); +ok( + !$ArrayRef_or_HashRef->check(50), + '... (ArrayRef | HashRef) cannot accept Numbers' +); + +diag $ArrayRef_or_HashRef->validate( [] ); + +ok( + !defined( $ArrayRef_or_HashRef->validate( [] ) ), + '... (ArrayRef | HashRef) can accept []' +); +ok( + !defined( $ArrayRef_or_HashRef->validate( {} ) ), + '... (ArrayRef | HashRef) can accept {}' +); + +like( + $ArrayRef_or_HashRef->validate( \( my $var2 ) ), + qr/Validation failed for \'ArrayRef\' with value .+ and Validation failed for \'HashRef\' with value .+ in \(ArrayRef\|HashRef\)/, + '... (ArrayRef | HashRef) cannot accept scalar refs' +); + +like( + $ArrayRef_or_HashRef->validate( sub { } ), + qr/Validation failed for \'ArrayRef\' with value .+ and Validation failed for \'HashRef\' with value .+ in \(ArrayRef\|HashRef\)/, + '... (ArrayRef | HashRef) cannot accept code refs' +); + +is( + $ArrayRef_or_HashRef->validate(50), + 'Validation failed for \'ArrayRef\' with value 50 and Validation failed for \'HashRef\' with value 50 in (ArrayRef|HashRef)', + '... (ArrayRef | HashRef) cannot accept Numbers' +); + +is( + $ArrayRef_or_HashRef->parent, + find_type_constraint('Ref'), + 'parent of ArrayRef|HashRef is Ref' +); + +my $double_union = Moose::Meta::TypeConstraint::Union->new( + type_constraints => [ $Str_or_Undef, $ArrayRef_or_HashRef ] ); + +is( + $double_union->parent, + find_type_constraint('Item'), + 'parent of (Str|Undef)|(ArrayRef|HashRef) is Item' +); + +ok( + $double_union->is_subtype_of('Item'), + '(Str|Undef)|(ArrayRef|HashRef) is a subtype of Item' +); + +ok( + $double_union->is_a_type_of('Item'), + '(Str|Undef)|(ArrayRef|HashRef) is a type of Item' +); + +ok( + !$double_union->is_a_type_of('Str'), + '(Str|Undef)|(ArrayRef|HashRef) is not a type of Str' +); + +type 'SomeType', where { 1 }; +type 'OtherType', where { 1 }; + +my $parentless_union = Moose::Meta::TypeConstraint::Union->new( + type_constraints => [ + find_type_constraint('SomeType'), + find_type_constraint('OtherType'), + ], +); + +is($parentless_union->parent, undef, "no common ancestor gives undef parent"); + + +done_testing; diff --git a/t/type_constraints/union_types_and_coercions.t b/t/type_constraints/union_types_and_coercions.t new file mode 100644 index 0000000..8c3f807 --- /dev/null +++ b/t/type_constraints/union_types_and_coercions.t @@ -0,0 +1,181 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::Requires qw(IO::String IO::File); # skip all if not installed + +{ + package Email::Moose; + use Moose; + use Moose::Util::TypeConstraints; + + use IO::String; + + our $VERSION = '0.01'; + + # create subtype for IO::String + + subtype 'IO::String' + => as 'Object' + => where { $_->isa('IO::String') }; + + coerce 'IO::String' + => from 'Str' + => via { IO::String->new($_) }, + => from 'ScalarRef', + => via { IO::String->new($_) }; + + # create subtype for IO::File + + subtype 'IO::File' + => as 'Object' + => where { $_->isa('IO::File') }; + + coerce 'IO::File' + => from 'FileHandle' + => via { bless $_, 'IO::File' }; + + # create the alias + + subtype 'IO::StringOrFile' => as 'IO::String | IO::File'; + + # attributes + + has 'raw_body' => ( + is => 'rw', + isa => 'IO::StringOrFile', + coerce => 1, + default => sub { IO::String->new() }, + ); + + sub as_string { + my ($self) = @_; + my $fh = $self->raw_body(); + return do { local $/; <$fh> }; + } +} + +{ + my $email = Email::Moose->new; + isa_ok($email, 'Email::Moose'); + + isa_ok($email->raw_body, 'IO::String'); + + is($email->as_string, undef, '... got correct empty string'); +} + +{ + my $email = Email::Moose->new(raw_body => '... this is my body ...'); + isa_ok($email, 'Email::Moose'); + + isa_ok($email->raw_body, 'IO::String'); + + is($email->as_string, '... this is my body ...', '... got correct string'); + + is( exception { + $email->raw_body('... this is the next body ...'); + }, undef, '... this will coerce correctly' ); + + isa_ok($email->raw_body, 'IO::String'); + + is($email->as_string, '... this is the next body ...', '... got correct string'); +} + +{ + my $str = '... this is my body (ref) ...'; + + my $email = Email::Moose->new(raw_body => \$str); + isa_ok($email, 'Email::Moose'); + + isa_ok($email->raw_body, 'IO::String'); + + is($email->as_string, $str, '... got correct string'); + + my $str2 = '... this is the next body (ref) ...'; + + is( exception { + $email->raw_body(\$str2); + }, undef, '... this will coerce correctly' ); + + isa_ok($email->raw_body, 'IO::String'); + + is($email->as_string, $str2, '... got correct string'); +} + +{ + my $io_str = IO::String->new('... this is my body (IO::String) ...'); + + my $email = Email::Moose->new(raw_body => $io_str); + isa_ok($email, 'Email::Moose'); + + isa_ok($email->raw_body, 'IO::String'); + is($email->raw_body, $io_str, '... and it is the one we expected'); + + is($email->as_string, '... this is my body (IO::String) ...', '... got correct string'); + + my $io_str2 = IO::String->new('... this is the next body (IO::String) ...'); + + is( exception { + $email->raw_body($io_str2); + }, undef, '... this will coerce correctly' ); + + isa_ok($email->raw_body, 'IO::String'); + is($email->raw_body, $io_str2, '... and it is the one we expected'); + + is($email->as_string, '... this is the next body (IO::String) ...', '... got correct string'); +} + +{ + my $fh; + + open($fh, '<', $0) || die "Could not open $0"; + + my $email = Email::Moose->new(raw_body => $fh); + isa_ok($email, 'Email::Moose'); + + isa_ok($email->raw_body, 'IO::File'); + + close($fh); +} + +{ + my $fh = IO::File->new($0); + + my $email = Email::Moose->new(raw_body => $fh); + isa_ok($email, 'Email::Moose'); + + isa_ok($email->raw_body, 'IO::File'); + is($email->raw_body, $fh, '... and it is the one we expected'); +} + +{ + package Foo; + + use Moose; + use Moose::Util::TypeConstraints; + + subtype 'Coerced' => as 'ArrayRef'; + coerce 'Coerced' + => from 'Value' + => via { [ $_ ] }; + + has carray => ( + is => 'ro', + isa => 'Coerced | Coerced', + coerce => 1, + ); +} + +{ + my $foo; + is( exception { $foo = Foo->new( carray => 1 ) }, undef, 'Can pass non-ref value for carray' ); + is_deeply( + $foo->carray, [1], + 'carray was coerced to an array ref' + ); + + like( exception { Foo->new( carray => {} ) }, qr/\QValidation failed for 'Coerced|Coerced' with value \E(?!undef)/, 'Cannot pass a hash ref for carray attribute, and hash ref is not coerced to an undef' ); +} + +done_testing; diff --git a/t/type_constraints/util_find_type_constraint.t b/t/type_constraints/util_find_type_constraint.t new file mode 100644 index 0000000..8da3af0 --- /dev/null +++ b/t/type_constraints/util_find_type_constraint.t @@ -0,0 +1,34 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util::TypeConstraints; + +foreach my $type_name (qw( + Any + Item + Bool + Undef + Defined + Value + Num + Int + Str + Ref + ScalarRef + ArrayRef + HashRef + CodeRef + RegexpRef + Object + )) { + is(find_type_constraint($type_name)->name, + $type_name, + '... got the right name for ' . $type_name); +} + +# TODO: +# add tests for is_subtype_of which confirm the hierarchy + +done_testing; diff --git a/t/type_constraints/util_more_type_coercion.t b/t/type_constraints/util_more_type_coercion.t new file mode 100644 index 0000000..0aa7f66 --- /dev/null +++ b/t/type_constraints/util_more_type_coercion.t @@ -0,0 +1,130 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package HTTPHeader; + use Moose; + use Moose::Util::TypeConstraints; + + coerce 'HTTPHeader' + => from ArrayRef + => via { HTTPHeader->new(array => $_[0]) }; + + coerce 'HTTPHeader' + => from HashRef + => via { HTTPHeader->new(hash => $_[0]) }; + + has 'array' => (is => 'ro'); + has 'hash' => (is => 'ro'); + + package Engine; + use strict; + use warnings; + use Moose; + + has 'header' => (is => 'rw', isa => 'HTTPHeader', coerce => 1); +} + +{ + my $engine = Engine->new(); + isa_ok($engine, 'Engine'); + + # try with arrays + + is( exception { + $engine->header([ 1, 2, 3 ]); + }, undef, '... type was coerced without incident' ); + isa_ok($engine->header, 'HTTPHeader'); + + is_deeply( + $engine->header->array, + [ 1, 2, 3 ], + '... got the right array value of the header'); + ok(!defined($engine->header->hash), '... no hash value set'); + + # try with hash + + is( exception { + $engine->header({ one => 1, two => 2, three => 3 }); + }, undef, '... type was coerced without incident' ); + isa_ok($engine->header, 'HTTPHeader'); + + is_deeply( + $engine->header->hash, + { one => 1, two => 2, three => 3 }, + '... got the right hash value of the header'); + ok(!defined($engine->header->array), '... no array value set'); + + isnt( exception { + $engine->header("Foo"); + }, undef, '... dies with the wrong type, even after coercion' ); + + is( exception { + $engine->header(HTTPHeader->new); + }, undef, '... lives with the right type, even after coercion' ); +} + +{ + my $engine = Engine->new(header => [ 1, 2, 3 ]); + isa_ok($engine, 'Engine'); + + isa_ok($engine->header, 'HTTPHeader'); + + is_deeply( + $engine->header->array, + [ 1, 2, 3 ], + '... got the right array value of the header'); + ok(!defined($engine->header->hash), '... no hash value set'); +} + +{ + my $engine = Engine->new(header => { one => 1, two => 2, three => 3 }); + isa_ok($engine, 'Engine'); + + isa_ok($engine->header, 'HTTPHeader'); + + is_deeply( + $engine->header->hash, + { one => 1, two => 2, three => 3 }, + '... got the right hash value of the header'); + ok(!defined($engine->header->array), '... no array value set'); +} + +{ + my $engine = Engine->new(header => HTTPHeader->new()); + isa_ok($engine, 'Engine'); + + isa_ok($engine->header, 'HTTPHeader'); + + ok(!defined($engine->header->hash), '... no hash value set'); + ok(!defined($engine->header->array), '... no array value set'); +} + +isnt( exception { + Engine->new(header => 'Foo'); +}, undef, '... dies correctly with bad params' ); + +isnt( exception { + Engine->new(header => \(my $var)); +}, undef, '... dies correctly with bad params' ); + +{ + my $tc = Moose::Util::TypeConstraints::find_type_constraint('HTTPHeader'); + isa_ok($tc, 'Moose::Meta::TypeConstraint', 'HTTPHeader TC'); + + my $from_aref = $tc->assert_coerce([ 1, 2, 3 ]); + isa_ok($from_aref, 'HTTPHeader', 'assert_coerce from aref to HTTPHeader'); + is_deeply($from_aref->array, [ 1, 2, 3 ], '...and has the right guts'); + + my $from_href = $tc->assert_coerce({ a => 1 }); + isa_ok($from_href, 'HTTPHeader', 'assert_coerce from href to HTTPHeader'); + is_deeply($from_href->hash, { a => 1 }, '...and has the right guts'); + + like( exception { $tc->assert_coerce('total garbage') }, qr/Validation failed for .HTTPHeader./, "assert_coerce throws if result is not acceptable" ); +} + +done_testing; diff --git a/t/type_constraints/util_std_type_constraints.t b/t/type_constraints/util_std_type_constraints.t new file mode 100644 index 0000000..534b190 --- /dev/null +++ b/t/type_constraints/util_std_type_constraints.t @@ -0,0 +1,1305 @@ +use strict; +use warnings; + +use Test::Fatal; +use Test::More; + +use Eval::Closure; +use IO::File; +use Moose::Util::TypeConstraints; +use Scalar::Util qw( blessed openhandle ); + +my $ZERO = 0; +my $ONE = 1; +my $INT = 100; +my $NEG_INT = -100; +my $NUM = 42.42; +my $NEG_NUM = -42.42; + +my $EMPTY_STRING = q{}; +my $STRING = 'foo'; +my $NUM_IN_STRING = 'has 42 in it'; +my $INT_WITH_NL1 = "1\n"; +my $INT_WITH_NL2 = "\n1"; + +my $SCALAR_REF = \( my $var ); +my $SCALAR_REF_REF = \$SCALAR_REF; +my $ARRAY_REF = []; +my $HASH_REF = {}; +my $CODE_REF = sub { }; + +my $GLOB = do { no warnings 'once'; *GLOB_REF }; +my $GLOB_REF = \$GLOB; + +open my $FH, '<', $0 or die "Could not open $0 for the test"; + +my $FH_OBJECT = IO::File->new( $0, 'r' ) + or die "Could not open $0 for the test"; + +my $REGEX = qr/../; +my $REGEX_OBJ = bless qr/../, 'BlessedQR'; +my $FAKE_REGEX = bless {}, 'Regexp'; + +my $OBJECT = bless {}, 'Foo'; + +my $UNDEF = undef; + +{ + package Thing; + + sub foo { } +} + +my $CLASS_NAME = 'Thing'; + +{ + package Role; + use Moose::Role; + + sub foo { } +} + +my $ROLE_NAME = 'Role'; + +my %tests = ( + Any => { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + }, + Item => { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + }, + Defined => { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + ], + reject => [ + $UNDEF, + ], + }, + Undef => { + accept => [ + $UNDEF, + ], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + ], + }, + Bool => { + accept => [ + $ZERO, + $ONE, + $EMPTY_STRING, + $UNDEF, + ], + reject => [ + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + ], + }, + Maybe => { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + }, + Value => { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $GLOB, + ], + reject => [ + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + }, + Ref => { + accept => [ + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + ], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $GLOB, + $UNDEF, + ], + }, + Num => { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + ], + reject => [ + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + $INT_WITH_NL1, + $INT_WITH_NL2, + ], + }, + Int => { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + ], + reject => [ + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + }, + Str => { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + ], + reject => [ + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + }, + ScalarRef => { + accept => [ + $SCALAR_REF, + $SCALAR_REF_REF, + ], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + }, + ArrayRef => { + accept => [ + $ARRAY_REF, + ], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + }, + HashRef => { + accept => [ + $HASH_REF, + ], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + }, + CodeRef => { + accept => [ + $CODE_REF, + ], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + }, + RegexpRef => { + accept => [ + $REGEX, + $REGEX_OBJ, + ], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $OBJECT, + $UNDEF, + $FAKE_REGEX, + ], + }, + GlobRef => { + accept => [ + $GLOB_REF, + $FH, + ], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $FH_OBJECT, + $OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $UNDEF, + ], + }, + FileHandle => { + accept => [ + $FH, + $FH_OBJECT, + ], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $UNDEF, + ], + }, + Object => { + accept => [ + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + ], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $UNDEF, + ], + }, + ClassName => { + accept => [ + $CLASS_NAME, + $ROLE_NAME, + ], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + }, + RoleName => { + accept => [ + $ROLE_NAME, + ], + reject => [ + $CLASS_NAME, + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + }, +); + +for my $name ( sort keys %tests ) { + test_constraint( $name, $tests{$name} ); + + test_constraint( + Moose::Util::TypeConstraints::find_or_create_type_constraint( + "$name|$name"), + $tests{$name} + ); +} + +my %substr_test_str = ( + ClassName => 'x' . $CLASS_NAME, + RoleName => 'x' . $ROLE_NAME, +); + +# We need to test that the Str constraint (and types that derive from it) +# accept the return val of substr() - which means passing that return val +# directly to the checking code +foreach my $type_name (qw(Str Num Int ClassName RoleName)) +{ + my $str = $substr_test_str{$type_name} || '123456789'; + + my $type = Moose::Util::TypeConstraints::find_type_constraint($type_name); + + my $unoptimized + = $type->has_parent + ? $type->_compile_subtype( $type->constraint ) + : $type->_compile_type( $type->constraint ); + + my $inlined; + { + $inlined = eval_closure( + source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }', + ); + } + + ok( + $type->check( substr( $str, 1, 5 ) ), + $type_name . ' accepts return val from substr using ->check' + ); + ok( + $unoptimized->( substr( $str, 1, 5 ) ), + $type_name . ' accepts return val from substr using unoptimized constraint' + ); + ok( + $inlined->( substr( $str, 1, 5 ) ), + $type_name . ' accepts return val from substr using inlined constraint' + ); + + # only Str accepts empty strings. + next unless $type_name eq 'Str'; + + ok( + $type->check( substr( $str, 0, 0 ) ), + $type_name . ' accepts empty return val from substr using ->check' + ); + ok( + $unoptimized->( substr( $str, 0, 0 ) ), + $type_name . ' accepts empty return val from substr using unoptimized constraint' + ); + ok( + $inlined->( substr( $str, 0, 0 ) ), + $type_name . ' accepts empty return val from substr using inlined constraint' + ); +} + +{ + my $class_tc = class_type('Thing'); + + test_constraint( + $class_tc, { + accept => [ + ( bless {}, 'Thing' ), + ], + reject => [ + 'Thing', + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + } + ); +} + +{ + package Duck; + + sub quack { } + sub flap { } +} + +{ + package DuckLike; + + sub quack { } + sub flap { } +} + +{ + package Bird; + + sub flap { } +} + +{ + my @methods = qw( quack flap ); + duck_type 'Duck' => \@methods; + + test_constraint( + 'Duck', { + accept => [ + ( bless {}, 'Duck' ), + ( bless {}, 'DuckLike' ), + ], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + ( bless {}, 'Bird' ), + $UNDEF, + ], + } + ); +} + +{ + my @allowed = qw( bar baz quux ); + enum 'Enumerated' => \@allowed; + + test_constraint( + 'Enumerated', { + accept => \@allowed, + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + } + ); +} + +{ + my $union = Moose::Meta::TypeConstraint::Union->new( + type_constraints => [ + find_type_constraint('Int'), + find_type_constraint('Object'), + ], + ); + + test_constraint( + $union, { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + ], + reject => [ + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $UNDEF, + ], + } + ); +} +{ + note 'Anonymous Union Test'; + + my $union = union(['Int','Object']); + + test_constraint( + $union, { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + ], + reject => [ + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $UNDEF, + ], + } + ); +} +{ + note 'Named Union Test'; + union 'NamedUnion' => ['Int','Object']; + + test_constraint( + 'NamedUnion', { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + ], + reject => [ + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $UNDEF, + ], + } + ); +} + +{ + note 'Combined Union Test'; + my $union = union( [ 'Int', enum( [qw[ red green blue ]] ) ] ); + + test_constraint( + $union, { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + 'red', + 'green', + 'blue', + ], + reject => [ + 'yellow', + 'pink', + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $UNDEF, + ], + } + ); +} + + +{ + enum 'Enum1' => ['a', 'b']; + enum 'Enum2' => ['x', 'y']; + + subtype 'EnumUnion', as 'Enum1 | Enum2'; + + test_constraint( + 'EnumUnion', { + accept => [qw( a b x y )], + reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + $UNDEF, + ], + } + ); +} + +{ + package DoesRole; + + use Moose; + + with 'Role'; +} + +# Test how $_ is used in XS implementation +{ + local $_ = qr/./; + ok( + Moose::Util::TypeConstraints::Builtins::_RegexpRef(), + '$_ is RegexpRef' + ); + ok( + !Moose::Util::TypeConstraints::Builtins::_RegexpRef(1), + '$_ is not read when param provided' + ); + + $_ = bless qr/./, 'Blessed'; + + ok( + Moose::Util::TypeConstraints::Builtins::_RegexpRef(), + '$_ is RegexpRef' + ); + + $_ = 42; + ok( + !Moose::Util::TypeConstraints::Builtins::_RegexpRef(), + '$_ is not RegexpRef' + ); + ok( + Moose::Util::TypeConstraints::Builtins::_RegexpRef(qr/./), + '$_ is not read when param provided' + ); +} + +close $FH + or warn "Could not close the filehandle $0 for test"; +$FH_OBJECT->close + or warn "Could not close the filehandle $0 for test"; + +done_testing; + +sub test_constraint { + my $type = shift; + my $tests = shift; + + local $Test::Builder::Level = $Test::Builder::Level + 1; + + unless ( blessed $type ) { + $type = Moose::Util::TypeConstraints::find_type_constraint($type) + or BAIL_OUT("No such type $type!"); + } + + my $name = $type->name; + + my $unoptimized + = $type->has_parent + ? $type->_compile_subtype( $type->constraint ) + : $type->_compile_type( $type->constraint ); + + my $inlined; + if ( $type->can_be_inlined ) { + $inlined = eval_closure( + source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }', + environment => $type->inline_environment, + ); + } + + my $class = Moose::Meta::Class->create_anon( + superclasses => ['Moose::Object'], + ); + $class->add_attribute( + simple => ( + is => 'ro', + isa => $type, + ) + ); + + $class->add_attribute( + collection => ( + traits => ['Array'], + isa => 'ArrayRef[' . $type->name . ']', + default => sub { [] }, + handles => { add_to_collection => 'push' }, + ) + ); + + my $anon_class = $class->name; + + for my $accept ( @{ $tests->{accept} || [] } ) { + my $described = describe($accept); + ok( + $type->check($accept), + "$name accepts $described using ->check" + ); + ok( + $unoptimized->($accept), + "$name accepts $described using unoptimized constraint" + ); + if ($inlined) { + ok( + $inlined->($accept), + "$name accepts $described using inlined constraint" + ); + } + + is( + exception { + $anon_class->new( simple => $accept ); + }, + undef, + "no exception passing $described to constructor with $name" + ); + + is( + exception { + $anon_class->new()->add_to_collection($accept); + }, + undef, + "no exception passing $described to native trait push method with $name" + ); + } + + for my $reject ( @{ $tests->{reject} || [] } ) { + my $described = describe($reject); + ok( + !$type->check($reject), + "$name rejects $described using ->check" + ); + ok( + !$unoptimized->($reject), + "$name rejects $described using unoptimized constraint" + ); + if ($inlined) { + ok( + !$inlined->($reject), + "$name rejects $described using inlined constraint" + ); + } + + ok( + exception { + $anon_class->new( simple => $reject ); + }, + "got exception passing $described to constructor with $name" + ); + + ok( + exception { + $anon_class->new()->add_to_collection($reject); + }, + "got exception passing $described to native trait push method with $name" + ); + } +} + +sub describe { + my $val = shift; + + return 'undef' unless defined $val; + + if ( !ref $val ) { + return q{''} if $val eq q{}; + + $val =~ s/\n/\\n/g; + + return $val; + } + + return 'open filehandle' + if openhandle $val && !blessed $val; + + return blessed $val + ? ( ref $val ) . ' object' + : ( ref $val ) . ' reference'; +} diff --git a/t/type_constraints/util_type_coercion.t b/t/type_constraints/util_type_coercion.t new file mode 100644 index 0000000..a066a76 --- /dev/null +++ b/t/type_constraints/util_type_coercion.t @@ -0,0 +1,100 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +{ + package HTTPHeader; + use Moose; + + has 'array' => (is => 'ro'); + has 'hash' => (is => 'ro'); +} + +subtype Header => + => as Object + => where { $_->isa('HTTPHeader') }; + +coerce Header + => from ArrayRef + => via { HTTPHeader->new(array => $_[0]) } + => from HashRef + => via { HTTPHeader->new(hash => $_[0]) }; + + +Moose::Util::TypeConstraints->export_type_constraints_as_functions(); + +my $header = HTTPHeader->new(); +isa_ok($header, 'HTTPHeader'); + +ok(Header($header), '... this passed the type test'); +ok(!Header([]), '... this did not pass the type test'); +ok(!Header({}), '... this did not pass the type test'); + +my $anon_type = subtype Object => where { $_->isa('HTTPHeader') }; + +is( exception { + coerce $anon_type + => from ArrayRef + => via { HTTPHeader->new(array => $_[0]) } + => from HashRef + => via { HTTPHeader->new(hash => $_[0]) }; +}, undef, 'coercion of anonymous subtype succeeds' ); + +foreach my $coercion ( + find_type_constraint('Header')->coercion, + $anon_type->coercion + ) { + + isa_ok($coercion, 'Moose::Meta::TypeCoercion'); + + { + my $coerced = $coercion->coerce([ 1, 2, 3 ]); + isa_ok($coerced, 'HTTPHeader'); + + is_deeply( + $coerced->array(), + [ 1, 2, 3 ], + '... got the right array'); + is($coerced->hash(), undef, '... nothing assigned to the hash'); + } + + { + my $coerced = $coercion->coerce({ one => 1, two => 2, three => 3 }); + isa_ok($coerced, 'HTTPHeader'); + + is_deeply( + $coerced->hash(), + { one => 1, two => 2, three => 3 }, + '... got the right hash'); + is($coerced->array(), undef, '... nothing assigned to the array'); + } + + { + my $scalar_ref = \(my $var); + my $coerced = $coercion->coerce($scalar_ref); + is($coerced, $scalar_ref, '... got back what we put in'); + } + + { + my $coerced = $coercion->coerce("Foo"); + is($coerced, "Foo", '... got back what we put in'); + } +} + +subtype 'StrWithTrailingX' + => as 'Str' + => where { /X$/ }; + +coerce 'StrWithTrailingX' + => from 'Str' + => via { $_ . 'X' }; + +my $tc = find_type_constraint('StrWithTrailingX'); +is($tc->coerce("foo"), "fooX", "coerce when needed"); +is($tc->coerce("fooX"), "fooX", "do not coerce when unneeded"); + +done_testing; diff --git a/t/type_constraints/util_type_constraints.t b/t/type_constraints/util_type_constraints.t new file mode 100644 index 0000000..6eededc --- /dev/null +++ b/t/type_constraints/util_type_constraints.t @@ -0,0 +1,233 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Scalar::Util (); + +use Moose::Util::TypeConstraints; + + +type Number => where { Scalar::Util::looks_like_number($_) }; +type String + => where { !ref($_) && !Number($_) } + => message { "This is not a string ($_)" }; + +subtype Natural + => as Number + => where { $_ > 0 }; + +subtype NaturalLessThanTen + => as Natural + => where { $_ < 10 } + => message { "The number '$_' is not less than 10" }; + +Moose::Util::TypeConstraints->export_type_constraints_as_functions(); + +ok(Number(5), '... this is a Num'); +ok(!defined(Number('Foo')), '... this is not a Num'); +{ + my $number_tc = Moose::Util::TypeConstraints::find_type_constraint('Number'); + is("$number_tc", 'Number', '... type constraint stringifies to name'); +} + +ok(String('Foo'), '... this is a Str'); +ok(!defined(String(5)), '... this is not a Str'); + +ok(Natural(5), '... this is a Natural'); +is(Natural(-5), undef, '... this is not a Natural'); +is(Natural('Foo'), undef, '... this is not a Natural'); + +ok(NaturalLessThanTen(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'); + +# anon sub-typing + +my $negative = subtype Number => where { $_ < 0 }; +ok(defined $negative, '... got a value back from negative'); +isa_ok($negative, 'Moose::Meta::TypeConstraint'); + +ok($negative->check(-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'); + +ok($negative->is_subtype_of('Number'), '... $negative is a subtype of Number'); +ok(!$negative->is_subtype_of('String'), '... $negative is not a subtype of String'); + +my $negative2 = subtype Number => where { $_ < 0 } => message {"$_ is not a negative number"}; + +ok(defined $negative2, '... got a value back from negative'); +isa_ok($negative2, 'Moose::Meta::TypeConstraint'); + +ok($negative2->check(-5), '... this is a negative number'); +ok(!defined($negative2->check(5)), '... this is not a negative number'); +is($negative2->check('Foo'), undef, '... this is not a negative number'); + +ok($negative2->is_subtype_of('Number'), '... $negative2 is a subtype of Number'); +ok(!$negative2->is_subtype_of('String'), '... $negative is not a subtype of String'); + +ok($negative2->has_message, '... it has a message'); +is($negative2->validate(2), + '2 is not a negative number', + '... validated unsuccessfully (got error)'); + +# 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->is_subtype_of('Natural'), '... NaturalLessThanTen is subtype of Natural'); +ok($natural_less_than_ten->is_subtype_of('Number'), '... NaturalLessThanTen is subtype of Number'); +ok(!$natural_less_than_ten->is_subtype_of('String'), '... NaturalLessThanTen is not subtype of String'); + +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->is_subtype_of('Number'), '... Natural is a subtype of Number'); +ok(!$natural->is_subtype_of('String'), '... Natural is not a subtype of String'); + +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' with value -5", + '... validated unsuccessfully (got error)'); + +my $string = find_type_constraint('String'); +isa_ok($string, 'Moose::Meta::TypeConstraint'); + +ok($string->has_message, '... it does have a message'); + +ok(!defined($string->validate("Five")), '... validated successfully (no error)'); + +is($string->validate(5), +"This is not a string (5)", +'... validated unsuccessfully (got error)'); + +is( exception { Moose::Meta::Attribute->new('bob', isa => 'Spong') }, undef, 'meta-attr construction ok even when type constraint utils loaded first' ); + +# Test type constraint predicate return values. + +foreach my $predicate (qw/equals is_subtype_of is_a_type_of/) { + ok( !defined $string->$predicate('DoesNotExist'), "$predicate predicate returns undef for non existant constraint"); +} + +# Test adding things which don't look like types to the registry throws an exception + +my $r = Moose::Util::TypeConstraints->get_type_constraint_registry; +like( exception {$r->add_type_constraint()}, qr/not a valid type constraint/, '->add_type_constraint(undef) throws' ); +like( exception {$r->add_type_constraint('foo')}, qr/not a valid type constraint/, '->add_type_constraint("foo") throws' ); +like( exception {$r->add_type_constraint(bless {}, 'SomeClass')}, qr/not a valid type constraint/, '->add_type_constraint(SomeClass->new) throws' ); + +# Test some specific things that in the past did not work, +# specifically weird variations on anon subtypes. + +{ + my $subtype = subtype as 'Str'; + isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got an anon subtype' ); + is( $subtype->parent->name, 'Str', 'parent is Str' ); + # This test sucks but is the best we can do + is( $subtype->constraint->(), 1, + 'subtype has the null constraint' ); + ok( ! $subtype->has_message, 'subtype has no message' ); +} + +{ + my $subtype = subtype as 'ArrayRef[Num|Str]'; + isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got an anon subtype' ); + is( $subtype->parent->name, 'ArrayRef[Num|Str]', 'parent is ArrayRef[Num|Str]' ); + ok( ! $subtype->has_message, 'subtype has no message' ); +} + +{ + my $subtype = subtype 'ArrayRef[Num|Str]' => message { 'foo' }; + isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got an anon subtype' ); + is( $subtype->parent->name, 'ArrayRef[Num|Str]', 'parent is ArrayRef[Num|Str]' ); + ok( $subtype->has_message, 'subtype does have a message' ); +} + +# alternative sugar-less calling style which is documented as legit: +{ + my $subtype = subtype( 'MyStr', { as => 'Str' } ); + isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got a subtype' ); + is( $subtype->name, 'MyStr', 'name is MyStr' ); + is( $subtype->parent->name, 'Str', 'parent is Str' ); +} + +{ + my $subtype = subtype( { as => 'Str' } ); + isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got a subtype' ); + is( $subtype->name, '__ANON__', 'name is __ANON__' ); + is( $subtype->parent->name, 'Str', 'parent is Str' ); +} + +{ + my $subtype = subtype( { as => 'Str', where => sub { /X/ } } ); + isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got a subtype' ); + is( $subtype->name, '__ANON__', 'name is __ANON__' ); + is( $subtype->parent->name, 'Str', 'parent is Str' ); + ok( $subtype->check('FooX'), 'constraint accepts FooX' ); + ok( ! $subtype->check('Foo'), 'constraint reject Foo' ); +} + +{ + like( exception { subtype 'Foo' }, qr/cannot consist solely of a name/, 'Cannot call subtype with a single string argument' ); +} + +{ + my $subtype = subtype( { as => 'Num' } ); + isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got a subtype' ); + + my @rejects = ( 'nan', + 'inf', + 'infinity', + 'Infinity', + 'NaN', + 'INF', + ' 1234 ', + ' 123.44 ', + ' 13e7 ', + 'hello', + "1e3\n", + "52563\n", + "123.4\n", + '0.', + "0 but true", + undef + ); + my @accepts = ( '123', + '123.4367', + '3322', + '13e7', + '0', + '0.0', + '.0', + .0, + 0.0, + 123, + 13e6, + 123.4367, + 10.5 + ); + + for( @rejects ) + { + my $printable = defined $_ ? $_ : "(undef)"; + ok( !$subtype->check($_), "constraint rejects $printable" ) + } + ok( $subtype->check($_), "constraint accepts $_" ) for @accepts; +} + +done_testing; diff --git a/t/type_constraints/util_type_constraints_export.t b/t/type_constraints/util_type_constraints_export.t new file mode 100644 index 0000000..0671bf9 --- /dev/null +++ b/t/type_constraints/util_type_constraints_export.t @@ -0,0 +1,27 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Foo; + + use Moose::Util::TypeConstraints; + + 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' ); + + Moose::Util::TypeConstraints->export_type_constraints_as_functions(); + + ::ok( MyRef( {} ), '... Ref worked correctly' ); + ::ok( MyArrayRef( [] ), '... ArrayRef worked correctly' ); +} + +done_testing; diff --git a/t/type_constraints/util_type_reloading.t b/t/type_constraints/util_type_reloading.t new file mode 100644 index 0000000..729cdc4 --- /dev/null +++ b/t/type_constraints/util_type_reloading.t @@ -0,0 +1,27 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Test::More; + + +$SIG{__WARN__} = sub { 0 }; + +eval { require Foo; }; +ok(!$@, '... loaded Foo successfully') || diag $@; + +delete $INC{'Foo.pm'}; + +eval { require Foo; }; +ok(!$@, '... re-loaded Foo successfully') || diag $@; + +eval { require Bar; }; +ok(!$@, '... loaded Bar successfully') || diag $@; + +delete $INC{'Bar.pm'}; + +eval { require Bar; }; +ok(!$@, '... re-loaded Bar successfully') || diag $@; + +done_testing; diff --git a/t/type_constraints/with-specio.t b/t/type_constraints/with-specio.t new file mode 100644 index 0000000..ef442d1 --- /dev/null +++ b/t/type_constraints/with-specio.t @@ -0,0 +1,204 @@ +use strict; +use warnings; + +use Test::Fatal; +use Test::Moose qw( with_immutable ); +use Test::More; + +BEGIN { + plan skip_all => 'These tests requires Specio, which requires perl 5.010' + unless $] >= 5.010; +} + +use Test::Requires { + 'Specio::Declare' => '0.10', + 'Specio::Library::Builtins' => '0.10', +}; + +{ + package Foo; + + use Moose; + use Specio::Library::Builtins; + + has int => ( + is => 'ro', + isa => t('Int'), + ); + + has array_of_ints => ( + is => 'ro', + isa => t( 'ArrayRef', of => t('Int') ), + ); + + has hash_of_ints => ( + is => 'ro', + isa => t( 'HashRef', of => t('Int') ), + ); +} + +with_immutable( + sub { + my $is_immutable = shift; + subtest( + 'Foo class' . ( $is_immutable ? ' (immutable)' : q{} ), + sub { + + is( + exception { Foo->new( int => 42 ) }, + undef, + '42 is an acceptable int' + ); + + like( + exception { Foo->new( int => 42.4 ) }, + qr/does not pass the type constraint.+for type named Int/, + '42.4 is not an acceptable int' + ); + + is( + exception { Foo->new( array_of_ints => [ 42, 84 ] ) }, + undef, + '[ 42, 84 ] is an acceptable array of ints' + ); + + like( + exception { Foo->new( array_of_ints => [ 42.4, 84 ] ) }, + qr/does not pass the type constraint.+for anonymous type/, + '[ 42.4, 84 ] is an acceptable array of ints' + ); + + is( + exception { + Foo->new( hash_of_ints => { foo => 42, bar => 84 } ); + }, + undef, + '{ foo => 42, bar => 84 } is an acceptable array of ints' + ); + + like( + exception { + Foo->new( + hash_of_ints => { foo => 42.4, bar => 84 } ); + }, + qr/does not pass the type constraint.+for anonymous type/, + '{ foo => 42.4, bar => 84 } is an acceptable array of ints' + ); + } + ); + }, + 'Foo' +); + +{ + package Bar; + + use Moose; + use Specio::Declare; + use Specio::Library::Builtins; + + my $array_of_ints = anon( parent => t( 'ArrayRef', of => t('Int') ) ); + + coerce( + $array_of_ints, + from => t('Int'), + using => sub { + return [ $_[0] ]; + } + ); + + has array_of_ints => ( + is => 'ro', + isa => $array_of_ints, + coerce => 1, + ); + + my $hash_of_ints = anon( parent => t( 'HashRef', of => t('Int') ) ); + + coerce( + $hash_of_ints, + from => t('Int'), + using => sub { + return { foo => $_[0] }; + } + ); + + has hash_of_ints => ( + is => 'ro', + isa => $hash_of_ints, + coerce => 1, + ); +} + +with_immutable( + sub { + my $is_immutable = shift; + subtest( + 'Bar class' . ( $is_immutable ? ' (immutable)' : q{} ), + sub { + + is( + exception { Bar->new( array_of_ints => [ 42, 84 ] ) }, + undef, + '[ 42, 84 ] is an acceptable array of ints' + ); + + like( + exception { Bar->new( array_of_ints => [ 42.4, 84 ] ) }, + qr/does not pass the type constraint.+for anonymous type/, + '[ 42.4, 84 ] is an acceptable array of ints' + ); + + { + my $bar; + is( + exception { $bar = Bar->new( array_of_ints => 42 ) }, + undef, + '42 is an acceptable array of ints with coercion' + ); + + is_deeply( + $bar->array_of_ints(), + [42], + 'int is coerced to single element arrayref' + ); + } + + is( + exception { + Bar->new( hash_of_ints => { foo => 42, bar => 84 } ); + }, + undef, + '{ foo => 42, bar => 84 } is an acceptable array of ints' + ); + + like( + exception { + Bar->new( + hash_of_ints => { foo => 42.4, bar => 84 } ); + }, + qr/does not pass the type constraint.+for anonymous type/, + '{ foo => 42.4, bar => 84 } is an acceptable array of ints' + ); + + { + my $bar; + is( + exception { $bar = Bar->new( hash_of_ints => 42 ) }, + undef, + '42 is an acceptable hash of ints with coercion' + ); + + is_deeply( + $bar->hash_of_ints(), + { foo => 42 }, + 'int is coerced to single element hashref' + ); + } + } + ); + }, + 'Bar' +); + +done_testing(); diff --git a/t/zzz-check-breaks.t b/t/zzz-check-breaks.t new file mode 100644 index 0000000..86e2f88 --- /dev/null +++ b/t/zzz-check-breaks.t @@ -0,0 +1,98 @@ +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::CheckBreaks 0.012 + +use Test::More 0.88; + +SKIP: { + eval 'require Moose::Conflicts; Moose::Conflicts->check_conflicts'; + skip('no Moose::Conflicts module found', 1) if not $INC{'Moose/Conflicts.pm'}; + + diag $@ if $@; + pass 'conflicts checked via Moose::Conflicts'; +} + +my $breaks = { + "Catalyst" => "<= 5.90049999", + "Config::MVP" => "<= 2.200004", + "Devel::REPL" => "<= 1.003020", + "Dist::Zilla::Plugin::Git" => "<= 2.016", + "Fey" => "<= 0.36", + "Fey::ORM" => "<= 0.42", + "File::ChangeNotify" => "<= 0.15", + "HTTP::Throwable" => "<= 0.017", + "KiokuDB" => "<= 0.51", + "Markdent" => "<= 0.16", + "Mason" => "<= 2.18", + "MooseX::ABC" => "<= 0.05", + "MooseX::Aliases" => "<= 0.08", + "MooseX::AlwaysCoerce" => "<= 0.13", + "MooseX::App" => "<= 1.22", + "MooseX::Attribute::Deflator" => "<= 2.1.7", + "MooseX::Attribute::Dependent" => "<= 1.1.0", + "MooseX::Attribute::Prototype" => "<= 0.10", + "MooseX::AttributeHelpers" => "<= 0.22", + "MooseX::AttributeIndexes" => "<= 1.0.0", + "MooseX::AttributeInflate" => "<= 0.02", + "MooseX::CascadeClearing" => "<= 0.03", + "MooseX::ClassAttribute" => "<= 0.26", + "MooseX::Constructor::AllErrors" => "<= 0.021", + "MooseX::Declare" => "<= 0.35", + "MooseX::FollowPBP" => "<= 0.02", + "MooseX::Getopt" => "<= 0.56", + "MooseX::InstanceTracking" => "<= 0.04", + "MooseX::LazyRequire" => "<= 0.06", + "MooseX::Meta::Attribute::Index" => "<= 0.04", + "MooseX::Meta::Attribute::Lvalue" => "<= 0.05", + "MooseX::Method::Signatures" => "<= 0.44", + "MooseX::MethodAttributes" => "<= 0.22", + "MooseX::NonMoose" => "<= 0.24", + "MooseX::Object::Pluggable" => "<= 0.0011", + "MooseX::POE" => "<= 0.214", + "MooseX::Params::Validate" => "<= 0.05", + "MooseX::PrivateSetters" => "<= 0.03", + "MooseX::Role::Cmd" => "<= 0.06", + "MooseX::Role::Parameterized" => "<= 1.00", + "MooseX::Role::WithOverloading" => "<= 0.14", + "MooseX::Runnable" => "<= 0.03", + "MooseX::Scaffold" => "<= 0.05", + "MooseX::SemiAffordanceAccessor" => "<= 0.05", + "MooseX::SetOnce" => "<= 0.100473", + "MooseX::Singleton" => "<= 0.25", + "MooseX::SlurpyConstructor" => "<= 1.1", + "MooseX::Storage" => "<= 0.42", + "MooseX::StrictConstructor" => "<= 0.12", + "MooseX::Traits" => "<= 0.11", + "MooseX::Types" => "<= 0.19", + "MooseX::Types::Parameterizable" => "<= 0.05", + "MooseX::Types::Set::Object" => "<= 0.03", + "MooseX::Types::Signal" => "<= 1.101930", + "MooseX::UndefTolerant" => "<= 0.11", + "PRANG" => "<= 0.14", + "Pod::Elemental" => "<= 0.093280", + "Pod::Weaver" => "<= 3.101638", + "Reaction" => "<= 0.002003", + "Test::Able" => "<= 0.10", + "Test::CleanNamespaces" => "<= 0.03", + "Test::Moose::More" => "<= 0.022", + "Test::TempDir" => "<= 0.05", + "Throwable" => "<= 0.102080", + "namespace::autoclean" => "<= 0.08" +}; + +use CPAN::Meta::Requirements; +my $reqs = CPAN::Meta::Requirements->new; +$reqs->add_string_requirement($_, $breaks->{$_}) foreach keys %$breaks; + +use CPAN::Meta::Check 0.007 'check_requirements'; +our $result = check_requirements($reqs, 'conflicts'); + +if (my @breaks = grep { defined $result->{$_} } keys %$result) +{ + diag 'Breakages found with Moose:'; + diag "$result->{$_}" for sort @breaks; + diag "\n", 'You should now update these modules!'; +} + +done_testing; |