point out this fact. (hdp)
* Moose::Cookbook::Basics::Recipe12
- - A new recipe, creating a custom meta-method class.
+ - A new recipe, creating a custom meta-method class.
* Moose::Cookbook::Meta::Recipe6
- A new recipe, creating a custom meta-method class.
called during instance construction were passed the
meta-attribute, but triggers called by normal accessors were
not. Fixes RT#44429, reported by Mark Swayne. (hdp)
-
+
* Moose::Manual::Attributes
- Remove references to triggers receving the meta-attribute object as an
argument. (hdp)
* Moose::Util::TypeConstraints
- Added the RoleName type (stevan)
- added tests for this (stevan)
-
+
* Moose::Cookbook::Basics::Recipe3
- Updated the before qw[left right] sub to be a little more
defensive about what it accepts (stevan)
- Some tests tried to use Test::Warn 0.10, which had bugs. Now
they require 0.11. (Dave Rolsky)
- * Documentation
+ * Documentation
- Lots of small changes to the manual, cookbook, and
elsewhere. These were based on feedback from various
users, too many to list here. (Dave Rolsky)
- Passing "-traits" when loading Moose caused the Moose.pm
exports to be broken. Reported by t0m. (Dave Rolsky)
- Tests for this bug. (t0m)
-
+
* Moose::Util
- Change resolve_metaclass alias to use the new
load_first_existing_class function. This makes it a lot
* Moose::Meta::TypeConstraint::Union
- Type constraint names are sorted as strings, not numbers.
(jnapiorkowski)
-
+
* Moose::Meta::TypeConstraint::Parameterizable
- New parameterize method. This can be used as a factory method
to make a new type constraint with a given parameterized
0.59 Tue October 14, 2008
* Moose
- Add abridged documentation for builder/default/initializer/
- predicate, and link to more details sections in
+ predicate, and link to more details sections in
Class::MOP::Attribute. (t0m)
* Moose::Util::TypeConstraints
- explicitly require Perl 5.8.0+ (Dave Rolsky)
* Moose::Util::TypeConstraints
- - Fix warnings from find_type_constraint if the type is not
+ - Fix warnings from find_type_constraint if the type is not
found (t0m).
-
+
* Moose::Meta::TypeConstraint
- Predicate methods (equals/is_a_type_of/is_subtype_of) now
return false if the type you specify cannot be found in the
type registry, rather than throwing an unhelpful and
coincidental exception. (t0m).
- added docs & test for this (t0m)
-
+
* Moose::Meta::TypeConstraint::Registry
- add_type_constraint now throws an exception if a parameter is
not supplied (t0m).
method when that method was provided by another role being
composed at the same time. (Dave Rolsky)
- test and bug finding (tokuhirom)
-
+
0.55_01 Wed August 20, 2008
!! Calling Moose::init_meta as a function is now !!
0.54 Thurs. July 3, 2008
... this is not my day today ...
-
+
* Moose::Meta::Attribute
- - fixed legal_options_for_inheritance such that
- clone_and_inherit options still works for
- Class::MOP::Attribute objects and therefore
+ - fixed legal_options_for_inheritance such that
+ clone_and_inherit options still works for
+ Class::MOP::Attribute objects and therefore
does not break MooseX::AttributeHelpers
(stevan)
0.53 Thurs. July 3, 2008
- * Whoops, I guess I should run 'make manifest' before
- actually releasing the module. No actual changes
+ * Whoops, I guess I should run 'make manifest' before
+ actually releasing the module. No actual changes
in this release, except the fact that it includes
- the changes that I didn't include in the last
+ the changes that I didn't include in the last
release. (stevan--)
0.52 Thurs. July 3, 2008
* Moose
- added "FEATURE REQUESTS" section to the Moose docs
to properly direct people (stevan) (RT #34333)
- - making 'extends' croak if it is passed a Role since
- this is not ever something you want to do
+ - making 'extends' croak if it is passed a Role since
+ this is not ever something you want to do
(fixed by stevan, found by obra)
- added tests for this (stevan)
* Moose::Object
- - adding support for DOES (as in UNIVERSAL::DOES)
+ - adding support for DOES (as in UNIVERSAL::DOES)
(nothingmuch)
- added test for this
- added tests for this (wreis)
* Moose::Cookbook::Snacks::*
- - removed some of the unfinished snacks that should
+ - removed some of the unfinished snacks that should
not have been released yet. Added some more examples
to the 'Keywords' snack. (stevan)
* Moose::Cookbook::Style
- - added general Moose "style guide" of sorts to the
+ - added general Moose "style guide" of sorts to the
cookbook (nothingmuch) (RT #34335)
* t/
!! faster with new Class::MOP 0.59 !!
* Moose::Meta::Attribute
- - fixed how the is => (ro|rw) works with
+ - fixed how the is => (ro|rw) works with
custom defined reader, writer and accessor
- options.
+ options.
- added docs for this (TODO).
- added tests for this (Thanks to Penfold)
- added the custom attribute alias for regular
Moose::Meta::Role
Moose::Meta::Role::Composite
Moose::Util::TypeConstraints
- - switched usage of reftype to ref because
+ - switched usage of reftype to ref because
it is much faster
-
+
* Moose::Meta::Role
- changing add_package_symbol to use the new
HASH ref form
-
+
* Moose::Object
- - fixed how DEMOLISHALL is called so that it
+ - fixed how DEMOLISHALL is called so that it
can be overrided in subclasses (thanks to Sartak)
- added test for this (thanks to Sartak)
0.47 Thurs. May 29, 2008
(late night release engineering)--
- - fixing the version is META.yml, no functional
+ - fixing the version is META.yml, no functional
changes in this release
0.46 Wed. May 28, 2008
* Moose::Meta::Class
- some optimizations of the &initialize method
- since it is called so often by &meta
-
+ since it is called so often by &meta
+
* Moose::Meta::Class
Moose::Meta::Role
- - now use the get_all_package_symbols from the
- updated Class::MOP, test suite is now 10 seconds
+ - now use the get_all_package_symbols from the
+ updated Class::MOP, test suite is now 10 seconds
faster
-
+
* Moose::Meta::Method::Destructor
- - is_needed can now also be called as a class
- method for immutablization to check if the
- destructor object even needs to be created
+ - is_needed can now also be called as a class
+ method for immutablization to check if the
+ destructor object even needs to be created
at all
-
+
* Moose::Meta::Method::Destructor
Moose::Meta::Method::Constructor
- - added more descriptive error message to help
+ - added more descriptive error message to help
keep people from wasting time tracking an error
that is easily fixed by upgrading.
0.45 Saturday, May 24, 2008
* Moose
- - Because of work in Class::MOP 0.57, all
+ - Because of work in Class::MOP 0.57, all
XS based functionality is now optional
and a Pure Perl version is supplied
- the CLASS_MOP_NO_XS environment variable
- can now be used to force non-XS versions
- to always be used
+ can now be used to force non-XS versions
+ to always be used
- several of the packages have been tweaked
to take care of this, mostly we added
- support for the package_name and name
+ support for the package_name and name
variables in all the Method metaclasses
- - before/around/after method modifiers now
+ - before/around/after method modifiers now
support regexp matching of names
(thanks to Takatoshi Kitano)
- tests added for this
- - NOTE: this only works for classes, it
- is currently not supported in roles,
+ - NOTE: this only works for classes, it
+ is currently not supported in roles,
but, ... patches welcome
- All usage of Carp::confess have been replaced
by Carp::croak in the "keyword" functions since
the stack trace is usually not helpful
-
+
* Moose::Role
- All usage of Carp::confess have been replaced
by Carp::croak in the "keyword" functions since
- the stack trace is usually not helpful
- - The 'has' keyword for roles now accepts the
- same array ref form that Moose.pm does
+ the stack trace is usually not helpful
+ - The 'has' keyword for roles now accepts the
+ same array ref form that Moose.pm does
(has [qw/foo bar/] => (is => 'rw', ...))
- added test for this
-
+
* Moose::Meta::Attribute
- trigger on a ro-attribute is no longer an
error, as it's useful to trigger off of the
constructor
* Moose::Meta::Class
- - added same 'add_package_symbol' fix as in
+ - added same 'add_package_symbol' fix as in
Class::MOP 0.57
* Moose::Util
- - does_role now handles non-Moose classes
+ - does_role now handles non-Moose classes
more gracefully
- added tests for this
- - added the 'add_method_modifier' function
+ - added the 'add_method_modifier' function
(thanks to Takatoshi Kitano)
* Moose::Util::TypeConstraints
- - subtypes of parameterizable types now are
+ - subtypes of parameterizable types now are
themselves parameterizable types
* Moose::Meta::Method::Constructor
- - fixed bug where trigger was not being
- called by the inlined immutable
- constructors
+ - fixed bug where trigger was not being
+ called by the inlined immutable
+ constructors
- added test for this (thanks to Caelum)
-
+
* Moose::Meta::Role::Application::ToInstance
- now uses the metaclass of the instance
(if possible) to create the anon-class
(thanks Jonathan Rockway)
-
+
* Moose::Cookbook::Recipe22
- added the meta-attribute trait recipe
(thanks to Sartak)
-
+
* t/
- - fixed hash-ordering test bug that was
+ - fixed hash-ordering test bug that was
causing occasional cpantester failures
- - renamed the t/000_recipe/*.t tests to be
- more descriptive (thanks to Sartak)
+ - renamed the t/000_recipe/*.t tests to be
+ more descriptive (thanks to Sartak)
0.44 Sat. May 10, 2008
* Moose
- - made make_immutable warning cluck to
+ - made make_immutable warning cluck to
show where the error is (thanks mst)
-
+
* Moose::Object
- - BUILDALL and DEMOLISHALL now call
- ->body when looping through the
+ - BUILDALL and DEMOLISHALL now call
+ ->body when looping through the
methods, to avoid the overloaded
method call.
- fixed issue where DEMOLISHALL was
- eating the $@ values, and so not
+ eating the $@ values, and so not
working correctly, it still kind of
- eats them, but so does vanilla perl
+ eats them, but so does vanilla perl
- added tests for this
-
+
* Moose::Cookbook::Recipe7
- - added new recipe for immutable
+ - added new recipe for immutable
functionality (thanks Dave Rolsky)
-
+
* Moose::Cookbook::Recipe9
- - added new recipe for builder and
+ - added new recipe for builder and
lazy_build (thanks Dave Rolsky)
-
+
* Moose::Cookbook::Recipe11
- - added new recipe for method aliasing
+ - added new recipe for method aliasing
and exclusion with Roles (thanks Dave Rolsky)
* t/
- fixed Win32 test failure (thanks spicyjack)
- ~ removed Build.PL and Module::Build compat
+ ~ removed Build.PL and Module::Build compat
since Module::Install has done that.
0.43 Wed. April, 30, 2008
* NOTE TO SELF:
- drink more coffee before
+ drink more coffee before
doing release engineering
-
- - whoops, forgot to do the smolder tests,
+
+ - whoops, forgot to do the smolder tests,
and we broke some of the custom meta-attr
modules. This fixes that.
0.42 Mon. April 28, 2008
- - some bad tests slipped by, nothing else
+ - some bad tests slipped by, nothing else
changed in this release (cpantesters++)
-
- - upped the Class::MOP dependency to 0.55
- since we have tests which need the C3
+
+ - upped the Class::MOP dependency to 0.55
+ since we have tests which need the C3
support
0.41 Mon. April 28, 2008
~~ numerous documentation updates ~~
-
+
- Changed all usage of die to Carp::croak for better
error reporting (initial patch by Tod Hagan)
any method/@ISA cache penalty (nothingmuch)
* Moose::Meta::Class
- - fixing &new_object to make sure trigger gets the
- coerced value (spotted by Charles Alderman on the
+ - fixing &new_object to make sure trigger gets the
+ coerced value (spotted by Charles Alderman on the
mailing list)
- added test for this
found by Jesse Luehrs, fixed by Dave Rolsky)
- added tests for this (Dave Rolsky)
- fix typo in initialize_body method (nothingmuch)
-
+
* Moose::Meta::Method::Destructor
- fix typo in initialize_body method (nothingmuch)
* Moose::Meta::Method::Overriden
Moose::Meta::Method::Augmented
- - moved the logic for these into their own
+ - moved the logic for these into their own
classes (nothingmuch)
* Moose::Meta::Attribute
- - inherited attributes may now be extended without
+ - inherited attributes may now be extended without
restriction on the type ('isa', 'does') (Sartak)
- added tests for this (Sartak)
- - when an attribute property is malformed (such as lazy without
- a default), give the name of the attribute in the error
+ - when an attribute property is malformed (such as lazy without
+ a default), give the name of the attribute in the error
message (Sartak)
- - added the &applied_traits and &has_applied_traits methods
+ - added the &applied_traits and &has_applied_traits methods
to allow introspection of traits
- added tests for this
- moved 'trait' and 'metaclass' argument handling to here from
- clone_and_inherit_options now handles 'trait' and 'metaclass' (has
'+foo' syntax) (nothingmuch)
- added tests for this (t0m)
-
- * Moose::Object
- - localize $@ inside DEMOLISHALL to avoid it
+
+ * Moose::Object
+ - localize $@ inside DEMOLISHALL to avoid it
eating $@ (found by Ernesto)
- added test for this (thanks to Ernesto)
* Moose::Util::TypeConstraints
- - &find_type_constraint now DWIMs when given an
+ - &find_type_constraint now DWIMs when given an
type constraint object or name (nothingmuch)
- &find_or_create_type_constraint superseded with a number of more
specific functions:
Moose::Meta::TypeConstraint::Enum
Moose::Meta::TypeConstraint::Union
Moose::Meta::TypeConstraint::Parameterized
- - added the &equals method for comparing two type
+ - added the &equals method for comparing two type
constraints (nothingmuch)
- added tests for this (nothingmuch)
* Moose::Meta::TypeConstraint
- - add the &parents method, which is just an alias to &parent.
+ - add the &parents method, which is just an alias to &parent.
Useful for polymorphism with TC::{Class,Role,Union} (nothingmuch)
* Moose::Meta::TypeConstraint::Class
- added the class attribute for introspection purposes
(nothingmuch)
- added tests for this
-
+
* Moose::Meta::TypeConstraint::Enum
Moose::Meta::TypeConstraint::Role
- broke these out into their own classes (nothingmuch)
0.39 Fri. March 14, 2008
* Moose
- - documenting the use of '+name' with attributes
+ - documenting the use of '+name' with attributes
that come from recently composed roles. It makes
- sense, people are using it, and so why not just
+ sense, people are using it, and so why not just
officially support it.
- - fixing the 'extends' keyword so that it will not
+ - fixing the 'extends' keyword so that it will not
trigger Ovid's bug (http://use.perl.org/~Ovid/journal/35763)
-
+
* oose
- - added the perl -Moose=+Class::Name feature to allow
+ - added the perl -Moose=+Class::Name feature to allow
monkeypatching of classes in one liners
-
+
* Moose::Util
- - fixing the 'apply_all_roles' keyword so that it will not
- trigger Ovid's bug (http://use.perl.org/~Ovid/journal/35763)
-
+ - fixing the 'apply_all_roles' keyword so that it will not
+ trigger Ovid's bug (http://use.perl.org/~Ovid/journal/35763)
+
* Moose::Meta::Class
- added ->create method which now supports roles (thanks to jrockway)
- added tests for this
- - added ->create_anon_class which now supports roles and caching of
+ - added ->create_anon_class which now supports roles and caching of
the results (thanks to jrockway)
- added tests for this
- made ->does_role a little more forgiving when it is
checking a Class::MOP era metaclasses.
-
+
* Moose::Meta::Role::Application::ToInstance
- - it is now possible to pass extra params to be used when
+ - it is now possible to pass extra params to be used when
a role is applied to an the instance (rebless_params)
- added tests for this
-
+
* Moose::Util::TypeConstraints
- class_type now accepts an optional second argument for a
custom message. POD anotated accordingly (groditi)
- - added tests for this
- - it is now possible to make anon-enums by passing 'enum' an
- ARRAY ref instead of the $name => @values. Everything else
+ - added tests for this
+ - it is now possible to make anon-enums by passing 'enum' an
+ ARRAY ref instead of the $name => @values. Everything else
works as before.
- added tests for this
-
+
* t/
- - making test for using '+name' on attributes consumed
+ - making test for using '+name' on attributes consumed
from a role, it works and makes sense too.
- * Moose::Meta::Attribute
- - fix handles so that it doesn't return nothing
- when the method cannot be found, not sure why
+ * Moose::Meta::Attribute
+ - fix handles so that it doesn't return nothing
+ when the method cannot be found, not sure why
it ever did this originally, this means we now
- have slightly better support for AUTOLOADed
+ have slightly better support for AUTOLOADed
objects
- added more delegation tests
- - adding ->does method to this so as to better
+ - adding ->does method to this so as to better
support traits and their introspection.
- added tests for this
-
+
* Moose::Object
- - localizing the Data::Dumper configurations so
+ - localizing the Data::Dumper configurations so
that it does not pollute others (RT #33509)
- made ->does a little more forgiving when it is
passed Class::MOP era metaclasses.
0.38 Fri. Feb. 15, 2008
- * Moose::Meta::Attribute
- - fixed initializer to correctly do
- type checking and coercion in the
- callback
+ * Moose::Meta::Attribute
+ - fixed initializer to correctly do
+ type checking and coercion in the
+ callback
- added tests for this
* t/
0.37 Thurs. Feb. 14, 2008
* Moose
- - fixed some details in Moose::init_meta
+ - fixed some details in Moose::init_meta
and its superclass handling (thanks thepler)
- added tests for this (thanks thepler)
- - 'has' now dies if you don't pass in name
+ - 'has' now dies if you don't pass in name
value pairs
- added the 'make_immutable' keyword as a shortcut
to make_immutable
* Moose::Meta::Class
Moose::Meta::Method::Constructor
- Moose::Meta::Attribute
+ Moose::Meta::Attribute
- making (init_arg => undef) work here too
(thanks to nothingmuch)
-
- * Moose::Meta::Attribute
+
+ * Moose::Meta::Attribute
Moose::Meta::Method::Constructor
- Moose::Meta::Method::Accessor
+ Moose::Meta::Method::Accessor
- make lazy attributes respect attr initializers (rjbs)
- added tests for this
-
+
* Moose::Util::TypeConstraints
Moose::Util::TypeConstraints::OptimizedConstraints
Moose::Meta::TypeConstraints
Moose::Meta::Attribute
Moose::Meta::Method::Constructor
- Moose::Meta::Method::Accessor
- - making type errors use the
+ Moose::Meta::Method::Accessor
+ - making type errors use the
assigned message (thanks to Sartak)
- added tests for this
* Moose::Meta::Method::Destructor
- - making sure DESTROY gets inlined properly
+ - making sure DESTROY gets inlined properly
with successive DEMOLISH calls (thanks to manito)
- * Moose::Meta::Attribute
- Moose::Meta::Method::Accessor
- - fixed handling of undef with type constraints
- (thanks to Ernesto)
+ * Moose::Meta::Attribute
+ Moose::Meta::Method::Accessor
+ - fixed handling of undef with type constraints
+ (thanks to Ernesto)
- added tests for this
-
+
* Moose::Util
- - added &get_all_init_args and &get_all_attribute_values
+ - added &get_all_init_args and &get_all_attribute_values
(thanks to Sartak and nothingmuch)
0.36 Sat. Jan. 26, 2008
* Moose::Role
Moose::Meta::Attribute
- - role type tests now support when roles are
+ - role type tests now support when roles are
applied to non-Moose classes (found by ash)
- added tests for this (thanks to ash)
- couple extra tests to boost code coverage
- * Moose::Meta::Method::Constructor
+ * Moose::Meta::Method::Constructor
- improved fix for handling Class::MOP attributes
- - added test for this
-
+ - added test for this
+
* Moose::Meta::Class
- handled the add_attribute($attribute_meta_object)
case correctly
0.35 Tues. Jan. 22, 2008
* Moose::Meta::Method::Constructor
- - fix to make sure even Class::MOP attributes
+ - fix to make sure even Class::MOP attributes
are handled correctly (Thanks to Dave Rolsky)
- added test for this (also Dave Rolsky)
-
+
* Moose::Meta::Class
- - improved error message on _apply_all_roles,
+ - improved error message on _apply_all_roles,
you should now use Moose::Util::apply_all_roles
and you shouldnt have been using a _ prefixed
method in the first place ;)
Moose is now a postmodern object system :)
- (see the POD for details)
-
- * <<Role System Refactoring>>
- - this release contains a major reworking and
- cleanup of the role system
+
+ * <<Role System Refactoring>>
+ - this release contains a major reworking and
+ cleanup of the role system
- 100% backwards compat.
- Role application now restructured into seperate
classes based on type of applicants
- Role summation (combining of more than one role)
- is much cleaner and anon-classes are no longer
+ is much cleaner and anon-classes are no longer
used in this process
- - new Composite role metaclass
+ - new Composite role metaclass
- runtime application of roles to instances
is now more efficient and re-uses generated
classes when applicable
-
+
* <<New Role composition features>>
- - methods can now be excluded from a given role
+ - methods can now be excluded from a given role
during composition
- - methods can now be aliased to another name (and
- still retain the original as well)
-
+ - methods can now be aliased to another name (and
+ still retain the original as well)
+
* Moose::Util::TypeConstraints::OptimizedConstraints
- added this module (see above)
* Moose::Meta::Method::Accessor
Moose::Meta::Method::Constructor
Moose::Meta::Attribute
- Moose::Meta::TypeConstraint
- Moose::Meta::TypeCoercion
- - lots of cleanup of such things as:
+ Moose::Meta::TypeConstraint
+ Moose::Meta::TypeCoercion
+ - lots of cleanup of such things as:
- generated methods
- type constraint handling
- - error handling/messages
- (thanks to nothingmuch)
-
+ - error handling/messages
+ (thanks to nothingmuch)
+
* Moose::Meta::TypeConstraint::Parameterizable
- - added this module to support the refactor
+ - added this module to support the refactor
in Moose::Meta::TypeConstraint::Parameterized
* Moose::Meta::TypeConstraint::Parameterized
- - refactored how these types are handled so they
+ - refactored how these types are handled so they
are more generic and not confined to ArrayRef
and HashRef only
-----------------------------------------------------------
-- Type Constraints refactor
------------------------------------------------------------
+-----------------------------------------------------------
- add support for locally scoped TC
-This would borrow from MooseX::TypeLibrary to prefix the TC with the name
-of the package. It would then be accesible from the outside as the fully
-scoped name, but the local attributes would use it first. (this would need support
+This would borrow from MooseX::TypeLibrary to prefix the TC with the name
+of the package. It would then be accesible from the outside as the fully
+scoped name, but the local attributes would use it first. (this would need support
in the registry for this).
- look into sugar extensions
-Use roles as sugar layer function providers (ala MooseX::AttributeHelpers). This
+Use roles as sugar layer function providers (ala MooseX::AttributeHelpers). This
would allow custom metaclasses to provide roles to extend the sugar syntax with.
(NOTE: Talk to phaylon a bit more on this)
-- allow a switch of some kind to optionally turn TC checking off at runtime
+- allow a switch of some kind to optionally turn TC checking off at runtime
-The type checks can get expensive and some people have suggested that allowing
-the checks to be turned off would be helpful for deploying into performance
+The type checks can get expensive and some people have suggested that allowing
+the checks to be turned off would be helpful for deploying into performance
intensive systems. Perhaps this can actually be done as an option to make_immutable?
- misc. minor bits
* and then something like this:
subtype Foo => as Bar => where { ... } => scoped => -global;
-subtype Foo => as Bar => where { ... } => scoped => -local;
+subtype Foo => as Bar => where { ... } => scoped => -local;
-# or
+# or
-subtype Foo => as Bar => where { ... } => in __PACKAGE__ ;
+subtype Foo => as Bar => where { ... } => in __PACKAGE__ ;
# or (not sure if it would be possible)
# ----------
[17:10] <autarch> stevan: it should do it if I pass coerce => 1 as part of the attribute definition
-[17:12] <stevan> autarch: what I am not 100% sure of is how to tell it to deep coerce and when to not
+[17:12] <stevan> autarch: what I am not 100% sure of is how to tell it to deep coerce and when to not
[17:13] <stevan> cause a basic coerce is from A to B
[17:13] <autarch> hmm
[17:13] <stevan> which is valid for collection types too
- create an official TC registry API (DONE)
-Right now the registration of the TC is a by-product of creation in the sugar
-layer, this is bad and make extension of TCs difficult. I am not sure if this
-registry API should exist as part of Moose::Util::TypeConstraints, or of we
-should create a complete registry object itself.
+Right now the registration of the TC is a by-product of creation in the sugar
+layer, this is bad and make extension of TCs difficult. I am not sure if this
+registry API should exist as part of Moose::Util::TypeConstraints, or of we
+should create a complete registry object itself.
-This registry should be a singleton, but M::U::TC should enforce that lifecycle
+This registry should be a singleton, but M::U::TC should enforce that lifecycle
choice so that you can use your own registry if you really want too.
I mean parent of the registry. So that I can create my own registry
- refactor the various TC internals to make it more subclassing friendly (DONE)
-This also includes the coercion stuff as well. This should give you what you
+This also includes the coercion stuff as well. This should give you what you
need to make your object/class bound stuff.
- move the container TCs from MooseX::AttributeHelpers into Moose core (DONE)
-These have proven so useful for me in the latest $work project that I think
+These have proven so useful for me in the latest $work project that I think
they should really be core.
-- move the details of TC construction that are in Moose.pm and
+- move the details of TC construction that are in Moose.pm and
Moose::Util::TypeConstraints into the Moose::Meta::TypeConstraint module
(DONE)
-This will make it much easier to generate TCs on their own, without
-having to use the sugar layer. This should also clean up their APIs
+This will make it much easier to generate TCs on their own, without
+having to use the sugar layer. This should also clean up their APIs
as well, which will make it easier to subclass them.
-----------------------------------------------------------
http://www.iinteractive.com
This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
+it under the same terms as Perl itself.
-------------------------------------------------------------------------------
BUGS
--------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
TODO
- DDuncan's Str types
-subtype 'Str'
- => as 'Value'
- => where { Encode::is_utf8( $_[0] ) or $_[0] !~ m/[^0x00-0x7F]/x }
+subtype 'Str'
+ => as 'Value'
+ => where { Encode::is_utf8( $_[0] ) or $_[0] !~ m/[^0x00-0x7F]/x }
=> optimize_as { defined($_[0]) && !ref($_[0]) };
-subtype 'Blob'
- => as 'Value'
- => where { !Encode::is_utf8( $_[0] ) }
+subtype 'Blob'
+ => as 'Value'
+ => where { !Encode::is_utf8( $_[0] ) }
=> optimize_as { defined($_[0]) && !ref($_[0]) };
- should handle some moose-specific options in &Moose::Meta::Class::create
- things like roles, and method modifiers (although those can probably be
+ things like roles, and method modifiers (although those can probably be
ignored if i want to)
- type unions
-Add support for doing it with Classes which do not have
+Add support for doing it with Classes which do not have
a type constraint yet created
- type intersections
- proxy attributes
a proxied attribute is an attribute
-which looks like an attribute,
-talks like an attribute, smells
-like an attribute,.. but if you
-look behind the curtain,.. its
+which looks like an attribute,
+talks like an attribute, smells
+like an attribute,.. but if you
+look behind the curtain,.. its
over there.. in that other object
(... probably be a custom metaclass)
[22:57] stevan :P
[22:57] stevan are you wanting to reuse it or something?
[22:57] stevan my $subtype = subtype 'Something' => where { ... };
-[22:58] stevan then you can do isa => $subtype
+[22:58] stevan then you can do isa => $subtype
[22:58] mst but I can't subtype it again
-[22:59] stevan mst: ahhh...
+[22:59] stevan mst: ahhh...
[22:59] mst well, I can. but it suddenly gets very "long way round" ish
[23:00] stevan my $constraint = Moose::Meta::TypeConstraint->new(
[23:00] stevan name => $name || '__ANON__',
-[23:00] stevan parent => $parent,
-[23:00] stevan constraint => $check,
-[23:00] stevan message => $message,
+[23:00] stevan parent => $parent,
+[23:00] stevan constraint => $check,
+[23:00] stevan message => $message,
[23:00] stevan );
[23:00] stevan yeah thats kinda the long way
[23:00] stevan mst: what would you like it to be?
[23:00] stevan hmm
[23:00] mst should be all you need to change
[23:00] stevan yeah
-[23:01] stevan so you can then say
+[23:01] stevan so you can then say
[23:01] stevan subtype $anon => where { ... };
[23:01] mst right
[23:01] stevan ok
[13:17] mst so if I'm trying to declare it cast-style per-source-class rather than per-target-class
[13:17] mst I am extremely screwed
[13:17] stevan yes
-[13:17] stevan they are not class specific
+[13:17] stevan they are not class specific
[13:18] stevan they are attached to the type constraint itself
[13:18] * stevan ponders anon-coercion-metaobjects
[13:18] mst yes, that's fine
[13:32] mst stevan: I want to be able to say in package Bar
[13:32] mst stevan: coerce_to 'Foo' via { ... };
[13:32] mst etc.
-[13:53] stevan hmm
-
-
+[13:53] stevan hmm
+
+
-------------------------------------------------------------------------------
TO PONDER
-------------------------------------------------------------------------------
- Moose "strict" mode
use Moose 'strict'; This would allow us to have all sort of expensive tests
-which can be turned off in prod.
-
+which can be turned off in prod.
+
- Moose::Philosophy.pod
To explain Moose from a very high level
- moosedoc
We certainly have enough meta-information to make pretty complete POD docs.
-
-
-
+
+
+
use Moose;
has 'default' => (is => 'rw', default => 10);
- has 'default_sub' => (is => 'rw', default => sub { [] });
+ has 'default_sub' => (is => 'rw', default => sub { [] });
has 'lazy' => (is => 'rw', default => 10, lazy => 1);
- has 'required' => (is => 'rw', required => 1);
- has 'weak_ref' => (is => 'rw', weak_ref => 1);
- has 'type_constraint' => (is => 'rw', isa => 'Foo');
- has 'coercion' => (is => 'rw', isa => 'Foo', coerce => 1);
-
+ has 'required' => (is => 'rw', required => 1);
+ has 'weak_ref' => (is => 'rw', weak_ref => 1);
+ has 'type_constraint' => (is => 'rw', isa => 'Foo');
+ has 'coercion' => (is => 'rw', isa => 'Foo', coerce => 1);
+
package Bar::Normal;
use Moose;
-
+
extends 'Foo::Normal';
-
+
has 'default_w_type_constraint' => (
is => 'rw',
isa => 'Int',
{
package Foo::Immutable;
use Moose;
-
+
has 'default' => (is => 'rw', default => 10);
- has 'default_sub' => (is => 'rw', default => sub { [] });
+ has 'default_sub' => (is => 'rw', default => sub { [] });
has 'lazy' => (is => 'rw', default => 10, lazy => 1);
- has 'required' => (is => 'rw', required => 1);
- has 'weak_ref' => (is => 'rw', weak_ref => 1);
- has 'type_constraint' => (is => 'rw', isa => 'Foo');
+ has 'required' => (is => 'rw', required => 1);
+ has 'weak_ref' => (is => 'rw', weak_ref => 1);
+ has 'type_constraint' => (is => 'rw', isa => 'Foo');
has 'coercion' => (is => 'rw', isa => 'Foo', coerce => 1);
-
+
#sub BUILD {
# # ...
#}
-
+
Foo::Immutable->meta->make_immutable(debug => 0);
-
+
package Bar::Immutable;
use Moose;
-
- extends 'Foo::Immutable';
-
+
+ extends 'Foo::Immutable';
+
has 'default_w_type_constraint' => (
is => 'rw',
isa => 'Int',
default => 10,
- );
-
- Bar::Immutable->meta->make_immutable(debug => 0);
+ );
+
+ Bar::Immutable->meta->make_immutable(debug => 0);
}
#__END__
my $foo = Foo->new;
-cmpthese(10_000,
+cmpthese(10_000,
{
'normal' => sub {
Foo::Normal->new(
required => 'BAR',
type_constraint => $foo,
coercion => [],
- weak_ref => {},
+ weak_ref => {},
);
},
}
package CMMChild::Before;
use Class::Method::Modifiers;
use base 'PlainParent';
-
+
before method => sub { "B" };
}
{
package CMMChild::Around;
use Class::Method::Modifiers;
use base 'PlainParent';
-
+
around method => sub { shift->() . "A" };
}
{
package CMMChild::AllThree;
use Class::Method::Modifiers;
use base 'PlainParent';
-
+
before method => sub { "B" };
around method => sub { shift->() . "A" };
after method => sub { "Z" };
=pod
-This compares the burden of a basic Moose
-class to a basic Class::MOP class.
+This compares the burden of a basic Moose
+class to a basic Class::MOP class.
-It is worth noting that the basic Moose
-class will also create a type constraint
-as well as export many subs, so this comparison
+It is worth noting that the basic Moose
+class will also create a type constraint
+as well as export many subs, so this comparison
is really not fair :)
=cut
-cmpthese(5_000,
- {
+cmpthese(5_000,
+ {
'w/out_moose' => sub {
eval 'package Bar; use metaclass;';
},
'w_moose' => sub {
eval 'package Baz; use Moose;';
- },
+ },
}
);
=pod
This compare the overhead of Class::MOP
-to the overhead of Moose.
+to the overhead of Moose.
-The goal here is to see how much more
+The goal here is to see how much more
startup cost Moose adds to Class::MOP.
NOTE:
-This benchmark may not be all that
-relevant really, but it's helpful to
+This benchmark may not be all that
+relevant really, but it's helpful to
see maybe.
=cut
-cmpthese(5_000,
+cmpthese(5_000,
{
'w/out_moose' => sub {
eval 'use Class::MOP;';
},
'w_moose' => sub {
eval 'use Moose;';
- },
+ },
}
);
use Moose;
has 'default' => (is => 'rw', default => 10);
- has 'default_sub' => (is => 'rw', default => sub { [] });
+ has 'default_sub' => (is => 'rw', default => sub { [] });
has 'lazy' => (is => 'rw', default => 10, lazy => 1);
- has 'required' => (is => 'rw', required => 1);
- has 'weak_ref' => (is => 'rw', weak_ref => 1);
- has 'type_constraint' => (is => 'rw', isa => 'ArrayRef');
+ has 'required' => (is => 'rw', required => 1);
+ has 'weak_ref' => (is => 'rw', weak_ref => 1);
+ has 'type_constraint' => (is => 'rw', isa => 'ArrayRef');
}
foreach (0 .. $num_iterations) {
=pod
-This benchmark compares the overhead of a
-auto-created type constraint vs. none at
+This benchmark compares the overhead of a
+auto-created type constraint vs. none at
all vs. a custom-created type.
=cut
package Foo;
use Moose;
use Moose::Util::TypeConstraints;
-
+
has 'baz' => (is => 'rw');
has 'bar' => (is => 'rw', isa => 'Foo');
}
{
package Bar;
-
+
sub new { bless {} => __PACKAGE__ }
- sub bar {
+ sub bar {
my $self = shift;
$self->{bar} = shift if @_;
$self->{bar};
my $foo = Foo->new;
my $bar = Bar->new;
-cmpthese(200_000,
+cmpthese(200_000,
{
'hand coded' => sub {
$bar->bar($bar);
$foo->baz($foo);
},
'w_constraint' => sub {
- $foo->bar($foo);
- },
+ $foo->bar($foo);
+ },
}
);
19:23 <nothingmuch> except without the Moose test suite's assumptions
19:23 <nothingmuch> about state and module loading, and all that
19:24 <nothingmuch> and doing that is a much more daunting prospect than hacking on MXC itself
-19:24 <obra> understood. the problem is that I still don't have a good sense of how to get it going, even manually
+19:24 <obra> understood. the problem is that I still don't have a good sense of how to get it going, even manually
19:24 <nothingmuch> ah
19:24 <obra> none of the test files seem to show off what I need
19:24 <nothingmuch> i can walk you through thjat
19:36 <obra> my tests aren't scientific.
19:36 <nothingmuch> trunk moose as of you sending me nytprofs
19:37 <nothingmuch> actually that's CPAN moose now
-19:37 <obra> 0.35 - 0.45
+19:37 <obra> 0.35 - 0.45
19:37 <nothingmuch> ouch
19:37 <nothingmuch> well, part of the problem is that it loads *EVERYTHING*
19:37 <nothingmuch> every type of meta method class, meta type constraint, the role system, etc
19:46 <obra> yeah. but the goal is to turn it into written docs.
19:46 <obra> ok. for now, it should end up in MooseX-Compile/doc/design
19:46 <nothingmuch> sounds good
-19:46 <obra> . o O { Thank god I don't have a moose commit bit }
+19:46 <obra> . o O { Thank god I don't have a moose commit bit }
19:47 <nothingmuch> though most of this affects moose itself though
19:47 * obra nods
19:47 <obra> Moose/doc/moosex-compile, then
}
sub throw_error {
- # FIXME This
+ # FIXME This
shift;
goto \&confess
}
=head1 PROVIDED METHODS
-Moose provides a number of methods to all your classes, mostly through the
+Moose provides a number of methods to all your classes, mostly through the
inheritance of L<Moose::Object>. There is however, one exception.
=over 4
=item B<with (@roles)>
-This will apply a given set of C<@roles> to the local class.
+This will apply a given set of C<@roles> to the local class.
=item B<has $name|@$names =E<gt> %options>
overriding locally defined methods, if you do want to do this, you should do it
manually, not with Moose.
-You do not I<need> to have a reader (or accessor) for the attribute in order
-to delegate to it. Moose will create a means of accessing the value for you,
-however this will be several times B<less> efficient then if you had given
+You do not I<need> to have a reader (or accessor) for the attribute in order
+to delegate to it. Moose will create a means of accessing the value for you,
+however this will be several times B<less> efficient then if you had given
the attribute a reader (or accessor) to use.
Below is the documentation for each option format:
This tells the class to use a custom attribute metaclass for this particular
attribute. Custom attribute metaclasses are useful for extending the
capabilities of the I<has> keyword: they are the simplest way to extend the MOP,
-but they are still a fairly advanced topic and too much to cover here, see
+but they are still a fairly advanced topic and too much to cover here, see
L<Moose::Cookbook::Meta::Recipe1> for more information.
The default behavior here is to just load C<$metaclass_name>; however, we also
=item I<traits =E<gt> [ @role_names ]>
-This tells Moose to take the list of C<@role_names> and apply them to the
-attribute meta-object. This is very similar to the I<metaclass> option, but
+This tells Moose to take the list of C<@role_names> and apply them to the
+attribute meta-object. This is very similar to the I<metaclass> option, but
allows you to use more than one extension at a time.
See L<TRAIT NAME RESOLUTION> for details on how a trait name is
=item B<has +$name =E<gt> %options>
This is variation on the normal attribute creator C<has> which allows you to
-clone and extend an attribute from a superclass or from a role. Here is an
+clone and extend an attribute from a superclass or from a role. Here is an
example of the superclass usage:
package Foo;
has '+message' => (default => 'Hello I am My::Foo');
-In this case, we are basically taking the attribute which the role supplied
-and altering it within the bounds of this feature.
+In this case, we are basically taking the attribute which the role supplied
+and altering it within the bounds of this feature.
-Aside from where the attributes come from (one from superclass, the other
-from a role), this feature works exactly the same. This feature is restricted
-somewhat, so as to try and force at least I<some> sanity into it. You are only
+Aside from where the attributes come from (one from superclass, the other
+from a role), this feature works exactly the same. This feature is restricted
+somewhat, so as to try and force at least I<some> sanity into it. You are only
allowed to change the following attributes:
=over 4
=item I<isa>
-You I<are> allowed to change the type without restriction.
+You I<are> allowed to change the type without restriction.
-It is recommended that you use this freedom with caution. We used to
-only allow for extension only if the type was a subtype of the parent's
-type, but we felt that was too restrictive and is better left as a
-policy decision.
+It is recommended that you use this freedom with caution. We used to
+only allow for extension only if the type was a subtype of the parent's
+type, but we felt that was too restrictive and is better left as a
+policy decision.
=item I<handles>
=item B<confess>
This is the C<Carp::confess> function, and exported here because I use it
-all the time.
+all the time.
=item B<blessed>
=head2 The MooseX:: namespace
-Generally if you're writing an extension I<for> Moose itself you'll want
-to put your extension in the C<MooseX::> namespace. This namespace is
-specifically for extensions that make Moose better or different in some
-fundamental way. It is traditionally B<not> for a package that just happens
-to use Moose. This namespace follows from the examples of the C<LWPx::>
+Generally if you're writing an extension I<for> Moose itself you'll want
+to put your extension in the C<MooseX::> namespace. This namespace is
+specifically for extensions that make Moose better or different in some
+fundamental way. It is traditionally B<not> for a package that just happens
+to use Moose. This namespace follows from the examples of the C<LWPx::>
and C<DBIx::> namespaces that perform the same function for C<LWP> and C<DBI>
respectively.
=item The Art of the MetaObject Protocol
-I mention this in the L<Class::MOP> docs too, this book was critical in
+I mention this in the L<Class::MOP> docs too, this book was critical in
the development of both modules and is highly recommended.
=back
=head1 FEATURE REQUESTS
-We are very strict about what features we add to the Moose core, especially
-the user-visible features. Instead we have made sure that the underlying
-meta-system of Moose is as extensible as possible so that you can add your
-own features easily. That said, occasionally there is a feature needed in the
-meta-system to support your planned extension, in which case you should
+We are very strict about what features we add to the Moose core, especially
+the user-visible features. Instead we have made sure that the underlying
+meta-system of Moose is as extensible as possible so that you can add your
+own features easily. That said, occasionally there is a feature needed in the
+meta-system to support your planned extension, in which case you should
either email the mailing list or join us on irc at #moose to discuss. The
L<Moose::Manual::Contributing> has more detail about how and when you can
contribute.
=head1 AUTHOR
-Moose is an open project, there are at this point dozens of people who have
-contributed, and can contribute. If you have added anything to the Moose
+Moose is an open project, there are at this point dozens of people who have
+contributed, and can contribute. If you have added anything to the Moose
project you have a commit bit on this file and can add your name to the list.
=head2 CABAL
-However there are only a few people with the rights to release a new version
+However there are only a few people with the rights to release a new version
of Moose. The Moose Cabal are the people to go to with questions regarding
the wider purview of Moose, and help out maintaining not just the code
but the community as well.
=item Method Modifiers
-The concept of method modifiers is directly ripped off from CLOS. A
+The concept of method modifiers is directly ripped off from CLOS. A
great explanation of them can be found by following this link.
L<http://www.gigamonkeys.com/book/object-reorientation-generic-functions.html>
=head3 Is Moose "production ready"?
-Yes. I have several medium-to-large-ish web applications in
-production using Moose, they have been running without
-issue now for well over a year.
+Yes. I have several medium-to-large-ish web applications in
+production using Moose, they have been running without
+issue now for well over a year.
-At C<$work> we are re-writing our core offering to use Moose,
-so its continued development is assured.
+At C<$work> we are re-writing our core offering to use Moose,
+so its continued development is assured.
-Several other people on #moose either have apps in production
-which use Moose, or are in the process of deploying sites
-which use Moose.
+Several other people on #moose either have apps in production
+which use Moose, or are in the process of deploying sites
+which use Moose.
=head3 Is Moose's API stable?
Yes and No. The external API, the one 90% of users will interact
-with, is B<very stable> and any changes B<will be 100% backwards
-compatible>. The introspection API is I<mostly> stable; I still
-reserve the right to tweak that if needed, but I will do my
+with, is B<very stable> and any changes B<will be 100% backwards
+compatible>. The introspection API is I<mostly> stable; I still
+reserve the right to tweak that if needed, but I will do my
absolute best to maintain backwards compatibility here as well.
=head3 I heard Moose is slow, is this true?
Again, this one is tricky, so Yes I<and> No.
-First let me say that I<nothing> in life is free, and that some
-Moose features do cost more than others. It is also the
-policy of Moose to B<only charge you for the features you use>,
-and to do our absolute best to not place any extra burdens on
-the execution of your code for features you are not using. Of
-course using Moose itself does involve some overhead, but it
-is mostly compile time. At this point we do have some options
-available for getting the speed you need.
-
-Currently we have the option of making your classes immutable
-as a means of boosting speed. This will mean a slightly larger compile
+First let me say that I<nothing> in life is free, and that some
+Moose features do cost more than others. It is also the
+policy of Moose to B<only charge you for the features you use>,
+and to do our absolute best to not place any extra burdens on
+the execution of your code for features you are not using. Of
+course using Moose itself does involve some overhead, but it
+is mostly compile time. At this point we do have some options
+available for getting the speed you need.
+
+Currently we have the option of making your classes immutable
+as a means of boosting speed. This will mean a slightly larger compile
time cost, but the runtime speed increase (especially in object
-construction) is pretty significant. This is not very well
+construction) is pretty significant. This is not very well
documented yet, so please ask on the list or on #moose for more
information.
use Moose's other features to handle your specific object construction
needs. Here are a few scenarios, and the Moose way to solve them;
-If you need to call initialization code post instance construction,
-then use the C<BUILD> method. This feature is taken directly from
-Perl 6. Every C<BUILD> method in your inheritance chain is called
-(in the correct order) immediately after the instance is constructed.
-This allows you to ensure that all your superclasses are initialized
+If you need to call initialization code post instance construction,
+then use the C<BUILD> method. This feature is taken directly from
+Perl 6. Every C<BUILD> method in your inheritance chain is called
+(in the correct order) immediately after the instance is constructed.
+This allows you to ensure that all your superclasses are initialized
properly as well. This is the best approach to take (when possible)
because it makes subclassing your class much easier.
-If you need to affect the constructor's parameters prior to the
+If you need to affect the constructor's parameters prior to the
instance actually being constructed, you have a number of options.
To change the parameter processing as a whole, you can use
most flexible and robust, but does have a slightly higher learning
curve.
-=head3 How do I make non-Moose constructors work with Moose?
+=head3 How do I make non-Moose constructors work with Moose?
Usually the correct approach to subclassing a non Moose class is
delegation. Moose makes this easy using the C<handles> keyword,
package My::HTML::Template;
use Moose;
-
- # explicit inheritance
+
+ # explicit inheritance
extends 'HTML::Template', 'Moose::Object';
-
+
# explicit constructor
sub new {
my $class = shift;
);
}
-Of course, this only works if both your Moose class and the
-inherited non-Moose class use the same instance type (typically
+Of course, this only works if both your Moose class and the
+inherited non-Moose class use the same instance type (typically
HASH refs).
Note that this doesn't call C<BUILDALL> automatically, you must do that
yourself.
-Other techniques can be used as well, such as creating the object
-using C<Moose::Object::new>, but calling the inherited non-Moose
-class's initialization methods (if available).
+Other techniques can be used as well, such as creating the object
+using C<Moose::Object::new>, but calling the inherited non-Moose
+class's initialization methods (if available).
It is also entirely possible to just rely on HASH autovivification
to create the slots needed for Moose based attributes, although this
does restrict use of construction time attribute features somewhat.
-In short, there are several ways to go about this, it is best to
-evaluate each case based on the class you wish to extend, and the
-features you wish to employ. As always, both IRC and the mailing
+In short, there are several ways to go about this, it is best to
+evaluate each case based on the class you wish to extend, and the
+features you wish to employ. As always, both IRC and the mailing
list are great ways to get help finding the best approach.
=head2 Accessors
=head3 How do I tell Moose to use get/set accessors?
-The easiest way to accomplish this is to use the C<reader> and
+The easiest way to accomplish this is to use the C<reader> and
C<writer> attribute options. Here is some example code:
has 'bar' => (
isa => 'Baz',
- reader => 'get_bar',
+ reader => 'get_bar',
writer => 'set_bar',
);
-Moose will still take advantage of type constraints, triggers, etc.
-when creating these methods.
+Moose will still take advantage of type constraints, triggers, etc.
+when creating these methods.
If you do not like this much typing, and wish it to be a default for your
class, please see L<MooseX::FollowPBP>. This will allow you to write:
And have Moose create separate C<get_bar> and C<set_bar> methods
instead of a single C<bar> method.
-NOTE: This B<cannot> be set globally in Moose, as that would break
+NOTE: This B<cannot> be set globally in Moose, as that would break
other classes which are built with Moose.
=head3 How can I get Moose to inflate/deflate values in the accessor?
-Well, the first question to ask is if you actually need both inflate
+Well, the first question to ask is if you actually need both inflate
and deflate.
-If you only need to inflate, then I suggest using coercions. Here is
+If you only need to inflate, then I suggest using coercions. Here is
some basic sample code for inflating a L<DateTime> object:
subtype 'DateTime'
=> as 'Object'
=> where { $_->isa('DateTime') };
-
+
coerce 'DateTime'
=> from 'Str'
=> via { DateTime::Format::MySQL->parse_datetime($_) };
-
+
has 'timestamp' => (is => 'rw', isa => 'DateTime', coerce => 1);
-This creates a custom subtype for L<DateTime> objects, then attaches
-a coercion to that subtype. The C<timestamp> attribute is then told
+This creates a custom subtype for L<DateTime> objects, then attaches
+a coercion to that subtype. The C<timestamp> attribute is then told
to expect a C<DateTime> type, and to try to coerce it. When a C<Str>
-type is given to the C<timestamp> accessor, it will attempt to
-coerce the value into a C<DateTime> object using the code in found
-in the C<via> block.
+type is given to the C<timestamp> accessor, it will attempt to
+coerce the value into a C<DateTime> object using the code in found
+in the C<via> block.
For a more comprehensive example of using coercions, see the
L<Moose::Cookbook::Basics::Recipe5>.
-If you need to deflate your attribute, the current best practice is to
+If you need to deflate your attribute, the current best practice is to
add an C<around> modifier to your accessor. Here is some example code:
- # a timestamp which stores as
+ # a timestamp which stores as
# seconds from the epoch
has 'timestamp' => (is => 'rw', isa => 'Int');
-
+
around 'timestamp' => sub {
my $next = shift;
my ($self, $timestamp) = @_;
$next->($self, $timestamp->epoch);
};
-It is also possible to do deflation using coercion, but this tends
-to get quite complex and require many subtypes. An example of this
-is outside the scope of this document, ask on #moose or send a mail
+It is also possible to do deflation using coercion, but this tends
+to get quite complex and require many subtypes. An example of this
+is outside the scope of this document, ask on #moose or send a mail
to the list.
-Still another option is to write a custom attribute metaclass, which
-is also outside the scope of this document, but I would be happy to
+Still another option is to write a custom attribute metaclass, which
+is also outside the scope of this document, but I would be happy to
explain it on #moose or the mailing list.
=head2 Method Modifiers
=head3 How can I affect the values in C<@_> using C<before>?
-You can't, actually: C<before> only runs before the main method,
-and it cannot easily affect the method's execution. What you want is
-an C<around> method.
+You can't, actually: C<before> only runs before the main method,
+and it cannot easily affect the method's execution. What you want is
+an C<around> method.
=head3 Can I use C<before> to stop execution of a method?
-Yes, but only if you throw an exception. If this is too drastic a
-measure then I suggest using C<around> instead. The C<around> method
-modifier is the only modifier which can gracefully prevent execution
+Yes, but only if you throw an exception. If this is too drastic a
+measure then I suggest using C<around> instead. The C<around> method
+modifier is the only modifier which can gracefully prevent execution
of the main method. Here is an example:
around 'baz' => sub {
$next->($self, %options);
};
-By choosing not to call the C<$next> method, you can stop the
+By choosing not to call the C<$next> method, you can stop the
execution of the main method.
=head2 Type Constraints
Use the C<message> option when building the subtype, like so:
- subtype 'NaturalLessThanTen'
+ subtype 'NaturalLessThanTen'
=> as 'Natural'
=> where { $_ < 10 }
=> message { "This number ($_) is not less than ten!" };
This will be called when a value fails to pass the C<NaturalLessThanTen>
-constraint check.
+constraint check.
=head3 Can I turn off type constraint checking?
-Not yet, but soon. This option will likely be coming in the next
+Not yet, but soon. This option will likely be coming in the next
release.
=head2 Roles
=head3 How do I get Moose to call BUILD in all my composed roles?
-See L<Moose::Cookbook::WTF> and specifically the B<Why is BUILD
+See L<Moose::Cookbook::WTF> and specifically the B<Why is BUILD
not called for my composed roles?> question in the B<Roles> section.
=head3 What are Traits, and how are they different from Roles?
=head3 Why is my code taking so long to load?
-Moose does have a compile time performance burden,
-which it inherits from Class::MOP. If load/compile
-time is a concern for your application, Moose may not
-be the right tool for you.
+Moose does have a compile time performance burden,
+which it inherits from Class::MOP. If load/compile
+time is a concern for your application, Moose may not
+be the right tool for you.
-Although, you should note that we are exploring the
-use of L<Module::Compile> to try and reduce this problem,
+Although, you should note that we are exploring the
+use of L<Module::Compile> to try and reduce this problem,
but nothing is ready yet.
=head3 Why are my objects taking so long to construct?
-Moose uses a lot of introspection when constructing an
-instance, and introspection can be slow. This problem
-can be solved by making your class immutable. This can
+Moose uses a lot of introspection when constructing an
+instance, and introspection can be slow. This problem
+can be solved by making your class immutable. This can
be done with the following code:
MyClass->meta->make_immutable();
Moose will then memoize a number of meta-level methods
-and inline a constructor for you. For more information
-on this see the L<Constructors> section below and in the
+and inline a constructor for you. For more information
+on this see the L<Constructors> section below and in the
L<Moose::Cookbook::FAQ>.
=head2 Constructors & Immutability
=head3 I made my class immutable, but C<new> is still slow!
-Do you have a custom C<new> method in your class? Moose
-will not overwrite your custom C<new> method, you would
-probably do better to try and convert this to use the
-C<BUILD> method or possibly set C<default> values in
-the attribute declaration.
+Do you have a custom C<new> method in your class? Moose
+will not overwrite your custom C<new> method, you would
+probably do better to try and convert this to use the
+C<BUILD> method or possibly set C<default> values in
+the attribute declaration.
-=head3 I made my class immutable, and now my (before | after |
+=head3 I made my class immutable, and now my (before | after |
around) C<new> is not being called?
-Making a I<before>, I<after> or I<around> wrap around the
-C<new> method will actually create a C<new> method within
+Making a I<before>, I<after> or I<around> wrap around the
+C<new> method will actually create a C<new> method within
your class. This will prevent Moose from creating one itself
-when you make the class immutable.
+when you make the class immutable.
=head2 Accessors
=head3 I created an attribute, where are my accessors?
-Accessors are B<not> created implicitly, you B<must> ask Moose
+Accessors are B<not> created implicitly, you B<must> ask Moose
to create them for you. My guess is that you have this:
has 'foo' => (isa => 'Bar');
has 'foo' => (isa => 'Bar', is => 'rw');
-The reason this is so is because it is a perfectly valid use
-case to I<not> have an accessor. The simplest one is that you
+The reason this is so is because it is a perfectly valid use
+case to I<not> have an accessor. The simplest one is that you
want to write your own. If Moose created one automatically, then
-because of the order in which classes are constructed, Moose
-would overwrite your custom accessor. You wouldn't want that
+because of the order in which classes are constructed, Moose
+would overwrite your custom accessor. You wouldn't want that
would you?
=head2 Method Modifiers
=head3 Why can't I change C<@_> in a C<before> modifier?
-The C<before> modifier is called I<before> the main method.
-Its return values are simply ignored, and are B<not> passed onto
-the main method body.
+The C<before> modifier is called I<before> the main method.
+Its return values are simply ignored, and are B<not> passed onto
+the main method body.
-There are a number of reasons for this, but those arguments are
-too lengthy for this document. Instead, I suggest using an C<around>
+There are a number of reasons for this, but those arguments are
+too lengthy for this document. Instead, I suggest using an C<around>
modifier instead. Here is some sample code:
around 'foo' => sub {
my $next = shift;
my ($self, @args) = @_;
- # do something silly here to @args
- $next->($self, reverse(@args));
+ # do something silly here to @args
+ $next->($self, reverse(@args));
};
=head3 Why can't I see return values in an C<after> modifier?
-As with the C<before> modifier, the C<after> modifier is simply
-called I<after> the main method. It is passed the original contents
-of C<@_> and B<not> the return values of the main method.
+As with the C<before> modifier, the C<after> modifier is simply
+called I<after> the main method. It is passed the original contents
+of C<@_> and B<not> the return values of the main method.
-Again, the arguments are too lengthy as to why this has to be. And
+Again, the arguments are too lengthy as to why this has to be. And
as with C<before> I recommend using an C<around> modifier instead.
Here is some sample code:
around 'foo' => sub {
my $next = shift;
my ($self, @args) = @_;
- my @rv = $next->($self, @args);
+ my @rv = $next->($self, @args);
# do something silly with the return values
return reverse @rv;
};
=head3 Why is BUILD not called for my composed roles?
-BUILD is never called in composed roles. The primary reason is that
-roles are B<not> order sensitive. Roles are composed in such a way
-that the order of composition does not matter (for information on
-the deeper theory of this read the original traits papers here
-L<http://www.iam.unibe.ch/~scg/Research/Traits/>).
+BUILD is never called in composed roles. The primary reason is that
+roles are B<not> order sensitive. Roles are composed in such a way
+that the order of composition does not matter (for information on
+the deeper theory of this read the original traits papers here
+L<http://www.iam.unibe.ch/~scg/Research/Traits/>).
-Because roles are essentially unordered, it would be impossible to
-determine the order in which to execute the BUILD methods.
+Because roles are essentially unordered, it would be impossible to
+determine the order in which to execute the BUILD methods.
As for alternate solutions, there are a couple.
=over 4
-=item *
+=item *
-Using a combination of lazy and default in your attributes to
+Using a combination of lazy and default in your attributes to
defer initialization (see the Binary Tree example in the cookbook
for a good example of lazy/default usage
L<Moose::Cookbook::Basics::Recipe3>)
=item *
-Use attribute triggers, which fire after an attribute is set, to facilitate
-initialization. These are described in the L<Moose> docs, and examples can be
+Use attribute triggers, which fire after an attribute is set, to facilitate
+initialization. These are described in the L<Moose> docs, and examples can be
found in the test suite.
=back
-In general, roles should not I<require> initialization; they should either
-provide sane defaults or should be documented as needing specific
+In general, roles should not I<require> initialization; they should either
+provide sane defaults or should be documented as needing specific
initialization. One such way to "document" this is to have a separate
-attribute initializer which is required for the role. Here is an example of
+attribute initializer which is required for the role. Here is an example of
how to do this:
package My::Role;
use Moose::Role;
-
+
has 'height' => (
is => 'rw',
isa => 'Int',
default => sub {
my $self = shift;
$self->init_height;
- }
+ }
);
-
+
requires 'init_height';
-In this example, the role will not compose successfully unless the class
-provides a C<init_height> method.
+In this example, the role will not compose successfully unless the class
+provides a C<init_height> method.
-If none of those solutions work, then it is possible that a role is not
+If none of those solutions work, then it is possible that a role is not
the best tool for the job, and you really should be using classes. Or, at
the very least, you should reduce the amount of functionality in your role
so that it does not require initialization.
predicate => 'has_applied_traits',
));
-# we need to have a ->does method in here to
-# more easily support traits, and the introspection
+# we need to have a ->does method in here to
+# more easily support traits, and the introspection
# of those traits. We extend the does check to look
# for metatrait aliases.
sub does {
my ($class, $name, @args) = @_;
my ( $new_class, @traits ) = $class->interpolate_class(@args);
-
+
$new_class->new($name, @args, ( scalar(@traits) ? ( traits => \@traits ) : () ) );
}
if ( my $metaclass_name = delete $options{metaclass} ) {
my $new_class = Moose::Util::resolve_metaclass_alias( Attribute => $metaclass_name );
-
+
if ( $class ne $new_class ) {
if ( $new_class->can("interpolate_class") ) {
return $new_class->interpolate_class(%options);
# ...
my @legal_options_for_inheritance = qw(
- default coerce required
- documentation lazy handles
+ default coerce required
+ documentation lazy handles
builder type_constraint
definition_context
lazy_build
sub legal_options_for_inheritance { @legal_options_for_inheritance }
# NOTE/TODO
-# This method *must* be able to handle
-# Class::MOP::Attribute instances as
-# well. Yes, I know that is wrong, but
-# apparently we didn't realize it was
-# doing that and now we have some code
-# which is dependent on it. The real
-# solution of course is to push this
+# This method *must* be able to handle
+# Class::MOP::Attribute instances as
+# well. Yes, I know that is wrong, but
+# apparently we didn't realize it was
+# doing that and now we have some code
+# which is dependent on it. The real
+# solution of course is to push this
# feature back up into Class::MOP::Attribute
# but I not right now, I am too lazy.
-# However if you are reading this and
-# looking for something to do,.. please
+# However if you are reading this and
+# looking for something to do,.. please
# be my guest.
# - stevan
sub clone_and_inherit_options {
my ($self, %options) = @_;
-
+
my %copy = %options;
-
+
my %actual_options;
-
+
# NOTE:
# we may want to extends a Class::MOP::Attribute
- # in which case we need to be able to use the
- # core set of legal options that have always
+ # in which case we need to be able to use the
+ # core set of legal options that have always
# been here. But we allows Moose::Meta::Attribute
# instances to changes them.
# - SL
my @legal_options = $self->can('legal_options_for_inheritance')
? $self->legal_options_for_inheritance
: @legal_options_for_inheritance;
-
+
foreach my $legal_option (@legal_options) {
if (exists $options{$legal_option}) {
$actual_options{$legal_option} = $options{$legal_option};
delete $options{$legal_option};
}
- }
+ }
if ($options{isa}) {
my $type_constraint;
$actual_options{type_constraint} = $type_constraint;
delete $options{isa};
}
-
+
if ($options{does}) {
my $type_constraint;
if (blessed($options{does}) && $options{does}->isa('Moose::Meta::TypeConstraint')) {
$actual_options{type_constraint} = $type_constraint;
delete $options{does};
- }
+ }
# NOTE:
- # this doesn't apply to Class::MOP::Attributes,
+ # this doesn't apply to Class::MOP::Attributes,
# so we can ignore it for them.
# - SL
if ($self->can('interpolate_class')) {
## is => rw, accessor => _foo # turns into (accessor => _foo)
## is => ro, accessor => _foo # error, accesor is rw
### -------------------------
-
+
if ($options->{is} eq 'ro') {
$class->throw_error("Cannot define an accessor name on a read-only attribute, accessors are read/write", data => $options)
if exists $options->{accessor};
if ($name =~ /^_/) {
$options->{clearer} ||= "_clear${name}";
$options->{predicate} ||= "_has${name}";
- }
+ }
else {
$options->{clearer} ||= "clear_${name}";
$options->{predicate} ||= "has_${name}";
my $value_is_set;
if ( defined($init_arg) and exists $params->{$init_arg}) {
$val = $params->{$init_arg};
- $value_is_set = 1;
+ $value_is_set = 1;
}
else {
# skip it if it's lazy
if ($self->has_default) {
$val = $self->default($instance);
$value_is_set = 1;
- }
+ }
elsif ($self->has_builder) {
$val = $self->_call_builder($instance);
$value_is_set = 1;
## Slot management
# FIXME:
-# this duplicates too much code from
-# Class::MOP::Attribute, we need to
+# this duplicates too much code from
+# Class::MOP::Attribute, we need to
# refactor these bits eventually.
# - SL
sub _set_initial_slot_value {
$meta_instance->set_slot_value($instance, $slot_name, $val);
};
-
+
my $initializer = $self->initializer;
# most things will just want to set a value, so make it first arg
my $method = $self->_make_delegation_method($handle, $method_to_call);
$self->associated_class->add_method($method->name, $method);
- }
+ }
}
sub remove_delegation {
(blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
|| $self->throw_error("Unable to canonicalize the 'handles' option with $handles because its metaclass is not a Moose::Meta::Role", data => $handles);
-
+
return map { $_ => $_ } (
$role_meta->get_method_list,
$role_meta->get_required_method_list
sub initialize {
my $class = shift;
my $pkg = shift;
- return Class::MOP::get_metaclass_by_name($pkg)
+ return Class::MOP::get_metaclass_by_name($pkg)
|| $class->SUPER::initialize($pkg,
'attribute_metaclass' => 'Moose::Meta::Attribute',
'method_metaclass' => 'Moose::Meta::Method',
'instance_metaclass' => 'Moose::Meta::Instance',
@_
- );
+ );
}
sub _immutable_options {
sub create {
my ($self, $package_name, %options) = @_;
-
+
(ref $options{roles} eq 'ARRAY')
|| $self->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
if exists $options{roles};
if ($roles) {
Moose::Util::apply_all_roles( $class, @$roles );
}
-
+
return $class;
}
my ($self, %options) = @_;
my $cache_ok = delete $options{cache};
-
+
# something like Super::Class|Super::Class::2=Role|Role::1
my $cache_key = join '=' => (
join('|', @{$options{superclasses} || []}),
join('|', sort @{$options{roles} || []}),
);
-
+
if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
return $ANON_CLASSES{$cache_key};
}
-
+
my $new_class = $self->SUPER::create_anon_class(%options);
$ANON_CLASSES{$cache_key} = $new_class
my $self = shift;
$self->SUPER::add_attribute(
(blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
- ? $_[0]
- : $self->_process_attribute(@_))
+ ? $_[0]
+ : $self->_process_attribute(@_))
);
}
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
sub _inline_check_constraint {
my ($self, $value) = @_;
-
+
my $attr = $self->associated_attribute;
my $attr_name = $attr->name;
-
+
return '' unless $attr->has_type_constraint;
-
+
my $type_constraint_name = $attr->type_constraint->name;
qq{\$type_constraint->($value) || } . $self->_inline_throw_error(qq{"Attribute ($attr_name) does not pass the type constraint because: " . \$type_constraint_obj->get_message($value)}, "data => $value") . ";";
my ($self, $value) = @_;
my $attr = $self->associated_attribute;
-
+
return '' unless $attr->should_coerce;
return "$value = \$attr->type_constraint->coerce($value);";
}
my $attr = $self->associated_attribute;
my $attr_name = $attr->name;
-
+
return '' unless $attr->is_required;
return qq{(\@_ >= 2) || } . $self->_inline_throw_error(qq{"Attribute ($attr_name) is required, so cannot be set to undef"}) . ';' # defined $_[1] is not good enough
}
if ($attr->has_default || $attr->has_builder) {
if ($attr->has_default) {
$code .= ' my $default = $attr->default(' . $instance . ');'."\n";
- }
+ }
elsif ($attr->has_builder) {
$code .= ' my $default;'."\n".
' if(my $builder = '.$instance.'->can($attr->builder)){ '."\n".
$code .= $self->_inline_check_coercion('$default') . "\n";
$code .= $self->_inline_check_constraint('$default') . "\n";
$code .= ' ' . $self->_inline_init_slot($attr, $instance, $slot_access, '$default') . "\n";
- }
+ }
else {
$code .= ' ' . $self->_inline_init_slot($attr, $instance, $slot_access, 'undef') . "\n";
}
} else {
if ($attr->has_default) {
- $code .= ' ' . $self->_inline_init_slot($attr, $instance, $slot_access, ('$attr->default(' . $instance . ')')) . "\n";
- }
+ $code .= ' ' . $self->_inline_init_slot($attr, $instance, $slot_access, ('$attr->default(' . $instance . ')')) . "\n";
+ }
elsif ($attr->has_builder) {
- $code .= ' if (my $builder = '.$instance.'->can($attr->builder)) { ' . "\n"
- . ' ' . $self->_inline_init_slot($attr, $instance, $slot_access, ($instance . '->$builder'))
+ $code .= ' if (my $builder = '.$instance.'->can($attr->builder)) { ' . "\n"
+ . ' ' . $self->_inline_init_slot($attr, $instance, $slot_access, ($instance . '->$builder'))
. "\n } else {\n"
. ' ' . $self->_inline_throw_error(q{sprintf "%s does not support builder method '%s' for attribute '%s'", ref(} . $instance . ') || '.$instance.', $attr->builder, $attr->name')
. ';'. "\n }";
- }
+ }
else {
$code .= ' ' . $self->_inline_init_slot($attr, $instance, $slot_access, 'undef') . "\n";
}
}
else {
return ($slot_access . ' = ' . $value . ';');
- }
+ }
}
sub _inline_store {
my ($self, $instance, $value) = @_;
my $attr = $self->associated_attribute;
-
+
my $mi = $attr->associated_class->get_meta_instance;
-
+
my $code = $mi->inline_set_slot_value($instance, $attr->slots, $value) . ";";
$code .= $mi->inline_weaken_slot_value($instance, $attr->slots, $value) . ";"
if $attr->is_weak_ref;
sub _inline_get {
my ($self, $instance) = @_;
my $attr = $self->associated_attribute;
-
+
my $mi = $attr->associated_class->get_meta_instance;
return $mi->inline_get_slot_value($instance, $attr->slots);
sub _inline_access {
my ($self, $instance) = @_;
my $attr = $self->associated_attribute;
-
+
my $mi = $attr->associated_class->get_meta_instance;
return $mi->inline_slot_access($instance, $attr->slots);
sub _inline_has {
my ($self, $instance) = @_;
my $attr = $self->associated_attribute;
-
+
my $mi = $attr->associated_class->get_meta_instance;
return $mi->inline_is_slot_initialized($instance, $attr->slots);
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
|| $class->throw_error("You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT");
my $self = bless {
- 'body' => undef,
+ 'body' => undef,
'package_name' => $options{package_name},
'name' => $options{name},
'options' => $options{options},
$source .= "\n" . 'my $class = shift;';
$source .= "\n" . 'return $class->Moose::Object::new(@_)';
- $source .= "\n if \$class ne '" . $self->associated_metaclass->name
+ $source .= "\n if \$class ne '" . $self->associated_metaclass->name
. "';\n";
$source .= $self->_generate_params('$params', '$class');
'@type_constraint_bodies' => \@type_constraint_bodies,
},
) or $self->throw_error("Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@", error => $@, data => $source );
-
+
$self->{'body'} = $code;
}
my $default;
if ( $attr->has_default ) {
$default = $self->_generate_default_value($attr, $index);
- }
+ }
else {
my $builder = $attr->builder;
$default = '$instance->' . $builder;
}
-
+
push @source => '{'; # wrap this to avoid my $val overwrite warnings
push @source => ('my $val = ' . $default . ';');
push @source => $self->_generate_type_constraint_and_coercion($attr, $index)
- if $is_moose;
+ if $is_moose;
push @source => $self->_generate_slot_assignment($attr, '$val', $index);
- push @source => '}'; # close - wrap this to avoid my $val overrite warnings
+ push @source => '}'; # close - wrap this to avoid my $val overrite warnings
push @source => "}" if defined $attr->init_arg;
}
if ($is_moose && $attr->has_type_constraint) {
if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
push @source => $self->_generate_type_coercion(
- $attr,
- '$type_constraints[' . $index . ']',
- '$val',
+ $attr,
+ '$type_constraints[' . $index . ']',
+ '$val',
'$val'
);
}
push @source => $self->_generate_type_constraint_check(
- $attr,
- '$type_constraint_bodies[' . $index . ']',
- '$type_constraints[' . $index . ']',
+ $attr,
+ '$type_constraint_bodies[' . $index . ']',
+ '$type_constraints[' . $index . ']',
'$val'
);
}
my ($self, $attr, $value, $index) = @_;
my $source;
-
+
if ($attr->has_initializer) {
$source = (
'$attrs->[' . $index . ']->set_initial_value($instance, ' . $value . ');'
- );
+ );
}
else {
$source = (
$attr->name,
$value
) . ';'
- );
+ );
}
-
- my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
+
+ my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
if ($is_moose && $attr->is_weak_ref) {
$source .= (
sub _generate_type_constraint_and_coercion {
my ($self, $attr, $index) = @_;
-
+
return unless $attr->has_type_constraint;
-
+
my @source;
if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
push @source => $self->_generate_type_coercion(
push @source => $self->_generate_type_constraint_check(
$attr,
('$type_constraint_bodies[' . $index . ']'),
- ('$type_constraints[' . $index . ']'),
+ ('$type_constraints[' . $index . ']'),
'$val'
);
return @source;
my ($self, $attr, $type_constraint_cv, $type_constraint_obj, $value_name) = @_;
return (
$self->_inline_throw_error('"Attribute (' # FIXME add 'dad'
- . $attr->name
- . ') does not pass the type constraint because: " . '
+ . $attr->name
+ . ') does not pass the type constraint because: " . '
. $type_constraint_obj . '->get_message(' . $value_name . ')')
. "\n\t unless " . $type_constraint_cv . '->(' . $value_name . ');'
);
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
sub new {
my $class = shift;
my %options = @_;
-
+
(ref $options{options} eq 'HASH')
|| $class->throw_error("You must pass a hash of options", data => $options{options});
my $self = bless {
# from our superclass
- 'body' => undef,
+ 'body' => undef,
'package_name' => $options{package_name},
- 'name' => $options{name},
+ 'name' => $options{name},
# ...
- 'options' => $options{options},
+ 'options' => $options{options},
'associated_metaclass' => $options{metaclass},
} => $class;
- # we don't want this creating
- # a cycle in the code, if not
+ # we don't want this creating
+ # a cycle in the code, if not
# needed
- weaken($self->{'associated_metaclass'});
+ weaken($self->{'associated_metaclass'});
$self->_initialize_body;
- return $self;
+ return $self;
}
-## accessors
+## accessors
sub options { (shift)->{'options'} }
sub _initialize_body {
my $self = shift;
# TODO:
- # the %options should also include a both
- # a call 'initializer' and call 'SUPER::'
- # options, which should cover approx 90%
- # of the possible use cases (even if it
- # requires some adaption on the part of
+ # the %options should also include a both
+ # a call 'initializer' and call 'SUPER::'
+ # options, which should cover approx 90%
+ # of the possible use cases (even if it
+ # requires some adaption on the part of
# the author, after all, nothing is free)
-
+
my @DEMOLISH_methods = $self->associated_metaclass->find_all_methods_by_name('DEMOLISH');
-
+
return unless @DEMOLISH_methods;
-
+
my $source = 'sub {';
my @DEMOLISH_calls;
foreach my $method (@DEMOLISH_methods) {
- push @DEMOLISH_calls => '$_[0]->' . $method->{class} . '::DEMOLISH()';
+ push @DEMOLISH_calls => '$_[0]->' . $method->{class} . '::DEMOLISH()';
}
-
+
$source .= join ";\n" => @DEMOLISH_calls;
- $source .= ";\n" . '}';
- warn $source if $self->options->{debug};
-
+ $source .= ";\n" . '}';
+ warn $source if $self->options->{debug};
+
my $code = $self->_compile_code(
environment => {},
code => $source,
=pod
-=head1 NAME
+=head1 NAME
Moose::Meta::Method::Destructor - Method Meta Object for destructors
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.
+it under the same terms as Perl itself.
=cut
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
## I normally don't do this, but I am doing
## a whole bunch of meta-programmin in this
## module, so it just makes sense. For a clearer
-## picture of what is going on in the next
-## several lines of code, look at the really
+## picture of what is going on in the next
+## several lines of code, look at the really
## big comment at the end of this file (right
## before the POD).
## - SL
# time when it is applied to a class. This means
# keeping a lot of things in hash maps, so we are
# using a little of that meta-programmin' magic
-# here an saving lots of extra typin. And since
+# here an saving lots of extra typin. And since
# many of these attributes above require similar
# functionality to support them, so we again use
# the wonders of meta-programmin' to deliver a
get_list => 'get_required_method_list',
existence => 'requires_method',
}
- },
+ },
{
name => 'attribute_map',
attr_reader => 'get_attribute_map',
foreach my $modifier_type (qw[ before around after ]) {
my $attr_reader = "get_${modifier_type}_method_modifiers_map";
-
+
# create the attribute ...
$META->add_attribute("${modifier_type}_method_modifiers" => (
reader => $attr_reader,
default => sub { {} }
- ));
+ ));
# and some helper methods ...
$META->add_method("get_${modifier_type}_method_modifiers" => sub {
}
else {
# NOTE:
- # in 5.10 constant.pm the constants show up
+ # in 5.10 constant.pm the constants show up
# as being in the right package, but in pre-5.10
- # they show up as constant::__ANON__ so we
+ # they show up as constant::__ANON__ so we
# make an exception here to be sure that things
# work as expected in both.
# - SL
unless ($pkg eq 'constant' && $name eq '__ANON__') {
next if ($pkg || '') ne $role_name ||
(($name || '') ne '__ANON__' && ($pkg || '') ne $role_name);
- }
+ }
}
-
+
$map->{$symbol} = $method_metaclass->wrap(
$code,
package_name => $role_name,
- name => $name
+ name => $name
);
}
- return $map;
+ return $map;
}
-sub get_method {
+sub get_method {
my ($self, $name) = @_;
$self->get_method_map->{$name};
}
if ($method->package_name ne $self->name) {
$method = $method->clone(
package_name => $self->name,
- name => $method_name
+ name => $method_name
) if $method->can('clone');
}
}
(blessed($other))
|| Moose->throw_error("You must pass in an blessed instance");
-
+
if ($other->isa('Moose::Meta::Role')) {
require Moose::Meta::Role::Application::ToRole;
return Moose::Meta::Role::Application::ToRole->new(@args)->apply($self, $other);
elsif ($other->isa('Moose::Meta::Class')) {
require Moose::Meta::Role::Application::ToClass;
return Moose::Meta::Role::Application::ToClass->new(@args)->apply($self, $other);
- }
+ }
else {
require Moose::Meta::Role::Application::ToInstance;
- return Moose::Meta::Role::Application::ToInstance->new(@args)->apply($self, $other);
- }
+ return Moose::Meta::Role::Application::ToInstance->new(@args)->apply($self, $other);
+ }
}
sub combine {
my ($class, @role_specs) = @_;
-
+
require Moose::Meta::Role::Application::RoleSummation;
- require Moose::Meta::Role::Composite;
-
+ require Moose::Meta::Role::Composite;
+
my (@roles, %role_params);
while (@role_specs) {
my ($role, $params) = @{ splice @role_specs, 0, 1 };
push @roles => Class::MOP::class_of($role);
next unless defined $params;
- $role_params{$role} = $params;
+ $role_params{$role} = $params;
}
-
+
my $c = Moose::Meta::Role::Composite->new(roles => \@roles);
Moose::Meta::Role::Application::RoleSummation->new(
role_params => \%role_params
)->apply($c);
-
+
return $c;
}
#####################################################################
## NOTE:
-## This is Moose::Meta::Role as defined by Moose (plus the use of
-## MooseX::AttributeHelpers module). It is here as a reference to
+## This is Moose::Meta::Role as defined by Moose (plus the use of
+## MooseX::AttributeHelpers module). It is here as a reference to
## make it easier to see what is happening above with all the meta
## programming. - SL
#####################################################################
# 'push' => 'add_role',
# }
# );
-#
+#
# has 'excluded_roles_map' => (
# metaclass => 'Collection::Hash',
# reader => 'get_excluded_roles_map',
# 'exists' => 'excludes_role',
# }
# );
-#
+#
# has 'attribute_map' => (
# metaclass => 'Collection::Hash',
# reader => 'get_attribute_map',
-# isa => 'HashRef[Str]',
+# isa => 'HashRef[Str]',
# provides => {
# # 'set' => 'add_attribute' # has some special crap in it
# 'get' => 'get_attribute',
# 'keys' => 'get_attribute_list',
# 'exists' => 'has_attribute',
# # Not exactly delete, cause it sets multiple
-# 'delete' => 'remove_attribute',
+# 'delete' => 'remove_attribute',
# }
# );
-#
+#
# has 'required_methods' => (
# metaclass => 'Collection::Hash',
# reader => 'get_required_methods_map',
# isa => 'HashRef[Str]',
-# provides => {
-# # not exactly set, or delete since it works for multiple
+# provides => {
+# # not exactly set, or delete since it works for multiple
# 'set' => 'add_required_methods',
# 'delete' => 'remove_required_methods',
# 'keys' => 'get_required_method_list',
-# 'exists' => 'requires_method',
+# 'exists' => 'requires_method',
# }
# );
-#
-# # the before, around and after modifiers are
-# # HASH keyed by method-name, with ARRAY of
+#
+# # the before, around and after modifiers are
+# # HASH keyed by method-name, with ARRAY of
# # CODE refs to apply in that order
-#
+#
# has 'before_method_modifiers' => (
-# metaclass => 'Collection::Hash',
+# metaclass => 'Collection::Hash',
# reader => 'get_before_method_modifiers_map',
# isa => 'HashRef[ArrayRef[CodeRef]]',
# provides => {
# 'keys' => 'get_before_method_modifiers',
-# 'exists' => 'has_before_method_modifiers',
-# # This actually makes sure there is an
+# 'exists' => 'has_before_method_modifiers',
+# # This actually makes sure there is an
# # ARRAY at the given key, and pushed onto
# # it. It also checks for duplicates as well
-# # 'add' => 'add_before_method_modifier'
-# }
+# # 'add' => 'add_before_method_modifier'
+# }
# );
-#
+#
# has 'after_method_modifiers' => (
-# metaclass => 'Collection::Hash',
+# metaclass => 'Collection::Hash',
# reader =>'get_after_method_modifiers_map',
# isa => 'HashRef[ArrayRef[CodeRef]]',
# provides => {
# 'keys' => 'get_after_method_modifiers',
-# 'exists' => 'has_after_method_modifiers',
-# # This actually makes sure there is an
+# 'exists' => 'has_after_method_modifiers',
+# # This actually makes sure there is an
# # ARRAY at the given key, and pushed onto
-# # it. It also checks for duplicates as well
-# # 'add' => 'add_after_method_modifier'
-# }
+# # it. It also checks for duplicates as well
+# # 'add' => 'add_after_method_modifier'
+# }
# );
-#
+#
# has 'around_method_modifiers' => (
-# metaclass => 'Collection::Hash',
+# metaclass => 'Collection::Hash',
# reader =>'get_around_method_modifiers_map',
# isa => 'HashRef[ArrayRef[CodeRef]]',
# provides => {
# 'keys' => 'get_around_method_modifiers',
-# 'exists' => 'has_around_method_modifiers',
-# # This actually makes sure there is an
+# 'exists' => 'has_around_method_modifiers',
+# # This actually makes sure there is an
# # ARRAY at the given key, and pushed onto
-# # it. It also checks for duplicates as well
-# # 'add' => 'add_around_method_modifier'
-# }
+# # it. It also checks for duplicates as well
+# # 'add' => 'add_around_method_modifier'
+# }
# );
-#
+#
# # override is similar to the other modifiers
# # except that it is not an ARRAY of code refs
# # but instead just a single name->code mapping
-#
+#
# has 'override_method_modifiers' => (
-# metaclass => 'Collection::Hash',
+# metaclass => 'Collection::Hash',
# reader =>'get_override_method_modifiers_map',
-# isa => 'HashRef[CodeRef]',
+# isa => 'HashRef[CodeRef]',
# provides => {
# 'keys' => 'get_override_method_modifier',
-# 'exists' => 'has_override_method_modifier',
-# 'add' => 'add_override_method_modifier', # checks for local method ..
+# 'exists' => 'has_override_method_modifier',
+# 'add' => 'add_override_method_modifier', # checks for local method ..
# }
# );
-#
+#
#####################################################################
default => sub { {} }
));
-sub new {
+sub new {
my ($class, %params) = @_;
-
+
if (exists $params{excludes}) {
# I wish we had coercion here :)
- $params{excludes} = (ref $params{excludes} eq 'ARRAY'
- ? $params{excludes}
+ $params{excludes} = (ref $params{excludes} eq 'ARRAY'
+ ? $params{excludes}
: [ $params{excludes} ]);
}
-
+
$class->_new(\%params);
}
$self->check_role_exclusions(@_);
$self->check_required_methods(@_);
$self->check_required_attributes(@_);
-
+
$self->apply_attributes(@_);
- $self->apply_methods(@_);
-
+ $self->apply_methods(@_);
+
$self->apply_override_method_modifiers(@_);
-
+
$self->apply_before_method_modifiers(@_);
$self->apply_around_method_modifiers(@_);
$self->apply_after_method_modifiers(@_);
if ($self->role_params->{$role} && defined $self->role_params->{$role}->{alias}) {
return $self->role_params->{$role}->{alias};
}
- return {};
+ return {};
}
sub is_method_excluded {
sub is_aliased_method {
my ($self, $role, $method_name) = @_;
- my %aliased_names = reverse %{$self->get_method_aliases_for_role($role->name)};
+ my %aliased_names = reverse %{$self->get_method_aliases_for_role($role->name)};
exists $aliased_names{$method_name} ? 1 : 0;
}
foreach my $role (@{$c->get_roles}) {
foreach my $required (keys %all_required_methods) {
-
+
delete $all_required_methods{$required}
if $role->has_method($required)
|| $self->is_aliased_method($role, $required);
}
sub check_required_attributes {
-
+
}
sub apply_attributes {
my ($self, $c) = @_;
-
+
my @all_attributes = map {
my $role = $_;
- map {
- +{
+ map {
+ +{
name => $_,
attr => $role->get_attribute($_),
}
} $role->get_attribute_list
} @{$c->get_roles};
-
+
my %seen;
foreach my $attr (@all_attributes) {
if (exists $seen{$attr->{name}}) {
if ( $seen{$attr->{name}} != $attr->{attr} ) {
require Moose;
- Moose->throw_error("We have encountered an attribute conflict with '" . $attr->{name} . "' "
+ Moose->throw_error("We have encountered an attribute conflict with '" . $attr->{name} . "' "
. "during composition. This is fatal error and cannot be disambiguated.")
}
}
$seen{$attr->{name}} = $attr->{attr};
}
- foreach my $attr (@all_attributes) {
+ foreach my $attr (@all_attributes) {
$c->add_attribute($attr->{name}, $attr->{attr});
}
}
sub apply_methods {
my ($self, $c) = @_;
-
+
my @all_methods = map {
my $role = $_;
my $aliases = $self->get_method_aliases_for_role($role);
my %excludes = map { $_ => undef } @{ $self->get_exclusions_for_role($role) };
(
- (map {
+ (map {
exists $excludes{$_} ? () :
- +{
+ +{
role => $role,
name => $_,
method => $role->get_method($_),
}
} $role->get_method_list),
- (map {
- +{
+ (map {
+ +{
role => $role,
name => $aliases->{$_},
method => $role->get_method($_),
- }
+ }
} keys %$aliases)
);
} @{$c->get_roles};
-
+
my (%seen, %method_map);
foreach my $method (@all_methods) {
if (exists $seen{$method->{name}}) {
$c->add_required_methods($method->{name});
delete $method_map{$method->{name}};
next;
- }
- }
-
+ }
+ }
+
$seen{$method->{name}} = $method->{method};
$method_map{$method->{name}} = $method->{method};
}
sub apply_override_method_modifiers {
my ($self, $c) = @_;
-
+
my @all_overrides = map {
my $role = $_;
- map {
- +{
+ map {
+ +{
name => $_,
method => $role->get_override_method_modifier($_),
}
} $role->get_method_modifier_list('override');
} @{$c->get_roles};
-
+
my %seen;
foreach my $override (@all_overrides) {
if ( $c->has_method($override->{name}) ){
}
$seen{$override->{name}} = $override->{method};
}
-
+
$c->add_override_method_modifier(
$_->{name}, $_->{method}
) for @all_overrides;
-
+
}
sub apply_method_modifiers {
=head1 DESCRIPTION
-Summation composes two traits, forming the union of non-conflicting
+Summation composes two traits, forming the union of non-conflicting
bindings and 'disabling' the conflicting bindings
=head2 METHODS
use base 'Moose::Meta::Role::Application';
sub apply {
- my ($self, $role, $class) = @_;
+ my ($self, $role, $class) = @_;
$self->SUPER::apply($role, $class);
- $class->add_role($role);
+ $class->add_role($role);
}
sub check_role_exclusions {
foreach my $required_method_name ($role->get_required_method_list) {
if (!$class->find_method_by_name($required_method_name)) {
-
+
next if $self->is_aliased_method($required_method_name);
push @missing, $required_method_name;
}
sub check_required_attributes {
-
+
}
sub apply_attributes {
sub apply_methods {
my ($self, $role, $class) = @_;
foreach my $method_name ($role->get_method_list) {
-
+
unless ($self->is_method_excluded($method_name)) {
# it if it has one already
if ($class->has_method($method_name) &&
$class->add_method(
$method_name,
$role->get_method($method_name)
- );
+ );
}
}
-
+
if ($self->is_method_aliased($method_name)) {
my $aliased_method_name = $self->get_method_aliases->{$method_name};
# it if it has one already
# and if they are not the same thing ...
$class->get_method($aliased_method_name)->body != $role->get_method($method_name)->body) {
$class->throw_error("Cannot create a method alias if a local method of the same name exists");
- }
+ }
$class->add_method(
$aliased_method_name,
$role->get_method($method_name)
- );
- }
+ );
+ }
}
# we must reset the cache here since
# we are just aliasing methods, otherwise
# the modifiers go wonky.
- $class->reset_package_cache_flag;
+ $class->reset_package_cache_flag;
}
sub apply_override_method_modifiers {
use base 'Moose::Meta::Role::Application';
sub apply {
- my ($self, $role1, $role2) = @_;
- $self->SUPER::apply($role1, $role2);
- $role2->add_role($role1);
+ my ($self, $role1, $role2) = @_;
+ $self->SUPER::apply($role1, $role2);
+ $role2->add_role($role1);
}
sub check_role_exclusions {
sub check_required_methods {
my ($self, $role1, $role2) = @_;
foreach my $required_method_name ($role1->get_required_method_list) {
-
+
next if $self->is_aliased_method($required_method_name);
-
+
$role2->add_required_methods($required_method_name)
unless $role2->find_method_by_name($required_method_name);
}
}
sub check_required_attributes {
-
+
}
sub apply_attributes {
}
next;
- }
-
- next if $self->is_method_excluded($method_name);
-
+ }
+
+ next if $self->is_method_excluded($method_name);
+
# it if it has one already
if ($role2->has_method($method_name) &&
# and if they are not the same thing ...
$method_name,
$role1->get_method($method_name)
);
-
+
}
-
+
}
}
use base 'Moose::Meta::Role';
# NOTE:
-# we need to override the ->name
+# we need to override the ->name
# method from Class::MOP::Package
-# since we don't have an actual
+# since we don't have an actual
# package for this.
# - SL
__PACKAGE__->meta->add_attribute('name' => (reader => 'name'));
# NOTE:
-# Again, since we don't have a real
-# package to store our methods in,
-# we use a HASH ref instead.
+# Again, since we don't have a real
+# package to store our methods in,
+# we use a HASH ref instead.
# - SL
__PACKAGE__->meta->add_attribute('methods' => (
reader => 'get_method_map',
if ($method->package_name ne $self->name) {
$method = $method->clone(
package_name => $self->name,
- name => $method_name
+ name => $method_name
) if $method->can('clone');
}
}
=head1 DESCRIPTION
-This is primarily used to mark methods coming from a role
+This is primarily used to mark methods coming from a role
as being different. Right now it is nothing but a subclass
of L<Moose::Meta::Method>.
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
accessor => '_compiled_type_coercion'
));
-sub new {
+sub new {
my $class = shift;
my $self = Class::MOP::class_of($class)->new_object(@_);
$self->compile_type_coercion;
Moose->throw_error("Could not find the type constraint ($constraint_name) to coerce from");
}
- push @coercions => [
- $type_constraint->_compiled_type_constraint,
- $action
+ push @coercions => [
+ $type_constraint->_compiled_type_constraint,
+ $action
];
}
- $self->_compiled_type_coercion(sub {
+ $self->_compiled_type_coercion(sub {
my $thing = shift;
foreach my $coercion (@coercions) {
my ($constraint, $converter) = @$coercion;
if ($constraint->($thing)) {
- local $_ = $thing;
+ local $_ = $thing;
return $converter->($thing);
}
}
return $thing;
- });
+ });
}
sub has_coercion_for_type {
sub add_type_coercions {
my ($self, @new_coercion_map) = @_;
-
- my $coercion_map = $self->type_coercion_map;
+
+ my $coercion_map = $self->type_coercion_map;
my %has_coercion = @$coercion_map;
-
+
while (@new_coercion_map) {
- my ($constraint_name, $action) = splice(@new_coercion_map, 0, 2);
+ my ($constraint_name, $action) = splice(@new_coercion_map, 0, 2);
if ( exists $has_coercion{$constraint_name} ) {
require Moose;
push @{$coercion_map} => ($constraint_name, $action);
}
-
+
# and re-compile ...
$self->compile_type_coercion;
}
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
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.
+it under the same terms as Perl itself.
=cut
sub compile_type_coercion {
my $self = shift;
my $type_constraint = $self->type_constraint;
-
+
(blessed $type_constraint && $type_constraint->isa('Moose::Meta::TypeConstraint::Union'))
|| Moose->throw_error("You can only a Moose::Meta::TypeCoercion::Union for a " .
"Moose::Meta::TypeConstraint::Union, not a $type_constraint");
-
+
$self->_compiled_type_coercion(sub {
my $value = shift;
- # go through all the type constraints
+ # go through all the type constraints
# in the union, and check em ...
foreach my $type (@{$type_constraint->type_constraints}) {
# if they have a coercion first
- if ($type->has_coercion) {
+ if ($type->has_coercion) {
# then try to coerce them ...
my $temp = $type->coerce($value);
- # and if they get something
+ # and if they get something
# make sure it still fits within
# the union type ...
return $temp if $type_constraint->check($temp);
}
}
- return undef;
+ return undef;
});
}
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
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.
+it under the same terms as Perl itself.
=cut
return $msg->($value);
}
else {
- $value = (defined $value ? overload::StrVal($value) : 'undef');
+ $value = (defined $value ? overload::StrVal($value) : 'undef');
return "Validation failed for '" . $self->name . "' failed with value $value";
- }
+ }
}
## type predicates ...
my $self = shift;
my $class = $self->class;
$self->hand_optimized_type_constraint(
- sub {
- blessed( $_[0] ) && $_[0]->isa($class)
+ sub {
+ blessed( $_[0] ) && $_[0]->isa($class)
}
);
}
# if anybody thinks this problematic please discuss on IRC.
# a possible fix is to add by attr indexing to the type registry to find types of a certain property
# regardless of their name
- Moose::Util::TypeConstraints::find_type_constraint($_)
- ||
+ Moose::Util::TypeConstraints::find_type_constraint($_)
+ ||
__PACKAGE__->new( class => $_, name => "__ANON__" )
} Class::MOP::class_of($self->class)->superclasses,
);
}
my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name_or_class);
-
+
return unless defined $type;
if ( $type->isa(__PACKAGE__) ) {
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
sub generate_constraint_for {
my ($self, $type) = @_;
-
+
return unless $self->has_constraint_generator;
-
+
return $self->constraint_generator->($type->type_parameter)
if $type->is_subtype_of($self->name);
-
+
return $self->_can_coerce_constraint_from($type)
if $self->has_coercion
&& $self->coercion->has_coercion_for_type($type->parent->name);
-
+
return;
}
my ($self, $type_parameter) = @_;
my $contained_tc = $self->_parse_type_parameter($type_parameter);
-
+
## The type parameter should be a subtype of the parent's type parameter
## if there is one.
-
+
if(my $parent = $self->parent) {
if($parent->can('type_parameter')) {
unless ( $contained_tc->is_a_type_of($parent->type_parameter) ) {
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
return unless $other->isa(__PACKAGE__);
-
+
return (
$self->type_parameter->equals( $other->type_parameter )
and
sub compile_type_constraint {
my $self = shift;
-
+
unless ( $self->has_type_parameter ) {
require Moose;
Moose->throw_error("You cannot create a Higher Order type without a type parameter");
}
my $type_parameter = $self->type_parameter;
-
+
unless ( blessed $type_parameter && $type_parameter->isa('Moose::Meta::TypeConstraint') ) {
require Moose;
Moose->throw_error("The type parameter must be a Moose meta type");
foreach my $type (Moose::Util::TypeConstraints::get_all_parameterizable_types()) {
if (my $constraint = $type->generate_constraint_for($self)) {
$self->_set_constraint($constraint);
- return $self->SUPER::compile_type_constraint;
+ return $self->SUPER::compile_type_constraint;
}
}
-
- # if we get here, then we couldn't
+
+ # if we get here, then we couldn't
# find a way to parameterize this type
require Moose;
- Moose->throw_error("The " . $self->name . " constraint cannot be used, because "
+ Moose->throw_error("The " . $self->name . " constraint cannot be used, because "
. $self->parent->name . " doesn't subtype or coerce from a parameterizable type.");
}
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
__PACKAGE__->meta->add_attribute('parent_registry' => (
reader => 'get_parent_registry',
- writer => 'set_parent_registry',
- predicate => 'has_parent_registry',
+ writer => 'set_parent_registry',
+ predicate => 'has_parent_registry',
));
__PACKAGE__->meta->add_attribute('type_constraints' => (
default => sub { {} }
));
-sub new {
+sub new {
my $class = shift;
my $self = $class->_new(@_);
return $self;
sub get_type_constraint {
my ($self, $type_name) = @_;
- return unless defined $type_name;
+ return unless defined $type_name;
$self->type_constraints->{$type_name}
}
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
# if anybody thinks this problematic please discuss on IRC.
# a possible fix is to add by attr indexing to the type registry to find types of a certain property
# regardless of their name
- Moose::Util::TypeConstraints::find_type_constraint($_)
- ||
+ Moose::Util::TypeConstraints::find_type_constraint($_)
+ ||
__PACKAGE__->new( role => $_, name => "__ANON__" )
} @{ Class::MOP::class_of($self->role)->get_roles },
);
my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name_or_role);
return unless defined $type;
-
+
if ( $type->isa(__PACKAGE__) ) {
# if $type_or_name_or_role isn't a role, it might be the TC name of another ::Role type
# or it could also just be a type object in this branch
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
default => sub { [] }
));
-sub new {
+sub new {
my ($class, %options) = @_;
my $name = join '|' => sort { $a cmp $b }
$message .= ($message ? ' and ' : '') . $err
if defined $err;
}
- return ($message . ' in (' . $self->name . ')') ;
+ return ($message . ' in (' . $self->name . ')') ;
}
sub is_a_type_of {
foreach my $type (@{$self->type_constraints}) {
return 1 if $type->is_a_type_of($type_name);
}
- return 0;
+ return 0;
}
sub is_subtype_of {
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
}
sub BUILDALL {
- # NOTE: we ask Perl if we even
+ # NOTE: we ask Perl if we even
# need to do this first, to avoid
# extra meta level calls
- return unless $_[0]->can('BUILD');
+ return unless $_[0]->can('BUILD');
my ($self, $params) = @_;
foreach my $method (reverse Class::MOP::class_of($self)->find_all_methods_by_name('BUILD')) {
$method->{code}->execute($self, $params);
}
}
-sub DESTROY {
+sub DESTROY {
# if we have an exception here ...
if ($@) {
# localize the $@ ...
}';
}
-# new does() methods will be created
+# new does() methods will be created
# as appropiate see Moose::Meta::Role
sub does {
my ($self, $role_name) = @_;
|| $meta->throw_error("You much supply a role name to does()");
foreach my $class ($meta->class_precedence_list) {
my $m = $meta->initialize($class);
- return 1
- if $m->can('does_role') && $m->does_role($role_name);
+ return 1
+ if $m->can('does_role') && $m->does_role($role_name);
}
- return 0;
+ return 0;
}
-sub dump {
+sub dump {
my $self = shift;
require Data::Dumper;
local $Data::Dumper::Maxdepth = shift if @_;
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
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.
+it under the same terms as Perl itself.
=cut
=item Excluded Roles
-A role can have a list of excluded roles, these are basically
-roles that they shouldn't be composed with. This is not just
-direct composition either, but also "inherited" composition.
+A role can have a list of excluded roles, these are basically
+roles that they shouldn't be composed with. This is not just
+direct composition either, but also "inherited" composition.
-This feature was taken from the Fortress language and is really
+This feature was taken from the Fortress language and is really
of most use when building a large set of role "building blocks"
some of which should never be used together.
=item Attributes
-A roles attributes are similar to those of a class, except that
+A roles attributes are similar to those of a class, except that
they are not actually applied. This means that methods that are
generated by an attributes accessor will not be generated in the
role, but only created once the role is applied to a class.
=item Required Methods
-A role can require a consuming class (or role) to provide a
-given method. Failure to do so for classes is a fatal error,
-while for roles it simply passes on the method requirement to
+A role can require a consuming class (or role) to provide a
+given method. Failure to do so for classes is a fatal error,
+while for roles it simply passes on the method requirement to
the consuming role.
=item Required Attributes
Just as a role can require methods, it can also require attributes.
-The requirement fulfilling attribute must implement at least as much
+The requirement fulfilling attribute must implement at least as much
as is required. That means, for instance, that if the role requires
that the attribute be read-only, then it must at least have a reader
-and can also have a writer. It means that if the role requires that
-the attribute be an ArrayRef, then it must either be an ArrayRef or
+and can also have a writer. It means that if the role requires that
+the attribute be an ArrayRef, then it must either be an ArrayRef or
a subtype of an ArrayRef.
=item Overridden Methods
-The C<override> and C<super> keywords are allowed in roles, but
-their behavior is different from that of it's class counterparts.
-The C<super> in a class refers directly to that class's superclass,
+The C<override> and C<super> keywords are allowed in roles, but
+their behavior is different from that of it's class counterparts.
+The C<super> in a class refers directly to that class's superclass,
while the C<super> in a role is deferred and only has meaning once
-the role is composed into a class. Once that composition occurs,
-C<super> then refers to that class's superclass.
+the role is composed into a class. Once that composition occurs,
+C<super> then refers to that class's superclass.
-It is key to remember that roles do not have hierarchy, so they
+It is key to remember that roles do not have hierarchy, so they
can never have a I<super> role.
=item Method Modifiers
-These are the C<before>, C<around> and C<after> modifiers provided
-in Moose classes. The difference here is that the modifiers are not
-actually applied until the role is composed into a class (this is
+These are the C<before>, C<around> and C<after> modifiers provided
+in Moose classes. The difference here is that the modifiers are not
+actually applied until the role is composed into a class (this is
just like attributes and the C<override> keyword).
=back
=head3 Composing into a Instance
-=head3 Composing into a Role
+=head3 Composing into a Role
=over 4
=head3 Role Summation
-When multiple roles are added to another role (using the
-C<with @roles> keyword) the roles are composed symmetrically.
-The product of the composition is a composite role
+When multiple roles are added to another role (using the
+C<with @roles> keyword) the roles are composed symmetrically.
+The product of the composition is a composite role
(L<Moose::Meta::Role::Composite>).
=over 4
=item Attributes
Attributes with the same name will conflict and are considered
-a unrecoverable error. No other aspect of the attribute is
-examined, it is enough that just the attribute names conflict.
+a unrecoverable error. No other aspect of the attribute is
+examined, it is enough that just the attribute names conflict.
-The reason for such early and harsh conflicts with attributes
-is because there is so much room for variance between two
-attributes that the problem quickly explodes and rules get
-very complex. It is my opinion that this complexity is not
+The reason for such early and harsh conflicts with attributes
+is because there is so much room for variance between two
+attributes that the problem quickly explodes and rules get
+very complex. It is my opinion that this complexity is not
worth the trouble.
=item Methods
-Methods with the same name will conflict, but no error is
-thrown, instead the method name is added to the list of
+Methods with the same name will conflict, but no error is
+thrown, instead the method name is added to the list of
I<required> methods for the new composite role.
-To look at this in terms of set theory, each role can be
-said to have a set of methods. The symmetric difference of
-these two sets is the new set of methods for the composite
-role, while the intersection of these two sets are the
+To look at this in terms of set theory, each role can be
+said to have a set of methods. The symmetric difference of
+these two sets is the new set of methods for the composite
+role, while the intersection of these two sets are the
conflicts. This can be illustrated like so:
Role A has method set { a, b, c }
Role B has method set { c, d, e }
-
- The composite role (A,B) has
+
+ The composite role (A,B) has
method set { a, b, d, e }
conflict set { c }
=item Overridden methods
-An overridden method can conflict in one of two ways.
+An overridden method can conflict in one of two ways.
-The first way is with another overridden method of the same
-name, and this is considered an unrecoverable error. This
+The first way is with another overridden method of the same
+name, and this is considered an unrecoverable error. This
is an obvious error since you cannot override a method twice
-in the same class.
+in the same class.
-The second way for conflict is for an overridden method and a
-regular method to have the same name. This is also an unrecoverable
-error since there is no way to combine these two, nor is it
-okay for both items to be composed into a single class at some
-point.
+The second way for conflict is for an overridden method and a
+regular method to have the same name. This is also an unrecoverable
+error since there is no way to combine these two, nor is it
+okay for both items to be composed into a single class at some
+point.
The use of override in roles can be tricky, but if used
carefully they can be a very powerful tool.
=item Method Modifiers (before, around, after)
-Method modifiers are the only place where the ordering of
-role composition matters. This is due to the nature of
-method modifiers themselves.
+Method modifiers are the only place where the ordering of
+role composition matters. This is due to the nature of
+method modifiers themselves.
-Since a method can have multiple method modifiers, these
-are just collected in order to be later applied to the
+Since a method can have multiple method modifiers, these
+are just collected in order to be later applied to the
class in that same order.
-In general, great care should be taken in using method
-modifiers in roles. The order sensitivity can possibly
-lead to subtle and difficult to find bugs if they are
-overused. As with all good things in life, moderation
+In general, great care should be taken in using method
+modifiers in roles. The order sensitivity can possibly
+lead to subtle and difficult to find bugs if they are
+overused. As with all good things in life, moderation
is the key.
=back
=head3 Composition Edge Cases
-This is a just a set of complex edge cases which can easily get
-confused. This attempts to clarify those cases and provide an
+This is a just a set of complex edge cases which can easily get
+confused. This attempts to clarify those cases and provide an
explanation of what is going on in them.
=over 4
Many people want to "override" methods in roles they are consuming.
This works fine for classes, since the local class method is favored
-over the role method. However in roles it is trickier, this is because
-conflicts result in neither method being chosen and the method being
-"required" instead.
+over the role method. However in roles it is trickier, this is because
+conflicts result in neither method being chosen and the method being
+"required" instead.
Here is an example of this (incorrect) type of overriding.
sub foo { ... }
sub bar { ... }
-Here the C<foo> methods conflict and the Role::FooBar now requires a
+Here the C<foo> methods conflict and the Role::FooBar now requires a
class or role consuming it to implement C<foo>. This is very often not
what the user wants.
use Moose::Role;
with 'Role::Foo', 'Role::Bar';
-
+
sub foo { ... }
This works because the combination of Role::Foo and Role::Bar produce
-a conflict with the C<foo> method. This conflict results in the
-composite role (that was created by the combination of Role::Foo
-and Role::Bar using the I<with> keyword) having a method requirement
-of C<foo>. The Role::FooBar then fulfills this requirement.
+a conflict with the C<foo> method. This conflict results in the
+composite role (that was created by the combination of Role::Foo
+and Role::Bar using the I<with> keyword) having a method requirement
+of C<foo>. The Role::FooBar then fulfills this requirement.
-It is important to note that Role::FooBar is simply fulfilling the
-required C<foo> method, and **NOT** overriding C<foo>. This is an
+It is important to note that Role::FooBar is simply fulfilling the
+required C<foo> method, and **NOT** overriding C<foo>. This is an
important distinction to make.
-Now here is another example of a (correct) type of overriding, this
+Now here is another example of a (correct) type of overriding, this
time using the I<excludes> option.
package Role::Foo;
use Moose::Role;
-
+
sub foo { ... }
-
+
package Role::FooBar;
use Moose::Role;
-
+
with 'Role::Foo' => { excludes => 'foo' };
-
+
sub foo { ... }
sub bar { ... }
-By specifically excluding the C<foo> method during composition,
+By specifically excluding the C<foo> method during composition,
we allow B<Role::FooBar> to define it's own version of C<foo>.
=back
=item Traits
-Roles are based on Traits, which originated in the Smalltalk
-community.
+Roles are based on Traits, which originated in the Smalltalk
+community.
-=over 4
+=over 4
=item L<http://www.iam.unibe.ch/~scg/Research/Traits/>
=item L<Class::Trait>
-I created this implementation of traits several years ago,
-after reading the papers linked above. (This module is now
+I created this implementation of traits several years ago,
+after reading the papers linked above. (This module is now
maintained by Ovid and I am no longer involved with it).
=back
=item Roles
-Since they are relatively new, and the Moose implementation
+Since they are relatively new, and the Moose implementation
is probably the most mature out there, roles don't have much
to link to. However, here is some bits worth looking at (mostly
related to Perl 6)
=item L<http://www.oreillynet.com/onlamp/blog/2006/08/roles_composable_units_of_obje.html>
-This is chromatic's take on roles, which is worth reading since
+This is chromatic's take on roles, which is worth reading since
he was/is one of the big proponents of them.
=item L<http://svn.perl.org/perl6/doc/trunk/design/syn/S12.pod>
our $AUTHORITY = 'cpan:STEVAN';
my @exports = qw[
- find_meta
+ find_meta
does_role
- search_class_by_role
+ search_class_by_role
ensure_all_roles
apply_all_roles
get_all_init_args
my ($class_or_obj, $role) = @_;
my $meta = find_meta($class_or_obj);
-
+
return unless defined $meta;
return unless $meta->can('does_role');
return 1 if $meta->does_role($role);
sub search_class_by_role {
my ($class_or_obj, $role_name) = @_;
-
+
my $meta = find_meta($class_or_obj);
return unless defined $meta;
foreach my $class ($meta->class_precedence_list) {
-
- my $_meta = find_meta($class);
+
+ my $_meta = find_meta($class);
next unless defined $_meta;
return +{
map { $_->init_arg => $_->get_value($instance) }
grep { $_->has_value($instance) }
- grep { defined($_->init_arg) }
+ grep { defined($_->init_arg) }
$class->get_all_attributes
};
}
if $cache{$cache_key}{$metaclass_name};
my $possible_full_name
- = 'Moose::Meta::'
+ = 'Moose::Meta::'
. $type
. '::Custom::'
. ( $options{trait} ? "Trait::" : "" )
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
=head1 DESCRIPTION
-This file contains the hand optimized versions of Moose type constraints,
+This file contains the hand optimized versions of Moose type constraints,
no user serviceable parts inside.
=head1 FUNCTIONS
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
my @exports = qw[
meta_ok
- does_ok
+ does_ok
has_attribute_ok
];
sub meta_ok ($;$) {
my ($class_or_obj, $message) = @_;
-
+
$message ||= "The object has a meta";
-
+
if (find_meta($class_or_obj)) {
return $Test->ok(1, $message)
}
else {
- return $Test->ok(0, $message);
+ return $Test->ok(0, $message);
}
}
sub does_ok ($$;$) {
my ($class_or_obj, $does, $message) = @_;
-
+
$message ||= "The object does $does";
-
+
if (does_role($class_or_obj, $does)) {
return $Test->ok(1, $message)
}
else {
- return $Test->ok(0, $message);
+ return $Test->ok(0, $message);
}
}
sub has_attribute_ok ($$;$) {
my ($class_or_obj, $attr_name, $message) = @_;
-
+
$message ||= "The object does has an attribute named $attr_name";
-
- my $meta = find_meta($class_or_obj);
-
+
+ my $meta = find_meta($class_or_obj);
+
if ($meta->find_attribute_by_name($attr_name)) {
return $Test->ok(1, $message)
}
else {
- return $Test->ok(0, $message);
- }
+ return $Test->ok(0, $message);
+ }
}
1;
=head1 SYNOPSIS
use Test::More plan => 1;
- use Test::Moose;
+ use Test::Moose;
meta_ok($class_or_obj, "... Foo has a ->meta");
does_ok($class_or_obj, $role, "... Foo does the Baz role");
=head1 DESCRIPTION
-This module provides some useful test functions for Moose based classes. It
+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
=item B<does_ok ($class_or_object, $role, ?$message)>
-Tests if a class or object does a certain role, similar to what C<isa_ok>
+Tests if a class or object does a certain role, similar to what C<isa_ok>
does for the C<isa> method.
=item B<has_attribute_ok($class_or_object, $attr_name, ?$message)>
-Tests if a class or object has a certain attribute, similar to what C<can_ok>
+Tests if a class or object has a certain attribute, similar to what C<can_ok>
does for the methods.
=back
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
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.
+it under the same terms as Perl itself.
=cut
BEGIN {
my $package;
- sub import {
+ sub import {
$package = $_[1] || 'Class';
if ($package =~ /^\+/) {
$package =~ s/^\+//;
# create a Moose class on the fly ...
perl -Moose=Foo -e 'has bar => ( is=>q[ro], default => q[baz] ); print Foo->new->bar' # prints baz
-
+
# loads an existing class (Moose or non-Moose)
# and re-"opens" the package definition to make
# debugging/introspection easier
- perl -Moose=+My::Class -e 'print join ", " => __PACKAGE__->meta->get_method_list'
+ perl -Moose=+My::Class -e 'print join ", " => __PACKAGE__->meta->get_method_list'
=head1 DESCRIPTION
-oose.pm is a simple source filter that adds C<package $name; use Moose;>
-to the beginning of your script and was entirely created because typing
+oose.pm is a simple source filter that adds C<package $name; use Moose;>
+to the beginning of your script and was entirely created because typing
C<perl -e'package Foo; use Moose; ...'> was annoying me.
-=head1 INTERFACE
+=head1 INTERFACE
oose provides exactly one method and it's automatically called by perl:
ok(Foo->isa('Moose::Object'), '... Foo is automagically a Moose::Object');
dies_ok {
- Foo->meta->has_method()
+ Foo->meta->has_method()
} '... has_method requires an arg';
dies_ok {
- Foo->meta->has_method('')
+ Foo->meta->has_method('')
} '... has_method requires an arg';
can_ok('Foo', 'does');
foreach my $function (qw(
extends
- has
+ has
before after around
blessed confess
type subtype as where
{
package Bar;
use Moose;
-
+
eval { extends 'Foo'; };
::ok(!$@, '... loaded Foo superclass correctly');
}
{
package Baz;
use Moose;
-
+
eval { extends 'Bar'; };
::ok(!$@, '... loaded (inline) Bar superclass correctly');
}
{
package Foo::Bar;
use Moose;
-
+
eval { extends 'Foo', 'Bar'; };
::ok(!$@, '... loaded Foo and (inline) Bar superclass correctly');
}
{
package Bling;
use Moose;
-
+
eval { extends 'No::Class'; };
::ok($@, '... could not find the superclass (as expected)');
::like($@, qr/^Could not load class \(No\:\:Class\) because \:/, '... and got the error we expected');
{
package Foo;
use Moose;
-
+
sub foo { 'Foo::foo' }
- sub bar { 'Foo::bar' }
+ sub bar { 'Foo::bar' }
sub baz { 'Foo::baz' }
-
+
package Bar;
use Moose;
-
+
extends 'Foo';
-
- override bar => sub { 'Bar::bar -> ' . super() };
-
+
+ override bar => sub { 'Bar::bar -> ' . super() };
+
package Baz;
use Moose;
-
+
extends 'Bar';
-
- override bar => sub { 'Baz::bar -> ' . super() };
- override baz => sub { 'Baz::baz -> ' . super() };
+
+ override bar => sub { 'Baz::bar -> ' . super() };
+ override baz => sub { 'Baz::baz -> ' . super() };
no Moose; # ensure super() still works after unimport
}
{
package Bling;
use Moose;
-
+
sub bling { 'Bling::bling' }
-
+
package Bling::Bling;
use Moose;
-
+
extends 'Bling';
-
- sub bling { 'Bling::bling' }
-
+
+ sub bling { 'Bling::bling' }
+
::dies_ok {
override 'bling' => sub {};
} '... cannot override a method which has a local equivalent';
-
+
}
{
package Foo;
use Moose;
-
+
sub foo { 'Foo::foo(' . (inner() || '') . ')' }
- sub bar { 'Foo::bar(' . (inner() || '') . ')' }
- sub baz { 'Foo::baz(' . (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' };
+
+ 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,
+ 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' };
+ augment bar => sub { 'Baz::bar' };
}
my $baz = Baz->new();
{
package Bling;
use Moose;
-
+
sub bling { 'Bling::bling' }
-
+
package Bling::Bling;
use Moose;
-
+
extends 'Bling';
-
- sub bling { 'Bling::bling' }
-
+
+ sub bling { 'Bling::bling' }
+
::dies_ok {
augment 'bling' => sub {};
} '... cannot augment a method which has a local equivalent';
-
+
}
{
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() };
-
+ override 'bar' => sub { 'Bar::bar -> ' . super() };
+
package Baz;
use Moose;
-
+
extends 'Bar';
-
+
override 'foo' => sub { 'Baz::foo -> ' . super() };
augment 'bar' => sub { 'Baz::bar' };
}
=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
+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)',
+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
+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 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)',
+is($baz->bar,
+ 'Bar::bar -> Foo::bar(Baz::bar)',
'... got the right value from mixed augment/override bar');
=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
+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.
+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 bar { 'Foo::bar' }
sub baz { 'Foo::baz' }
-
+
package Bar;
use Moose;
-
+
extends 'Foo';
-
- override bar => sub { 'Bar::bar -> ' . super() };
-
+
+ override bar => sub { 'Bar::bar -> ' . super() };
+
package Baz;
use Moose;
-
+
extends 'Bar';
-
- override bar => sub { 'Baz::bar -> ' . super() };
- override baz => sub { 'Baz::baz -> ' . super() };
+
+ override bar => sub { 'Baz::bar -> ' . super() };
+ override baz => sub { 'Baz::baz -> ' . super() };
}
my $baz = Baz->new();
{
package Foo;
use Moose;
-
+
eval '$foo = 5;';
::ok($@, '... got an error because strict is on');
::like($@, qr/Global symbol \"\$foo\" requires explicit package name at/, '... 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');
}
{
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 at/, '... 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');
}
after qw/scalar_or_array void/ => sub {
my $self = shift;
- $self->inc;
+ $self->inc;
}
}
my @moose_exports = qw(
- extends with
- has
+ extends with
+ has
before after around
override
augment
# and check the type constraints as well
my @moose_type_constraint_exports = qw(
- type subtype as where message
- coerce from via
+ type subtype as where message
+ coerce from via
enum
find_type_constraint
);
::dies_ok {
around qr/bark.*/ => sub {};
- } '... this is not currently supported';
-
- ::dies_ok {
+ } '... this is not currently supported';
+
+ ::dies_ok {
after qr/bark.*/ => sub {};
- } '... this is not currently supported';
+ } '... this is not currently supported';
}
=pod
-This tests demonstrates that Moose will not override
-a preexisting type constraint of the same name when
+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
-it's isa option will get the subtype Foo, and not a
+it's isa option will get the subtype Foo, and not a
type representing the Foo moose class.
=cut
-BEGIN {
+BEGIN {
# create this subtype first (in BEGIN)
- subtype Foo
- => as 'Value'
+ subtype Foo
+ => as 'Value'
=> where { $_ eq 'Foo' };
}
{
package Bar;
use Moose;
-
+
has 'foo' => (is => 'rw', isa => 'Foo');
}
isa_ok($bar, 'Bar');
lives_ok {
- $bar->foo('Foo');
+ $bar->foo('Foo');
} '... checked the type constraint correctly';
dies_ok {
- $bar->foo(Foo->new);
+ $bar->foo(Foo->new);
} '... checked the type constraint correctly';
lives_ok { $foo->type_constrained(10.5) } "Num type constraint for now..";
# try to rebless, except it will fail due to Child's stricter type constraint
-throws_ok { Child->meta->rebless_instance($foo) }
+throws_ok { Child->meta->rebless_instance($foo) }
qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' failed with value 10\.5/,
'... this failed cause of type check';
-throws_ok { Child->meta->rebless_instance($bar) }
+throws_ok { Child->meta->rebless_instance($bar) }
qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' failed with value 5\.5/,
'... this failed cause of type check';;
is($foo->lazy_classname, 'Parent', "lazy attribute was already initialized");
is($bar->lazy_classname, 'Child', "lazy attribute just now initialized");
-throws_ok { $foo->type_constrained(10.5) }
+throws_ok { $foo->type_constrained(10.5) }
qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' failed with value 10\.5/,
'... this failed cause of type check';
use Test::More tests => 7;
use Test::Exception;
-{
+{
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 }
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 }
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';
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'],
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;
}
use Moose;
has bar => ( is => "rw" );
- has baz => ( is => "rw" );
+ has baz => ( is => "rw" );
sub BUILDARGS {
my ( $self, @args ) = @_;
my $o = $class->new(42, baz => 47);
is($o->bar, 42, '... got the right bar');
is($o->baz, 47, '... got the right bar');
- }
+ }
}
{
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,
+ reader => 'get_lazy_foo',
+ lazy => 1,
default => sub { 10 }
);
};
- ::ok(!$@, '... created the lazy reader method okay') or warn $@;
+ ::ok(!$@, '... created the lazy reader method okay') or warn $@;
}
{
dies_ok {
$foo->get_foo(100);
} '... 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');
dies_ok {
$foo->get_lazy_foo(100);
- } '... get_lazy_foo is a read-only';
+ } '... get_lazy_foo is a read-only';
}
{
isa_ok($foo, 'Foo');
is($foo->get_foo(), 10, '... got the correct value');
- is($foo->get_lazy_foo(), 100, '... got the correct value');
+ is($foo->get_lazy_foo(), 100, '... got the correct value');
}
{
package Foo;
use Moose;
-
+
eval {
has 'foo' => (
reader => 'get_foo',
isa => 'Int',
);
};
- ::ok(!$@, '... created the writer method with type constraint okay');
-
+ ::ok(!$@, '... created the writer method with type constraint okay');
+
eval {
has 'foo_weak' => (
reader => 'get_foo_weak',
weak_ref => 1
);
};
- ::ok(!$@, '... created the writer method with weak_ref okay');
+ ::ok(!$@, '... created the writer method with weak_ref okay');
}
{
lives_ok {
$foo->set_foo(100);
} '... set_foo wrote successfully';
- is($foo->get_foo(), 100, '... got the correct set value');
-
- ok(!isweak($foo->{foo}), '... it is not a weak reference');
-
+ is($foo->get_foo(), 100, '... got the correct set value');
+
+ ok(!isweak($foo->{foo}), '... it is not a weak reference');
+
# required writer
-
+
dies_ok {
Foo->new;
} '... cannot create without the required attribute';
lives_ok {
$foo->set_foo_required(100);
} '... set_foo_required wrote successfully';
- is($foo->get_foo_required(), 100, '... got the correct set value');
-
+ is($foo->get_foo_required(), 100, '... got the correct set value');
+
dies_ok {
$foo->set_foo_required();
} '... set_foo_required died successfully with no value';
lives_ok {
$foo->set_foo_required(undef);
- } '... set_foo_required did accept undef';
+ } '... set_foo_required did accept undef';
+
+ ok(!isweak($foo->{foo_required}), '... it is not a weak reference');
- 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');
lives_ok {
$foo->set_foo_int(100);
} '... set_foo_int wrote successfully';
- is($foo->get_foo_int(), 100, '... got the correct set value');
-
+ is($foo->get_foo_int(), 100, '... got the correct set value');
+
dies_ok {
$foo->set_foo_int("Foo");
- } '... set_foo_int died successfully';
-
- ok(!isweak($foo->{foo_int}), '... it is not a weak reference');
-
+ } '... 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');
lives_ok {
$foo->set_foo_weak($test);
} '... set_foo_weak wrote successfully';
- is($foo->get_foo_weak(), $test, '... got the correct set value');
-
+ is($foo->get_foo_weak(), $test, '... got the correct set value');
+
ok(isweak($foo->{foo_weak}), '... it is a weak reference');
}
{
package Foo;
use Moose;
-
+
eval {
has 'foo' => (
accessor => 'foo',
);
};
::ok(!$@, '... created the accessor method okay');
-
+
eval {
has 'lazy_foo' => (
- accessor => 'lazy_foo',
- lazy => 1,
+ accessor => 'lazy_foo',
+ lazy => 1,
default => sub { 10 }
);
};
- ::ok(!$@, '... created the lazy accessor method okay');
-
+ ::ok(!$@, '... created the lazy accessor method okay');
+
eval {
has 'foo_required' => (
isa => 'Int',
);
};
- ::ok(!$@, '... created the accessor method with type constraint okay');
-
+ ::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');
+ ::ok(!$@, '... created the accessor method with weak_ref okay');
eval {
has 'foo_deref' => (
auto_deref => 1,
);
};
- ::ok(!$@, '... created the accessor method with auto_deref okay');
+ ::ok(!$@, '... created the accessor method with auto_deref okay');
eval {
has 'foo_deref_ro' => (
auto_deref => 1,
);
};
- ::ok(!$@, '... created the reader method with auto_deref okay');
+ ::ok(!$@, '... created the reader method with auto_deref okay');
eval {
has 'foo_deref_hash' => (
auto_deref => 1,
);
};
- ::ok(!$@, '... created the reader method with auto_deref okay');
+ ::ok(!$@, '... created the reader method with auto_deref okay');
}
{
lives_ok {
$foo->foo(100);
} '... foo wrote successfully';
- is($foo->foo(), 100, '... got the correct set value');
-
- ok(!isweak($foo->{foo}), '... it is not a weak reference');
-
+ is($foo->foo(), 100, '... got the correct set value');
+
+ ok(!isweak($foo->{foo}), '... it is not a weak reference');
+
# required writer
-
+
dies_ok {
Foo->new;
} '... cannot create without the required attribute';
lives_ok {
$foo->foo_required(100);
} '... foo_required wrote successfully';
- is($foo->foo_required(), 100, '... got the correct set value');
-
+ is($foo->foo_required(), 100, '... got the correct set value');
+
lives_ok {
$foo->foo_required(undef);
- } '... foo_required did not die with 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');
-
+ 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');
-
+ 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');
lives_ok {
$foo->foo_int(100);
} '... foo_int wrote successfully';
- is($foo->foo_int(), 100, '... got the correct set value');
-
+ is($foo->foo_int(), 100, '... got the correct set value');
+
dies_ok {
$foo->foo_int("Foo");
- } '... foo_int died successfully';
-
- ok(!isweak($foo->{foo_int}), '... it is not a weak reference');
-
+ } '... 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');
lives_ok {
$foo->foo_weak($test);
} '... foo_weak wrote successfully';
- is($foo->foo_weak(), $test, '... got the correct set value');
-
+ 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');
{
package Foo;
use Moose;
-
- has 'bar' => (is => 'rw',
+
+ has 'bar' => (is => 'rw',
isa => 'Maybe[Bar]',
- trigger => sub {
+ trigger => sub {
my ($self, $bar) = @_;
$bar->foo($self) if defined $bar;
});
-
+
has 'baz' => (writer => 'set_baz',
reader => 'get_baz',
isa => 'Baz',
- trigger => sub {
+ trigger => sub {
my ($self, $baz) = @_;
$baz->foo($self);
- });
-
-
+ });
+
+
package Bar;
use Moose;
-
- has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1);
-
+
+ has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1);
+
package Baz;
use Moose;
-
- has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1);
+
+ has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1);
}
{
is($bar->foo, $foo, '... which in turn set the value bar.foo correctly');
ok(isweak($bar->{foo}), '... bar.foo is a weak reference');
-
+
lives_ok {
$foo->bar(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');
+ is($bar->foo, $foo, '... which in turn set the value bar.foo correctly');
# test the writer
my $baz = Baz->new;
isa_ok($baz, 'Baz');
-
+
my $foo = Foo->new(bar => $bar, baz => $baz);
- isa_ok($foo, 'Foo');
+ 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');
{
package Bling;
use Moose;
-
- ::dies_ok {
+
+ ::dies_ok {
has('bling' => (is => 'rw', trigger => 'Fail'));
} '... a trigger must be a CODE ref';
-
- ::dies_ok {
+
+ ::dies_ok {
has('bling' => (is => 'rw', trigger => []));
- } '... a trigger must be a CODE ref';
+ } '... a trigger must be a CODE ref';
}
# Triggers do not fire on built values
{
package Foo::Role;
use Moose::Role;
- use Moose::Util::TypeConstraints;
+ use Moose::Util::TypeConstraints;
- # if does() exists on its own, then
- # we create a type constraint for
+ # 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 'bar' => (is => 'rw', does => 'Bar::Role');
has 'baz' => (
- is => 'rw',
+ is => 'rw',
does => subtype('Role', where { $_->does('Bar::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');
-
+ # 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 Foo::Class;
use Moose;
-
+
with 'Foo::Role';
package Bar::Class;
$bar->foo($foo);
} '... foo passed the type constraint okay';
-
+
# some error conditions
::dies_ok {
has 'foo' => (isa => 'Foo::Class', does => 'Bar::Class');
} '... 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;
}
-
+
-{
+{
package Foo::Meta::Attribute;
use Moose;
-
+
extends 'Moose::Meta::Attribute';
-
+
around 'new' => sub {
my $next = shift;
my $self = shift;
package Foo;
use Moose;
-
+
has 'foo' => (metaclass => 'Foo::Meta::Attribute');
}
{
{
package Bar::Meta::Attribute;
use Moose;
-
- extends 'Class::MOP::Attribute';
-
+
+ extends 'Class::MOP::Attribute';
+
package Bar;
use Moose;
-
+
::lives_ok {
- has 'bar' => (metaclass => 'Bar::Meta::Attribute');
+ has 'bar' => (metaclass => 'Bar::Meta::Attribute');
} '... 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;
-
+
::lives_ok {
- has 'foo' => (metaclass => 'Foo');
+ has 'foo' => (metaclass => 'Foo');
} '... the attribute metaclass alias worked correctly';
-
+
::lives_ok {
- has 'bar' => (metaclass => 'Bar');
- } '... the attribute metaclass alias worked correctly';
+ has 'bar' => (metaclass => 'Bar');
+ } '... 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');
+ isa_ok($bar_attr, 'Moose::Meta::Attribute');
}
{
package Foo;
use Moose;
-
+
has 'bar' => (is => 'rw', isa => 'ArrayRef | HashRef');
}
{
package Bar;
use Moose;
-
+
has 'baz' => (is => 'rw', isa => 'Str | CodeRef');
}
{
package Thing;
use Moose;
-
+
sub hello { 'Hello World (from Thing)' }
- sub goodbye { 'Goodbye World (from Thing)' }
-
+ sub goodbye { 'Goodbye World (from Thing)' }
+
package Foo;
use Moose;
use Moose::Util::TypeConstraints;
-
- subtype 'FooStr'
+
+ subtype 'FooStr'
=> as 'Str'
=> where { /Foo/ };
-
- coerce 'FooStr'
+
+ 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 'baz' => (is => 'rw', isa => 'Ref');
+ has 'foo' => (is => 'rw', isa => 'FooStr');
+
+ has 'gorch' => (is => 'ro');
+ has 'gloum' => (is => 'ro', default => sub {[]});
+
has 'bling' => (is => 'ro', isa => 'Thing');
- has 'blang' => (is => 'ro', isa => 'Thing', handles => ['goodbye']);
-
+ has 'blang' => (is => 'ro', isa => 'Thing', handles => ['goodbye']);
+
has 'bunch_of_stuff' => (is => 'rw', isa => 'ArrayRef');
- has 'one_last_one' => (is => 'rw', isa => 'Ref');
-
+ has 'one_last_one' => (is => 'rw', isa => 'Ref');
+
# this one will work here ....
has 'fail' => (isa => 'CodeRef');
- has 'other_fail';
-
+ has 'other_fail';
+
package Bar;
use Moose;
use Moose::Util::TypeConstraints;
-
+
extends 'Foo';
- ::lives_ok {
- has '+bar' => (default => 'Bar::bar');
- } '... we can change the default attribute option';
-
- ::lives_ok {
- has '+baz' => (isa => 'ArrayRef');
- } '... we can add change the isa as long as it is a subtype';
-
- ::lives_ok {
- has '+foo' => (coerce => 1);
- } '... we can change/add coerce as an attribute option';
-
- ::lives_ok {
- has '+gorch' => (required => 1);
- } '... we can change/add required as an attribute option';
-
- ::lives_ok {
- has '+gloum' => (lazy => 1);
- } '... we can change/add lazy as an attribute option';
+ ::lives_ok {
+ has '+bar' => (default => 'Bar::bar');
+ } '... we can change the default attribute option';
+
+ ::lives_ok {
+ has '+baz' => (isa => 'ArrayRef');
+ } '... we can add change the isa as long as it is a subtype';
+
+ ::lives_ok {
+ has '+foo' => (coerce => 1);
+ } '... we can change/add coerce as an attribute option';
+
+ ::lives_ok {
+ has '+gorch' => (required => 1);
+ } '... we can change/add required as an attribute option';
+
+ ::lives_ok {
+ has '+gloum' => (lazy => 1);
+ } '... we can change/add lazy as an attribute option';
::lives_ok {
has '+gloum' => (lazy_build => 1);
} '... we can add lazy_build as an attribute option';
::lives_ok {
- has '+bunch_of_stuff' => (isa => 'ArrayRef[Int]');
+ has '+bunch_of_stuff' => (isa => 'ArrayRef[Int]');
} '... extend an attribute with parameterized type';
-
+
::lives_ok {
- has '+one_last_one' => (isa => subtype('Ref', where { blessed $_ eq 'CODE' }));
- } '... extend an attribute with anon-subtype';
-
+ has '+one_last_one' => (isa => subtype('Ref', where { blessed $_ eq 'CODE' }));
+ } '... extend an attribute with anon-subtype';
+
::lives_ok {
- has '+one_last_one' => (isa => 'Value');
- } '... now can extend an attribute with a non-subtype';
+ has '+one_last_one' => (isa => 'Value');
+ } '... now can extend an attribute with a non-subtype';
::lives_ok {
- has '+bling' => (handles => ['hello']);
+ has '+bling' => (handles => ['hello']);
} '... we can add the handles attribute option';
-
+
# this one will *not* work here ....
::dies_ok {
- has '+blang' => (handles => ['hello']);
- } '... we can not alter the handles attribute option';
- ::lives_ok {
- has '+fail' => (isa => 'Ref');
- } '... can now create an attribute with an improper subtype relation';
- ::dies_ok {
- has '+other_fail' => (trigger => sub {});
- } '... cannot create an attribute with an illegal option';
- ::dies_ok {
- has '+other_fail' => (weak_ref => 1);
- } '... cannot create an attribute with an illegal option';
+ has '+blang' => (handles => ['hello']);
+ } '... we can not alter the handles attribute option';
+ ::lives_ok {
+ has '+fail' => (isa => 'Ref');
+ } '... can now create an attribute with an improper subtype relation';
+ ::dies_ok {
+ has '+other_fail' => (trigger => sub {});
+ } '... cannot create an attribute with an illegal option';
+ ::dies_ok {
+ has '+other_fail' => (weak_ref => 1);
+ } '... cannot create an attribute with an illegal option';
::throws_ok {
has '+does_not_exist' => (isa => 'Str');
} qr/in Bar/, '... cannot extend a non-existing attribute';
my $hash_ref = {};
lives_ok { $foo->baz($hash_ref) } '... Foo::baz accepts hash refs';
is($foo->baz, $hash_ref, '... got the right value assigned to baz');
-
+
my $array_ref = [];
lives_ok { $foo->baz($array_ref) } '... Foo::baz accepts an array ref';
is($foo->baz, $array_ref, '... got the right value assigned to baz');
my $scalar_ref = \(my $var);
lives_ok { $foo->baz($scalar_ref) } '... Foo::baz accepts scalar ref';
is($foo->baz, $scalar_ref, '... got the right value assigned to baz');
-
- lives_ok { $foo->bunch_of_stuff([qw[one two three]]) } '... Foo::bunch_of_stuff accepts an array of strings';
-
- lives_ok { $foo->one_last_one(sub { 'Hello World'}) } '... Foo::one_last_one accepts a code ref';
-
+
+ lives_ok { $foo->bunch_of_stuff([qw[one two three]]) } '... Foo::bunch_of_stuff accepts an array of strings';
+
+ lives_ok { $foo->one_last_one(sub { 'Hello World'}) } '... Foo::one_last_one accepts a code ref';
+
my $code_ref = sub { 1 };
lives_ok { $foo->baz($code_ref) } '... Foo::baz accepts a code ref';
- is($foo->baz, $code_ref, '... got the right value assigned to baz');
+ is($foo->baz, $code_ref, '... got the right value assigned to baz');
}
dies_ok {
{
my $hash_ref = {};
dies_ok { $bar->baz($hash_ref) } '... Bar::baz does not accept hash refs';
-
+
my $array_ref = [];
lives_ok { $bar->baz($array_ref) } '... Bar::baz can accept an array ref';
is($bar->baz, $array_ref, '... got the right value assigned to baz');
my $scalar_ref = \(my $var);
dies_ok { $bar->baz($scalar_ref) } '... Bar::baz does not accept a scalar ref';
-
- lives_ok { $bar->bunch_of_stuff([1, 2, 3]) } '... Bar::bunch_of_stuff accepts an array of ints';
- dies_ok { $bar->bunch_of_stuff([qw[one two three]]) } '... Bar::bunch_of_stuff does not accept an array of strings';
-
+
+ lives_ok { $bar->bunch_of_stuff([1, 2, 3]) } '... Bar::bunch_of_stuff accepts an array of ints';
+ dies_ok { $bar->bunch_of_stuff([qw[one two three]]) } '... Bar::bunch_of_stuff does not accept an array of strings';
+
my $code_ref = sub { 1 };
dies_ok { $bar->baz($code_ref) } '... Bar::baz does not accept a code ref';
}
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'),
+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'),
+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'),
+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,
+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');
+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,
+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,
+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,
+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,
+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,
+
+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,
+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,
+
+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,
+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,
+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');
+ok(Bar->meta->get_attribute('bling')->has_handles,
+ '... Bar::foo should handles');
# HASH handles
# -------------------------------------------------------------------
# the canonical form of of the 'handles'
-# option is the hash ref mapping a
+# option is the hash ref mapping a
# method name to the delegated method name
{
package Foo;
use Moose;
- has 'bar' => (is => 'rw', default => 10);
+ has 'bar' => (is => 'rw', default => 10);
package Bar;
- use Moose;
-
+ use Moose;
+
has 'foo' => (
is => 'rw',
default => sub { Foo->new },
$bar->foo_bar(50);
-# and make sure everyone sees it
+# 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');
is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
# -------------------------------------------------------------------
-# ARRAY handles
+# ARRAY handles
# -------------------------------------------------------------------
# we also support an array based format
-# which assumes that the name is the same
+# which assumes that the name is the same
# on either end
{
use Moose;
sub go { 'Engine::go' }
- sub stop { 'Engine::stop' }
+ sub stop { 'Engine::stop' }
package Car;
- use Moose;
-
+ use Moose;
+
has 'engine' => (
is => 'rw',
default => sub { Engine->new },
is($car->stop, 'Engine::stop', '... got the right value from ->stop');
# -------------------------------------------------------------------
-# REGEXP handles
+# REGEXP handles
# -------------------------------------------------------------------
# and we support regexp delegation
use Moose;
sub foo { 'Baz::foo' }
- sub bar { 'Baz::bar' }
- sub boo { 'Baz::boo' }
+ sub bar { 'Baz::bar' }
+ sub boo { 'Baz::boo' }
package Baz::Proxy1;
- use Moose;
-
+ use Moose;
+
has 'baz' => (
is => 'ro',
isa => 'Baz',
default => sub { Baz->new },
handles => qr/.*/
);
-
+
package Baz::Proxy2;
- use Moose;
-
+ use Moose;
+
has 'baz' => (
is => 'ro',
isa => 'Baz',
default => sub { Baz->new },
handles => qr/.oo/
- );
-
+ );
+
package Baz::Proxy3;
- use Moose;
-
+ use Moose;
+
has 'baz' => (
is => 'ro',
isa => 'Baz',
default => sub { Baz->new },
handles => qr/b.*/
- );
+ );
}
{
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');
+ is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
}
{
my $baz_proxy = Baz::Proxy2->new;
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');
+ is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
}
{
my $baz_proxy = Baz::Proxy3->new;
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');
+ is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
}
# -------------------------------------------------------------------
{
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' }
-
+ sub baz { 'Foo::Baz::BAZ' }
+
package Foo::Thing;
use Moose;
-
+
has 'thing' => (
- is => 'rw',
+ is => 'rw',
isa => 'Foo::Baz',
handles => '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');
+ 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');
+ is($foo->thing->baz, 'Foo::Baz::BAZ', '... got the right value');
}
# -------------------------------------------------------------------
}
package Bar::Autoloaded;
- use Moose;
-
+ use Moose;
+
has 'foo' => (
is => 'rw',
default => sub { Foo::Autoloaded->new },
handles => { 'foo_bar' => 'bar' }
);
-
+
package Baz::Autoloaded;
- use Moose;
-
+ use Moose;
+
has 'foo' => (
is => 'rw',
default => sub { Foo::Autoloaded->new },
handles => ['bar']
- );
-
+ );
+
package Goorch::Autoloaded;
- use Moose;
-
+ use Moose;
+
::dies_ok {
has 'foo' => (
is => 'rw',
default => sub { Foo::Autoloaded->new },
handles => qr/bar/
- );
+ );
} '... you cannot delegate to AUTOLOADED class with regexp';
}
$bar->foo_bar(50);
- # and make sure everyone sees it
+ # 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');
isa_ok($foo, 'Foo::Autoloaded');
$foo->bar(25);
-
+
is($foo->bar, 25, '... got the right foo->bar');
lives_ok {
$baz->bar(50);
- # and make sure everyone sees it
+ # 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');
isa_ok($foo, 'Foo::Autoloaded');
$foo->bar(25);
-
+
is($foo->bar, 25, '... got the right foo->bar');
lives_ok {
{
package Quux;
use Moose;
- has foo => (
- isa => 'Foo',
+ has foo => (
+ isa => 'Foo',
default => sub { Foo->new },
handles => { 'foo_bar' => 'bar' }
);
=pod
-This tests the more complex
-delegation cases and that they
+This tests the more complex
+delegation cases and that they
do not fail at compile time.
=cut
} "subrefs on non moose class give no meta";
::is( $delegate_class, "ChildF", "plain classes are handed down to subs" );
-
+
::lives_ok {
has child_g => (
isa => "ChildG",
default => sub { ChildG->new },
handles => ["child_g_method_1"],
);
- } "can delegate to object even without explicit reader";
+ } "can delegate to object even without explicit reader";
sub parent_method { "p" }
}
throws_ok {
$moose_obj->a_str( $moose_obj )
- } qr/Attribute \(a_str\) does not pass the type constraint because\: Validation failed for 'Str' failed with value OverloadedStr=HASH\(0x.+?\)/,
+ } qr/Attribute \(a_str\) does not pass the type constraint because\: Validation failed for 'Str' failed with value OverloadedStr=HASH\(0x.+?\)/,
'... dies without overloading the string';
}
throws_ok {
OverloadBreaker->new;
- } qr/Attribute \(a_num\) does not pass the type constraint because\: Validation failed for 'Int' failed with value 7\.5/,
+ } qr/Attribute \(a_num\) does not pass the type constraint because\: Validation failed for 'Int' failed with value 7\.5/,
'... this doesnt trip overload to break anymore ';
lives_ok {
is($instance->foo, 'works', "foo builder works");
}
-{
+{
{
package Test::Builder::Attribute::Broken;
use Moose;
has 'foo' => ( required => 1, builder => 'build_foo', is => 'ro');
}
-
+
dies_ok {
Test::Builder::Attribute::Broken->new;
} '... no builder, wtf';
::lives_ok {
has 'customers' => (
is => 'ro',
- isa => subtype('ArrayRef' => where {
+ isa => subtype('ArrayRef' => where {
(blessed($_) && $_->isa('Customer') || return) for @$_; 1 }),
auto_deref => 1,
);
{
my $autoderef = AutoDeref->new;
-
+
dies_ok {
$autoderef->bar(1, 2, 3);
} '... its auto-de-ref-ing, not auto-en-ref-ing';
-
- lives_ok {
- $autoderef->bar([ 1, 2, 3 ])
+
+ lives_ok {
+ $autoderef->bar([ 1, 2, 3 ])
} '... set the results of bar correctly';
is_deeply [ $autoderef->bar ], [ 1, 2, 3 ], '... auto-dereffed correctly';
{
package HTTPHeader;
use Moose;
-
+
has 'array' => (is => 'ro');
- has 'hash' => (is => 'ro');
+ has 'hash' => (is => 'ro');
}
{
package Request;
use Moose;
use Moose::Util::TypeConstraints;
-
- subtype Header =>
- => as Object
+
+ subtype Header =>
+ => as Object
=> where { $_->isa('HTTPHeader') };
- coerce Header
- => from ArrayRef
+ coerce Header
+ => from ArrayRef
=> via { HTTPHeader->new(array => $_[0]) }
- => from HashRef
- => via { HTTPHeader->new(hash => $_[0]) };
-
+ => from HashRef
+ => via { HTTPHeader->new(hash => $_[0]) };
+
has 'headers' => (
is => 'rw',
isa => 'Header',
coerce => 1,
lazy => 1,
- default => sub { [ 'content-type', 'text/html' ] }
+ default => sub { [ 'content-type', 'text/html' ] }
);
}
{
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->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);
{
package My::Meta::Attribute::DefaultReadOnly;
use Moose;
-
+
extends 'Moose::Meta::Attribute';
-
+
around 'new' => sub {
my $next = shift;
my ($self, $name, %options) = @_;
- $options{is} = 'ro'
+ $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->alias_to,
$self->get_read_method_ref
);
};
{
package My::Class;
use Moose;
-
+
has 'bar' => (
metaclass => 'My::Meta::Attribute::DefaultReadOnly',
traits => [qw/My::Attribute::Trait/],
{
package Foo;
use Moose;
-
+
eval {
has 'foo' => (
is => "rw",
{
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);
},
);
default => 10,
initializer => sub {
my ($self, $value, $callback, $attr) = @_;
-
+
::isa_ok($attr, 'Moose::Meta::Attribute');
- ::is($attr->name, 'lazy_foo', '... got the right name');
-
+ ::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',
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');
-
+ ::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');
-
+ ::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',
+ 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');
-
+ ::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 }
+
+ sub get_foo_builder { 100 }
+ sub get_foo_builder_w_type { 1000 }
}
{
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');
+ 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');
+ 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;
}
lives_ok {$obj->_foo(1)} "$class->_foo is writer";
is($obj->foo(), 1, "$class->foo is reader");
dies_ok {$obj->foo(2)} "$class->foo is not writer"; # this should fail
-ok(!defined $obj->_foo(), "$class->_foo is not reader");
+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");
package Baz;
use Moose;
use Moose::Util::TypeConstraints;
-
+
coerce 'Baz' => from 'HashRef' => via { Baz->new($_) };
-
+
has 'hello' => (
is => 'ro',
- isa => 'Str',
+ isa => 'Str',
);
-
+
package Bar;
use Moose;
use Moose::Util::TypeConstraints;
-
+
coerce 'Bar' => from 'HashRef' => via { Bar->new($_) };
-
+
has 'baz' => (
is => 'ro',
- isa => 'Baz',
+ isa => 'Baz',
coerce => 1
);
-
+
package Foo;
use Moose;
-
+
has 'bar' => (
is => 'ro',
- isa => 'Bar',
+ isa => 'Bar',
coerce => 1,
);
}
{
package FooRole;
-
+
our $VERSION = '0.01';
-
+
sub foo { 'FooRole::foo' }
}
[ $foo_role->get_method_list() ],
[ 'foo' ],
'... got the right method list');
-
+
# attributes ...
is_deeply(
NOTE:
Should we be testing here that the has & override
-are injecting their methods correctly? In other
+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');
-
+ has 'baz' => (is => 'ro');
+
sub foo { 'FooRole::foo' }
- sub boo { 'FooRole::boo' }
-
+ 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" };
-
+
+ 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" };
+
::dies_ok { extends() } '... extends() is not supported';
- ::dies_ok { augment() } '... augment() is not supported';
- ::dies_ok { inner() } '... inner() is not supported';
+ ::dies_ok { augment() } '... augment() is not supported';
+ ::dies_ok { inner() } '... inner() is not supported';
no Moose::Role;
}
# 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",
+is(($foo_role->get_before_method_modifiers('boo'))[0]->(),
+ "FooRole::boo:before",
'... got the right method back');
is_deeply(
'... 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",
+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(($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",
+is(($foo_role->get_around_method_modifiers('boo'))[0]->(),
+ "FooRole::boo:around",
'... got the right method back');
is_deeply(
## 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",
+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",
+is($foo_role->get_override_method_modifier('fling')->(),
+ "FooRole::fling:override",
'... got the right method back');
is_deeply(
use Moose::Role;
requires 'foo';
-
+
sub bar { 'Role::Foo::bar' }
-
+
package Role::Bar;
use Moose::Role;
-
+
requires 'bar';
-
- sub foo { 'Role::Bar::foo' }
+
+ sub foo { 'Role::Bar::foo' }
}
{
package My::Test1;
use Moose;
-
+
::lives_ok {
with 'Role::Foo', 'Role::Bar';
} '... our mutually recursive roles combine okay';
-
+
package My::Test2;
use Moose;
-
+
::lives_ok {
with 'Role::Bar', 'Role::Foo';
- } '... our mutually recursive roles combine okay (no matter what order)';
+ } '... our mutually recursive roles combine okay (no matter what order)';
}
my $test1 = My::Test1->new;
{
package Role::Bling;
use Moose::Role;
-
+
sub bling { 'Role::Bling::bling' }
-
+
package Role::Bling::Bling;
use Moose::Role;
-
- sub bling { 'Role::Bling::Bling::bling' }
+
+ sub bling { 'Role::Bling::Bling::bling' }
}
{
package My::Test3;
use Moose;
-
+
::throws_ok {
with 'Role::Bling', 'Role::Bling::Bling';
} qr/requires the method \'bling\' to be implemented/, '... role methods conflicted and method was required';
-
+
package My::Test4;
use Moose;
-
+
::lives_ok {
with 'Role::Bling';
with 'Role::Bling::Bling';
- } '... role methods didnt conflict when manually combined';
-
+ } '... role methods didnt conflict when manually combined';
+
package My::Test5;
use Moose;
-
+
::lives_ok {
with 'Role::Bling::Bling';
with 'Role::Bling';
- } '... role methods didnt conflict when manually combined (in opposite order)';
-
+ } '... role methods didnt conflict when manually combined (in opposite order)';
+
package My::Test6;
use Moose;
-
+
::lives_ok {
with 'Role::Bling::Bling', 'Role::Bling';
- } '... role methods didnt conflict when manually resolved';
-
+ } '... role methods didnt conflict when manually resolved';
+
sub bling { 'My::Test6::bling' }
}
{
package Role::Bling::Bling::Bling;
use Moose::Role;
-
+
with 'Role::Bling::Bling';
-
- sub bling { 'Role::Bling::Bling::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')->(),
+is(Role::Bling::Bling::Bling->meta->get_method('bling')->(),
'Role::Bling::Bling::Bling::bling',
'... still got the bling method in Role::Bling::Bling::Bling');
{
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;
-
+
::throws_ok {
with 'Role::Boo', 'Role::Boo::Hoo';
- } qr/We have encountered an attribute conflict/,
+ } qr/We have encountered an attribute conflict/,
'... role attrs conflicted and method was required';
package My::Test8;
with 'Role::Boo';
with 'Role::Boo::Hoo';
} '... role attrs didnt conflict when manually combined';
-
+
package My::Test9;
use Moose;
::lives_ok {
with 'Role::Boo::Hoo';
with 'Role::Boo';
- } '... role attrs didnt conflict when manually combined';
+ } '... role attrs didnt conflict when manually combined';
package My::Test10;
use Moose;
-
- has 'ghost' => (is => 'ro', default => 'My::Test10::ghost');
-
+
+ has 'ghost' => (is => 'ro', default => 'My::Test10::ghost');
+
::throws_ok {
with 'Role::Boo', 'Role::Boo::Hoo';
- } qr/We have encountered an attribute conflict/,
- '... role attrs conflicted and cannot be manually disambiguted';
+ } qr/We have encountered an attribute conflict/,
+ '... role attrs conflicted and cannot be manually disambiguted';
}
{
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';
::lives_ok {
with 'Role::Truth';
} '... composed the role with override okay';
-
+
package My::Test12;
use Moose;
extends 'My::Test::Base';
- ::lives_ok {
+ ::lives_ok {
with 'Role::Plot';
} '... composed the role with override okay';
-
+
package My::Test13;
use Moose;
::dies_ok {
- with 'Role::Plot';
+ with 'Role::Plot';
} '... cannot compose it because we have no superclass';
-
+
package My::Test14;
use Moose;
extends 'My::Test::Base';
::throws_ok {
- with 'Role::Plot', 'Role::Truth';
- } qr/Two \'override\' methods of the same name encountered/,
- '... cannot compose it because we have no superclass';
+ 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');
package Role::Reality;
use Moose::Role;
- ::throws_ok {
+ ::throws_ok {
with 'Role::Plot';
- } qr/A local method of the same name as been found/,
+ } 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',
+is(Role::Reality->meta->get_method('twist')->(),
+ 'Role::Reality::twist',
'... the twist method returns the right value');
=pod
{
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 {
+ ::lives_ok {
with 'Role::Method';
} '... composed the method role into the method class';
http://research.sun.com/projects/plrg/fortress0903.pdf
-trait OrganicMolecule extends Molecule
- excludes { InorganicMolecule }
-end
-trait InorganicMolecule extends Molecule end
+trait OrganicMolecule extends Molecule
+ excludes { InorganicMolecule }
+end
+trait InorganicMolecule extends Molecule end
=cut
package Molecule::Organic;
use Moose::Role;
-
+
with 'Molecule';
excludes 'Molecule::Inorganic';
-
+
package Molecule::Inorganic;
- use Moose::Role;
-
- with 'Molecule';
+ 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::Organic->meta->get_excluded_roles_list() ],
[ 'Molecule::Inorganic' ],
'... Molecule::Organic exludes Molecule::Inorganic');
=pod
-Check some basic conflicts when combining
+Check some basic conflicts when combining
the roles into the same class
=cut
{
package My::Test1;
use Moose;
-
+
::lives_ok {
with 'Molecule::Organic';
} '... adding the role (w/ excluded roles) okay';
package My::Test2;
use Moose;
-
+
::throws_ok {
with 'Molecule::Organic', 'Molecule::Inorganic';
- } qr/Conflict detected: Role Molecule::Organic excludes role 'Molecule::Inorganic'/,
- '... adding the role w/ excluded role conflict dies okay';
-
+ } qr/Conflict detected: Role Molecule::Organic excludes role 'Molecule::Inorganic'/,
+ '... adding the role w/ excluded role conflict dies okay';
+
package My::Test3;
use Moose;
-
+
::lives_ok {
with 'Molecule::Organic';
- } '... adding the role (w/ excluded roles) okay';
-
+ } '... adding the role (w/ excluded roles) okay';
+
::throws_ok {
with 'Molecule::Inorganic';
- } qr/Conflict detected: My::Test3 excludes role 'Molecule::Inorganic'/,
- '... adding the role w/ excluded role conflict dies okay';
+ } 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');
=pod
-Check some basic conflicts when combining
+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';
-
+
+ extends 'Methane';
+
::throws_ok {
- with 'Molecule::Inorganic';
+ with 'Molecule::Inorganic';
} qr/Conflict detected: My::Test4 excludes role \'Molecule::Inorganic\'/,
'... cannot add exculded role into class which extends Methane';
}
=pod
NOTE:
-A fair amount of these tests will likely be irrelevant
+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
+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
+Role which requires a method implemented
+in another role as an override (it does
not remove the requirement)
=cut
use strict;
use warnings;
use Moose::Role;
-
+
requires 'foo';
-
+
package Role::ProvideFoo;
use strict;
use warnings;
use Moose::Role;
-
+
::lives_ok {
with 'Role::RequireFoo';
} '... the required "foo" method will not exist yet (but we will live)';
-
- override 'foo' => sub { 'Role::ProvideFoo::foo' };
+
+ override 'foo' => sub { 'Role::ProvideFoo::foo' };
}
is_deeply(
- [ Role::ProvideFoo->meta->get_required_method_list ],
- [ 'foo' ],
+ [ 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
+Role which requires a method implemented
+in the consuming class as an override.
+It will fail since method modifiers are
second class citizens.
=cut
use Moose;
sub foo { 'Class::ProvideFoo::Base::foo' }
-
+
package Class::ProvideFoo::Override1;
use Moose;
-
+
extends 'Class::ProvideFoo::Base';
-
+
::lives_ok {
with 'Role::RequireFoo';
} '... the required "foo" method will be found in the superclass';
-
- override 'foo' => sub { 'Class::ProvideFoo::foo' };
-
+
+ override 'foo' => sub { 'Class::ProvideFoo::foo' };
+
package Class::ProvideFoo::Override2;
use Moose;
-
+
extends 'Class::ProvideFoo::Base';
-
- override 'foo' => sub { 'Class::ProvideFoo::foo' };
-
+
+ override 'foo' => sub { 'Class::ProvideFoo::foo' };
+
::lives_ok {
with 'Role::RequireFoo';
} '... the required "foo" method exists, although it is overriden locally';
=pod
-Now same thing, but with a before
+Now same thing, but with a before
method modifier.
=cut
{
package Class::ProvideFoo::Before1;
use Moose;
-
+
extends 'Class::ProvideFoo::Base';
-
+
::lives_ok {
with 'Role::RequireFoo';
} '... the required "foo" method will be found in the superclass';
-
- before 'foo' => sub { 'Class::ProvideFoo::foo:before' };
-
+
+ before 'foo' => sub { 'Class::ProvideFoo::foo:before' };
+
package Class::ProvideFoo::Before2;
use Moose;
-
+
extends 'Class::ProvideFoo::Base';
-
- before 'foo' => sub { 'Class::ProvideFoo::foo:before' };
-
+
+ before 'foo' => sub { 'Class::ProvideFoo::foo:before' };
+
::lives_ok {
with 'Role::RequireFoo';
- } '... the required "foo" method exists, although it is a before modifier locally';
-
+ } '... 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' };
-
+ before 'foo' => sub { 'Class::ProvideFoo::foo:before' };
+
::lives_ok {
with 'Role::RequireFoo';
- } '... the required "foo" method exists locally, and it is modified locally';
-
+ } '... 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' };
+
+ 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__,
+ ::is(__PACKAGE__->meta->get_method('foo')->get_original_method->package_name, __PACKAGE__,
'... but the original method is from our package');
-
+
::lives_ok {
with 'Role::RequireFoo';
- } '... the required "foo" method exists in the symbol table (and we will live)';
-
-}
+ } '... the required "foo" method exists in the symbol table (and we will live)';
+
+}
=pod
=cut
{
-
+
package Class::ProvideFoo::Attr1;
use Moose;
-
+
extends 'Class::ProvideFoo::Base';
-
+
::lives_ok {
with 'Role::RequireFoo';
} '... 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');
-
+
+ has 'foo' => (is => 'ro');
+
::lives_ok {
with 'Role::RequireFoo';
} '... the required "foo" method exists, and is an accessor';
-}
+}
# ...
-# a method required in a role, but then
-# implemented in the superclass (as an
+# 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',
+
+ 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 }
+
+ has 'foo' => (
+ isa => 'Int',
+ is => 'rw',
+ lazy => 1,
+ default => sub { (shift)->bar + 1 }
);
}
{
package Foo::Class::Child;
use Moose;
extends 'Foo::Class::Base';
-
+
::lives_ok {
with 'Foo::Role';
} '... our role combined successfully';
=pod
-Check for repeated inheritance causing
-a method conflict (which is not really
+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;
-
+ use Moose::Role;
+
with 'Role::Base';
-
+
package Role::Derived2;
- use Moose::Role;
+ use Moose::Role;
with 'Role::Base';
-
+
package My::Test::Class1;
- use Moose;
-
+ use Moose;
+
::lives_ok {
- with 'Role::Derived1', 'Role::Derived2';
+ with 'Role::Derived1', 'Role::Derived2';
} '... roles composed okay (no conflicts)';
}
=pod
-Check for repeated inheritance causing
-a method conflict with method modifiers
+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;
-
+ use Moose::Role;
+
with 'Role::Base2';
-
+
package Role::Derived4;
- use Moose::Role;
+ 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';
-
+ use Moose;
+
+ extends 'My::Test::Class2::Base';
+
::lives_ok {
- with 'Role::Derived3', 'Role::Derived4';
+ with 'Role::Derived3', 'Role::Derived4';
} '... roles composed okay (no conflicts)';
}
=pod
-Check for repeated inheritance of the
-same code. There are no conflicts with
+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
+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;
-
+ use Moose::Role;
+
with 'Role::Base3';
-
+
package Role::Derived6;
- use Moose::Role;
+ 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';
-
+ use Moose;
+
+ extends 'My::Test::Class3::Base';
+
::lives_ok {
- with 'Role::Derived5', 'Role::Derived6';
+ with 'Role::Derived5', 'Role::Derived6';
} '... roles composed okay (no conflicts)';
}
=pod
-Check for repeated inheritance causing
-a attr conflict (which is not really
+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;
-
+ use Moose::Role;
+
with 'Role::Base4';
-
+
package Role::Derived8;
- use Moose::Role;
+ use Moose::Role;
with 'Role::Base4';
-
+
package My::Test::Class4;
- use Moose;
-
+ use Moose;
+
::lives_ok {
- with 'Role::Derived7', 'Role::Derived8';
+ with 'Role::Derived7', 'Role::Derived8';
} '... roles composed okay (no conflicts)';
}
{
# NOTE:
- # this tests that repeated role
- # composition will not cause
+ # 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;
package SubAB;
use Moose;
- ::lives_ok {
- with "SubAA", "RootA";
+ ::lives_ok {
+ with "SubAA", "RootA";
} '... role was composed as expected';
}
can_ok( $i, "foo" );
my $foo_rv;
- lives_ok {
- $foo_rv = $i->foo;
+ lives_ok {
+ $foo_rv = $i->foo;
} '... 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
+ # 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
+ # 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
+ # 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
+ # 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
+ # 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;
package SubBB;
use Moose;
- ::lives_ok {
+ ::lives_ok {
with "SubBA";
} '... composed the role successfully';
}
isa_ok( my $i = SubBB->new, "SubBB" );
can_ok( $i, "foo" );
-
+
my $foo_rv;
- lives_ok {
- $foo_rv = $i->foo
+ lives_ok {
+ $foo_rv = $i->foo
} '... called foo successfully';
is( $foo_rv, "RootB::foo", "foo rv" );
is( $i->counter, 1, "after hook called" );
-
+
lives_ok { $i->foo } '... 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();
+ #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
+ # composed in method. In this case the
+ # RootC::foo, which is composed into
+ # SubCA cannot be trampled with an
# override of 'foo'
{
package RootC;
with "RootC";
- ::dies_ok {
+ ::dies_ok {
override foo => sub { "overridden" };
} '... 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
+# 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)
{
with "ConcreteA";
# NOTE:
- # this was originally override, but
+ # 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
+ # However, this may not be testing the
# same thing that was originally intended
around other => sub {
return ( (shift)->() . " + c" );
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 $@;
=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
+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.
}
my $obj = My::Class->new;
-isa_ok($obj, 'My::Class');
-
+isa_ok($obj, 'My::Class');
+
my $obj2 = My::Class->new;
-isa_ok($obj2, 'My::Class');
+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');
+ 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('Bark'), '... we do not do any roles yet');
-
+
Bark->meta->apply($obj2);
-
+
ok($obj2->does('Bark'), '... we now do the Bark role');
is(blessed($obj), blessed($obj2), '... they share the same anon-class/role thing');
}
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 no longer share the same anon-class/role thing');
-
+ 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 no longer 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');
+ is($obj->talk, 'zzz', '... 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 Bark role');
is(blessed($obj), blessed($obj2), '... they share the same anon-class/role thing again');
}
-{
+{
# test no conflicts here
package Role::A;
use Moose::Role;
package Role::C;
use Moose::Role;
-
+
::lives_ok {
with qw(Role::A Role::B); # no conflict here
} "define role C";
::lives_ok {
with qw(Role::C);
} "define class A";
-
+
sub zot { 'Class::A::zot' }
}
{
# check that when a role is added to another role
# and they conflict and the method they conflicted
- # with is then required.
-
+ # with is then required.
+
package Role::A::Conflict;
use Moose::Role;
-
+
with 'Role::A';
-
+
sub bar { 'Role::A::Conflict::bar' }
-
+
package Class::A::Conflict;
use Moose;
-
+
::throws_ok {
with 'Role::A::Conflict';
} qr/requires.*'bar'/, '... did not fufill the requirement of &bar method';
-
+
package Class::A::Resolved;
use Moose;
-
+
::lives_ok {
with 'Role::A::Conflict';
- } '... did fufill the requirement of &bar method';
-
+ } '... did fufill the requirement of &bar method';
+
sub bar { 'Class::A::Resolved::bar' }
}
{
# 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' }
+ sub bar { 'Role::D::bar' }
package Role::E;
use Moose::Role;
::lives_ok {
with qw(Role::D Role::E); # conflict between 'foo's here
} "define role Role::F";
-
+
sub foo { 'Role::F::foo' }
- sub zot { 'Role::F::zot' }
-
+ sub zot { 'Role::F::zot' }
+
package Class::B;
use Moose;
-
+
::lives_ok {
with qw(Role::F);
} "define class Class::B";
-
+
sub zot { 'Class::B::zot' }
}
{
# check that a conflict can be resolved
- # by a role, but also new ones can be
+ # by a role, but also new ones can be
# created just as easily ...
-
+
package Role::D::And::E::Conflict;
use Moose::Role;
::lives_ok {
with qw(Role::D Role::E); # conflict between 'foo's here
} "... define role Role::D::And::E::Conflict";
-
+
sub foo { 'Role::D::And::E::Conflict::foo' } # this overrides ...
-
- # but these conflict
- sub xxy { 'Role::D::And::E::Conflict::xxy' }
- sub bar { 'Role::D::And::E::Conflict::bar' }
+
+ # but these conflict
+ sub xxy { 'Role::D::And::E::Conflict::xxy' }
+ sub bar { 'Role::D::And::E::Conflict::bar' }
}
{
# conflict propagation
-
+
package Role::H;
use Moose::Role;
sub foo { 'Role::H::foo' }
- sub bar { 'Role::H::bar' }
+ sub bar { 'Role::H::bar' }
package Role::J;
use Moose::Role;
::lives_ok {
with qw(Role::J Role::H); # conflict between 'foo's here
} "define role Role::I";
-
+
sub zot { 'Role::I::zot' }
sub zzy { 'Role::I::zzy' }
package Class::C;
use Moose;
-
+
::throws_ok {
with qw(Role::I);
} qr/requires.*'foo'/, "defining class Class::C fails";
::lives_ok {
with qw(Role::I);
- } "resolved with method";
+ } "resolved with method";
sub foo { 'Class::E::foo' }
- sub zot { 'Class::E::zot' }
+ sub zot { 'Class::E::zot' }
}
can_ok( Class::E->new, qw(foo bar xxy zot) );
{
package Foo::Role;
use Moose::Role;
-
+
sub foo { 'Foo::Role::foo' }
-
+
package Bar::Role;
use Moose::Role;
-
- sub foo { 'Bar::Role::foo' }
+
+ sub foo { 'Bar::Role::foo' }
package Baz::Role;
use Moose::Role;
-
- sub foo { 'Baz::Role::foo' }
-
+
+ sub foo { 'Baz::Role::foo' }
+
package My::Foo::Class;
use Moose;
-
+
::lives_ok {
with 'Foo::Role' => { excludes => 'foo' },
- 'Bar::Role' => { excludes => 'foo' },
+ 'Bar::Role' => { excludes => 'foo' },
'Baz::Role';
} '... composed our roles correctly';
-
+
package My::Foo::Class::Broken;
use Moose;
-
+
::throws_ok {
with 'Foo::Role',
- 'Bar::Role' => { excludes => 'foo' },
+ 'Bar::Role' => { excludes => 'foo' },
'Baz::Role';
- } qr/\'Foo::Role\|Bar::Role\|Baz::Role\' requires the method \'foo\' to be implemented by \'My::Foo::Class::Broken\'/,
- '... composed our roles correctly';
+ } qr/\'Foo::Role\|Bar::Role\|Baz::Role\' requires the method \'foo\' to be implemented by \'My::Foo::Class::Broken\'/,
+ '... composed our roles correctly';
}
{
::lives_ok {
with 'Foo::Role' => { excludes => 'foo' },
- 'Bar::Role' => { excludes => 'foo' },
+ 'Bar::Role' => { excludes => 'foo' },
'Baz::Role';
} '... composed our roles correctly';
}
::lives_ok {
with 'Foo::Role',
- 'Bar::Role' => { excludes => 'foo' },
+ 'Bar::Role' => { excludes => 'foo' },
'Baz::Role';
} '... composed our roles correctly';
}
sub foo { 'Foo::foo' }
sub bar { 'Foo::bar' }
sub baz { 'Foo::baz' }
-
+
requires 'role_bar';
package My::Class;
::lives_ok {
with 'My::Role' => { alias => { bar => 'role_bar' } };
} '... this succeeds';
-
+
package My::Class::Failure;
use Moose;
::throws_ok {
with 'My::Role' => { alias => { bar => 'role_bar' } };
- } qr/Cannot create a method alias if a local method of the same name exists/, '... this succeeds';
-
+ } qr/Cannot create a method alias if a local method of the same name exists/, '... this succeeds';
+
sub role_bar { 'FAIL' }
}
} '... this succeeds';
sub bar { 'My::OtherRole::bar' }
-
+
package My::OtherRole::Failure;
use Moose::Role;
::throws_ok {
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' }
+ } qr/Cannot create a method alias if a local method of the same name exists/, '... this succeeds';
+
+ sub role_bar { 'FAIL' }
}
ok(My::OtherRole->meta->has_method($_), "we have a $_ method") for qw(foo baz role_bar);
{
package Foo::Role;
use Moose::Role;
-
+
sub foo { 'Foo::Role::foo' }
-
+
package Bar::Role;
use Moose::Role;
-
- sub foo { 'Bar::Role::foo' }
+
+ sub foo { 'Bar::Role::foo' }
package Baz::Role;
use Moose::Role;
-
- sub foo { 'Baz::Role::foo' }
-
+
+ sub foo { 'Baz::Role::foo' }
+
package My::Foo::Class;
use Moose;
-
+
::lives_ok {
with 'Foo::Role' => { alias => { 'foo' => 'foo_foo' }, excludes => 'foo' },
- 'Bar::Role' => { alias => { 'foo' => 'bar_foo' }, excludes => 'foo' },
+ 'Bar::Role' => { alias => { 'foo' => 'bar_foo' }, excludes => 'foo' },
'Baz::Role';
- } '... composed our roles correctly';
-
+ } '... composed our roles correctly';
+
package My::Foo::Class::Broken;
use Moose;
-
+
::throws_ok {
with 'Foo::Role' => { alias => { 'foo' => 'foo_foo' }, excludes => 'foo' },
- 'Bar::Role' => { alias => { 'foo' => 'foo_foo' }, excludes => 'foo' },
+ 'Bar::Role' => { alias => { 'foo' => 'foo_foo' }, excludes => 'foo' },
'Baz::Role';
- } qr/\'Foo::Role\|Bar::Role\|Baz::Role\' requires the method \'foo_foo\' to be implemented by \'My::Foo::Class::Broken\'/,
- '... composed our roles correctly';
+ } qr/\'Foo::Role\|Bar::Role\|Baz::Role\' requires the method \'foo_foo\' to be implemented by \'My::Foo::Class::Broken\'/,
+ '... composed our roles correctly';
}
{
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');
+ is($foo->foo_foo, 'Foo::Role::foo', '... got the right method');
+ is($foo->bar_foo, 'Bar::Role::foo', '... got the right method');
}
{
::lives_ok {
with 'Foo::Role' => { alias => { 'foo' => 'foo_foo' }, excludes => 'foo' },
- 'Bar::Role' => { alias => { 'foo' => 'bar_foo' }, excludes => 'foo' },
+ 'Bar::Role' => { alias => { 'foo' => 'bar_foo' }, excludes => 'foo' },
'Baz::Role';
} '... composed our roles correctly';
}
::lives_ok {
with 'Foo::Role' => { alias => { 'foo' => 'foo_foo' }, excludes => 'foo' },
- 'Bar::Role' => { alias => { 'foo' => 'foo_foo' }, excludes => 'foo' },
+ 'Bar::Role' => { alias => { 'foo' => 'foo_foo' }, excludes => 'foo' },
'Baz::Role';
} '... composed our roles correctly';
}
{
package Foo;
use Moose::Role;
-
+
sub foo { 'Foo::foo' }
sub bar { 'Foo::bar' }
sub baz { 'Foo::baz' }
- sub gorch { 'Foo::gorch' }
-
+ 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' }
+ 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' }
-
+ 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' }
+ sub gorch { 'Gorch::gorch' }
}
{
package My::Class;
use Moose;
-
+
::lives_ok {
with 'Foo' => { excludes => [qw/bar baz gorch/], alias => { gorch => 'foo_gorch' } },
'Bar' => { excludes => [qw/foo baz gorch/] },
}
my $obj = Foo->new;
-isa_ok($obj, 'Foo');
+isa_ok($obj, 'Foo');
ok(!$obj->can( 'talk' ), "... the role is not composed yet");
ok(!$obj->can( 'fur' ), 'ditto');
}
my $bar = Bar->new;
-isa_ok($bar, 'Bar');
+isa_ok($bar, 'Bar');
my $foo = Foo->new;
-isa_ok($foo, 'Foo');
+isa_ok($foo, 'Foo');
ok(!$bar->can( 'talk' ), "... the role is not composed yet");
=pod
-This basically just makes sure that using +name
+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',
+ isa => 'Int',
default => sub { 10 },
);
-
+
package Foo;
use Moose;
-
+
with 'Foo::Role';
-
+
::lives_ok {
has '+bar' => (default => sub { 100 });
- } '... extended the attribute successfully';
+ } '... extended the attribute successfully';
}
my $foo = Foo->new;
package Foo;
use Moose;
has 'bar' => (is => 'ro');
-
+
package Bar;
use Moose::Role;
-
- has 'baz' => (is => 'ro', default => 'BAZ');
+
+ has 'baz' => (is => 'ro', default => 'BAZ');
}
# normal ...
{
package Role::Foo;
use Moose::Role;
-
+
package Role::Bar;
use Moose::Role;
package Role::Baz;
- use Moose::Role;
-
+ use Moose::Role;
+
package Role::Gorch;
- use Moose::Role;
+ use Moose::Role;
}
{
roles => [
Role::Foo->meta,
Role::Bar->meta,
- Role::Baz->meta,
+ Role::Baz->meta,
]
);
isa_ok($c, 'Moose::Meta::Role::Composite');
is_deeply($c->get_roles, [
Role::Foo->meta,
Role::Bar->meta,
- Role::Baz->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
+ Role::Baz
);
-
+
lives_ok {
Moose::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this composed okay';
-
+ } '... this composed okay';
+
##... now nest 'em
- {
+ {
my $c2 = Moose::Meta::Role::Composite->new(
roles => [
$c,
is_deeply($c2->get_roles, [
$c,
- Role::Gorch->meta,
+ 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
- );
+ Role::Baz
+ Role::Gorch
+ );
}
}
{
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';
-
+ with 'Role::ExcludesFoo';
+
package Role::DoesFoo;
use Moose::Role;
- with 'Role::Foo';
+ with 'Role::Foo';
}
ok(Role::ExcludesFoo->meta->excludes_role('Role::Foo'), '... got the right exclusions');
isa_ok($c, 'Moose::Meta::Role::Composite');
is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
-
+
lives_ok {
Moose::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this lives as expected';
+ } '... this lives as expected';
}
# test no conflicts w/exclusion
my $c = Moose::Meta::Role::Composite->new(
roles => [
Role::Bar->meta,
- Role::ExcludesFoo->meta,
+ Role::ExcludesFoo->meta,
]
);
isa_ok($c, 'Moose::Meta::Role::Composite');
is($c->name, 'Role::Bar|Role::ExcludesFoo', '... got the composite role name');
-
+
lives_ok {
Moose::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this lives as expected';
-
- is_deeply([$c->get_excluded_roles_list], ['Role::Foo'], '... has excluded roles');
+ } '... this lives as expected';
+
+ is_deeply([$c->get_excluded_roles_list], ['Role::Foo'], '... has excluded roles');
}
]
)
);
-
+
} '... this fails as expected';
# test conflict with an "inherited" exclusion of an "inherited" role
dies_ok {
Moose::Meta::Role::Application::RoleSummation->new->apply(
- Moose::Meta::Role::Composite->new(
+ Moose::Meta::Role::Composite->new(
roles => [
- Role::DoesFoo->meta,
+ Role::DoesFoo->meta,
Role::DoesExcludesFoo->meta,
]
)
{
package Role::Foo;
- use Moose::Role;
+ use Moose::Role;
requires 'foo';
-
+
package Role::Bar;
use Moose::Role;
requires 'bar';
-
+
package Role::ProvidesFoo;
- use Moose::Role;
+ use Moose::Role;
sub foo { 'Role::ProvidesFoo::foo' }
-
+
package Role::ProvidesBar;
- use Moose::Role;
- sub bar { 'Role::ProvidesBar::bar' }
+ use Moose::Role;
+ sub bar { 'Role::ProvidesBar::bar' }
}
# test simple requirement
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($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
+
lives_ok {
Moose::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this succeeds as expected';
-
+ } '... this succeeds as expected';
+
is_deeply(
[ sort $c->get_required_method_list ],
[ 'bar', 'foo' ],
);
isa_ok($c, 'Moose::Meta::Role::Composite');
- is($c->name, 'Role::Foo|Role::ProvidesFoo', '... got the composite role name');
-
- lives_ok {
+ is($c->name, 'Role::Foo|Role::ProvidesFoo', '... got the composite role name');
+
+ lives_ok {
Moose::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this succeeds as expected';
-
+ } '... this succeeds as expected';
+
is_deeply(
[ sort $c->get_required_method_list ],
[],
roles => [
Role::Foo->meta,
Role::ProvidesFoo->meta,
- Role::Bar->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($c->name, 'Role::Foo|Role::ProvidesFoo|Role::Bar', '... got the composite role name');
+
lives_ok {
Moose::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this succeeds as expected';
-
+ } '... this succeeds as expected';
+
is_deeply(
[ sort $c->get_required_method_list ],
[ 'bar' ],
roles => [
Role::Foo->meta,
Role::ProvidesFoo->meta,
- Role::ProvidesBar->meta,
- Role::Bar->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($c->name, 'Role::Foo|Role::ProvidesFoo|Role::ProvidesBar|Role::Bar', '... got the composite role name');
+
lives_ok {
Moose::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this succeeds as expected';
-
+ } '... this succeeds as expected';
+
is_deeply(
[ sort $c->get_required_method_list ],
[ ],
{
package Role::Foo;
- use Moose::Role;
+ use Moose::Role;
has 'foo' => (is => 'rw');
-
+
package Role::Bar;
use Moose::Role;
has 'bar' => (is => 'rw');
-
+
package Role::FooConflict;
- use Moose::Role;
+ use Moose::Role;
has 'foo' => (is => 'rw');
-
+
package Role::BarConflict;
use Moose::Role;
has 'bar' => (is => 'rw');
-
+
package Role::AnotherFooConflict;
- use Moose::Role;
+ use Moose::Role;
with 'Role::FooConflict';
}
);
isa_ok($c, 'Moose::Meta::Role::Composite');
- is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
-
+ is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
+
lives_ok {
Moose::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this succeeds as expected';
-
+ } '... this succeeds as expected';
+
is_deeply(
[ sort $c->get_attribute_list ],
[ 'bar', 'foo' ],
Moose::Meta::Role::Composite->new(
roles => [
Role::Foo->meta,
- Role::Bar->meta,
+ Role::Bar->meta,
Role::FooConflict->meta,
- Role::BarConflict->meta,
+ Role::BarConflict->meta,
]
)
);
{
package Role::Foo;
use Moose::Role;
-
- sub foo { 'Role::Foo::foo' }
-
+
+ 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' }
-
+ 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;
+ use Moose::Role;
with 'Role::FooConflict';
sub baz { 'Role::AnotherFooConflict::baz' }
);
isa_ok($c, 'Moose::Meta::Role::Composite');
- is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
-
+ is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
+
lives_ok {
Moose::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this succeeds as expected';
-
+ } '... this succeeds as expected';
+
is_deeply(
[ sort $c->get_method_list ],
[ 'bar', 'foo' ],
);
isa_ok($c, 'Moose::Meta::Role::Composite');
- is($c->name, 'Role::Foo|Role::FooConflict', '... got the composite role name');
-
+ is($c->name, 'Role::Foo|Role::FooConflict', '... got the composite role name');
+
lives_ok {
Moose::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this succeeds as expected';
-
+ } '... 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::Bar->meta,
Role::FooConflict->meta,
- Role::BarConflict->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($c->name, 'Role::Foo|Role::Bar|Role::FooConflict|Role::BarConflict', '... got the composite role name');
lives_ok {
Moose::Meta::Role::Application::RoleSummation->new->apply($c);
[ 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
);
isa_ok($c, 'Moose::Meta::Role::Composite');
- is($c->name, 'Role::Foo|Role::AnotherFooConflict', '... got the composite role name');
-
+ is($c->name, 'Role::Foo|Role::AnotherFooConflict', '... got the composite role name');
+
lives_ok {
Moose::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this succeeds as expected';
-
+ } '... 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'
- );
+ );
}
{
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;
-
+ use Moose::Role;
+
override foo => sub { 'Role::FooConflict::foo' };
-
+
package Role::FooMethodConflict;
- use Moose::Role;
-
- sub foo { 'Role::FooConflict::foo' }
-
+ use Moose::Role;
+
+ sub foo { 'Role::FooConflict::foo' }
+
package Role::BarMethodConflict;
use Moose::Role;
-
+
sub bar { 'Role::BarConflict::bar' }
}
);
isa_ok($c, 'Moose::Meta::Role::Composite');
- is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
-
+ is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
+
lives_ok {
Moose::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this lives ok';
-
+ } '... this lives ok';
+
is_deeply(
[ sort $c->get_method_modifier_list('override') ],
[ 'bar', 'foo' ],
# test simple overrides w/ conflicts
dies_ok {
Moose::Meta::Role::Application::RoleSummation->new->apply(
- Moose::Meta::Role::Composite->new(
+ Moose::Meta::Role::Composite->new(
roles => [
Role::Foo->meta,
Role::FooMethodConflict->meta,
Moose::Meta::Role::Composite->new(
roles => [
Role::Foo->meta,
- Role::Bar->meta,
- Role::FooConflict->meta,
+ Role::Bar->meta,
+ Role::FooConflict->meta,
]
)
);
# test simple overrides w/ conflicts
dies_ok {
Moose::Meta::Role::Application::RoleSummation->new->apply(
- Moose::Meta::Role::Composite->new(
+ Moose::Meta::Role::Composite->new(
roles => [
Role::Foo->meta,
- Role::Bar->meta,
- Role::FooMethodConflict->meta,
+ Role::Bar->meta,
+ Role::FooMethodConflict->meta,
]
)
);
use Moose::Role;
before foo => sub { 'Role::Foo::foo' };
- around foo => sub { 'Role::Foo::foo' };
- after 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' };
+ around bar => sub { 'Role::Bar::bar' };
+ after bar => sub { 'Role::Bar::bar' };
package Role::Baz;
use Moose::Role;
);
isa_ok($c, 'Moose::Meta::Role::Composite');
- is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
+ is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
lives_ok {
Moose::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this succeeds as expected';
+ } '... this succeeds as expected';
is_deeply(
[ sort $c->get_method_modifier_list('before') ],
[ 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'
- );
+ );
}
{
package My::Role;
use Moose::Role;
-
+
sub foo { "FOO" }
- sub bar { "BAR" }
+ sub bar { "BAR" }
}
{
package My::Class;
use Moose;
-
+
with 'My::Role' => {
alias => { foo => 'baz', bar => 'gorch' },
- excludes => ['foo', 'bar'],
+ excludes => ['foo', 'bar'],
};
}
{
package My::Role::Again;
use Moose::Role;
-
+
with 'My::Role' => {
alias => { foo => 'baz', bar => 'gorch' },
- excludes => ['foo', 'bar'],
+ excludes => ['foo', 'bar'],
};
-
+
package My::Class::Again;
use Moose;
-
+
with 'My::Role::Again';
}
type Number => where { Scalar::Util::looks_like_number($_) };
-type String
+type String
=> where { !ref($_) && !Number($_) }
=> message { "This is not a string ($_)" };
-subtype Natural
- => as Number
+subtype Natural
+ => as Number
=> where { $_ > 0 };
-subtype NaturalLessThanTen
+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');
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
-
+
+# 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(!$negative2->is_subtype_of('String'), '... $negative is not a subtype of String');
ok($negative2->has_message, '... it has a message');
-is($negative2->validate(2),
+is($negative2->validate(2),
'2 is not a negative number',
'... validated unsuccessfully (got error)');
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",
+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');
ok(!defined($natural->validate(5)), '... validated successfully (no error)');
-is($natural->validate(-5),
- "Validation failed for 'Natural' failed with value -5",
+is($natural->validate(-5),
+ "Validation failed for 'Natural' failed with value -5",
'... validated unsuccessfully (got error)');
my $string = find_type_constraint('String');
ok(!defined($string->validate("Five")), '... validated successfully (no error)');
-is($string->validate(5),
-"This is not a string (5)",
+is($string->validate(5),
+"This is not a string (5)",
'... validated unsuccessfully (got error)');
lives_ok { Moose::Meta::Attribute->new('bob', isa => 'Spong') }
use Scalar::Util ();
BEGIN {
- use_ok('Moose::Util::TypeConstraints');
+ use_ok('Moose::Util::TypeConstraints');
}
my $SCALAR_REF = \(my $var);
foreach my $type_name (qw(
Any
- Item
+ Item
Bool
Undef
Defined
HashRef
CodeRef
RegexpRef
- Object
+ Object
Role
)) {
- is(find_type_constraint($type_name)->name,
- $type_name,
+ is(find_type_constraint($type_name)->name,
+ $type_name,
'... got the right name for ' . $type_name);
}
{
package HTTPHeader;
use Moose;
-
+
has 'array' => (is => 'ro');
- has 'hash' => (is => 'ro');
+ has 'hash' => (is => 'ro');
}
-subtype Header =>
- => as Object
+subtype Header =>
+ => as Object
=> where { $_->isa('HTTPHeader') };
-
-coerce Header
- => from ArrayRef
+
+coerce Header
+ => from ArrayRef
=> via { HTTPHeader->new(array => $_[0]) }
- => from HashRef
+ => from HashRef
=> via { HTTPHeader->new(hash => $_[0]) };
-
-Moose::Util::TypeConstraints->export_type_constraints_as_functions();
-
+
+Moose::Util::TypeConstraints->export_type_constraints_as_functions();
+
my $header = HTTPHeader->new();
isa_ok($header, 'HTTPHeader');
lives_ok {
coerce $anon_type
- => from ArrayRef
+ => from ArrayRef
=> via { HTTPHeader->new(array => $_[0]) }
- => from HashRef
+ => from HashRef
=> via { HTTPHeader->new(hash => $_[0]) };
} 'coercion of anonymous subtype succeeds';
) {
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');
+ 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');
+ 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');
package HTTPHeader;
use Moose;
use Moose::Util::TypeConstraints;
-
+
coerce 'HTTPHeader'
- => from ArrayRef
+ => from ArrayRef
=> via { HTTPHeader->new(array => $_[0]) };
-
+
coerce 'HTTPHeader'
- => from HashRef
- => via { HTTPHeader->new(hash => $_[0]) };
-
+ => from HashRef
+ => via { HTTPHeader->new(hash => $_[0]) };
+
has 'array' => (is => 'ro');
- has 'hash' => (is => 'ro');
+ has 'hash' => (is => 'ro');
package Engine;
use strict;
use warnings;
use Moose;
-
- has 'header' => (is => 'rw', isa => 'HTTPHeader', coerce => 1);
+
+ has 'header' => (is => 'rw', isa => 'HTTPHeader', coerce => 1);
}
{
ok(!defined($engine->header->array), '... no array value set');
dies_ok {
- $engine->header("Foo");
+ $engine->header("Foo");
} '... dies with the wrong type, even after coercion';
lives_ok {
- $engine->header(HTTPHeader->new);
+ $engine->header(HTTPHeader->new);
} '... lives with the right type, even after coercion';
}
use Test::Exception;
BEGIN {
- use_ok('Moose::Util::TypeConstraints');
+ use_ok('Moose::Util::TypeConstraints');
}
my $Str = find_type_constraint('Str');
ok(!defined($HashOrArray->validate([])), '... (ArrayRef | HashRef) can accept []');
ok(!defined($HashOrArray->validate({})), '... (ArrayRef | HashRef) can accept {}');
-like($HashOrArray->validate(\(my $var2)),
-qr/Validation failed for \'ArrayRef\' failed with value SCALAR\(0x.+?\) and Validation failed for \'HashRef\' failed with value SCALAR\(0x.+?\) in \(ArrayRef\|HashRef\)/,
+like($HashOrArray->validate(\(my $var2)),
+qr/Validation failed for \'ArrayRef\' failed with value SCALAR\(0x.+?\) and Validation failed for \'HashRef\' failed with value SCALAR\(0x.+?\) in \(ArrayRef\|HashRef\)/,
'... (ArrayRef | HashRef) cannot accept scalar refs');
-like($HashOrArray->validate(sub {}),
-qr/Validation failed for \'ArrayRef\' failed with value CODE\(0x.+?\) and Validation failed for \'HashRef\' failed with value CODE\(0x.+?\) in \(ArrayRef\|HashRef\)/,
+like($HashOrArray->validate(sub {}),
+qr/Validation failed for \'ArrayRef\' failed with value CODE\(0x.+?\) and Validation failed for \'HashRef\' failed with value CODE\(0x.+?\) in \(ArrayRef\|HashRef\)/,
'... (ArrayRef | HashRef) cannot accept code refs');
is($HashOrArray->validate(50),
-'Validation failed for \'ArrayRef\' failed with value 50 and Validation failed for \'HashRef\' failed with value 50 in (ArrayRef|HashRef)',
+'Validation failed for \'ArrayRef\' failed with value 50 and Validation failed for \'HashRef\' failed with value 50 in (ArrayRef|HashRef)',
'... (ArrayRef | HashRef) cannot accept Numbers');
BEGIN {
eval "use IO::String; use IO::File;";
- plan skip_all => "IO::String and IO::File are required for this test" if $@;
- plan tests => 28;
+ plan skip_all => "IO::String and IO::File are required for this test" if $@;
+ plan tests => 28;
}
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',
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($email->as_string, '... this is my body ...', '... got correct string');
+
lives_ok {
- $email->raw_body('... this is the next body ...');
+ $email->raw_body('... this is the next body ...');
} '... this will coerce correctly';
-
+
isa_ok($email->raw_body, 'IO::String');
-
- is($email->as_string, '... this is the next body ...', '... got correct 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($email->as_string, $str, '... got correct string');
+
+ my $str2 = '... this is the next body (ref) ...';
+
lives_ok {
- $email->raw_body(\$str2);
+ $email->raw_body(\$str2);
} '... this will coerce correctly';
-
+
isa_ok($email->raw_body, 'IO::String');
-
- is($email->as_string, $str2, '... got correct 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($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) ...');
+
lives_ok {
- $email->raw_body($io_str2);
+ $email->raw_body($io_str2);
} '... 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');
+
+ 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');
}
use Test::Exception;
BEGIN {
- use_ok('Moose::Util::TypeConstraints');
+ use_ok('Moose::Util::TypeConstraints');
}
# subtype 'aliasing' ...
use Test::More tests => 24;
use Test::Exception;
-BEGIN {
- use_ok('Moose::Util::TypeConstraints');
- use_ok('Moose::Meta::TypeConstraint::Parameterized');
+BEGIN {
+ use_ok('Moose::Util::TypeConstraints');
+ use_ok('Moose::Meta::TypeConstraint::Parameterized');
}
# Array of Ints
use Test::More tests => 10;
use Test::Exception;
-BEGIN {
- use_ok('Moose::Util::TypeConstraints');
- use_ok('Moose::Meta::TypeConstraint::Parameterized');
+BEGIN {
+ use_ok('Moose::Util::TypeConstraints');
+ use_ok('Moose::Meta::TypeConstraint::Parameterized');
}
my $r = Moose::Util::TypeConstraints->get_type_constraint_registry;
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 });
use Test::More tests => 33;
use Test::Exception;
-BEGIN {
- use_ok('Moose::Util::TypeConstraints');
- use_ok('Moose::Meta::TypeConstraint::Parameterized');
+BEGIN {
+ use_ok('Moose::Util::TypeConstraints');
+ use_ok('Moose::Meta::TypeConstraint::Parameterized');
}
my $r = Moose::Util::TypeConstraints->get_type_constraint_registry;
# union of Arrays of Str | Int or Arrays of Int | Hash
-# we can't build this using the simplistic parser
+# 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]');
## check the containers
-ok(Moose::Util::TypeConstraints::_detect_parameterized_type_constraint($_),
+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]]',
+ 'ArrayRef[ArrayRef[Int]]',
+ 'ArrayRef[ArrayRef[Int | Foo]]',
+ 'ArrayRef[ArrayRef[Int|Str]]',
);
-ok(!Moose::Util::TypeConstraints::_detect_parameterized_type_constraint($_),
+ok(!Moose::Util::TypeConstraints::_detect_parameterized_type_constraint($_),
'... this correctly detected a non-container (' . $_ . ')')
for (
'ArrayRef[]',
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,
+ '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]]' => [ 'ArrayRef', 'ArrayRef[Int]' ],
'ArrayRef[ArrayRef[Int | Foo]]' => [ 'ArrayRef', 'ArrayRef[Int | Foo]' ],
- 'ArrayRef[ArrayRef[Int|Str]]' => [ 'ArrayRef', 'ArrayRef[Int|Str]' ],
+ 'ArrayRef[ArrayRef[Int|Str]]' => [ 'ArrayRef', 'ArrayRef[Int|Str]' ],
);
is_deeply(
## now for the unions
-ok(Moose::Util::TypeConstraints::_detect_type_constraint_union($_),
+ok(Moose::Util::TypeConstraints::_detect_type_constraint_union($_),
'... this correctly detected union (' . $_ . ')')
for (
'Int | Str',
- 'Int|Str',
+ 'Int|Str',
'ArrayRef[Foo] | Int',
- 'ArrayRef[Foo]|Int',
+ 'ArrayRef[Foo]|Int',
'Int | ArrayRef[Foo]',
- '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',
+ '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($_),
+ok(!Moose::Util::TypeConstraints::_detect_type_constraint_union($_),
'... this correctly detected a non-union (' . $_ . ')')
for (
'Int',
'ArrayRef[Foo | Int]',
- 'ArrayRef[Foo|Int]',
+ 'ArrayRef[Foo|Int]',
);
{
my %split_tests = (
'Int | Str' => [ 'Int', 'Str' ],
- 'Int|Str' => [ 'Int', 'Str' ],
+ 'Int|Str' => [ 'Int', 'Str' ],
'ArrayRef[Foo] | Int' => [ 'ArrayRef[Foo]', 'Int' ],
- 'ArrayRef[Foo]|Int' => [ 'ArrayRef[Foo]', 'Int' ],
+ 'ArrayRef[Foo]|Int' => [ 'ArrayRef[Foo]', 'Int' ],
'Int | ArrayRef[Foo]' => [ 'Int', 'ArrayRef[Foo]' ],
- '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' ],
+ '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(
}
lives_ok {
- subtype 'MySpecialHashExtended'
+ subtype 'MySpecialHashExtended'
=> as 'HashRef[Int]'
=> where {
# all values are less then 10
## 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 $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 ! $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 ! $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';
-
+
throws_ok sub {
my $SubOfMyArrayRef = subtype 'SubSubOfMyArrayRef',
- as 'SubOfMyArrayRef[Str]';
+ as 'SubOfMyArrayRef[Str]';
}, qr/Str is not a subtype of BiggerInt/, 'Failed to parameterize with a bad type parameter';
}
is($p->name, 'ArrayRef|HashRef', '... parent name is correct');
ok($t->check([]), '... validated it correctly');
- ok($t->check({}), '... validated it correctly');
+ ok($t->check({}), '... validated it correctly');
ok(!$t->check(1), '... validated it correctly');
}
lives_ok {
- subtype 'MyCollectionsExtended'
+ subtype 'MyCollectionsExtended'
=> as 'ArrayRef|HashRef'
=> where {
if (ref($_) eq 'ARRAY') {
return if scalar(@$_) < 2;
}
elsif (ref($_) eq 'HASH') {
- return if scalar(keys(%$_)) < 2;
+ return if scalar(keys(%$_)) < 2;
}
1;
};
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, 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');
}
package Foo;
use Moose;
use Moose::Util::TypeConstraints;
-
- has 'arr' => (is => 'rw', isa => 'Maybe[ArrayRef]', required => 1);
+
+ 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')));
}
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]]');
+ 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
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 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 ("")';
-
-throws_ok sub { $obj->Maybe_Int("") },
+
+throws_ok sub { $obj->Maybe_Int("") },
qr/Attribute \(Maybe_Int\) does not pass the type constraint/
=> 'failed assigned ("")';
ok !$Maybe_Int->check("a")
=> 'failed ("a")';
-throws_ok sub { $obj->Maybe_Int("a") },
+throws_ok sub { $obj->Maybe_Int("a") },
qr/Attribute \(Maybe_Int\) does not pass the type constraint/
=> 'failed assigned ("a")';
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 a Int');
ok(Number(5), '... 5 is a Number');
-ok(Str(5), '... 5 is a Str');
+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 a 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 a Int');
lives_ok { $foo->vUndef(undef) } '... undef is a Foo->Undef';
dies_ok { $foo->vDefined(undef) } '... undef is NOT a Foo->Defined';
-dies_ok { $foo->vInt(undef) } '... undef is NOT a Foo->Int';
-dies_ok { $foo->vNumber(undef) } '... undef is NOT a Foo->Number';
-dies_ok { $foo->vStr(undef) } '... undef is NOT a Foo->Str';
-dies_ok { $foo->vString(undef) } '... undef is NOT a Foo->String';
+dies_ok { $foo->vInt(undef) } '... undef is NOT a Foo->Int';
+dies_ok { $foo->vNumber(undef) } '... undef is NOT a Foo->Number';
+dies_ok { $foo->vStr(undef) } '... undef is NOT a Foo->Str';
+dies_ok { $foo->vString(undef) } '... undef is NOT a Foo->String';
dies_ok { $foo->vUndef(5) } '... 5 is NOT a Foo->Undef';
lives_ok { $foo->vDefined(5) } '... 5 is a Foo->Defined';
lives_ok { $foo->vInt(5) } '... 5 is a Foo->Int';
lives_ok { $foo->vNumber(5) } '... 5 is a Foo->Number';
-lives_ok { $foo->vStr(5) } '... 5 is a Foo->Str';
+lives_ok { $foo->vStr(5) } '... 5 is a Foo->Str';
dies_ok { $foo->vString(5) } '... 5 is NOT a Foo->String';
dies_ok { $foo->vUndef(0.5) } '... 0.5 is NOT a Foo->Undef';
lives_ok { $foo->vStr('Foo') } '... "Foo" is a Foo->Str';
lives_ok { $foo->vString('Foo') } '... "Foo" is a Foo->String';
-# the lazy tests
+# the lazy tests
lives_ok { $foo->v_lazy_Undef() } '... undef is a Foo->Undef';
dies_ok { $foo->v_lazy_Defined() } '... undef is NOT a Foo->Defined';
-dies_ok { $foo->v_lazy_Int() } '... undef is NOT a Foo->Int';
-dies_ok { $foo->v_lazy_Number() } '... undef is NOT a Foo->Number';
-dies_ok { $foo->v_lazy_Str() } '... undef is NOT a Foo->Str';
-dies_ok { $foo->v_lazy_String() } '... undef is NOT a Foo->String';
+dies_ok { $foo->v_lazy_Int() } '... undef is NOT a Foo->Int';
+dies_ok { $foo->v_lazy_Number() } '... undef is NOT a Foo->Number';
+dies_ok { $foo->v_lazy_Str() } '... undef is NOT a Foo->Str';
+dies_ok { $foo->v_lazy_String() } '... undef is NOT a Foo->String';
=> where { /^6$/ };
subtype 'TextSix' => as 'Str'
=> where { /Six/i };
- coerce 'TextSix'
- => from 'DigitSix'
+ coerce 'TextSix'
+ => from 'DigitSix'
=> via { confess("Cannot live without 6 ($_)") unless /^6$/; 'Six' };
has foo => (
use Test::Exception;
BEGIN {
- use_ok('Moose::Util::TypeConstraints');
+ use_ok('Moose::Util::TypeConstraints');
}
## First, we check that the new regex parsing works
use Test::Exception;
BEGIN {
- use_ok('Moose::Util::TypeConstraints');
+ use_ok('Moose::Util::TypeConstraints');
}
# testing the parameterize method
package Test::Moose::Meta::TypeConstraint::AnySubType;
use Moose;
extends 'Moose::Meta::TypeConstraint';
-
+
sub my_custom_method {
return 1;
}
{
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',
{
package My::Class;
use Moose;
-
+
with 'My::Fancy::Role';
}
lives_ok {
package Moose::Meta::Attribute::Custom::Test;
use Moose;
-
+
extends 'Moose::Meta::Attribute';
with 'MooseX::Attribute::Test';
} 'custom attribute metaclass extending role is okay';
=pod
-This test demonstrates that Moose will respect
-a metaclass previously set with the metaclass
-pragma.
+This test demonstrates that Moose will respect
+a metaclass previously set with the metaclass
+pragma.
-It also checks an error condition where that
+It also checks an error condition where that
metaclass must be a Moose::Meta::Class subclass
in order to work.
use warnings;
use base 'Moose::Meta::Class';
-
+
package Foo;
use strict;
use warnings;
package Bar::Meta;
use strict;
use warnings;
-
+
use base '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($@,
+ ::like($@,
qr/^Bar already has a metaclass, but it does not inherit Moose::Meta::Class/,
'... got the right error too');
}
{
package My::Meta::Class;
use Moose;
-
+
extends 'Moose::Meta::Class';
-
+
around 'create_anon_class' => sub {
my $next = shift;
my ($self, %options) = @_;
isa_ok($anon, 'Class::MOP::Class');
is_deeply(
- [ $anon->superclasses ],
- [ 'Moose::Object' ],
+ [ $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'
+ $options{is} = 'ro'
unless exists $options{is};
$next->($self, $name, %options);
- };
+ };
}
{
BEGIN {
package MyFramework::Base;
use Moose;
-
+
package MyFramework::Meta::Base;
- use Moose;
-
- extends 'Moose::Meta::Class';
-
+ use Moose;
+
+ extends 'Moose::Meta::Class';
+
package MyFramework;
use Moose;
strict->import;
warnings->import;
-
+
return if $CALLER eq 'main';
Moose::init_meta( $CALLER, 'MyFramework::Base', 'MyFramework::Meta::Base' );
Moose->import({ into => $CALLER });
}
}
-{
+{
package MyClass;
BEGIN { MyFramework->import }
-
+
has 'foo' => (is => 'rw');
}
shift;
my %p = @_;
Moose->init_meta(%p);
- return Moose::Util::MetaRole::apply_metaclass_roles(
+ return Moose::Util::MetaRole::apply_metaclass_roles(
for_class => $p{for_class},
# Causes us to recurse through init_meta, as we have to
# load MyMetaclassRole from disk.
BEGIN {
eval "use Module::Refresh;";
- plan skip_all => "Module::Refresh is required for this test" if $@;
- plan tests => 23;
+ plan skip_all => "Module::Refresh is required for this test" if $@;
+ plan tests => 23;
}
=pod
First lets test some of our simple example modules ...
-=cut
+=cut
my @modules = qw[Foo Bar MyMooseA MyMooseB MyMooseObject];
do {
use_ok($_);
-
+
is($_->meta->name, $_, '... initialized the meta correctly');
-
+
lives_ok {
Module::Refresh->new->refresh_module($_ . '.pm')
- } '... successfully refreshed ' . $_;
+ } '... successfully refreshed ' . $_;
} foreach @modules;
=pod
|;
{
- open FILE, ">", $test_module_file
+ open FILE, ">", $test_module_file
|| die "Could not open $test_module_file because $!";
print FILE $test_module_source_1;
close FILE;
ok(!TestBaz->isa('Foo'), '... TestBaz is not a Foo');
{
- open FILE, ">", $test_module_file
+ open FILE, ">", $test_module_file
|| die "Could not open $test_module_file because $!";
print FILE $test_module_source_2;
close FILE;
=pod
-This test demonstrates that Moose will respect
-a previously set @ISA using use base, and not
-try to add Moose::Object to it.
+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
+However, this is extremely order sensitive as
this test also demonstrates.
=cut
package Foo;
use strict;
use warnings;
-
+
sub foo { 'Foo::foo' }
-
- package Bar;
+
+ package Bar;
use base 'Foo';
use Moose;
-
- sub new { (shift)->meta->new_object(@_) }
-
+
+ sub new { (shift)->meta->new_object(@_) }
+
package Baz;
- use Moose;
- use base 'Foo';
+ use Moose;
+ use base 'Foo';
}
my $bar = Bar->new;
subtype Stuff
=> as Object
=> where { ... }
-
-will break if the Object:: namespace exists. So the
+
+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.
+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');
+::use_ok('Moose');
=pod
-This just makes sure that the Bar gets
+This just makes sure that the Bar gets
a metaclass initialized for it correctly.
=cut
{
- package Foo;
- use Moose;
+ package Foo;
+ use Moose;
- package Bar;
+ package Bar;
use strict;
use warnings;
-
- use base 'Foo';
+
+ use base 'Foo';
}
my $bar = Bar->new;
=pod
-This was a bug, but it is fixed now. This
+This was a bug, but it is fixed now. This
test makes sure it does not creep back in.
=cut
{
package Foo;
use Moose;
-
+
::lives_ok {
has 'bar' => (
- is => 'ro',
+ is => 'ro',
isa => 'Int',
lazy => 1,
default => 10,
);
} '... this didnt die';
}
-
+
{
package Foo;
- sub new {
- bless({}, 'Foo')
+ sub new {
+ bless({}, 'Foo')
}
-
+
sub a { 'Foo::a' }
}
handles => qr/^a$/,
);
} '... can create the attribute with delegations';
-
+
}
my $bar;
handles => qr/.*/,
);
} '... can create the attribute with delegations';
-
+
}
is(@w, 0, "no warnings");
handles => [qw(a new)],
);
} '... can create the attribute with delegations';
-
+
}
{
{
package Foo;
- use Moose;
+ 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',
+ is($reader, 'get_foo',
'reader => "get_foo" has correct presedence');
can_ok($foo, 'get_foo');
is($foo->$reader, 10, "Reader works as expected");
::is( $obj, undef, "... the object is undef" );
}
{
- local $@;
+ local $@;
my $obj = eval { $pkg->new ( notanattr => 1 ); };
::like( $@, qr/is required/, "... $pkg undef" );
::is( $obj, undef, "... the object is undef" );
}
{
- local $@;
+ local $@;
my $obj = eval { $pkg->new ( %param ); };
::like( $@, qr/is required/, "... $pkg undef param" );
::is( $obj, undef, "... the object is undef" );
}
{
- local $@;
+ 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 $@;
+ 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 $@;
+ local $@;
my $obj = eval { $pkg->new ( path => $FindBin::Bin ); };
::is( $@, '', "... $pkg no error" );
::isa_ok( $obj, $pkg );
# if no call to ANY Moose::Object->new was done before.
sub DEMOLISH {
my ( $self ) = @_;
- # ... Moose (kinda) eats exceptions in DESTROY/DEMOLISH";
+ # ... Moose (kinda) eats exceptions in DESTROY/DEMOLISH";
}
}
{
package Bar;
-
+
sub new { die "Bar died"; }
sub DESTROY {
{
package My::Class;
use Moose;
-
+
::throws_ok {
extends 'My::Role';
- } qr/You cannot inherit from a Moose Role \(My\:\:Role\)/,
+ } qr/You cannot inherit from a Moose Role \(My\:\:Role\)/,
'... this croaks correctly';
}
subtype 'MyArrayRef'
=> as 'ArrayRef'
=> where { defined $_->[0] }
- => message { ref $_ ? "ref: ". ref $_ : 'scalar' } # stringy
+ => message { ref $_ ? "ref: ". ref $_ : 'scalar' } # stringy
;
subtype 'MyObjectType'
use Moose qw(extends with);
extends 'Moose::Meta::Class';
with 'MyRole';
-
- sub foo { 'i am foo' }
+
+ sub foo { 'i am foo' }
}
{
has id => (
isa => 'Str',
is => 'ro',
- default => 017600,
+ default => 017600,
);
no Moose;
has id => (
isa => 'Str',
is => 'ro',
- default => 0xFF,
+ default => 0xFF,
);
no Moose;
has id => (
isa => 'Str',
is => 'ro',
- default => '0xFF',
+ default => '0xFF',
);
no Moose;
has id => (
isa => 'Str',
is => 'ro',
- default => '0 but true',
+ default => '0 but true',
);
no Moose;
my $c = shift;
my ($self, $field) = @_;
return undef if $c->($self, $self->validation_value($field));
- return $self->error_message;
+ return $self->error_message;
};
-
+
sub validation_value {
my ($self, $field) = @_;
return $field;
}
-
+
sub error_message { confess "Abstract method!" }
-
+
package Constraint::OnLength;
use Moose::Role;
override 'error_message' => sub {
my $self = shift;
return super() . ' ' . $self->units;
- };
+ };
}
-## Classes
+## Classes
{
package Constraint::AtLeast;
extends 'Constraint::NoMoreThan';
with 'Constraint::OnLength';
-
+
package Constraint::LengthAtLeast;
use Moose;
-
+
extends 'Constraint::AtLeast';
- with 'Constraint::OnLength';
+ with 'Constraint::OnLength';
}
my $no_more_than_10 = Constraint::NoMoreThan->new(value => 10);
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',
+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');
BEGIN {
eval "use DBM::Deep 1.0003;";
- plan skip_all => "DBM::Deep 1.0003 (or greater) is required for this test" if $@;
+ plan skip_all => "DBM::Deep 1.0003 (or greater) is required for this test" if $@;
eval "use DateTime::Format::MySQL;";
- plan skip_all => "DateTime::Format::MySQL is required for this test" if $@;
- plan tests => 88;
+ plan skip_all => "DateTime::Format::MySQL is required for this test" if $@;
+ plan tests => 88;
}
use Test::Exception;
=pod
-This example creates a very basic Object Database which
-links in the instances created with a backend store
+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.
+as a real-world ODB, but is a proof of concept of the flexibility
+of the ::Instance protocol.
=cut
BEGIN {
-
+
package Moose::POOP::Meta::Instance;
use Moose;
-
+
use DBM::Deep;
-
+
extends 'Moose::Meta::Instance';
-
+
{
my %INSTANCE_COUNTERS;
autobless => 1,
locking => 1,
});
-
+
sub _reload_db {
#use Data::Dumper;
- #warn Dumper $db;
+ #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)];
+ 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 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 Moose::POOP::Meta::Class;
- use Moose;
-
- extends 'Moose::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})
+ return $class->get_meta_instance->find_instance($params->{oid})
if $params->{oid};
super();
};
}
-{
+{
package Moose::POOP::Object;
use metaclass 'Moose::POOP::Meta::Class' => (
instance_metaclass => 'Moose::POOP::Meta::Instance'
- );
+ );
use Moose;
-
+
sub oid {
my $self = shift;
$self->meta
}
}
-{
+{
package Newswriter::Author;
use Moose;
-
+
extends 'Moose::POOP::Object';
-
+
has 'first_name' => (is => 'rw', isa => 'Str');
- has 'last_name' => (is => 'rw', isa => 'Str');
-
- package Newswriter::Article;
+ has 'last_name' => (is => 'rw', isa => 'Str');
+
+ package Newswriter::Article;
use Moose;
- use Moose::Util::TypeConstraints;
-
+ use Moose::Util::TypeConstraints;
+
use DateTime::Format::MySQL;
-
- extends 'Moose::POOP::Object';
+
+ extends 'Moose::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 '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 '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 @_;
+ $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(Moose::POOP::Object->meta, 'Moose::POOP::Meta::Class');
- isa_ok(Moose::POOP::Object->meta, 'Moose::Meta::Class');
- isa_ok(Moose::POOP::Object->meta, 'Class::MOP::Class');
-
- is(Moose::POOP::Object->meta->instance_metaclass,
- 'Moose::POOP::Meta::Instance',
+ isa_ok(Moose::POOP::Object->meta, 'Moose::Meta::Class');
+ isa_ok(Moose::POOP::Object->meta, 'Class::MOP::Class');
+
+ is(Moose::POOP::Object->meta->instance_metaclass,
+ 'Moose::POOP::Meta::Instance',
'... got the right instance metaclass name');
-
- isa_ok(Moose::POOP::Object->meta->get_meta_instance, 'Moose::POOP::Meta::Instance');
-
+
+ isa_ok(Moose::POOP::Object->meta->get_meta_instance, 'Moose::POOP::Meta::Instance');
+
my $base = Moose::POOP::Object->new;
- isa_ok($base, 'Moose::POOP::Object');
- isa_ok($base, 'Moose::Object');
-
+ isa_ok($base, 'Moose::POOP::Object');
+ isa_ok($base, 'Moose::Object');
+
isa_ok($base->meta, 'Moose::POOP::Meta::Class');
- isa_ok($base->meta, 'Moose::Meta::Class');
- isa_ok($base->meta, 'Class::MOP::Class');
-
- is($base->meta->instance_metaclass,
- 'Moose::POOP::Meta::Instance',
+ isa_ok($base->meta, 'Moose::Meta::Class');
+ isa_ok($base->meta, 'Class::MOP::Class');
+
+ is($base->meta->instance_metaclass,
+ 'Moose::POOP::Meta::Instance',
'... got the right instance metaclass name');
-
- isa_ok($base->meta->get_meta_instance, 'Moose::POOP::Meta::Instance');
+
+ isa_ok($base->meta->get_meta_instance, 'Moose::POOP::Meta::Instance');
}
my $article_oid;
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'
);
} '... created my article successfully';
isa_ok($article, 'Newswriter::Article');
- isa_ok($article, 'Moose::POOP::Object');
-
+ isa_ok($article, 'Moose::POOP::Object');
+
lives_ok {
$article->start_date(DateTime->new(year => 2006, month => 6, day => 10));
$article->end_date(DateTime->new(year => 2006, month => 6, day => 17));
} '... add the article date-time stuff';
-
+
## check some meta stuff
-
+
isa_ok($article->meta, 'Moose::POOP::Meta::Class');
- isa_ok($article->meta, 'Moose::Meta::Class');
- isa_ok($article->meta, 'Class::MOP::Class');
-
- is($article->meta->instance_metaclass,
- 'Moose::POOP::Meta::Instance',
+ isa_ok($article->meta, 'Moose::Meta::Class');
+ isa_ok($article->meta, 'Class::MOP::Class');
+
+ is($article->meta->instance_metaclass,
+ 'Moose::POOP::Meta::Instance',
'... got the right instance metaclass name');
-
- isa_ok($article->meta->get_meta_instance, 'Moose::POOP::Meta::Instance');
-
+
+ isa_ok($article->meta->get_meta_instance, 'Moose::POOP::Meta::Instance');
+
ok($article->oid, '... got a oid for the article');
$article_oid = $article->oid;
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');
-
+ is($article->article, '...', '... got the right article');
+
isa_ok($article->start_date, 'DateTime');
isa_ok($article->end_date, 'DateTime');
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'
);
} '... created my article successfully';
isa_ok($article2, 'Newswriter::Article');
isa_ok($article2, 'Moose::POOP::Object');
-
+
$article2_oid = $article2->oid;
$article2_ref = "$article2";
-
+
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');
-
+ 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');
is($article2->author->last_name, 'Couric', '... got the right author last name');
is($article2->status, 'posted', '... got the right status');
-
+
## orig-article
-
+
my $article;
lives_ok {
$article = Newswriter::Article->new(oid => $article_oid);
} '... (re)-created my article successfully';
isa_ok($article, 'Newswriter::Article');
- isa_ok($article, 'Moose::POOP::Object');
-
+ isa_ok($article, 'Moose::POOP::Object');
+
is($article->oid, $article_oid, '... got a oid for the article');
- isnt($article_ref, "$article", '... got a new article instance');
+ isnt($article_ref, "$article", '... got a new article instance');
is($article->headline,
'Home Office Redecorated',
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');
-
+ 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');
-
+
lives_ok {
$article->author->first_name('Dan');
- $article->author->last_name('Rather');
+ $article->author->last_name('Rather');
} '... 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->author->last_name, 'Rather', '... got the changed author last name');
is($article->status, 'pending', '... got the right status');
}
$article = Newswriter::Article->new(oid => $article_oid);
} '... (re)-created my article successfully';
isa_ok($article, 'Newswriter::Article');
- isa_ok($article, 'Moose::POOP::Object');
-
+ isa_ok($article, 'Moose::POOP::Object');
+
is($article->oid, $article_oid, '... got a oid for the article');
- isnt($article_ref, "$article", '... got a new article instance');
+ isnt($article_ref, "$article", '... got a new article instance');
is($article->headline,
'Home Office Redecorated',
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');
-
+ 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->author->last_name, 'Rather', '... got the changed author last name');
is($article->status, 'pending', '... got the right status');
-
+
my $article2;
lives_ok {
$article2 = Newswriter::Article->new(oid => $article2_oid);
} '... (re)-created my article successfully';
isa_ok($article2, 'Newswriter::Article');
- isa_ok($article2, 'Moose::POOP::Object');
-
+ isa_ok($article2, 'Moose::POOP::Object');
+
is($article2->oid, $article2_oid, '... got a oid for the article');
- isnt($article2_ref, "$article2", '... got a new article instance');
+ isnt($article2_ref, "$article2", '... got a new article instance');
is($article2->headline,
'Company wins Lottery',
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');
-
+ 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');
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');
-
+ is($article2->status, 'posted', '... got the right status');
+
}
{
package List;
use Moose::Role;
-
+
has '_list' => (
is => 'ro',
- isa => 'ArrayRef',
+ isa => 'ArrayRef',
init_arg => '::',
default => sub { [] }
);
-
+
sub head { (shift)->_list->[0] }
sub tail {
my $self = shift;
$self->new(
- '::' => [
- @{$self->_list}[1 .. $#{$self->_list}]
+ '::' => [
+ @{$self->_list}[1 .. $#{$self->_list}]
]
);
- }
-
+ }
+
sub print {
join ", " => @{$_[0]->_list};
- }
-
+ }
+
package List::Immutable;
use Moose::Role;
-
+
requires 'head';
- requires 'tail';
-
+ requires 'tail';
+
sub is_empty { not defined ($_[0]->head) }
-
+
sub length {
my $self = shift;
(::Y(sub {
}
}))->($self, 0);
}
-
+
sub apply {
my ($self, $function) = @_;
(::Y(sub {
my $redo = shift;
sub {
my ($list, $func, $acc) = @_;
- return $list->new('::' => $acc)
+ return $list->new('::' => $acc)
if $list->is_empty;
$redo->(
- $list->tail,
+ $list->tail,
$func,
[ @{$acc}, $func->($list->head) ]
);
}
- }))->($self, $function, []);
+ }))->($self, $function, []);
}
-
+
package My::List1;
use Moose;
-
+
::lives_ok {
with 'List', 'List::Immutable';
} '... successfully composed roles together';
-
+
package My::List2;
- use Moose;
-
+ use Moose;
+
::lives_ok {
with 'List::Immutable', 'List';
- } '... successfully composed roles together';
-
+ } '... successfully composed roles together';
+
}
{
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');
+ is($coll->length, 0, '... we have a length of 1 for the collection');
}
{
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');
+ is($coll->length, 0, '... we have a length of 1 for the collection');
}
{
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->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');
+
+ 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');
}
{
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->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');
+
+ 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');
}
=pod
-This tests how well Moose type constraints
-play with Declare::Constraints::Simple.
+This tests how well Moose type constraints
+play with Declare::Constraints::Simple.
Pretty well if I do say so myself :)
BEGIN {
eval "use Declare::Constraints::Simple;";
- plan skip_all => "Declare::Constraints::Simple is required for this test" if $@;
- plan tests => 9;
+ plan skip_all => "Declare::Constraints::Simple is required for this test" if $@;
+ plan tests => 9;
}
use Test::Exception;
is => 'rw',
isa => 'HashOfArrayOfObjects',
);
-
+
# inline the constraints as anon-subtypes
has 'baz' => (
is => 'rw',
my $hash_of_arrays_of_objs = {
foo1 => [ Bar->new ],
- foo2 => [ Bar->new, Bar->new ],
+ foo2 => [ Bar->new, Bar->new ],
};
my $array_of_ints = [ 1 .. 10 ];
$foo = Foo->new(
'bar' => $hash_of_arrays_of_objs,
'baz' => $array_of_ints,
- );
+ );
} '... construction succeeded';
isa_ok($foo, 'Foo');
=pod
-This tests how well Moose type constraints
-play with Test::Deep.
+This tests how well Moose type constraints
+play with Test::Deep.
-Its not as pretty as Declare::Constraints::Simple,
+Its not as pretty as Declare::Constraints::Simple,
but it is not completely horrid either.
=cut
BEGIN {
eval "use Test::Deep;";
- plan skip_all => "Test::Deep is required for this test" if $@;
- plan tests => 5;
+ plan skip_all => "Test::Deep is required for this test" if $@;
+ plan tests => 5;
}
use Test::Exception;
use Test::Deep qw[
eq_deeply array_each subhashof ignore
];
-
+
# define your own type ...
- type 'ArrayOfHashOfBarsAndRandomNumbers'
+ type 'ArrayOfHashOfBarsAndRandomNumbers'
=> where {
- eq_deeply($_,
+ eq_deeply($_,
array_each(
subhashof({
bar => Test::Deep::isa('Bar'),
})
)
)
- };
-
+ };
+
has 'bar' => (
is => 'rw',
isa => 'ArrayOfHashOfBarsAndRandomNumbers',
my $array_of_hashes = [
{ bar => Bar->new, random_number => 10 },
- { bar => Bar->new },
+ { bar => Bar->new },
];
my $foo;
lives_ok {
- $foo = Foo->new('bar' => $array_of_hashes);
+ $foo = Foo->new('bar' => $array_of_hashes);
} '... construction succeeded';
isa_ok($foo, 'Foo');
=pod
-This is an example of making Moose behave
+This is an example of making Moose behave
more like a prototype based object system.
-Why?
+Why?
Well cause merlyn asked if it could :)
{
package ProtoMoose::Meta::Instance;
use Moose;
-
+
BEGIN { extends 'Moose::Meta::Instance' };
-
+
# NOTE:
# do not let things be inlined by
# the attribute or accessor generator
{
package ProtoMoose::Meta::Method::Accessor;
use Moose;
-
+
BEGIN { extends 'Moose::Meta::Method::Accessor' };
-
- # customize the accessors to always grab
+
+ # 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
}
# if its an instance ...
else {
- # and there is no value currently
- # associated with the instance and
+ # 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
+ # again, defer the prototype in
# the class in which is was defined
$instance = $attr->associated_class->prototype_instance;
}
- # otherwise, you want to assign
+ # otherwise, you want to assign
# to your local copy ...
}
return $instance;
}
-
+
sub _generate_accessor_method {
my $self = shift;
- my $attr = $self->associated_attribute;
+ my $attr = $self->associated_attribute;
return sub {
if (scalar(@_) == 2) {
$attr->set_value(
- $self->find_instance($_[0], 'w'),
+ $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;
+ 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;
+ my $attr = $self->associated_attribute;
return sub {
$attr->set_value(
- $self->find_instance($_[0], 'w'),
+ $self->find_instance($_[0], 'w'),
$_[1]
);
};
# deal with these later ...
sub generate_predicate_method {}
- sub generate_clearer_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',
lazy => 1,
default => sub { (shift)->new_object }
);
-
+
sub initialize {
# NOTE:
- # I am not sure why 'around' does
+ # I am not sure why 'around' does
# not work here, have to investigate
# it later - SL
- (shift)->SUPER::initialize(@_,
+ (shift)->SUPER::initialize(@_,
instance_metaclass => 'ProtoMoose::Meta::Instance',
- attribute_metaclass => 'ProtoMoose::Meta::Attribute',
+ 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
+ # to tie-the-knot, if you take it
+ # out, then you get deep recursion
# several levels deep :)
- $self->prototype_instance($next->($self, @_))
+ $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]
+ my $prototype = blessed($_[0])
+ ? $_[0]
: $_[0]->meta->prototype_instance;
my (undef, %params) = @_;
my $self = $prototype->meta->clone_object($prototype, %params);
{
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',
+ isa_ok($class->meta,
+ 'ProtoMoose::Meta::Class',
'... got the right metaclass for ' . $class . ' ->');
- is($class->meta->instance_metaclass,
- 'ProtoMoose::Meta::Instance',
+ is($class->meta->instance_metaclass,
+ 'ProtoMoose::Meta::Instance',
'... got the right instance meta for ' . $class);
- is($class->meta->attribute_metaclass,
- 'ProtoMoose::Meta::Attribute',
+ is($class->meta->attribute_metaclass,
+ 'ProtoMoose::Meta::Attribute',
'... got the right attribute meta for ' . $class);
}
$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
+# 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
+# now make an instance, which
+# is basically a clone of the
# prototype
my $foo = Foo->new;
isa_ok($foo, '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
+# 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)');
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
+## subclasses
# now we can check that the subclass
-# will seek out the correct prototypical
+# will seek out the correct prototypical
# value from it's "parent"
is(Bar->bar, 100, '... got the value stored in the Foo prototype (through the Bar class)');
$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
+# 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)');
=pod
-Some examples of triggers and how they can
+Some examples of triggers and how they can
be used to manage parent-child relationships.
=cut
{
package Record;
use Moose;
-
+
has 'first_name' => (is => 'ro', isa => 'Str');
- has 'last_name' => (is => 'ro', isa => 'Str');
-
+ has 'last_name' => (is => 'ro', isa => 'Str');
+
package RecordSet;
use Moose;
-
+
has 'data' => (
is => 'ro',
- isa => 'ArrayRef[Record]',
+ isa => 'ArrayRef[Record]',
default => sub { [] },
);
-
+
has 'index' => (
is => 'rw',
- isa => 'Int',
+ 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;
isa => 'RecordSet',
);
- # list the fields you want to
+ # 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',
+ isa => 'Record',
lazy => 1,
default => sub {
my $self = shift;
},
trigger => sub {
my $self = shift;
- # whenever this attribute is
- # updated, it will clear all
+ # whenever this attribute is
+ # updated, it will clear all
# the fields for you.
$self->$_() for map { '_clear_' . $_ } @fields;
}
);
- # define the attributes
+ # define the attributes
# for all the fields.
for my $field (@fields) {
has $field => (
is => 'ro',
- isa => 'Any',
+ isa => 'Any',
lazy => 1,
- default => sub {
+ default => sub {
my $self = shift;
- # fetch the value from
+ # fetch the value from
# the current record
$self->current_record->$field();
},
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'),
+ Record->new(first_name => 'Bob', last_name => 'Jones'),
+ Record->new(first_name => 'Jim', last_name => 'Johnson'),
]
);
isa_ok($rs, 'RecordSet');
{
package My::Role;
use Moose::Role;
-
- around 'baz' => sub {
+
+ around 'baz' => sub {
my $next = shift;
'My::Role::baz(' . $next->(@_) . ')';
};
{
package Foo;
use Moose;
-
+
sub baz { 'Foo::baz' }
-
+
__PACKAGE__->meta->make_immutable(debug => 0);
}
extends 'Moose::Meta::Class';
- has 'meta_size' => (
+ has 'meta_size' => (
is => 'rw',
isa => 'Int',
);
}
-lives_ok {
- My::Meta->meta()->make_immutable(debug => 0)
+lives_ok {
+ My::Meta->meta()->make_immutable(debug => 0)
} '... can make a meta class immutable';
=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
+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 '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 'foo' => (is => 'rw', isa => 'Maybe[Str]', trigger => sub {
die "Pulling the Foo trigger\n"
});
-
- has 'bar' => (is => 'rw', isa => 'Maybe[Str]');
-
+
+ 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);
use Moose;
has bar => ( is => "rw" );
- has baz => ( is => "rw" );
+ has baz => ( is => "rw" );
sub BUILDARGS {
my ( $self, @args ) = @_;
use Moose;
extends qw(Foo);
-
+
__PACKAGE__->meta->make_immutable;
}
my $o = $class->new(42, baz => 47);
is($o->bar, 42, '... got the right bar');
is($o->baz, 47, '... got the right bar');
- }
+ }
}
{
package Foo;
use Moose;
-
+
has 'foo';
}
{
package Bar;
use Moose;
-
+
extends 'Foo';
-
- has 'bar';
+
+ has 'bar';
}
use Test::Exception;
BEGIN {
- use_ok('Moose::Util::TypeConstraints');
+ use_ok('Moose::Util::TypeConstraints');
}
lives_ok {
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"
+ 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 Tree;
use Moose::Role;
-
+
has bark => ( is => "rw" );
package Dog;
use Moose::Role;
-
+
sub bark { warn "woof!" };
package EntPuppy;
package Zoink;
use Moose;
-
+
extends qw(Gorch);
}
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
+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;
+use threads;
{
- package Foo;
- use Moose;
- has "bar" => (is => 'rw', isa => "Str | Num");
+ package Foo;
+ use Moose;
+ has "bar" => (is => 'rw', isa => "Str | Num");
}
-my $thr = threads->create(sub {});
+my $thr = threads->create(sub {});
$thr->join();
=cut
projects / gitmo/Moose.git / commitdiff