From: Stevan Little Date: Sun, 12 Aug 2007 06:14:12 +0000 (+0000) Subject: some reworkings of the Test::Moose and Moose::Util code X-Git-Tag: 0_25~4 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7125b244a930704aad50320f730d27e97f948e9a;p=gitmo%2FMoose.git some reworkings of the Test::Moose and Moose::Util code --- diff --git a/Changes b/Changes index 6ded70c..d3adac2 100644 --- a/Changes +++ b/Changes @@ -1,10 +1,6 @@ Revision history for Perl extension Moose 0.25 - * Moose::Cookbook::Recipe7 - - added new recipe for augment/inner functionality - - added test for this - * Moose - Documentation update to reference Moose::Util::TypeConstraints under 'isa' in 'has' for how to define a new type @@ -32,16 +28,25 @@ Revision history for Perl extension Moose * Moose::Meta::Role - massive refactoring of this code - added several more tests - - tests for subtle conflict resolition bugs (thanks to kolibre) + - tests for subtle conflict resolition issues + added, but not currently running + (thanks to kolibre) + + * Moose::Cookbook::Recipe7 + - added new recipe for augment/inner functionality + - example only, no docs yet (sorry) + - added test for this * Moose::Spec::Role - - a formal definition of roles + - a formal definition of roles (still in progress) * Moose::Util - utilities for easier working with moose classes + - added tests for these * Test::Moose - moose specific tests + - added tests for these 0.24 Tues. July 3, 2007 ~ Some doc updates/cleanup ~ diff --git a/MANIFEST b/MANIFEST index 53a5c60..0c80594 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1,7 +1,7 @@ Build.PL Changes -Makefile.PL META.yml +Makefile.PL MANIFEST MANIFEST.SKIP README @@ -9,6 +9,7 @@ lib/Moose.pm lib/Moose/Cookbook.pod lib/Moose/Object.pm lib/Moose/Role.pm +lib/Moose/Util.pm lib/Moose/Cookbook/FAQ.pod lib/Moose/Cookbook/Recipe1.pod lib/Moose/Cookbook/Recipe2.pod @@ -16,6 +17,7 @@ lib/Moose/Cookbook/Recipe3.pod lib/Moose/Cookbook/Recipe4.pod lib/Moose/Cookbook/Recipe5.pod lib/Moose/Cookbook/Recipe6.pod +lib/Moose/Cookbook/Recipe7.pod lib/Moose/Cookbook/WTF.pod lib/Moose/Meta/Attribute.pm lib/Moose/Meta/Class.pm @@ -29,8 +31,11 @@ lib/Moose/Meta/Method/Constructor.pm lib/Moose/Meta/Method/Destructor.pm lib/Moose/Meta/Method/Overriden.pm lib/Moose/Meta/Role/Method.pm +lib/Moose/Meta/Role/Method/Required.pm lib/Moose/Meta/TypeConstraint/Union.pm +lib/Moose/Spec/Role.pod lib/Moose/Util/TypeConstraints.pm +lib/Test/Moose.pm t/000_load.t t/001_recipe.t t/002_recipe.t @@ -38,6 +43,7 @@ t/003_recipe.t t/004_recipe.t t/005_recipe.t t/006_recipe.t +t/007_recipe.t t/010_basic_class_setup.t t/011_require_superclasses.t t/012_super_and_override.t @@ -105,6 +111,13 @@ t/204_example_w_DCS.t t/205_example_w_TestDeep.t t/206_example_Protomoose.t t/300_immutable_moose.t +t/400_moose_util.t +t/401_moose_util_does_role.t +t/402_moose_util_search_class_by_role.t +t/500_test_moose.t +t/501_test_moose_does_ok.t +t/502_test_moose_has_attribute_ok.t +t/503_test_moose_meta_ok.t t/pod.t t/pod_coverage.t t/lib/Bar.pm diff --git a/lib/Moose/Cookbook/Recipe7.pod b/lib/Moose/Cookbook/Recipe7.pod index f53df9c..4418a72 100644 --- a/lib/Moose/Cookbook/Recipe7.pod +++ b/lib/Moose/Cookbook/Recipe7.pod @@ -58,6 +58,8 @@ Moose::Cookbook::Recipe7 - The augment/inner example =head1 DESCRIPTION +Coming Soon. + =head1 CONCLUSION =head1 FOOTNOTES @@ -72,7 +74,7 @@ Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE -Copyright 2006, 2007 by Infinity Interactive, Inc. +Copyright 2007 by Infinity Interactive, Inc. L diff --git a/lib/Moose/Util.pm b/lib/Moose/Util.pm index 8089593..113f6b1 100644 --- a/lib/Moose/Util.pm +++ b/lib/Moose/Util.pm @@ -1,39 +1,64 @@ package Moose::Util; -use Exporter qw/import/; -use Scalar::Util; - use strict; use warnings; -our $VERSION = '0.01'; +use Sub::Exporter; +use Scalar::Util (); +use Class::MOP (); -our $AUTHORITY = 'cpan:BERLE'; +our $VERSION = '0.01'; +our $AUTHORITY = 'cpan:STEVAN'; -our @EXPORT_OK = qw/does_role search_class_by_role/; +my @exports = qw[ + does_role + search_class_by_role +]; -sub does_role { - my ($class, $role) = @_; +Sub::Exporter::setup_exporter({ + exports => \@exports, + groups => { default => \@exports } +}); + +## some utils for the utils ... + +sub _get_meta { + return unless $_[0]; + return Class::MOP::get_metaclass_by_name(ref($_[0]) || $_[0]); +} - return unless defined $class; +## the functions ... - my $meta = Class::MOP::get_metaclass_by_name (ref $class || $class); +sub does_role { + my ($class_or_obj, $role) = @_; - return unless defined $meta; + my $meta = _get_meta($class_or_obj); + + return unless defined $meta; - return $meta->does_role ($role); + return 1 if $meta->does_role($role); + return; } sub search_class_by_role { - my ($obj, $role_name) = @_; + my ($class_or_obj, $role_name) = @_; + + my $meta = _get_meta($class_or_obj); + + return unless defined $meta; + + foreach my $class ($meta->class_precedence_list) { + + my $_meta = _get_meta($class); - for my $class ($obj->meta->class_precedence_list) { - for my $role (@{ $class->meta->roles || [] }) { + next unless defined $_meta; + + foreach my $role (@{ $_meta->roles || [] }) { return $class if $role->name eq $role_name; } } - return undef; + return; } 1; @@ -44,7 +69,7 @@ __END__ =head1 NAME -Moose::Util - Moose utilities +Moose::Util - Utilities for working with Moose classes =head1 SYNOPSIS @@ -57,21 +82,37 @@ Moose::Util - Moose utilities my $class = search_class_by_role($object, 'FooRole'); print "Nearest class with 'FooRole' is $class\n"; -=head1 FUNCTIONS +=head1 DESCRIPTION + +This is a set of utility functions to help working with Moose classes. This +is an experimental module, and it's not 100% clear what purpose it will serve. +That said, ideas, suggestions and contributions to this collection are most +welcome. See the L section below for a list of ideas for possible +functions to write. + +=head1 EXPORTED FUNCTIONS =over 4 -=item does_role +=item B + +Returns true if C<$class_or_obj> can do the role C<$role_name>. + +=item B + +Returns first class in precedence list that consumed C<$role_name>. + +=back - does_role($object, $rolename); +=head1 TODO -Returns true if $object can do the role $rolename. +Here is a list of possible functions to write -=item search_class_by_role +=over 4 - my $class = search_class_by_role($object, $rolename); +=item discovering original method from modified method -Returns first class in precedence list that consumed C<$rolename>. +=item search for origin class of a method or attribute =back @@ -85,6 +126,12 @@ to cpan-RT. Anders Nor Berle Edebolaz@gmail.comE +B + +Robert (phaylon) Sedlacek + +Stevan Little + =head1 COPYRIGHT AND LICENSE Copyright 2007 by Infinity Interactive, Inc. diff --git a/lib/Test/Moose.pm b/lib/Test/Moose.pm index e9694e2..58b7e95 100644 --- a/lib/Test/Moose.pm +++ b/lib/Test/Moose.pm @@ -1,40 +1,77 @@ package Test::Moose; -use Exporter; -use Moose::Util qw/does_role/; -use Test::Builder; - use strict; use warnings; -our $VERSION = '0.01'; +use Sub::Exporter; +use Test::Builder; -our $AUTHORITY = 'cpan:BERLE'; +our $VERSION = '0.01'; +our $AUTHORITY = 'cpan:STEVAN'; -our @EXPORT = qw/does_ok/; +my @exports = qw[ + meta_ok + does_ok + has_attribute_ok +]; -my $tester = Test::Builder->new; +Sub::Exporter::setup_exporter({ + exports => \@exports, + groups => { default => \@exports } +}); -sub import { - my $class = shift; +my $Test = Test::Builder->new; - if (@_) { - my $package = caller; - - $tester->exported_to ($package); +## some helpers ... - $tester->plan (@_); - } +sub _get_meta { + return unless $_[0]; + return Class::MOP::get_metaclass_by_name(ref($_[0]) || $_[0]); +} - @_ = ($class); +## exported functions - goto &Exporter::import; +sub meta_ok ($;$) { + my ($class_or_obj, $message) = @_; + + $message ||= "The object has a meta"; + + if (_get_meta($class_or_obj)) { + return $Test->ok(1, $message) + } + else { + return $Test->ok(0, $message); + } } sub does_ok ($$;$) { - my ($class,$does,$name) = @_; + my ($class_or_obj, $does, $message) = @_; + + $message ||= "The object does $does"; + + my $meta = _get_meta($class_or_obj); + + if ($meta->does_role($does)) { + return $Test->ok(1, $message) + } + else { + return $Test->ok(0, $message); + } +} - return $tester->ok (does_role ($class,$does),$name) +sub has_attribute_ok ($$;$) { + my ($class_or_obj, $attr_name, $message) = @_; + + $message ||= "The object does has an attribute named $attr_name"; + + my $meta = _get_meta($class_or_obj); + + if ($meta->find_attribute_by_name($attr_name)) { + return $Test->ok(1, $message) + } + else { + return $Test->ok(0, $message); + } } 1; @@ -49,20 +86,57 @@ Test::Moose - Test functions for Moose specific features =head1 SYNOPSIS - use Test::Moose plan => 1; + use Test::More plan => 1; + use Test::Moose; - does_ok ($class,$role,"Does $class do $role"); + meta_ok($class_or_obj, "... Foo has a ->meta"); + does_ok($class_or_obj, $role, "... Foo does the Baz role"); + has_attribute_ok($class_or_obj, $attr_name, "... Foo has the 'bar' attribute"); -=head1 TESTS +=head1 DESCRIPTION + +This module provides some useful test functions for Moose based classes. It +is an experimental first release, so comments and suggestions are very welcome. + +=head1 EXPORTED FUNCTIONS =over 4 -=item does_ok +=item B + +Tests if a class or object has a metaclass. + +=item B - does_ok ($class,$role,$name); +Tests if a class or object does a certain role, similar to what C +does for the C method. -Tests if a class does a certain role, similar to what isa_ok does for -isa. +=item B + +Tests if a class or object has a certain attribute, similar to what C +does for the methods. + +=back + +=head1 TODO + +=over 4 + +=item Convert the Moose test suite to use this module. + +=item Here is a list of possible functions to write + +=over 4 + +=item immutability predicates + +=item anon-class predicates + +=item discovering original method from modified method + +=item attribute metaclass predicates (attribute_isa?) + +=back =back @@ -84,6 +158,8 @@ to cpan-RT. Anders Nor Berle Edebolaz@gmail.comE +Stevan Little Estevan@iinteractive.comE + =head1 COPYRIGHT AND LICENSE Copyright 2007 by Infinity Interactive, Inc. diff --git a/t/400_moose_util.t b/t/400_moose_util.t index d3fb650..1f08fb5 100644 --- a/t/400_moose_util.t +++ b/t/400_moose_util.t @@ -1,90 +1,10 @@ -#!/usr/bin/env perl - -use Test::More tests => 13; +#!/usr/bin/perl use strict; use warnings; -BEGIN { - use_ok('Moose'); - use_ok('Moose::Role'); - use_ok('Moose::Util'); -} - -{ - package Foo; - - use Moose::Role; -} - -{ - package Bar; - - use Moose; - - with qw/Foo/; -} - -{ - package Baz; - - use Moose; -} - -# Classes - -ok(Moose::Util::does_role('Bar', 'Foo')); - -ok(! Moose::Util::does_role('Baz', 'Foo')); - -# Objects - -my $bar = Bar->new; - -ok(Moose::Util::does_role($bar, 'Foo')); - -my $baz = Baz->new; - -ok(! Moose::Util::does_role($baz, 'Foo')); - -# Invalid values - -ok(! Moose::Util::does_role(undef,'Foo')); - -ok(! Moose::Util::does_role(1,'Foo')); - -# -# search_class_by_role tests -# -BEGIN { Moose::Util->import(qw( search_class_by_role )) } -my $t_pfx = 'search_class_by_role: '; - -{ package SCBR::Role; - use Moose::Role; -} - -{ package SCBR::A; - use Moose; -} -is search_class_by_role('SCBR::A', 'SCBR::Role'), undef, $t_pfx . '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', $t_pfx . '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', $t_pfx . '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', $t_pfx . 'nearest class being direct class returned'; +use Test::More tests => 1; +BEGIN { + use_ok('Moose::Util'); +} \ No newline at end of file diff --git a/t/401_moose_util_does_role.t b/t/401_moose_util_does_role.t new file mode 100644 index 0000000..1590c6b --- /dev/null +++ b/t/401_moose_util_does_role.t @@ -0,0 +1,52 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 7; + +BEGIN { + use_ok('Moose::Util'); +} + +{ + package Foo; + + use Moose::Role; +} + +{ + package Bar; + + use Moose; + + with qw/Foo/; +} + +{ + package Baz; + + use Moose; +} + +# 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'); diff --git a/t/402_moose_util_search_class_by_role.t b/t/402_moose_util_search_class_by_role.t new file mode 100644 index 0000000..19d432b --- /dev/null +++ b/t/402_moose_util_search_class_by_role.t @@ -0,0 +1,40 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 5; + +BEGIN { + use_ok('Moose::Util'); +} + +{ 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'; + +{ 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'; + +{ package SCBR::C; + use Moose; + extends 'SCBR::B'; +} +is search_class_by_role('SCBR::C', 'SCBR::Role'), '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'; + diff --git a/t/500_test_moose.t b/t/500_test_moose.t new file mode 100644 index 0000000..7510786 --- /dev/null +++ b/t/500_test_moose.t @@ -0,0 +1,10 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 1; + +BEGIN { + use_ok('Test::Moose'); +} \ No newline at end of file diff --git a/t/401_test_moose.t b/t/501_test_moose_does_ok.t similarity index 75% rename from t/401_test_moose.t rename to t/501_test_moose_does_ok.t index dc6291a..d7e505e 100644 --- a/t/401_test_moose.t +++ b/t/501_test_moose_does_ok.t @@ -1,33 +1,30 @@ -use Test::Builder::Tester tests => 4; -use Test::More; +#!/usr/bin/perl use strict; use warnings; +use Test::Builder::Tester tests => 2; +use Test::More; + BEGIN { - use_ok('Moose'); - use_ok('Moose::Role'); use_ok('Test::Moose'); } { - package Foo; - - use Moose::Role; + package Foo; + use Moose::Role; } { - package Bar; + package Bar; + use Moose; - use Moose; - - with qw/Foo/; + with qw/Foo/; } { - package Baz; - - use Moose; + package Baz; + use Moose; } # class ok @@ -39,7 +36,6 @@ 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'); @@ -57,7 +53,6 @@ does_ok ($bar,'Foo','does_ok object'); my $baz = Baz->new; test_out ('not ok 4 - does_ok object fail'); - test_fail (+2); does_ok ($baz,'Foo','does_ok object fail'); diff --git a/t/502_test_moose_has_attribute_ok.t b/t/502_test_moose_has_attribute_ok.t new file mode 100644 index 0000000..e8e3869 --- /dev/null +++ b/t/502_test_moose_has_attribute_ok.t @@ -0,0 +1,48 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::Builder::Tester tests => 2; +use Test::More; + +BEGIN { + use_ok('Test::Moose'); +} + +{ + package Foo; + use Moose; + + has 'foo'; +} + +{ + package Bar; + use Moose; + + extends 'Foo'; + + has 'bar'; +} + + +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'); + diff --git a/t/503_test_moose_meta_ok.t b/t/503_test_moose_meta_ok.t new file mode 100644 index 0000000..a4cb60b --- /dev/null +++ b/t/503_test_moose_meta_ok.t @@ -0,0 +1,32 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::Builder::Tester tests => 2; +use Test::More; + +BEGIN { + use_ok('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'); +