[Moose-commits] r7315 - in Moose/branches/Moose-XS: . doc lib
lib/Moose lib/Moose/Cookbook lib/Moose/Cookbook/Basics
lib/Moose/Cookbook/Extending lib/Moose/Cookbook/Meta
lib/Moose/Cookbook/Roles lib/Moose/Error lib/Moose/Meta
lib/Moose/Meta/Method lib/Moose/Meta/Role
lib/Moose/Meta/Role/Application lib/Moose/Meta/Role/Method
lib/Moose/Meta/TypeCoercion lib/Moose/Meta/TypeConstraint
lib/Moose/Util lib/Moose/Util/TypeConstraints lib/Test
t/000_recipes/extending t/010_basics t/020_attributes
t/030_roles t/040_type_constraints t/050_metaclasses
t/060_compat t/100_bugs t/300_immutable t/400_moose_util
t/600_todo_tests t/lib t/lib/Moose t/lib/Moose/Meta
t/lib/Moose/Meta/Attribute t/lib/Moose/Meta/Attribute/Custom
t/lib/Moose/Meta/Attribute/Custom/Trait t/lib/Role
nothingmuch at code2.0beta.co.uk
nothingmuch at code2.0beta.co.uk
Sat Jan 17 20:17:27 GMT 2009
Author: nothingmuch
Date: 2009-01-17 12:17:26 -0800 (Sat, 17 Jan 2009)
New Revision: 7315
Added:
Moose/branches/Moose-XS/.shipit
Moose/branches/Moose-XS/doc/
Moose/branches/Moose-XS/doc/moosex-compile
Moose/branches/Moose-XS/lib/Moose/Cookbook/Extending/Recipe3.pod
Moose/branches/Moose-XS/lib/Moose/Cookbook/Extending/Recipe4.pod
Moose/branches/Moose-XS/lib/Moose/Error/
Moose/branches/Moose-XS/lib/Moose/Error/Confess.pm
Moose/branches/Moose-XS/lib/Moose/Error/Croak.pm
Moose/branches/Moose-XS/lib/Moose/Error/Default.pm
Moose/branches/Moose-XS/lib/Moose/Intro.pod
Moose/branches/Moose-XS/lib/Moose/Meta/Method/Delegation.pm
Moose/branches/Moose-XS/lib/Moose/Unsweetened.pod
Moose/branches/Moose-XS/lib/Moose/Util/MetaRole.pm
Moose/branches/Moose-XS/t/010_basics/017_error_handling.t
Moose/branches/Moose-XS/t/010_basics/018_methods.t
Moose/branches/Moose-XS/t/020_attributes/023_attribute_names.t
Moose/branches/Moose-XS/t/020_attributes/024_attribute_traits_parameterized.t
Moose/branches/Moose-XS/t/030_roles/031_roles_applied_in_create.t
Moose/branches/Moose-XS/t/030_roles/032_roles_and_method_cloning.t
Moose/branches/Moose-XS/t/030_roles/033_role_exclusion_and_alias_bug.t
Moose/branches/Moose-XS/t/030_roles/034_create_role.t
Moose/branches/Moose-XS/t/030_roles/035_anonymous_roles.t
Moose/branches/Moose-XS/t/030_roles/036_free_anonymous_roles.t
Moose/branches/Moose-XS/t/030_roles/037_create_role_subclass.t
Moose/branches/Moose-XS/t/040_type_constraints/026_normalize_type_name.t
Moose/branches/Moose-XS/t/040_type_constraints/027_parameterize_from.t
Moose/branches/Moose-XS/t/040_type_constraints/029_define_type_twice_throws.t
Moose/branches/Moose-XS/t/040_type_constraints/030-class_subtypes.t
Moose/branches/Moose-XS/t/050_metaclasses/015_metarole.t
Moose/branches/Moose-XS/t/050_metaclasses/016_metarole_w_metaclass_pm.t
Moose/branches/Moose-XS/t/050_metaclasses/017_use_base_of_moose.t
Moose/branches/Moose-XS/t/050_metaclasses/018_throw_error.t
Moose/branches/Moose-XS/t/050_metaclasses/019_create_anon_with_required_attr.t
Moose/branches/Moose-XS/t/050_metaclasses/020_metaclass_parameterized_traits.t
Moose/branches/Moose-XS/t/100_bugs/019_moose_octal_defaults.t
Moose/branches/Moose-XS/t/100_bugs/020_super_recursion.t
Moose/branches/Moose-XS/t/300_immutable/010_constructor_is_not_moose.t
Moose/branches/Moose-XS/t/300_immutable/011_constructor_is_wrapped.t
Moose/branches/Moose-XS/t/300_immutable/012_default_values.t
Moose/branches/Moose-XS/t/300_immutable/013_immutable_roundtrip.t
Moose/branches/Moose-XS/t/400_moose_util/004_resolve_alias.t
Moose/branches/Moose-XS/t/600_todo_tests/006_attr_metaclass_overrides_metarole.t
Moose/branches/Moose-XS/t/lib/Moose/
Moose/branches/Moose-XS/t/lib/Moose/Meta/
Moose/branches/Moose-XS/t/lib/Moose/Meta/Attribute/
Moose/branches/Moose-XS/t/lib/Moose/Meta/Attribute/Custom/
Moose/branches/Moose-XS/t/lib/Moose/Meta/Attribute/Custom/Bar.pm
Moose/branches/Moose-XS/t/lib/Moose/Meta/Attribute/Custom/Foo.pm
Moose/branches/Moose-XS/t/lib/Moose/Meta/Attribute/Custom/Trait/
Moose/branches/Moose-XS/t/lib/Moose/Meta/Attribute/Custom/Trait/Bar.pm
Moose/branches/Moose-XS/t/lib/Moose/Meta/Attribute/Custom/Trait/Foo.pm
Moose/branches/Moose-XS/t/lib/MyMetaclassRole.pm
Moose/branches/Moose-XS/t/lib/Role/
Moose/branches/Moose-XS/t/lib/Role/Child.pm
Moose/branches/Moose-XS/t/lib/Role/Interface.pm
Moose/branches/Moose-XS/t/lib/Role/Parent.pm
Removed:
Moose/branches/Moose-XS/lib/Moose/Meta/Role/Application/ToMetaclassInstance.pm
Moose/branches/Moose-XS/t/030_roles/030_role_parameterized.t
Moose/branches/Moose-XS/t/300_immutable/006_immutable_nonmoose_subclass.t
Moose/branches/Moose-XS/t/600_todo_tests/004_inlined_constructor_modified_new.t
Modified:
Moose/branches/Moose-XS/Changes
Moose/branches/Moose-XS/MANIFEST
Moose/branches/Moose-XS/MANIFEST.SKIP
Moose/branches/Moose-XS/Makefile.PL
Moose/branches/Moose-XS/README
Moose/branches/Moose-XS/doap.rdf
Moose/branches/Moose-XS/lib/Moose.pm
Moose/branches/Moose-XS/lib/Moose/Cookbook.pod
Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe1.pod
Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe10.pod
Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe2.pod
Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe3.pod
Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe4.pod
Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe5.pod
Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe6.pod
Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe7.pod
Moose/branches/Moose-XS/lib/Moose/Cookbook/Extending/Recipe1.pod
Moose/branches/Moose-XS/lib/Moose/Cookbook/Extending/Recipe2.pod
Moose/branches/Moose-XS/lib/Moose/Cookbook/FAQ.pod
Moose/branches/Moose-XS/lib/Moose/Cookbook/Meta/Recipe2.pod
Moose/branches/Moose-XS/lib/Moose/Cookbook/Meta/Recipe3.pod
Moose/branches/Moose-XS/lib/Moose/Cookbook/Meta/Recipe4.pod
Moose/branches/Moose-XS/lib/Moose/Cookbook/Meta/Recipe5.pod
Moose/branches/Moose-XS/lib/Moose/Cookbook/Roles/Recipe1.pod
Moose/branches/Moose-XS/lib/Moose/Cookbook/Roles/Recipe2.pod
Moose/branches/Moose-XS/lib/Moose/Cookbook/Style.pod
Moose/branches/Moose-XS/lib/Moose/Cookbook/WTF.pod
Moose/branches/Moose-XS/lib/Moose/Exporter.pm
Moose/branches/Moose-XS/lib/Moose/Meta/Attribute.pm
Moose/branches/Moose-XS/lib/Moose/Meta/Class.pm
Moose/branches/Moose-XS/lib/Moose/Meta/Instance.pm
Moose/branches/Moose-XS/lib/Moose/Meta/Method.pm
Moose/branches/Moose-XS/lib/Moose/Meta/Method/Accessor.pm
Moose/branches/Moose-XS/lib/Moose/Meta/Method/Augmented.pm
Moose/branches/Moose-XS/lib/Moose/Meta/Method/Constructor.pm
Moose/branches/Moose-XS/lib/Moose/Meta/Method/Destructor.pm
Moose/branches/Moose-XS/lib/Moose/Meta/Method/Overriden.pm
Moose/branches/Moose-XS/lib/Moose/Meta/Role.pm
Moose/branches/Moose-XS/lib/Moose/Meta/Role/Application.pm
Moose/branches/Moose-XS/lib/Moose/Meta/Role/Application/RoleSummation.pm
Moose/branches/Moose-XS/lib/Moose/Meta/Role/Application/ToClass.pm
Moose/branches/Moose-XS/lib/Moose/Meta/Role/Application/ToInstance.pm
Moose/branches/Moose-XS/lib/Moose/Meta/Role/Application/ToRole.pm
Moose/branches/Moose-XS/lib/Moose/Meta/Role/Composite.pm
Moose/branches/Moose-XS/lib/Moose/Meta/Role/Method.pm
Moose/branches/Moose-XS/lib/Moose/Meta/Role/Method/Required.pm
Moose/branches/Moose-XS/lib/Moose/Meta/TypeCoercion.pm
Moose/branches/Moose-XS/lib/Moose/Meta/TypeCoercion/Union.pm
Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint.pm
Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Class.pm
Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Enum.pm
Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Parameterizable.pm
Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Parameterized.pm
Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Registry.pm
Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Role.pm
Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Union.pm
Moose/branches/Moose-XS/lib/Moose/Object.pm
Moose/branches/Moose-XS/lib/Moose/Role.pm
Moose/branches/Moose-XS/lib/Moose/Util.pm
Moose/branches/Moose-XS/lib/Moose/Util/TypeConstraints.pm
Moose/branches/Moose-XS/lib/Moose/Util/TypeConstraints/OptimizedConstraints.pm
Moose/branches/Moose-XS/lib/Test/Moose.pm
Moose/branches/Moose-XS/lib/oose.pm
Moose/branches/Moose-XS/t/000_recipes/extending/001_base_class.t
Moose/branches/Moose-XS/t/010_basics/009_import_unimport.t
Moose/branches/Moose-XS/t/020_attributes/004_attribute_triggers.t
Moose/branches/Moose-XS/t/020_attributes/009_attribute_inherited_slot_specs.t
Moose/branches/Moose-XS/t/020_attributes/010_attribute_delegation.t
Moose/branches/Moose-XS/t/030_roles/004_role_composition_errors.t
Moose/branches/Moose-XS/t/030_roles/006_role_exclusion.t
Moose/branches/Moose-XS/t/030_roles/017_extending_role_attrs.t
Moose/branches/Moose-XS/t/040_type_constraints/001_util_type_constraints.t
Moose/branches/Moose-XS/t/040_type_constraints/008_union_types.t
Moose/branches/Moose-XS/t/040_type_constraints/010_misc_type_tests.t
Moose/branches/Moose-XS/t/040_type_constraints/015_enum.t
Moose/branches/Moose-XS/t/040_type_constraints/016_subtyping_parameterized_types.t
Moose/branches/Moose-XS/t/040_type_constraints/017_subtyping_union_types.t
Moose/branches/Moose-XS/t/040_type_constraints/020_class_type_constraint.t
Moose/branches/Moose-XS/t/040_type_constraints/021_maybe_type_constraint.t
Moose/branches/Moose-XS/t/040_type_constraints/024_role_type_constraint.t
Moose/branches/Moose-XS/t/050_metaclasses/012_moose_exporter.t
Moose/branches/Moose-XS/t/050_metaclasses/013_metaclass_traits.t
Moose/branches/Moose-XS/t/060_compat/003_foreign_inheritence.t
Moose/branches/Moose-XS/t/100_bugs/011_DEMOLISH_eats_exceptions.t
Moose/branches/Moose-XS/t/100_bugs/017_type_constraint_messages.t
Moose/branches/Moose-XS/t/300_immutable/004_inlined_constructors_n_types.t
Moose/branches/Moose-XS/t/600_todo_tests/002_various_role_shit.t
Moose/branches/Moose-XS/t/600_todo_tests/005_moose_and_threads.t
Log:
merge trunk
Added: Moose/branches/Moose-XS/.shipit
===================================================================
--- Moose/branches/Moose-XS/.shipit (rev 0)
+++ Moose/branches/Moose-XS/.shipit 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,7 @@
+# auto-generated shipit config file.
+steps = FindVersion, ChangeVersion, CheckChangeLog, CheckVersionsMatch, DistTest, Commit, Tag, MakeDist, DistClean
+
+svn.tagpattern = %v
+svn.tagpattern = http://code2.0beta.co.uk/moose/svn/Moose/tags/%v
+
+CheckChangeLog.files = Changes
Modified: Moose/branches/Moose-XS/Changes
===================================================================
--- Moose/branches/Moose-XS/Changes 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/Changes 2009-01-17 20:17:26 UTC (rev 7315)
@@ -1,6 +1,378 @@
Revision history for Perl extension Moose
-0.56
+0.65
+ * Moose and Moose::Meta::Method::Overridden
+ - If an overridden method called super(), and then the
+ superclass's method (not overridden) _also_ called super(),
+ Moose went into an endless recursion loop. Test provided by
+ Chris Prather. (Dave Rolsky)
+ * Moose::Meta::TypeConstraint
+ - Add some explanation for a few explanationless methods (gphat)
+
+0.64 Wed, December 31, 2008
+ * Moose::Meta::Method::Accessor
+ - Always inline predicate and clearer methods (Sartak)
+ * Moose::Meta::Attribute
+ - Support for parameterized traits (Sartak)
+ - verify_against_type_constraint method to avoid duplication
+ and enhance extensibility (Sartak)
+ * Moose::Meta::Class
+ - Tests (but no support yet) for parameterized traits (Sartak)
+ * Moose
+ - Require Class::MOP 0.75+, which has the side effect of making
+ sure we work on Win32. (Dave Rolsky)
+
+0.63 Mon, December 8, 2008
+ * Moose::Unsweetened
+ - Some small grammar tweaks and bug fixes in non-Moose example
+ code. (Dave Rolsky)
+
+0.62_02 Fri, December 5, 2008
+ * Moose::Meta::Role::Application::ToClass
+ - When a class does not provide all of a role's required
+ methods, the error thrown now mentions all of the missing
+ methods, as opposed to just the first one found. Requested by
+ Curtis Poe (RT #41119). (Dave Rolsky)
+
+ * Moose::Meta::Method::Constructor
+ - Moose will no longer inline a constructor for your class
+ unless it inherits its constructor from Moose::Object, and
+ will warn when it doesn't inline. If you want to force
+ inlining anyway, pass "replace_constructor => 1" to
+ make_immutable. Addresses RT #40968, reported by Jon
+ Swartz. (Dave Rolsky)
+ - The quoting of default values could be broken if the default
+ contained a single quote ('). Now we use quotemeta to escape
+ anything potentially dangerous in the defaults. (Dave Rolsky)
+
+0.62_01 Wed, December 3, 2008
+ * Moose::Object
+ - use the method->execute API for BUILDALL
+ and DEMOLISHALL (Sartak)
+
+ * Moose::Util::TypeConstraints
+ - We now make all the type constraint meta classes immutable
+ before creating the default types provided by Moose. This
+ should make loading Moose a little faster. (Dave Rolsky)
+
+0.62 Wed November 26, 2008
+ * Moose::Meta::Role::Application::ToClass
+ Moose::Meta::Role::Application::ToRole
+ - fixed issues where excluding and aliasing the
+ same methods for a single role did not work
+ right (worked just fine with multiple
+ roles) (stevan)
+ - added test for this (stevan)
+
+ * Moose::Meta::Role::Application::RoleSummation
+ - fixed the error message when trying to compose
+ a role with a role it excludes (Sartak)
+
+ * Moose::Exporter
+ - Catch another case where recursion caused the value
+ of $CALLER to be stamped on (t0m)
+ - added test for this (t0m)
+
+ * Moose
+ - Remove the make_immutable keyword, which has been
+ deprecated since April. It breaks metaclasses that
+ use Moose without no Moose (Sartak)
+
+ * Moose::Meta::Attribute
+ - Removing an attribute from a class now also removes delegation
+ (handles) methods installed for that attribute (t0m)
+ - added test for this (t0m)
+
+ * Moose::Meta::Method::Constructor
+ - An attribute with a default that looked like a number (but was
+ really a string) would accidentally be treated as a number
+ when the constructor was made immutable (perigrin)
+ - added test for this (perigrin)
+
+ * Moose::Meta::Role
+ - create method for constructing a role
+ dynamically (Sartak)
+ - added test for this (Sartak)
+ - anonymous roles! (Sartak)
+ - added test for this (Sartak)
+
+ * Moose::Role
+ - more consistent error messages (Sartak)
+
+ * Moose::Cookbook::Roles::Recipe1
+ - attempt to explain why a role that just requires
+ methods is useful (Sartak)
+
+0.61 Fri November 7, 2008
+ * Moose::Meta::Attribute
+ - When passing a role to handles, it will be loaded if necessary
+ (perigrin)
+
+ * Moose::Meta::Class
+ - Method objects returned by get_method (and other methods)
+ Could end up being returned without an associated_metaclass
+ attribute. Removing get_method_map, which is provided by
+ Class::MOP::Class, fixed this. The Moose version did nothing
+ different from its parent except introduce a bug. (Dave Rolsky)
+ - added tests for this (jdv79)
+
+ * Various
+ - Added a $VERSION to all .pm files which didn't have one. Fixes
+ RT #40049, reported by Adam Kennedy. (Dave Rolsky)
+
+ * Moose::Cookbook::Basics::Recipe4
+ * Moose::Cookbook::Basics::Recipe6
+ - These files had spaces on the first line of the SYNOPSIS, as
+ opposed to a totally empty line. According to RT #40432, this
+ confuses POD parsers. (Dave Rolsky)
+
+0.60 Fri October 24, 2008
+ * Moose::Exporter
+ - 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
+ simpler, and also around 5 times faster. (t0m)
+ - Add caching to resolve_metaclass_alias, which gives an order
+ of magnitude speedup to things which repeatedly call the
+ Moose::Meta::Attribute->does method, notably MooseX::Storage
+ (t0m)
+
+ * Moose::Util::TypeConstraint
+ - Put back the changes for parameterized constraints that
+ shouldn't have been removed in 0.59. We still cannot parse
+ them, but MooseX modules can create them in some other
+ way. See the 0.58 changes for more details. (jnapiorkowski)
+ - Changed the way subtypes are created so that the job is
+ delegated to a type constraint parent. This clears up some
+ hardcoded checking and should allow correct subtypes of
+ Moose::Meta::Type::Constraint. Don't rely on this new API too
+ much (create_child_type) because it may go away in the
+ future. (jnapiorkowski)
+
+ * 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
+ type. (jnapiorkowski)
+ - added tests (jnapiorkowski)
+
+0.59 Tue October 14, 2008
+ * Moose
+ - Add abridged documentation for builder/default/initializer/
+ predicate, and link to more details sections in
+ Class::MOP::Attribute. (t0m)
+
+ * Moose::Util::TypeConstraints
+ - removed prototypes from all but the &-based stuff (mst)
+
+ * Moose::Util::TypeConstraints
+ - Creating a anonymous subtype with both a constraint and a
+ message failed with a very unhelpful error, but should just
+ work. Reported by t0m. (Dave Rolsky)
+
+ * Tests
+ - Some tests that used Test::Warn if it was available failed
+ with older versions of Test::Warn. Reported by Fayland. (Dave
+ Rolsky)
+ - Test firing behavior of triggers in relation to builder/default/
+ lazy_build. (t0m)
+ - Test behavior of equals/is_a_type_of/is_a_subtype_of for all
+ kinds of supported type. (t0m)
+
+ * Moose::Meta::Class
+ - In create(), do not pass "roles" option to the superclass
+ - added related test that creates an anon metaclass with
+ a required attribute
+
+ * Moose::Meta::TypeConstraint::Class
+ * Moose::Meta::TypeConstraint::Role
+ - Unify behavior of equals/is_a_type_of/is_a_subtype_of with
+ other types (as per change in 0.55_02). (t0m)
+
+ * Moose::Meta::TypeConstraint::Registry
+ - Fix warning when dealing with unknown type names (t0m)
+
+ * Moose::Util::TypeConstraints
+ - Reverted changes from 0.58 related to handle parameterized
+ types. This caused random failures on BSD and Win32 systems,
+ apparently related to the regex engine. This means that Moose
+ can no longer parse structured type constraints like
+ ArrayRef[Int,Int] or HashRef[name=>Str]. This will be
+ supported in a slightly different way via MooseX::Types some
+ time in the future. (Dave Rolsky)
+
+0.58 Sat September 20, 2008
+ !! This release has an incompatible change regarding !!
+ !! how roles add methods to a class !!
+
+ * Roles and role application
+ ! Roles now add methods by calling add_method, not
+ alias_method. They make sure to always provide a method
+ object, which will be cloned internally. This means that it is
+ now possible to track the source of a method provided by a
+ role, and even follow its history through intermediate roles.
+
+ This means that methods added by a role now show up when
+ looking at a class's method list/map. (Dave Rolsky)
+
+ * Makefile.PL
+ - From this release on, we'll try to maintain a list of
+ conflicting modules, and warn you if you have one
+ installed. For example, this release conflicts with ...
+ - MooseX::Singleton <= 0.11
+ - MooseX::Params::Validate <= 0.05
+ - Fey::ORM <= 0.10
+
+ In general, we try to not break backwards compatibility for
+ most Moose users, but MooseX modules and other code which
+ extends Moose's metaclasses is often affected by very small
+ changes in the Moose internals.
+
+ * Moose::Meta::Method::Delegation
+ * Moose::Meta::Attribute
+ - Delegation methods now have their own method class. (Dave
+ Rolsky)
+
+ * Moose::Meta::TypeConstraint::Parameterizable
+ - Added a new method 'parameterize' which is basically a factory
+ for the containing constraint. This makes it easier to create
+ new types of parameterized constraints. (jnapiorkowski)
+
+ * Moose::Meta::TypeConstraint::Union
+ - Changed the way Union types canonicalize their names to follow
+ the normalized TC naming rules, which means we strip all
+ whitespace. (jnapiorkowski)
+
+ * Moose::Util::TypeConstraints
+ - Parameter and Union args are now sorted, this makes Int|Str
+ the same constraint as Str|Int. (jnapiorkowski)
+ - Changes to the way Union types are parsed to more correctly
+ stringify their names. (jnapiorkowski)
+ - When creating a parameterized type, we now use the new
+ parameterize method. (jnapiorkowski)
+ - Incoming type constraint strings are now normalized to remove
+ all whitespace differences. (jnapiorkowski)
+ - Changed the way we parse type constraint strings so that we now
+ match TC[Int,Int,...] and TC[name=>Str] as parameterized type
+ constraints. This lays the foundation for more flexible type
+ constraint implementations.
+
+ * Tests and docs for all the above. (jnapiorkowski)
+
+ * Moose::Exporter
+ * Moose
+ - Moose::Exporter will no longer remove a subroutine that the
+ exporting package re-exports. Moose re-exports the
+ Carp::confess function, among others. The reasoning is that we
+ cannot know whether you have also explicitly imported those
+ functions for your own use, so we err on the safe side and
+ always keep them. (Dave Rolsky)
+ - added tests for this (rafl)
+
+ * Moose::Meta::Class
+ - Changes to how we fix metaclass compatibility that are much
+ too complicated to go into. The summary is that Moose is much
+ less likely to complain about metaclass incompatibility
+ now. In particular, if two metaclasses differ because
+ Moose::Util::MetaRole was used on the two corresponding
+ classes, then the difference in roles is reconciled for the
+ subclass's metaclass. (Dave Rolsky)
+ - Squashed an warning in _process_attribute (thepler)
+
+ * Moose::Meta::Role
+ - throw exceptions (sooner) for invalid attribute names (thepler)
+ - added tests for this (thepler)
+
+ * Moose::Util::MetaRole
+ - If you explicitly set a constructor or destructor class for a
+ metaclass object, and then applied roles to the metaclass,
+ that explicitly set class would be lost and replaced with the
+ default.
+
+ * Moose::Meta::Class
+ * Moose::Meta::Attribute
+ * Moose::Meta::Method
+ * Moose
+ * Moose::Object
+ * Moose::Error::Default
+ * Moose::Error::Croak
+ * Moose::Error::Confess
+ - All instances of confess() changed to use overridable
+ C<throw_error> method. This method ultimately calls a class
+ constructor, and you can change the class being called. In
+ addition, errors now pass more information than just a string.
+ The default C<error_class> behaves like C<Carp::confess>, so
+ the behavior is not visibly different for end users.
+
+0.57 Wed September 3, 2008
+ * Moose::Intro
+ - A new bit of doc intended to introduce folks familiar with
+ "standard" Perl 5 OO to Moose concepts. (Dave Rolsky)
+
+ * Moose::Unsweetened
+ - Shows examples of two classes, each done first with and then
+ without Moose. This makes a nice parallel to
+ Moose::Intro. (Dave Rolsky)
+
+ * Moose::Util::TypeConstraints
+ - Fixed a bug in find_or_parse_type_constraint so that it
+ accepts a Moose::Meta::TypeConstraint object as the parent
+ type, not just a name (jnapiorkowski)
+ - added tests (jnapiorkowski)
+
+ * Moose::Exporter
+ - If Sub::Name was not present, unimporting failed to actually
+ remove some sugar subs, causing test failures (Dave Rolsky)
+
+0.56 Mon September 1, 2008
+ For those not following the series of dev releases, there are
+ several major changes in this release of Moose.
+ ! Moose::init_meta should now be called as a method. See the
+ docs for details.
+
+ - Major performance improvements by nothingmuch.
+
+ - New modules for extension writers, Moose::Exporter and
+ Moose::Util::MetaRole by Dave Rolsky.
+
+ - Lots of doc improvements and additions, especially in the
+ cookbook sections.
+
+ - Various bug fixes.
+
+ * Removed all references to the experimental-but-no-longer-needed
+ Moose::Meta::Role::Application::ToMetaclassInstance.
+
+ * Require Class::MOP 0.65.
+
+0.55_04 Sat August 30, 2008
+ * Moose::Util::MetaRole
+ * Moose::Cookbook::Extending::Recipe2
+ - This simplifies the application of roles to any meta class, as
+ well as the base object class. Reimplemented metaclass traits
+ using this module. (Dave Rolsky)
+
+ * Moose::Cookbook::Extending::Recipe1
+ - This a new recipe, an overview of various ways to write Moose
+ extensions (Dave Rolsky)
+
+ * Moose::Cookbook::Extending::Recipe3
+ * Moose::Cookbook::Extending::Recipe4
+ - These used to be Extending::Recipe1 and Extending::Recipe2,
+ respectively.
+
+0.55_03 Fri August 29, 2008
+ * No changes from 0.55_02 except increasing the Class::MOP
+ dependency to 0.64_07.
+
+0.55_02 Fri August 29, 2008
* Makefile.PL and Moose.pm
- explicitly require Perl 5.8.0+ (Dave Rolsky)
@@ -9,17 +381,26 @@
found (t0m).
* Moose::Meta::TypeConstraint
- - predicate methods (equals/is_a_type_of/is_subtype_of) now
+ - 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. The behavior is now in line with to
- $ob->isa('DoesNotExist') (t0m).
+ 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).
- added docs & test for this (t0m)
+
+ * Moose::Cookbook::FAQ
+ - Added a faq entry on the difference between "role" and "trait"
+ (t0m)
+
+ * Moose::Meta::Role
+ - Fixed a bug that caused role composition to not see a required
+ 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
@@ -298,7 +679,7 @@
0.45 Saturday, May 24, 2008
* Moose
- - Because of work in Class::MOP 0.56, 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
@@ -335,7 +716,7 @@
* Moose::Meta::Class
- added same 'add_package_symbol' fix as in
- Class::MOP 0.56
+ Class::MOP 0.57
* Moose::Util
- does_role now handles non-Moose classes
@@ -883,7 +1264,7 @@
ArrayRef[Int] # array or integers
HashRef[Object] # a hash with object values
They can also be nested:
- ArrayRef[HashRef[RegExpr]] # an array of hashes with regexpr values
+ ArrayRef[HashRef[RegexpRef]] # an array of hashes with regex values
And work with the type unions as well:
ArrayRef[Int | Str] # array of integers of strings
@@ -1152,7 +1533,7 @@
- added tests to assure we work with Module::Refresh
- added stricter test skip logic in the Moose POOP
test, ask Rob Kinyon why.
- - *cough* DBM::Deep 1.0 backwards compatability sucks *cough* ;)
+ - *cough* DBM::Deep 1.0 backwards compatibility sucks *cough* ;)
0.18 Sat. March 10, 2007
~~ Many, many documentation updates ~~
@@ -1433,7 +1814,7 @@
- 'with' now checks Role validaity and
accepts more than one Role at a time
- 'extends' makes metaclass adjustments as
- needed to ensure metaclass compatability
+ needed to ensure metaclass compatibility
* Moose::Role
- refactored the keyword exports
Modified: Moose/branches/Moose-XS/MANIFEST
===================================================================
--- Moose/branches/Moose-XS/MANIFEST 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/MANIFEST 2009-01-17 20:17:26 UTC (rev 7315)
@@ -21,6 +21,8 @@
lib/Moose/Cookbook/Basics/Recipe9.pod
lib/Moose/Cookbook/Extending/Recipe1.pod
lib/Moose/Cookbook/Extending/Recipe2.pod
+lib/Moose/Cookbook/Extending/Recipe3.pod
+lib/Moose/Cookbook/Extending/Recipe4.pod
lib/Moose/Cookbook/FAQ.pod
lib/Moose/Cookbook/Meta/Recipe1.pod
lib/Moose/Cookbook/Meta/Recipe2.pod
@@ -33,7 +35,11 @@
lib/Moose/Cookbook/Snack/Types.pod
lib/Moose/Cookbook/Style.pod
lib/Moose/Cookbook/WTF.pod
+lib/Moose/Error/Confess.pm
+lib/Moose/Error/Croak.pm
+lib/Moose/Error/Default.pm
lib/Moose/Exporter.pm
+lib/Moose/Intro.pod
lib/Moose/Meta/Attribute.pm
lib/Moose/Meta/Class.pm
lib/Moose/Meta/Instance.pm
@@ -41,6 +47,7 @@
lib/Moose/Meta/Method/Accessor.pm
lib/Moose/Meta/Method/Augmented.pm
lib/Moose/Meta/Method/Constructor.pm
+lib/Moose/Meta/Method/Delegation.pm
lib/Moose/Meta/Method/Destructor.pm
lib/Moose/Meta/Method/Overriden.pm
lib/Moose/Meta/Role.pm
@@ -48,7 +55,6 @@
lib/Moose/Meta/Role/Application/RoleSummation.pm
lib/Moose/Meta/Role/Application/ToClass.pm
lib/Moose/Meta/Role/Application/ToInstance.pm
-lib/Moose/Meta/Role/Application/ToMetaclassInstance.pm
lib/Moose/Meta/Role/Application/ToRole.pm
lib/Moose/Meta/Role/Composite.pm
lib/Moose/Meta/Role/Method.pm
@@ -66,7 +72,9 @@
lib/Moose/Object.pm
lib/Moose/Role.pm
lib/Moose/Spec/Role.pod
+lib/Moose/Unsweetened.pod
lib/Moose/Util.pm
+lib/Moose/Util/MetaRole.pm
lib/Moose/Util/TypeConstraints.pm
lib/Moose/Util/TypeConstraints/OptimizedConstraints.pm
lib/oose.pm
@@ -106,6 +114,8 @@
t/010_basics/014_create_anon.t
t/010_basics/015_buildargs.t
t/010_basics/016_load_into_main.t
+t/010_basics/017_error_handling.t
+t/010_basics/018_methods.t
t/020_attributes/001_attribute_reader_generation.t
t/020_attributes/002_attribute_writer_generation.t
t/020_attributes/003_attribute_accessor_generation.t
@@ -128,6 +138,8 @@
t/020_attributes/020_trigger_and_coerce.t
t/020_attributes/021_method_generation_rules.t
t/020_attributes/022_legal_options_for_inheritance.t
+t/020_attributes/023_attribute_names.t
+t/020_attributes/024_attribute_traits_parameterized.t
t/030_roles/001_meta_role.t
t/030_roles/002_role.t
t/030_roles/003_apply_role.t
@@ -154,7 +166,13 @@
t/030_roles/024_role_composition_methods.t
t/030_roles/025_role_composition_override.t
t/030_roles/026_role_composition_method_mods.t
-t/030_roles/030_role_parameterized.t
+t/030_roles/031_roles_applied_in_create.t
+t/030_roles/032_roles_and_method_cloning.t
+t/030_roles/033_role_exclusion_and_alias_bug.t
+t/030_roles/034_create_role.t
+t/030_roles/035_anonymous_roles.t
+t/030_roles/036_free_anonymous_roles.t
+t/030_roles/037_create_role_subclass.t
t/040_type_constraints/001_util_type_constraints.t
t/040_type_constraints/002_util_type_constraints_export.t
t/040_type_constraints/003_util_std_type_constraints.t
@@ -180,6 +198,10 @@
t/040_type_constraints/023_types_and_undef.t
t/040_type_constraints/024_role_type_constraint.t
t/040_type_constraints/025_type_coersion_on_lazy_attributes.t
+t/040_type_constraints/026_normalize_type_name.t
+t/040_type_constraints/027_parameterize_from.t
+t/040_type_constraints/029_define_type_twice_throws.t
+t/040_type_constraints/030-class_subtypes.t
t/050_metaclasses/001_custom_attr_meta_with_roles.t
t/050_metaclasses/002_custom_attr_meta_as_role.t
t/050_metaclasses/003_moose_w_metaclass.t
@@ -189,6 +211,12 @@
t/050_metaclasses/012_moose_exporter.t
t/050_metaclasses/013_metaclass_traits.t
t/050_metaclasses/014_goto_moose_import.t
+t/050_metaclasses/015_metarole.t
+t/050_metaclasses/016_metarole_w_metaclass_pm.t
+t/050_metaclasses/017_use_base_of_moose.t
+t/050_metaclasses/018_throw_error.t
+t/050_metaclasses/019_create_anon_with_required_attr.t
+t/050_metaclasses/020_metaclass_parameterized_traits.t
t/060_compat/001_module_refresh_compat.t
t/060_compat/002_moose_respects_base.t
t/060_compat/003_foreign_inheritence.t
@@ -209,6 +237,7 @@
t/100_bugs/016_inheriting_from_roles.t
t/100_bugs/017_type_constraint_messages.t
t/100_bugs/018_immutable_metaclass_does_role.t
+t/100_bugs/019_moose_octal_defaults.t
t/200_examples/001_example.t
t/200_examples/002_example_Moose_POOP.t
t/200_examples/003_example.t
@@ -222,13 +251,17 @@
t/300_immutable/003_immutable_meta_class.t
t/300_immutable/004_inlined_constructors_n_types.t
t/300_immutable/005_multiple_demolish_inline.t
-t/300_immutable/006_immutable_nonmoose_subclass.t
t/300_immutable/007_immutable_trigger_from_constructor.t
t/300_immutable/008_immutable_constructor_error.t
t/300_immutable/009_buildargs.t
+t/300_immutable/010_constructor_is_not_moose.t
+t/300_immutable/011_constructor_is_wrapped.t
+t/300_immutable/012_default_values.t
+t/300_immutable/013_immutable_roundtrip.t
t/400_moose_util/001_moose_util.t
t/400_moose_util/002_moose_util_does_role.t
t/400_moose_util/003_moose_util_search_class_by_role.t
+t/400_moose_util/004_resolve_alias.t
t/500_test_moose/001_test_moose.t
t/500_test_moose/002_test_moose_does_ok.t
t/500_test_moose/003_test_moose_has_attribute_ok.t
@@ -236,12 +269,19 @@
t/600_todo_tests/001_exception_reflects_failed_constraint.t
t/600_todo_tests/002_various_role_shit.t
t/600_todo_tests/003_immutable_n_around.t
-t/600_todo_tests/004_inlined_constructor_modified_new.t
t/600_todo_tests/005_moose_and_threads.t
t/lib/Bar.pm
t/lib/Foo.pm
+t/lib/Moose/Meta/Attribute/Custom/Bar.pm
+t/lib/Moose/Meta/Attribute/Custom/Foo.pm
+t/lib/Moose/Meta/Attribute/Custom/Trait/Bar.pm
+t/lib/Moose/Meta/Attribute/Custom/Trait/Foo.pm
+t/lib/MyMetaclassRole.pm
t/lib/MyMooseA.pm
t/lib/MyMooseB.pm
t/lib/MyMooseObject.pm
+t/lib/Role/Child.pm
+t/lib/Role/Interface.pm
+t/lib/Role/Parent.pm
t/pod.t
t/pod_coverage.t
Modified: Moose/branches/Moose-XS/MANIFEST.SKIP
===================================================================
--- Moose/branches/Moose-XS/MANIFEST.SKIP 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/MANIFEST.SKIP 2009-01-17 20:17:26 UTC (rev 7315)
@@ -17,6 +17,8 @@
^\.#
^TODO$
^PLANS$
+^doc/
^benchmarks
^\._.*$
-^t\/600_todo_tests\/$
\ No newline at end of file
+^t\/600_todo_tests\/$
+\.shipit
Modified: Moose/branches/Moose-XS/Makefile.PL
===================================================================
--- Moose/branches/Moose-XS/Makefile.PL 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/Makefile.PL 2009-01-17 20:17:26 UTC (rev 7315)
@@ -1,31 +1,73 @@
use strict;
use warnings;
use inc::Module::Install;
+use 5.008;
+check_conflicts();
+
name 'Moose';
+perl_version '5.008';
all_from 'lib/Moose.pm';
license 'perl';
-# Scalar::Util 1.18 doesn't work on Windows
-my $win32 = !! ( $^O eq 'Win32' or $^O eq 'cygwin' );
-
# prereqs
-requires 'perl' => '5.008';
-requires 'Scalar::Util' => $win32 ? '1.17' : '1.18';
+requires 'Scalar::Util' => '1.19';
requires 'Carp';
-requires 'Class::MOP' => '0.64_01';
-requires 'List::MoreUtils';
+requires 'Class::MOP' => '0.75';
+requires 'List::MoreUtils' => '0.12';
requires 'Sub::Exporter' => '0.972';
+requires 'Task::Weaken' => '0';
# only used by oose.pm, not Moose.pm :P
requires 'Filter::Simple' => '0';
# things the tests need
-build_requires 'Test::More' => '0.62';
+build_requires 'Test::More' => '0.77';
build_requires 'Test::Exception' => '0.21';
-build_requires 'Test::LongString';
-tests_recursive;
+tests_recursive();
WriteAll();
+# Use the cpan-smolder-stable script in the Moose svn root to figure
+# out what on CPAN will break with the latest Moose, then update this
+# before a release.
+sub check_conflicts {
+ my %conflicts = (
+ 'MooseX::Singleton' => '0.12',
+ 'MooseX::Params::Validate' => '0.05',
+ 'Fey::ORM' => '0.12',
+ );
+
+ my $found = 0;
+ for my $mod ( sort keys %conflicts ) {
+ eval "require $mod";
+ next if $@;
+
+ my $installed = $mod->VERSION();
+ if ( $installed le $conflicts{$mod} ) {
+
+ print <<"EOF";
+
+***
+ This version of Moose conflicts with the version of
+ $mod ($installed) you have installed.
+
+ You will need to upgrade $mod after installing
+ this version of Moose.
+***
+
+EOF
+
+ $found = 1;
+ }
+ }
+
+ return unless $found;
+
+ # More or less copied from Module::Build
+ return if $ENV{PERL_MM_USE_DEFAULT};
+ return unless -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT));
+
+ sleep 4;
+}
Property changes on: Moose/branches/Moose-XS/Makefile.PL
___________________________________________________________________
Name: svn:executable
+ *
Modified: Moose/branches/Moose-XS/README
===================================================================
--- Moose/branches/Moose-XS/README 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/README 2009-01-17 20:17:26 UTC (rev 7315)
@@ -1,4 +1,4 @@
-Moose version 0.55_01
+Moose version 0.64
===========================
See the individual module documentation for more information
Modified: Moose/branches/Moose-XS/doap.rdf
===================================================================
--- Moose/branches/Moose-XS/doap.rdf 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/doap.rdf 2009-01-17 20:17:26 UTC (rev 7315)
@@ -5,21 +5,38 @@
<description>Moose is a postmodern object system for Perl 5 that takes the tedium out of writing object-oriented Perl. It borrows all the best features from Perl 6, CLOS (LISP), Smalltalk, Java, BETA, OCaml, Ruby and more, while still keeping true to its Perl 5 roots. </description>
<homepage rdf:resource="http://www.iinteractive.com/moose/" />
<download-page rdf:resource="http://search.cpan.org/~stevan/Moose/" />
-
<bug-database rdf:resource="http://rt.cpan.org/Public/Dist/Display.html?Name=Moose" />
<programming-language>Perl</programming-language>
<license rdf:resource="http://usefulinc.com/doap/licenses/artistic" />
<maintainer>
<foaf:Person>
<foaf:name>Stevan Little</foaf:name>
+ <foaf:nick>stevan</foaf:nick>
</foaf:Person>
</maintainer>
- <developer>
+ <maintainer>
<foaf:Person>
- <foaf:name>Chris Prather</foaf:name>
+ <foaf:name>Yuval Kogman</foaf:name>
+ <foaf:nick>nothingmuch</foaf:nick>
</foaf:Person>
- </developer>
+ </maintainer>
+
+ <maintainer>
+ <foaf:Person>
+ <foaf:name>Shawn Moore</foaf:name>
+ <foaf:nick>Sartak</foaf:nick>
+ </foaf:Person>
+ </maintainer>
+
+ <maintainer>
+ <foaf:Person>
+ <foaf:name>Dave Rolsky</foaf:name>
+ <foaf:nick>autarch</foaf:nick>
+ </foaf:Person>
+ </maintainer>
+
+
<repository>
<SVNRepository>
<browse rdf:resource='http://code2.0beta.co.uk/moose/svnweb/index.cgi/moose' />
Added: Moose/branches/Moose-XS/doc/moosex-compile
===================================================================
--- Moose/branches/Moose-XS/doc/moosex-compile (rev 0)
+++ Moose/branches/Moose-XS/doc/moosex-compile 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,176 @@
+MooseX-Compile, wherein Yuval explains how MooseX::Compile is supposed to work and what needs doing.
+
+TODO: PLEASE EDIT ME
+
+19:11 <obra> hiya
+19:12 <nothingmuch> hola
+19:13 <obra> so, my empty mail was an attempted abort
+19:13 <obra> but was going to be "MX::Compile doesn't depend on MX::Compile::CLI. should it?"
+19:13 <nothingmuch> ah, ok =)
+19:13 <obra> but i'm without my laptop, so i couldn't actually check my assumption
+19:14 <nothingmuch> no, because MX::Compile::CLI is "just a a frontend" and at the time the dependencies were a little sketchy
+19:14 <nothingmuch> they've since matured, so maybe it should dep
+19:21 * obra nods
+19:21 <obra> I was on a plane and was trying to see if MX::Compile was at the point where I could try trivial tests
+19:22 <nothingmuch> ah
+19:22 <nothingmuch> so the answer is definitely maybe ;-)
+19:22 <nothingmuch> i haven't been able to make time for it in the past week
+19:23 <nothingmuch> if you guys hand me small, targetted test cases (just commit to it) of code that passes under plain Moose and should pass with MX::Compile i can probably do that stuff pretty quickly
+19:23 <nothingmuch> but the biggest barrier MXC has right now is testing, in order for it to progress towards something production worthy it basically needs to pass the Moose test suite
+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 <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:25 <nothingmuch> the assumptions of the system are:
+19:25 <nothingmuch> the class you are compiling is in its own .pm using standard moose sugar
+19:25 <nothingmuch> there is one package in that file
+19:26 <nothingmuch> the compiler object takes the metaclass and the .pm file as args
+19:26 <nothingmuch> it serializes the metaclass to a .mopc file, and the generated code into a .pmc
+19:26 <nothingmuch> the .pmc contains the original .pm verbatim
+19:26 <nothingmuch> except that all the moose sugar does nothing
+19:27 <nothingmuch> meta is overriden to lazy load .mopc
+19:27 <nothingmuch> and the class is supposed to be usable without loading Moose at all
+19:27 <obra> what is the point of containing the original pm verbatim?
+19:27 <nothingmuch> the user code
+19:28 <nothingmuch> could open and slurp and eval
+19:28 <nothingmuch> but this is a little more flexible
+19:28 <nothingmuch> basically any subroutines the user has written, global/lexical variable initialization, loading of assorted modules etc all must work
+19:28 <obra> are you using the flexibility?
+19:28 <obra> (open, slurp, eval sounds suspiciously like "do")
+19:29 <nothingmuch> can't use do/require/etc because it will go to the .pmc
+19:29 <nothingmuch> instead of the .pm
+19:29 <nothingmuch> the flexibility is helpful because you get a lexical set if the code is compiled
+19:29 <nothingmuch> for when you need to do trickery
+19:29 <nothingmuch> see Moose/Object.pm
+19:29 <obra> I didn't think 'do' had that logic. but ok :)
+19:30 <obra> anyway
+19:30 <obra> do go on
+19:30 <nothingmuch> now that we have Devel::Declare that might prove even simpler
+19:30 <nothingmuch> simply replacing has() etc to export the subs inline
+19:30 <nothingmuch> and write the resulting buffers to a .pmc
+19:30 <nothingmuch> but that's for Later™
+19:30 <obra> The fact that the TM shows up in my terminal scare me
+19:30 <obra> but only a bit less than that you typed it ;)
+19:30 <nothingmuch> utf8++
+19:31 <obra> ubuntu++
+19:31 <nothingmuch> most linuxes seem to get that refreshingly right
+19:31 <nothingmuch> so, erm
+19:31 <obra> yeah. it's pleasant.
+19:31 <nothingmuch> mxcompile
+19:31 <obra> anyway
+19:31 <nothingmuch> that is a nice frontend to the compiler object
+19:31 <obra> I guess "what do I need to do to try MX::Compile for prophet+sd?"
+19:31 <nothingmuch> it can recurse through a directory of modules, or take a list of classes
+19:31 <nothingmuch> for starters, role support
+19:31 <nothingmuch> i know how to do it
+19:31 <nothingmuch> but haven't yet
+19:32 <nothingmuch> type constraint support is very primitive
+19:32 <obra> is that essentially the same code sartak needs to write to give Mouse roles?
+19:32 <nothingmuch> i don't know what that is but doesn't sound likely
+19:32 <nothingmuch> in MXC moose has already done the role composition
+19:32 <nothingmuch> i just need to figure where the data came from, load that file and realias the subs
+19:33 <nothingmuch> (at bootstrap time)
+19:33 <nothingmuch> no role composition per se
+19:33 <nothingmuch> it's nice to make clear that MXC has two "levels" of awesome
+19:33 <nothingmuch> so you can figure out what you can hope to achieve
+19:34 <nothingmuch> 100% compiled everything means you don't load Moose or Class::MOP
+19:34 <nothingmuch> until you need runtime reflection
+19:34 <nothingmuch> no codegen at compile time
+19:34 <nothingmuch> it should load as fast as hand written code
+19:34 <nothingmuch> i've had it beating Object::Tiny in some benchmarks =)
+19:35 <obra> oo
+19:35 <nothingmuch> Moose::XS should aid in making MooseX::Compile's supported feature set easier
+19:35 <nothingmuch> the less awesome level of awesome is just some classes
+19:35 <nothingmuch> you don't pay for those classes' compilation (Role composition, etc)
+19:35 <obra> (especially since for me perl -MMoose -e1 takes up 50% of "sd help"'s runtime
+19:36 <obra> (.4s here)
+19:36 <nothingmuch> 5.8.8/
+19:36 <nothingmuch> ?
+19:36 <obra> yeah
+19:36 <obra> "that's what's in the wild"
+19:36 <nothingmuch> i'm just curious if it makes a dfif
+19:36 * obra nods
+19:36 <obra> I don't have my macbook right now or I'd test
+19:36 <nothingmuch> trunk moose loads slower
+19:36 <obra> how much slower?
+19:36 <nothingmuch> but 5.10 loads faster
+19:36 <nothingmuch> negligiably
+19:36 <nothingmuch> i think like 10%
+19:36 <obra> this was trunk moose as of friday
+19:36 <nothingmuch> but we can fix that
+19:36 <nothingmuch> ah
+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 <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:37 <nothingmuch> for a big app these probably will get loaded
+19:38 <nothingmuch> but for a small app, especially if you load the various sub modules only as needed, you shouldn't pay for these
+19:38 <nothingmuch> that's a trivial fix that perigrin started working on
+19:38 <obra> yeah. I played with his branch and saw no change as of last night
+19:39 <obra> so yeah, we're using roles. if roles aren't ready yet, I won't get far at all.
+19:39 <obra> (Also, I do really appreciate all the work you're doing. That I'm not paying for, even ;)
+19:39 <obra> Thank you.
+19:39 <nothingmuch> i will try shaving Moose's own load time with a profile based approach
+19:39 <obra> It's SO MUCH better than it was
+19:39 <nothingmuch> well, everybody wins =)
+19:39 <nothingmuch> a. you're a friend
+19:40 <nothingmuch> b. part of my job is making Moose work well
+19:40 <nothingmuch> c. your using Moose helps moose directly and indirectly
+19:40 <nothingmuch> d. I LIKE TACOS
+19:40 <nothingmuch> erm, i mean sushi
+19:40 <nothingmuch> so no worries on that
+19:41 <nothingmuch> so, long term goals:
+19:41 <nothingmuch> App::SD etc has all the meta calculations already cached in .mopc and .pmc
+19:41 <nothingmuch> moose is not loaded
+19:41 <nothingmuch> all generated code is cached
+19:41 <nothingmuch> at worst Moose::XS is loaded to install subs with newXS
+19:41 <obra> that would be really cool
+19:41 <nothingmuch> depending on which actually fairs better
+19:42 <nothingmuch> that goal is realistic, but involves a lot of work
+19:42 <nothingmuch> more realistic short term goals:
+19:42 <obra> I started playing with try to dump the symbol table, etc
+19:42 <nothingmuch> MooseX::Compile partly speeding up SD
+19:42 <nothingmuch> we can incrementally improve on that
+19:42 <obra> and found that DD::Streamer is a lot closer than anything has ever been, but it craps out around not being able to dump lvalue subs
+19:43 <nothingmuch> Moose::XS replacing some code gen
+19:43 <nothingmuch> yes, the initial approach was to to try and marshall Moose classes into DDS
+19:43 <nothingmuch> but it wasn't stable enough
+19:43 <nothingmuch> and also there's the problem of imports
+19:43 <nothingmuch> you must serialize the whole table at once
+19:43 <nothingmuch> or manage an intricate web of inter dependencies
+19:43 * obra nods
+19:44 <nothingmuch> i sort of work around that by making all the require()/use() statements stay verbatim
+19:44 <nothingmuch> also it doesn't handle xsubs
+19:44 <obra> how hard would it be to get moose's codegen to write out source code instead of blowing subs into memory?
+19:44 <nothingmuch> so there's guesswork for where ::bootstrap was called
+19:44 <nothingmuch> i was just getting to that =
+19:44 <nothingmuch> =)
+19:44 <nothingmuch> pretty trivial
+19:44 <obra> heh
+19:44 <nothingmuch> just grunt work
+19:44 <obra> is that a more viable approach?
+19:44 <nothingmuch> it's one of the limiting parts of MooseX::Compile
+19:45 <nothingmuch> if we clean up that code it will be easier to add support for more features
+19:45 <nothingmuch> but it's not a huge hurdle since it's a very contained problem
+19:45 <nothingmuch> it doesn't directly affect the design of MXC
+19:45 <obra> is this stuff written down anywhere other than this buffer?
+19:45 <nothingmuch> i don't think so
+19:46 <obra> where should it get pasted?
+19:46 <nothingmuch> good question =)
+19:46 <nothingmuch> i think #moose-dev is pretty aware
+19:46 <obra> is there a moose wiki?
+19:46 <nothingmuch> but documenting is good for people to help out
+19:46 <nothingmuch> no, there should be
+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:47 <nothingmuch> though most of this affects moose itself though
+19:47 * obra nods
+19:47 <obra> Moose/doc/moosex-compile, then
Modified: Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe1.pod
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe1.pod 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe1.pod 2009-01-17 20:17:26 UTC (rev 7315)
@@ -31,6 +31,14 @@
$self->z(0);
};
+ ....
+
+ # hash or hashrefs are ok for the constructor
+ my $point1 = Point->new(x => 5, y => 7);
+ my $point2 = Point->new({x => 5, y => 7});
+
+ my $point3d = Point3D->new(x => 5, y => 42, z => -5);
+
=head1 DESCRIPTION
This is the classic Point example. It is taken directly from the Perl
@@ -140,14 +148,18 @@
Since B<Point> inherits from L<Moose::Object>, it will also inherit
the default L<Moose::Object> constructor:
- my $point = Point ->new(x => 1, y => 2);
- my $point3d = Point3D->new(x => 1, y => 2, z => 3);
+ my $point1 = Point->new(x => 5, y => 7);
+ my $point2 = Point->new({x => 5, y => 7});
+ my $point3d = Point3D->new(x => 5, y => 42, z => -5);
+
The C<new> constructor accepts a named argument pair for each
-attribute defined by the class. In this particular example, the
-attributes are required, and calling C<new> without them will throw an
-error.
+attribute defined by the class, which you can provide as a hash or
+hash reference. In this particular example, the attributes are
+required, and calling C<new> without them will throw an error.
+ my $point = Point->new( x => 5 ); # no y, kaboom!
+
From here on, we can use C<$point> and C<$point3d> just as you would
any other Perl 5 object. For a more detailed example of what can be
done, you can refer to the F<t/000_recipes/basic/001_point.t> test
Modified: Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe10.pod
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe10.pod 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe10.pod 2009-01-17 20:17:26 UTC (rev 7315)
@@ -8,32 +8,33 @@
=head1 SYNOPSIS
package Human;
-
+
use Moose;
use Moose::Util::TypeConstraints;
-
+
subtype 'Gender'
=> as 'Str'
=> where { $_ =~ m{^[mf]$}s };
-
+
has 'gender' => ( is => 'ro', isa => 'Gender', required => 1 );
-
+
has 'mother' => ( is => 'ro', isa => 'Human' );
has 'father' => ( is => 'ro', isa => 'Human' );
-
+
use overload '+' => \&_overload_add, fallback => 1;
-
+
sub _overload_add {
- my ($one, $two) = @_;
-
+ my ( $one, $two ) = @_;
+
die('Only male and female humans may create children')
- if ($one->gender() eq $two->gender());
-
- my ( $mother, $father ) = ( $one->gender eq 'f' ? ($one, $two) : ($two, $one) );
-
+ if ( $one->gender() eq $two->gender() );
+
+ my ( $mother, $father )
+ = ( $one->gender eq 'f' ? ( $one, $two ) : ( $two, $one ) );
+
my $gender = 'f';
- $gender = 'm' if (rand() >= 0.5);
-
+ $gender = 'm' if ( rand() >= 0.5 );
+
return Human->new(
gender => $gender,
mother => $mother,
@@ -106,12 +107,12 @@
=head2 bey2
package Human::Gene::bey2;
-
+
use Moose;
use Moose::Util::TypeConstraints;
-
+
type 'bey2Color' => where { $_ =~ m{^(?:brown|blue)$}s };
-
+
has 'color' => ( is => 'ro', isa => 'bey2Color' );
This class is really simple. All we need to know about the bey2
@@ -122,12 +123,12 @@
=head2 gey
package Human::Gene::gey;
-
+
use Moose;
use Moose::Util::TypeConstraints;
-
+
type 'geyColor' => where { $_ =~ m{^(?:green|blue)$}s };
-
+
has 'color' => ( is => 'ro', isa => 'geyColor' );
The gey gene is nearly identical to the bey2, except that it
@@ -142,32 +143,32 @@
characteristics that makes up a Human.
package Human::EyeColor;
-
+
use Moose;
use Moose::Util::TypeConstraints;
-
+
subtype 'bey2Gene'
=> as 'Object'
=> where { $_->isa('Human::Gene::bey2') };
-
+
coerce 'bey2Gene'
=> from 'Str'
=> via { Human::Gene::bey2->new( color => $_ ) };
-
+
subtype 'geyGene'
=> as 'Object'
=> where { $_->isa('Human::Gene::gey') };
-
+
coerce 'geyGene'
=> from 'Str'
=> via { Human::Gene::gey->new( color => $_ ) };
-
+
has 'bey2_1' => ( is => 'ro', isa => 'bey2Gene', coerce => 1 );
has 'bey2_2' => ( is => 'ro', isa => 'bey2Gene', coerce => 1 );
-
- has 'gey_1' => ( is => 'ro', isa => 'geyGene', coerce => 1 );
- has 'gey_2' => ( is => 'ro', isa => 'geyGene', coerce => 1 );
+ has 'gey_1' => ( is => 'ro', isa => 'geyGene', coerce => 1 );
+ has 'gey_2' => ( is => 'ro', isa => 'geyGene', coerce => 1 );
+
So, we now have a class that can hold the four genes that dictate
eye color. This isn't quite enough, as we also need to calculate
what the human's actual eye color is as a result of the genes.
@@ -178,10 +179,16 @@
the bey and gey2 blue genes are recessive to both brown and green.
sub color {
- my ( $self ) = @_;
-
- return 'brown' if ($self->bey2_1->color() eq 'brown' or $self->bey2_2->color() eq 'brown');
- return 'green' if ($self->gey_1->color() eq 'green' or $self->gey_2->color() eq 'green');
+ my ($self) = @_;
+
+ return 'brown'
+ if ( $self->bey2_1->color() eq 'brown'
+ or $self->bey2_2->color() eq 'brown' );
+
+ return 'green'
+ if ( $self->gey_1->color() eq 'green'
+ or $self->gey_2->color() eq 'green' );
+
return 'blue';
}
@@ -202,16 +209,16 @@
the gene selection in human reproduction.
use overload '+' => \&_overload_add, fallback => 1;
-
+
sub _overload_add {
- my ($one, $two) = @_;
-
+ my ( $one, $two ) = @_;
+
my $one_bey2 = 'bey2_' . _rand2();
my $two_bey2 = 'bey2_' . _rand2();
-
+
my $one_gey = 'gey_' . _rand2();
my $two_gey = 'gey_' . _rand2();
-
+
return Human::EyeColor->new(
bey2_1 => $one->$one_bey2->color(),
bey2_2 => $two->$two_bey2->color(),
@@ -219,7 +226,7 @@
gey_2 => $two->$two_gey->color(),
);
}
-
+
sub _rand2 {
return 1 + int( rand(2) );
}
@@ -242,29 +249,28 @@
we'll coerce an arrayref of colors in to an EyeColor object.
use List::MoreUtils qw( zip );
-
+
subtype 'EyeColor'
=> as 'Object'
=> where { $_->isa('Human::EyeColor') };
-
+
coerce 'EyeColor'
=> from 'ArrayRef'
- => via {
- my @genes = qw( bey2_1 bey2_2 gey_1 gey_2 );
- return Human::EyeColor->new( zip( @genes, @$_ ) );
- };
-
- has 'eye_color' => ( is => 'ro', isa => 'EyeColor', coerce => 1, required => 1 );
+ => via { my @genes = qw( bey2_1 bey2_2 gey_1 gey_2 );
+ return Human::EyeColor->new( zip( @genes, @$_ ) ); };
+ has 'eye_color' =>
+ ( is => 'ro', isa => 'EyeColor', coerce => 1, required => 1 );
+
And then in the _overload_add() of the Human class we modify
the creation of the child object to include the addition of
the mother and father's eye colors.
return Human->new(
- gender => $gender,
+ gender => $gender,
eye_color => ( $one->eye_color() + $two->eye_color() ),
- mother => $mother,
- father => $father,
+ mother => $mother,
+ father => $father,
);
=head1 CONCLUSION
Modified: Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe2.pod
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe2.pod 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe2.pod 2009-01-17 20:17:26 UTC (rev 7315)
@@ -9,33 +9,33 @@
package BankAccount;
use Moose;
-
- has 'balance' => (isa => 'Int', is => 'rw', default => 0);
-
+
+ has 'balance' => ( isa => 'Int', is => 'rw', default => 0 );
+
sub deposit {
- my ($self, $amount) = @_;
- $self->balance($self->balance + $amount);
+ my ( $self, $amount ) = @_;
+ $self->balance( $self->balance + $amount );
}
-
+
sub withdraw {
- my ($self, $amount) = @_;
+ my ( $self, $amount ) = @_;
my $current_balance = $self->balance();
- ($current_balance >= $amount)
+ ( $current_balance >= $amount )
|| confess "Account overdrawn";
- $self->balance($current_balance - $amount);
+ $self->balance( $current_balance - $amount );
}
-
+
package CheckingAccount;
use Moose;
-
+
extends 'BankAccount';
-
- has 'overdraft_account' => (isa => 'BankAccount', is => 'rw');
-
+
+ has 'overdraft_account' => ( isa => 'BankAccount', is => 'rw' );
+
before 'withdraw' => sub {
- my ($self, $amount) = @_;
+ my ( $self, $amount ) = @_;
my $overdraft_amount = $amount - $self->balance();
- if ($self->overdraft_account && $overdraft_amount > 0) {
+ if ( $self->overdraft_account && $overdraft_amount > 0 ) {
$self->overdraft_account->withdraw($overdraft_amount);
$self->deposit($overdraft_amount);
}
@@ -45,11 +45,11 @@
The first recipe demonstrated how to build very basic Moose classes,
focusing on creating and manipulating attributes. The objects in that
-recipe very data-oriented, and did not have much in the way of
+recipe were very data-oriented, and did not have much in the way of
behavior (i.e. methods). In this recipe, we expand upon the concepts
from the first recipe to include some real behavior. In particular, we
-should how you can use a method modifier to implement new behavior for
-a method.
+show how you can use a method modifier to implement new behavior for a
+method.
The classes in the SYNOPSIS show two kinds of bank account. A simple
bank account has one attribute, the balance, and two behaviors,
@@ -65,7 +65,7 @@
The first class, B<BankAccount>, introduces a new attribute feature, a
default value:
- has 'balance' => (isa => 'Int', is => 'rw', default => 0);
+ has 'balance' => ( isa => 'Int', is => 'rw', default => 0 );
This says that a B<BankAccount> has a C<balance> attribute, which has
a C<Int> type constraint, a read/write accessor, and a default value
@@ -81,7 +81,7 @@
B<BankAccount>. The next line introduces yet another new attribute
feature, class-based type constraints:
- has 'overdraft_account' => (isa => 'BankAccount', is => 'rw');
+ has 'overdraft_account' => ( isa => 'BankAccount', is => 'rw' );
Up until now, we have only seen the C<Int> type constraint, which (as
we saw in the first recipe) is a builtin type constraint. The
@@ -101,9 +101,9 @@
modifier.
before 'withdraw' => sub {
- my ($self, $amount) = @_;
+ my ( $self, $amount ) = @_;
my $overdraft_amount = $amount - $self->balance();
- if ($self->overdraft_account && $overdraft_amount > 0) {
+ if ( $self->overdraft_account && $overdraft_amount > 0 ) {
$self->overdraft_account->withdraw($overdraft_amount);
$self->deposit($overdraft_amount);
}
@@ -124,9 +124,9 @@
C<SUPER::> to get the same effect:
sub withdraw {
- my ($self, $amount) = @_;
+ my ( $self, $amount ) = @_;
my $overdraft_amount = $amount - $self->balance();
- if ($self->overdraft_account && $overdraft_amount > 0) {
+ if ( $self->overdraft_account && $overdraft_amount > 0 ) {
$self->overdraft_account->withdraw($overdraft_amount);
$self->deposit($overdraft_amount);
}
Modified: Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe3.pod
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe3.pod 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe3.pod 2009-01-17 20:17:26 UTC (rev 7315)
@@ -9,35 +9,35 @@
package BinaryTree;
use Moose;
-
- has 'node' => (is => 'rw', isa => 'Any');
-
+
+ has 'node' => ( is => 'rw', isa => 'Any' );
+
has 'parent' => (
is => 'rw',
- isa => 'BinaryTree',
+ isa => 'BinaryTree',
predicate => 'has_parent',
weak_ref => 1,
);
-
+
has 'left' => (
- is => 'rw',
- isa => 'BinaryTree',
- predicate => 'has_left',
+ is => 'rw',
+ isa => 'BinaryTree',
+ predicate => 'has_left',
lazy => 1,
- default => sub { BinaryTree->new(parent => $_[0]) },
+ default => sub { BinaryTree->new( parent => $_[0] ) },
);
-
+
has 'right' => (
- is => 'rw',
- isa => 'BinaryTree',
- predicate => 'has_right',
- lazy => 1,
- default => sub { BinaryTree->new(parent => $_[0]) },
+ is => 'rw',
+ isa => 'BinaryTree',
+ predicate => 'has_right',
+ lazy => 1,
+ default => sub { BinaryTree->new( parent => $_[0] ) },
);
-
+
before 'right', 'left' => sub {
- my ($self, $tree) = @_;
- $tree->parent($self) if defined $tree;
+ my ( $self, $tree ) = @_;
+ $tree->parent($self) if defined $tree;
};
=head1 DESCRIPTION
@@ -55,7 +55,7 @@
Now, let's start with the code. Our first attribute is the C<node>
slot, defined as such:
- has 'node' => (is => 'rw', isa => 'Any');
+ has 'node' => ( is => 'rw', isa => 'Any' );
If you recall from the previous recipes, this slot will have a read/write
accessor generated for it, and has a type constraint on it. The new item here is
@@ -72,7 +72,7 @@
has 'parent' => (
is => 'rw',
- isa => 'BinaryTree',
+ isa => 'BinaryTree',
predicate => 'has_parent',
weak_ref => 1,
);
@@ -100,11 +100,11 @@
save for different names, so I will just describe one here:
has 'left' => (
- is => 'rw',
- isa => 'BinaryTree',
- predicate => 'has_left',
+ is => 'rw',
+ isa => 'BinaryTree',
+ predicate => 'has_left',
lazy => 1,
- default => sub { BinaryTree->new(parent => $_[0]) },
+ default => sub { BinaryTree->new( parent => $_[0] ) },
);
You already know what the C<is>, C<isa> and C<predicate> options do, but now we
@@ -122,11 +122,11 @@
(ARRAY ref, HASH ref, object instance, etc) you would need to
wrap it in a CODE reference, so this:
- has 'foo' => (is => 'rw', default => []);
+ has 'foo' => ( is => 'rw', default => [] );
is actually illegal in Moose. Instead, what you really want is this:
- has 'foo' => (is => 'rw', default => sub { [] });
+ has 'foo' => ( is => 'rw', default => sub { [] } );
This ensures that each instance of this class will get its own ARRAY ref in the
C<foo> slot.
@@ -136,7 +136,7 @@
where the slot will be stored. This can come in quite handy at times, as
illustrated above, with this code:
- default => sub { BinaryTree->new(parent => $_[0]) },
+ default => sub { BinaryTree->new( parent => $_[0] ) },
The default value being generated is a new C<BinaryTree> instance for the
C<left> (or C<right>) slot. Here we set up the correct relationship by passing
@@ -173,10 +173,10 @@
that would require us to implement all those features we got automatically (type
constraints, lazy initialization, and so on). Instead, we use method modifiers
again:
-
+
before 'right', 'left' => sub {
- my ($self, $tree) = @_;
- $tree->parent($self) if defined $tree;
+ my ( $self, $tree ) = @_;
+ $tree->parent($self) if defined $tree;
};
This is a C<before> modifier, just like we saw in the second recipe, but with
Modified: Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe4.pod
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe4.pod 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe4.pod 2009-01-17 20:17:26 UTC (rev 7315)
@@ -6,90 +6,91 @@
Moose::Cookbook::Basics::Recipe4 - Subtypes, and modeling a simple B<Company> class hierarchy
=head1 SYNOPSIS
-
+
package Address;
use Moose;
use Moose::Util::TypeConstraints;
-
+
use Locale::US;
use Regexp::Common 'zip';
-
+
my $STATES = Locale::US->new;
-
- subtype USState
+ subtype 'USState'
=> as Str
=> where {
- (exists $STATES->{code2state}{uc($_)} ||
- exists $STATES->{state2code}{uc($_)})
- };
-
- subtype USZipCode
+ ( exists $STATES->{code2state}{ uc($_) }
+ || exists $STATES->{state2code}{ uc($_) } );
+ };
+
+ subtype 'USZipCode'
=> as Value
=> where {
- /^$RE{zip}{US}{-extended => 'allow'}$/
- };
-
- has 'street' => (is => 'rw', isa => 'Str');
- has 'city' => (is => 'rw', isa => 'Str');
- has 'state' => (is => 'rw', isa => 'USState');
- has 'zip_code' => (is => 'rw', isa => 'USZipCode');
-
+ /^$RE{zip}{US}{-extended => 'allow'}$/;
+ };
+
+ has 'street' => ( is => 'rw', isa => 'Str' );
+ has 'city' => ( is => 'rw', isa => 'Str' );
+ has 'state' => ( is => 'rw', isa => 'USState' );
+ has 'zip_code' => ( is => 'rw', isa => 'USZipCode' );
+
package Company;
use Moose;
use Moose::Util::TypeConstraints;
-
- has 'name' => (is => 'rw', isa => 'Str', required => 1);
- has 'address' => (is => 'rw', isa => 'Address');
- has 'employees' => (is => 'rw', isa => 'ArrayRef[Employee]');
-
+
+ has 'name' => ( is => 'rw', isa => 'Str', required => 1 );
+ has 'address' => ( is => 'rw', isa => 'Address' );
+ has 'employees' => ( is => 'rw', isa => 'ArrayRef[Employee]' );
+
sub BUILD {
- my ($self, $params) = @_;
- if ($params->{employees}) {
- foreach my $employee (@{$params->{employees}}) {
+ my ( $self, $params ) = @_;
+ if ( $params->{employees} ) {
+ foreach my $employee ( @{ $params->{employees} } ) {
$employee->company($self);
}
}
}
-
+
after 'employees' => sub {
- my ($self, $employees) = @_;
- if (defined $employees) {
- foreach my $employee (@{$employees}) {
+ my ( $self, $employees ) = @_;
+ if ( defined $employees ) {
+ foreach my $employee ( @{$employees} ) {
$employee->company($self);
- }
+ }
}
- };
-
+ };
+
package Person;
use Moose;
-
- has 'first_name' => (is => 'rw', isa => 'Str', required => 1);
- has 'last_name' => (is => 'rw', isa => 'Str', required => 1);
- has 'middle_initial' => (is => 'rw', isa => 'Str',
- predicate => 'has_middle_initial');
- has 'address' => (is => 'rw', isa => 'Address');
-
+
+ has 'first_name' => ( is => 'rw', isa => 'Str', required => 1 );
+ has 'last_name' => ( is => 'rw', isa => 'Str', required => 1 );
+ has 'middle_initial' => (
+ is => 'rw', isa => 'Str',
+ predicate => 'has_middle_initial'
+ );
+ has 'address' => ( is => 'rw', isa => 'Address' );
+
sub full_name {
my $self = shift;
- return $self->first_name .
- ($self->has_middle_initial ?
- ' ' . $self->middle_initial . '. '
- :
- ' ') .
- $self->last_name;
+ return $self->first_name
+ . (
+ $self->has_middle_initial
+ ? ' ' . $self->middle_initial . '. '
+ : ' '
+ ) . $self->last_name;
}
-
+
package Employee;
- use Moose;
-
+ use Moose;
+
extends 'Person';
-
- has 'title' => (is => 'rw', isa => 'Str', required => 1);
- has 'company' => (is => 'rw', isa => 'Company', weak_ref => 1);
-
+
+ has 'title' => ( is => 'rw', isa => 'Str', required => 1 );
+ has 'company' => ( is => 'rw', isa => 'Company', weak_ref => 1 );
+
override 'full_name' => sub {
my $self = shift;
- super() . ', ' . $self->title
+ super() . ', ' . $self->title;
};
=head1 DESCRIPTION
@@ -106,14 +107,14 @@
provides two hashes which can be used to perform existential checks for state
names and their two letter state codes. It is a very simple and very useful
module, and perfect for use in a C<subtype> constraint.
-
- my $STATES = Locale::US->new;
- subtype USState
+
+ my $STATES = Locale::US->new;
+ subtype 'USState'
=> as Str
=> where {
- (exists $STATES->{code2state}{uc($_)} ||
- exists $STATES->{state2code}{uc($_)})
- };
+ ( exists $STATES->{code2state}{ uc($_) }
+ || exists $STATES->{state2code}{ uc($_) } );
+ };
Because we know that states will be passed to us as strings, we
can make C<USState> a subtype of the built-in type constraint
@@ -126,7 +127,7 @@
criteria, then the constraint will pass, otherwise it will fail.
We can now use this as we would any built-in constraint, like so:
- has 'state' => (is => 'rw', isa => 'USState');
+ has 'state' => ( is => 'rw', isa => 'USState' );
The C<state> accessor will now check all values against the
C<USState> constraint, thereby only allowing valid state names or
@@ -135,11 +136,11 @@
The next C<subtype> does pretty much the same thing using the L<Regexp::Common>
module, and is used as the constraint for the C<zip_code> slot.
- subtype USZipCode
+ subtype 'USZipCode'
=> as Value
=> where {
- /^$RE{zip}{US}{-extended => 'allow'}$/
- };
+ /^$RE{zip}{US}{-extended => 'allow'}$/;
+ };
Using subtypes can save a lot of unnecessary abstraction by not requiring you to
create many small classes for these relatively simple values. They also allow
@@ -153,11 +154,11 @@
earlier recipes, we can use the C<Address> type constraint that
Moose automatically created for us:
- has 'address' => (is => 'rw', isa => 'Address');
+ has 'address' => ( is => 'rw', isa => 'Address' );
A company also needs a name, so we define that as well:
- has 'name' => (is => 'rw', isa => 'Str', required => 1);
+ has 'name' => ( is => 'rw', isa => 'Str', required => 1 );
Here we introduce another attribute option, the C<required> option.
This option tells Moose that C<name> is a required parameter in
@@ -167,9 +168,9 @@
The next attribute option is not actually new, but a new variant
of options we have already introduced:
-
- has 'employees' => (is => 'rw', isa => 'ArrayRef[Employee]');
+ has 'employees' => ( is => 'rw', isa => 'ArrayRef[Employee]' );
+
Here, we are passing a more complex string to the C<isa> option, we
are passing a container type constraint. Container type constraints
can either be C<ArrayRef> or C<HashRef> with a contained type given
@@ -184,11 +185,11 @@
This is accomplished in two places. First we need to be sure that any employees
array passed to the constructor is properly initialized. For this we can use the
C<BUILD> method (2):
-
+
sub BUILD {
- my ($self, $params) = @_;
- if ($params->{employees}) {
- foreach my $employee (@{$params->{employees}}) {
+ my ( $self, $params ) = @_;
+ if ( $params->{employees} ) {
+ foreach my $employee ( @{ $params->{employees} } ) {
$employee->company($self);
}
}
@@ -206,11 +207,11 @@
like so:
after 'employees' => sub {
- my ($self, $employees) = @_;
- if (defined $employees) {
- foreach my $employee (@{$employees}) {
+ my ( $self, $employees ) = @_;
+ if ( defined $employees ) {
+ foreach my $employee ( @{$employees} ) {
$employee->company($self);
- }
+ }
}
};
@@ -234,7 +235,7 @@
override 'full_name' => sub {
my $self = shift;
- super() . ', ' . $self->title
+ super() . ', ' . $self->title;
};
This just tells Moose that I am intentionally overriding the superclass
Modified: Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe5.pod
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe5.pod 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe5.pod 2009-01-17 20:17:26 UTC (rev 7315)
@@ -10,61 +10,61 @@
package Request;
use Moose;
use Moose::Util::TypeConstraints;
-
+
use HTTP::Headers ();
use Params::Coerce ();
use URI ();
-
+
subtype 'Header'
=> as 'Object'
=> where { $_->isa('HTTP::Headers') };
-
+
coerce 'Header'
=> from 'ArrayRef'
- => via { HTTP::Headers->new( @{ $_ } ) }
+ => via { HTTP::Headers->new( @{$_} ) }
=> from 'HashRef'
- => via { HTTP::Headers->new( %{ $_ } ) };
-
+ => via { HTTP::Headers->new( %{$_} ) };
+
subtype 'Uri'
=> as 'Object'
=> where { $_->isa('URI') };
-
+
coerce 'Uri'
=> from 'Object'
- => via { $_->isa('URI')
- ? $_
- : Params::Coerce::coerce( 'URI', $_ ) }
+ => via { $_->isa('URI')
+ ? $_
+ : Params::Coerce::coerce( 'URI', $_ ); }
=> from 'Str'
=> via { URI->new( $_, 'http' ) };
-
+
subtype 'Protocol'
- => as Str
+ => as 'Str'
=> where { /^HTTP\/[0-9]\.[0-9]$/ };
-
- has 'base' => (is => 'rw', isa => 'Uri', coerce => 1);
- has 'uri' => (is => 'rw', isa => 'Uri', coerce => 1);
- has 'method' => (is => 'rw', isa => 'Str');
- has 'protocol' => (is => 'rw', isa => 'Protocol');
+
+ has 'base' => ( is => 'rw', isa => 'Uri', coerce => 1 );
+ has 'uri' => ( is => 'rw', isa => 'Uri', coerce => 1 );
+ has 'method' => ( is => 'rw', isa => 'Str' );
+ has 'protocol' => ( is => 'rw', isa => 'Protocol' );
has 'headers' => (
is => 'rw',
isa => 'Header',
coerce => 1,
- default => sub { HTTP::Headers->new }
+ default => sub { HTTP::Headers->new }
);
=head1 DESCRIPTION
-This recipe introduces the idea of type coercions, and the C<coerce>
-keyword. Coercions can be attached to existing type constraints,
-and can be used to transform input of one type into input of another
-type. This can be an extremely powerful tool if used correctly, which
-is why it is off by default. If you want your accessor to attempt
-a coercion, you must specifically ask for it with the B<coerce> option.
+This recipe introduces the idea of type coercions, and the C<coerce>
+keyword. Coercions can be attached to existing type constraints, and
+can be used to transform input of one type into input of another
+type. This can be an extremely powerful tool if used correctly, which
+is why it is off by default. If you want your accessor to attempt a
+coercion, you must specifically ask for it with the B<coerce> option.
-Now, onto the coercions.
+Now, onto the coercions.
-First we need to create a subtype to attach our coercion to. Here we
-create a basic I<Header> subtype, which matches any instance of the
+First we need to create a subtype to attach our coercion to. Here we
+create a basic I<Header> subtype, which matches any instance of the
class B<HTTP::Headers>:
subtype 'Header'
@@ -74,60 +74,60 @@
The simplest thing from here would be create an accessor declaration
like this:
- has 'headers' => (
+ has 'headers' => (
is => 'rw',
isa => 'Header',
- default => sub { HTTP::Headers->new }
+ default => sub { HTTP::Headers->new }
);
-We would then have a self-validating accessor whose default value is
-an empty instance of B<HTTP::Headers>. This is nice, but it is not
+We would then have a self-validating accessor whose default value is
+an empty instance of B<HTTP::Headers>. This is nice, but it is not
ideal.
The constructor for B<HTTP::Headers> accepts a list of key-value pairs
-representing the HTTP header fields. In Perl, such a list could
-easily be stored in an ARRAY or HASH reference. We would like our
-class's interface to be able to accept this list of key-value pairs
-in place of the B<HTTP::Headers> instance, and just DWIM. This is where
+representing the HTTP header fields. In Perl, such a list could easily
+be stored in an ARRAY or HASH reference. We would like our class's
+interface to be able to accept this list of key-value pairs in place
+of the B<HTTP::Headers> instance, and just DWIM. This is where
coercion can help. First, let's declare our coercion:
coerce 'Header'
=> from 'ArrayRef'
- => via { HTTP::Headers->new( @{ $_ } ) }
+ => via { HTTP::Headers->new( @{$_} ) }
=> from 'HashRef'
- => via { HTTP::Headers->new( %{ $_ } ) };
+ => via { HTTP::Headers->new( %{$_} ) };
We first tell it that we are attaching the coercion to the 'Header'
-subtype. We then give it a set of C<from> clauses which map other
-subtypes to coercion routines (through the C<via> keyword). Fairly
-simple really; however, this alone does nothing. We have to tell
-our attribute declaration to actually use the coercion, like so:
+subtype. We then give it a set of C<from> clauses which map other
+subtypes to coercion routines (through the C<via> keyword). Fairly
+simple really; however, this alone does nothing. We have to tell our
+attribute declaration to actually use the coercion, like so:
- has 'headers' => (
+ has 'headers' => (
is => 'rw',
isa => 'Header',
coerce => 1,
- default => sub { HTTP::Headers->new }
+ default => sub { HTTP::Headers->new }
);
This will coerce any B<ArrayRef> or B<HashRef> which is passed into
the C<headers> accessor into an instance of B<HTTP::Headers>. So the
the following lines of code are all equivalent:
- $foo->headers(HTTP::Headers->new(bar => 1, baz => 2));
- $foo->headers([ 'bar', 1, 'baz', 2 ]);
- $foo->headers({ bar => 1, baz => 2 });
+ $foo->headers( HTTP::Headers->new( bar => 1, baz => 2 ) );
+ $foo->headers( [ 'bar', 1, 'baz', 2 ] );
+ $foo->headers( { bar => 1, baz => 2 } );
-As you can see, careful use of coercions can produce a very open
-interface for your class, while still retaining the "safety" of
-your type constraint checks.
+As you can see, careful use of coercions can produce a very open
+interface for your class, while still retaining the "safety" of your
+type constraint checks.
-Our next coercion takes advantage of the power of CPAN to handle
-the details of our coercion. In this particular case it uses the
+Our next coercion takes advantage of the power of CPAN to handle the
+details of our coercion. In this particular case it uses the
L<Params::Coerce> module, which fits in rather nicely with L<Moose>.
-Again, we create a simple subtype to represent instances of the
-B<URI> class:
+Again, we create a simple subtype to represent instances of the B<URI>
+class:
subtype 'Uri'
=> as 'Object'
@@ -137,50 +137,50 @@
coerce 'Uri'
=> from 'Object'
- => via { $_->isa('URI')
- ? $_
- : Params::Coerce::coerce( 'URI', $_ ) }
+ => via { $_->isa('URI')
+ ? $_
+ : Params::Coerce::coerce( 'URI', $_ ); }
=> from 'Str'
=> via { URI->new( $_, 'http' ) };
-The first C<from> clause we introduce is for the 'Object' subtype. An 'Object'
-is simply any C<bless>ed value. This means that if the coercion encounters
-another object, it should use this clause. Now we look at the C<via> block.
-First it checks to see if the object is a B<URI> instance. Since the coercion
-process occurs prior to any type constraint checking, it is entirely possible
-for this to happen, and if it does happen, we simply want to pass the instance
-on through. However, if it is not an instance of B<URI>, then we need to coerce
-it. This is where L<Params::Coerce> can do its magic, and we can just use its
-return value. Simple really, and much less work since we used a module from CPAN
-:)
+The first C<from> clause we introduce is for the 'Object' subtype. An
+'Object' is simply any C<bless>ed value. This means that if the
+coercion encounters another object, it should use this clause. Now we
+look at the C<via> block. First it checks to see if the object is a
+B<URI> instance. Since the coercion process occurs prior to any type
+constraint checking, it is entirely possible for this to happen, and
+if it does happen, we simply want to pass the instance on
+through. However, if it is not an instance of B<URI>, then we need to
+coerce it. This is where L<Params::Coerce> can do its magic, and we
+can just use its return value. Simple really, and much less work since
+we used a module from CPAN :)
-The second C<from> clause is attached to the 'Str' subtype, and
-illustrates how coercions can also be used to handle certain
-'default' behaviors. In this coercion, we simple take any string
-and pass it to the B<URI> constructor along with the default
-'http' scheme type.
+The second C<from> clause is attached to the 'Str' subtype, and
+illustrates how coercions can also be used to handle certain 'default'
+behaviors. In this coercion, we simple take any string and pass it to
+the B<URI> constructor along with the default 'http' scheme type.
-And of course, our coercions do nothing unless they are told to,
-like so:
+And of course, our coercions do nothing unless they are told to, like
+so:
- has 'base' => (is => 'rw', isa => 'Uri', coerce => 1);
- has 'uri' => (is => 'rw', isa => 'Uri', coerce => 1);
+ has 'base' => ( is => 'rw', isa => 'Uri', coerce => 1 );
+ has 'uri' => ( is => 'rw', isa => 'Uri', coerce => 1 );
-As you can see, re-using the coercion allows us to enforce a
+As you can see, re-using the coercion allows us to enforce a
consistent and very flexible API across multiple accessors.
=head1 CONCLUSION
-This recipe illustrated the power of coercions to build a more
-flexible and open API for your accessors, while still retaining
-all the safety that comes from using Moose's type constraints.
-Using coercions it becomes simple to manage (from a single
-location) a consistent API not only across multiple accessors,
-but across multiple classes as well.
+This recipe illustrated the power of coercions to build a more
+flexible and open API for your accessors, while still retaining all
+the safety that comes from using Moose's type constraints. Using
+coercions it becomes simple to manage (from a single location) a
+consistent API not only across multiple accessors, but across multiple
+classes as well.
-In the next recipe, we will introduce roles, a concept originally
-borrowed from Smalltalk, which made it's way into Perl 6, and
-now into Moose.
+In the next recipe, we will introduce roles, a concept originally
+borrowed from Smalltalk, which made its way into Perl 6, and now into
+Moose.
=head1 AUTHOR
@@ -195,4 +195,4 @@
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
-=cut
\ No newline at end of file
+=cut
Modified: Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe6.pod
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe6.pod 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe6.pod 2009-01-17 20:17:26 UTC (rev 7315)
@@ -6,58 +6,59 @@
Moose::Cookbook::Basics::Recipe6 - The augment/inner example
=head1 SYNOPSIS
-
+
package Document::Page;
use Moose;
-
- has 'body' => (is => 'rw', isa => 'Str', default => sub {''});
-
+
+ has 'body' => ( is => 'rw', isa => 'Str', default => sub {''} );
+
sub create {
my $self = shift;
$self->open_page;
inner();
$self->close_page;
}
-
- sub append_body {
- my ($self, $appendage) = @_;
- $self->body($self->body . $appendage);
+
+ sub append_body {
+ my ( $self, $appendage ) = @_;
+ $self->body( $self->body . $appendage );
}
-
+
sub open_page { (shift)->append_body('<page>') }
- sub close_page { (shift)->append_body('</page>') }
-
+ sub close_page { (shift)->append_body('</page>') }
+
package Document::PageWithHeadersAndFooters;
use Moose;
-
+
extends 'Document::Page';
-
+
augment 'create' => sub {
my $self = shift;
$self->create_header;
inner();
$self->create_footer;
};
-
+
sub create_header { (shift)->append_body('<header/>') }
- sub create_footer { (shift)->append_body('<footer/>') }
-
+ sub create_footer { (shift)->append_body('<footer/>') }
+
package TPSReport;
use Moose;
-
+
extends 'Document::PageWithHeadersAndFooters';
-
+
augment 'create' => sub {
my $self = shift;
$self->create_tps_report;
};
-
+
sub create_tps_report {
- (shift)->append_body('<report type="tps"/>')
+ (shift)->append_body('<report type="tps"/>');
}
-
- print TPSReport->new->create # <page><header/><report type="tps"/><footer/></page>
+ # <page><header/><report type="tps"/><footer/></page>
+ print TPSReport->new->create;
+
=head1 DESCRIPTION
Coming Soon.
Modified: Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe7.pod
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe7.pod 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Cookbook/Basics/Recipe7.pod 2009-01-17 20:17:26 UTC (rev 7315)
@@ -10,8 +10,8 @@
package Point;
use Moose;
- has 'x' => (isa => 'Int', is => 'ro');
- has 'y' => (isa => 'Int', is => 'rw');
+ has 'x' => ( isa => 'Int', is => 'ro' );
+ has 'y' => ( isa => 'Int', is => 'rw' );
__PACKAGE__->meta->make_immutable;
Modified: Moose/branches/Moose-XS/lib/Moose/Cookbook/Extending/Recipe1.pod
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Cookbook/Extending/Recipe1.pod 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Cookbook/Extending/Recipe1.pod 2009-01-17 20:17:26 UTC (rev 7315)
@@ -3,79 +3,321 @@
=head1 NAME
-Moose::Cookbook::Extending::Recipe1 - Providing an alternate base object class
+Moose::Cookbook::Extending::Recipe1 - Moose extension overview
-=head1 SYNOPSIS
+=head1 DESCRIPTION
- package MyApp::Base;
- use Moose;
+Moose has quite a number of ways in which extensions can hook into
+Moose and change its behavior. Moose also has a lot of behavior that
+can be changed. This recipe will provide an overview of each extension
+method and give you some recommendations on what tools to use.
- extends 'Moose::Object';
+If you haven't yet read the recipes on metaclasses, go read those
+first. You can't really write Moose extensions without understanding
+the metaclasses, and those recipes also demonstrate some basic
+extensions mechanisms such as metaclass subclasses and traits.
- before 'new' => sub { warn "Making a new " . $_[0] };
+=head2 Playing Nice With Others
- no Moose;
+One of the goals of this overview is to help you build extensions that
+cooperate well with other extensions. This is especially important if
+you plan to release your extension to CPAN.
- package MyApp::UseMyBase;
+Moose comes with several modules that exist to help your write
+cooperative extensions. These are L<Moose::Exporter> and
+L<Moose::Util::MetaRole>. By using these two modules to implement your
+extensions, you will ensure that your extension works with both the
+Moose core features and any other CPAN extension using those modules.
+
+=head1 PARTS OF Moose YOU CAN EXTEND
+
+The types of things you might want to do in Moose extensions broadly
+fall into a few categories.
+
+=head2 Metaclass Extensions
+
+One way of extending Moose is by extending one or more Moose
+metaclasses. For example, in L<Moose::Cookbook::Meta::Recipe4> we saw
+a metaclass subclass that added a C<table> attribute to the
+metaclass. If you were writing an ORM, this would be a logical
+extension.
+
+Many of the Moose extensions on CPAN work by providing an attribute
+metaclass extension. For example, the C<MooseX::AttributeHelpers>
+distro provides a new attribute metaclass that lets you delegate
+behavior to a non-object attribute (a hashref or simple number).
+
+A metaclass extension can be packaged as a subclass or a
+role/trait. If you can, we recommend using traits instead of
+subclasses, since it's generally much easier to combine disparate
+traits then it is to combine a bunch of subclasses.
+
+When your extensions are implemented as roles, you can apply them with
+the L<Moose::Util::MetaRole> module.
+
+=head2 Providing Sugar Subs
+
+As part of a metaclass extension, you may also want to provide some
+sugar subroutines, much like C<Moose.pm> does. Moose provides a helper
+module called L<Moose::Exporter> that makes this much simpler. This
+will be used in several of the extension recipes.
+
+=head2 Object Class Extensions
+
+Another common Moose extension is to change the default object class
+behavior. For example, the C<MooseX::Singleton> extension changes the
+behavior of your objects so that they are singletons. The
+C<MooseX::StrictConstructor> extension makes the constructor reject
+arguments which don't match its attributes.
+
+Object class extensions often also include metaclass extensions. In
+particular, if you want your object extension to work when a class is
+made immutable, you may need to extend some or all of the
+C<Moose::Meta::Instance>, C<Moose::Meta::Method::Constructor>, and
+C<Moose::Meta::Method::Destructor> objects.
+
+The L<Moose::Util::MetaRole> module lets you apply roles to the base
+object class, as well as the meta classes just mentioned.
+
+=head2 Providing a Role
+
+Some extensions come in the form of a role for you to consume. The
+C<MooseX::Object::Pluggable> extension is a great example of this. In
+fact, despite the C<MooseX> name, it does not actually change anything
+about Moose's behavior. Instead, it is just a role that an object
+which wants to be pluggable can consume.
+
+If you are implementing this sort of extension, you don't need to do
+anything special. You simply create a role and document that it should
+be used via the normal C<with> sugar:
+
+ package RoleConsumer;
+
+ use Moose;
+
+ with 'MooseX::My::Role';
+
+=head2 New Types
+
+Another common Moose extension is a new type for the Moose type
+system. In this case, you simply create a type in your module. When
+people load your module, the type is created, and they can refer to it
+by name after that. The C<MooseX::Types::URI> and
+C<MooseX::Types::DateTime> distros are two good examples of how this
+works.
+
+=head1 ROLES VS TRAITS VS SUBCLASSES
+
+It is important to understand that B<roles and traits are the same
+thing>. A role can be used as a trait, and a trait is a role. The only
+thing that distinguishes the two is that a trait is packaged in a way
+that lets Moose resolve a short name to a class name. In other words,
+with a trait, the caller can specify it by a short name like "Big",
+and Moose will resolve it to a class like
+C<MooseX::Embiggen::Meta::Attribute::Role::Big>.
+
+See L<Moose::Cookbook::Meta::Recipe3> and
+L<Moose::Cookbook::Meta::Recipe5> for examples of traits in action. In
+particular, both of these recipes demonstrate the trait resolution
+mechanism.
+
+Implementing an extension as a (set of) metaclass or base object
+role(s) will make your extension more cooperative. It is hard for an
+end-user to effectively combine together multiple metaclass
+subclasses, but it can be very easy to combine roles.
+
+=head1 USING YOUR EXTENSION
+
+There are a number of ways in which an extension can be applied. In
+some cases you can provide multiple ways of consuming your extension.
+
+=head2 Extensions as Metaclass Traits
+
+If your extension is available as a trait, you can ask end users to
+simply specify it in a list of traits. Currently, this only works for
+metaclass and attribute metaclass traits:
+
+ use Moose -traits => [ 'Big', 'Blue' ];
+
+ has 'animal' => (
+ traits => [ 'Big', 'Blue' ],
+ ...
+ );
+
+If your extension applies to any other metaclass, or the object base
+class, you cannot use the trait mechanism.
+
+The benefit of the trait mechanism is that is very easy to see where a
+trait is applied in the code, and consumers have fine-grained control
+over what the trait applies to. This is especially true for attribute
+traits, where you can apply the trait to just one attribute in a
+class.
+
+=head2 Extensions as Metaclass (and Base Object) Subclasses
+
+Moose does not provide any simple APIs for consumers to use a subclass
+extension, except for attribute metaclasses. The attribute declaration
+parameters include a C<metaclass> parameter a consumer of your
+extension can use to specify your subclass.
+
+This is one reason why implementing an extension as a subclass can be
+a poor choice. However, you can force the use of certain subclasses at
+import time by calling C<< Moose->init_meta >> for the caller, and
+providing an alternate metaclass or base object class.
+
+If you do want to do this, you should look at using C<Moose::Exporter>
+to re-export the C<Moose.pm> sugar subroutines. When you use
+L<Moose::Exporter> and your exporting class has an C<init_meta>
+method, L<Moose::Exporter> makes sure that this C<init_meta> method
+gets called when your class is imported.
+
+Then in your C<init_meta> you can arrange for the caller to use your
+subclasses:
+
+ package MooseX::Embiggen;
+
use Moose ();
use Moose::Exporter;
+ use MooseX::Embiggen::Meta::Class;
+ use MooseX::Embiggen::Object;
+
Moose::Exporter->setup_import_methods( also => 'Moose' );
sub init_meta {
- shift;
- Moose->init_meta( @_, base_class => 'MyApp::Object' );
+ shift; # just your package name
+ my %options = @_;
+
+ return Moose->init_meta(
+ for_class => $options{for_class},
+ metaclass => 'MooseX::Embiggen::Meta::Class',
+ base_class => 'MooseX::Embiggen::Object',
+ );
}
-=head1 DESCRIPTION
+=head2 Extensions as Metaclass (and Base Object) Roles
-Often you find that you want to share some behavior between all your
-classes. One way to do that is to make a base class and simply add
-C<S<extends 'MyApp::Base'>> to every class in your
-application. However, that can get tedious. Instead, you can simply
-create your Moose-alike module that sets the base object class to
-C<MyApp::Base> for you.
+Implementing your extensions as metaclass roles makes your extensions
+easy to apply, and cooperative with other metaclass role-based extensions.
-Then, instead of writing C<S<use Moose>> you can write C<S<use
-MyApp::UseMyBase>>.
+Just as with a subclass, you will probably want to package your
+extensions for consumption with a single module that uses
+L<Moose::Exporter>. However, in this case, you will use
+L<Moose::Util::MetaRole> to apply all of your roles. The advantage of
+using this module is that I<it preserves any subclassing or roles
+already applied to the users metaclasses>. This means that your
+extension is cooperative I<by default>, and consumers of your
+extension can easily use it with other role-based extensions.
-In this particular example, our base class issues some debugging
-output every time a new object is created, but you can surely think of
-some more interesting things to do with your own base class.
+ package MooseX::Embiggen;
-This all works because of the magic of L<Moose::Exporter>. When we
-call C<< Moose::Exporter->setup_import_methods( also => 'Moose' ) >>
-it builds an C<import> and C<unimport> method for you. The C<< also =>
-'Moose' >> bit says that we want to export everything that Moose does.
+ use Moose ();
+ use Moose::Exporter;
+ use Moose::Util::MetaRole;
-The C<import> method that gets created will call our C<init_meta>
-method, passing it C<< for_caller => $caller >> as its arguments. The
-C<$caller> is set to the class that actually imported us in the first
-place.
+ use MooseX::Embiggen::Role::Meta::Class;
+ use MooseX::Embiggen::Role::Meta::Attribute;
+ use MooseX::Embiggen::Role::Meta::Method::Constructor;
+ use MooseX::Embiggen::Role::Object;
-See the L<Moose::Exporter> docs for more details on its API.
+ Moose::Exporter->setup_import_methods( also => 'Moose' );
-=head1 USING MyApp::UseMyBase
+ sub init_meta {
+ shift; # just your package name
+ my %options = @_;
-To actually use our new base class, we simply use C<MyApp::UseMyBase>
-I<instead> of C<Moose>. We get all the Moose sugar plus our new base
-class.
+ Moose->init_meta(%options);
- package Foo;
+ my $meta = Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => $options{for_class},
+ metaclass_roles => ['MooseX::Embiggen::Role::Meta::Class'],
+ attribute_metaclass_roles =>
+ ['MooseX::Embiggen::Role::Meta::Attribute'],
+ constructor_class_roles =>
+ ['MooseX::Embiggen::Role::Meta::Method::Constructor'],
+ );
- use MyApp::UseMyBase;
+ Moose::Util::MetaRole::apply_base_class_roles(
+ for_class => $options{for_class},
+ roles => ['MooseX::Embiggen::Role::Object'],
+ );
- has 'size' => ( is => 'rw' );
+ return $meta;
+ }
- no MyApp::UseMyBase;
+As you can see from this example, you can use C<Moose::Util::MetaRole>
+to apply roles to any metaclass, as well as the base object class. If
+some other extension has already applied its own roles, they will be
+preserved when your extension applies its roles, and vice versa.
+=head2 Providing Sugar
+
+With L<Moose::Exporter>, you can also export your own sugar subs, as
+well as those from other sugar modules:
+
+ package MooseX::Embiggen;
+
+ use Moose ();
+ use Moose::Exporter;
+
+ Moose::Exporter->setup_import_methods(
+ with_caller => ['embiggen'],
+ also => 'Moose',
+ );
+
+ sub init_meta { ... }
+
+ sub embiggen {
+ my $caller = shift;
+ $caller->meta()->embiggen(@_);
+ }
+
+And then the consumer of your extension can use your C<embiggen> sub:
+
+ package Consumer;
+
+ use MooseX::Embiggen;
+
+ extends 'Thing';
+
+ embiggen ...;
+
+This can be combined with metaclass and base class roles quite easily.
+
+=head1 LEGACY EXTENSION METHODOLOGIES
+
+Before the existence of L<Moose::Exporter> and
+L<Moose::Util::MetaRole>, there were a number of other ways to extend
+Moose. In general, these methods were less cooperative, and only
+worked well with a single extension.
+
+These methods include C<metaclass.pm>, C<Moose::Policy> (which uses
+C<metaclass.pm> under the hood), and various hacks to do what
+L<Moose::Exporter> does. Please do not use these for your own
+extensions.
+
+Note that if you write a cooperative extension, it should cooperate
+with older extensions, though older extensions generally do not
+cooperate with each other.
+
+=head1 CONCLUSION
+
+If you can write your extension as one or more metaclass and base
+object roles, please consider doing so. Make sure to read the docs for
+L<Moose::Exporter> and L<Moose::Util::MetaRole> as well.
+
+=head2 Caveat
+
+The L<Moose::Util::MetaRole> API is still considered an experiment,
+and could go away or change in the future.
+
=head1 AUTHOR
Dave Rolsky E<lt>autarch at urth.orgE<gt>
=head1 COPYRIGHT AND LICENSE
-Copyright 2006-2008 by Infinity Interactive, Inc.
+Copyright 2008 by Infinity Interactive, Inc.
L<http://www.iinteractive.com>
Modified: Moose/branches/Moose-XS/lib/Moose/Cookbook/Extending/Recipe2.pod
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Cookbook/Extending/Recipe2.pod 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Cookbook/Extending/Recipe2.pod 2009-01-17 20:17:26 UTC (rev 7315)
@@ -3,83 +3,68 @@
=head1 NAME
-Moose::Cookbook::Extending::Recipe2 - Acting like Moose.pm and providing sugar Moose-style
+Moose::Cookbook::Extending::Recipe2 - Providing a role for the base object class
=head1 SYNOPSIS
- package MyApp::Mooseish;
+ package MooseX::Debugging;
use strict;
use warnings;
use Moose ();
use Moose::Exporter;
+ use Moose::Util::MetaRole;
+ use MooseX::Debugging::Role::Object;
- Moose::Exporter->setup_import_methods(
- with_caller => ['has_table'],
- also => 'Moose',
- );
+ Moose::Exporter->setup_import_methods();
sub init_meta {
shift;
- Moose->init_meta( @_, metaclass => 'MyApp::Meta::Class' );
- }
+ my %options = @_;
- sub has_table {
- my $caller = shift;
- $caller->meta()->table(shift);
+ Moose->init_meta(%options);
+
+ Moose::Util::MetaRole::apply_base_class_roles(
+ for_class => $options{for_class},
+ roles => ['MooseX::Debugging::Role::Object'],
+ );
}
-=head1 DESCRIPTION
+ package MooseX::Debugging::Role::Object;
-This recipe expands on the use of L<Moose::Exporter> we saw in
-L<Moose::Cookbook::Extending::Recipe1>. Instead of providing our own
-object base class, we provide our own metaclass class, and we also
-export a sugar subroutine C<has_table()>.
+ after 'BUILD' => sub {
+ my $self = shift;
-Given the above code, you can now replace all instances of C<use
-Moose> with C<use MyApp::Mooseish>. Similarly, C<no Moose> is now
-replaced with C<no MyApp::Mooseish>.
+ warn "Made a new " . ref $self . " object\n";
+ };
-The C<with_caller> parameter specifies a list of functions that should
-be wrapped before exporting. The wrapper simply ensures that the
-importing package name is the first argument to the function, so we
-can do C<S<my $caller = shift;>>.
+=head1 DESCRIPTION
-See the L<Moose::Exporter> docs for more details on its API.
+In this example, we provide a role for the base object class that adds
+some simple debugging output. Every time an object is created, it
+spits out a warning saying what type of object it was.
-=head1 USING MyApp::Mooseish
+Obviously, a real debugging role would do something more interesting,
+but this recipe is all about how we apply that role.
-The purpose of all this code is to provide a Moose-like
-interface. Here's what it would look like in actual use:
+In this case, with the combination of L<Moose::Exporter> and
+L<Moose::Util::MetaRole>, we ensure that when a module does "S<use
+MooseX::Debugging>", it automatically gets the debugging role applied
+to its base object class.
- package MyApp::User;
-
- use MyApp::Mooseish;
-
- has_table 'User';
-
- has 'username' => ( is => 'ro' );
- has 'password' => ( is => 'ro' );
-
- sub login { ... }
-
- no MyApp::Mooseish;
-
-All of the normal Moose sugar (C<has()>, C<with()>, etc) is available
-when you C<use MyApp::Mooseish>.
-
=head1 AUTHOR
Dave Rolsky E<lt>autarch at urth.orgE<gt>
=head1 COPYRIGHT AND LICENSE
-Copyright 2006-2008 by Infinity Interactive, Inc.
+Copyright 2008 by Infinity Interactive, Inc.
L<http://www.iinteractive.com>
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
-=pod
+=cut
+
Copied: Moose/branches/Moose-XS/lib/Moose/Cookbook/Extending/Recipe3.pod (from rev 5504, Moose/branches/Moose-XS/lib/Moose/Cookbook/Extending/Recipe1.pod)
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Cookbook/Extending/Recipe3.pod (rev 0)
+++ Moose/branches/Moose-XS/lib/Moose/Cookbook/Extending/Recipe3.pod 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,85 @@
+
+=pod
+
+=head1 NAME
+
+Moose::Cookbook::Extending::Recipe3 - Providing an alternate base object class
+
+=head1 SYNOPSIS
+
+ package MyApp::Base;
+ use Moose;
+
+ extends 'Moose::Object';
+
+ before 'new' => sub { warn "Making a new " . $_[0] };
+
+ no Moose;
+
+ package MyApp::UseMyBase;
+ use Moose ();
+ use Moose::Exporter;
+
+ Moose::Exporter->setup_import_methods( also => 'Moose' );
+
+ sub init_meta {
+ shift;
+ Moose->init_meta( @_, base_class => 'MyApp::Object' );
+ }
+
+=head1 DESCRIPTION
+
+Often you find that you want to share some behavior between all your
+classes. One way to do that is to make a base class and simply add
+C<S<extends 'MyApp::Base'>> to every class in your
+application. However, that can get tedious. Instead, you can simply
+create your Moose-alike module that sets the base object class to
+C<MyApp::Base> for you.
+
+Then, instead of writing C<S<use Moose>> you can write C<S<use
+MyApp::UseMyBase>>.
+
+In this particular example, our base class issues some debugging
+output every time a new object is created, but you can surely think of
+some more interesting things to do with your own base class.
+
+This all works because of the magic of L<Moose::Exporter>. When we
+call C<< Moose::Exporter->setup_import_methods( also => 'Moose' ) >>
+it builds an C<import> and C<unimport> method for you. The C<< also =>
+'Moose' >> bit says that we want to export everything that Moose does.
+
+The C<import> method that gets created will call our C<init_meta>
+method, passing it C<< for_caller => $caller >> as its arguments. The
+C<$caller> is set to the class that actually imported us in the first
+place.
+
+See the L<Moose::Exporter> docs for more details on its API.
+
+=head1 USING MyApp::UseMyBase
+
+To actually use our new base class, we simply use C<MyApp::UseMyBase>
+I<instead> of C<Moose>. We get all the Moose sugar plus our new base
+class.
+
+ package Foo;
+
+ use MyApp::UseMyBase;
+
+ has 'size' => ( is => 'rw' );
+
+ no MyApp::UseMyBase;
+
+=head1 AUTHOR
+
+Dave Rolsky E<lt>autarch at urth.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
Copied: Moose/branches/Moose-XS/lib/Moose/Cookbook/Extending/Recipe4.pod (from rev 5504, Moose/branches/Moose-XS/lib/Moose/Cookbook/Extending/Recipe2.pod)
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Cookbook/Extending/Recipe4.pod (rev 0)
+++ Moose/branches/Moose-XS/lib/Moose/Cookbook/Extending/Recipe4.pod 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,85 @@
+
+=pod
+
+=head1 NAME
+
+Moose::Cookbook::Extending::Recipe4 - Acting like Moose.pm and providing sugar Moose-style
+
+=head1 SYNOPSIS
+
+ package MyApp::Mooseish;
+
+ use strict;
+ use warnings;
+
+ use Moose ();
+ use Moose::Exporter;
+
+ Moose::Exporter->setup_import_methods(
+ with_caller => ['has_table'],
+ also => 'Moose',
+ );
+
+ sub init_meta {
+ shift;
+ Moose->init_meta( @_, metaclass => 'MyApp::Meta::Class' );
+ }
+
+ sub has_table {
+ my $caller = shift;
+ $caller->meta()->table(shift);
+ }
+
+=head1 DESCRIPTION
+
+This recipe expands on the use of L<Moose::Exporter> we saw in
+L<Moose::Cookbook::Extending::Recipe1>. Instead of providing our own
+object base class, we provide our own metaclass class, and we also
+export a sugar subroutine C<has_table()>.
+
+Given the above code, you can now replace all instances of C<use
+Moose> with C<use MyApp::Mooseish>. Similarly, C<no Moose> is now
+replaced with C<no MyApp::Mooseish>.
+
+The C<with_caller> parameter specifies a list of functions that should
+be wrapped before exporting. The wrapper simply ensures that the
+importing package name is the first argument to the function, so we
+can do C<S<my $caller = shift;>>.
+
+See the L<Moose::Exporter> docs for more details on its API.
+
+=head1 USING MyApp::Mooseish
+
+The purpose of all this code is to provide a Moose-like
+interface. Here's what it would look like in actual use:
+
+ package MyApp::User;
+
+ use MyApp::Mooseish;
+
+ has_table 'User';
+
+ has 'username' => ( is => 'ro' );
+ has 'password' => ( is => 'ro' );
+
+ sub login { ... }
+
+ no MyApp::Mooseish;
+
+All of the normal Moose sugar (C<has()>, C<with()>, etc) is available
+when you C<use MyApp::Mooseish>.
+
+=head1 AUTHOR
+
+Dave Rolsky E<lt>autarch at urth.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=pod
Modified: Moose/branches/Moose-XS/lib/Moose/Cookbook/FAQ.pod
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Cookbook/FAQ.pod 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Cookbook/FAQ.pod 2009-01-17 20:17:26 UTC (rev 7315)
@@ -16,7 +16,7 @@
issue now for well over a year.
At C<$work> we are re-writing our core offering to use Moose,
-so it's continued development is assured.
+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
@@ -85,7 +85,7 @@
To change the handling of individual parameters, there are I<coercions>
(See the L<Moose::Cookbook::Basics::Recipe5> for a complete example and
-explaination of coercions). With coercions it is possible to morph
+explanation of coercions). With coercions it is possible to morph
argument values into the correct expected types. This approach is the
most flexible and robust, but does have a slightly higher learning
curve.
@@ -172,7 +172,7 @@
is => 'rw',
);
-And have Moose create seperate C<get_bar> and C<set_bar> methods
+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
@@ -282,6 +282,21 @@
See L<Moose::Cookbook::WTF> and specifically the B<How come BUILD
is not called for my composed roles?> question in the B<Roles> section.
+=head3 What are Traits, and how are they different to Roles?
+
+In Moose, a trait is almost exactly the same thing as a role, except
+that traits typically register themselves, which allows you to refer
+to them by a short name ("Big" vs "MyApp::Role::Big").
+
+In Moose-speak, a I<Role> is usually composed into a I<class> at
+compile time, whereas a I<Trait> is usually composed into an instance
+of a class at runtime to add or modify the behavior of B<just that
+instance>.
+
+Outside the context of Moose, traits and roles generally mean exactly the
+same thing. The original paper called them Traits, however Perl 6 will call
+them Roles.
+
=head1 AUTHOR
Stevan Little E<lt>stevan at iinteractive.comE<gt>
Modified: Moose/branches/Moose-XS/lib/Moose/Cookbook/Meta/Recipe2.pod
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Cookbook/Meta/Recipe2.pod 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Cookbook/Meta/Recipe2.pod 2009-01-17 20:17:26 UTC (rev 7315)
@@ -7,62 +7,63 @@
=head1 SYNOPSIS
- package MyApp::Meta::Attribute::Labeled;
- use Moose;
- extends 'Moose::Meta::Attribute';
+ package MyApp::Meta::Attribute::Labeled;
+ use Moose;
+ extends 'Moose::Meta::Attribute';
- has label => (
- is => 'rw',
- isa => 'Str',
- predicate => 'has_label',
- );
+ has label => (
+ is => 'rw',
+ isa => 'Str',
+ predicate => 'has_label',
+ );
- package Moose::Meta::Attribute::Custom::Labeled;
- sub register_implementation { 'MyApp::Meta::Attribute::Labeled' }
+ package Moose::Meta::Attribute::Custom::Labeled;
+ sub register_implementation {'MyApp::Meta::Attribute::Labeled'}
- package MyApp::Website;
- use Moose;
- use MyApp::Meta::Attribute::Labeled;
+ package MyApp::Website;
+ use Moose;
+ use MyApp::Meta::Attribute::Labeled;
- has url => (
- metaclass => 'Labeled',
- is => 'rw',
- isa => 'Str',
- label => "The site's URL",
- );
+ has url => (
+ metaclass => 'Labeled',
+ is => 'rw',
+ isa => 'Str',
+ label => "The site's URL",
+ );
- has name => (
- is => 'rw',
- isa => 'Str',
- );
+ has name => (
+ is => 'rw',
+ isa => 'Str',
+ );
- sub dump {
- my $self = shift;
+ sub dump {
+ my $self = shift;
- # iterate over all the attributes in $self
- my %attributes = %{ $self->meta->get_attribute_map };
- while (my ($name, $attribute) = each %attributes) {
+ # iterate over all the attributes in $self
+ my %attributes = %{ $self->meta->get_attribute_map };
+ while ( my ( $name, $attribute ) = each %attributes ) {
- # print the label if available
- if ($attribute->isa('MyApp::Meta::Attribute::Labeled')
- && $attribute->has_label) {
- print $attribute->label;
- }
- # otherwise print the name
- else {
- print $name;
- }
+ # print the label if available
+ if ( $attribute->isa('MyApp::Meta::Attribute::Labeled')
+ && $attribute->has_label ) {
+ print $attribute->label;
+ }
- # print the attribute's value
- my $reader = $attribute->get_read_method;
- print ": " . $self->$reader . "\n";
- }
- }
+ # otherwise print the name
+ else {
+ print $name;
+ }
- package main;
- my $app = MyApp::Website->new(url => "http://google.com", name => "Google");
- $app->dump;
+ # print the attribute's value
+ my $reader = $attribute->get_read_method;
+ print ": " . $self->$reader . "\n";
+ }
+ }
+ package main;
+ my $app = MyApp::Website->new( url => "http://google.com", name => "Google" );
+ $app->dump;
+
=head1 SUMMARY
In this recipe, we begin to really delve into the wonder of meta-programming.
@@ -81,8 +82,8 @@
These objects have methods and (surprisingly) attributes. Let's look at a
concrete example.
- has 'x' => (isa => 'Int', is => 'ro');
- has 'y' => (isa => 'Int', is => 'rw');
+ has 'x' => ( isa => 'Int', is => 'ro' );
+ has 'y' => ( isa => 'Int', is => 'rw' );
Ahh, the veritable x and y of the Point example. Internally, every Point has an
x object and a y object. They have methods (such as "get_value") and attributes
@@ -94,23 +95,23 @@
So you have a C<$point> object, which has C<x> and C<y> methods. How can you
actually access the objects behind these attributes? Here's one way:
- $point->meta->get_attribute_map()
+ $point->meta->get_attribute_map()
C<get_attribute_map> returns a hash reference that maps attribute names to
their objects. In our case, C<get_attribute_map> might return something that
looks like the following:
- {
- x => Moose::Meta::Attribute=HASH(0x196c23c),
- y => Moose::Meta::Attribute=HASH(0x18d1690),
- }
+ {
+ x => Moose::Meta::Attribute=HASH(0x196c23c),
+ y => Moose::Meta::Attribute=HASH(0x18d1690),
+ }
Another way to get a handle on an attribute's object is
C<< $self->meta->get_attribute('name') >>. Here's one thing you can do now that
you can interact with the attribute's object directly:
- print $point->meta->get_attribute('x')->type_constraint;
- => Int
+ print $point->meta->get_attribute('x')->type_constraint;
+ => Int
(As an aside, it's not called C<< ->isa >> because C<< $obj->isa >> is already
taken)
@@ -134,18 +135,18 @@
We get the ball rolling by creating a new attribute metaclass. It starts off
somewhat ungloriously.
- package MyApp::Meta::Attribute::Labeled;
- use Moose;
- extends 'Moose::Meta::Attribute';
+ package MyApp::Meta::Attribute::Labeled;
+ use Moose;
+ extends 'Moose::Meta::Attribute';
You subclass metaclasses the same way you subclass regular classes. (Extra
credit: how in the actual hell can you use the MOP to extend itself?)
- has label => (
- is => 'rw',
- isa => 'Str',
- predicate => 'has_label',
- );
+ has label => (
+ is => 'rw',
+ isa => 'Str',
+ predicate => 'has_label',
+ );
Hey, this looks pretty reasonable! This is plain jane Moose code. Recipe 1
fare. This is merely making a new attribute. An attribute that attributes have.
@@ -156,8 +157,8 @@
C<predicate> is a standard part of C<has>. It just creates a method that asks
the question "Does this attribute have a value?"
- package Moose::Meta::Attribute::Custom::Labeled;
- sub register_implementation { 'MyApp::Meta::Attribute::Labeled' }
+ package Moose::Meta::Attribute::Custom::Labeled;
+ sub register_implementation { 'MyApp::Meta::Attribute::Labeled' }
This lets Moose discover our new metaclass. That way attributes can actually
use it. More on what this is doing in a moment.
@@ -165,19 +166,19 @@
Note that we're done defining the new metaclass! Only nine lines of code, and
not particularly difficult lines, either. Now to start using the metaclass.
- package MyApp::Website;
- use Moose;
- use MyApp::Meta::Attribute::Labeled;
+ package MyApp::Website;
+ use Moose;
+ use MyApp::Meta::Attribute::Labeled;
Nothing new here. We do have to actually load our metaclass to be able to use
it.
- has url => (
- metaclass => 'Labeled',
- is => 'rw',
- isa => 'Str',
- label => "The site's URL",
- );
+ has url => (
+ metaclass => 'Labeled',
+ is => 'rw',
+ isa => 'Str',
+ label => "The site's URL",
+ );
Ah ha! Now we're using the metaclass. We're adding a new attribute, C<url>, to
C<MyApp::Website>. C<has> lets you set the metaclass of the attribute.
@@ -199,35 +200,35 @@
Finally, we see that C<has> is setting our new meta-attribute, C<label>, to
C<"The site's URL">. We can access this meta-attribute with:
- $website->meta->get_attribute('url')->label()
+ $website->meta->get_attribute('url')->label()
Well, back to the code.
- has name => (
- is => 'rw',
- isa => 'Str',
- );
+ has name => (
+ is => 'rw',
+ isa => 'Str',
+ );
Of course, you don't have to use the new metaclass for B<all> new attributes.
Now we begin defining a method that will dump the C<MyApp::Website> instance
for human readers.
- sub dump {
- my $self = shift;
+ sub dump {
+ my $self = shift;
- # iterate over all the attributes in $self
- my %attributes = %{ $self->meta->get_attribute_map };
- while (my ($name, $attribute) = each %attributes) {
+ # iterate over all the attributes in $self
+ my %attributes = %{ $self->meta->get_attribute_map };
+ while ( my ( $name, $attribute ) = each %attributes ) {
Recall that C<get_attribute_map> returns a hashref of attribute names and their
associated objects.
- # print the label if available
- if ($attribute->isa('MyApp::Meta::Attribute::Labeled')
- && $attribute->has_label) {
- print $attribute->label;
- }
+ # print the label if available
+ if ( $attribute->isa('MyApp::Meta::Attribute::Labeled')
+ && $attribute->has_label ) {
+ print $attribute->label;
+ }
We have two checks here. The first is "is this attribute an instance of
C<MyApp::Meta::Attribute::Labeled>?". It's good to code defensively. Even if
@@ -240,18 +241,18 @@
defined in the new metaclass as the "predicate". If we pass both checks, we
print the attribute's label.
- # otherwise print the name
- else {
- print $name;
- }
+ # otherwise print the name
+ else {
+ print $name;
+ }
Another good, defensive coding practice: Provide reasonable defaults.
- # print the attribute's value
- my $reader = $attribute->get_read_method;
- print ": " . $self->$reader . "\n";
- }
- }
+ # print the attribute's value
+ my $reader = $attribute->get_read_method;
+ print ": " . $self->$reader . "\n";
+ }
+ }
Here's another example of using the attribute metaclass.
C<< $attribute->get_read_method >> returns the name of the method that can
@@ -261,9 +262,9 @@
Perl doesn't mind. Another way to write this would be
C<< $self->can($reader)->($self) >>. Yuck. :)
- package main;
- my $app = MyApp::Website->new(url => "http://google.com", name => "Google");
- $app->dump;
+ package main;
+ my $app = MyApp::Website->new( url => "http://google.com", name => "Google" );
+ $app->dump;
And we wrap up the example with a script to show off our newfound magic.
@@ -282,13 +283,13 @@
a metaclass that expires attributes after a certain amount of time. You
might use it as such:
- has site_cache => (
- metaclass => 'TimedExpiry',
- expires_after => { hours => 1 },
- refresh_with => sub { get($_->url) },
- isa => 'Str',
- is => 'ro',
- );
+ has site_cache => (
+ metaclass => 'TimedExpiry',
+ expires_after => { hours => 1 },
+ refresh_with => sub { get( $_->url ) },
+ isa => 'Str',
+ is => 'ro',
+ );
The sky's the limit!
Modified: Moose/branches/Moose-XS/lib/Moose/Cookbook/Meta/Recipe3.pod
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Cookbook/Meta/Recipe3.pod 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Cookbook/Meta/Recipe3.pod 2009-01-17 20:17:26 UTC (rev 7315)
@@ -7,61 +7,62 @@
=head1 SYNOPSIS
- package MyApp::Meta::Attribute::Trait::Labeled;
- use Moose::Role;
+ package MyApp::Meta::Attribute::Trait::Labeled;
+ use Moose::Role;
- has label => (
- is => 'rw',
- isa => 'Str',
- predicate => 'has_label',
- );
+ has label => (
+ is => 'rw',
+ isa => 'Str',
+ predicate => 'has_label',
+ );
- package Moose::Meta::Attribute::Custom::Trait::Labeled;
- sub register_implementation { 'MyApp::Meta::Attribute::Trait::Labeled' }
+ package Moose::Meta::Attribute::Custom::Trait::Labeled;
+ sub register_implementation {'MyApp::Meta::Attribute::Trait::Labeled'}
- package MyApp::Website;
- use Moose;
- use MyApp::Meta::Attribute::Trait::Labeled;
+ package MyApp::Website;
+ use Moose;
+ use MyApp::Meta::Attribute::Trait::Labeled;
- has url => (
- traits => [qw/Labeled/],
- is => 'rw',
- isa => 'Str',
- label => "The site's URL",
- );
+ has url => (
+ traits => [qw/Labeled/],
+ is => 'rw',
+ isa => 'Str',
+ label => "The site's URL",
+ );
- has name => (
- is => 'rw',
- isa => 'Str',
- );
+ has name => (
+ is => 'rw',
+ isa => 'Str',
+ );
- sub dump {
- my $self = shift;
+ sub dump {
+ my $self = shift;
- # iterate over all the attributes in $self
- my %attributes = %{ $self->meta->get_attribute_map };
- while (my ($name, $attribute) = each %attributes) {
+ # iterate over all the attributes in $self
+ my %attributes = %{ $self->meta->get_attribute_map };
+ while ( my ( $name, $attribute ) = each %attributes ) {
- # print the label if available
- if ($attribute->does('MyApp::Meta::Attribute::Trait::Labeled')
- && $attribute->has_label) {
- print $attribute->label;
- }
- # otherwise print the name
- else {
- print $name;
- }
+ # print the label if available
+ if ( $attribute->does('MyApp::Meta::Attribute::Trait::Labeled')
+ && $attribute->has_label ) {
+ print $attribute->label;
+ }
- # print the attribute's value
- my $reader = $attribute->get_read_method;
- print ": " . $self->$reader . "\n";
- }
- }
+ # otherwise print the name
+ else {
+ print $name;
+ }
- package main;
- my $app = MyApp::Website->new(url => "http://google.com", name => "Google");
- $app->dump;
+ # print the attribute's value
+ my $reader = $attribute->get_read_method;
+ print ": " . $self->$reader . "\n";
+ }
+ }
+ package main;
+ my $app = MyApp::Website->new( url => "http://google.com", name => "Google" );
+ $app->dump;
+
=head1 BUT FIRST
This recipe is a continuation of
@@ -110,22 +111,22 @@
indicate that defining and using a trait is very similar to defining and using
a new attribute metaclass.
- package MyApp::Meta::Attribute::Trait::Labeled;
- use Moose::Role;
+ package MyApp::Meta::Attribute::Trait::Labeled;
+ use Moose::Role;
- has label => (
- is => 'rw',
- isa => 'Str',
- predicate => 'has_label',
- );
+ has label => (
+ is => 'rw',
+ isa => 'Str',
+ predicate => 'has_label',
+ );
Instead of subclassing L<Moose::Meta::Attribute>, we define a role. Traits
don't need any special methods or attributes. You just focus on whatever it is
you actually need to get done. Here we're adding a new meta-attribute for use
in our application.
- package Moose::Meta::Attribute::Custom::Trait::Labeled;
- sub register_implementation { 'MyApp::Meta::Attribute::Trait::Labeled' }
+ package Moose::Meta::Attribute::Custom::Trait::Labeled;
+ sub register_implementation { 'MyApp::Meta::Attribute::Trait::Labeled' }
Much like when we define a new attribute metaclass, we can provide a shorthand
name for the trait. Moose looks at the C<register_implementation> method in
@@ -135,22 +136,22 @@
Now we begin writing our application logic. I'll only cover what has changed
since recipe 2.
- has url => (
- traits => [qw/Labeled/],
- is => 'rw',
- isa => 'Str',
- label => "The site's URL",
- );
+ has url => (
+ traits => [qw/Labeled/],
+ is => 'rw',
+ isa => 'Str',
+ label => "The site's URL",
+ );
L<Moose/has> provides a C<traits> option. Just pass the list of trait names and
it will compose them together to form the (anonymous) attribute metaclass used
by the attribute. We provide a label for the attribute in the same way.
- # print the label if available
- if ($attribute->does('MyApp::Meta::Attribute::Trait::Labeled')
- && $attribute->has_label) {
- print $attribute->label;
- }
+ # print the label if available
+ if ( $attribute->does('MyApp::Meta::Attribute::Trait::Labeled')
+ && $attribute->has_label ) {
+ print $attribute->label;
+ }
Previously, this code asked the question "Does this attribute use our attribute
metaclass?" Since we're now using a trait, we ask "Does this attribute's
@@ -169,13 +170,13 @@
easily get a regular metaclass extension out of it. You just compose the trait
in the attribute metaclass, as normal.
- package MyApp::Meta::Attribute::Labeled;
- use Moose;
- extends 'Moose::Meta::Attribute';
- with 'MyApp::Meta::Attribute::Trait::Labeled';
+ package MyApp::Meta::Attribute::Labeled;
+ use Moose;
+ extends 'Moose::Meta::Attribute';
+ with 'MyApp::Meta::Attribute::Trait::Labeled';
- package Moose::Meta::Attribute::Custom::Labeled;
- sub register_implementation { 'MyApp::Meta::Attribute::Labeled' }
+ package Moose::Meta::Attribute::Custom::Labeled;
+ sub register_implementation { 'MyApp::Meta::Attribute::Labeled' }
Unfortunately, going the other way (providing a trait created from a metaclass)
is more tricky. Thus, defining your extensions as traits is just plain better
Modified: Moose/branches/Moose-XS/lib/Moose/Cookbook/Meta/Recipe4.pod
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Cookbook/Meta/Recipe4.pod 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Cookbook/Meta/Recipe4.pod 2009-01-17 20:17:26 UTC (rev 7315)
@@ -11,10 +11,10 @@
use Moose;
extends 'Moose::Meta::Class';
- has table =>
- ( is => 'rw',
- isa => 'Str',
- );
+ has table => (
+ is => 'rw',
+ isa => 'Str',
+ );
=head1 DESCRIPTION
@@ -38,7 +38,7 @@
Using this new "table" attribute is quite simple. Let's say we have a
class named C<MyApp::User>, we could simply write the following:
- my $table = MyApp::User->meta()->table();
+ my $table = MyApp::User->meta->table;
As long as MyApp::User has arranged to use C<MyApp::Meta::Class> as
its metaclass, this method call just works.
Modified: Moose/branches/Moose-XS/lib/Moose/Cookbook/Meta/Recipe5.pod
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Cookbook/Meta/Recipe5.pod 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Cookbook/Meta/Recipe5.pod 2009-01-17 20:17:26 UTC (rev 7315)
@@ -10,10 +10,10 @@
package MyApp::Meta::Class::Trait::HasTable;
use Moose::Role;
- has table =>
- ( is => 'rw',
- isa => 'Str',
- );
+ has table => (
+ is => 'rw',
+ isa => 'Str',
+ );
package Moose::Meta::Class::Custom::Trait::HasTable;
sub register_implementation { 'MyApp::Meta::Class::Trait::HasTable' }
@@ -21,7 +21,7 @@
package MyApp::User;
use Moose -traits => 'HasTable';
- __PACKAGE__->table('User');
+ __PACKAGE__->meta->table('User');
=head1 DESCRIPTION
@@ -42,7 +42,7 @@
Once this trait has been applied to a metaclass, it looks exactly like
the example we saw in L<Moose::Cookbook::Meta::Recipe4>:
- my $table = MyApp::User->meta()->table();
+ my $table = MyApp::User->meta->table;
=head1 SEE ALSO
Modified: Moose/branches/Moose-XS/lib/Moose/Cookbook/Roles/Recipe1.pod
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Cookbook/Roles/Recipe1.pod 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Cookbook/Roles/Recipe1.pod 2009-01-17 20:17:26 UTC (rev 7315)
@@ -9,66 +9,66 @@
package Eq;
use Moose::Role;
-
+
requires 'equal_to';
-
- sub not_equal_to {
- my ($self, $other) = @_;
+
+ sub not_equal_to {
+ my ( $self, $other ) = @_;
not $self->equal_to($other);
}
-
+
package Comparable;
use Moose::Role;
-
+
with 'Eq';
-
+
requires 'compare';
-
+
sub equal_to {
- my ($self, $other) = @_;
+ my ( $self, $other ) = @_;
$self->compare($other) == 0;
- }
-
+ }
+
sub greater_than {
- my ($self, $other) = @_;
+ my ( $self, $other ) = @_;
$self->compare($other) == 1;
- }
-
+ }
+
sub less_than {
- my ($self, $other) = @_;
+ my ( $self, $other ) = @_;
$self->compare($other) == -1;
}
-
+
sub greater_than_or_equal_to {
- my ($self, $other) = @_;
+ my ( $self, $other ) = @_;
$self->greater_than($other) || $self->equal_to($other);
- }
-
+ }
+
sub less_than_or_equal_to {
- my ($self, $other) = @_;
+ my ( $self, $other ) = @_;
$self->less_than($other) || $self->equal_to($other);
- }
-
+ }
+
package Printable;
use Moose::Role;
-
- requires 'to_string';
-
+
+ requires 'to_string';
+
package US::Currency;
use Moose;
-
+
with 'Comparable', 'Printable';
-
- has 'amount' => (is => 'rw', isa => 'Num', default => 0);
-
+
+ has 'amount' => ( is => 'rw', isa => 'Num', default => 0 );
+
sub compare {
- my ($self, $other) = @_;
+ my ( $self, $other ) = @_;
$self->amount <=> $other->amount;
}
-
+
sub to_string {
my $self = shift;
- sprintf '$%0.2f USD' => $self->amount
+ sprintf '$%0.2f USD' => $self->amount;
}
=head1 DESCRIPTION
@@ -119,32 +119,36 @@
target class need implement.
sub equal_to {
- my ($self, $other) = @_;
+ my ( $self, $other ) = @_;
$self->compare($other) == 0;
}
-
+
sub greater_than {
- my ($self, $other) = @_;
+ my ( $self, $other ) = @_;
$self->compare($other) == 1;
- }
-
+ }
+
sub less_than {
- my ($self, $other) = @_;
+ my ( $self, $other ) = @_;
$self->compare($other) == -1;
}
-
+
sub greater_than_or_equal_to {
- my ($self, $other) = @_;
+ my ( $self, $other ) = @_;
$self->greater_than($other) || $self->equal_to($other);
- }
-
+ }
+
sub less_than_or_equal_to {
- my ($self, $other) = @_;
+ my ( $self, $other ) = @_;
$self->less_than($other) || $self->equal_to($other);
}
Next up is B<Printable>. This is a very simple role, akin to B<Eq>. It merely
-requires a C<to_string> method.
+requires a C<to_string> method. Roles that only require methods are very much
+like Java's interfaces. If we know that a class does the B<Printable> role, it
+not only tells us that we can call the C<to_string> method on it, but also that
+C<to_string> has the precise semantics we want (consider classes B<Tree> and
+B<Dog>, both with method C<bark>).
Finally, we come to B<US::Currency>, a class that allows us to reap the benefits
of our hard work. This is a regular Moose class, so we include the normal C<use
@@ -156,12 +160,12 @@
It also defines a regular Moose attribute, C<amount>, with a type constraint of
C<Num> and a default of C<0>:
- has 'amount' => (is => 'rw', isa => 'Num', default => 0);
+ has 'amount' => ( is => 'rw', isa => 'Num', default => 0 );
Now we come to the core of the class. First up, we define a C<compare> method:
sub compare {
- my ($self, $other) = @_;
+ my ( $self, $other ) = @_;
$self->amount <=> $other->amount;
}
@@ -176,7 +180,7 @@
sub to_string {
my $self = shift;
- sprintf '$%0.2f USD' => $self->amount
+ sprintf '$%0.2f USD' => $self->amount;
}
=head1 CONCLUSION
@@ -209,4 +213,4 @@
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
-=cut
+=cut
Modified: Moose/branches/Moose-XS/lib/Moose/Cookbook/Roles/Recipe2.pod
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Cookbook/Roles/Recipe2.pod 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Cookbook/Roles/Recipe2.pod 2009-01-17 20:17:26 UTC (rev 7315)
@@ -25,8 +25,12 @@
package Restartable::ButUnreliable;
use Moose::Role;
- with 'Restartable' => { alias => { stop => '_stop',
- start => '_start' } };
+ with 'Restartable' => {
+ alias => {
+ stop => '_stop',
+ start => '_start'
+ }
+ };
sub stop {
my $self = shift;
Modified: Moose/branches/Moose-XS/lib/Moose/Cookbook/Style.pod
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Cookbook/Style.pod 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Cookbook/Style.pod 2009-01-17 20:17:26 UTC (rev 7315)
@@ -175,6 +175,11 @@
will return true, even though C<has> is not a method.
+If you choose L<namespace::clean>, make sure to keep the C<meta> method if you
+want to use it for introspection:
+
+ use namespace::clean -except => "meta";
+
=head1 Accept no substitutes
By substitutes I mean hacks instead of "proper" solutions.
Modified: Moose/branches/Moose-XS/lib/Moose/Cookbook/WTF.pod
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Cookbook/WTF.pod 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Cookbook/WTF.pod 2009-01-17 20:17:26 UTC (rev 7315)
@@ -149,7 +149,7 @@
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<http://search.cpan.org/~stevan/Moose-0.21/lib/Moose/Cookbook/Recipe3.pod>)
+L<Moose::Cookbook::Basics::Recipe3>)
=item *
Modified: Moose/branches/Moose-XS/lib/Moose/Cookbook.pod
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Cookbook.pod 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Cookbook.pod 2009-01-17 20:17:26 UTC (rev 7315)
@@ -76,6 +76,10 @@
Demonstrates using operator overloading, coercion, and subtypes to
model how eye color is determined during reproduction.
+=item L<Moose::Cookbook::Basics::Recipe11> - BUILD and BUILDARGS (TODO)
+
+We need a good recipe demonstrating how these work.
+
=back
=head2 Moose Roles
@@ -84,20 +88,20 @@
=over 4
-=item L<Moose::Cookbook::Role::Recipe1> - The Moose::Role example
+=item L<Moose::Cookbook::Roles::Recipe1> - The Moose::Role example
Demonstrates roles, which are also sometimes known as traits or
mix-ins. Roles provide a method of code re-use which is orthogonal to
subclassing.
-=item L<Moose::Cookbook::Role::Recipe2> - Advanced Role Composition - method exclusion and aliasing
+=item L<Moose::Cookbook::Roles::Recipe2> - Advanced Role Composition - method exclusion and aliasing
Sometimes you just want to include part of a role in your
class. Sometimes you want the whole role but one if its methods
conflicts with one in your class. With method exclusion and aliasing,
you can work around these problems.
-=item L<Moose::Cookbook::Role::Recipe3> - Runtime Role Composition (TODO)
+=item L<Moose::Cookbook::Roles::Recipe3> - Runtime Role Composition (TODO)
I<abstract goes here>
@@ -169,14 +173,27 @@
=over 4
-=item L<Moose::Cookbook::Extending::Recipe1> - Providing an alternate base object class
+=item L<Moose::Cookbook::Extending::Recipe1> - Moose extension overview
+There are quite a number of ways to extend Moose. This recipe explains
+provides an overview of each method, and provides recommendations for
+when each is appropriate.
+
+=item L<Moose::Cookbook::Extending::Recipe2> - Providing a base object class role
+
+Many base object class extensions can be implemented as roles. This
+example shows how to provide a base object class debugging role that
+is applied to any class that uses a notional C<MooseX::Debugging>
+module.
+
+=item L<Moose::Cookbook::Extending::Recipe3> - Providing an alternate base object class
+
You may find that you want to provide an alternate base object class
along with a meta extension, or maybe you just want to add some
functionality to all your classes without typing C<extends
'MyApp::Base'> over and over.
-=item L<Moose::Cookbook::Extending::Recipe2> - Acting like Moose.pm and providing sugar Moose-style
+=item L<Moose::Cookbook::Extending::Recipe4> - Acting like Moose.pm and providing sugar Moose-style
This recipe shows how to provide a replacement for C<Moose.pm>. You
may want to do this as part of the API for a C<MooseX> module,
Added: Moose/branches/Moose-XS/lib/Moose/Error/Confess.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Error/Confess.pm (rev 0)
+++ Moose/branches/Moose-XS/lib/Moose/Error/Confess.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,37 @@
+package Moose::Error::Confess;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.64';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base qw(Moose::Error::Default);
+
+__PACKAGE__
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Error::Confess - Prefer C<confess>
+
+=head1 SYNOPSIS
+
+ use metaclass => (
+ metaclass => "Moose::Meta::Class",
+ error_class => "Moose::Error::Confess",
+ );
+
+=head1 DESCRIPTION
+
+This error class uses L<Carp/confess> to raise errors generated in your
+metaclass.
+
+=cut
+
+
+
Added: Moose/branches/Moose-XS/lib/Moose/Error/Croak.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Error/Croak.pm (rev 0)
+++ Moose/branches/Moose-XS/lib/Moose/Error/Croak.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,51 @@
+package Moose::Error::Croak;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.64';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base qw(Moose::Error::Default);
+
+sub new {
+ my ( $self, @args ) = @_;
+ $self->create_error_croak(@args);
+}
+
+__PACKAGE__
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Error::Croak - Prefer C<croak>
+
+=head1 SYNOPSIS
+
+ use metaclass => (
+ metaclass => "Moose::Meta::Class",
+ error_class => "Moose::Error::Croak",
+ );
+
+=head1 DESCRIPTION
+
+This error class uses L<Carp/croak> to raise errors generated in your
+metaclass.
+
+=head1 METHODS
+
+=over 4
+
+=item new
+
+Overrides L<Moose::Error::Default/new> to prefer C<croak>.
+
+=back
+
+=cut
+
+
Added: Moose/branches/Moose-XS/lib/Moose/Error/Default.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Error/Default.pm (rev 0)
+++ Moose/branches/Moose-XS/lib/Moose/Error/Default.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,78 @@
+package Moose::Error::Default;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.64';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use Carp::Heavy;
+
+
+sub new {
+ my ( $self, @args ) = @_;
+ $self->create_error_confess( @args );
+}
+
+sub create_error_croak {
+ my ( $self, @args ) = @_;
+ $self->_create_error_carpmess( @args );
+}
+
+sub create_error_confess {
+ my ( $self, @args ) = @_;
+ $self->_create_error_carpmess( @args, longmess => 1 );
+}
+
+sub _create_error_carpmess {
+ my ( $self, %args ) = @_;
+
+ my $carp_level = 3 + ( $args{depth} || 1 );
+ local $Carp::MaxArgNums = 20; # default is 8, usually we use named args which gets messier though
+
+ my @args = exists $args{message} ? $args{message} : ();
+
+ if ( $args{longmess} || $Carp::Verbose ) {
+ local $Carp::CarpLevel = ( $Carp::CarpLevel || 0 ) + $carp_level;
+ return Carp::longmess(@args);
+ } else {
+ return Carp::ret_summary($carp_level, @args);
+ }
+}
+
+__PACKAGE__
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Error::Default - L<Carp> based error generation for Moose.
+
+=head1 DESCRIPTION
+
+This class implements L<Carp> based error generation.
+
+The default behavior is like L<Moose::Error::Confess>.
+
+=head1 METHODS
+
+=over 4
+
+=item new @args
+
+Create a new error. Delegates to C<create_error_confess>.
+
+=item create_error_confess @args
+
+=item create_error_croak @args
+
+Creates a new errors string of the specified style.
+
+=back
+
+=cut
+
+
Modified: Moose/branches/Moose-XS/lib/Moose/Exporter.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Exporter.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Exporter.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -3,9 +3,13 @@
use strict;
use warnings;
-use Carp qw( confess );
+our $VERSION = '0.64';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
use Class::MOP;
use List::MoreUtils qw( first_index uniq );
+use Moose::Util::MetaRole;
use Sub::Exporter;
@@ -32,9 +36,12 @@
my @exports_from = $class->_follow_also( $exporting_package );
- my $exports
- = $class->_make_sub_exporter_params( $exporting_package, @exports_from );
+ my $export_recorder = {};
+ my ( $exports, $is_removable )
+ = $class->_make_sub_exporter_params(
+ [ $exporting_package, @exports_from ], $export_recorder );
+
my $exporter = Sub::Exporter::build_exporter(
{
exports => $exports,
@@ -48,9 +55,8 @@
my $import = $class->_make_import_sub( $exporting_package, $exporter,
\@exports_from, $args{_export_to_main} );
- my $unimport
- = $class->_make_unimport_sub( $exporting_package, \@exports_from,
- [ keys %{$exports} ] );
+ my $unimport = $class->_make_unimport_sub( $exporting_package, $exports,
+ $is_removable, $export_recorder );
return ( $import, $unimport )
}
@@ -70,7 +76,7 @@
sub _follow_also_real {
my $exporting_package = shift;
- die "Package in also ($exporting_package) does not seem to use MooseX::Exporter"
+ die "Package in also ($exporting_package) does not seem to use Moose::Exporter"
unless exists $EXPORT_SPEC{$exporting_package};
my $also = $EXPORT_SPEC{$exporting_package}{also};
@@ -81,7 +87,7 @@
for my $package (@also)
{
- die "Circular reference in also parameter to MooseX::Exporter between $exporting_package and $package"
+ die "Circular reference in also parameter to Moose::Exporter between $exporting_package and $package"
if $seen->{$package};
$seen->{$package} = 1;
@@ -92,12 +98,14 @@
}
sub _make_sub_exporter_params {
- my $class = shift;
- my @packages = @_;
+ my $class = shift;
+ my $packages = shift;
+ my $export_recorder = shift;
my %exports;
+ my %is_removable;
- for my $package (@packages) {
+ for my $package ( @{$packages} ) {
my $args = $EXPORT_SPEC{$package}
or die "The $package package does not use Moose::Exporter\n";
@@ -107,11 +115,15 @@
\&{ $package . '::' . $name };
};
+ my $fq_name = $package . '::' . $name;
+
$exports{$name} = $class->_make_wrapped_sub(
- $package,
- $name,
- $sub
+ $fq_name,
+ $sub,
+ $export_recorder,
);
+
+ $is_removable{$name} = 1;
}
for my $name ( @{ $args->{as_is} } ) {
@@ -119,119 +131,151 @@
if ( ref $name ) {
$sub = $name;
- $name = ( Class::MOP::get_code_info($name) )[1];
+
+ # Even though Moose re-exports things from Carp &
+ # Scalar::Util, we don't want to remove those at
+ # unimport time, because the importing package may
+ # have imported them explicitly ala
+ #
+ # use Carp qw( confess );
+ #
+ # This is a hack. Since we can't know whether they
+ # really want to keep these subs or not, we err on the
+ # safe side and leave them in.
+ my $coderef_pkg;
+ ( $coderef_pkg, $name ) = Class::MOP::get_code_info($name);
+
+ $is_removable{$name} = $coderef_pkg eq $package ? 1 : 0;
}
else {
$sub = do {
no strict 'refs';
\&{ $package . '::' . $name };
};
+
+ $is_removable{$name} = 1;
}
+ $export_recorder->{$sub} = 1;
+
$exports{$name} = sub {$sub};
}
}
- return \%exports;
+ return ( \%exports, \%is_removable );
}
-{
- # This variable gets closed over in each export _generator_. Then
- # in the generator we grab the value and close over it _again_ in
- # the real export, so it gets captured each time the generator
- # runs.
- #
- # In the meantime, we arrange for the import method we generate to
- # set this variable to the caller each time it is called.
- #
- # This is all a bit confusing, but it works.
- my $CALLER;
+our $CALLER;
- sub _make_wrapped_sub {
- my $class = shift;
- my $exporting_package = shift;
- my $name = shift;
- my $sub = shift;
+sub _make_wrapped_sub {
+ my $self = shift;
+ my $fq_name = shift;
+ my $sub = shift;
+ my $export_recorder = shift;
- # We need to set the package at import time, so that when
- # package Foo imports has(), we capture "Foo" as the
- # package. This lets other packages call Foo::has() and get
- # the right package. This is done for backwards compatibility
- # with existing production code, not because this is a good
- # idea ;)
- return sub {
- my $caller = $CALLER;
- Class::MOP::subname( $exporting_package . '::'
- . $name => sub { $sub->( $caller, @_ ) } );
- };
- }
+ # We need to set the package at import time, so that when
+ # package Foo imports has(), we capture "Foo" as the
+ # package. This lets other packages call Foo::has() and get
+ # the right package. This is done for backwards compatibility
+ # with existing production code, not because this is a good
+ # idea ;)
+ return sub {
+ my $caller = $CALLER;
- sub _make_import_sub {
- shift;
- my $exporting_package = shift;
- my $exporter = shift;
- my $exports_from = shift;
- my $export_to_main = shift;
+ my $wrapper = $self->_make_wrapper($caller, $sub, $fq_name);
- return sub {
- # I think we could use Sub::Exporter's collector feature
- # to do this, but that would be rather gross, since that
- # feature isn't really designed to return a value to the
- # caller of the exporter sub.
- #
- # Also, this makes sure we preserve backwards compat for
- # _get_caller, so it always sees the arguments in the
- # expected order.
- my $traits;
- ($traits, @_) = Moose::Exporter::_strip_traits(@_);
+ my $sub = Class::MOP::subname($fq_name => $wrapper);
- # Normally we could look at $_[0], but in some weird cases
- # (involving goto &Moose::import), $_[0] ends as something
- # else (like Squirrel).
- my $class = $exporting_package;
+ $export_recorder->{$sub} = 1;
- $CALLER = Moose::Exporter::_get_caller(@_);
+ return $sub;
+ };
+}
- # this works because both pragmas set $^H (see perldoc
- # perlvar) which affects the current compilation -
- # i.e. the file who use'd us - which is why we don't need
- # to do anything special to make it affect that file
- # rather than this one (which is already compiled)
+sub _make_wrapper {
+ shift;
+ my $caller = shift;
+ my $sub = shift;
+ my $fq_name = shift;
- strict->import;
- warnings->import;
+ return sub { $sub->($caller, @_) };
+}
- # we should never export to main
- if ( $CALLER eq 'main' && ! $export_to_main ) {
- warn
- qq{$class does not export its sugar to the 'main' package.\n};
- return;
- }
+sub _make_import_sub {
+ shift;
+ my $exporting_package = shift;
+ my $exporter = shift;
+ my $exports_from = shift;
+ my $export_to_main = shift;
- my $did_init_meta;
- for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) {
+ return sub {
- $c->init_meta( for_class => $CALLER );
- $did_init_meta = 1;
- }
+ # I think we could use Sub::Exporter's collector feature
+ # to do this, but that would be rather gross, since that
+ # feature isn't really designed to return a value to the
+ # caller of the exporter sub.
+ #
+ # Also, this makes sure we preserve backwards compat for
+ # _get_caller, so it always sees the arguments in the
+ # expected order.
+ my $traits;
+ ( $traits, @_ ) = _strip_traits(@_);
- if ($did_init_meta) {
- _apply_meta_traits( $CALLER, $traits );
- }
- elsif ( $traits && @{$traits} ) {
- confess
- "Cannot provide traits when $class does not have an init_meta() method";
- }
+ # Normally we could look at $_[0], but in some weird cases
+ # (involving goto &Moose::import), $_[0] ends as something
+ # else (like Squirrel).
+ my $class = $exporting_package;
- goto $exporter;
- };
- }
+ $CALLER = _get_caller(@_);
+
+ # this works because both pragmas set $^H (see perldoc
+ # perlvar) which affects the current compilation -
+ # i.e. the file who use'd us - which is why we don't need
+ # to do anything special to make it affect that file
+ # rather than this one (which is already compiled)
+
+ strict->import;
+ warnings->import;
+
+ # we should never export to main
+ if ( $CALLER eq 'main' && !$export_to_main ) {
+ warn
+ qq{$class does not export its sugar to the 'main' package.\n};
+ return;
+ }
+
+ my $did_init_meta;
+ for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) {
+ # init_meta can apply a role, which when loaded uses
+ # Moose::Exporter, which in turn sets $CALLER, so we need
+ # to protect against that.
+ local $CALLER = $CALLER;
+ $c->init_meta( for_class => $CALLER );
+ $did_init_meta = 1;
+ }
+
+ if ( $did_init_meta && @{$traits} ) {
+ # The traits will use Moose::Role, which in turn uses
+ # Moose::Exporter, which in turn sets $CALLER, so we need
+ # to protect against that.
+ local $CALLER = $CALLER;
+ _apply_meta_traits( $CALLER, $traits );
+ }
+ elsif ( @{$traits} ) {
+ Moose->throw_error(
+ "Cannot provide traits when $class does not have an init_meta() method"
+ );
+ }
+
+ goto $exporter;
+ };
}
+
sub _strip_traits {
my $idx = first_index { $_ eq '-traits' } @_;
- return ( undef, @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
+ return ( [], @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
my $traits = $_[ $idx + 1 ];
@@ -245,31 +289,25 @@
sub _apply_meta_traits {
my ( $class, $traits ) = @_;
- return
- unless $traits && @$traits;
+ return unless @{$traits};
my $meta = $class->meta();
my $type = ( split /::/, ref $meta )[-1]
- or confess
+ or Moose->throw_error(
'Cannot determine metaclass type for trait application . Meta isa '
- . ref $meta;
+ . ref $meta );
- # We can only call does_role() on Moose::Meta::Class objects, and
- # we can only do that on $meta->meta() if it has already had at
- # least one trait applied to it. By default $meta->meta() returns
- # a Class::MOP::Class object (not a Moose::Meta::Class).
- my @traits = grep {
- $meta->meta()->can('does_role')
- ? not $meta->meta()->does_role($_)
- : 1
- }
- map { Moose::Util::resolve_metatrait_alias( $type => $_ ) } @$traits;
+ my @resolved_traits
+ = map { Moose::Util::resolve_metatrait_alias( $type => $_ ) }
+ @$traits;
- return unless @traits;
+ return unless @resolved_traits;
- Moose::Util::apply_all_roles_with_method( $meta,
- 'apply_to_metaclass_instance', \@traits );
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => $class,
+ metaclass_roles => \@resolved_traits,
+ );
}
sub _get_caller {
@@ -287,39 +325,38 @@
sub _make_unimport_sub {
shift;
my $exporting_package = shift;
- my $sources = shift;
- my $keywords = shift;
+ my $exports = shift;
+ my $is_removable = shift;
+ my $export_recorder = shift;
return sub {
my $caller = scalar caller();
Moose::Exporter->_remove_keywords(
$caller,
- [ $exporting_package, @{$sources} ],
- $keywords
+ [ keys %{$exports} ],
+ $is_removable,
+ $export_recorder,
);
};
}
sub _remove_keywords {
shift;
- my $package = shift;
- my $sources = shift;
- my $keywords = shift;
+ my $package = shift;
+ my $keywords = shift;
+ my $is_removable = shift;
+ my $recorded_exports = shift;
- my %sources = map { $_ => 1 } @{$sources};
-
no strict 'refs';
- # loop through the keywords ...
- foreach my $name ( @{$keywords} ) {
+ foreach my $name ( @{ $keywords } ) {
+ next unless $is_removable->{$name};
- # if we find one ...
if ( defined &{ $package . '::' . $name } ) {
- my $keyword = \&{ $package . '::' . $name };
+ my $sub = \&{ $package . '::' . $name };
# make sure it is from us
- my ($pkg_name) = Class::MOP::get_code_info($keyword);
- next unless $sources{$pkg_name};
+ next unless $recorded_exports->{$sub};
# and if it is from us, then undef the slot
delete ${ $package . '::' }{$name};
@@ -346,18 +383,26 @@
use Moose::Exporter;
Moose::Exporter->setup_import_methods(
- with_caller => [ 'sugar1', 'sugar2' ],
+ with_caller => [ 'has_rw', 'sugar2' ],
as_is => [ 'sugar3', \&Some::Random::thing ],
also => 'Moose',
);
+ sub has_rw {
+ my ($caller, $name, %options) = @_;
+ Class::MOP::Class->initialize($caller)->add_attribute($name,
+ is => 'rw',
+ %options,
+ );
+ }
+
# then later ...
package MyApp::User;
use MyApp::Moose;
has 'name';
- sugar1 'do your thing';
+ has_rw 'size';
thing;
no MyApp::Moose;
@@ -404,6 +449,11 @@
re-export some other module's functions directly by reference
(C<\&Some::Package::function>).
+If you do export some other packages function, this function will
+never be removed by the C<unimport> method. The reason for this is we
+cannot know if the caller I<also> explicitly imported the sub
+themselves, and therefore wants to keep it.
+
=item * also => $name or \@names
This is a list of modules which contain functions that the caller
Added: Moose/branches/Moose-XS/lib/Moose/Intro.pod
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Intro.pod (rev 0)
+++ Moose/branches/Moose-XS/lib/Moose/Intro.pod 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,550 @@
+=pod
+
+=head1 NAME
+
+Moose::Intro - What is Moose, and how do I use it?
+
+=head1 WHAT IS MOOSE?
+
+Moose is a I<complete> object system for Perl 5. If you've used a
+modern object-oriented language (which Perl 5 definitely isn't), you
+know they provide keywords for attribute declaration, object
+construction, and inheritance. These keywords are part of the
+language, and you don't care how they are implemented.
+
+Moose aims to do the same thing for Perl 5 OO. We can't actually
+create new keywords, but we do offer "sugar" that looks a lot like
+them. More importantly, with Moose, you I<declaratively define> your
+class, without needing to know about blessed hashrefs, accessor
+methods, and so on.
+
+Moose lets you focus on the I<logical> structure of your classes, so
+you can focus on "what" rather than "how". With Moose, a class
+definition should read like a list of very concise English sentences.
+
+Moose is built in top of C<Class::MOP>, a meta-object protocol (aka
+MOP). Using the MOP, Moose provides complete introspection for all
+Moose-using classes. This means you can ask classes about their
+attributes, parents, children, methods, etc., all using a well-defined
+API. The MOP abstracts away tedious digging about in the Perl symbol
+table, looking at C<@ISA> vars, and all the other crufty Perl tricks
+we know and love (?).
+
+Moose is based in large part on the Perl 6 object system, as well as
+drawing on the best ideas from CLOS, Smalltalk, and many other
+languages.
+
+=head1 WHY MOOSE?
+
+Moose makes Perl 5 OO both simpler and more powerful. It encapsulates
+all the tricks of Perl 5 power users in high-level declarative APIs
+which are easy to use, and don't require any special knowledge of how
+Perl works under the hood.
+
+Moose makes Perl 5 OO fun, accessible, and powerful. And if you want
+to dig about in the guts, Moose lets you do that too, by using and
+extending its powerful introspection API.
+
+=head1 AN EXAMPLE
+
+ package Person;
+
+ use Moose;
+
+ has 'first_name' => (
+ is => 'rw',
+ isa => 'Str',
+ );
+
+ has 'last_name' => (
+ is => 'rw',
+ isa => 'Str',
+ );
+
+This is a I<complete and usable> class definition!
+
+ package User;
+
+ use DateTime;
+ use Moose;
+
+ extends 'Person';
+
+ has 'password' => (
+ is => 'rw',
+ isa => 'Str',
+ );
+
+ has 'last_login' => (
+ is => 'rw',
+ isa => 'DateTime',
+ handles => { 'date_of_last_login' => 'date' },
+ );
+
+ sub login {
+ my $self = shift;
+ my $pw = shift;
+
+ return 0 if $pw ne $self->password;
+
+ $self->last_login( DateTime->now() );
+
+ return 1;
+ }
+
+We'll leave the line-by-line explanation of this code to other
+documentation, but you can see how Moose reduces common OO idioms to
+simple declarative constructs.
+
+=head2 Where's the Constructor?
+
+One point of confusion that might come up with Moose is how it handles
+object construction. B<You should not define a C<new()> method for
+your classes!>
+
+Moose will provide one for you. It will accept a hash or hash
+reference of named parameters matching your attributes. This is just
+another way in which Moose keeps you from worrying I<how> classes are
+implemented. Simply define a class and you're ready to start creating
+objects!
+
+=head1 MOOSE CONCEPTS (VS "OLD SCHOOL" Perl)
+
+In the past, you may not have thought too much about the difference
+between packages and classes, attributes and methods, constructors and
+methods, etc. Part of what the MOP provides is well-defined
+introspection features for each of those things, and in turn Moose
+provides I<distinct> sugar for each of them. Moose also introduces
+concepts that are uncommon (or entirely new) like roles, method
+modifiers, and declarative delegation.
+
+Knowing what these concepts mean in Moose-speak, and how they used to
+be done in old school Perl 5 OO is a good way to start learning to use
+Moose.
+
+=head2 Class
+
+When you say "use Moose" in a package, you are defining your package
+as a class. At its simplest, a class will consist simply of attributes
+and/or methods. It can also include roles, method modifiers, and more.
+
+A class I<has> zero or more B<attributes>.
+
+A class I<has> zero or more B<methods>.
+
+A class I<has> zero or more superclasses (aka parent classes). A
+class inherits from its superclass(es).
+
+A class I<has> zero or more B<method modifiers>. These modifiers can
+apply to its own methods or methods that are inherited from its
+ancestors.
+
+A class may I<do> zero or more B<roles>.
+
+A class I<has> a B<constructor> and a B<destructor>. These are
+provided for you "for free" by Moose.
+
+The B<constructor> accepts named parameters corresponding to the
+class's attributes and uses them to initialize an B<object instance>.
+
+A class I<has> a B<metaclass>, which in turn has B<meta-attributes>,
+B<meta-methods>, and B<meta-roles>. This metaclass I<describes> the
+class.
+
+A class is usually analogous to a category of nouns, like "People" or
+"Users".
+
+ package Person;
+
+ use Moose;
+ # now it's a Moose class!
+
+=head2 Attribute
+
+An attribute is a property of the class that defines it. It I<always>
+has a name, and it I<may have> a number of other defining
+characteristics.
+
+These characteristics may include a read/write flag, a B<type>,
+accessor method names, B<delegations>, a default value, and more.
+
+Attributes I<are not> methods, but defining them causes various
+accessor methods to be created. At a minimum, a normal attribute will
+always have a reader accessor method. Many attributes have things like
+a writer method, clearer method, and predicate method ("has it been
+set?").
+
+An attribute may also define B<delegation>s, which will create
+additional methods based on the delegation specification.
+
+By default, Moose stores attributes in the object instance, which is a
+hashref, I<but this is invisible to the author of a Moose-base class>!
+It is best to think of Moose attributes as "properties" of the
+I<opaque> B<object instance>. These properties are accessed through
+well-defined accessor methods.
+
+An attribute is usually analogous to a specific feature of something in
+the class's category. For example, People have first and last
+names. Users have passwords and last login datetimes.
+
+ has 'first_name' => (
+ is => 'rw',
+ isa => 'Str',
+ );
+
+=head2 Method
+
+A method is very straightforward. Any subroutine you define in your
+class is a method.
+
+Methods correspond to verbs, and are what your objects can do. For
+example, a User can login.
+
+ sub login { ... }
+
+=head2 Roles
+
+A role is something that a class I<does>. For example, a Machine class
+might do the Breakable role, and so could a Bone class. A role is
+used to define some concept that cuts across multiple unrelated
+classes, like "breakability", or "has a color".
+
+A role I<has> zero or more B<attributes>.
+
+A role I<has> zero or more B<methods>.
+
+A role I<has> zero or more B<method modifiers>.
+
+A role I<has> zero or more B<required methods>.
+
+A required method is not implemented by the role. Instead, a required
+method says "to use this Role you must implement this method".
+
+Roles are I<composed> into classes (or other roles). When a role is
+composed into a class, its attributes and methods are "flattened" into
+the class. Roles I<do not> show up in the inheritance hierarchy. When
+a role is composed, its attributes and methods appear as if they were
+defined I<in the consuming class>.
+
+Role are somewhat like mixins or interfaces in other OO languages.
+
+ package Breakable;
+
+ use Moose::Role;
+
+ has is_broken => (
+ is => 'rw',
+ isa => 'Bool',
+ );
+
+ requires 'break';
+
+ before 'break' => {
+ my $self = shift;
+
+ $self->is_broken(1);
+ };
+
+=head2 Method Modifiers
+
+A method modifier is a way of defining an action to be taken when a
+named method is called. Think of it as a hook on the named method. For
+example, you could say "before calling C<login()>, call this modifier
+first". Modifiers come in different flavors like "before", "after",
+"around", and "augment", and you can apply more than one modifier to
+a single method.
+
+Method modifiers are often used as an alternative to overriding a
+method in a parent class. They are also used in roles as a way of
+modifying methods in the consuming class.
+
+Under the hood, a method modifier is just a plain old Perl subroutine
+that gets called before or after (or around, etc.) some named method.
+
+ before 'login' => sub {
+ my $self = shift;
+ my $pw = shift;
+
+ warn "Called login() with $pw\n";
+ };
+
+=head2 Type
+
+Moose also comes with a (miniature) type system. This allows you to
+define types for attributes. Moose has a set of built-in types based
+on what Perl provides, such as "Str", "Num", "Bool", "HashRef", etc.
+
+In addition, every class name in your application can also be used as
+a type name. We saw an example using "DateTime" earlier.
+
+Finally, you can define your own types, either as subtypes or entirely
+new types, with their own constraints. For example, you could define a
+type "PosInt", a subtype of "Int" which only allows positive numbers.
+
+=head2 Delegation
+
+Moose attributes provide declarative syntax for defining
+delegations. A delegation is a method which delegates the real work to
+some attribute of the class.
+
+You saw this in the User example, where we defined a delegation for
+the C<date_of_last_login()> method. Under the hood, this simple calls
+C<date()> on the User object's C<last_login> attribute.
+
+=head2 Constructor
+
+A constructor creates an B<object instance> for the class. In old
+school Perl, this was usually done by defining a method called
+C<new()> which in turn called C<bless> on a reference.
+
+With Moose, this C<new()> method is created for you, and it simply
+does the right thing. You should never need to define your own
+constructor!
+
+Sometimes you want to do something whenever an object is created. In
+those cases, you can provide a C<BUILD()> method in your class. Moose
+will call this for you after creating a new object.
+
+=head2 Destructor
+
+This is a special method called when an object instance goes out of
+scope. You can specialize what your class does in this method if you
+need to, but you usually don't.
+
+With old school Perl 5, this is the C<DESTROY()> method, but with
+Moose it is the C<DEMOLISH()> method.
+
+=head2 Object Instance
+
+An object instance is a specific noun in the class's "category". For
+example, one specific Person or User. An instance is created by the
+class's B<constructor>.
+
+An instance has values for its attributes. For example, a specific
+person has a first and last name.
+
+In old school Perl 5, this is often a blessed hash reference. With
+Moose, you should never need to know what your object instance
+actually is. (ok, it's usually a blessed hashref with Moose too)
+
+=head2 Moose VS Old School Summary
+
+=over 4
+
+=item * Class
+
+A package with no introspection other than mucking about in the symbol
+table.
+
+With Moose, you get well-defined declaration and introspection.
+
+=item * Attributes
+
+Hand-written accessor methods, symbol table hackery, or a helper
+module like C<Class::Accessor>.
+
+With Moose, these are declaratively defined, and distinct from
+methods.
+
+=item * Method
+
+These are pretty much the same in Moose as in old school Perl.
+
+=item * Roles
+
+C<Class::Trait> or C<Class::Role>, or maybe C<mixin.pm>.
+
+With Moose, they're part of the core feature set, and are
+introspectable like everything else.
+
+=item * Method Modifiers
+
+Could only be done through serious symbol table wizardry, and you
+probably never saw this before (at least in Perl 5).
+
+=item * Type
+
+Hand-written parameter checking in your C<new()> method and accessors.
+
+With Moose, you define types declaratively, and then use them by name
+in your attributes.
+
+=item * Delegation
+
+C<Class::Delegation> or C<Class::Delegator>, but probably even more
+hand-written code.
+
+With Moose, this is also declarative.
+
+=item * Constructor
+
+A C<new()> method which calls C<bless> on a reference.
+
+Comes for free when you define a class with Moose.
+
+=item * Destructor
+
+A C<DESTROY()> method.
+
+With Moose, this is called C<DEMOLISH()>.
+
+=item * Object Instance
+
+A blessed reference, usually a hash reference.
+
+With Moose, this is an opaque thing which has a bunch of attributes
+and methods, as defined by its class.
+
+=item * Immutabilization
+
+Moose comes with a feature called "immutabilization". When you make
+your class immutable, it means you're done adding methods, attributes,
+roles, etc. This lets Moose optimize your class with a bunch of
+extremely dirty in-place code generation tricks that speed up things
+like object construction and so on.
+
+=back
+
+=head1 META WHAT?
+
+A metaclass is a class that describes classes. With Moose, every class
+you define gets a C<meta()> method. It returns a L<Moose::Meta::Class>
+object, which has an introspection API that can tell you about the
+class it represents.
+
+ my $meta = User->meta();
+
+ for my $attribute ( $meta->compute_all_applicable_attributes ) {
+ print $attribute->name(), "\n";
+
+ if ( $attribute->has_type_constraint ) {
+ print " type: ", $attribute->type_constraint->name, "\n";
+ }
+ }
+
+ for my $method ( $meta->compute_all_applicable_methods ) {
+ print $method->name, "\n";
+ }
+
+Almost every concept we defined earlier has a meta class, so we have
+L<Moose::Meta::Class>, L<Moose::Meta::Attribute>,
+L<Moose::Meta::Method>, L<Moose::Meta::Role>,
+L<Moose::Meta::TypeConstraint>, L<Moose::Meta::Instance>, and so on.
+
+=head1 BUT I NEED TO DO IT MY WAY!
+
+One of the great things about Moose is that if you dig down and find
+that it does something the "wrong way", you can change it by extending
+a metaclass. For example, you can have arrayref based objects, you can
+make your constructors strict (no unknown params allowed!), you can
+define a naming scheme for attribute accessors, you can make a class a
+Singleton, and much, much more.
+
+Many of these extensions require surprisingly small amounts of code,
+and once you've done it once, you'll never have to hand-code "your way
+of doing things" again. Instead you'll just load your favorite
+extensions.
+
+ package MyWay::User;
+
+ use Moose;
+ use MooseX::StrictConstructor
+ use MooseX::MyWay;
+
+ has ...;
+
+
+=head1 JUSTIFICATION
+
+If you're still still asking yourself "Why do I need this?", then this
+section is for you.
+
+=over 4
+
+=item Another object system!?!?
+
+Yes, I know there has been an explosion recently of new ways to
+build objects in Perl 5, most of them based on inside-out objects
+and other such things. Moose is different because it is not a new
+object system for Perl 5, but instead an extension of the existing
+object system.
+
+Moose is built on top of L<Class::MOP>, which is a metaclass system
+for Perl 5. This means that Moose not only makes building normal
+Perl 5 objects better, but it also provides the power of metaclass
+programming.
+
+=item Is this for real? Or is this just an experiment?
+
+Moose is I<based> on the prototypes and experiments Stevan did for the
+Perl 6 meta-model. However, Moose is B<NOT> an experiment or
+prototype; it is for B<real>.
+
+=item Is this ready for use in production?
+
+Yes.
+
+Moose has been used successfully in production environments by several
+people and companies. There are Moose applications which have been in
+production with little or no issue now for well over two years. We
+consider it highly stable and we are commited to keeping it stable.
+
+Of course, in the end, you need to make this call yourself. If you
+have any questions or concerns, please feel free to email Stevan, the
+moose at perl.org list, or just stop by irc.perl.org#moose and ask away.
+
+=item Is Moose just Perl 6 in Perl 5?
+
+No. While Moose is very much inspired by Perl 6, it is not itself Perl
+6. Instead, it is an OO system for Perl 5. Stevan built Moose because
+he was tired of writing the same old boring Perl 5 OO code, and
+drooling over Perl 6 OO. So instead of switching to Ruby, he wrote
+Moose :)
+
+=item Wait, I<post> modern, I thought it was just I<modern>?
+
+Stevan read Larry Wall's talk from the 1999 Linux World entitled
+"Perl, the first postmodern computer language" in which he talks about
+how he picked the features for Perl because he thought they were cool
+and he threw out the ones that he thought sucked. This got him
+thinking about how we have done the same thing in Moose. For Moose, we
+have "borrowed" features from Perl 6, CLOS (LISP), Smalltalk, Java,
+BETA, OCaml, Ruby and more, and the bits we didn't like (cause they
+sucked) we tossed aside. So for this reason (and a few others) Stevan
+has re-dubbed Moose a I<postmodern> object system.
+
+Nuff Said.
+
+=back
+
+=head1 WHAT NEXT?
+
+So you're sold on Moose. Time to learn how to really use it.
+
+We recommend that you start with the L<Moose::Cookbook>. If you work
+your way through all the recipes under the basics section, you should
+have a pretty good sense of how Moose works, and all of its basic OO
+features.
+
+After that, check out the Role recipes. If you're really curious, go
+on and read the Meta and Extending recipes, but those are mostly there
+for people who want to be Moose wizards and change how Moose works.
+
+If you want to see how Moose would translate directly old school Perl
+5 OO code, check out L<Moose::Unsweetened>.
+
+=head1 AUTHOR
+
+Dave Rolsky E<lt>autarch at urth.orgE<gt> and Stevan Little
+E<lt>stevan at iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2008 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/Attribute.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/Attribute.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/Attribute.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -5,13 +5,13 @@
use warnings;
use Scalar::Util 'blessed', 'weaken';
-use Carp 'confess';
use overload ();
-our $VERSION = '0.57';
+our $VERSION = '0.64';
our $AUTHORITY = 'cpan:STEVAN';
use Moose::Meta::Method::Accessor;
+use Moose::Meta::Method::Delegation;
use Moose::Util ();
use Moose::Util::TypeConstraints ();
@@ -61,9 +61,19 @@
Moose::Util::resolve_metatrait_alias(Attribute => $role_name)
};
return 0 if !defined($name); # failed to load class
- return Moose::Object::does($self, $name);
+ return $self->Moose::Object::does($name);
}
+sub throw_error {
+ my $self = shift;
+ my $class = ( ref $self && $self->associated_class ) || "Moose::Meta::Class";
+ unshift @_, "message" if @_ % 2 == 1;
+ unshift @_, attr => $self if ref $self;
+ unshift @_, $class;
+ my $handler = $class->can("throw_error"); # to avoid incrementing depth by 1
+ goto $handler;
+}
+
sub new {
my ($class, $name, %options) = @_;
$class->_process_options($name, \%options) unless $options{__hack_no_process_options}; # used from clone()... YECHKKK FIXME ICKY YUCK GROSS
@@ -98,11 +108,24 @@
my @traits;
if (my $traits = $options{traits}) {
- if ( @traits = grep { not $class->does($_) } map {
- Moose::Util::resolve_metatrait_alias( Attribute => $_ )
- or
- $_
- } @$traits ) {
+ my $i = 0;
+ while ($i < @$traits) {
+ my $trait = $traits->[$i++];
+ next if ref($trait); # options to a trait we discarded
+
+ $trait = Moose::Util::resolve_metatrait_alias(Attribute => $trait)
+ || $trait;
+
+ next if $class->does($trait);
+
+ push @traits, $trait;
+
+ # are there options?
+ push @traits, $traits->[$i++]
+ if $traits->[$i] && ref($traits->[$i]);
+ }
+
+ if (@traits) {
my $anon_class = Moose::Meta::Class->create_anon_class(
superclasses => [ $class ],
roles => [ @traits ],
@@ -122,6 +145,7 @@
default coerce required
documentation lazy handles
builder type_constraint
+ definition_context
);
sub legal_options_for_inheritance { @legal_options_for_inheritance }
@@ -173,7 +197,7 @@
else {
$type_constraint = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options{isa});
(defined $type_constraint)
- || confess "Could not find the type constraint '" . $options{isa} . "'";
+ || $self->throw_error("Could not find the type constraint '" . $options{isa} . "'", data => $options{isa});
}
$actual_options{type_constraint} = $type_constraint;
@@ -188,7 +212,7 @@
else {
$type_constraint = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options{does});
(defined $type_constraint)
- || confess "Could not find the type constraint '" . $options{does} . "'";
+ || $self->throw_error("Could not find the type constraint '" . $options{does} . "'", data => $options{does});
}
$actual_options{type_constraint} = $type_constraint;
@@ -210,7 +234,7 @@
}
(scalar keys %options == 0)
- || confess "Illegal inherited options => (" . (join ', ' => keys %options) . ")";
+ || $self->throw_error("Illegal inherited options => (" . (join ', ' => keys %options) . ")", data => \%options);
$self->clone(%actual_options);
@@ -258,7 +282,7 @@
### -------------------------
if ($options->{is} eq 'ro') {
- confess "Cannot define an accessor name on a read-only attribute, accessors are read/write"
+ $class->throw_error("Cannot define an accessor name on a read-only attribute, accessors are read/write", data => $options)
if exists $options->{accessor};
$options->{reader} ||= $name;
}
@@ -271,7 +295,7 @@
}
}
else {
- confess "I do not understand this option (is => " . $options->{is} . ") on attribute ($name)"
+ $class->throw_error("I do not understand this option (is => " . $options->{is} . ") on attribute ($name)", data => $options->{is});
}
}
@@ -279,10 +303,10 @@
if (exists $options->{does}) {
if (eval { $options->{isa}->can('does') }) {
($options->{isa}->does($options->{does}))
- || confess "Cannot have an isa option and a does option if the isa does not do the does on attribute ($name)";
+ || $class->throw_error("Cannot have an isa option and a does option if the isa does not do the does on attribute ($name)", data => $options);
}
else {
- confess "Cannot have an isa option which cannot ->does() on attribute ($name)";
+ $class->throw_error("Cannot have an isa option which cannot ->does() on attribute ($name)", data => $options);
}
}
@@ -306,26 +330,26 @@
if (exists $options->{coerce} && $options->{coerce}) {
(exists $options->{type_constraint})
- || confess "You cannot have coercion without specifying a type constraint on attribute ($name)";
- confess "You cannot have a weak reference to a coerced value on attribute ($name)"
+ || $class->throw_error("You cannot have coercion without specifying a type constraint on attribute ($name)", data => $options);
+ $class->throw_error("You cannot have a weak reference to a coerced value on attribute ($name)", data => $options)
if $options->{weak_ref};
}
if (exists $options->{trigger}) {
('CODE' eq ref $options->{trigger})
- || confess "Trigger must be a CODE ref on attribute ($name)";
+ || $class->throw_error("Trigger must be a CODE ref on attribute ($name)", data => $options->{trigger});
}
if (exists $options->{auto_deref} && $options->{auto_deref}) {
(exists $options->{type_constraint})
- || confess "You cannot auto-dereference without specifying a type constraint on attribute ($name)";
+ || $class->throw_error("You cannot auto-dereference without specifying a type constraint on attribute ($name)", data => $options);
($options->{type_constraint}->is_a_type_of('ArrayRef') ||
$options->{type_constraint}->is_a_type_of('HashRef'))
- || confess "You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)";
+ || $class->throw_error("You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)", data => $options);
}
if (exists $options->{lazy_build} && $options->{lazy_build} == 1) {
- confess("You can not use lazy_build and default for the same attribute ($name)")
+ $class->throw_error("You can not use lazy_build and default for the same attribute ($name)", data => $options)
if exists $options->{default};
$options->{lazy} = 1;
$options->{required} = 1;
@@ -342,11 +366,11 @@
if (exists $options->{lazy} && $options->{lazy}) {
(exists $options->{default} || defined $options->{builder} )
- || confess "You cannot have lazy attribute ($name) without specifying a default value for it";
+ || $class->throw_error("You cannot have lazy attribute ($name) without specifying a default value for it", data => $options);
}
if ( $options->{required} && !( ( !exists $options->{init_arg} || defined $options->{init_arg} ) || exists $options->{default} || defined $options->{builder} ) ) {
- confess "You cannot have a required attribute ($name) without a default, builder, or an init_arg";
+ $class->throw_error("You cannot have a required attribute ($name) without a default, builder, or an init_arg", data => $options);
}
}
@@ -366,7 +390,7 @@
# skip it if it's lazy
return if $self->is_lazy;
# and die if it's required and doesn't have a default value
- confess "Attribute (" . $self->name . ") is required"
+ $self->throw_error("Attribute (" . $self->name . ") is required", object => $instance, data => $params)
if $self->is_required && !$self->has_default && !$self->has_builder;
# if nothing was in the %params, we can use the
@@ -376,13 +400,8 @@
$value_is_set = 1;
}
elsif ($self->has_builder) {
- if (my $builder = $instance->can($self->builder)){
- $val = $instance->$builder;
- $value_is_set = 1;
- }
- else {
- confess(blessed($instance)." does not support builder method '".$self->builder."' for attribute '" . $self->name . "'");
- }
+ $val = $self->_call_builder($instance);
+ $value_is_set = 1;
}
}
@@ -393,11 +412,7 @@
if ($self->should_coerce && $type_constraint->has_coercion) {
$val = $type_constraint->coerce($val);
}
- $type_constraint->check($val)
- || confess "Attribute ("
- . $self->name
- . ") does not pass the type constraint because: "
- . $type_constraint->get_message($val);
+ $self->verify_against_type_constraint($val, instance => $instance);
}
$self->set_initial_value($instance, $val);
@@ -405,6 +420,24 @@
if ref $val && $self->is_weak_ref;
}
+sub _call_builder {
+ my ( $self, $instance ) = @_;
+
+ my $builder = $self->builder();
+
+ return $instance->$builder()
+ if $instance->can( $self->builder );
+
+ $self->throw_error( blessed($instance)
+ . " does not support builder method '"
+ . $self->builder
+ . "' for attribute '"
+ . $self->name
+ . "'",
+ object => $instance,
+ );
+}
+
## Slot management
# FIXME:
@@ -431,11 +464,7 @@
if ($type_constraint) {
$val = $type_constraint->coerce($val)
if $can_coerce;
- $type_constraint->check($val)
- || confess "Attribute ("
- . $slot_name
- . ") does not pass the type constraint because: "
- . $type_constraint->get_message($val);
+ $self->verify_against_type_constraint($val, object => $instance);
}
$meta_instance->set_slot_value($instance, $slot_name, $val);
};
@@ -453,7 +482,7 @@
my $attr_name = $self->name;
if ($self->is_required and not @args) {
- confess "Attribute ($attr_name) is required";
+ $self->throw_error("Attribute ($attr_name) is required", object => $instance);
}
if ($self->has_type_constraint) {
@@ -464,10 +493,10 @@
$value = $type_constraint->coerce($value);
}
$type_constraint->_compiled_type_constraint->($value)
- || confess "Attribute ("
+ || $self->throw_error("Attribute ("
. $self->name
. ") does not pass the type constraint because "
- . $type_constraint->get_message($value);
+ . $type_constraint->get_message($value), object => $instance, data => $value);
}
my $meta_instance = Class::MOP::Class->initialize(blessed($instance))
@@ -493,26 +522,13 @@
if ($self->has_default) {
$value = $self->default($instance);
} elsif ( $self->has_builder ) {
- if (my $builder = $instance->can($self->builder)){
- $value = $instance->$builder;
- }
- else {
- confess(blessed($instance)
- . " does not support builder method '"
- . $self->builder
- . "' for attribute '"
- . $self->name
- . "'");
- }
- }
+ $value = $self->_call_builder($instance);
+ }
if ($self->has_type_constraint) {
my $type_constraint = $self->type_constraint;
$value = $type_constraint->coerce($value)
if ($self->should_coerce);
- $type_constraint->check($value)
- || confess "Attribute (" . $self->name
- . ") does not pass the type constraint because: "
- . $type_constraint->get_message($value);
+ $self->verify_against_type_constraint($value);
}
$self->set_initial_value($instance, $value);
}
@@ -533,7 +549,7 @@
return wantarray ? %{ $rv } : $rv;
}
else {
- confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
+ $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", object => $instance, type_constraint => $type_constraint);
}
}
@@ -554,6 +570,13 @@
return;
}
+sub remove_accessors {
+ my $self = shift;
+ $self->SUPER::remove_accessors(@_);
+ $self->remove_delegation if $self->has_handles;
+ return;
+}
+
sub install_delegation {
my $self = shift;
@@ -564,8 +587,6 @@
# to delagate to, see that method for details
my %handles = $self->_canonicalize_handles;
- # find the accessor method for this attribute
- my $accessor = $self->_get_delegate_accessor;
# install the delegation ...
my $associated_class = $self->associated_class;
@@ -574,8 +595,8 @@
my $class_name = $associated_class->name;
my $name = "${class_name}::${handle}";
- (!$associated_class->has_method($handle))
- || confess "You cannot overwrite a locally defined method ($handle) with a delegation";
+ (!$associated_class->has_method($handle))
+ || $self->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation", method_name => $handle);
# NOTE:
# handles is not allowed to delegate
@@ -587,43 +608,23 @@
#cluck("Not delegating method '$handle' because it is a core method") and
next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
- if ('CODE' eq ref($method_to_call)) {
- $associated_class->add_method($handle => Class::MOP::subname($name, $method_to_call));
- }
- else {
- # NOTE:
- # we used to do a goto here, but the
- # goto didn't handle failure correctly
- # (it just returned nothing), so I took
- # that out. However, the more I thought
- # about it, the less I liked it doing
- # the goto, and I prefered the act of
- # delegation being actually represented
- # in the stack trace.
- # - SL
- $associated_class->add_method($handle => Class::MOP::subname($name, sub {
- my $proxy = (shift)->$accessor();
- (defined $proxy)
- || confess "Cannot delegate $handle to $method_to_call because " .
- "the value of " . $self->name . " is not defined";
- $proxy->$method_to_call(@_);
- }));
- }
+ my $method = $self->_make_delegation_method($handle, $method_to_call);
+
+ $self->associated_class->add_method($method->name, $method);
}
}
-# private methods to help delegation ...
-
-sub _get_delegate_accessor {
+sub remove_delegation {
my $self = shift;
- # find the accessor method for this attribute
- my $accessor = $self->get_read_method_ref;
- # then unpack it if we need too ...
- $accessor = $accessor->body if blessed $accessor;
- # return the accessor
- return $accessor;
+ my %handles = $self->_canonicalize_handles;
+ my $associated_class = $self->associated_class;
+ foreach my $handle (keys %handles) {
+ $self->associated_class->remove_method($handle);
+ }
}
+# private methods to help delegation ...
+
sub _canonicalize_handles {
my $self = shift;
my $handles = $self->handles;
@@ -636,7 +637,7 @@
}
elsif ($handle_type eq 'Regexp') {
($self->has_type_constraint)
- || confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
+ || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)", data => $handles);
return map { ($_ => $_) }
grep { /$handles/ } $self->_get_delegate_method_list;
}
@@ -644,18 +645,21 @@
return $handles->($self, $self->_find_delegate_metaclass);
}
else {
- confess "Unable to canonicalize the 'handles' option with $handles";
+ $self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles);
}
}
else {
+ Class::MOP::load_class($handles)
+ unless Class::MOP::is_class_loaded($handles);
+
my $role_meta = eval { $handles->meta };
if ($@) {
- confess "Unable to canonicalize the 'handles' option with $handles because : $@";
+ $self->throw_error("Unable to canonicalize the 'handles' option with $handles because : $@", data => $handles, error => $@);
}
(blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
- || confess "Unable to canonicalize the 'handles' option with $handles because ->meta is not a Moose::Meta::Role";
-
+ || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because ->meta is not a Moose::Meta::Role", data => $handles);
+
return map { $_ => $_ } (
$role_meta->get_method_list,
$role_meta->get_required_method_list
@@ -681,7 +685,7 @@
return $role->meta;
}
else {
- confess "Cannot find delegate metaclass for attribute " . $self->name;
+ $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name);
}
}
@@ -697,10 +701,41 @@
return $meta->get_method_list;
}
else {
- confess "Unable to recognize the delegate metaclass '$meta'";
+ $self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta);
}
}
+sub _make_delegation_method {
+ my ( $self, $handle_name, $method_to_call ) = @_;
+
+ my $method_body;
+
+ $method_body = $method_to_call
+ if 'CODE' eq ref($method_to_call);
+
+ return Moose::Meta::Method::Delegation->new(
+ name => $handle_name,
+ package_name => $self->associated_class->name,
+ attribute => $self,
+ delegate_to_method => $method_to_call,
+ );
+}
+
+sub verify_against_type_constraint {
+ my $self = shift;
+ my $val = shift;
+
+ return 1 if !$self->has_type_constraint;
+
+ my $type_constraint = $self->type_constraint;
+
+ $type_constraint->check($val)
+ || $self->throw_error("Attribute ("
+ . $self->name
+ . ") does not pass the type constraint because: "
+ . $type_constraint->get_message($val), data => $val, @_);
+}
+
package Moose::Meta::Attribute::Custom::Moose;
sub register_implementation { 'Moose::Meta::Attribute' }
@@ -744,8 +779,12 @@
=item B<install_accessors>
+=item B<remove_accessors>
+
=item B<install_delegation>
+=item B<remove_delegation>
+
=item B<accessor_metaclass>
=item B<get_value>
@@ -761,7 +800,7 @@
Before setting the value, a check is made on the type constraint of
the attribute, if it has one, to see if the value passes it. If the
-value fails to pass, the set operation dies with a L<Carp/confess>.
+value fails to pass, the set operation dies with a L<throw_error>.
Any coercion to convert values is done before checking the type constraint.
@@ -780,6 +819,10 @@
=over 4
+=item B<throw_error>
+
+Delegates to C<associated_class> or C<Moose::Meta::Class> if there is none.
+
=item B<interpolate_class_and_new>
=item B<interpolate_class>
@@ -808,6 +851,11 @@
more information on what you can do with this, see the documentation
for L<Moose::Meta::TypeConstraint>.
+=item B<verify_against_type_constraint>
+
+Verifies that the given value is valid under this attribute's type
+constraint, otherwise throws an error.
+
=item B<has_handles>
Returns true if this meta-attribute performs delegation.
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/Class.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/Class.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/Class.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -6,15 +6,18 @@
use Class::MOP;
-use Carp 'confess';
+use Carp ();
+use List::Util qw( first );
+use List::MoreUtils qw( any all uniq );
use Scalar::Util 'weaken', 'blessed';
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Moose::Meta::Method::Overriden;
use Moose::Meta::Method::Augmented;
+use Moose::Error::Default;
use base 'Class::MOP::Class';
@@ -23,6 +26,22 @@
default => sub { [] }
));
+__PACKAGE__->meta->add_attribute('constructor_class' => (
+ accessor => 'constructor_class',
+ default => 'Moose::Meta::Method::Constructor',
+));
+
+__PACKAGE__->meta->add_attribute('destructor_class' => (
+ accessor => 'destructor_class',
+ default => 'Moose::Meta::Method::Destructor',
+));
+
+__PACKAGE__->meta->add_attribute('error_class' => (
+ accessor => 'error_class',
+ default => 'Moose::Error::Default',
+));
+
+
sub initialize {
my $class = shift;
my $pkg = shift;
@@ -39,18 +58,29 @@
my ($self, $package_name, %options) = @_;
(ref $options{roles} eq 'ARRAY')
- || confess "You must pass an ARRAY ref of roles"
+ || $self->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
if exists $options{roles};
-
+ my $roles = delete $options{roles};
+
my $class = $self->SUPER::create($package_name, %options);
-
- if (exists $options{roles}) {
- Moose::Util::apply_all_roles($class, @{$options{roles}});
+
+ if ($roles) {
+ Moose::Util::apply_all_roles( $class, @$roles );
}
return $class;
}
+sub check_metaclass_compatibility {
+ my $self = shift;
+
+ if ( my @supers = $self->superclasses ) {
+ $self->_fix_metaclass_incompatibility(@supers);
+ }
+
+ $self->SUPER::check_metaclass_compatibility(@_);
+}
+
my %ANON_CLASSES;
sub create_anon_class {
@@ -60,8 +90,8 @@
# something like Super::Class|Super::Class::2=Role|Role::1
my $cache_key = join '=' => (
- join('|', sort @{$options{superclasses} || []}),
- join('|', sort @{$options{roles} || []}),
+ join('|', @{$options{superclasses} || []}),
+ join('|', sort @{$options{roles} || []}),
);
if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
@@ -79,7 +109,7 @@
sub add_role {
my ($self, $role) = @_;
(blessed($role) && $role->isa('Moose::Meta::Role'))
- || confess "Roles must be instances of Moose::Meta::Role";
+ || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
push @{$self->roles} => $role;
}
@@ -92,7 +122,7 @@
sub does_role {
my ($self, $role_name) = @_;
(defined $role_name)
- || confess "You must supply a role name to look for";
+ || $self->throw_error("You must supply a role name to look for");
foreach my $class ($self->class_precedence_list) {
next unless $class->can('meta') && $class->meta->can('roles');
foreach my $role (@{$class->meta->roles}) {
@@ -105,7 +135,7 @@
sub excludes_role {
my ($self, $role_name) = @_;
(defined $role_name)
- || confess "You must supply a role name to look for";
+ || $self->throw_error("You must supply a role name to look for");
foreach my $class ($self->class_precedence_list) {
next unless $class->can('meta');
# NOTE:
@@ -122,33 +152,31 @@
}
sub new_object {
- my $class = shift;
+ my $class = shift;
my $params = @_ == 1 ? $_[0] : {@_};
- my $self = $class->SUPER::new_object($params);
- foreach my $attr ($class->compute_all_applicable_attributes()) {
- # if we have a trigger, then ...
- if ($attr->can('has_trigger') && $attr->has_trigger) {
- # make sure we have an init-arg ...
- if (defined(my $init_arg = $attr->init_arg)) {
- # now make sure an init-arg was passes ...
- if (exists $params->{$init_arg}) {
- # and if get here, fire the trigger
- $attr->trigger->(
- $self,
- # check if there is a coercion
- ($attr->should_coerce
- # and if so, we need to grab the
- # value that is actually been stored
- ? $attr->get_read_method_ref->($self)
- # otherwise, just get the value from
- # the constructor params
- : $params->{$init_arg}),
- $attr
- );
- }
- }
- }
+ my $self = $class->SUPER::new_object($params);
+
+ foreach my $attr ( $class->compute_all_applicable_attributes() ) {
+
+ next unless $attr->can('has_trigger') && $attr->has_trigger;
+
+ my $init_arg = $attr->init_arg;
+
+ next unless defined $init_arg;
+
+ next unless exists $params->{$init_arg};
+
+ $attr->trigger->(
+ $self,
+ (
+ $attr->should_coerce
+ ? $attr->get_read_method_ref->($self)
+ : $params->{$init_arg}
+ ),
+ $attr
+ );
}
+
return $self;
}
@@ -167,74 +195,6 @@
return $instance;
}
-# FIXME:
-# This is ugly
-sub get_method_map {
- my $self = shift;
-
- my $current = Class::MOP::check_package_cache_flag($self->name);
-
- if (defined $self->{'_package_cache_flag'} && $self->{'_package_cache_flag'} == $current) {
- return $self->{'methods'};
- }
-
- $self->{_package_cache_flag} = $current;
-
- my $map = $self->{'methods'};
-
- my $class_name = $self->name;
- my $method_metaclass = $self->method_metaclass;
-
- my %all_code = $self->get_all_package_symbols('CODE');
-
- foreach my $symbol (keys %all_code) {
- my $code = $all_code{$symbol};
-
- next if exists $map->{$symbol} &&
- defined $map->{$symbol} &&
- $map->{$symbol}->body == $code;
-
- my ($pkg, $name) = Class::MOP::get_code_info($code);
-
- if ($pkg->can('meta')
- # NOTE:
- # we don't know what ->meta we are calling
- # here, so we need to be careful cause it
- # just might blow up at us, or just complain
- # loudly (in the case of Curses.pm) so we
- # just be a little overly cautious here.
- # - SL
- && eval { no warnings; blessed($pkg->meta) }
- && $pkg->meta->isa('Moose::Meta::Role')) {
- #my $role = $pkg->meta->name;
- #next unless $self->does_role($role);
- }
- else {
-
- # NOTE:
- # 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
- # 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 $class_name ||
- (($name || '') ne '__ANON__' && ($pkg || '') ne $class_name);
- }
-
- }
-
- $map->{$symbol} = $method_metaclass->wrap(
- $code,
- package_name => $class_name,
- name => $symbol
- );
- }
-
- return $map;
-}
-
### ---------------------------------------------
sub add_attribute {
@@ -250,7 +210,7 @@
my ($self, $name, $method, $_super_package) = @_;
(!$self->has_method($name))
- || confess "Cannot add an override method if a local method is already present";
+ || $self->throw_error("Cannot add an override method if a local method is already present");
$self->add_method($name => Moose::Meta::Method::Overriden->new(
method => $method,
@@ -263,7 +223,7 @@
sub add_augment_method_modifier {
my ($self, $name, $method) = @_;
(!$self->has_method($name))
- || confess "Cannot add an augment method if a local method is already present";
+ || $self->throw_error("Cannot add an augment method if a local method is already present");
$self->add_method($name => Moose::Meta::Method::Augmented->new(
method => $method,
@@ -283,52 +243,243 @@
return undef;
}
-sub _fix_metaclass_incompatability {
+sub _fix_metaclass_incompatibility {
my ($self, @superclasses) = @_;
+
foreach my $super (@superclasses) {
- # don't bother if it does not have a meta.
- my $meta = Class::MOP::Class->initialize($super) or next;
- next unless $meta->isa("Class::MOP::Class");
+ next if $self->_superclass_meta_is_compatible($super);
- # get the name, make sure we take
- # immutable classes into account
- my $super_meta_name = ($meta->is_immutable
- ? $meta->get_mutable_metaclass_name
- : ref($meta));
+ unless ( $self->is_pristine ) {
+ $self->throw_error(
+ "Cannot attempt to reinitialize metaclass for "
+ . $self->name
+ . ", it isn't pristine" );
+ }
- # but if we have anything else,
- # we need to check it out ...
- unless (# see if of our metaclass is incompatible
- $self->isa($super_meta_name)
- and
- # and see if our instance metaclass is incompatible
- $self->instance_metaclass->isa($meta->instance_metaclass)
+ $self->_reconcile_with_superclass_meta($super);
+ }
+}
+
+sub _superclass_meta_is_compatible {
+ my ($self, $super) = @_;
+
+ my $super_meta = Class::MOP::Class->initialize($super)
+ or return 1;
+
+ next unless $super_meta->isa("Class::MOP::Class");
+
+ my $super_meta_name
+ = $super_meta->is_immutable
+ ? $super_meta->get_mutable_metaclass_name
+ : ref($super_meta);
+
+ return 1
+ if $self->isa($super_meta_name)
+ and
+ $self->instance_metaclass->isa( $super_meta->instance_metaclass );
+}
+
+# I don't want to have to type this >1 time
+my @MetaClassTypes =
+ qw( attribute_metaclass method_metaclass instance_metaclass
+ constructor_class destructor_class error_class );
+
+sub _reconcile_with_superclass_meta {
+ my ($self, $super) = @_;
+
+ my $super_meta = $super->meta;
+
+ my $super_meta_name
+ = $super_meta->is_immutable
+ ? $super_meta->get_mutable_metaclass_name
+ : ref($super_meta);
+
+ my $self_metaclass = ref $self;
+
+ # If neither of these is true we have a more serious
+ # incompatibility that we just cannot fix (yet?).
+ if ( $super_meta_name->isa( ref $self )
+ && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
+ $self->_reinitialize_with($super_meta);
+ }
+ elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
+ $self->_reconcile_role_differences($super_meta);
+ }
+}
+
+sub _reinitialize_with {
+ my ( $self, $new_meta ) = @_;
+
+ my $new_self = $new_meta->reinitialize(
+ $self->name,
+ attribute_metaclass => $new_meta->attribute_metaclass,
+ method_metaclass => $new_meta->method_metaclass,
+ instance_metaclass => $new_meta->instance_metaclass,
+ );
+
+ $new_self->$_( $new_meta->$_ )
+ for qw( constructor_class destructor_class error_class );
+
+ %$self = %$new_self;
+
+ bless $self, ref $new_self;
+
+ # We need to replace the cached metaclass instance or else when it
+ # goes out of scope Class::MOP::Class destroy's the namespace for
+ # the metaclass's class, causing much havoc.
+ Class::MOP::store_metaclass_by_name( $self->name, $self );
+ Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
+}
+
+# In the more complex case, we share a common ancestor with our
+# superclass's metaclass, but each metaclass (ours and the parent's)
+# has a different set of roles applied. We reconcile this by first
+# reinitializing into the parent class, and _then_ applying our own
+# roles.
+sub _all_metaclasses_differ_by_roles_only {
+ my ($self, $super_meta) = @_;
+
+ for my $pair (
+ [ ref $self, ref $super_meta ],
+ map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
) {
- if ( $meta->isa(ref($self)) ) {
- unless ( $self->is_pristine ) {
- confess "Not reinitializing metaclass for " . $self->name . ", it isn't pristine";
- }
- # also check values %{ $self->get_method_map } for any generated methods
- # NOTE:
- # We might want to consider actually
- # transfering any attributes from the
- # original meta into this one, but in
- # general you should not have any there
- # at this point anyway, so it's very
- # much an obscure edge case anyway
- $self = $meta->reinitialize(
- $self->name,
- attribute_metaclass => $meta->attribute_metaclass,
- method_metaclass => $meta->method_metaclass,
- instance_metaclass => $meta->instance_metaclass,
- );
- } else {
- # this will be called soon enough, for now we let it slide
- # $self->check_metaclass_compatability()
- }
- }
+ next if $pair->[0] eq $pair->[1];
+
+ my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
+ my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
+
+ my $common_ancestor
+ = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
+
+ return unless $common_ancestor;
+
+ return
+ unless _is_role_only_subclass_of(
+ $self_meta_meta,
+ $common_ancestor,
+ )
+ && _is_role_only_subclass_of(
+ $super_meta_meta,
+ $common_ancestor,
+ );
}
+
+ return 1;
+}
+
+# This, and some other functions, could be called as methods, but
+# they're not for two reasons. One, we just end up ignoring the first
+# argument, because we can't call these directly on one of the real
+# arguments, because one of them could be a Class::MOP::Class object
+# and not a Moose::Meta::Class. Second, only a completely insane
+# person would attempt to subclass this stuff!
+sub _find_common_ancestor {
+ my ($meta1, $meta2) = @_;
+
+ # FIXME? This doesn't account for multiple inheritance (not sure
+ # if it needs to though). For example, is somewhere in $meta1's
+ # history it inherits from both ClassA and ClassB, and $meta
+ # inherits from ClassB & ClassA, does it matter? And what crazy
+ # fool would do that anyway?
+
+ my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
+
+ return first { $meta1_parents{$_} } $meta2->linearized_isa;
+}
+
+sub _is_role_only_subclass_of {
+ my ($meta, $ancestor) = @_;
+
+ return 1 if $meta->name eq $ancestor;
+
+ my @roles = _all_roles_until( $meta, $ancestor );
+
+ my %role_packages = map { $_->name => 1 } @roles;
+
+ my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
+
+ my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
+
+ for my $method ( $meta->get_all_methods() ) {
+ next if $method->name eq 'meta';
+ next if $method->can('associated_attribute');
+
+ next
+ if $role_packages{ $method->original_package_name }
+ || $shared_ancestors{ $method->original_package_name };
+
+ return 0;
+ }
+
+ # FIXME - this really isn't right. Just because an attribute is
+ # defined in a role doesn't mean it isn't _also_ defined in the
+ # subclass.
+ for my $attr ( $meta->get_all_attributes ) {
+ next if $shared_ancestors{ $attr->associated_class->name };
+
+ next if any { $_->has_attribute( $attr->name ) } @roles;
+
+ return 0;
+ }
+
+ return 1;
+}
+
+sub _all_roles {
+ my $meta = shift;
+
+ return _all_roles_until($meta);
+}
+
+sub _all_roles_until {
+ my ($meta, $stop_at_class) = @_;
+
+ return unless $meta->can('calculate_all_roles');
+
+ my @roles = $meta->calculate_all_roles;
+
+ for my $class ( $meta->linearized_isa ) {
+ last if $stop_at_class && $stop_at_class eq $class;
+
+ my $meta = Class::MOP::Class->initialize($class);
+ last unless $meta->can('calculate_all_roles');
+
+ push @roles, $meta->calculate_all_roles;
+ }
+
+ return uniq @roles;
+}
+
+sub _reconcile_role_differences {
+ my ($self, $super_meta) = @_;
+
+ my $self_meta = $self->meta;
+
+ my %roles;
+
+ if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
+ $roles{metaclass_roles} = \@roles;
+ }
+
+ for my $thing (@MetaClassTypes) {
+ my $name = $self->$thing();
+
+ my $thing_meta = Class::MOP::Class->initialize($name);
+
+ my @roles = map { $_->name } _all_roles($thing_meta)
+ or next;
+
+ $roles{ $thing . '_roles' } = \@roles;
+ }
+
+ $self->_reinitialize_with($super_meta);
+
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => $self->name,
+ %roles,
+ );
+
return $self;
}
@@ -345,7 +496,7 @@
@args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
- if ($name =~ /^\+(.*)/) {
+ if (($name || '') =~ /^\+(.*)/) {
return $self->_process_inherited_attribute($1, @args);
}
else {
@@ -363,7 +514,7 @@
my ($self, $attr_name, %options) = @_;
my $inherited_attr = $self->find_attribute_by_name($attr_name);
(defined $inherited_attr)
- || confess "Could not find an attribute by the name of '$attr_name' to inherit from";
+ || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
if ($inherited_attr->isa('Moose::Meta::Attribute')) {
return $inherited_attr->clone_and_inherit_options(%options);
}
@@ -411,7 +562,7 @@
wrapped => {
add_package_symbol => sub {
my $original = shift;
- confess "Cannot add package symbols to an immutable metaclass"
+ $self->throw_error("Cannot add package symbols to an immutable metaclass")
unless (caller(2))[3] eq 'Class::MOP::Package::get_package_symbol';
goto $original->body;
},
@@ -424,8 +575,8 @@
my $self = shift;
$self->SUPER::make_immutable
(
- constructor_class => 'Moose::Meta::Method::Constructor',
- destructor_class => 'Moose::Meta::Method::Destructor',
+ constructor_class => $self->constructor_class,
+ destructor_class => $self->destructor_class,
inline_destructor => 1,
# NOTE:
# no need to do this,
@@ -435,6 +586,44 @@
);
}
+our $error_level;
+
+sub throw_error {
+ my ( $self, @args ) = @_;
+ local $error_level = ($error_level || 0) + 1;
+ $self->raise_error($self->create_error(@args));
+}
+
+sub raise_error {
+ my ( $self, @args ) = @_;
+ die @args;
+}
+
+sub create_error {
+ my ( $self, @args ) = @_;
+
+ require Carp::Heavy;
+
+ local $error_level = ($error_level || 0 ) + 1;
+
+ if ( @args % 2 == 1 ) {
+ unshift @args, "message";
+ }
+
+ my %args = ( metaclass => $self, last_error => $@, @args );
+
+ $args{depth} += $error_level;
+
+ my $class = ref $self ? $self->error_class : "Moose::Error::Default";
+
+ Class::MOP::load_class($class);
+
+ $class->new(
+ Carp::caller_info($args{depth}),
+ %args
+ );
+}
+
1;
__END__
@@ -545,6 +734,65 @@
This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
support for taking the C<$params> as a HASH ref.
+=item B<constructor_class ($class_name)>
+
+=item B<destructor_class ($class_name)>
+
+These are the names of classes used when making a class
+immutable. These default to L<Moose::Meta::Method::Constructor> and
+L<Moose::Meta::Method::Destructor> respectively. These accessors are
+read-write, so you can use them to change the class name.
+
+=item B<error_class ($class_name)>
+
+The name of the class used to throw errors. This default to
+L<Moose::Error::Default>, which generates an error with a stacktrace
+just like C<Carp::confess>.
+
+=item B<check_metaclass_compatibility>
+
+Moose overrides this method from C<Class::MOP::Class> and attempts to
+fix some incompatibilities before doing the check.
+
+=item B<throw_error $message, %extra>
+
+Throws the error created by C<create_error> using C<raise_error>
+
+=item B<create_error $message, %extra>
+
+Creates an error message or object.
+
+The default behavior is C<create_error_confess>.
+
+If C<error_class> is set uses C<create_error_object>. Otherwise uses
+C<error_builder> (a code reference or variant name), and calls the appropriate
+C<create_error_$builder> method.
+
+=item B<error_builder $builder_name>
+
+Get or set the error builder. Defaults to C<confess>.
+
+=item B<error_class $class_name>
+
+Get or set the error class. This defaults to L<Moose::Error::Default>.
+
+=item B<create_error_confess %args>
+
+Creates an error using L<Carp/longmess>
+
+=item B<create_error_croak %args>
+
+Creates an error using L<Carp/shortmess>
+
+=item B<create_error_object %args>
+
+Calls C<new> on the C<class> parameter in C<%args>. Usable with C<error_class>
+to support custom error objects for your meta class.
+
+=item B<raise_error $error>
+
+Dies with an error object or string.
+
=back
=head1 BUGS
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/Instance.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/Instance.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/Instance.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -4,7 +4,7 @@
use strict;
use warnings;
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/Method/Accessor.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/Method/Accessor.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/Method/Accessor.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -4,16 +4,17 @@
use strict;
use warnings;
-use Carp 'confess';
-
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Moose::Meta::Method',
'Class::MOP::Method::Accessor';
-## Inline method generators
+sub _error_thrower {
+ my $self = shift;
+ ( ref $self && $self->associated_attribute ) || $self->SUPER::_error_thrower();
+}
sub _eval_code {
my ( $self, $code ) = @_;
@@ -22,6 +23,7 @@
# set up the environment
my $attr = $self->associated_attribute;
my $attr_name = $attr->name;
+ my $meta = $self;
my $type_constraint_obj = $attr->type_constraint;
my $type_constraint_name = $type_constraint_obj && $type_constraint_obj->name;
@@ -30,10 +32,8 @@
: undef;
#warn "code for $attr_name =>\n" . $code . "\n";
- my $sub = eval $code;
- confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
- return $sub;
-
+ eval $self->_prepare_code( code => $code )
+ or $self->throw_error("Could not create writer for '$attr_name' because $@ \n code: $code", error => $@, data => $code );
}
sub generate_accessor_method_inline {
@@ -54,7 +54,7 @@
. $self->_inline_store($inv, $value_name) . "\n"
. $self->_inline_trigger($inv, $value_name) . "\n"
. ' }' . "\n"
- . $self->_inline_check_lazy . "\n"
+ . $self->_inline_check_lazy($inv) . "\n"
. $self->_inline_post_body(@_) . "\n"
. 'return ' . $self->_inline_auto_deref($self->_inline_get($inv)) . "\n"
. ' }');
@@ -89,8 +89,8 @@
$self->_eval_code('sub {'
. $self->_inline_pre_body(@_)
- . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
- . $self->_inline_check_lazy
+ . $self->_inline_throw_error('"Cannot assign a value to a read-only accessor"', 'data => \@_') . ' if @_ > 1;'
+ . $self->_inline_check_lazy($inv)
. $self->_inline_post_body(@_)
. 'return ' . $self->_inline_auto_deref( $slot_access ) . ';'
. '}');
@@ -109,6 +109,8 @@
sub generate_reader_method { shift->generate_reader_method_inline(@_) }
sub generate_writer_method { shift->generate_writer_method_inline(@_) }
sub generate_accessor_method { shift->generate_accessor_method_inline(@_) }
+sub generate_predicate_method { shift->generate_predicate_method_inline(@_) }
+sub generate_clearer_method { shift->generate_clearer_method_inline(@_) }
sub _inline_pre_body { '' }
sub _inline_post_body { '' }
@@ -123,14 +125,7 @@
my $type_constraint_name = $attr->type_constraint->name;
- # FIXME
- # This sprintf is insanely annoying, we should
- # fix it someday - SL
- return sprintf <<'EOF', $value, $attr_name, $value, $value,
-$type_constraint->(%s)
- || confess "Attribute (%s) does not pass the type constraint because: "
- . $type_constraint_obj->get_message(%s);
-EOF
+ 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") . ";";
}
sub _inline_check_coercion {
@@ -141,62 +136,63 @@
}
sub _inline_check_required {
- my $attr = (shift)->associated_attribute;
+ my $self = shift;
+ my $attr = $self->associated_attribute;
my $attr_name = $attr->name;
return '' unless $attr->is_required;
- return qq{(\@_ >= 2) || confess "Attribute ($attr_name) is required, so cannot be set to undef";} # defined $_[1] is not good enough
+ 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
}
sub _inline_check_lazy {
- my $self = $_[0];
+ my ($self, $instance) = @_;
+
my $attr = $self->associated_attribute;
return '' unless $attr->is_lazy;
- my $inv = '$_[0]';
- my $slot_access = $self->_inline_access($inv, $attr->name);
+ my $slot_access = $self->_inline_access($instance, $attr->name);
- my $slot_exists = $self->_inline_has($inv, $attr->name);
+ my $slot_exists = $self->_inline_has($instance, $attr->name);
my $code = 'unless (' . $slot_exists . ') {' . "\n";
if ($attr->has_type_constraint) {
if ($attr->has_default || $attr->has_builder) {
if ($attr->has_default) {
- $code .= ' my $default = $attr->default(' . $inv . ');'."\n";
+ $code .= ' my $default = $attr->default(' . $instance . ');'."\n";
}
elsif ($attr->has_builder) {
$code .= ' my $default;'."\n".
- ' if(my $builder = '.$inv.'->can($attr->builder)){ '."\n".
- ' $default = '.$inv.'->$builder; '. "\n } else {\n" .
- ' confess(Scalar::Util::blessed('.$inv.')." does not support builder method '.
- '\'".$attr->builder."\' for attribute \'" . $attr->name . "\'");'. "\n }";
+ ' if(my $builder = '.$instance.'->can($attr->builder)){ '."\n".
+ ' $default = '.$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 }";
}
$code .= ' $default = $type_constraint_obj->coerce($default);'."\n" if $attr->should_coerce;
$code .= ' ($type_constraint->($default))' .
- ' || confess "Attribute (" . $attr_name . ") does not pass the type constraint ("' .
- ' . $type_constraint_name . ") with " . (defined($default) ? overload::StrVal($default) : "undef");'
+ ' || ' . $self->_inline_throw_error('"Attribute (" . $attr_name . ") does not pass the type constraint ("' .
+ ' . $type_constraint_name . ") with " . (defined($default) ? overload::StrVal($default) : "undef")' ) . ';'
. "\n";
- $code .= ' ' . $self->_inline_init_slot($attr, $inv, $slot_access, '$default') . "\n";
+ $code .= ' ' . $self->_inline_init_slot($attr, $instance, $slot_access, '$default') . "\n";
}
else {
- $code .= ' ' . $self->_inline_init_slot($attr, $inv, $slot_access, 'undef') . "\n";
+ $code .= ' ' . $self->_inline_init_slot($attr, $instance, $slot_access, 'undef') . "\n";
}
} else {
if ($attr->has_default) {
- $code .= ' ' . $self->_inline_init_slot($attr, $inv, $slot_access, ('$attr->default(' . $inv . ')')) . "\n";
+ $code .= ' ' . $self->_inline_init_slot($attr, $instance, $slot_access, ('$attr->default(' . $instance . ')')) . "\n";
}
elsif ($attr->has_builder) {
- $code .= ' if (my $builder = '.$inv.'->can($attr->builder)) { ' . "\n"
- . ' ' . $self->_inline_init_slot($attr, $inv, $slot_access, ($inv . '->$builder'))
- . "\n } else {\n" .
- ' confess(Scalar::Util::blessed('.$inv.')." does not support builder method '.
- '\'".$attr->builder."\' for attribute \'" . $attr->name . "\'");'. "\n }";
+ $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, $inv, $slot_access, 'undef') . "\n";
+ $code .= ' ' . $self->_inline_init_slot($attr, $instance, $slot_access, 'undef') . "\n";
}
}
$code .= "}\n";
@@ -279,7 +275,7 @@
$sigil = '%';
}
else {
- confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
+ $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", type_constraint => $type_constraint );
}
"(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
@@ -315,6 +311,10 @@
=item B<generate_writer_method>
+=item B<generate_predicate_method>
+
+=item B<generate_clearer_method>
+
=item B<generate_accessor_method_inline>
=item B<generate_reader_method_inline>
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/Method/Augmented.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/Method/Augmented.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/Method/Augmented.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -3,9 +3,7 @@
use strict;
use warnings;
-use Carp 'confess';
-
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -24,7 +22,7 @@
my $super = $meta->find_next_method_by_name($name);
(defined $super)
- || confess "You cannot augment '$name' because it has no super method";
+ || $meta->throw_error("You cannot augment '$name' because it has no super method", data => $name);
my $_super_package = $super->package_name;
# BUT!,... if this is an overriden method ....
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/Method/Constructor.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/Method/Constructor.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/Method/Constructor.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -4,10 +4,9 @@
use strict;
use warnings;
-use Carp 'confess';
use Scalar::Util 'blessed', 'weaken', 'looks_like_number';
-our $VERSION = '0.57';
+our $VERSION = '0.64';
our $AUTHORITY = 'cpan:STEVAN';
use base 'Moose::Meta::Method',
@@ -17,11 +16,13 @@
my $class = shift;
my %options = @_;
- (exists $options{options} && ref $options{options} eq 'HASH')
- || confess "You must pass a hash of options";
+ my $meta = $options{metaclass};
+ (ref $options{options} eq 'HASH')
+ || $class->throw_error("You must pass a hash of options", data => $options{options});
+
($options{package_name} && $options{name})
- || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
+ || $class->throw_error("You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT");
my $self = bless {
# from our superclass
@@ -30,10 +31,10 @@
'name' => $options{name},
# specific to this subclass
'options' => $options{options},
- 'meta_instance' => $options{metaclass}->get_meta_instance,
- 'attributes' => [ $options{metaclass}->compute_all_applicable_attributes ],
+ 'meta_instance' => $meta->get_meta_instance,
+ 'attributes' => [ $meta->compute_all_applicable_attributes ],
# ...
- 'associated_metaclass' => $options{metaclass},
+ 'associated_metaclass' => $meta,
} => $class;
# we don't want this creating
@@ -46,6 +47,64 @@
return $self;
}
+sub can_be_inlined {
+ my $self = shift;
+ my $metaclass = $self->associated_metaclass;
+
+ my $expected_class = $self->_expected_constructor_class;
+
+ # If any of our parents have been made immutable, we are okay to
+ # inline our own new method. The assumption is that an inlined new
+ # method provided by a parent does not actually get used by
+ # children anyway.
+ for my $meta (
+ grep { $_->is_immutable }
+ map { ( ref $metaclass )->initialize($_) }
+ grep { $_ ne $expected_class }
+ $metaclass->linearized_isa
+ ) {
+ my $transformer = $meta->get_immutable_transformer;
+
+ # This is actually a false positive if we're in a subclass of
+ # this class, _and_ the expected class is not overridden (but
+ # should be), and the real expected class is actually
+ # immutable itself (see Fey::Object::Table for an example of
+ # how this can happen). I'm not sure how to actually handle
+ # that case, since it's effectively a bug in the subclass (for
+ # not overriding _expected_constructor_class).
+ return 1 if $transformer->inlined_constructor;
+ }
+
+ if ( my $constructor = $metaclass->find_method_by_name( $self->name ) ) {
+ my $class = $self->associated_metaclass->name;
+
+ if ( $constructor->body != $expected_class->can('new') ) {
+ my $warning
+ = "Not inlining a constructor for $class since it is not"
+ . " inheriting the default $expected_class constructor\n";
+
+ $warning .= " (constructor has method modifiers which would be lost if it were inlined)\n"
+ if $constructor->isa('Class::MOP::Method::Wrapped');
+
+ warn $warning;
+
+ return 0;
+ }
+ else {
+ return 1;
+ }
+ }
+
+ # This would be a rather weird case where we have no constructor
+ # in the inheritance chain.
+ return 1;
+}
+
+# This is here so can_be_inlined can be inherited by MooseX modules.
+sub _expected_constructor_class {
+ return 'Moose::Object';
+}
+
## accessors
sub options { (shift)->{'options'} }
@@ -58,7 +117,7 @@
# this was changed in 0.41, but broke MooseX::Singleton, so try to catch
# any other code using the original broken spelling
-sub intialize_body { confess "Please correct the spelling of 'intialize_body' to 'initialize_body'" }
+sub intialize_body { Moose->throw_error("Please correct the spelling of 'intialize_body' to 'initialize_body'") }
sub initialize_body {
my $self = shift;
@@ -92,6 +151,8 @@
my $code;
{
+ my $meta = $self; # FIXME for _inline_throw_error...
+
# NOTE:
# create the nessecary lexicals
# to be picked up in the eval
@@ -115,7 +176,7 @@
} @type_constraints;
$code = eval $source;
- confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
+ $self->throw_error("Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@", error => $@, data => $source ) if $@;
}
$self->{'body'} = $code;
}
@@ -128,7 +189,7 @@
if ( $args eq '@_' and ( !$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS ) ) {
return join("\n",
'do {',
- 'confess "Single parameters to new() must be a HASH ref"',
+ $self->_inline_throw_error('"Single parameters to new() must be a HASH ref"', 'data => $_[0]'),
' if scalar @_ == 1 && defined $_[0] && ref($_[0]) ne q{HASH};',
'(scalar @_ == 1) ? {%{$_[0]}} : {@_};',
'}',
@@ -185,7 +246,7 @@
if ($is_moose && defined($attr->init_arg) && $attr->is_required && !$attr->has_default && !$attr->has_builder) {
push @source => ('(exists $params->{\'' . $attr->init_arg . '\'}) ' .
- '|| confess "Attribute (' . $attr->name . ') is required";');
+ '|| ' . $self->_inline_throw_error('"Attribute (' . $attr->name . ') is required"') .';');
}
if (($attr->has_default || $attr->has_builder) && !($is_moose && $attr->is_lazy)) {
@@ -311,11 +372,11 @@
sub _generate_type_constraint_check {
my ($self, $attr, $type_constraint_cv, $type_constraint_obj, $value_name) = @_;
return (
- $type_constraint_cv . '->(' . $value_name . ')'
- . "\n\t" . '|| confess "Attribute ('
+ $self->_inline_throw_error('"Attribute (' # FIXME add 'dad'
. $attr->name
. ') does not pass the type constraint because: " . '
- . $type_constraint_obj . '->get_message(' . $value_name . ');'
+ . $type_constraint_obj . '->get_message(' . $value_name . ')')
+ . "\n\t unless " . $type_constraint_cv . '->(' . $value_name . ');'
);
}
@@ -331,13 +392,7 @@
return '$attrs->[' . $index . ']->default($instance)';
}
else {
- my $default = $attr->default;
- # make sure to quote strings ...
- unless (looks_like_number($default)) {
- $default = "'$default'";
- }
-
- return $default;
+ return q{"} . quotemeta( $attr->default ) . q{"};
}
}
@@ -364,6 +419,8 @@
=item B<new>
+=item B<can_be_inlined>
+
=item B<attributes>
=item B<meta_instance>
@@ -374,6 +431,8 @@
=item B<associated_metaclass>
+=item B<can_be_inlined>
+
=back
=head1 AUTHORS
Added: Moose/branches/Moose-XS/lib/Moose/Meta/Method/Delegation.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/Method/Delegation.pm (rev 0)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/Method/Delegation.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,168 @@
+
+package Moose::Meta::Method::Delegation;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Scalar::Util 'blessed', 'weaken';
+
+our $VERSION = '0.64';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Method',
+ 'Class::MOP::Method::Generated';
+
+
+sub new {
+ my $class = shift;
+ my %options = @_;
+
+ ( exists $options{attribute} )
+ || confess "You must supply an attribute to construct with";
+
+ ( blessed( $options{attribute} )
+ && $options{attribute}->isa('Moose::Meta::Attribute') )
+ || confess
+ "You must supply an attribute which is a 'Moose::Meta::Attribute' instance";
+
+ ( $options{package_name} && $options{name} )
+ || confess
+ "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
+
+ ( $options{delegate_to_method} && ( !ref $options{delegate_to_method} )
+ || ( 'CODE' eq ref $options{delegate_to_method} ) )
+ || confess
+ 'You must supply a delegate_to_method which is a method name or a CODE reference';
+
+ my $self = $class->_new( \%options );
+
+ weaken( $self->{'attribute'} );
+
+ $self->_initialize_body;
+
+ return $self;
+}
+
+sub _new {
+ my $class = shift;
+ my $options = @_ == 1 ? $_[0] : {@_};
+
+ return bless $options, $class;
+}
+
+sub associated_attribute { (shift)->{'attribute'} }
+
+sub delegate_to_method { (shift)->{'delegate_to_method'} }
+
+sub _initialize_body {
+ my $self = shift;
+
+ my $method_to_call = $self->delegate_to_method;
+ return $self->{body} = $method_to_call
+ if ref $method_to_call;
+
+ my $accessor = $self->_get_delegate_accessor;
+
+ my $handle_name = $self->name;
+
+ # NOTE: we used to do a goto here, but the goto didn't handle
+ # failure correctly (it just returned nothing), so I took that
+ # out. However, the more I thought about it, the less I liked it
+ # doing the goto, and I prefered the act of delegation being
+ # actually represented in the stack trace. - SL
+ $self->{body} = sub {
+ my $instance = shift;
+ my $proxy = $instance->$accessor();
+ ( defined $proxy )
+ || $self->throw_error(
+ "Cannot delegate $handle_name to $method_to_call because "
+ . "the value of "
+ . $self->name
+ . " is not defined",
+ method_name => $method_to_call,
+ object => $instance
+ );
+ $proxy->$method_to_call(@_);
+ };
+}
+
+sub _get_delegate_accessor {
+ my $self = shift;
+
+ my $accessor = $self->associated_attribute->get_read_method_ref;
+
+ $accessor = $accessor->body if blessed $accessor;
+
+ return $accessor;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::Method::Delegation - A Moose Method metaclass for delegation methods
+
+=head1 DESCRIPTION
+
+This is a subclass of L<Moose::Meta::Method> for delegation
+methods.
+
+=head1 METHODS
+
+=over 4
+
+=item B<new (%options)>
+
+This creates the method based on the criteria in C<%options>,
+these options are:
+
+=over 4
+
+=item I<attribute>
+
+This must be an instance of C<Moose::Meta::Attribute> which this
+accessor is being generated for. This paramter is B<required>.
+
+=item I<delegate_to_method>
+
+The method in the associated attribute's value to which we
+delegate. This can be either a method name or a code reference.
+
+=back
+
+=item B<associated_attribute>
+
+Returns the attribute associated with this method.
+
+=item B<delegate_to_method>
+
+Returns the method to which this method delegates.
+
+=back
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no
+exception. If you find a bug please either email me, or add the bug
+to cpan-RT.
+
+=head1 AUTHOR
+
+Dave Rolsky E<lt>autarch at urth.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2008 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/Method/Destructor.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/Method/Destructor.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/Method/Destructor.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -4,10 +4,9 @@
use strict;
use warnings;
-use Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -18,12 +17,12 @@
my $class = shift;
my %options = @_;
- (exists $options{options} && ref $options{options} eq 'HASH')
- || confess "You must pass a hash of options";
-
+ (ref $options{options} eq 'HASH')
+ || $class->throw_error("You must pass a hash of options", data => $options{options});
+
($options{package_name} && $options{name})
- || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
-
+ || $class->throw_error("You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT");
+
my $self = bless {
# from our superclass
'body' => undef,
@@ -57,7 +56,7 @@
# then must pass in a class name
unless (blessed $self) {
(blessed $_[0] && $_[0]->isa('Class::MOP::Class'))
- || confess "When calling is_needed as a class method you must pass a class name";
+ || $self->throw_error("When calling is_needed as a class method you must pass a class name");
return $_[0]->meta->can('DEMOLISH');
}
defined $self->{'body'} ? 1 : 0
@@ -92,7 +91,7 @@
my $code;
{
$code = eval $source;
- confess "Could not eval the destructor :\n\n$source\n\nbecause :\n\n$@" if $@;
+ $self->throw_error("Could not eval the destructor :\n\n$source\n\nbecause :\n\n$@", error => $@, data => $source) if $@;
}
$self->{'body'} = $code;
}
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/Method/Overriden.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/Method/Overriden.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/Method/Overriden.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -3,9 +3,7 @@
use strict;
use warnings;
-use Carp 'confess';
-
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -18,27 +16,28 @@
# it is really more like body's compilation stash
# this is where we need to override the definition of super() so that the
# body of the code can call the right overridden version
- my $_super_package = $args{package} || $args{class}->name;
+ my $super_package = $args{package} || $args{class}->name;
my $name = $args{name};
my $super = $args{class}->find_next_method_by_name($name);
(defined $super)
- || confess "You cannot override '$name' because it has no super method";
+ || $class->throw_error("You cannot override '$name' because it has no super method", data => $name);
my $super_body = $super->body;
my $method = $args{method};
my $body = sub {
+ local $Moose::SUPER_PACKAGE = $super_package;
local @Moose::SUPER_ARGS = @_;
local $Moose::SUPER_BODY = $super_body;
return $method->(@_);
};
# FIXME do we need this make sure this works for next::method?
- # subname "${_super_package}::${name}", $method;
+ # subname "${super_package}::${name}", $method;
# FIXME store additional attrs
$class->wrap(
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/Method.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/Method.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/Method.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -3,12 +3,32 @@
use strict;
use warnings;
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Class::MOP::Method';
+sub _error_thrower {
+ my $self = shift;
+ ( ref $self && $self->associated_metaclass ) || "Moose::Meta::Class";
+}
+
+sub throw_error {
+ my $self = shift;
+ my $inv = $self->_error_thrower;
+ unshift @_, "message" if @_ % 2 == 1;
+ unshift @_, method => $self if ref $self;
+ unshift @_, $inv;
+ my $handler = $inv->can("throw_error");
+ goto $handler; # to avoid incrementing depth by 1
+}
+
+sub _inline_throw_error {
+ my ( $self, $msg, $args ) = @_;
+ "\$meta->throw_error($msg" . ($args ? ", $args" : "") . ")"; # FIXME makes deparsing *REALLY* hard
+}
+
1;
__END__
@@ -25,6 +45,16 @@
but with the expanding role of the method sub-protocol, it might
be more useful later on.
+=head1 METHODS
+
+=over 4
+
+=item throw_error $msg, %args
+
+=item _inline_throw_error $msg_expr, $args_expr
+
+=back
+
=head1 BUGS
All complex software has bugs lurking in it, and this module is no
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/Role/Application/RoleSummation.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/Role/Application/RoleSummation.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/Role/Application/RoleSummation.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -4,13 +4,11 @@
use warnings;
use metaclass;
-use Carp 'confess';
use Scalar::Util 'blessed';
-use Data::Dumper;
use Moose::Meta::Role::Composite;
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -67,18 +65,25 @@
sub check_role_exclusions {
my ($self, $c) = @_;
- my @all_excluded_roles = $uniq->(map {
- $_->get_excluded_roles_list
- } @{$c->get_roles});
+ my %excluded_roles;
+ for my $role (@{ $c->get_roles }) {
+ my $name = $role->name;
+ for my $excluded ($role->get_excluded_roles_list) {
+ push @{ $excluded_roles{$excluded} }, $name;
+ }
+ }
+
foreach my $role (@{$c->get_roles}) {
- foreach my $excluded (@all_excluded_roles) {
- confess "Conflict detected: " . $role->name . " excludes role '" . $excluded . "'"
- if $role->does_role($excluded);
+ foreach my $excluded (keys %excluded_roles) {
+ next unless $role->does_role($excluded);
+
+ my @excluding = @{ $excluded_roles{$excluded} };
+ Moose->throw_error(sprintf "Conflict detected: Role%s %s exclude%s role '%s'", (@excluding == 1 ? '' : 's'), join(', ', @excluding), (@excluding == 1 ? 's' : ''), $excluded);
}
}
- $c->add_excluded_roles(@all_excluded_roles);
+ $c->add_excluded_roles(keys %excluded_roles);
}
sub check_required_methods {
@@ -120,8 +125,8 @@
my %seen;
foreach my $attr (@all_attributes) {
if (exists $seen{$attr->{name}}) {
- confess "We have encountered an attribute conflict with '" . $attr->{name} . "' "
- . "during composition. This is fatal error and cannot be disambiguated."
+ Moose->throw_error("We have encountered an attribute conflict with '" . $attr->{name} . "' "
+ . "during composition. This is fatal error and cannot be disambiguated.")
if $seen{$attr->{name}} != $attr->{attr};
}
$seen{$attr->{name}} = $attr->{attr};
@@ -172,7 +177,7 @@
$method_map{$method->{name}} = $method->{method};
}
- $c->alias_method($_ => $method_map{$_}) for keys %method_map;
+ $c->add_method($_ => $method_map{$_}) for keys %method_map;
}
sub apply_override_method_modifiers {
@@ -190,14 +195,14 @@
my %seen;
foreach my $override (@all_overrides) {
- confess "Role '" . $c->name . "' has encountered an 'override' method conflict " .
+ Moose->throw_error( "Role '" . $c->name . "' has encountered an 'override' method conflict " .
"during composition (A local method of the same name as been found). This " .
- "is fatal error."
+ "is fatal error." )
if $c->has_method($override->{name});
if (exists $seen{$override->{name}}) {
- confess "We have encountered an 'override' method conflict during " .
+ Moose->throw_error( "We have encountered an 'override' method conflict during " .
"composition (Two 'override' methods of the same name encountered). " .
- "This is fatal error."
+ "This is fatal error.")
if $seen{$override->{name}} != $override->{method};
}
$seen{$override->{name}} = $override->{method};
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/Role/Application/ToClass.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/Role/Application/ToClass.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/Role/Application/ToClass.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -4,12 +4,10 @@
use warnings;
use metaclass;
-use Carp 'confess';
-use Scalar::Util 'blessed';
+use Moose::Util 'english_list';
+use Scalar::Util 'blessed';
-use Data::Dumper;
-
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -24,17 +22,21 @@
sub check_role_exclusions {
my ($self, $role, $class) = @_;
if ($class->excludes_role($role->name)) {
- confess "Conflict detected: " . $class->name . " excludes role '" . $role->name . "'";
+ $class->throw_error("Conflict detected: " . $class->name . " excludes role '" . $role->name . "'");
}
foreach my $excluded_role_name ($role->get_excluded_roles_list) {
if ($class->does_role($excluded_role_name)) {
- confess "The class " . $class->name . " does the excluded role '$excluded_role_name'";
+ $class->throw_error("The class " . $class->name . " does the excluded role '$excluded_role_name'");
}
}
}
sub check_required_methods {
my ($self, $role, $class) = @_;
+
+ my @missing;
+ my @is_attr;
+
# NOTE:
# we might need to move this down below the
# the attributes so that we can require any
@@ -46,9 +48,8 @@
if (!$class->find_method_by_name($required_method_name)) {
next if $self->is_aliased_method($required_method_name);
-
- confess "'" . $role->name . "' requires the method '$required_method_name' " .
- "to be implemented by '" . $class->name . "'";
+
+ push @missing, $required_method_name;
}
else {
# NOTE:
@@ -58,9 +59,8 @@
my $method = $class->find_method_by_name($required_method_name);
# check if it is a generated accessor ...
- (!$method->isa('Class::MOP::Method::Accessor'))
- || confess "'" . $role->name . "' requires the method '$required_method_name' " .
- "to be implemented by '" . $class->name . "', the method is only an attribute accessor";
+ push @is_attr, $required_method_name,
+ if $method->isa('Class::MOP::Method::Accessor');
# NOTE:
# All other tests here have been removed, they were tests
@@ -75,6 +75,43 @@
# - SL
}
}
+
+ return unless @missing || @is_attr;
+
+ my $error = '';
+
+ if (@missing) {
+ my $noun = @missing == 1 ? 'method' : 'methods';
+
+ my $list
+ = Moose::Util::english_list( map { q{'} . $_ . q{'} } @missing );
+
+ $error
+ .= q{'}
+ . $role->name
+ . "' requires the $noun $list "
+ . "to be implemented by '"
+ . $class->name . q{'};
+ }
+
+ if (@is_attr) {
+ my $noun = @is_attr == 1 ? 'method' : 'methods';
+
+ my $list
+ = Moose::Util::english_list( map { q{'} . $_ . q{'} } @is_attr );
+
+ $error .= "\n" if length $error;
+
+ $error
+ .= q{'}
+ . $role->name
+ . "' requires the $noun $list "
+ . "to be implemented by '"
+ . $class->name
+ . "' but the method is only an attribute accessor";
+ }
+
+ $class->throw_error($error);
}
sub check_required_attributes {
@@ -103,21 +140,21 @@
my ($self, $role, $class) = @_;
foreach my $method_name ($role->get_method_list) {
- next if $self->is_method_excluded($method_name);
-
- # it if it has one already
- if ($class->has_method($method_name) &&
- # and if they are not the same thing ...
- $class->get_method($method_name)->body != $role->get_method($method_name)->body) {
- next;
+ unless ($self->is_method_excluded($method_name)) {
+ # it if it has one already
+ if ($class->has_method($method_name) &&
+ # and if they are not the same thing ...
+ $class->get_method($method_name)->body != $role->get_method($method_name)->body) {
+ next;
+ }
+ else {
+ # add it, although it could be overriden
+ $class->add_method(
+ $method_name,
+ $role->get_method($method_name)
+ );
+ }
}
- else {
- # add it, although it could be overriden
- $class->alias_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};
@@ -125,9 +162,9 @@
if ($class->has_method($aliased_method_name) &&
# and if they are not the same thing ...
$class->get_method($aliased_method_name)->body != $role->get_method($method_name)->body) {
- confess "Cannot create a method alias if a local method of the same name exists";
+ $class->throw_error("Cannot create a method alias if a local method of the same name exists");
}
- $class->alias_method(
+ $class->add_method(
$aliased_method_name,
$role->get_method($method_name)
);
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/Role/Application/ToInstance.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/Role/Application/ToInstance.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/Role/Application/ToInstance.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -4,10 +4,9 @@
use warnings;
use metaclass;
-use Carp 'confess';
use Scalar::Util 'blessed';
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
Deleted: Moose/branches/Moose-XS/lib/Moose/Meta/Role/Application/ToMetaclassInstance.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/Role/Application/ToMetaclassInstance.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/Role/Application/ToMetaclassInstance.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -1,93 +0,0 @@
-package Moose::Meta::Role::Application::ToMetaclassInstance;
-
-use strict;
-use warnings;
-use metaclass;
-
-use Scalar::Util 'blessed';
-
-our $VERSION = '0.55_01';
-$VERSION = eval $VERSION;
-our $AUTHORITY = 'cpan:STEVAN';
-
-use base 'Moose::Meta::Role::Application::ToClass';
-
-__PACKAGE__->meta->add_attribute('rebless_params' => (
- reader => 'rebless_params',
- default => sub { {} }
-));
-
-my %ANON_CLASSES;
-
-sub apply {
- my ( $self, $role, $meta ) = @_;
-
- my $anon_role_key = (blessed($meta) . $role->name);
-
- my $class;
- if (exists $ANON_CLASSES{$anon_role_key} && defined $ANON_CLASSES{$anon_role_key}) {
- $class = $ANON_CLASSES{$anon_role_key};
- }
- else {
- my $metaclass_class
- = ( ref $meta )->can('create_anon_class')
- ? ref $meta
- : 'Moose::Meta::Class';
- $class = $metaclass_class->create_anon_class(
- superclasses => [ blessed($meta) ],
- );
-
- $ANON_CLASSES{$anon_role_key} = $class;
- $self->SUPER::apply( $role, $class );
- }
-
- $class->rebless_instance( $meta, %{ $self->rebless_params } );
-}
-
-1;
-
-__END__
-
-=pod
-
-=head1 NAME
-
-Moose::Meta::Role::Application::ToMetaclassInstance - Compose a role into a metaclass instance
-
-=head1 DESCRIPTION
-
-=head2 METHODS
-
-=over 4
-
-=item B<new>
-
-=item B<meta>
-
-=item B<apply>
-
-=item B<rebless_params>
-
-=back
-
-=head1 BUGS
-
-All complex software has bugs lurking in it, and this module is no
-exception. If you find a bug please either email me, or add the bug
-to cpan-RT.
-
-=head1 AUTHOR
-
-Stevan Little E<lt>stevan at iinteractive.comE<gt>
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 2006-2008 by Infinity Interactive, Inc.
-
-L<http://www.iinteractive.com>
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
-
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/Role/Application/ToRole.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/Role/Application/ToRole.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/Role/Application/ToRole.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -4,12 +4,9 @@
use warnings;
use metaclass;
-use Carp 'confess';
use Scalar::Util 'blessed';
-use Data::Dumper;
-
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -23,10 +20,10 @@
sub check_role_exclusions {
my ($self, $role1, $role2) = @_;
- confess "Conflict detected: " . $role2->name . " excludes role '" . $role1->name . "'"
+ Moose->throw_error("Conflict detected: " . $role2->name . " excludes role '" . $role1->name . "'")
if $role2->excludes_role($role1->name);
foreach my $excluded_role_name ($role1->get_excluded_roles_list) {
- confess "The class " . $role2->name . " does the excluded role '$excluded_role_name'"
+ Moose->throw_error("The class " . $role2->name . " does the excluded role '$excluded_role_name'")
if $role2->does_role($excluded_role_name);
$role2->add_excluded_roles($excluded_role_name);
}
@@ -54,8 +51,8 @@
if ($role2->has_attribute($attribute_name) &&
# make sure we haven't seen this one already too
$role2->get_attribute($attribute_name) != $role1->get_attribute($attribute_name)) {
- confess "Role '" . $role1->name . "' has encountered an attribute conflict " .
- "during composition. This is fatal error and cannot be disambiguated.";
+ Moose->throw_error("Role '" . $role1->name . "' has encountered an attribute conflict " .
+ "during composition. This is fatal error and cannot be disambiguated.");
}
else {
$role2->add_attribute(
@@ -69,8 +66,6 @@
sub apply_methods {
my ($self, $role1, $role2) = @_;
foreach my $method_name ($role1->get_method_list) {
-
- next if $self->is_method_excluded($method_name);
if ($self->is_method_aliased($method_name)) {
my $aliased_method_name = $self->get_method_aliases->{$method_name};
@@ -78,21 +73,24 @@
if ($role2->has_method($aliased_method_name) &&
# and if they are not the same thing ...
$role2->get_method($aliased_method_name)->body != $role1->get_method($method_name)->body) {
- confess "Cannot create a method alias if a local method of the same name exists";
+ Moose->throw_error("Cannot create a method alias if a local method of the same name exists");
}
- $role2->alias_method(
+ $role2->add_method(
$aliased_method_name,
$role1->get_method($method_name)
);
if (!$role2->has_method($method_name)) {
- $role2->add_required_methods($method_name);
+ $role2->add_required_methods($method_name)
+ unless $self->is_method_excluded($method_name);
}
next;
- }
+ }
+ 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 ...
@@ -103,7 +101,7 @@
}
else {
# add it, although it could be overriden
- $role2->alias_method(
+ $role2->add_method(
$method_name,
$role1->get_method($method_name)
);
@@ -122,9 +120,9 @@
# we have a conflict here, because you cannot
# combine an overriden method with a locally
# defined one
- confess "Role '" . $role1->name . "' has encountered an 'override' method conflict " .
+ Moose->throw_error("Role '" . $role1->name . "' has encountered an 'override' method conflict " .
"during composition (A local method of the same name as been found). This " .
- "is fatal error.";
+ "is fatal error.");
}
else {
# if we are a role, we need to make sure
@@ -132,9 +130,9 @@
# we are composing into
if ($role2->has_override_method_modifier($method_name) &&
$role2->get_override_method_modifier($method_name) != $role2->get_override_method_modifier($method_name)) {
- confess "Role '" . $role1->name . "' has encountered an 'override' method conflict " .
+ Moose->throw_error("Role '" . $role1->name . "' has encountered an 'override' method conflict " .
"during composition (Two 'override' methods of the same name encountered). " .
- "This is fatal error.";
+ "This is fatal error.");
}
else {
# if there is no conflict,
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/Role/Application.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/Role/Application.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/Role/Application.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -4,7 +4,7 @@
use warnings;
use metaclass;
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/Role/Composite.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/Role/Composite.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/Role/Composite.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -4,10 +4,9 @@
use warnings;
use metaclass;
-use Carp 'confess';
use Scalar::Util 'blessed';
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -35,7 +34,7 @@
my ($class, %params) = @_;
# the roles param is required ...
($_->isa('Moose::Meta::Role'))
- || confess "The list of roles must be instances of Moose::Meta::Role, not $_"
+ || Moose->throw_error("The list of roles must be instances of Moose::Meta::Role, not $_")
foreach @{$params{roles}};
# and the name is created from the
# roles if one has not been provided
@@ -43,23 +42,29 @@
$class->_new(\%params);
}
-# NOTE:
-# we need to override this cause
-# we dont have that package I was
-# talking about above.
-# - SL
-sub alias_method {
+# This is largely a cope of what's in Moose::Meta::Role (itself
+# largely a copy of Class::MOP::Class). However, we can't actually
+# call add_package_symbol, because there's no package to which which
+# add the symbol.
+sub add_method {
my ($self, $method_name, $method) = @_;
(defined $method_name && $method_name)
- || confess "You must define a method name";
+ || Moose->throw_error("You must define a method name");
- # make sure to bless the
- # method if nessecary
- $method = $self->method_metaclass->wrap(
- $method,
- package_name => $self->name,
- name => $method_name
- ) if !blessed($method);
+ my $body;
+ if (blessed($method)) {
+ $body = $method->body;
+ if ($method->package_name ne $self->name) {
+ $method = $method->clone(
+ package_name => $self->name,
+ name => $method_name
+ ) if $method->can('clone');
+ }
+ }
+ else {
+ $body = $method;
+ $method = $self->wrap_method_body( body => $body, name => $method_name );
+ }
$self->get_method_map->{$method_name} = $method;
}
@@ -88,7 +93,7 @@
=item B<get_method_map>
-=item B<alias_method>
+=item B<add_method>
=back
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/Role/Method/Required.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/Role/Method/Required.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/Role/Method/Required.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -4,7 +4,7 @@
use strict;
use warnings;
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/Role/Method.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/Role/Method.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/Role/Method.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -4,11 +4,11 @@
use strict;
use warnings;
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
-use base 'Class::MOP::Method';
+use base 'Moose::Meta::Method';
1;
@@ -24,7 +24,7 @@
This is primarily used to mark methods coming from a role
as being different. Right now it is nothing but a subclass
-of L<Class::MOP::Method>.
+of L<Moose::Meta::Method>.
=head1 BUGS
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/Role.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/Role.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/Role.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -5,10 +5,10 @@
use warnings;
use metaclass;
+use Scalar::Util 'blessed';
use Carp 'confess';
-use Scalar::Util 'blessed';
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -122,6 +122,8 @@
sub add_attribute {
my $self = shift;
my $name = shift;
+ (defined $name && $name)
+ || Moose->throw_error("You must provide a name for the attribute");
my $attr_desc;
if (scalar @_ == 1 && ref($_[0]) eq 'HASH') {
$attr_desc = $_[0];
@@ -215,8 +217,8 @@
sub add_override_method_modifier {
my ($self, $method_name, $method) = @_;
(!$self->has_method($method_name))
- || confess "Cannot add an override of method '$method_name' " .
- "because there is a local version of '$method_name'";
+ || Moose->throw_error("Cannot add an override of method '$method_name' " .
+ "because there is a local version of '$method_name'");
$self->get_override_method_modifiers_map->{$method_name} = $method;
}
@@ -260,8 +262,9 @@
sub add_role {
my ($self, $role) = @_;
(blessed($role) && $role->isa('Moose::Meta::Role'))
- || confess "Roles must be instances of Moose::Meta::Role";
+ || Moose->throw_error("Roles must be instances of Moose::Meta::Role");
push @{$self->get_roles} => $role;
+ $self->reset_package_cache_flag;
}
sub calculate_all_roles {
@@ -277,7 +280,7 @@
sub does_role {
my ($self, $role_name) = @_;
(defined $role_name)
- || confess "You must supply a role name to look for";
+ || Moose->throw_error("You must supply a role name to look for");
# if we are it,.. then return true
return 1 if $role_name eq $self->name;
# otherwise.. check our children
@@ -308,10 +311,10 @@
my $role_name = $self->name;
my $method_metaclass = $self->method_metaclass;
- my %all_code = $self->get_all_package_symbols('CODE');
+ my $all_code = $self->get_all_package_symbols('CODE');
- foreach my $symbol (keys %all_code) {
- my $code = $all_code{$symbol};
+ foreach my $symbol (keys %{ $all_code }) {
+ my $code = $all_code->{$symbol};
next if exists $map->{$symbol} &&
defined $map->{$symbol} &&
@@ -366,38 +369,32 @@
exists $self->get_method_map->{$name} ? 1 : 0
}
-# FIXME this is copypasated from Class::MOP::Class
+# FIXME this is copy-pasted from Class::MOP::Class
# refactor to inherit from some common base
sub wrap_method_body {
my ( $self, %args ) = @_;
- my $body = delete $args{body}; # delete is for compat
+ ('CODE' eq ref $args{body})
+ || Moose->throw_error("Your code block must be a CODE reference");
- ('CODE' eq ref($body))
- || confess "Your code block must be a CODE reference";
-
- $self->method_metaclass->wrap( $body => (
+ $self->method_metaclass->wrap(
package_name => $self->name,
%args,
- ));
+ );
}
sub add_method {
my ($self, $method_name, $method) = @_;
(defined $method_name && $method_name)
- || confess "You must define a method name";
+ || Moose->throw_error("You must define a method name");
my $body;
if (blessed($method)) {
$body = $method->body;
- if ($method->package_name ne $self->name &&
- $method->name ne $method_name) {
- warn "Hello there, got something for you."
- . " Method says " . $method->package_name . " " . $method->name
- . " Class says " . $self->name . " " . $method_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');
}
}
@@ -427,18 +424,9 @@
}
sub alias_method {
- my ($self, $method_name, $method) = @_;
- (defined $method_name && $method_name)
- || confess "You must define a method name";
+ my $self = shift;
- my $body = (blessed($method) ? $method->body : $method);
- ('CODE' eq ref($body))
- || confess "Your code block must be a CODE reference";
-
- $self->add_package_symbol(
- { sigil => '&', type => 'CODE', name => $method_name },
- $body
- );
+ $self->add_method(@_);
}
## ------------------------------------------------------------------
@@ -449,7 +437,7 @@
my ($self, $other, @args) = @_;
(blessed($other))
- || confess "You must pass in an blessed instance";
+ || Moose->throw_error("You must pass in an blessed instance");
if ($other->isa('Moose::Meta::Role')) {
require Moose::Meta::Role::Application::ToRole;
@@ -465,16 +453,6 @@
}
}
-sub apply_to_metaclass_instance {
- my ($self, $meta, @args) = @_;
-
- $meta->isa('Moose::Meta::Class') || $meta->isa('Moose::Meta::Role')
- || confess "You must pass in a Moose::Meta::Class or Moose::Meta::Role instance";
-
- require Moose::Meta::Role::Application::ToMetaclassInstance;
- return Moose::Meta::Role::Application::ToMetaclassInstance->new(@args)->apply($self, $meta);
-}
-
sub combine {
my ($class, @role_specs) = @_;
@@ -497,6 +475,119 @@
return $c;
}
+sub create {
+ my ( $role, $package_name, %options ) = @_;
+
+ $options{package} = $package_name;
+
+ (ref $options{attributes} eq 'HASH')
+ || confess "You must pass a HASH ref of attributes"
+ if exists $options{attributes};
+
+ (ref $options{methods} eq 'HASH')
+ || confess "You must pass a HASH ref of methods"
+ if exists $options{methods};
+
+ $role->SUPER::create(%options);
+
+ my (%initialize_options) = %options;
+ delete @initialize_options{qw(
+ package
+ attributes
+ methods
+ version
+ authority
+ )};
+
+ my $meta = $role->initialize( $package_name => %initialize_options );
+
+ # FIXME totally lame
+ $meta->add_method('meta' => sub {
+ $role->initialize(ref($_[0]) || $_[0]);
+ });
+
+ if (exists $options{attributes}) {
+ foreach my $attribute_name (keys %{$options{attributes}}) {
+ my $attr = $options{attributes}->{$attribute_name};
+ $meta->add_attribute($attribute_name => $attr);
+ }
+ }
+
+ if (exists $options{methods}) {
+ foreach my $method_name (keys %{$options{methods}}) {
+ $meta->add_method($method_name, $options{methods}->{$method_name});
+ }
+ }
+
+ Class::MOP::weaken_metaclass($meta->name)
+ if $meta->is_anon_role;
+
+ return $meta;
+}
+
+# anonymous roles. most of it is copied straight out of Class::MOP::Class.
+# an intrepid hacker might find great riches if he unifies this code with that
+# code in Class::MOP::Module or Class::MOP::Package
+{
+ # NOTE:
+ # this should be sufficient, if you have a
+ # use case where it is not, write a test and
+ # I will change it.
+ my $ANON_ROLE_SERIAL = 0;
+
+ # NOTE:
+ # we need a sufficiently annoying prefix
+ # this should suffice for now, this is
+ # used in a couple of places below, so
+ # need to put it up here for now.
+ my $ANON_ROLE_PREFIX = 'Moose::Meta::Role::__ANON__::SERIAL::';
+
+ sub is_anon_role {
+ my $self = shift;
+ no warnings 'uninitialized';
+ $self->name =~ /^$ANON_ROLE_PREFIX/;
+ }
+
+ sub create_anon_role {
+ my ($role, %options) = @_;
+ my $package_name = $ANON_ROLE_PREFIX . ++$ANON_ROLE_SERIAL;
+ return $role->create($package_name, %options);
+ }
+
+ # NOTE:
+ # this will only get called for
+ # anon-roles, all other calls
+ # are assumed to occur during
+ # global destruction and so don't
+ # really need to be handled explicitly
+ sub DESTROY {
+ my $self = shift;
+
+ return if Class::MOP::in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
+
+ no warnings 'uninitialized';
+ return unless $self->name =~ /^$ANON_ROLE_PREFIX/;
+
+ # XXX: is this necessary for us? I don't understand what it's doing
+ # -sartak
+
+ # Moose does a weird thing where it replaces the metaclass for
+ # class when fixing metaclass incompatibility. In that case,
+ # we don't want to clean out the namespace now. We can detect
+ # that because Moose will explicitly update the singleton
+ # cache in Class::MOP.
+ #my $current_meta = Class::MOP::get_metaclass_by_name($self->name);
+ #return if $current_meta ne $self;
+
+ my ($serial_id) = ($self->name =~ /^$ANON_ROLE_PREFIX(\d+)/);
+ no strict 'refs';
+ foreach my $key (keys %{$ANON_ROLE_PREFIX . $serial_id}) {
+ delete ${$ANON_ROLE_PREFIX . $serial_id}{$key};
+ }
+ delete ${'main::' . $ANON_ROLE_PREFIX}{$serial_id . '::'};
+ }
+}
+
#####################################################################
## NOTE:
## This is Moose::Meta::Role as defined by Moose (plus the use of
@@ -791,6 +882,16 @@
=back
+=over 4
+
+=item B<create>
+
+=item B<create_anon_role>
+
+=item B<is_anon_role>
+
+=back
+
=head1 BUGS
All complex software has bugs lurking in it, and this module is no
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/TypeCoercion/Union.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/TypeCoercion/Union.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/TypeCoercion/Union.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -5,10 +5,9 @@
use warnings;
use metaclass;
-use Carp 'confess';
use Scalar::Util 'blessed';
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -19,8 +18,8 @@
my $type_constraint = $self->type_constraint;
(blessed $type_constraint && $type_constraint->isa('Moose::Meta::TypeConstraint::Union'))
- || confess "You can only a Moose::Meta::TypeCoercion::Union for a " .
- "Moose::Meta::TypeConstraint::Union, not a $type_constraint";
+ || 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;
@@ -44,7 +43,7 @@
sub has_coercion_for_type { 0 }
sub add_type_coercions {
- confess "Cannot add additional type coercions to Union types";
+ Moose->throw_error("Cannot add additional type coercions to Union types");
}
1;
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/TypeCoercion.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/TypeCoercion.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/TypeCoercion.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -5,12 +5,10 @@
use warnings;
use metaclass;
-use Carp 'confess';
-
use Moose::Meta::Attribute;
use Moose::Util::TypeConstraints ();
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -46,7 +44,7 @@
my ($constraint_name, $action) = splice(@coercion_map, 0, 2);
my $type_constraint = ref $constraint_name ? $constraint_name : Moose::Util::TypeConstraints::find_or_parse_type_constraint($constraint_name);
(defined $type_constraint)
- || confess "Could not find the type constraint ($constraint_name) to coerce from";
+ || Moose->throw_error("Could not find the type constraint ($constraint_name) to coerce from");
push @coercions => [
$type_constraint->_compiled_type_constraint,
$action
@@ -80,7 +78,7 @@
while (@new_coercion_map) {
my ($constraint_name, $action) = splice(@new_coercion_map, 0, 2);
- confess "A coercion action already exists for '$constraint_name'"
+ Moose->throw_error("A coercion action already exists for '$constraint_name'")
if exists $has_coercion{$constraint_name};
push @{$coercion_map} => ($constraint_name, $action);
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Class.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Class.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Class.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -7,7 +7,7 @@
use Scalar::Util 'blessed';
use Moose::Util::TypeConstraints ();
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -61,6 +61,7 @@
my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
+ return unless defined $other;
return unless $other->isa(__PACKAGE__);
return $self->class eq $other->class;
@@ -83,6 +84,8 @@
}
my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name_or_class);
+
+ return unless defined $type;
if ( $type->isa(__PACKAGE__) ) {
# if $type_or_name_or_class isn't a class, it might be the TC name of another ::Class type
@@ -94,6 +97,15 @@
}
}
+# This is a bit counter-intuitive, but a child type of a Class type
+# constraint is not itself a Class type constraint (it has no class
+# attribute). This whole create_child_type thing needs some changing
+# though, probably making MMC->new a factory or something.
+sub create_child_type {
+ my ($self, @args) = @_;
+ return Moose::Meta::TypeConstraint->new(@args, parent => $self);
+}
+
1;
__END__
@@ -128,6 +140,8 @@
=item B<meta>
+=item B<create_child_type>
+
=back
=head1 BUGS
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Enum.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Enum.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Enum.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -6,7 +6,7 @@
use Moose::Util::TypeConstraints ();
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -67,6 +67,11 @@
sub { defined($_[0]) && !ref($_[0]) && exists $values{$_[0]} };
}
+sub create_child_type {
+ my ($self, @args) = @_;
+ return Moose::Meta::TypeConstraint->new(@args, parent => $self);
+}
+
1;
__END__
@@ -91,6 +96,8 @@
=item B<meta>
+=item B<create_child_type>
+
=back
=head1 BUGS
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Parameterizable.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Parameterizable.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Parameterizable.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -4,11 +4,13 @@
use warnings;
use metaclass;
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Moose::Meta::TypeConstraint';
+use Moose::Meta::TypeConstraint::Parameterized;
+use Moose::Util::TypeConstraints ();
__PACKAGE__->meta->add_attribute('constraint_generator' => (
accessor => 'constraint_generator',
@@ -40,7 +42,40 @@
};
}
+sub _parse_type_parameter {
+ my ($self, $type_parameter) = @_;
+ return Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($type_parameter);
+}
+sub parameterize {
+ 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')) {
+ $contained_tc->is_a_type_of($parent->type_parameter)
+ || Moose->throw_error("$type_parameter is not a subtype of ".$parent->type_parameter);
+ }
+ }
+
+ if ( $contained_tc->isa('Moose::Meta::TypeConstraint') ) {
+ my $tc_name = $self->name . '[' . $contained_tc->name . ']';
+ return Moose::Meta::TypeConstraint::Parameterized->new(
+ name => $tc_name,
+ parent => $self,
+ type_parameter => $contained_tc,
+ );
+ }
+ else {
+ Moose->throw_error("The type parameter must be a Moose meta type");
+ }
+}
+
+
1;
__END__
@@ -62,6 +97,11 @@
=item B<generate_constraint_for>
+=item B<parameterize>
+
+Given a single type constraint string, this method parses the string
+and parameterizes the type based on the parsed string.
+
=item B<meta>
=back
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Parameterized.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Parameterized.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Parameterized.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -5,10 +5,10 @@
use metaclass;
use Scalar::Util 'blessed';
-use Carp 'confess';
use Moose::Util::TypeConstraints;
+use Moose::Meta::TypeConstraint::Parameterizable;
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -37,12 +37,12 @@
my $self = shift;
($self->has_type_parameter)
- || confess "You cannot create a Higher Order type without a type parameter";
+ || Moose->throw_error("You cannot create a Higher Order type without a type parameter");
my $type_parameter = $self->type_parameter;
(blessed $type_parameter && $type_parameter->isa('Moose::Meta::TypeConstraint'))
- || confess "The type parameter must be a Moose meta type";
+ || 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)) {
@@ -53,10 +53,15 @@
# if we get here, then we couldn't
# find a way to parameterize this type
- confess "The " . $self->name . " constraint cannot be used, because "
- . $self->parent->name . " doesn't subtype or coerce from a parameterizable type.";
+ Moose->throw_error("The " . $self->name . " constraint cannot be used, because "
+ . $self->parent->name . " doesn't subtype or coerce from a parameterizable type.");
}
+sub create_child_type {
+ my ($self, %opts) = @_;
+ return Moose::Meta::TypeConstraint::Parameterizable->new(%opts, parent=>$self);
+}
+
1;
__END__
@@ -82,6 +87,8 @@
=item B<equals>
+=item B<create_child_type>
+
=back
=head1 BUGS
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Registry.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Registry.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Registry.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -6,9 +6,9 @@
use metaclass;
use Scalar::Util 'blessed';
-use Carp 'confess';
+use Carp 'confess'; # FIXME Moose->throw_error
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -33,7 +33,7 @@
sub has_type_constraint {
my ($self, $type_name) = @_;
- exists $self->type_constraints->{$type_name} ? 1 : 0
+ ($type_name and exists $self->type_constraints->{$type_name}) ? 1 : 0
}
sub get_type_constraint {
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Role.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Role.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Role.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -7,7 +7,7 @@
use Scalar::Util 'blessed';
use Moose::Util::TypeConstraints ();
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -59,6 +59,7 @@
my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
+ return unless defined $other;
return unless $other->isa(__PACKAGE__);
return $self->role eq $other->role;
@@ -82,6 +83,8 @@
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
@@ -92,6 +95,11 @@
}
}
+sub create_child_type {
+ my ($self, @args) = @_;
+ return Moose::Meta::TypeConstraint->new(@args, parent => $self);
+}
+
1;
__END__
@@ -120,6 +128,8 @@
=item B<is_subtype_of>
+=item B<create_child_type>
+
=item B<parents>
Return all the parent types, corresponding to the parent classes.
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Union.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Union.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint/Union.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -7,7 +7,7 @@
use Moose::Meta::TypeCoercion::Union;
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -21,7 +21,8 @@
sub new {
my ($class, %options) = @_;
my $self = $class->SUPER::new(
- name => (join ' | ' => map { $_->name } @{$options{type_constraints}}),
+ name => (join '|' => sort {$a cmp $b}
+ map { $_->name } @{$options{type_constraints}}),
parent => undef,
message => undef,
hand_optimized_type_constraint => undef,
@@ -99,6 +100,29 @@
return 0;
}
+sub create_child_type {
+ my ( $self, %opts ) = @_;
+
+ my $constraint
+ = Moose::Meta::TypeConstraint->new( %opts, parent => $self );
+
+ # if we have a type constraint union, and no
+ # type check, this means we are just aliasing
+ # the union constraint, which means we need to
+ # handle this differently.
+ # - SL
+ if ( not( defined $opts{constraint} )
+ && $self->has_coercion ) {
+ $constraint->coercion(
+ Moose::Meta::TypeCoercion::Union->new(
+ type_constraint => $self,
+ )
+ );
+ }
+
+ return $constraint;
+}
+
1;
__END__
@@ -181,6 +205,8 @@
=item B<has_hand_optimized_type_constraint>
+=item B<create_child_type>
+
=back
=head1 BUGS
Modified: Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Meta/TypeConstraint.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -8,12 +8,11 @@
use overload '""' => sub { shift->name }, # stringify to tc name
fallback => 1;
-use Carp 'confess';
use Scalar::Util qw(blessed refaddr);
use base qw(Class::MOP::Object);
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -60,14 +59,26 @@
sub new {
my $class = shift;
- my $self = $class->_new(@_);
+ my ($first, @rest) = @_;
+ my %args = ref $first ? %$first : $first ? ($first, @rest) : ();
+ $args{name} = $args{name} ? "$args{name}" : "__ANON__";
+
+ my $self = $class->_new(%args);
$self->compile_type_constraint()
unless $self->_has_compiled_type_constraint;
return $self;
}
-sub coerce { ((shift)->coercion || confess "Cannot coerce without a type coercion")->coerce(@_) }
-sub check { $_[0]->_compiled_type_constraint->($_[1]) ? 1 : undef }
+
+
+sub coerce { ((shift)->coercion || Moose->throw_error("Cannot coerce without a type coercion"))->coerce(@_) }
+
+sub check {
+ my ($self, @args) = @_;
+ my $constraint_subref = $self->_compiled_type_constraint;
+ return $constraint_subref->(@args) ? 1 : undef;
+}
+
sub validate {
my ($self, $value) = @_;
if ($self->_compiled_type_constraint->($value)) {
@@ -155,9 +166,9 @@
my $check = $self->constraint;
(defined $check)
- || confess "Could not compile type constraint '"
+ || Moose->throw_error("Could not compile type constraint '"
. $self->name
- . "' because no constraint check";
+ . "' because no constraint check");
return $self->_compile_subtype($check)
if $self->has_parent;
@@ -170,7 +181,7 @@
my $type_constraint = $self->hand_optimized_type_constraint;
- confess unless ref $type_constraint;
+ Moose->throw_error("Hand optimized type constraint is not a code reference") unless ref $type_constraint;
return $type_constraint;
}
@@ -205,8 +216,9 @@
} else {
return Class::MOP::subname($self->name, sub {
return undef unless $optimized_parent->($_[0]);
- local $_ = $_[0];
- $check->($_[0]);
+ my (@args) = @_;
+ local $_ = $args[0];
+ $check->(@args);
});
}
} else {
@@ -214,9 +226,10 @@
my @checks = @parents;
push @checks, $check if $check != $null_constraint;
return Class::MOP::subname($self->name => sub {
- local $_ = $_[0];
+ my (@args) = @_;
+ local $_ = $args[0];
foreach my $check (@checks) {
- return undef unless $check->($_[0]);
+ return undef unless $check->(@args);
}
return 1;
});
@@ -229,8 +242,9 @@
return $check if $check == $null_constraint; # Item, Any
return Class::MOP::subname($self->name => sub {
- local $_ = $_[0];
- $check->($_[0]);
+ my (@args) = @_;
+ local $_ = $args[0];
+ $check->(@args);
});
}
@@ -247,6 +261,12 @@
return @parents;
}
+sub create_child_type {
+ my ($self, %opts) = @_;
+ my $class = ref $self;
+ return $class->new(%opts, parent => $self);
+}
+
## this should get deprecated actually ...
sub union { Carp::croak "DEPRECATED" }
@@ -282,22 +302,23 @@
=item B<equals ($type_name_or_object)>
-This checks the current type against the supplied type (only).
-Returns false either if the type name or object supplied
-does not match, or if a type name isn't found in the type registry.
+This checks the current type against the supplied type (only).
+Returns false if the two types are not equal. It also returns false if
+you provide the type as a name, and the type name isn't found in the
+type registry.
=item B<is_a_type_of ($type_name_or_object)>
This checks the current type against the supplied type, or if the
-current type is a sub-type of the type name or object supplied.
-Returns false if the current type is not descended from the supplied
-type, of if the supplied type isn't found in the type registry.
+current type is a sub-type of the type name or object supplied. It
+also returns false if you provide the type as a name, and the type
+name isn't found in the type registry.
=item B<is_subtype_of ($type_name_or_object)>
-This checks the current type is a sub-type of the type name or object supplied.
-Returns false if the current type is not descended from the supplied
-type, of if the supplied type isn't found in the type registry.
+This checks the current type is a sub-type of the type name or object
+supplied. It also returns false if you provide the type as a name, and
+the type name isn't found in the type registry.
=item B<compile_type_constraint>
@@ -323,30 +344,47 @@
=item B<parent>
-The parent type of this type.
+This type's parent type.
=item B<has_parent>
-If this type has a parent type.
+Returns true if this type has a parent type.
=item B<parents>
+Synonym for C<parent>.
+
=item B<constraint>
+Returns this type's constraint. This is the value of C<where> provided
+when defining a type.
+
=item B<has_message>
+Returns true if this type has a message.
+
=item B<message>
+Returns this type's message.
+
=item B<get_message ($value)>
+Generate message for $value.
+
=item B<has_coercion>
+Returns true if this type has a coercion.
+
=item B<coercion>
+Returns this type's L<Moose::Meta::TypeCoercion> if one exists.
+
=item B<hand_optimized_type_constraint>
=item B<has_hand_optimized_type_constraint>
+=item B<create_child_type>
+
=back
=head2 DEPRECATED METHOD
Modified: Moose/branches/Moose-XS/lib/Moose/Object.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Object.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Object.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -7,9 +7,7 @@
use if ( not our $__mx_is_compiled ), 'Moose::Meta::Class';
use if ( not our $__mx_is_compiled ), metaclass => 'Moose::Meta::Class';
-use Carp 'confess';
-
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -26,7 +24,7 @@
if (scalar @_ == 1) {
if (defined $_[0]) {
(ref($_[0]) eq 'HASH')
- || confess "Single parameters to new() must be a HASH ref";
+ || $class->meta->throw_error("Single parameters to new() must be a HASH ref", data => $_[0]);
return {%{$_[0]}};
}
else {
@@ -45,14 +43,14 @@
return unless $_[0]->can('BUILD');
my ($self, $params) = @_;
foreach my $method (reverse $self->meta->find_all_methods_by_name('BUILD')) {
- $method->{code}->body->($self, $params);
+ $method->{code}->execute($self, $params);
}
}
sub DEMOLISHALL {
my $self = shift;
foreach my $method ($self->meta->find_all_methods_by_name('DEMOLISH')) {
- $method->{code}->body->($self);
+ $method->{code}->execute($self);
}
}
@@ -85,12 +83,12 @@
}
# new does() methods will be created
-# as approiate see Moose::Meta::Role
+# as appropiate see Moose::Meta::Role
sub does {
my ($self, $role_name) = @_;
- (defined $role_name)
- || confess "You must supply a role name to does()";
my $meta = $self->meta;
+ (defined $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
Modified: Moose/branches/Moose-XS/lib/Moose/Role.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Role.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Role.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -5,12 +5,12 @@
use warnings;
use Scalar::Util 'blessed';
-use Carp 'confess', 'croak';
+use Carp 'croak';
use Data::OptList;
use Sub::Exporter;
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -54,7 +54,7 @@
my $code = pop @_;
for (@_) {
- croak "Moose::Role do not currently support "
+ croak "Roles do not currently support "
. ref($_)
. " references for before method modifiers"
if ref $_;
@@ -67,7 +67,7 @@
my $code = pop @_;
for (@_) {
- croak "Moose::Role do not currently support "
+ croak "Roles do not currently support "
. ref($_)
. " references for after method modifiers"
if ref $_;
@@ -79,7 +79,7 @@
my $meta = Moose::Meta::Role->initialize(shift);
my $code = pop @_;
for (@_) {
- croak "Moose::Role do not currently support "
+ croak "Roles do not currently support "
. ref($_)
. " references for around method modifiers"
if ref $_;
@@ -100,11 +100,11 @@
}
sub inner {
- croak "Moose::Role cannot support 'inner'";
+ croak "Roles cannot support 'inner'";
}
sub augment {
- croak "Moose::Role cannot support 'augment'";
+ croak "Roles cannot support 'augment'";
}
my $exporter = Moose::Exporter->setup_import_methods(
@@ -123,8 +123,7 @@
my %args = @_;
my $role = $args{for_class}
- or confess
- "Cannot call init_meta without specifying a for_class";
+ or Moose->throw_error("Cannot call init_meta without specifying a for_class");
my $metaclass = $args{metaclass} || "Moose::Meta::Role";
@@ -136,11 +135,17 @@
if ($role->can('meta')) {
$meta = $role->meta();
(blessed($meta) && $meta->isa('Moose::Meta::Role'))
- || confess "You already have a &meta function, but it does not return a Moose::Meta::Role";
+ || Moose->throw_error("You already have a &meta function, but it does not return a Moose::Meta::Role");
}
else {
$meta = $metaclass->initialize($role);
- $meta->alias_method('meta' => sub { $meta });
+
+ $meta->add_method(
+ 'meta' => sub {
+ # re-initialize so it inherits properly
+ $metaclass->initialize( ref($_[0]) || $_[0] );
+ }
+ );
}
return $meta;
Added: Moose/branches/Moose-XS/lib/Moose/Unsweetened.pod
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Unsweetened.pod (rev 0)
+++ Moose/branches/Moose-XS/lib/Moose/Unsweetened.pod 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,334 @@
+=pod
+
+=head1 NAME
+
+Moose::Unsweetened - Moose idioms in plain old Perl 5 without the sugar
+
+=head1 DESCRIPTION
+
+If you're trying to figure out just what the heck Moose does, and how
+it saves you time, you might find it helpful to see what Moose is
+I<really> doing for you. This document shows you the translation from
+Moose sugar back to plain old Perl 5.
+
+=head1 CLASSES AND ATTRIBUTES
+
+First, we define two very small classes the Moose way.
+
+ package Person;
+
+ use DateTime;
+ use DateTime::Format::Natural;
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ has name => (
+ is => 'rw',
+ isa => 'Str',
+ required => 1,
+ );
+
+ # Moose doesn't know about non-Moose-based classes.
+ class_type 'DateTime';
+
+ my $en_parser = DateTime::Format::Natural->new(
+ lang => 'en',
+ time_zone => 'UTC',
+ );
+
+ coerce 'DateTime'
+ => from 'Str'
+ => via { $en_parser->parse_datetime($_) };
+
+ has birth_date => (
+ is => 'rw',
+ isa => 'DateTime',
+ coerce => 1,
+ handles => { birth_year => 'year' },
+ );
+
+ subtype 'ShirtSize'
+ => as 'Str'
+ => where { /^(?:s|m|l|xl|xxl)$/i }
+ => message { "$_ is not a valid shirt size (s, m, l, xl, xxl)" };
+
+ has shirt_size => (
+ is => 'rw',
+ isa => 'ShirtSize',
+ default => 'l',
+ );
+
+This is a fairly simple class with three attributes. We also define a
+type to validate t-shirt sizes because we don't want to end up with
+something like "blue" for the shirt size!
+
+ package User;
+
+ use Email::Valid;
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ extends 'Person';
+
+ subtype 'Email'
+ => as 'Str'
+ => where { Email::Valid->address($_) }
+ => message { "$_ is not a valid email address" };
+
+ has email_address => (
+ is => 'rw',
+ isa => 'Email',
+ required => 1,
+ );
+
+This class subclasses Person to add a single attribute, email address.
+
+Now we will show what these classes would look like in plain old Perl
+5. For the sake of argument, we won't use any base classes or any
+helpers like C<Class::Accessor>.
+
+ package Person;
+
+ use strict;
+ use warnings;
+
+ use Carp qw( confess );
+ use DateTime;
+ use DateTime::Format::Natural;
+
+
+ sub new {
+ my $class = shift;
+ my %p = ref $_[0] ? %{ $_[0] } : @_;
+
+ exists $p{name}
+ or confess 'name is a required attribute';
+ $class->_validate_name( $p{name} );
+
+ exists $p{birth_date}
+ or confess 'birth_date is a required attribute';
+
+ $p{birth_date} = $class->_coerce_birth_date( $p{birth_date} );
+ $class->_validate_birth_date( $p{birth_date} );
+
+ $p{shirt_size} = 'l'
+ unless exists $p{shirt_size}:
+
+ $class->_validate_shirt_size( $p{shirt_size} );
+
+ return bless \%p, $class;
+ }
+
+ sub _validate_name {
+ shift;
+ my $name = shift;
+
+ local $Carp::CarpLevel = $Carp::CarpLevel + 1;
+
+ defined $name
+ or confess 'name must be a string';
+ }
+
+ {
+ my $en_parser = DateTime::Format::Natural->new(
+ lang => 'en',
+ time_zone => 'UTC',
+ );
+
+ sub _coerce_birth_date {
+ shift;
+ my $date = shift;
+
+ return $date unless defined $date && ! ref $date;
+
+ my $dt = $en_parser->parse_datetime($date);
+
+ return $dt ? $dt : undef;
+ }
+ }
+
+ sub _validate_birth_date {
+ shift;
+ my $birth_date = shift;
+
+ local $Carp::CarpLevel = $Carp::CarpLevel + 1;
+
+ $birth_date->isa('DateTime') )
+ or confess 'birth_date must be a DateTime object';
+ }
+
+ sub _validate_shirt_size {
+ shift;
+ my $shirt_size = shift;
+
+ local $Carp::CarpLevel = $Carp::CarpLevel + 1;
+
+ defined $shirt_size
+ or confess 'shirt_size cannot be undef';
+
+ $shirt_size =~ /^(?:s|m|l|xl|xxl)$/
+ or confess "$shirt_size is not a valid shirt size (s, m, l, xl, xxl)";
+ }
+
+ sub name {
+ my $self = shift;
+
+ if (@_) {
+ $self->_validate_name( $_[0] );
+ $self->{name} = $_[0];
+ }
+
+ return $self->{name};
+ }
+
+ sub birth_date {
+ my $self = shift;
+
+ if (@_) {
+ my $date = $self->_coerce_birth_date( $_[0] );
+ $self->_validate_birth_date( $date );
+
+ $self->{birth_date} = $date;
+ }
+
+ return $self->{birth_date};
+ }
+
+ sub birth_year {
+ my $self = shift;
+
+ return $self->birth_date->year;
+ }
+
+ sub shirt_size {
+ my $self = shift;
+
+ if (@_) {
+ $self->_validate_shirt_size( $_[0] );
+ $self->{shirt_size} = $_[0];
+ }
+
+ return $self->{shirt_size};
+ }
+
+Wow, that was a mouthful! One thing to note is just how much space the
+data validation code consumes. As a result, it's pretty common for
+Perl 5 programmers to just not bother. Unfortunately, not validating
+arguments leads to surprises down the line ("why is birth_date an
+email address?").
+
+Also, did you spot the (intentional) bug?
+
+It's in the C<_validate_birth_date()> method. We should check that
+that value in C<$birth_date> is actually defined and object before we
+go and call C<isa()> on it! Leaving out those checks means our data
+validation code could actually cause our program to die. Oops.
+
+Note that if we add a superclass to Person we'll have to change the
+constructor to account for that.
+
+(As an aside, getting all the little details of what Moose does for
+you just right in this example was really not easy, which emphasizes
+the point of the example. Moose saves you a lot of work!)
+
+Now let's see User:
+
+ package User;
+
+ use strict;
+ use warnings;
+
+ use Carp qw( confess );
+ use Email::Valid;
+ use Scalar::Util qw( blessed );
+
+ use base 'Person';
+
+
+ sub new {
+ my $class = shift;
+ my %p = ref $_[0] ? %{ $_[0] } : @_;
+
+ exists $p{email_address}
+ or confess 'email_address is a required attribute';
+ $class->_validate_email_address( $p{email_address} );
+
+ my $self = $class->SUPER::new(%p);
+
+ $self->{email_address} = $p{email_address};
+
+ return $self;
+ }
+
+ sub _validate_email_address {
+ shift;
+ my $email_address = shift;
+
+ local $Carp::CarpLevel = $Carp::CarpLevel + 1;
+
+ defined $email_address
+ or confess 'email_address must be a string';
+
+ Email::Valid->address($email_address)
+ or confess "$email_address is not a valid email address";
+ }
+
+ sub email_address {
+ my $self = shift;
+
+ if (@_) {
+ $self->_validate_email_address( $_[0] );
+ $self->{email_address} = $_[0];
+ }
+
+ return $self->{email_address};
+ }
+
+That one was shorter, but it only has one attribute.
+
+Between the two classes, we have a whole lot of code that doesn't do
+much. We could probably simplify this by defining some sort of
+"attribute and validation" hash, like this:
+
+ package Person;
+
+ my %Attr = (
+ name => {
+ required => 1,
+ validate => sub { defined $_ },
+ },
+ birth_date => {
+ required => 1,
+ validate => sub { blessed $_ && $_->isa('DateTime') },
+ },
+ shirt_size => {
+ required => 1,
+ validate => sub { defined $_ && $_ =~ /^(?:s|m|l|xl|xxl)$/i },
+ }
+ );
+
+Then we could define a base class that would accept such a definition,
+and do the right thing. Keep that sort of thing up and we're well on
+our way to writing a half-assed version of Moose!
+
+Of course, there are CPAN modules that do some of what Moose does,
+like C<Class::Accessor>, C<Class::Meta>, and so on. But none of them
+put together all of Moose's features along with a layer of declarative
+sugar, nor are these other modules designed for extensibility in the
+same way as Moose. With Moose, it's easy to write a MooseX module to
+replace or extend a piece of built-in functionality.
+
+=head1 AUTHOR
+
+Dave Rolsky E<lt>autarch at urth.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2008 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
Added: Moose/branches/Moose-XS/lib/Moose/Util/MetaRole.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Util/MetaRole.pm (rev 0)
+++ Moose/branches/Moose-XS/lib/Moose/Util/MetaRole.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,269 @@
+package Moose::Util::MetaRole;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.64';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use List::MoreUtils qw( all );
+
+my @Classes = qw( constructor_class destructor_class error_class );
+
+sub apply_metaclass_roles {
+ my %options = @_;
+
+ my $for = $options{for_class};
+
+ my %old_classes
+ = map { $_ => $for->meta->$_ } grep { $for->meta->can($_) } @Classes;
+
+ my $meta = _make_new_metaclass( $for, \%options );
+
+ for my $c ( grep { $meta->can($_) } @Classes ) {
+ if ( $options{ $c . '_roles' } ) {
+ my $class = _make_new_class(
+ $meta->$c(),
+ $options{ $c . '_roles' }
+ );
+
+ $meta->$c($class);
+ }
+ else {
+ $meta->$c( $old_classes{$c} );
+ }
+ }
+
+ return $meta;
+}
+
+sub _make_new_metaclass {
+ my $for = shift;
+ my $options = shift;
+
+ return $for->meta()
+ unless grep { exists $options->{ $_ . '_roles' } }
+ qw(
+ metaclass
+ attribute_metaclass
+ method_metaclass
+ instance_metaclass
+ );
+
+ my $new_metaclass
+ = _make_new_class( ref $for->meta(), $options->{metaclass_roles} );
+
+ my $old_meta = $for->meta();
+
+ # This could get called for a Moose::Meta::Role as well as a Moose::Meta::Class
+ my %classes = map {
+ $_ => _make_new_class( $old_meta->$_(), $options->{ $_ . '_roles' } )
+ }
+ grep { $old_meta->can($_) }
+ qw(
+ attribute_metaclass
+ method_metaclass
+ instance_metaclass
+ );
+
+ return $new_metaclass->reinitialize( $for, %classes );
+}
+
+sub apply_base_class_roles {
+ my %options = @_;
+
+ my $for = $options{for_class};
+
+ my $meta = $for->meta();
+
+ my $new_base = _make_new_class(
+ $for,
+ $options{roles},
+ [ $meta->superclasses() ],
+ );
+
+ $meta->superclasses($new_base)
+ if $new_base ne $meta->name();
+}
+
+sub _make_new_class {
+ my $existing_class = shift;
+ my $roles = shift;
+ my $superclasses = shift || [$existing_class];
+
+ return $existing_class unless $roles;
+
+ my $meta = Class::MOP::Class->initialize($existing_class);
+
+ return $existing_class
+ if $meta->can('does_role') && all { $meta->does_role($_) } @{$roles};
+
+ return Moose::Meta::Class->create_anon_class(
+ superclasses => $superclasses,
+ roles => $roles,
+ cache => 1,
+ )->name();
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Moose::Util::MetaRole - Apply roles to any metaclass, as well as the object base class
+
+=head1 SYNOPSIS
+
+ package MyApp::Moose;
+
+ use strict;
+ use warnings;
+
+ use Moose ();
+ use Moose::Exporter;
+ use Moose::Util::Meta::Role;
+
+ use MyApp::Role::Meta::Class;
+ use MyApp::Role::Meta::Method::Constructor;
+ use MyApp::Role::Object;
+
+ Moose::Exporter->setup_import_methods( also => 'Moose' );
+
+ sub init_meta {
+ shift;
+ my %options = @_;
+
+ Moose->init_meta(%options);
+
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => $options{for_class},
+ metaclass_roles => ['MyApp::Role::Meta::Class'],
+ constructor_class_roles => ['MyApp::Role::Meta::Method::Constructor'],
+ );
+
+ Moose::Util::MetaRole::apply_base_class_roles(
+ for_class => $options{for_class},
+ roles => ['MyApp::Role::Object'],
+ );
+
+ return $options{for_class}->meta();
+ }
+
+=head1 DESCRIPTION
+
+B<The whole concept behind this module is still considered
+experimental, and it could go away in the future!>
+
+This utility module is designed to help authors of Moose extensions
+write extensions that are able to cooperate with other Moose
+extensions. To do this, you must write your extensions as roles, which
+can then be dynamically applied to the caller's metaclasses.
+
+This module makes sure to preserve any existing superclasses and roles
+already set for the meta objects, which means that any number of
+extensions can apply roles in any order.
+
+=head1 USAGE
+
+B<It is very important that you only call this module's functions when
+your module is imported by the caller>. The process of applying roles
+to the metaclass reinitializes the metaclass object, which wipes out
+any existing attributes already defined. However, as long as you do
+this when your module is imported, the caller should not have any
+attributes defined yet.
+
+The easiest way to ensure that this happens is to use
+L<Moose::Exporter> and provide an C<init_meta> method that will be
+called when imported.
+
+=head1 FUNCTIONS
+
+This module provides two functions.
+
+=head2 apply_metaclass_roles( ... )
+
+This function will apply roles to one or more metaclasses for the
+specified class. It accepts the following parameters:
+
+=over 4
+
+=item * for_class => $name
+
+This specifies the class for which to alter the meta classes.
+
+=item * metaclass_roles => \@roles
+
+=item * attribute_metaclass_roles => \@roles
+
+=item * method_metaclass_roles => \@roles
+
+=item * instance_metaclass_roles => \@roles
+
+=item * constructor_class_roles => \@roles
+
+=item * destructor_class_roles => \@roles
+
+These parameter all specify one or more roles to be applied to the
+specified metaclass. You can pass any or all of these parameters at
+once.
+
+=back
+
+=head2 apply_base_class_roles( for_class => $class, roles => \@roles )
+
+This function will apply the specified roles to the object's base class.
+
+=head1 PROBLEMS WITH METACLASS ROLES AND SUBCLASS
+
+Because of the way this module works, there is an ordering problem
+which occurs in certain situations. This sequence of events causes an
+error:
+
+=over 4
+
+=item 1.
+
+There is a class (ClassA) which uses some extension(s) that apply
+roles to the metaclass.
+
+=item 2.
+
+You have another class (ClassB) which wants to subclass ClassA and
+apply some more extensions.
+
+=back
+
+Normally, the call to C<extends> will happen at run time, I<after> the
+additional extensions are applied. This causes an error when we try to
+make the metaclass for ClassB compatible with the metaclass for
+ClassA.
+
+We hope to be able to fix this in the future.
+
+For now the workaround is for ClassB to make sure it extends ClassA
+I<before> it loads extensions:
+
+ package ClassB;
+
+ use Moose;
+
+ BEGIN { extends 'ClassA' }
+
+ use MooseX::SomeExtension;
+
+=head1 AUTHOR
+
+Dave Rolsky E<lt>autarch at urth.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2008 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
Modified: Moose/branches/Moose-XS/lib/Moose/Util/TypeConstraints/OptimizedConstraints.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Util/TypeConstraints/OptimizedConstraints.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Util/TypeConstraints/OptimizedConstraints.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -5,7 +5,7 @@
use Scalar::Util 'blessed', 'looks_like_number';
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
Modified: Moose/branches/Moose-XS/lib/Moose/Util/TypeConstraints.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Util/TypeConstraints.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Util/TypeConstraints.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -4,11 +4,12 @@
use strict;
use warnings;
-use Carp 'confess';
+use Carp ();
+use List::MoreUtils qw( all );
use Scalar::Util 'blessed';
use Moose::Exporter;
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -19,31 +20,11 @@
# ensures the prototypes are in scope when consumers are
# compiled.
-# creation and location
-sub find_type_constraint ($);
-sub register_type_constraint ($);
-sub find_or_create_type_constraint ($;$);
-sub find_or_parse_type_constraint ($);
-sub find_or_create_isa_type_constraint ($);
-sub find_or_create_does_type_constraint ($);
-sub create_type_constraint_union (@);
-sub create_parameterized_type_constraint ($);
-sub create_class_type_constraint ($;$);
-sub create_role_type_constraint ($;$);
-sub create_enum_type_constraint ($$);
-
# dah sugah!
-sub type ($$;$$);
-sub subtype ($$;$$$);
-sub class_type ($;$);
-sub coerce ($@);
-sub as ($);
-sub from ($);
sub where (&);
sub via (&);
sub message (&);
sub optimize_as (&);
-sub enum ($;@);
## private stuff ...
sub _create_type_constraint ($$$;$$);
@@ -92,7 +73,7 @@
}
}
-sub create_type_constraint_union (@) {
+sub create_type_constraint_union {
my @type_constraint_names;
if (scalar @_ == 1 && _detect_type_constraint_union($_[0])) {
@@ -101,48 +82,58 @@
else {
@type_constraint_names = @_;
}
-
+
(scalar @type_constraint_names >= 2)
- || confess "You must pass in at least 2 type names to make a union";
+ || Moose->throw_error("You must pass in at least 2 type names to make a union");
- ($REGISTRY->has_type_constraint($_))
- || confess "Could not locate type constraint ($_) for the union"
- foreach @type_constraint_names;
+ my @type_constraints = map {
+ find_or_parse_type_constraint($_) ||
+ Moose->throw_error("Could not locate type constraint ($_) for the union");
+ } @type_constraint_names;
return Moose::Meta::TypeConstraint::Union->new(
- type_constraints => [
- map {
- $REGISTRY->get_type_constraint($_)
- } @type_constraint_names
- ],
+ type_constraints => \@type_constraints
);
}
-sub create_parameterized_type_constraint ($) {
+sub create_parameterized_type_constraint {
my $type_constraint_name = shift;
-
my ($base_type, $type_parameter) = _parse_parameterized_type_constraint($type_constraint_name);
(defined $base_type && defined $type_parameter)
- || confess "Could not parse type name ($type_constraint_name) correctly";
+ || Moose->throw_error("Could not parse type name ($type_constraint_name) correctly");
- ($REGISTRY->has_type_constraint($base_type))
- || confess "Could not locate the base type ($base_type)";
-
- return Moose::Meta::TypeConstraint::Parameterized->new(
- name => $type_constraint_name,
- parent => $REGISTRY->get_type_constraint($base_type),
- type_parameter => find_or_create_isa_type_constraint($type_parameter),
- );
+ if ($REGISTRY->has_type_constraint($base_type)) {
+ my $base_type_tc = $REGISTRY->get_type_constraint($base_type);
+ return _create_parameterized_type_constraint(
+ $base_type_tc,
+ $type_parameter
+ );
+ } else {
+ Moose->throw_error("Could not locate the base type ($base_type)");
+ }
}
+sub _create_parameterized_type_constraint {
+ my ( $base_type_tc, $type_parameter ) = @_;
+ if ( $base_type_tc->can('parameterize') ) {
+ return $base_type_tc->parameterize($type_parameter);
+ } else {
+ return Moose::Meta::TypeConstraint::Parameterized->new(
+ name => $base_type_tc->name . '[' . $type_parameter . ']',
+ parent => $base_type_tc,
+ type_parameter => find_or_create_isa_type_constraint($type_parameter),
+ );
+ }
+}
+
#should we also support optimized checks?
-sub create_class_type_constraint ($;$) {
+sub create_class_type_constraint {
my ( $class, $options ) = @_;
# too early for this check
#find_type_constraint("ClassName")->check($class)
- # || confess "Can't create a class type constraint because '$class' is not a class name";
+ # || Moose->throw_error("Can't create a class type constraint because '$class' is not a class name");
my %options = (
class => $class,
@@ -155,12 +146,12 @@
Moose::Meta::TypeConstraint::Class->new( %options );
}
-sub create_role_type_constraint ($;$) {
+sub create_role_type_constraint {
my ( $role, $options ) = @_;
# too early for this check
#find_type_constraint("ClassName")->check($class)
- # || confess "Can't create a class type constraint because '$class' is not a class name";
+ # || Moose->throw_error("Can't create a class type constraint because '$class' is not a class name");
my %options = (
role => $role,
@@ -174,7 +165,7 @@
}
-sub find_or_create_type_constraint ($;$) {
+sub find_or_create_type_constraint {
my ( $type_constraint_name, $options_for_anon_type ) = @_;
if ( my $constraint = find_or_parse_type_constraint($type_constraint_name) ) {
@@ -201,28 +192,25 @@
return;
}
-sub find_or_create_isa_type_constraint ($) {
+sub find_or_create_isa_type_constraint {
my $type_constraint_name = shift;
find_or_parse_type_constraint($type_constraint_name) || create_class_type_constraint($type_constraint_name)
}
-sub find_or_create_does_type_constraint ($) {
+sub find_or_create_does_type_constraint {
my $type_constraint_name = shift;
find_or_parse_type_constraint($type_constraint_name) || create_role_type_constraint($type_constraint_name)
}
-sub find_or_parse_type_constraint ($) {
- my $type_constraint_name = shift;
-
- return $REGISTRY->get_type_constraint($type_constraint_name)
- if $REGISTRY->has_type_constraint($type_constraint_name);
-
+sub find_or_parse_type_constraint {
+ my $type_constraint_name = normalize_type_constraint_name(shift);
my $constraint;
-
- if (_detect_type_constraint_union($type_constraint_name)) {
+
+ if ($constraint = find_type_constraint($type_constraint_name)) {
+ return $constraint;
+ } elsif (_detect_type_constraint_union($type_constraint_name)) {
$constraint = create_type_constraint_union($type_constraint_name);
- }
- elsif (_detect_parameterized_type_constraint($type_constraint_name)) {
+ } elsif (_detect_parameterized_type_constraint($type_constraint_name)) {
$constraint = create_parameterized_type_constraint($type_constraint_name);
} else {
return;
@@ -232,51 +220,70 @@
return $constraint;
}
+sub normalize_type_constraint_name {
+ my $type_constraint_name = shift;
+ $type_constraint_name =~ s/\s//g;
+ return $type_constraint_name;
+}
+
+sub _confess {
+ my $error = shift;
+
+ local $Carp::CarpLevel = $Carp::CarpLevel + 1;
+ Carp::confess($error);
+}
+
## --------------------------------------------------------
## exported functions ...
## --------------------------------------------------------
-sub find_type_constraint ($) {
+sub find_type_constraint {
my $type = shift;
if ( blessed $type and $type->isa("Moose::Meta::TypeConstraint") ) {
return $type;
- }
+ }
else {
return unless $REGISTRY->has_type_constraint($type);
return $REGISTRY->get_type_constraint($type);
}
}
-sub register_type_constraint ($) {
+sub register_type_constraint {
my $constraint = shift;
- confess "can't register an unnamed type constraint" unless defined $constraint->name;
+ Moose->throw_error("can't register an unnamed type constraint") unless defined $constraint->name;
$REGISTRY->add_type_constraint($constraint);
return $constraint;
}
# type constructors
-sub type ($$;$$) {
+sub type {
splice(@_, 1, 0, undef);
goto &_create_type_constraint;
}
-sub subtype ($$;$$$) {
+sub subtype {
# NOTE:
# this adds an undef for the name
# if this is an anon-subtype:
# subtype(Num => where { $_ % 2 == 0 }) # anon 'even' subtype
- # but if the last arg is not a code
- # ref then it is a subtype alias:
+ # or
+ # subtype(Num => where { $_ % 2 == 0 }) message { "$_ must be an even number" }
+ #
+ # but if the last arg is not a code ref then it is a subtype
+ # alias:
+ #
# subtype(MyNumbers => as Num); # now MyNumbers is the same as Num
# ... yeah I know it's ugly code
# - SL
- unshift @_ => undef if scalar @_ <= 2 && ('CODE' eq ref($_[1]));
+ unshift @_ => undef if scalar @_ == 2 && ( 'CODE' eq ref( $_[-1] ) );
+ unshift @_ => undef
+ if scalar @_ == 3 && all { ref($_) =~ /^(?:CODE|HASH)$/ } @_[ 1, 2 ];
goto &_create_type_constraint;
}
-sub class_type ($;$) {
+sub class_type {
register_type_constraint(
create_class_type_constraint(
$_[0],
@@ -294,20 +301,20 @@
);
}
-sub coerce ($@) {
+sub coerce {
my ($type_name, @coercion_map) = @_;
_install_type_coercions($type_name, \@coercion_map);
}
-sub as ($) { $_[0] }
-sub from ($) { $_[0] }
+sub as { @_ }
+sub from { @_ }
sub where (&) { $_[0] }
sub via (&) { $_[0] }
sub message (&) { +{ message => $_[0] } }
sub optimize_as (&) { +{ optimized => $_[0] } }
-sub enum ($;@) {
+sub enum {
my ($type_name, @values) = @_;
# NOTE:
# if only an array-ref is passed then
@@ -318,7 +325,7 @@
$type_name = undef;
}
(scalar @values >= 2)
- || confess "You must have at least two values to enumerate through";
+ || Moose->throw_error("You must have at least two values to enumerate through");
my %valid = map { $_ => 1 } @values;
register_type_constraint(
@@ -329,9 +336,9 @@
);
}
-sub create_enum_type_constraint ($$) {
+sub create_enum_type_constraint {
my ( $type_name, $values ) = @_;
-
+
Moose::Meta::TypeConstraint::Enum->new(
name => $type_name || '__ANON__',
values => $values,
@@ -347,56 +354,45 @@
my $parent = shift;
my $check = shift;
- my ($message, $optimized);
+ my ( $message, $optimized );
for (@_) {
$message = $_->{message} if exists $_->{message};
$optimized = $_->{optimized} if exists $_->{optimized};
}
- my $pkg_defined_in = scalar(caller(0));
+ my $pkg_defined_in = scalar( caller(0) );
- if (defined $name) {
+ if ( defined $name ) {
my $type = $REGISTRY->get_type_constraint($name);
- ($type->_package_defined_in eq $pkg_defined_in)
- || confess ("The type constraint '$name' has already been created in "
- . $type->_package_defined_in . " and cannot be created again in "
- . $pkg_defined_in)
- if defined $type;
+ ( $type->_package_defined_in eq $pkg_defined_in )
+ || _confess(
+ "The type constraint '$name' has already been created in "
+ . $type->_package_defined_in
+ . " and cannot be created again in "
+ . $pkg_defined_in )
+ if defined $type;
}
- my $class = "Moose::Meta::TypeConstraint";
-
- # FIXME should probably not be a special case
- if ( defined $parent and $parent = find_or_parse_type_constraint($parent) ) {
- $class = "Moose::Meta::TypeConstraint::Parameterizable"
- if $parent->isa("Moose::Meta::TypeConstraint::Parameterizable");
- }
-
- my $constraint = $class->new(
- name => $name || '__ANON__',
+ my %opts = (
+ name => $name,
package_defined_in => $pkg_defined_in,
- ($parent ? (parent => $parent ) : ()),
- ($check ? (constraint => $check) : ()),
- ($message ? (message => $message) : ()),
- ($optimized ? (optimized => $optimized) : ()),
+ ( $check ? ( constraint => $check ) : () ),
+ ( $message ? ( message => $message ) : () ),
+ ( $optimized ? ( optimized => $optimized ) : () ),
);
- # NOTE:
- # if we have a type constraint union, and no
- # type check, this means we are just aliasing
- # the union constraint, which means we need to
- # handle this differently.
- # - SL
- if (not(defined $check)
- && $parent->isa('Moose::Meta::TypeConstraint::Union')
- && $parent->has_coercion
- ){
- $constraint->coercion(Moose::Meta::TypeCoercion::Union->new(
- type_constraint => $parent
- ));
+ my $constraint;
+ if ( defined $parent
+ and $parent
+ = blessed $parent ? $parent : find_or_parse_type_constraint($parent) )
+ {
+ $constraint = $parent->create_child_type(%opts);
}
+ else {
+ $constraint = Moose::Meta::TypeConstraint->new(%opts);
+ }
$REGISTRY->add_type_constraint($constraint)
if defined $name;
@@ -408,7 +404,7 @@
my ($type_name, $coercion_map) = @_;
my $type = find_type_constraint($type_name);
(defined $type)
- || confess "Cannot find type '$type_name', perhaps you forgot to load it.";
+ || Moose->throw_error("Cannot find type '$type_name', perhaps you forgot to load it.");
if ($type->has_coercion) {
$type->coercion->add_type_coercions(@$coercion_map);
}
@@ -439,9 +435,9 @@
my $any;
- my $type = qr{ $valid_chars+ (?: \[ (??{$any}) \] )? }x;
- my $type_capture_parts = qr{ ($valid_chars+) (?: \[ ((??{$any})) \] )? }x;
- my $type_with_parameter = qr{ $valid_chars+ \[ (??{$any}) \] }x;
+ my $type = qr{ $valid_chars+ (?: \[ \s* (??{$any}) \s* \] )? }x;
+ my $type_capture_parts = qr{ ($valid_chars+) (?: \[ \s* ((??{$any})) \s* \] )? }x;
+ my $type_with_parameter = qr{ $valid_chars+ \[ \s* (??{$any}) \s* \] }x;
my $op_union = qr{ \s* \| \s* }x;
my $union = qr{ $type (?: $op_union $type )+ }x;
@@ -467,11 +463,11 @@
push @rv => $1;
}
(pos($given) eq length($given))
- || confess "'$given' didn't parse (parse-pos="
+ || Moose->throw_error("'$given' didn't parse (parse-pos="
. pos($given)
. " and str-length="
. length($given)
- . ")";
+ . ")");
@rv;
}
@@ -485,6 +481,27 @@
# define some basic built-in types
## --------------------------------------------------------
+# By making these classes immutable before creating all the types we
+# below, we avoid repeatedly calling the slow MOP-based accessors.
+$_->make_immutable(
+ inline_constructor => 1,
+ constructor_name => "_new",
+
+ # these are Class::MOP accessors, so they need inlining
+ inline_accessors => 1
+ ) for grep { $_->is_mutable }
+ map { $_->meta }
+ qw(
+ Moose::Meta::TypeConstraint
+ Moose::Meta::TypeConstraint::Union
+ Moose::Meta::TypeConstraint::Parameterized
+ Moose::Meta::TypeConstraint::Parameterizable
+ Moose::Meta::TypeConstraint::Class
+ Moose::Meta::TypeConstraint::Role
+ Moose::Meta::TypeConstraint::Enum
+ Moose::Meta::TypeConstraint::Registry
+);
+
type 'Any' => where { 1 }; # meta-type including all
type 'Item' => where { 1 }; # base-type
@@ -619,7 +636,7 @@
sub add_parameterizable_type {
my $type = shift;
(blessed $type && $type->isa('Moose::Meta::TypeConstraint::Parameterizable'))
- || confess "Type must be a Moose::Meta::TypeConstraint::Parameterizable not $type";
+ || Moose->throw_error("Type must be a Moose::Meta::TypeConstraint::Parameterizable not $type");
push @PARAMETERIZABLE_TYPES => $type;
}
@@ -649,7 +666,7 @@
type 'Num' => where { Scalar::Util::looks_like_number($_) };
subtype 'Natural'
- => as 'Num'
+ => as 'Int'
=> where { $_ > 0 };
subtype 'NaturalLessThanTen'
@@ -675,7 +692,7 @@
inference is performed, expression are not typed, etc. etc. etc.
This is simply a means of creating small constraint functions which
-can be used to simplify your own type-checking code, with the added
+can be used to simplify your own type-checking code, with the added
side benefit of making your intentions clearer through self-documentation.
=head2 Slightly Less Important Caveat
@@ -705,7 +722,7 @@
=head2 Default Type Constraints
-This module also provides a simple hierarchy for Perl 5 types, here is
+This module also provides a simple hierarchy for Perl 5 types, here is
that hierarchy represented visually.
Any
@@ -733,12 +750,12 @@
B<NOTE:> Any type followed by a type parameter C<[`a]> can be
parameterized, this means you can say:
- ArrayRef[Int] # an array of intergers
+ ArrayRef[Int] # an array of integers
HashRef[CodeRef] # a hash of str to CODE ref mappings
Maybe[Str] # value may be a string, may be undefined
B<NOTE:> Unless you parameterize a type, then it is invalid to
-include the square brackets. I.e. C<ArrayRef[]> will be
+include the square brackets. I.e. C<ArrayRef[]> will be
literally interpreted as a type name.
B<NOTE:> The C<Undef> type constraint for the most part works
@@ -750,10 +767,10 @@
this type constraint to pass. I know this is not ideal for all,
but it is a saner restriction than most others.
-=head2 Type Constraint Naming
+=head2 Type Constraint Naming
-Since the types created by this module are global, it is suggested
-that you namespace your types just as you would namespace your
+Since the types created by this module are global, it is suggested
+that you namespace your types just as you would namespace your
modules. So instead of creating a I<Color> type for your B<My::Graphics>
module, you would call the type I<My::Graphics::Color> instead.
@@ -774,7 +791,7 @@
-keys => HasLength,
-values => IsArrayRef( IsObject ));
-For more examples see the F<t/200_examples/204_example_w_DCS.t>
+For more examples see the F<t/200_examples/204_example_w_DCS.t>
test file.
Here is an example of using L<Test::Deep> and it's non-test
@@ -789,7 +806,7 @@
})))
};
-For a complete example see the
+For a complete example see the
F<t/200_examples/205_example_w_TestDeep.t> test file.
=head1 FUNCTIONS
@@ -857,18 +874,19 @@
This is just sugar for the type constraint construction syntax.
-Takes a block/code ref as an argument. When the type constraint is tested,
-the supplied code is run with the value to be tested in $_. Returning
-a true value indicates that the type constraint passes, a false value
-indicates that it failed.
+Takes a block/code ref as an argument. When the type constraint is
+tested, the supplied code is run with the value to be tested in
+$_. This block should return true or false to indicate whether or not
+the constraint check passed.
=item B<message>
This is just sugar for the type constraint construction syntax.
Takes a block/code ref as an argument. When the type constraint fails,
-then the code block is run (with the value again in $_), and the value
-returned is the text of the exception which is thrown.
+then the code block is run (with the value provided in $_). This code
+ref should return a string, which will be used in the text of the
+exception thrown.
=item B<optimize_as>
@@ -910,6 +928,11 @@
=over 4
+=item B<normalize_type_constraint_name ($type_constraint_name)>
+
+Given a string that is expected to match a type constraint, will normalize the
+string so that extra whitespace and newlines are removed.
+
=item B<create_type_constraint_union ($pipe_seperated_types | @type_constraint_names)>
Given string with C<$pipe_seperated_types> or a list of C<@type_constraint_names>,
@@ -957,7 +980,7 @@
=item B<find_or_create_does_type_constraint ($type_name)>
-Attempts to parse the type name using L<find_or_parse_type_constraint> and if
+Attempts to parse the type name using C<find_or_parse_type_constraint> and if
no appropriate constraint is found will create a new anonymous one.
The C<isa> variant will use C<create_class_type_constraint> and the C<does>
Modified: Moose/branches/Moose-XS/lib/Moose/Util.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose/Util.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose/Util.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -5,10 +5,9 @@
use Sub::Exporter;
use Scalar::Util 'blessed';
-use Carp 'confess';
-use Class::MOP 0.56;
+use Class::MOP 0.60;
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -22,6 +21,7 @@
resolve_metatrait_alias
resolve_metaclass_alias
add_method_modifier
+ english_list
];
Sub::Exporter::setup_exporter({
@@ -73,17 +73,10 @@
sub apply_all_roles {
my $applicant = shift;
- apply_all_roles_with_method( $applicant, 'apply', [@_] );
-}
+ Moose->throw_error("Must specify at least one role to apply to $applicant") unless @_;
-sub apply_all_roles_with_method {
- my ( $applicant, $apply_method, $role_list ) = @_;
+ my $roles = Data::OptList::mkopt( [@_] );
- confess "Must specify at least one role to apply to $applicant"
- unless @$role_list;
-
- my $roles = Data::OptList::mkopt($role_list);
-
my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
foreach my $role_spec (@$roles) {
@@ -91,18 +84,17 @@
}
( $_->[0]->can('meta') && $_->[0]->meta->isa('Moose::Meta::Role') )
- || confess "You can only consume roles, "
+ || Moose->throw_error("You can only consume roles, "
. $_->[0]
- . " is not a Moose role"
+ . " is not a Moose role")
foreach @$roles;
if ( scalar @$roles == 1 ) {
my ( $role, $params ) = @{ $roles->[0] };
- $role->meta->$apply_method( $meta,
- ( defined $params ? %$params : () ) );
+ $role->meta->apply( $meta, ( defined $params ? %$params : () ) );
}
else {
- Moose::Meta::Role->combine( @$roles )->$apply_method($meta);
+ Moose::Meta::Role->combine( @$roles )->apply($meta);
}
}
@@ -128,25 +120,35 @@
}
sub resolve_metatrait_alias {
- resolve_metaclass_alias( @_, trait => 1 );
+ return resolve_metaclass_alias( @_, trait => 1 );
}
-sub resolve_metaclass_alias {
- my ( $type, $metaclass_name, %options ) = @_;
+{
+ my %cache;
- if ( my $resolved = eval {
- my $possible_full_name = 'Moose::Meta::' . $type . '::Custom::' . ( $options{trait} ? "Trait::" : "" ) . $metaclass_name;
+ sub resolve_metaclass_alias {
+ my ( $type, $metaclass_name, %options ) = @_;
- Class::MOP::load_class($possible_full_name);
+ my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
+ return $cache{$cache_key}{$metaclass_name}
+ if $cache{$cache_key}{$metaclass_name};
- $possible_full_name->can('register_implementation')
- ? $possible_full_name->register_implementation
- : $possible_full_name;
- } ) {
- return $resolved;
- } else {
- Class::MOP::load_class($metaclass_name);
- return $metaclass_name;
+ my $possible_full_name
+ = 'Moose::Meta::'
+ . $type
+ . '::Custom::'
+ . ( $options{trait} ? "Trait::" : "" )
+ . $metaclass_name;
+
+ my $loaded_class = Class::MOP::load_first_existing_class(
+ $possible_full_name,
+ $metaclass_name
+ );
+
+ return $cache{$cache_key}{$metaclass_name}
+ = $loaded_class->can('register_implementation')
+ ? $loaded_class->register_implementation
+ : $loaded_class;
}
}
@@ -169,6 +171,19 @@
}
}
+sub english_list {
+ my @items = sort @_;
+
+ return $items[0] if @items == 1;
+ return "$items[0] and $items[1]" if @items == 2;
+
+ my $tail = pop @items;
+ my $list = join ', ', @items;
+ $list .= ', and ' . $tail;
+
+ return $list;
+}
+
1;
__END__
@@ -229,13 +244,6 @@
C<@roles> will be pre-processed through L<Data::OptList::mkopt>
to allow for the additional arguments to be passed.
-=item B<apply_all_roles_with_method ($applicant, $method, @roles)>
-
-This function works just like C<apply_all_roles()>, except it allows
-you to specify what method will be called on the role metaclass when
-applying it to the C<$applicant>. This exists primarily so one can use
-the C<< Moose::Meta::Role->apply_to_metaclass_instance() >> method.
-
=item B<get_all_attribute_values($meta, $instance)>
Returns the values of the C<$instance>'s fields keyed by the attribute names.
@@ -260,6 +268,12 @@
=item B<add_method_modifier ($class_or_obj, $modifier_name, $args)>
+=item B<english_list(@items)>
+
+Given a list of scalars, turns them into a proper list in English
+("one and two", "one, two, three, and four"). This is used to help us
+make nicer error messages.
+
=back
=head1 TODO
Modified: Moose/branches/Moose-XS/lib/Moose.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Moose.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Moose.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -6,17 +6,18 @@
use 5.008;
-our $VERSION = '0.55_01';
-our $XS_VERSION = $VERSION;
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
+our $XS_VERSION = $VERSION;
+
use Scalar::Util 'blessed';
use Carp 'confess', 'croak', 'cluck';
use Moose::Exporter;
-use Class::MOP 0.64;
+use Class::MOP 0.75;
use Moose::Meta::Class;
use Moose::Meta::TypeConstraint;
@@ -33,11 +34,23 @@
use Moose::Meta::Role::Application::ToClass;
use Moose::Meta::Role::Application::ToRole;
use Moose::Meta::Role::Application::ToInstance;
-use Moose::Meta::Role::Application::ToMetaclassInstance;
use Moose::Util::TypeConstraints;
use Moose::Util ();
+sub _caller_info {
+ my $level = @_ ? ($_[0] + 1) : 2;
+ my %info;
+ @info{qw(package file line)} = caller($level);
+ return \%info;
+}
+
+sub throw_error {
+ # FIXME This
+ shift;
+ goto \&confess
+}
+
sub extends {
my $class = shift;
@@ -57,7 +70,7 @@
# this checks the metaclass to make sure
# it is correct, sometimes it can get out
# of sync when the classes are being built
- my $meta = Moose::Meta::Class->initialize($class)->_fix_metaclass_incompatability(@supers);
+ my $meta = Moose::Meta::Class->initialize($class);
$meta->superclasses(@supers);
}
@@ -70,7 +83,7 @@
my $class = shift;
my $name = shift;
croak 'Usage: has \'name\' => ( key => value, ... )' if @_ == 1;
- my %options = @_;
+ my %options = ( definition_context => _caller_info(), @_ );
my $attrs = ( ref($name) eq 'ARRAY' ) ? $name : [ ($name) ];
Class::MOP::Class->initialize($class)->add_attribute( $_, %options ) for @$attrs;
}
@@ -90,8 +103,15 @@
Moose::Util::add_method_modifier($class, 'around', \@_);
}
+our $SUPER_PACKAGE;
+our $SUPER_BODY;
+our @SUPER_ARGS;
+
sub super {
- return unless our $SUPER_BODY; $SUPER_BODY->(our @SUPER_ARGS);
+ # This check avoids a recursion loop - see
+ # t/100_bugs/020_super_recursion.t
+ return if defined $SUPER_PACKAGE && $SUPER_PACKAGE ne caller();
+ return unless $SUPER_BODY; $SUPER_BODY->(@SUPER_ARGS);
}
sub override {
@@ -120,16 +140,9 @@
Class::MOP::Class->initialize($class)->add_augment_method_modifier( $name => $method );
}
-sub make_immutable {
- my $class = shift;
- cluck "The make_immutable keyword has been deprecated, " .
- "please go back to __PACKAGE__->meta->make_immutable\n";
- Class::MOP::Class->initialize($class)->make_immutable(@_);
-}
-
Moose::Exporter->setup_import_methods(
with_caller => [
- qw( extends with has before after around override augment make_immutable )
+ qw( extends with has before after around override augment)
],
as_is => [
qw( super inner ),
@@ -153,12 +166,11 @@
my %args = @_;
my $class = $args{for_class}
- or confess "Cannot call init_meta without specifying a for_class";
+ or Moose->throw_error("Cannot call init_meta without specifying a for_class");
my $base_class = $args{base_class} || 'Moose::Object';
my $metaclass = $args{metaclass} || 'Moose::Meta::Class';
- confess
- "The Metaclass $metaclass must be a subclass of Moose::Meta::Class."
+ Moose->throw_error("The Metaclass $metaclass must be a subclass of Moose::Meta::Class.")
unless $metaclass->isa('Moose::Meta::Class');
# make a subtype for each Moose class
@@ -169,7 +181,7 @@
if ( $meta = Class::MOP::get_metaclass_by_name($class) ) {
unless ( $meta->isa("Moose::Meta::Class") ) {
- confess "$class already has a metaclass, but it does not inherit $metaclass ($meta)";
+ Moose->throw_error("$class already has a metaclass, but it does not inherit $metaclass ($meta)");
}
} else {
# no metaclass, no 'meta' method
@@ -185,7 +197,7 @@
: ref($ancestor_meta));
# if we have an ancestor metaclass that inherits $metaclass, we use
- # that. This is like _fix_metaclass_incompatability, but we can do it now.
+ # that. This is like _fix_metaclass_incompatibility, but we can do it now.
# the case of having an ancestry is not very common, but arises in
# e.g. Reaction
@@ -211,7 +223,7 @@
my $method_meta = $class->meta;
( blessed($method_meta) && $method_meta->isa('Moose::Meta::Class') )
- || confess "$class already has a &meta function, but it does not return a Moose::Meta::Class ($meta)";
+ || Moose->throw_error("$class already has a &meta function, but it does not return a Moose::Meta::Class ($meta)");
$meta = $method_meta;
}
@@ -241,24 +253,18 @@
## make 'em all immutable
-$_->meta->make_immutable(
+$_->make_immutable(
inline_constructor => 1,
constructor_name => "_new",
- inline_accessors => 1, # these are Class::MOP accessors, so they need inlining
- )
- for (qw(
+ # these are Class::MOP accessors, so they need inlining
+ inline_accessors => 1
+ ) for grep { $_->is_mutable }
+ map { $_->meta }
+ qw(
Moose::Meta::Attribute
Moose::Meta::Class
Moose::Meta::Instance
- Moose::Meta::TypeConstraint
- Moose::Meta::TypeConstraint::Union
- Moose::Meta::TypeConstraint::Parameterized
- Moose::Meta::TypeConstraint::Parameterizable
- Moose::Meta::TypeConstraint::Enum
- Moose::Meta::TypeConstraint::Class
- Moose::Meta::TypeConstraint::Role
- Moose::Meta::TypeConstraint::Registry
Moose::Meta::TypeCoercion
Moose::Meta::TypeCoercion::Union
@@ -280,8 +286,7 @@
Moose::Meta::Role::Application::ToClass
Moose::Meta::Role::Application::ToRole
Moose::Meta::Role::Application::ToInstance
- Moose::Meta::Role::Application::ToMetaclassInstance
-));
+);
1;
@@ -325,21 +330,24 @@
The main goal of Moose is to make Perl 5 Object Oriented programming
easier, more consistent and less tedious. With Moose you can to think
-more about what you want to do and less about the mechanics of OOP.
+more about what you want to do and less about the mechanics of OOP.
-Additionally, Moose is built on top of L<Class::MOP>, which is a
-metaclass system for Perl 5. This means that Moose not only makes
-building normal Perl 5 objects better, but it provides the power of
-metaclass programming as well.
+Additionally, Moose is built on top of L<Class::MOP>, which is a
+metaclass system for Perl 5. This means that Moose not only makes
+building normal Perl 5 objects better, but it provides the power of
+metaclass programming as well.
=head2 New to Moose?
-If you're new to Moose, the best place to start is the
-L<Moose::Cookbook>. The recipes on Moose basics will get you up to
-speed with many of Moose's features quickly. Once you have an idea of
-what Moose can do, you can use the API documentation to get more
-detail on features which interest you.
+If you're new to Moose, the best place to start is the L<Moose::Intro>
+docs, followed by the L<Moose::Cookbook>. The intro will show you what
+Moose is, and how it makes Perl 5 OO better.
+The cookbook recipes on Moose basics will get you up to speed with
+many of Moose's features quickly. Once you have an idea of what Moose
+can do, you can use the API documentation to get more detail on
+features which interest you.
+
=head2 Moose Extensions
The C<MooseX::> namespace is the official place to find Moose extensions.
@@ -397,12 +405,13 @@
This will apply a given set of C<@roles> to the local class.
-=item B<has $name =E<gt> %options>
+=item B<has $name|@$names =E<gt> %options>
-This will install an attribute of a given C<$name> into the current class.
-The C<%options> are the same as those provided by
-L<Class::MOP::Attribute>, in addition to the list below which are provided
-by Moose (L<Moose::Meta::Attribute> to be more specific):
+This will install an attribute of a given C<$name> into the current class. If
+the first parameter is an array reference, it will create an attribute for
+every C<$name> in the list. The C<%options> are the same as those provided by
+L<Class::MOP::Attribute>, in addition to the list below which are provided by
+Moose (L<Moose::Meta::Attribute> to be more specific):
=over 4
@@ -412,10 +421,12 @@
only). These will create either a read/write accessor or a read-only
accessor respectively, using the same name as the C<$name> of the attribute.
-If you need more control over how your accessors are named, you can use the
-I<reader>, I<writer> and I<accessor> options inherited from
-L<Class::MOP::Attribute>, however if you use those, you won't need the I<is>
-option.
+If you need more control over how your accessors are named, you can
+use the L<reader|Class::MOP::Attribute/reader>,
+L<writer|Class::MOP::Attribute/writer> and
+L<accessor|Class::MOP::Attribute/accessor> options inherited from
+L<Class::MOP::Attribute>, however if you use those, you won't need the
+I<is> option.
=item I<isa =E<gt> $type_name>
@@ -466,8 +477,12 @@
the attribute is set. The CODE ref will be passed the instance itself, the
updated value and the attribute meta-object (this is for more advanced fiddling
and can typically be ignored). You B<cannot> have a trigger on a read-only
-attribute.
+attribute.
+B<NOTE:> Triggers will only fire when you B<assign> to the attribute,
+either in the constructor, or using the writer. Default and built values will
+B<not> cause the trigger to be fired.
+
=item I<handles =E<gt> ARRAY | HASH | REGEXP | ROLE | CODE>
The I<handles> option provides Moose classes with automated delegation features.
@@ -601,11 +616,58 @@
Also see L<Moose::Cookbook::Meta::Recipe3> for a metaclass trait
example.
+=item I<builder> => Str
+
+The value of this key is the name of the method that will be called to
+obtain the value used to initialize the attribute. See the L<builder
+option docs in Class::MOP::Attribute|Class::MOP::Attribute/builder>
+for more information.
+
+=item I<default> => SCALAR | CODE
+
+The value of this key is the default value which will initialize the attribute.
+
+NOTE: If the value is a simple scalar (string or number), then it can
+be just passed as is. However, if you wish to initialize it with a
+HASH or ARRAY ref, then you need to wrap that inside a CODE reference.
+See the L<default option docs in
+Class::MOP::Attribute|Class::MOP::Attribute/default> for more
+information.
+
+=item I<initializer> => Str
+
+This may be a method name (referring to a method on the class with
+this attribute) or a CODE ref. The initializer is used to set the
+attribute value on an instance when the attribute is set during
+instance initialization (but not when the value is being assigned
+to). See the L<initializer option docs in
+Class::MOP::Attribute|Class::MOP::Attribute/initializer> for more
+information.
+
+=item I<clearer> => Str
+
+Allows you to clear the value, see the L<clearer option docs in
+Class::MOP::Attribute|Class::MOP::Attribute/clearer> for more
+information.
+
+=item I<predicate> => Str
+
+Basic test to see if a value has been set in the attribute, see the
+L<predicate option docs in
+Class::MOP::Attribute|Class::MOP::Attribute/predicate> for more
+information.
+
+=item I<lazy_build> => (0|1)
+
+Automatically define lazy => 1 as well as builder => "_build_$attr", clearer =>
+"clear_$attr', predicate => 'has_$attr' unless they are already defined.
+
+
=back
=item B<has +$name =E<gt> %options>
-This is variation on the normal attibute creator C<has> which allows you to
+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
example of the superclass usage:
@@ -684,7 +746,7 @@
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 descision.
+policy decision.
=item I<handles>
@@ -812,47 +874,11 @@
=head1 EXTENDING AND EMBEDDING MOOSE
-Moose also offers some options for extending or embedding it into your
-own framework. There are several things you might want to do as part
-of such a framework. First, you probably want to export Moose's sugar
-functions (C<has>, C<extends>, etc) for users of the
-framework. Second, you may want to provide additional sugar of your
-own. Third, you may want to provide your own object base class instead
-of L<Moose::Object>, and/or your own metaclass class instead of
-L<Moose::Meta::Class>.
+To learn more about extending Moose, we recommend checking out the
+"Extending" recipes in the L<Moose::Cookbook>, starting with
+L<Moose::Cookbook::Extending::Recipe1>, which provides an overview of
+all the different ways you might extend Moose.
-The exporting needs can be asily satisfied by using
-L<Moose::Exporter>, which is what C<Moose.pm> itself uses for
-exporting. L<Moose::Exporter> lets you "export like Moose".
-
-If you define an C<init_meta> method in a module that uses
-L<Moose::Exporter>, then this method will be called I<before>
-C<Moose.pm>'s own C<init_meta>. This gives you a chance to provide an
-alternate object base class or metaclass class.
-
-Here is a simple example:
-
- package MyFramework;
-
- use strict;
- use warnings;
-
- use Moose (); # no need to get Moose's exports
- use Moose::Exporter;
-
- Moose::Exporter->setup_import_methods( also => 'Moose' );
-
- sub init_meta {
- shift;
- return Moose->init_meta( @_, base_class => 'MyFramework::Base' );
- }
-
-In this example, any class that includes C<use MyFramework> will get
-all of C<Moose.pm>'s sugar functions, and will have their superclass
-set to C<MyFramework::Base>.
-
-Additionally, that class can include C<no MyFramework> to unimport
-
=head2 B<< Moose->init_meta(for_class => $class, base_class => $baseclass, metaclass => $metaclass) >>
The C<init_meta> method sets up the metaclass object for the class
@@ -878,6 +904,60 @@
sanely. It handles getting the exported functions into the right place
for you.
+=head2 B<throw_error>
+
+An alias for C<confess>, used by internally by Moose.
+
+=head1 METACLASS COMPATIBILITY AND MOOSE
+
+Metaclass compatibility is a thorny subject. You should start by
+reading the "About Metaclass compatibility" section in the
+C<Class::MOP> docs.
+
+Moose will attempt to resolve a few cases of metaclass incompatibility
+when you set the superclasses for a class, unlike C<Class::MOP>, which
+simply dies if the metaclasses are incompatible.
+
+In actuality, Moose fixes incompatibility for I<all> of a class's
+metaclasses, not just the class metaclass. That includes the instance
+metaclass, attribute metaclass, as well as its constructor class and
+destructor class. However, for simplicity this discussion will just
+refer to "metaclass", meaning the class metaclass, most of the time.
+
+Moose has two algorithms for fixing metaclass incompatibility.
+
+The first algorithm is very simple. If all the metaclass for the
+parent is a I<subclass> of the child's metaclass, then we simply
+replace the child's metaclass with the parent's.
+
+The second algorithm is more complicated. It tries to determine if the
+metaclasses only "differ by roles". This means that the parent and
+child's metaclass share a common ancestor in their respective
+hierarchies, and that the subclasses under the common ancestor are
+only different because of role applications. This case is actually
+fairly common when you mix and match various C<MooseX::*> modules,
+many of which apply roles to the metaclass.
+
+If the parent and child do differ by roles, Moose replaces the
+metaclass in the child with a newly created metaclass. This metaclass
+is a subclass of the parent's metaclass, does all of the roles that
+the child's metaclass did before being replaced. Effectively, this
+means the new metaclass does all of the roles done by both the
+parent's and child's original metaclasses.
+
+Ultimately, this is all transparent to you except in the case of an
+unresolvable conflict.
+
+=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::>
+and C<DBIx::> namespaces that perform the same function for C<LWP> and C<DBI>
+respectively.
+
=head1 CAVEATS
=over 4
@@ -898,77 +978,8 @@
their behavior is then easier to predict. Time will tell whether I am right or
not (UPDATE: so far so good).
-=item *
-
-It is important to note that we currently have no simple way of combining
-multiple extended versions of Moose (see L<EXTENDING AND EMBEDDING MOOSE> above),
-and that in many cases they will conflict with one another. We are working on
-developing a way around this issue, but in the meantime, you have been warned.
-
=back
-=head1 JUSTIFICATION
-
-In case you are still asking yourself "Why do I need this?", then this
-section is for you. This used to be part of the main DESCRIPTION, but
-I think Moose no longer actually needs justification, so it is included
-(read: buried) here for those who are still not convinced.
-
-=over 4
-
-=item Another object system!?!?
-
-Yes, I know there has been an explosion recently of new ways to
-build objects in Perl 5, most of them based on inside-out objects
-and other such things. Moose is different because it is not a new
-object system for Perl 5, but instead an extension of the existing
-object system.
-
-Moose is built on top of L<Class::MOP>, which is a metaclass system
-for Perl 5. This means that Moose not only makes building normal
-Perl 5 objects better, but it also provides the power of metaclass
-programming.
-
-=item Is this for real? Or is this just an experiment?
-
-Moose is I<based> on the prototypes and experiments I did for the Perl 6
-meta-model. However, Moose is B<NOT> an experiment/prototype; it is for B<real>.
-
-=item Is this ready for use in production?
-
-Yes, I believe that it is.
-
-Moose has been used successfully in production environemnts by several people
-and companies (including the one I work for). There are Moose applications
-which have been in production with little or no issue now for well over two years.
-I consider it highly stable and we are commited to keeping it stable.
-
-Of course, in the end, you need to make this call yourself. If you have
-any questions or concerns, please feel free to email me, or even the list
-or just stop by #moose and ask away.
-
-=item Is Moose just Perl 6 in Perl 5?
-
-No. While Moose is very much inspired by Perl 6, it is not itself Perl 6.
-Instead, it is an OO system for Perl 5. I built Moose because I was tired of
-writing the same old boring Perl 5 OO code, and drooling over Perl 6 OO. So
-instead of switching to Ruby, I wrote Moose :)
-
-=item Wait, I<post> modern, I thought it was just I<modern>?
-
-So I was reading Larry Wall's talk from the 1999 Linux World entitled
-"Perl, the first postmodern computer language" in which he talks about how
-he picked the features for Perl because he thought they were cool and he
-threw out the ones that he thought sucked. This got me thinking about how
-we have done the same thing in Moose. For Moose, we have "borrowed" features
-from Perl 6, CLOS (LISP), Smalltalk, Java, BETA, OCaml, Ruby and more, and
-the bits we didn't like (cause they sucked) we tossed aside. So for this
-reason (and a few others) I have re-dubbed Moose a I<postmodern> object system.
-
-Nuff Said.
-
-=back
-
=head1 ACKNOWLEDGEMENTS
=over 4
@@ -1062,10 +1073,27 @@
=head1 AUTHOR
-Stevan Little E<lt>stevan at iinteractive.comE<gt>
+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.
-B<with contributions from:>
+=head2 CABAL
+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.
+
+Stevan (stevan) Little E<lt>stevan at iinteractive.comE<gt>
+
+Yuval (nothingmuch) Kogman
+
+Shawn (sartak) Moore
+
+Dave (autarch) Rolsky E<lt>autarch at urth.orgE<gt>
+
+=head2 OTHER CONTRIBUTORS
+
Aankhen
Adam (Alias) Kennedy
@@ -1094,8 +1122,6 @@
Shlomi (rindolf) Fish
-Yuval (nothingmuch) Kogman
-
Chris (perigrin) Prather
Wallace (wreis) Reis
@@ -1106,7 +1132,7 @@
Sam (mugwump) Vilain
-Shawn (sartak) Moore
+Cory (gphat) Watson
... and many other #moose folks
Modified: Moose/branches/Moose-XS/lib/Test/Moose.pm
===================================================================
--- Moose/branches/Moose-XS/lib/Test/Moose.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/Test/Moose.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -8,7 +8,7 @@
use Moose::Util 'does_role', 'find_meta';
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
Modified: Moose/branches/Moose-XS/lib/oose.pm
===================================================================
--- Moose/branches/Moose-XS/lib/oose.pm 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/lib/oose.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -5,7 +5,7 @@
use Class::MOP;
-our $VERSION = '0.55_01';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -49,7 +49,7 @@
=head1 INTERFACE
-oose provides exactly one method and it's automically called by perl:
+oose provides exactly one method and it's automatically called by perl:
=over 4
Modified: Moose/branches/Moose-XS/t/000_recipes/extending/001_base_class.t
===================================================================
--- Moose/branches/Moose-XS/t/000_recipes/extending/001_base_class.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/000_recipes/extending/001_base_class.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -7,8 +7,8 @@
use Test::Exception;
BEGIN {
- unless ( eval 'use Test::Warn; 1' ) {
- plan skip_all => 'These tests require Test::Warn';
+ unless ( eval 'use Test::Warn 0.10; 1' ) {
+ plan skip_all => 'These tests require Test::Warn 0.10+';
}
else {
plan tests => 4;
Modified: Moose/branches/Moose-XS/t/010_basics/009_import_unimport.t
===================================================================
--- Moose/branches/Moose-XS/t/010_basics/009_import_unimport.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/010_basics/009_import_unimport.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -3,10 +3,9 @@
use strict;
use warnings;
-use Test::More tests => 46;
+use Test::More tests => 41;
-
my @moose_exports = qw(
extends with
has
@@ -14,27 +13,24 @@
override
augment
super inner
- make_immutable
);
{
package Foo;
+
+ eval 'use Moose';
+ die $@ if $@;
}
-eval q{
- package Foo;
- use Moose;
-};
-ok(!$@, '... Moose succesfully exported into Foo');
-
can_ok('Foo', $_) for @moose_exports;
-eval q{
+{
package Foo;
- no Moose;
-};
-ok(!$@, '... Moose succesfully un-exported from Foo');
+ eval 'no Moose';
+ die $@ if $@;
+}
+
ok(!Foo->can($_), '... Foo can no longer do ' . $_) for @moose_exports;
# and check the type constraints as well
@@ -48,21 +44,30 @@
{
package Bar;
+
+ eval 'use Moose::Util::TypeConstraints';
+ die $@ if $@;
}
-eval q{
- package Bar;
- use Moose::Util::TypeConstraints;
-};
-ok(!$@, '... Moose::Util::TypeConstraints succesfully exported into Bar');
-
can_ok('Bar', $_) for @moose_type_constraint_exports;
-eval q{
+{
package Bar;
- no Moose::Util::TypeConstraints;
-};
-ok(!$@, '... Moose::Util::TypeConstraints succesfully un-exported from Bar');
+ eval 'no Moose::Util::TypeConstraints';
+ die $@ if $@;
+}
+
ok(!Bar->can($_), '... Bar can no longer do ' . $_) for @moose_type_constraint_exports;
+
+{
+ package Baz;
+
+ use Scalar::Util qw( blessed );
+ use Moose;
+
+ no Moose;
+}
+
+can_ok( 'Baz', 'blessed' );
Added: Moose/branches/Moose-XS/t/010_basics/017_error_handling.t
===================================================================
--- Moose/branches/Moose-XS/t/010_basics/017_error_handling.t (rev 0)
+++ Moose/branches/Moose-XS/t/010_basics/017_error_handling.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,20 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+use Test::Exception;
+
+# This tests the error handling in Moose::Object only
+
+{
+ package Foo;
+ use Moose;
+}
+
+throws_ok { Foo->new('bad') } qr/^\QSingle parameters to new() must be a HASH ref/,
+ 'A single non-hashref arg to a constructor throws an error';
+
+throws_ok { Foo->does() } qr/^\QYou much supply a role name to does()/,
+ 'Cannot call does() without a role name';
Added: Moose/branches/Moose-XS/t/010_basics/018_methods.t
===================================================================
--- Moose/branches/Moose-XS/t/010_basics/018_methods.t (rev 0)
+++ Moose/branches/Moose-XS/t/010_basics/018_methods.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,44 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 6;
+
+
+my $test1 = Moose::Meta::Class->create_anon_class;
+$test1->add_method( 'foo1', sub { } );
+
+my $t1 = $test1->new_object;
+my $t1_am = $t1->meta->get_method('foo1')->associated_metaclass;
+
+ok( $t1_am, 'associated_metaclass is defined' );
+
+isa_ok(
+ $t1_am, 'Moose::Meta::Class',
+ 'associated_metaclass is correct class'
+);
+
+like( $t1_am->name(), qr/::__ANON__::/,
+ 'associated_metaclass->name looks like an anonymous class' );
+
+{
+ package Test2;
+
+ use Moose;
+
+ sub foo2 { }
+}
+
+my $t2 = Test2->new;
+my $t2_am = $t2->meta->get_method('foo2')->associated_metaclass;
+
+ok( $t2_am, 'associated_metaclass is defined' );
+
+isa_ok(
+ $t2_am, 'Moose::Meta::Class',
+ 'associated_metaclass is correct class'
+);
+
+is( $t2_am->name(), 'Test2',
+ 'associated_metaclass->name is Test2' );
Modified: Moose/branches/Moose-XS/t/020_attributes/004_attribute_triggers.t
===================================================================
--- Moose/branches/Moose-XS/t/020_attributes/004_attribute_triggers.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/020_attributes/004_attribute_triggers.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -5,7 +5,7 @@
use Scalar::Util 'isweak';
-use Test::More tests => 25;
+use Test::More tests => 36;
use Test::Exception;
@@ -115,4 +115,46 @@
} '... a trigger must be a CODE ref';
}
+# Triggers do not fire on built values
+{
+ package Blarg;
+ use Moose;
+
+ our %trigger_calls;
+ our %trigger_vals;
+ has foo => (is => 'rw', default => sub { 'default foo value' },
+ trigger => sub { my ($self, $val, $attr) = @_;
+ $trigger_calls{foo}++;
+ $trigger_vals{foo} = $val });
+ has bar => (is => 'rw', lazy_build => 1,
+ trigger => sub { my ($self, $val, $attr) = @_;
+ $trigger_calls{bar}++;
+ $trigger_vals{bar} = $val });
+ sub _build_bar { return 'default bar value' }
+ has baz => (is => 'rw', builder => '_build_baz',
+ trigger => sub { my ($self, $val, $attr) = @_;
+ $trigger_calls{baz}++;
+ $trigger_vals{baz} = $val });
+ sub _build_baz { return 'default baz value' }
+}
+
+{
+ my $blarg;
+ lives_ok { $blarg = Blarg->new; } 'Blarg->new() lives';
+ ok($blarg, 'Have a $blarg');
+ foreach my $attr (qw/foo bar baz/) {
+ is($blarg->$attr(), "default $attr value", "$attr has default value");
+ }
+ is_deeply(\%Blarg::trigger_calls, {}, 'No triggers fired');
+ foreach my $attr (qw/foo bar baz/) {
+ $blarg->$attr("Different $attr value");
+ }
+ is_deeply(\%Blarg::trigger_calls, { map { $_ => 1 } qw/foo bar baz/ }, 'All triggers fired once on assign');
+ is_deeply(\%Blarg::trigger_vals, { map { $_ => "Different $_ value" } qw/foo bar baz/ }, 'All triggers given assigned values');
+
+ lives_ok { $blarg => Blarg->new( map { $_ => "Yet another $_ value" } qw/foo bar baz/ ) } '->new() with parameters';
+ is_deeply(\%Blarg::trigger_calls, { map { $_ => 2 } qw/foo bar baz/ }, 'All triggers fired once on construct');
+ is_deeply(\%Blarg::trigger_vals, { map { $_ => "Yet another $_ value" } qw/foo bar baz/ }, 'All triggers given assigned values');
+}
+
Modified: Moose/branches/Moose-XS/t/020_attributes/009_attribute_inherited_slot_specs.t
===================================================================
--- Moose/branches/Moose-XS/t/020_attributes/009_attribute_inherited_slot_specs.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/020_attributes/009_attribute_inherited_slot_specs.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 82;
+use Test::More tests => 83;
use Test::Exception;
@@ -100,6 +100,9 @@
::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 $foo = Foo->new;
Modified: Moose/branches/Moose-XS/t/020_attributes/010_attribute_delegation.t
===================================================================
--- Moose/branches/Moose-XS/t/020_attributes/010_attribute_delegation.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/020_attributes/010_attribute_delegation.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 84;
+use Test::More tests => 88;
use Test::Exception;
@@ -37,6 +37,11 @@
ok($bar->foo, '... we have something in bar->foo');
isa_ok($bar->foo, 'Foo');
+my $meth = Bar->meta->get_method('foo_bar');
+isa_ok($meth, 'Moose::Meta::Method::Delegation');
+is($meth->associated_attribute->name, 'foo',
+ 'associated_attribute->name for this method is foo');
+
is($bar->foo->bar, 10, '... bar->foo->bar returned the right default');
can_ok($bar, 'foo_bar');
@@ -387,3 +392,21 @@
is($baz->foo->bar, 25, '... baz->foo->bar returned the right result');
is($baz->bar, 25, '... and baz->foo_bar delegated correctly again');
}
+
+# Check that removing attributes removes their handles methods also.
+{
+ {
+ package Quux;
+ use Moose;
+ has foo => (
+ isa => 'Foo',
+ default => sub { Foo->new },
+ handles => { 'foo_bar' => 'bar' }
+ );
+ }
+ my $i = Quux->new;
+ ok($i->meta->has_method('foo_bar'), 'handles method foo_bar is present');
+ $i->meta->remove_attribute('foo');
+ ok(!$i->meta->has_method('foo_bar'), 'handles method foo_bar is removed');
+}
+
Added: Moose/branches/Moose-XS/t/020_attributes/023_attribute_names.t
===================================================================
--- Moose/branches/Moose-XS/t/020_attributes/023_attribute_names.t (rev 0)
+++ Moose/branches/Moose-XS/t/020_attributes/023_attribute_names.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,29 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More tests => 8;
+use Test::Exception;
+
+# note: not sure about "" and 0 being illegal attribute names
+# but I'm just copying what Class::MOP::Attribute does
+
+my $exception_regex = qr/You must provide a name for the attribute/;
+{
+ package My::Role;
+ use Moose::Role;
+ ::throws_ok{ has; } $exception_regex, 'has; fails';
+ ::throws_ok{ has undef; } $exception_regex, 'has undef; fails';
+ ::throws_ok{ has ""; } $exception_regex, 'has ""; fails';
+ ::throws_ok{ has 0; } $exception_regex, 'has 0; fails';
+}
+
+{
+ package My::Class;
+ use Moose;
+ ::throws_ok{ has; } $exception_regex, 'has; fails';
+ ::throws_ok{ has undef; } $exception_regex, 'has undef; fails';
+ ::throws_ok{ has ""; } $exception_regex, 'has ""; fails';
+ ::throws_ok{ has 0; } $exception_regex, 'has 0; fails';
+}
+
Added: Moose/branches/Moose-XS/t/020_attributes/024_attribute_traits_parameterized.t
===================================================================
--- Moose/branches/Moose-XS/t/020_attributes/024_attribute_traits_parameterized.t (rev 0)
+++ Moose/branches/Moose-XS/t/020_attributes/024_attribute_traits_parameterized.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,53 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 4;
+
+{
+ package My::Attribute::Trait;
+ use Moose::Role;
+
+ sub reversed_name {
+ my $self = shift;
+ scalar reverse $self->name;
+ }
+}
+
+{
+ package My::Class;
+ use Moose;
+
+ has foo => (
+ traits => [
+ 'My::Attribute::Trait' => {
+ alias => {
+ reversed_name => 'eman',
+ },
+ },
+ ],
+ );
+}
+
+{
+ package My::Other::Class;
+ use Moose;
+
+ has foo => (
+ traits => [
+ 'My::Attribute::Trait' => {
+ alias => {
+ reversed_name => 'reversed',
+ },
+ },
+ ],
+ );
+}
+
+my $attr = My::Class->meta->get_attribute('foo');
+is($attr->eman, 'oof', 'the aliased method is in the attribute');
+ok(!$attr->can('reversed'), "the method was not installed under the other class' alias");
+
+my $other_attr = My::Other::Class->meta->get_attribute('foo');
+is($other_attr->reversed, 'oof', 'the aliased method is in the attribute');
+ok(!$other_attr->can('enam'), "the method was not installed under the other class' alias");
+
Modified: Moose/branches/Moose-XS/t/030_roles/004_role_composition_errors.t
===================================================================
--- Moose/branches/Moose-XS/t/030_roles/004_role_composition_errors.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/030_roles/004_role_composition_errors.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -3,86 +3,157 @@
use strict;
use warnings;
-use Test::More tests => 10;
+use Test::More tests => 14;
use Test::Exception;
{
+
package Foo::Role;
use Moose::Role;
-
+
requires 'foo';
}
is_deeply(
[ sort Foo::Role->meta->get_required_method_list ],
- [ 'foo' ],
- '... the Foo::Role has a required method (foo)');
+ ['foo'],
+ '... the Foo::Role has a required method (foo)'
+);
# classes which does not implement required method
{
+
package Foo::Class;
use Moose;
-
- ::dies_ok { with('Foo::Role') } '... no foo method implemented by Foo::Class';
+
+ ::dies_ok { with('Foo::Role') }
+ '... no foo method implemented by Foo::Class';
}
# class which does implement required method
{
+
package Bar::Class;
use Moose;
-
- ::dies_ok { with('Foo::Class') } '... cannot consume a class, it must be a role';
- ::lives_ok { with('Foo::Role') } '... has a foo method implemented by Bar::Class';
-
- sub foo { 'Bar::Class::foo' }
+
+ ::dies_ok { with('Foo::Class') }
+ '... cannot consume a class, it must be a role';
+ ::lives_ok { with('Foo::Role') }
+ '... has a foo method implemented by Bar::Class';
+
+ sub foo {'Bar::Class::foo'}
}
# role which does implement required method
{
+
package Bar::Role;
use Moose::Role;
-
- ::lives_ok { with('Foo::Role') } '... has a foo method implemented by Bar::Role';
-
- sub foo { 'Bar::Role::foo' }
+
+ ::lives_ok { with('Foo::Role') }
+ '... has a foo method implemented by Bar::Role';
+
+ sub foo {'Bar::Role::foo'}
}
is_deeply(
[ sort Bar::Role->meta->get_required_method_list ],
[],
- '... the Bar::Role has not inherited the required method from Foo::Role');
+ '... the Bar::Role has not inherited the required method from Foo::Role'
+);
# role which does not implement required method
{
+
package Baz::Role;
use Moose::Role;
-
- ::lives_ok { with('Foo::Role') } '... no foo method implemented by Baz::Role';
+
+ ::lives_ok { with('Foo::Role') }
+ '... no foo method implemented by Baz::Role';
}
is_deeply(
[ sort Baz::Role->meta->get_required_method_list ],
- [ 'foo' ],
- '... the Baz::Role has inherited the required method from Foo::Role');
-
+ ['foo'],
+ '... the Baz::Role has inherited the required method from Foo::Role'
+);
+
# classes which does not implement required method
{
+
package Baz::Class;
use Moose;
- ::dies_ok { with('Baz::Role') } '... no foo method implemented by Baz::Class2';
+ ::dies_ok { with('Baz::Role') }
+ '... no foo method implemented by Baz::Class2';
}
# class which does implement required method
{
+
package Baz::Class2;
use Moose;
- ::lives_ok { with('Baz::Role') } '... has a foo method implemented by Baz::Class2';
+ ::lives_ok { with('Baz::Role') }
+ '... has a foo method implemented by Baz::Class2';
- sub foo { 'Baz::Class2::foo' }
-}
-
+ sub foo {'Baz::Class2::foo'}
+}
+
+{
+ package Quux::Role;
+ use Moose::Role;
+
+ requires qw( meth1 meth2 meth3 meth4 );
+}
+
+# RT #41119
+{
+
+ package Quux::Class;
+ use Moose;
+
+ ::throws_ok { with('Quux::Role') }
+ qr/\Q'Quux::Role' requires the methods 'meth1', 'meth2', 'meth3', and 'meth4' to be implemented by 'Quux::Class'/,
+ 'exception mentions all the missing required methods at once';
+}
+
+{
+ package Quux::Class2;
+ use Moose;
+
+ sub meth1 { }
+
+ ::throws_ok { with('Quux::Role') }
+ qr/'Quux::Role' requires the methods 'meth2', 'meth3', and 'meth4' to be implemented by 'Quux::Class2'/,
+ 'exception mentions all the missing required methods at once, but not the one that exists';
+}
+
+{
+ package Quux::Class3;
+ use Moose;
+
+ has 'meth1' => ( is => 'ro' );
+ has 'meth2' => ( is => 'ro' );
+
+ ::throws_ok { with('Quux::Role') }
+ qr/\Q'Quux::Role' requires the methods 'meth3' and 'meth4' to be implemented by 'Quux::Class3'\E\n
+ \Q'Quux::Role' requires the methods 'meth1' and 'meth2' to be implemented by 'Quux::Class3' but the method is only an attribute accessor/x,
+ 'exception mentions all the require methods that are accessors at once, as well as missing methods';
+}
+
+{
+ package Quux::Class4;
+ use Moose;
+
+ sub meth1 { }
+ has 'meth2' => ( is => 'ro' );
+
+ ::throws_ok { with('Quux::Role') }
+ qr/\Q'Quux::Role' requires the methods 'meth3' and 'meth4' to be implemented by 'Quux::Class4'\E\n
+ \Q'Quux::Role' requires the method 'meth2' to be implemented by 'Quux::Class4' but the method is only an attribute accessor/x,
+ 'exception mentions all the require methods that are accessors at once, as well as missing methods, but not the one that exists';
+}
Modified: Moose/branches/Moose-XS/t/030_roles/006_role_exclusion.t
===================================================================
--- Moose/branches/Moose-XS/t/030_roles/006_role_exclusion.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/030_roles/006_role_exclusion.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -62,7 +62,7 @@
::throws_ok {
with 'Molecule::Organic', 'Molecule::Inorganic';
- } qr/Conflict detected: .+ excludes role \'Molecule::Inorganic\'/,
+ } qr/Conflict detected: Role Molecule::Organic excludes role 'Molecule::Inorganic'/,
'... adding the role w/ excluded role conflict dies okay';
package My::Test3;
Modified: Moose/branches/Moose-XS/t/030_roles/017_extending_role_attrs.t
===================================================================
--- Moose/branches/Moose-XS/t/030_roles/017_extending_role_attrs.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/030_roles/017_extending_role_attrs.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -99,7 +99,7 @@
$baz->baz('Foo');
is($baz->baz, 'Foo', "... can change the attribute's value to a ClassName");
-throws_ok { $baz->baz("zonk") } qr/^Attribute \(baz\) does not pass the type constraint because: Validation failed for 'Int \| ClassName' failed with value zonk at /;
+throws_ok { $baz->baz("zonk") } qr/^Attribute \(baz\) does not pass the type constraint because: Validation failed for 'ClassName\|Int' failed with value zonk at /;
is_deeply($baz->baz, 'Foo', "... still has the old ClassName value");
@@ -137,10 +137,10 @@
$quux->quux(["hi"]);
is_deeply($quux->quux, ["hi"], "... can change the attribute's value to an ArrayRef");
-throws_ok { $quux->quux("quux") } qr/^Attribute \(quux\) does not pass the type constraint because: Validation failed for 'Positive \| ArrayRef' failed with value quux at /;
+throws_ok { $quux->quux("quux") } qr/^Attribute \(quux\) does not pass the type constraint because: Validation failed for 'ArrayRef\|Positive' failed with value quux at /;
is_deeply($quux->quux, ["hi"], "... still has the old ArrayRef value");
-throws_ok { $quux->quux({a => 1}) } qr/^Attribute \(quux\) does not pass the type constraint because: Validation failed for 'Positive \| ArrayRef' failed with value HASH\(\w+\) at /;
+throws_ok { $quux->quux({a => 1}) } qr/^Attribute \(quux\) does not pass the type constraint because: Validation failed for 'ArrayRef\|Positive' failed with value HASH\(\w+\) at /;
is_deeply($quux->quux, ["hi"], "... still has the old ArrayRef value");
Deleted: Moose/branches/Moose-XS/t/030_roles/030_role_parameterized.t
===================================================================
--- Moose/branches/Moose-XS/t/030_roles/030_role_parameterized.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/030_roles/030_role_parameterized.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -1,37 +0,0 @@
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More skip_all => 'The feature this test exercises is not yet written';
-use Test::Exception;
-
-
-{
- package Scalar;
- use Moose::Role;
-
- BEGIN { parameter T => { isa => 'Moose::Meta::TypeConstraint' } };
-
- has 'val' => (is => 'ro', isa => T);
-
- requires 'eq';
-
- sub not_eq { ! (shift)->eq(shift) }
-}
-
-is_deeply(
- Scalar->meta->parameters,
- { T => { isa => 'Moose::Meta::TypeConstraint' } },
- '... got the right parameters in the role'
-);
-
-{
- package Integers;
- use Moose;
- use Moose::Util::TypeConstraints;
-
- with Scalar => { T => find_type_constraint('Int') };
-
- sub eq { shift == shift }
-}
Added: Moose/branches/Moose-XS/t/030_roles/031_roles_applied_in_create.t
===================================================================
--- Moose/branches/Moose-XS/t/030_roles/031_roles_applied_in_create.t (rev 0)
+++ Moose/branches/Moose-XS/t/030_roles/031_roles_applied_in_create.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,27 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 1;
+use Test::Exception;
+use Moose::Meta::Class;
+use Moose::Util;
+
+use lib 't/lib', 'lib';
+
+
+# Note that this test passed (pre svn #5543) if we inlined the role
+# definitions in this file, as it was very timing sensitive.
+lives_ok(
+ sub {
+ my $builder_meta = Moose::Meta::Class->create(
+ 'YATTA' => (
+ superclass => 'Moose::Meta::Class',
+ roles => [qw( Role::Interface Role::Child )],
+ )
+ );
+ },
+ 'Create a new class with several roles'
+);
+
Added: Moose/branches/Moose-XS/t/030_roles/032_roles_and_method_cloning.t
===================================================================
--- Moose/branches/Moose-XS/t/030_roles/032_roles_and_method_cloning.t (rev 0)
+++ Moose/branches/Moose-XS/t/030_roles/032_roles_and_method_cloning.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,72 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 14;
+
+
+{
+ package Role::Foo;
+ use Moose::Role;
+
+ sub foo { }
+}
+
+{
+ package ClassA;
+ use Moose;
+
+ with 'Role::Foo';
+}
+
+{
+ my $meth = ClassA->meta->get_method('foo');
+ ok( $meth, 'ClassA has a foo method' );
+ isa_ok( $meth, 'Moose::Meta::Method' );
+ is( $meth->original_method, Role::Foo->meta->get_method('foo'),
+ 'ClassA->foo was cloned from Role::Foo->foo' );
+ is( $meth->fully_qualified_name, 'ClassA::foo',
+ 'fq name is ClassA::foo' );
+ is( $meth->original_fully_qualified_name, 'Role::Foo::foo',
+ 'original fq name is Role::Foo::foo' );
+}
+
+{
+ package Role::Bar;
+ use Moose::Role;
+ with 'Role::Foo';
+
+ sub bar { }
+}
+
+{
+ my $meth = Role::Bar->meta->get_method('foo');
+ ok( $meth, 'Role::Bar has a foo method' );
+ is( $meth->original_method, Role::Foo->meta->get_method('foo'),
+ 'Role::Bar->foo was cloned from Role::Foo->foo' );
+ is( $meth->fully_qualified_name, 'Role::Bar::foo',
+ 'fq name is Role::Bar::foo' );
+ is( $meth->original_fully_qualified_name, 'Role::Foo::foo',
+ 'original fq name is Role::Foo::foo' );
+}
+
+{
+ package ClassB;
+ use Moose;
+
+ with 'Role::Bar';
+}
+
+{
+ my $meth = ClassB->meta->get_method('foo');
+ ok( $meth, 'ClassB has a foo method' );
+ is( $meth->original_method, Role::Bar->meta->get_method('foo'),
+ 'ClassA->foo was cloned from Role::Bar->foo' );
+ is( $meth->original_method->original_method, Role::Foo->meta->get_method('foo'),
+ '... which in turn was cloned from Role::Foo->foo' );
+ is( $meth->fully_qualified_name, 'ClassB::foo',
+ 'fq name is ClassA::foo' );
+ is( $meth->original_fully_qualified_name, 'Role::Foo::foo',
+ 'original fq name is Role::Foo::foo' );
+}
Added: Moose/branches/Moose-XS/t/030_roles/033_role_exclusion_and_alias_bug.t
===================================================================
--- Moose/branches/Moose-XS/t/030_roles/033_role_exclusion_and_alias_bug.t (rev 0)
+++ Moose/branches/Moose-XS/t/030_roles/033_role_exclusion_and_alias_bug.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,69 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 17;
+use Test::Moose;
+
+{
+ package My::Role;
+ use Moose::Role;
+
+ sub foo { "FOO" }
+ sub bar { "BAR" }
+}
+
+{
+ package My::Class;
+ use Moose;
+
+ with 'My::Role' => {
+ alias => { foo => 'baz', bar => 'gorch' },
+ excludes => ['foo', 'bar'],
+ };
+}
+
+{
+ my $x = My::Class->new;
+ isa_ok($x, 'My::Class');
+ does_ok($x, 'My::Role');
+
+ can_ok($x, $_) for qw[baz gorch];
+
+ ok(!$x->can($_), '... cant call method ' . $_) for qw[foo bar];
+
+ is($x->baz, 'FOO', '... got the right value');
+ is($x->gorch, 'BAR', '... got the right value');
+}
+
+{
+ package My::Role::Again;
+ use Moose::Role;
+
+ with 'My::Role' => {
+ alias => { foo => 'baz', bar => 'gorch' },
+ excludes => ['foo', 'bar'],
+ };
+
+ package My::Class::Again;
+ use Moose;
+
+ with 'My::Role::Again';
+}
+
+{
+ my $x = My::Class::Again->new;
+ isa_ok($x, 'My::Class::Again');
+ does_ok($x, 'My::Role::Again');
+ does_ok($x, 'My::Role');
+
+ can_ok($x, $_) for qw[baz gorch];
+
+ ok(!$x->can($_), '... cant call method ' . $_) for qw[foo bar];
+
+ is($x->baz, 'FOO', '... got the right value');
+ is($x->gorch, 'BAR', '... got the right value');
+}
+
+
Added: Moose/branches/Moose-XS/t/030_roles/034_create_role.t
===================================================================
--- Moose/branches/Moose-XS/t/030_roles/034_create_role.t (rev 0)
+++ Moose/branches/Moose-XS/t/030_roles/034_create_role.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,32 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 4;
+use Moose ();
+
+my $role = Moose::Meta::Role->create(
+ 'MyItem::Role::Equipment',
+ attributes => {
+ is_worn => {
+ is => 'rw',
+ isa => 'Bool',
+ },
+ },
+ methods => {
+ remove => sub { shift->is_worn(0) },
+ },
+);
+
+my $class = Moose::Meta::Class->create('MyItem::Armor::Helmet' =>
+ roles => ['MyItem::Role::Equipment'],
+);
+
+my $visored = $class->construct_instance(is_worn => 0);
+ok(!$visored->is_worn, "attribute, accessor was consumed");
+$visored->is_worn(1);
+ok($visored->is_worn, "accessor was consumed");
+$visored->remove;
+ok(!$visored->is_worn, "method was consumed");
+
+ok(!$role->is_anon_role, "the role is not anonymous");
+
Added: Moose/branches/Moose-XS/t/030_roles/035_anonymous_roles.t
===================================================================
--- Moose/branches/Moose-XS/t/030_roles/035_anonymous_roles.t (rev 0)
+++ Moose/branches/Moose-XS/t/030_roles/035_anonymous_roles.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,35 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 7;
+use Moose ();
+
+my $role = Moose::Meta::Role->create_anon_role(
+ attributes => {
+ is_worn => {
+ is => 'rw',
+ isa => 'Bool',
+ },
+ },
+ methods => {
+ remove => sub { shift->is_worn(0) },
+ },
+);
+
+my $class = Moose::Meta::Class->create('MyItem::Armor::Helmet');
+$role->apply($class);
+# XXX: Moose::Util::apply_all_roles doesn't cope with references yet
+
+my $visored = $class->construct_instance(is_worn => 0);
+ok(!$visored->is_worn, "attribute, accessor was consumed");
+$visored->is_worn(1);
+ok($visored->is_worn, "accessor was consumed");
+$visored->remove;
+ok(!$visored->is_worn, "method was consumed");
+
+like($role->name, qr/^Moose::Meta::Role::__ANON__::SERIAL::\d+$/, "");
+ok($role->is_anon_role, "the role knows it's anonymous");
+
+ok(Class::MOP::is_class_loaded(Moose::Meta::Role->create_anon_role->name), "creating an anonymous role satisifes is_class_loaded");
+ok(Class::MOP::load_class(Moose::Meta::Role->create_anon_role->name), "creating an anonymous role satisifes load_class");
+
Added: Moose/branches/Moose-XS/t/030_roles/036_free_anonymous_roles.t
===================================================================
--- Moose/branches/Moose-XS/t/030_roles/036_free_anonymous_roles.t (rev 0)
+++ Moose/branches/Moose-XS/t/030_roles/036_free_anonymous_roles.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,34 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 4;
+use Moose ();
+use Scalar::Util 'weaken';
+
+my $weak;
+my $name;
+do {
+ my $anon_class;
+
+ do {
+ my $role = Moose::Meta::Role->create_anon_role(
+ methods => {
+ improperly_freed => sub { 1 },
+ },
+ );
+ weaken($weak = $role);
+
+ $name = $role->name;
+
+ $anon_class = Moose::Meta::Class->create_anon_class(
+ roles => [ $role->name ],
+ );
+ };
+
+ ok($weak, "we still have the role metaclass because the anonymous class that consumed it is still alive");
+ ok($name->can('improperly_freed'), "we have not blown away the role's symbol table");
+};
+
+ok(!$weak, "the role metaclass is freed after its last reference (from a consuming anonymous class) is freed");
+
+ok(!$name->can('improperly_freed'), "we blew away the role's symbol table entries");
Added: Moose/branches/Moose-XS/t/030_roles/037_create_role_subclass.t
===================================================================
--- Moose/branches/Moose-XS/t/030_roles/037_create_role_subclass.t (rev 0)
+++ Moose/branches/Moose-XS/t/030_roles/037_create_role_subclass.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,26 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 2;
+use Moose ();
+
+do {
+ package My::Meta::Role;
+ use Moose;
+ extends 'Moose::Meta::Role';
+
+ has test_serial => (
+ is => 'ro',
+ isa => 'Int',
+ default => 1,
+ );
+
+ no Moose;
+};
+
+my $role = My::Meta::Role->create_anon_role;
+is($role->test_serial, 1, "default value for the serial attribute");
+
+my $nine_role = My::Meta::Role->create_anon_role(test_serial => 9);
+is($nine_role->test_serial, 9, "parameter value for the serial attribute");
+
Modified: Moose/branches/Moose-XS/t/040_type_constraints/001_util_type_constraints.t
===================================================================
--- Moose/branches/Moose-XS/t/040_type_constraints/001_util_type_constraints.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/040_type_constraints/001_util_type_constraints.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -3,29 +3,28 @@
use strict;
use warnings;
-use Test::More tests => 44;
+use Test::More tests => 52;
use Test::Exception;
use Scalar::Util ();
-BEGIN {
- use_ok('Moose::Util::TypeConstraints');
-}
+use Moose::Util::TypeConstraints;
+
type Number => where { Scalar::Util::looks_like_number($_) };
type String
=> where { !ref($_) && !Number($_) }
=> message { "This is not a string ($_)" };
subtype Natural
- => as Number
- => where { $_ > 0 };
+ => as Number
+ => where { $_ > 0 };
subtype NaturalLessThanTen
- => as Natural
- => where { $_ < 10 }
- => message { "The number '$_' is not less than 10" };
-
+ => 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');
@@ -46,10 +45,10 @@
is(NaturalLessThanTen(12), undef, '... this is not a NaturalLessThanTen');
is(NaturalLessThanTen(-5), undef, '... this is not a NaturalLessThanTen');
is(NaturalLessThanTen('Foo'), undef, '... this is not a NaturalLessThanTen');
-
-# anon sub-typing
-
-my $negative = subtype Number => where { $_ < 0 };
+
+# anon sub-typing
+
+my $negative = subtype Number => where { $_ < 0 };
ok(defined $negative, '... got a value back from negative');
isa_ok($negative, 'Moose::Meta::TypeConstraint');
@@ -60,6 +59,23 @@
ok($negative->is_subtype_of('Number'), '... $negative is a subtype of Number');
ok(!$negative->is_subtype_of('String'), '... $negative is not a subtype of String');
+my $negative2 = subtype Number => where { $_ < 0 } => message {"$_ is not a negative number"};
+
+ok(defined $negative2, '... got a value back from negative');
+isa_ok($negative2, 'Moose::Meta::TypeConstraint');
+
+ok($negative2->check(-5), '... this is a negative number');
+ok(!defined($negative2->check(5)), '... this is not a negative number');
+is($negative2->check('Foo'), undef, '... this is not a negative number');
+
+ok($negative2->is_subtype_of('Number'), '... $negative2 is a subtype of Number');
+ok(!$negative2->is_subtype_of('String'), '... $negative is not a subtype of String');
+
+ok($negative2->has_message, '... it has a message');
+is($negative2->validate(2),
+ '2 is not a negative number',
+ '... validated unsuccessfully (got error)');
+
# check some meta-details
my $natural_less_than_ten = find_type_constraint('NaturalLessThanTen');
Modified: Moose/branches/Moose-XS/t/040_type_constraints/008_union_types.t
===================================================================
--- Moose/branches/Moose-XS/t/040_type_constraints/008_union_types.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/040_type_constraints/008_union_types.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 33;
+use Test::More tests => 35;
use Test::Exception;
BEGIN {
@@ -35,6 +35,9 @@
ok( $Str_or_Undef->equals(Moose::Meta::TypeConstraint::Union->new(type_constraints => [ $Str, $Undef ])), "equal to clone" );
ok( $Str_or_Undef->equals(Moose::Meta::TypeConstraint::Union->new(type_constraints => [ $Undef, $Str ])), "equal to reversed clone" );
+ok( !$Str_or_Undef->is_a_type_of("ThisTypeDoesNotExist"), "not type of non existant type" );
+ok( !$Str_or_Undef->is_subtype_of("ThisTypeDoesNotExist"), "not subtype of non existant type" );
+
# another ....
my $ArrayRef = find_type_constraint('ArrayRef');
@@ -64,14 +67,14 @@
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\)/,
+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\)/,
+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');
Modified: Moose/branches/Moose-XS/t/040_type_constraints/010_misc_type_tests.t
===================================================================
--- Moose/branches/Moose-XS/t/040_type_constraints/010_misc_type_tests.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/040_type_constraints/010_misc_type_tests.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 3;
+use Test::More tests => 8;
use Test::Exception;
BEGIN {
@@ -17,4 +17,33 @@
} '... create bare subtype fine';
my $numb3rs = find_type_constraint('Numb3rs');
-isa_ok($numb3rs, 'Moose::Meta::TypeConstraint');
\ No newline at end of file
+isa_ok($numb3rs, 'Moose::Meta::TypeConstraint');
+
+# subtype with unions
+
+{
+ package Test::Moose::Meta::TypeConstraint::Union;
+
+ use overload '""' => sub {'Broken|Test'}, fallback => 1;
+ use Moose;
+
+ extends 'Moose::Meta::TypeConstraint';
+}
+
+my $dummy_instance = Test::Moose::Meta::TypeConstraint::Union->new;
+
+ok $dummy_instance => "Created Instance";
+
+isa_ok $dummy_instance,
+ 'Test::Moose::Meta::TypeConstraint::Union' => 'isa correct type';
+
+is "$dummy_instance", "Broken|Test" =>
+ 'Got expected stringification result';
+
+my $subtype1 = subtype 'New1' => as $dummy_instance;
+
+ok $subtype1 => 'made a subtype from our type object';
+
+my $subtype2 = subtype 'New2' => as $subtype1;
+
+ok $subtype2 => 'made a subtype of our subtype';
Modified: Moose/branches/Moose-XS/t/040_type_constraints/015_enum.t
===================================================================
--- Moose/branches/Moose-XS/t/040_type_constraints/015_enum.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/040_type_constraints/015_enum.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -31,7 +31,7 @@
plan tests => @valid_letters + @invalid_letters
+ @valid_languages + @invalid_languages
+ @valid_metacharacters + @invalid_metacharacters
- + @valid_languages + 6;
+ + @valid_languages + 10;
Moose::Util::TypeConstraints->export_type_constraints_as_functions();
@@ -59,3 +59,10 @@
ok( !$anon_enum->equals( enum [qw(foo bar)] ), "doesn't equal a diff enum" );
ok( $anon_enum->equals( $anon_enum ), "equals itself" );
ok( $anon_enum->equals( enum \@valid_languages ), "equals duplicate" );
+
+ok( !$anon_enum->is_subtype_of('Object'), 'enum not a subtype of Object');
+ok( !$anon_enum->is_a_type_of('Object'), 'enum not type of Object');
+
+ok( !$anon_enum->is_subtype_of('ThisTypeDoesNotExist'), 'enum not a subtype of nonexistant type');
+ok( !$anon_enum->is_a_type_of('ThisTypeDoesNotExist'), 'enum not type of nonexistant type');
+
Modified: Moose/branches/Moose-XS/t/040_type_constraints/016_subtyping_parameterized_types.t
===================================================================
--- Moose/branches/Moose-XS/t/040_type_constraints/016_subtyping_parameterized_types.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/040_type_constraints/016_subtyping_parameterized_types.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 30;
+use Test::More tests => 39;
use Test::Exception;
BEGIN {
@@ -26,12 +26,15 @@
is($p->name, 'HashRef[Int]', '... parent name is correct');
- ok($t->check({ one => 1, two => 2 }), '... validated it correctly');
+ ok($t->check({ one => 1, two => 2 }), '... validated {one=>1, two=>2} correctly');
ok(!$t->check({ one => "ONE", two => "TWO" }), '... validated it correctly');
ok( $t->equals($t), "equals to self" );
ok( !$t->equals( $t->parent ), "not equal to parent" );
ok( $t->parent->equals( $t->parent ), "parent equals to self" );
+
+ ok( !$t->is_a_type_of("ThisTypeDoesNotExist"), "not a non existant type" );
+ ok( !$t->is_subtype_of("ThisTypeDoesNotExist"), "not a subtype of a non existant type" );
}
lives_ok {
@@ -56,7 +59,7 @@
is($p->name, 'HashRef[Int]', '... parent name is correct');
ok($t->check({ one => 1, two => 2 }), '... validated it correctly');
- ok(!$t->check({ zero => 10, one => 11, two => 12 }), '... validated it correctly');
+ ok(!$t->check({ zero => 10, one => 11, two => 12 }), '... validated { zero => 10, one => 11, two => 12 } correctly');
ok(!$t->check({ one => "ONE", two => "TWO" }), '... validated it correctly');
}
@@ -85,3 +88,34 @@
ok( !$t->check({ one => 1, two => "foo", three => [] }), "failed" );
ok( !$t->check({ one => 1 }), "failed" );
}
+
+{
+ ## Because to throw errors in M:M:Parameterizable needs Moose loaded in
+ ## order to throw errors. In theory the use Moose belongs to that class
+ ## but when I put it there causes all sorts or trouble. In theory this is
+ ## never a real problem since you are likely to use Moose somewhere when you
+ ## are creating type constraints.
+ use Moose ();
+
+ my $MyArrayRefInt = subtype 'MyArrayRefInt',
+ as 'ArrayRef[Int]';
+
+ my $BiggerInt = subtype 'BiggerInt',
+ as 'Int',
+ where {$_>10};
+
+ my $SubOfMyArrayRef = subtype 'SubOfMyArrayRef',
+ as 'MyArrayRefInt[BiggerInt]';
+
+ ok $MyArrayRefInt->check([1,2,3]), '[1,2,3] is okay';
+ ok ! $MyArrayRefInt->check(["a","b"]), '["a","b"] is not';
+ ok $BiggerInt->check(100), '100 is big enough';
+ ok ! $BiggerInt->check(5), '5 is big enough';
+ ok $SubOfMyArrayRef->check([15,20,25]), '[15,20,25] is a bunch of big ints';
+ ok ! $SubOfMyArrayRef->check([15,5,25]), '[15,5,25] is NOT a bunch of big ints';
+
+ throws_ok sub {
+ my $SubOfMyArrayRef = subtype 'SubSubOfMyArrayRef',
+ as 'SubOfMyArrayRef[Str]';
+ }, qr/Str is not a subtype of BiggerInt/, 'Failed to parameterize with a bad type parameter';
+}
Modified: Moose/branches/Moose-XS/t/040_type_constraints/017_subtyping_union_types.t
===================================================================
--- Moose/branches/Moose-XS/t/040_type_constraints/017_subtyping_union_types.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/040_type_constraints/017_subtyping_union_types.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -24,7 +24,7 @@
isa_ok($p, 'Moose::Meta::TypeConstraint::Union');
isa_ok($p, 'Moose::Meta::TypeConstraint');
- is($p->name, 'ArrayRef | HashRef', '... parent name is correct');
+ is($p->name, 'ArrayRef|HashRef', '... parent name is correct');
ok($t->check([]), '... validated it correctly');
ok($t->check({}), '... validated it correctly');
@@ -33,7 +33,7 @@
lives_ok {
subtype 'MyCollectionsExtended'
- => as 'ArrayRef | HashRef'
+ => as 'ArrayRef|HashRef'
=> where {
if (ref($_) eq 'ARRAY') {
return if scalar(@$_) < 2;
@@ -55,7 +55,7 @@
isa_ok($p, 'Moose::Meta::TypeConstraint::Union');
isa_ok($p, 'Moose::Meta::TypeConstraint');
- is($p->name, 'ArrayRef | HashRef', '... parent name is correct');
+ is($p->name, 'ArrayRef|HashRef', '... parent name is correct');
ok(!$t->check([]), '... validated it correctly');
ok($t->check([1, 2]), '... validated it correctly');
Modified: Moose/branches/Moose-XS/t/040_type_constraints/020_class_type_constraint.t
===================================================================
--- Moose/branches/Moose-XS/t/040_type_constraints/020_class_type_constraint.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/040_type_constraints/020_class_type_constraint.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 18;
+use Test::More tests => 20;
use Test::Exception;
BEGIN {
@@ -38,6 +38,9 @@
ok( $type->is_subtype_of("Object"), "subtype of Object" );
+ok( !$type->is_subtype_of("ThisTypeDoesNotExist"), "not subtype of undefined type" );
+ok( !$type->is_a_type_of("ThisTypeDoesNotExist"), "not type of undefined type" );
+
ok( find_type_constraint("Bar")->check(Foo->new), "Foo passes Bar" );
ok( find_type_constraint("Bar")->check(Bar->new), "Bar passes Bar" );
ok( !find_type_constraint("Gorch")->check(Bar->new), "but Bar doesn't pass Gorch");
Modified: Moose/branches/Moose-XS/t/040_type_constraints/021_maybe_type_constraint.t
===================================================================
--- Moose/branches/Moose-XS/t/040_type_constraints/021_maybe_type_constraint.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/040_type_constraints/021_maybe_type_constraint.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 17;
+use Test::More tests => 31;
use Test::Exception;
use Moose::Util::TypeConstraints;
@@ -48,3 +48,60 @@
Foo->new(bar => 'hello world');
} '... failed the type check';
+
+{
+ package Test::MooseX::Types::Maybe;
+ use Moose;
+
+ has 'Maybe_Int' => (is=>'rw', isa=>'Maybe[Int]');
+ has 'Maybe_ArrayRef' => (is=>'rw', isa=>'Maybe[ArrayRef]');
+ has 'Maybe_HashRef' => (is=>'rw', isa=>'Maybe[HashRef]');
+ has 'Maybe_ArrayRefInt' => (is=>'rw', isa=>'Maybe[ArrayRef[Int]]');
+ has 'Maybe_HashRefInt' => (is=>'rw', isa=>'Maybe[HashRef[Int]]');
+}
+
+ok my $obj = Test::MooseX::Types::Maybe->new
+ => 'Create good test object';
+
+## Maybe[Int]
+
+ok my $Maybe_Int = Moose::Util::TypeConstraints::find_or_parse_type_constraint('Maybe[Int]')
+ => 'made TC Maybe[Int]';
+
+ok $Maybe_Int->check(1)
+ => 'passed (1)';
+
+ok $obj->Maybe_Int(1)
+ => 'assigned (1)';
+
+ok $Maybe_Int->check()
+ => 'passed ()';
+
+ok $obj->Maybe_Int()
+ => 'assigned ()';
+
+ok $Maybe_Int->check(0)
+ => 'passed (0)';
+
+ok defined $obj->Maybe_Int(0)
+ => 'assigned (0)';
+
+ok $Maybe_Int->check(undef)
+ => 'passed (undef)';
+
+ok sub {$obj->Maybe_Int(undef); 1}->()
+ => 'assigned (undef)';
+
+ok !$Maybe_Int->check("")
+ => 'failed ("")';
+
+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") },
+ qr/Attribute \(Maybe_Int\) does not pass the type constraint/
+ => 'failed assigned ("a")';
\ No newline at end of file
Modified: Moose/branches/Moose-XS/t/040_type_constraints/024_role_type_constraint.t
===================================================================
--- Moose/branches/Moose-XS/t/040_type_constraints/024_role_type_constraint.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/040_type_constraints/024_role_type_constraint.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 17;
+use Test::More tests => 19;
use Test::Exception;
BEGIN {
@@ -46,6 +46,9 @@
ok( $type->is_subtype_of("Object"), "subtype of Object" );
ok( $type->is_subtype_of("Role"), "subtype of Role" );
+ok( !$type->is_subtype_of("ThisTypeDoesNotExist"), "not subtype of unknown type name" );
+ok( !$type->is_a_type_of("ThisTypeDoesNotExist"), "not type of unknown type name" );
+
ok( find_type_constraint("Bar")->check(FooC->new), "Foo passes Bar" );
ok( find_type_constraint("Bar")->check(BarC->new), "Bar passes Bar" );
ok( !find_type_constraint("Gorch")->check(BarC->new), "but Bar doesn't pass Gorch");
Added: Moose/branches/Moose-XS/t/040_type_constraints/026_normalize_type_name.t
===================================================================
--- Moose/branches/Moose-XS/t/040_type_constraints/026_normalize_type_name.t (rev 0)
+++ Moose/branches/Moose-XS/t/040_type_constraints/026_normalize_type_name.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,151 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 37;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Moose::Util::TypeConstraints');
+}
+
+## First, we check that the new regex parsing works
+
+ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint(
+ 'ArrayRef[Str]') => 'detected correctly';
+
+is_deeply
+ [
+ Moose::Util::TypeConstraints::_parse_parameterized_type_constraint(
+ 'ArrayRef[Str]')
+ ],
+ [ "ArrayRef", "Str" ] => 'Correctly parsed ArrayRef[Str]';
+
+ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint(
+ 'ArrayRef[Str ]') => 'detected correctly';
+
+is_deeply
+ [
+ Moose::Util::TypeConstraints::_parse_parameterized_type_constraint(
+ 'ArrayRef[Str ]')
+ ],
+ [ "ArrayRef", "Str" ] => 'Correctly parsed ArrayRef[Str ]';
+
+ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint(
+ 'ArrayRef[ Str]') => 'detected correctly';
+
+is_deeply
+ [
+ Moose::Util::TypeConstraints::_parse_parameterized_type_constraint(
+ 'ArrayRef[ Str]')
+ ],
+ [ "ArrayRef", "Str" ] => 'Correctly parsed ArrayRef[ Str]';
+
+ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint(
+ 'ArrayRef[ Str ]') => 'detected correctly';
+
+is_deeply
+ [
+ Moose::Util::TypeConstraints::_parse_parameterized_type_constraint(
+ 'ArrayRef[ Str ]')
+ ],
+ [ "ArrayRef", "Str" ] => 'Correctly parsed ArrayRef[ Str ]';
+
+ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint(
+ 'ArrayRef[ HashRef[Int] ]') => 'detected correctly';
+
+is_deeply
+ [
+ Moose::Util::TypeConstraints::_parse_parameterized_type_constraint(
+ 'ArrayRef[ HashRef[Int] ]')
+ ],
+ [ "ArrayRef", "HashRef[Int]" ] =>
+ 'Correctly parsed ArrayRef[ HashRef[Int] ]';
+
+ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint(
+ 'ArrayRef[ HashRef[Int ] ]') => 'detected correctly';
+
+is_deeply
+ [
+ Moose::Util::TypeConstraints::_parse_parameterized_type_constraint(
+ 'ArrayRef[ HashRef[Int ] ]')
+ ],
+ [ "ArrayRef", "HashRef[Int ]" ] =>
+ 'Correctly parsed ArrayRef[ HashRef[Int ] ]';
+
+ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint(
+ 'ArrayRef[Int|Str]') => 'detected correctly';
+
+is_deeply
+ [
+ Moose::Util::TypeConstraints::_parse_parameterized_type_constraint(
+ 'ArrayRef[Int|Str]')
+ ],
+ [ "ArrayRef", "Int|Str" ] => 'Correctly parsed ArrayRef[Int|Str]';
+
+ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint(
+ 'ArrayRef[ArrayRef[Int]|Str]') => 'detected correctly';
+
+is_deeply
+ [
+ Moose::Util::TypeConstraints::_parse_parameterized_type_constraint(
+ 'ArrayRef[ArrayRef[Int]|Str]')
+ ],
+ [ "ArrayRef", "ArrayRef[Int]|Str" ] =>
+ 'Correctly parsed ArrayRef[ArrayRef[Int]|Str]';
+
+## creating names via subtype
+
+ok my $r = Moose::Util::TypeConstraints->get_type_constraint_registry =>
+ 'Got registry object';
+
+ok my $subtype_a1
+ = subtype( 'subtype_a1' => as 'HashRef[Int]' ), => 'created subtype_a1';
+
+ok my $subtype_a2
+ = subtype( 'subtype_a2' => as 'HashRef[ Int]' ), => 'created subtype_a2';
+
+ok my $subtype_a3
+ = subtype( 'subtype_a2' => as 'HashRef[Int ]' ), => 'created subtype_a2';
+
+ok my $subtype_a4 = subtype( 'subtype_a2' => as 'HashRef[ Int ]' ), =>
+ 'created subtype_a2';
+
+is $subtype_a1->parent->name, $subtype_a2->parent->name => 'names match';
+
+is $subtype_a1->parent->name, $subtype_a3->parent->name => 'names match';
+
+is $subtype_a1->parent->name, $subtype_a4->parent->name => 'names match';
+
+ok my $subtype_b1 = subtype( 'subtype_b1' => as 'HashRef[Int|Str]' ), =>
+ 'created subtype_b1';
+
+ok my $subtype_b2 = subtype( 'subtype_b2' => as 'HashRef[Int | Str]' ), =>
+ 'created subtype_b2';
+
+ok my $subtype_b3 = subtype( 'subtype_b3' => as 'HashRef[Str|Int]' ), =>
+ 'created subtype_b3';
+
+is $subtype_b1->parent->name, $subtype_b2->parent->name => 'names match';
+
+is $subtype_b1->parent->name, $subtype_b3->parent->name => 'names match';
+
+is $subtype_b2->parent->name, $subtype_b3->parent->name => 'names match';
+
+## testing via add_constraint
+
+ok my $union1 = Moose::Util::TypeConstraints::create_type_constraint_union(
+ 'ArrayRef[Int|Str] | ArrayRef[Int | HashRef]') => 'Created Union1';
+
+ok my $union2 = Moose::Util::TypeConstraints::create_type_constraint_union(
+ 'ArrayRef[ Int|Str] | ArrayRef[Int | HashRef]') => 'Created Union2';
+
+ok my $union3 = Moose::Util::TypeConstraints::create_type_constraint_union(
+ 'ArrayRef[Int |Str ] | ArrayRef[Int | HashRef ]') => 'Created Union3';
+
+is $union1->name, $union2->name, 'names match';
+
+is $union1->name, $union3->name, 'names match';
+
+is $union2->name, $union3->name, 'names match';
Added: Moose/branches/Moose-XS/t/040_type_constraints/027_parameterize_from.t
===================================================================
--- Moose/branches/Moose-XS/t/040_type_constraints/027_parameterize_from.t (rev 0)
+++ Moose/branches/Moose-XS/t/040_type_constraints/027_parameterize_from.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,79 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 12;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Moose::Util::TypeConstraints');
+}
+
+# testing the parameterize method
+
+{
+ my $parameterizable = subtype 'parameterizable_hashref', as 'HashRef';
+
+ my $parameterized = subtype 'parameterized_hashref', as 'HashRef[Int]';
+
+ my $int = Moose::Util::TypeConstraints::find_type_constraint('Int');
+
+ my $from_parameterizable = $parameterizable->parameterize($int);
+
+ isa_ok $parameterizable,
+ 'Moose::Meta::TypeConstraint::Parameterizable', =>
+ 'Got expected type instance';
+
+ package Test::Moose::Meta::TypeConstraint::Parameterizable;
+ use Moose;
+
+ has parameterizable => ( is => 'rw', isa => $parameterizable );
+ has parameterized => ( is => 'rw', isa => $parameterized );
+ has from_parameterizable => ( is => 'rw', isa => $from_parameterizable );
+}
+
+# Create and check a dummy object
+
+ok my $params = Test::Moose::Meta::TypeConstraint::Parameterizable->new() =>
+ 'Create Dummy object for testing';
+
+isa_ok $params, 'Test::Moose::Meta::TypeConstraint::Parameterizable' =>
+ 'isa correct type';
+
+# test parameterizable
+
+lives_ok sub {
+ $params->parameterizable( { a => 'Hello', b => 'World' } );
+} => 'No problem setting parameterizable';
+
+is_deeply $params->parameterizable,
+ { a => 'Hello', b => 'World' } => 'Got expected values';
+
+# test parameterized
+
+lives_ok sub {
+ $params->parameterized( { a => 1, b => 2 } );
+} => 'No problem setting parameterized';
+
+is_deeply $params->parameterized, { a => 1, b => 2 } => 'Got expected values';
+
+throws_ok sub {
+ $params->parameterized( { a => 'Hello', b => 'World' } );
+ }, qr/Attribute \(parameterized\) does not pass the type constraint/ =>
+ 'parameterized throws expected error';
+
+# test from_parameterizable
+
+lives_ok sub {
+ $params->from_parameterizable( { a => 1, b => 2 } );
+} => 'No problem setting from_parameterizable';
+
+is_deeply $params->from_parameterizable,
+ { a => 1, b => 2 } => 'Got expected values';
+
+throws_ok sub {
+ $params->from_parameterizable( { a => 'Hello', b => 'World' } );
+ },
+ qr/Attribute \(from_parameterizable\) does not pass the type constraint/
+ => 'from_parameterizable throws expected error';
Added: Moose/branches/Moose-XS/t/040_type_constraints/029_define_type_twice_throws.t
===================================================================
--- Moose/branches/Moose-XS/t/040_type_constraints/029_define_type_twice_throws.t (rev 0)
+++ Moose/branches/Moose-XS/t/040_type_constraints/029_define_type_twice_throws.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,26 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Moose::Util::TypeConstraints');
+}
+
+{
+ package Some::Class;
+ use Moose::Util::TypeConstraints;
+
+ subtype 'MySubType' => as 'Int' => where { 1 };
+}
+
+throws_ok {
+ package Some::Other::Class;
+ use Moose::Util::TypeConstraints;
+
+ subtype 'MySubType' => as 'Int' => where { 1 };
+} qr/cannot be created again/, 'Trying to create same type twice throws';
+
Added: Moose/branches/Moose-XS/t/040_type_constraints/030-class_subtypes.t
===================================================================
--- Moose/branches/Moose-XS/t/040_type_constraints/030-class_subtypes.t (rev 0)
+++ Moose/branches/Moose-XS/t/040_type_constraints/030-class_subtypes.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,82 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 18;
+use Test::Exception;
+
+use Moose::Util::TypeConstraints;
+use Moose::Meta::TypeConstraint;
+
+
+## Create a subclass with a custom method
+
+{
+ package Test::Moose::Meta::TypeConstraint::AnySubType;
+ use Moose;
+ extends 'Moose::Meta::TypeConstraint';
+
+ sub my_custom_method {
+ return 1;
+ }
+}
+
+my $Int = find_type_constraint('Int');
+ok $Int, 'Got a good type contstraint';
+
+my $parent = Test::Moose::Meta::TypeConstraint::AnySubType->new({
+ name => "Test::Moose::Meta::TypeConstraint::AnySubType" ,
+ parent => $Int,
+});
+
+ok $parent, 'Created type constraint';
+ok $parent->check(1), 'Correctly passed';
+ok ! $parent->check('a'), 'correctly failed';
+ok $parent->my_custom_method, 'found the custom method';
+
+my $subtype1 = subtype 'another_subtype' => as $parent;
+
+ok $subtype1, 'Created type constraint';
+ok $subtype1->check(1), 'Correctly passed';
+ok ! $subtype1->check('a'), 'correctly failed';
+ok $subtype1->my_custom_method, 'found the custom method';
+
+
+my $subtype2 = subtype 'another_subtype' => as $subtype1 => where { $_ < 10 };
+
+ok $subtype2, 'Created type constraint';
+ok $subtype2->check(1), 'Correctly passed';
+ok ! $subtype2->check('a'), 'correctly failed';
+ok ! $subtype2->check(100), 'correctly failed';
+
+ok $subtype2->my_custom_method, 'found the custom method';
+
+
+{
+ package Foo;
+
+ use Moose;
+}
+
+{
+ package Bar;
+
+ use Moose;
+
+ extends 'Foo';
+}
+
+{
+ package Baz;
+
+ use Moose;
+}
+
+my $foo = class_type 'Foo';
+my $isa_foo = subtype 'IsaFoo' => as $foo;
+
+ok $isa_foo, 'Created subtype of Foo type';
+ok $isa_foo->check( Foo->new ), 'Foo passes check';
+ok $isa_foo->check( Bar->new ), 'Bar passes check';
+ok ! $isa_foo->check( Baz->new ), 'Baz does not pass check';
Modified: Moose/branches/Moose-XS/t/050_metaclasses/012_moose_exporter.t
===================================================================
--- Moose/branches/Moose-XS/t/050_metaclasses/012_moose_exporter.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/050_metaclasses/012_moose_exporter.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -7,8 +7,8 @@
use Test::Exception;
BEGIN {
- unless ( eval 'use Test::Warn; 1' ) {
- plan skip_all => 'These tests require Test::Warn';
+ unless ( eval 'use Test::Warn 0.10; 1' ) {
+ plan skip_all => 'These tests require Test::Warn 0.10';
}
else {
plan tests => 40;
@@ -214,7 +214,7 @@
::like(
$@,
- qr/\QCircular reference in also parameter to MooseX::Exporter between MooseX::CircularAlso and MooseX::CircularAlso/,
+ qr/\QCircular reference in also parameter to Moose::Exporter between MooseX::CircularAlso and MooseX::CircularAlso/,
'got the expected error from circular reference in also'
);
}
@@ -235,7 +235,7 @@
::like(
$@,
- qr/\QPackage in also (NoSuchThing) does not seem to use MooseX::Exporter/,
+ qr/\QPackage in also (NoSuchThing) does not seem to use Moose::Exporter/,
'got the expected error from a reference in also to a package which does not use Moose::Exporter'
);
}
Modified: Moose/branches/Moose-XS/t/050_metaclasses/013_metaclass_traits.t
===================================================================
--- Moose/branches/Moose-XS/t/050_metaclasses/013_metaclass_traits.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/050_metaclasses/013_metaclass_traits.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -3,7 +3,9 @@
use strict;
use warnings;
-use Test::More tests => 23;
+use lib 't/lib', 'lib';
+
+use Test::More tests => 32;
use Test::Exception;
{
@@ -170,3 +172,51 @@
like( $@, qr/does not have an init_meta/,
'... and error provides a useful explanation' );
}
+
+{
+ package Foo::Subclass;
+
+ use Moose -traits => [ 'My::SimpleTrait3' ];
+
+ extends 'Foo';
+}
+
+can_ok( Foo::Subclass->meta(), 'simple' );
+is( Foo::Subclass->meta()->simple(), 5,
+ 'Foo::Subclass->meta()->simple() returns expected value' );
+is( Foo::Subclass->meta()->simple2(), 55,
+ 'Foo::Subclass->meta()->simple2() returns expected value' );
+can_ok( Foo::Subclass->meta(), 'attr2' );
+is( Foo::Subclass->meta()->attr2(), 'something',
+ 'Foo::Subclass->meta()->attr2() returns expected value' );
+
+{
+
+ package Class::WithAlreadyPresentTrait;
+ use Moose -traits => 'My::SimpleTrait';
+
+ has an_attr => ( is => 'ro' );
+}
+
+lives_ok {
+ my $instance = Class::WithAlreadyPresentTrait->new( an_attr => 'value' );
+ is( $instance->an_attr, 'value', 'Can get value' );
+}
+'Can create instance and access attributes';
+
+{
+
+ package Class::WhichLoadsATraitFromDisk;
+
+ # Any role you like here, the only important bit is that it gets
+ # loaded from disk and has not already been defined.
+ use Moose -traits => 'Role::Parent';
+
+ has an_attr => ( is => 'ro' );
+}
+
+lives_ok {
+ my $instance = Class::WhichLoadsATraitFromDisk->new( an_attr => 'value' );
+ is( $instance->an_attr, 'value', 'Can get value' );
+}
+'Can create instance and access attributes';
Added: Moose/branches/Moose-XS/t/050_metaclasses/015_metarole.t
===================================================================
--- Moose/branches/Moose-XS/t/050_metaclasses/015_metarole.t (rev 0)
+++ Moose/branches/Moose-XS/t/050_metaclasses/015_metarole.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,513 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use lib 't/lib', 'lib';
+
+use Test::More tests => 73;
+use Test::Exception;
+
+use Moose::Util::MetaRole;
+
+
+{
+ package My::Meta::Class;
+ use Moose;
+ extends 'Moose::Meta::Class';
+}
+
+{
+ package Role::Foo;
+ use Moose::Role;
+ has 'foo' => ( is => 'ro', default => 10 );
+}
+
+{
+ package My::Class;
+
+ use Moose;
+}
+
+{
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class',
+ metaclass_roles => ['Role::Foo'],
+ );
+
+ ok( My::Class->meta()->meta()->does_role('Role::Foo'),
+ 'apply Role::Foo to My::Class->meta()' );
+ is( My::Class->meta()->foo(), 10,
+ '... and call foo() on that meta object' );
+}
+
+{
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class',
+ attribute_metaclass_roles => ['Role::Foo'],
+ );
+
+ ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class->meta()'s attribute metaclass} );
+ ok( My::Class->meta()->meta()->does_role('Role::Foo'),
+ '... My::Class->meta() still does Role::Foo' );
+
+ My::Class->meta()->add_attribute( 'size', is => 'ro' );
+ is( My::Class->meta()->get_attribute('size')->foo(), 10,
+ '... call foo() on an attribute metaclass object' );
+}
+
+{
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class',
+ method_metaclass_roles => ['Role::Foo'],
+ );
+
+ ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class->meta()'s method metaclass} );
+ ok( My::Class->meta()->meta()->does_role('Role::Foo'),
+ '... My::Class->meta() still does Role::Foo' );
+ ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
+ q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );
+
+ My::Class->meta()->add_method( 'bar' => sub { 'bar' } );
+ is( My::Class->meta()->get_method('bar')->foo(), 10,
+ '... call foo() on a method metaclass object' );
+}
+
+{
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class',
+ instance_metaclass_roles => ['Role::Foo'],
+ );
+
+ ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class->meta()'s instance metaclass} );
+ ok( My::Class->meta()->meta()->does_role('Role::Foo'),
+ '... My::Class->meta() still does Role::Foo' );
+ ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
+ q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );
+ ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
+ q{... My::Class->meta()'s method metaclass still does Role::Foo} );
+
+ is( My::Class->meta()->get_meta_instance()->foo(), 10,
+ '... call foo() on an instance metaclass object' );
+}
+
+{
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class',
+ constructor_class_roles => ['Role::Foo'],
+ );
+
+ ok( My::Class->meta()->constructor_class()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class->meta()'s constructor class} );
+ ok( My::Class->meta()->meta()->does_role('Role::Foo'),
+ '... My::Class->meta() still does Role::Foo' );
+ ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
+ q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );
+ ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
+ q{... My::Class->meta()'s method metaclass still does Role::Foo} );
+ ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
+ q{... My::Class->meta()'s instance metaclass still does Role::Foo} );
+
+ # Actually instantiating the constructor class is too freaking hard!
+ ok( My::Class->meta()->constructor_class()->can('foo'),
+ '... constructor class has a foo method' );
+}
+
+{
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class',
+ destructor_class_roles => ['Role::Foo'],
+ );
+
+ ok( My::Class->meta()->destructor_class()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class->meta()'s destructor class} );
+ ok( My::Class->meta()->meta()->does_role('Role::Foo'),
+ '... My::Class->meta() still does Role::Foo' );
+ ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
+ q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );
+ ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
+ q{... My::Class->meta()'s method metaclass still does Role::Foo} );
+ ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
+ q{... My::Class->meta()'s instance metaclass still does Role::Foo} );
+ ok( My::Class->meta()->constructor_class()->meta()->does_role('Role::Foo'),
+ q{... My::Class->meta()'s constructor class still does Role::Foo} );
+
+ # same problem as the constructor class
+ ok( My::Class->meta()->destructor_class()->can('foo'),
+ '... destructor class has a foo method' );
+}
+
+{
+ Moose::Util::MetaRole::apply_base_class_roles(
+ for_class => 'My::Class',
+ roles => ['Role::Foo'],
+ );
+
+ ok( My::Class->meta()->does_role('Role::Foo'),
+ 'apply Role::Foo to My::Class base class' );
+ is( My::Class->new()->foo(), 10,
+ '... call foo() on a My::Class object' );
+}
+
+{
+ package My::Class2;
+
+ use Moose;
+}
+
+{
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class2',
+ metaclass_roles => ['Role::Foo'],
+ attribute_metaclass_roles => ['Role::Foo'],
+ method_metaclass_roles => ['Role::Foo'],
+ instance_metaclass_roles => ['Role::Foo'],
+ constructor_class_roles => ['Role::Foo'],
+ destructor_class_roles => ['Role::Foo'],
+ );
+
+ ok( My::Class2->meta()->meta()->does_role('Role::Foo'),
+ 'apply Role::Foo to My::Class2->meta()' );
+ is( My::Class2->meta()->foo(), 10,
+ '... and call foo() on that meta object' );
+ ok( My::Class2->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class2->meta()'s attribute metaclass} );
+ My::Class2->meta()->add_attribute( 'size', is => 'ro' );
+
+ is( My::Class2->meta()->get_attribute('size')->foo(), 10,
+ '... call foo() on an attribute metaclass object' );
+
+ ok( My::Class2->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class2->meta()'s method metaclass} );
+
+ My::Class2->meta()->add_method( 'bar' => sub { 'bar' } );
+ is( My::Class2->meta()->get_method('bar')->foo(), 10,
+ '... call foo() on a method metaclass object' );
+
+ ok( My::Class2->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class2->meta()'s instance metaclass} );
+ is( My::Class2->meta()->get_meta_instance()->foo(), 10,
+ '... call foo() on an instance metaclass object' );
+
+ ok( My::Class2->meta()->constructor_class()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class2->meta()'s constructor class} );
+ ok( My::Class2->meta()->constructor_class()->can('foo'),
+ '... constructor class has a foo method' );
+
+ ok( My::Class2->meta()->destructor_class()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class2->meta()'s destructor class} );
+ ok( My::Class2->meta()->destructor_class()->can('foo'),
+ '... destructor class has a foo method' );
+}
+
+
+{
+ package My::Meta;
+
+ use Moose::Exporter;
+ Moose::Exporter->setup_import_methods( also => 'Moose' );
+
+ sub init_meta {
+ shift;
+ my %p = @_;
+
+ Moose->init_meta( %p, metaclass => 'My::Meta::Class' );
+ }
+}
+
+{
+ package My::Class3;
+
+ My::Meta->import();
+}
+
+
+{
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class3',
+ metaclass_roles => ['Role::Foo'],
+ );
+
+ ok( My::Class3->meta()->meta()->does_role('Role::Foo'),
+ 'apply Role::Foo to My::Class3->meta()' );
+ is( My::Class3->meta()->foo(), 10,
+ '... and call foo() on that meta object' );
+ ok( ( grep { $_ eq 'My::Meta::Class' } My::Class3->meta()->meta()->superclasses() ),
+ 'apply_metaclass_roles() does not interfere with metaclass set via Moose->init_meta()' );
+}
+
+{
+ package Role::Bar;
+ use Moose::Role;
+ has 'bar' => ( is => 'ro', default => 200 );
+}
+
+{
+ package My::Class4;
+ use Moose;
+}
+
+{
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class4',
+ metaclass_roles => ['Role::Foo'],
+ );
+
+ ok( My::Class4->meta()->meta()->does_role('Role::Foo'),
+ 'apply Role::Foo to My::Class4->meta()' );
+
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class4',
+ metaclass_roles => ['Role::Bar'],
+ );
+
+ ok( My::Class4->meta()->meta()->does_role('Role::Bar'),
+ 'apply Role::Bar to My::Class4->meta()' );
+ ok( My::Class4->meta()->meta()->does_role('Role::Foo'),
+ '... and My::Class4->meta() still does Role::Foo' );
+}
+
+{
+ package My::Class5;
+ use Moose;
+
+ extends 'My::Class';
+}
+
+{
+ ok( My::Class5->meta()->meta()->does_role('Role::Foo'),
+ q{My::Class5->meta()'s does Role::Foo because it extends My::Class} );
+ ok( My::Class5->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
+ q{My::Class5->meta()'s attribute metaclass also does Role::Foo} );
+ ok( My::Class5->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
+ q{My::Class5->meta()'s method metaclass also does Role::Foo} );
+ ok( My::Class5->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
+ q{My::Class5->meta()'s instance metaclass also does Role::Foo} );
+ ok( My::Class5->meta()->constructor_class()->meta()->does_role('Role::Foo'),
+ q{My::Class5->meta()'s constructor class also does Role::Foo} );
+ ok( My::Class5->meta()->destructor_class()->meta()->does_role('Role::Foo'),
+ q{My::Class5->meta()'s destructor class also does Role::Foo} );
+}
+
+{
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class5',
+ metaclass_roles => ['Role::Bar'],
+ );
+
+ ok( My::Class5->meta()->meta()->does_role('Role::Bar'),
+ q{apply Role::Bar My::Class5->meta()} );
+ ok( My::Class5->meta()->meta()->does_role('Role::Foo'),
+ q{... and My::Class5->meta() still does Role::Foo} );
+}
+
+{
+ package My::Class6;
+ use Moose;
+
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class6',
+ metaclass_roles => ['Role::Bar'],
+ );
+
+ extends 'My::Class';
+}
+
+{
+ ok( My::Class6->meta()->meta()->does_role('Role::Bar'),
+ q{apply Role::Bar My::Class6->meta() before extends} );
+ ok( My::Class6->meta()->meta()->does_role('Role::Foo'),
+ q{... and My::Class6->meta() does Role::Foo because My::Class6 extends My::Class} );
+}
+
+# This is the hack that used to be needed to work around the
+# _fix_metaclass_incompatibility problem. You called extends() (which
+# in turn calls _fix_metaclass_imcompatibility) _before_ you apply
+# more extensions in the subclass. We wabt to make sure this continues
+# to work in the future.
+{
+ package My::Class7;
+ use Moose;
+
+ # In real usage this would go in a BEGIN block so it happened
+ # before apply_metaclass_roles was called by an extension.
+ extends 'My::Class';
+
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class7',
+ metaclass_roles => ['Role::Bar'],
+ );
+}
+
+{
+ ok( My::Class7->meta()->meta()->does_role('Role::Bar'),
+ q{apply Role::Bar My::Class7->meta() before extends} );
+ ok( My::Class7->meta()->meta()->does_role('Role::Foo'),
+ q{... and My::Class7->meta() does Role::Foo because My::Class7 extends My::Class} );
+}
+
+{
+ package My::Class8;
+ use Moose;
+
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class8',
+ metaclass_roles => ['Role::Bar'],
+ attribute_metaclass_roles => ['Role::Bar'],
+ );
+
+ extends 'My::Class';
+}
+
+{
+ ok( My::Class8->meta()->meta()->does_role('Role::Bar'),
+ q{apply Role::Bar My::Class8->meta() before extends} );
+ ok( My::Class8->meta()->meta()->does_role('Role::Foo'),
+ q{... and My::Class8->meta() does Role::Foo because My::Class8 extends My::Class} );
+ ok( My::Class8->meta()->attribute_metaclass->meta()->does_role('Role::Bar'),
+ q{apply Role::Bar to My::Class8->meta()->attribute_metaclass before extends} );
+ ok( My::Class8->meta()->attribute_metaclass->meta()->does_role('Role::Foo'),
+ q{... and My::Class8->meta()->attribute_metaclass does Role::Foo because My::Class8 extends My::Class} );
+}
+
+
+{
+ package My::Class9;
+ use Moose;
+
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class9',
+ attribute_metaclass_roles => ['Role::Bar'],
+ );
+
+ extends 'My::Class';
+}
+
+{
+ ok( My::Class9->meta()->meta()->does_role('Role::Foo'),
+ q{... and My::Class9->meta() does Role::Foo because My::Class9 extends My::Class} );
+ ok( My::Class9->meta()->attribute_metaclass->meta()->does_role('Role::Bar'),
+ q{apply Role::Bar to My::Class9->meta()->attribute_metaclass before extends} );
+ ok( My::Class9->meta()->attribute_metaclass->meta()->does_role('Role::Foo'),
+ q{... and My::Class9->meta()->attribute_metaclass does Role::Foo because My::Class9 extends My::Class} );
+}
+
+# This tests applying meta roles to a metaclass's metaclass. This is
+# completely insane, but is exactly what happens with
+# Fey::Meta::Class::Table. It's a subclass of Moose::Meta::Class
+# itself, and then it _uses_ MooseX::ClassAttribute, so the metaclass
+# for Fey::Meta::Class::Table does a role.
+#
+# At one point this caused a metaclass incompatibility error down
+# below, when we applied roles to the metaclass of My::Class10. It's
+# all madness but as long as the tests pass we're happy.
+{
+ package My::Meta::Class2;
+ use Moose;
+ extends 'Moose::Meta::Class';
+
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Meta::Class2',
+ metaclass_roles => ['Role::Foo'],
+ );
+}
+
+{
+ package My::Object;
+ use Moose;
+ extends 'Moose::Object';
+}
+
+{
+ package My::Meta2;
+
+ use Moose::Exporter;
+ Moose::Exporter->setup_import_methods( also => 'Moose' );
+
+ sub init_meta {
+ shift;
+ my %p = @_;
+
+ Moose->init_meta(
+ %p,
+ metaclass => 'My::Meta::Class2',
+ base_class => 'My::Object',
+ );
+ }
+}
+
+{
+ package My::Class10;
+ My::Meta2->import;
+
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class10',
+ metaclass_roles => ['Role::Bar'],
+ );
+}
+
+{
+ ok( My::Class10->meta()->meta()->meta()->does_role('Role::Foo'),
+ q{My::Class10->meta()->meta() does Role::Foo } );
+ ok( My::Class10->meta()->meta()->does_role('Role::Bar'),
+ q{My::Class10->meta()->meta() does Role::Bar } );
+ ok( My::Class10->meta()->isa('My::Meta::Class2'),
+ q{... and My::Class10->meta still isa(My::Meta::Class2)} );
+ ok( My::Class10->isa('My::Object'),
+ q{... and My::Class10 still isa(My::Object)} );
+}
+
+{
+ package My::Constructor;
+
+ use base 'Moose::Meta::Method::Constructor';
+}
+
+{
+ package My::Class11;
+
+ use Moose;
+
+ __PACKAGE__->meta->constructor_class('My::Constructor');
+
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class11',
+ metaclass_roles => ['Role::Foo'],
+ );
+}
+
+{
+ ok( My::Class11->meta()->meta()->does_role('Role::Foo'),
+ q{My::Class11->meta()->meta() does Role::Foo } );
+ is( My::Class11->meta()->constructor_class, 'My::Constructor',
+ q{... and explicitly set constructor_class value is unchanged)} );
+}
+
+{
+ package ExportsMoose;
+
+ Moose::Exporter->setup_import_methods(
+ also => 'Moose',
+ );
+
+ sub init_meta {
+ shift;
+ my %p = @_;
+ Moose->init_meta(%p);
+ return Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => $p{for_class},
+ # Causes us to recurse through init_meta, as we have to
+ # load MyMetaclassRole from disk.
+ metaclass_roles => [qw/MyMetaclassRole/],
+ );
+ }
+}
+
+lives_ok {
+ package UsesExportedMoose;
+ ExportsMoose->import;
+} 'import module which loads a role from disk during init_meta';
+
Added: Moose/branches/Moose-XS/t/050_metaclasses/016_metarole_w_metaclass_pm.t
===================================================================
--- Moose/branches/Moose-XS/t/050_metaclasses/016_metarole_w_metaclass_pm.t (rev 0)
+++ Moose/branches/Moose-XS/t/050_metaclasses/016_metarole_w_metaclass_pm.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,109 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 8;
+
+use Moose::Util::MetaRole;
+
+BEGIN
+{
+ package My::Meta::Class;
+ use Moose;
+ extends 'Moose::Meta::Class';
+}
+
+BEGIN
+{
+ package My::Meta::Attribute;
+ use Moose;
+ extends 'Moose::Meta::Attribute';
+}
+
+BEGIN
+{
+ package My::Meta::Method;
+ use Moose;
+ extends 'Moose::Meta::Method';
+}
+
+BEGIN
+{
+ package My::Meta::Instance;
+ use Moose;
+ extends 'Moose::Meta::Instance';
+}
+
+BEGIN
+{
+ package Role::Foo;
+ use Moose::Role;
+ has 'foo' => ( is => 'ro', default => 10 );
+}
+
+{
+ package My::Class;
+
+ use metaclass 'My::Meta::Class';
+ use Moose;
+}
+
+{
+ package My::Class2;
+
+ use metaclass 'My::Meta::Class' => (
+ attribute_metaclass => 'My::Meta::Attribute',
+ method_metaclass => 'My::Meta::Method',
+ instance_metaclass => 'My::Meta::Instance',
+ );
+
+ use Moose;
+}
+
+{
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class',
+ metaclass_roles => ['Role::Foo'],
+ );
+
+ ok( My::Class->meta()->meta()->does_role('Role::Foo'),
+ 'apply Role::Foo to My::Class->meta()' );
+ has_superclass( My::Class->meta(), 'My::Meta::Class',
+ 'apply_metaclass_roles works with metaclass.pm' );
+}
+
+{
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class2',
+ attribute_metaclass_roles => ['Role::Foo'],
+ method_metaclass_roles => ['Role::Foo'],
+ instance_metaclass_roles => ['Role::Foo'],
+ );
+
+ ok( My::Class2->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class2->meta()'s attribute metaclass} );
+ has_superclass( My::Class2->meta()->attribute_metaclass(), 'My::Meta::Attribute',
+ '... and this does not interfere with attribute metaclass set via metaclass.pm' );
+ ok( My::Class2->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class2->meta()'s method metaclass} );
+ has_superclass( My::Class2->meta()->method_metaclass(), 'My::Meta::Method',
+ '... and this does not interfere with method metaclass set via metaclass.pm' );
+ ok( My::Class2->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class2->meta()'s instance metaclass} );
+ has_superclass( My::Class2->meta()->instance_metaclass(), 'My::Meta::Instance',
+ '... and this does not interfere with instance metaclass set via metaclass.pm' );
+}
+
+# like isa_ok but works with a class name, not just refs
+sub has_superclass {
+ my $thing = shift;
+ my $parent = shift;
+ my $desc = shift;
+
+ my %supers = map { $_ => 1 } $thing->meta()->superclasses();
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ ok( $supers{$parent}, $desc );
+}
Added: Moose/branches/Moose-XS/t/050_metaclasses/017_use_base_of_moose.t
===================================================================
--- Moose/branches/Moose-XS/t/050_metaclasses/017_use_base_of_moose.t (rev 0)
+++ Moose/branches/Moose-XS/t/050_metaclasses/017_use_base_of_moose.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,37 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 4;
+use Test::Exception;
+
+{
+ package NoOpTrait;
+ use Moose::Role;
+}
+
+{
+ package Parent;
+ use Moose -traits => 'NoOpTrait';
+
+ has attr => (
+ is => 'rw',
+ isa => 'Str',
+ );
+}
+
+{
+ package Child;
+ use base 'Parent';
+}
+
+is(Child->meta->name, 'Child', "correct metaclass name");
+
+my $child = Child->new(attr => "ibute");
+ok($child, "constructor works");
+
+is($child->attr, "ibute", "getter inherited properly");
+
+$child->attr("ition");
+is($child->attr, "ition", "setter inherited properly");
Added: Moose/branches/Moose-XS/t/050_metaclasses/018_throw_error.t
===================================================================
--- Moose/branches/Moose-XS/t/050_metaclasses/018_throw_error.t (rev 0)
+++ Moose/branches/Moose-XS/t/050_metaclasses/018_throw_error.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,156 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 24;
+use Test::Exception;
+
+{
+
+ package Foo;
+ use Moose;
+
+ has foo => ( is => "ro" );
+
+ package Bar;
+ use metaclass (
+ metaclass => "Moose::Meta::Class",
+ error_class => "Moose::Error::Croak",
+ );
+ use Moose;
+
+ has foo => ( is => "ro" );
+
+ package Baz::Error;
+ use Moose;
+
+ has message => ( isa => "Str", is => "ro" );
+ has attr => ( isa => "Moose::Meta::Attribute", is => "ro" );
+ has method => ( isa => "Moose::Meta::Method", is => "ro" );
+ has metaclass => ( isa => "Moose::Meta::Class", is => "ro" );
+ has data => ( is => "ro" );
+ has line => ( isa => "Int", is => "ro" );
+ has file => ( isa => "Str", is => "ro" );
+ has last_error => ( isa => "Any", is => "ro" );
+
+ package Baz;
+ use metaclass (
+ metaclass => "Moose::Meta::Class",
+ error_class => "Baz::Error",
+ );
+ use Moose;
+
+ has foo => ( is => "ro" );
+}
+
+my $line;
+sub blah { $line = __LINE__; shift->foo(4) }
+
+sub create_error {
+ eval {
+ eval { die "Blah" };
+ blah(shift);
+ };
+ ok( my $e = $@, "got some error" );
+ return {
+ file => __FILE__,
+ line => $line,
+ error => $e,
+ };
+}
+
+{
+ my $e = create_error( Foo->new );
+ ok( !ref( $e->{error} ), "error is a string" );
+ like( $e->{error}, qr/line $e->{line}\n.*\n/s, "confess" );
+}
+
+{
+ my $e = create_error( Bar->new );
+ ok( !ref( $e->{error} ), "error is a string" );
+ like( $e->{error}, qr/line $e->{line}$/s, "croak" );
+}
+
+{
+ my $e = create_error( my $baz = Baz->new );
+ isa_ok( $e->{error}, "Baz::Error" );
+ unlike( $e->{error}->message, qr/line $e->{line}/s,
+ "no line info, just a message" );
+ isa_ok( $e->{error}->metaclass, "Moose::Meta::Class", "metaclass" );
+ is( $e->{error}->metaclass, Baz->meta, "metaclass value" );
+ isa_ok( $e->{error}->attr, "Moose::Meta::Attribute", "attr" );
+ is( $e->{error}->attr, Baz->meta->get_attribute("foo"), "attr value" );
+ isa_ok( $e->{error}->method, "Moose::Meta::Method", "method" );
+ is( $e->{error}->method, Baz->meta->get_method("foo"), "method value" );
+ is( $e->{error}->line, $e->{line}, "line attr" );
+ is( $e->{error}->file, $e->{file}, "file attr" );
+ is_deeply( $e->{error}->data, [ $baz, 4 ], "captured args" );
+ like( $e->{error}->last_error, qr/Blah/, "last error preserved" );
+}
+
+{
+ package Role::Foo;
+ use Moose::Role;
+
+ sub foo { }
+}
+
+{
+ package Baz::Sub;
+
+ use Moose;
+ extends 'Baz';
+
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => __PACKAGE__,
+ metaclass_roles => ['Role::Foo'],
+ );
+}
+
+{
+ package Baz::Sub::Sub;
+ use metaclass (
+ metaclass => 'Moose::Meta::Class',
+ error_class => 'Moose::Error::Croak',
+ );
+ use Moose;
+
+ ::dies_ok { extends 'Baz::Sub' } 'error_class is included in metaclass compatibility checks';
+}
+
+{
+ package Foo::Sub;
+
+ use metaclass (
+ metaclass => 'Moose::Meta::Class',
+ error_class => 'Moose::Error::Croak',
+ );
+
+ use Moose;
+
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => __PACKAGE__,
+ metaclass_roles => ['Role::Foo'],
+ );
+}
+
+ok( Foo::Sub->meta->error_class->isa('Moose::Error::Croak'),
+ q{Foo::Sub's error_class still isa Moose::Error::Croak} );
+
+{
+ package Foo::Sub::Sub;
+ use Moose;
+
+ ::lives_ok { extends 'Foo::Sub' } 'error_class differs by role so incompat is handled';
+
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => __PACKAGE__,
+ error_class_roles => ['Role::Foo'],
+ );
+}
+
+ok( Foo::Sub::Sub->meta->error_class->meta->does_role('Role::Foo'),
+ q{Foo::Sub::Sub's error_class does Role::Foo} );
+ok( Foo::Sub::Sub->meta->error_class->isa('Moose::Error::Croak'),
+ q{Foo::Sub::Sub's error_class now subclasses Moose::Error::Croak} );
Added: Moose/branches/Moose-XS/t/050_metaclasses/019_create_anon_with_required_attr.t
===================================================================
--- Moose/branches/Moose-XS/t/050_metaclasses/019_create_anon_with_required_attr.t (rev 0)
+++ Moose/branches/Moose-XS/t/050_metaclasses/019_create_anon_with_required_attr.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,87 @@
+#!/usr/bin/perl
+
+# this functionality may be pushing toward parametric roles/classes
+# it's off in a corner and may not be that important
+
+use strict;
+use warnings;
+
+use Test::More tests => 15;
+use Test::Exception;
+
+{
+ package HasFoo;
+ use Moose::Role;
+ has 'foo' => (
+ is => 'ro',
+ isa => 'Str',
+ required => 1,
+ );
+
+}
+
+{
+ package My::Metaclass;
+ use Moose;
+ extends 'Moose::Meta::Class';
+ with 'HasFoo';
+}
+
+package main;
+
+my $anon;
+lives_ok {
+ $anon = My::Metaclass->create_anon_class( foo => 'this' );
+} 'create anon class with required attr';
+isa_ok( $anon, 'My::Metaclass' );
+cmp_ok( $anon->foo, 'eq', 'this', 'foo is this' );
+dies_ok {
+ $anon = My::Metaclass->create_anon_class();
+} 'failed to create anon class without required attr';
+
+my $meta;
+lives_ok {
+ $meta
+ = My::Metaclass->initialize( 'Class::Name1' => ( foo => 'that' ) );
+} 'initialize a class with required attr';
+isa_ok( $meta, 'My::Metaclass' );
+cmp_ok( $meta->foo, 'eq', 'that', 'foo is that' );
+cmp_ok( $meta->name, 'eq', 'Class::Name1', 'for the correct class' );
+dies_ok {
+ $meta
+ = My::Metaclass->initialize( 'Class::Name2' );
+} 'failed to initialize a class without required attr';
+
+lives_ok {
+ eval qq{
+ package Class::Name3;
+ use metaclass 'My::Metaclass' => (
+ foo => 'another',
+ );
+ use Moose;
+ };
+ die $@ if $@;
+} 'use metaclass with required attr';
+$meta = Class::Name3->meta;
+isa_ok( $meta, 'My::Metaclass' );
+cmp_ok( $meta->foo, 'eq', 'another', 'foo is another' );
+cmp_ok( $meta->name, 'eq', 'Class::Name3', 'for the correct class' );
+dies_ok {
+ eval qq{
+ package Class::Name4;
+ use metaclass 'My::Metaclass';
+ use Moose;
+ };
+ die $@ if $@;
+} 'failed to use metaclass without required attr';
+
+
+# how do we pass a required attribute to -traits?
+dies_ok {
+ eval qq{
+ package Class::Name5;
+ use Moose -traits => 'HasFoo';
+ };
+ die $@ if $@;
+} 'failed to use trait without required attr';
+
Added: Moose/branches/Moose-XS/t/050_metaclasses/020_metaclass_parameterized_traits.t
===================================================================
--- Moose/branches/Moose-XS/t/050_metaclasses/020_metaclass_parameterized_traits.t (rev 0)
+++ Moose/branches/Moose-XS/t/050_metaclasses/020_metaclass_parameterized_traits.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,29 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More skip_all => "Feature not implemented yet";
+#use Test::More tests => 1;
+
+{
+ package My::Trait;
+ use Moose::Role;
+
+ sub reversed_name {
+ my $self = shift;
+ scalar reverse $self->name;
+ }
+}
+
+{
+ package My::Class;
+ use Moose -traits => [
+ 'My::Trait' => {
+ alias => {
+ reversed_name => 'enam',
+ },
+ },
+ ];
+}
+
+is(My::Class->meta->enam, 'ssalC::yM', 'parameterized trait applied');
+
Modified: Moose/branches/Moose-XS/t/060_compat/003_foreign_inheritence.t
===================================================================
--- Moose/branches/Moose-XS/t/060_compat/003_foreign_inheritence.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/060_compat/003_foreign_inheritence.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -80,6 +80,6 @@
} 'Immutability on Moose class extending Class::MOP class ok';
lives_ok {
- SubClass2->meta->superclasses([ 'MyBase' ]);
+ SubClass2->meta->superclasses('MyBase');
} 'Can subclass the same non-Moose class twice with different metaclasses';
Modified: Moose/branches/Moose-XS/t/100_bugs/011_DEMOLISH_eats_exceptions.t
===================================================================
--- Moose/branches/Moose-XS/t/100_bugs/011_DEMOLISH_eats_exceptions.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/100_bugs/011_DEMOLISH_eats_exceptions.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -11,7 +11,7 @@
subtype 'FilePath'
=> as 'Str'
- => where { $_ =~ m#^(/[a-zA-Z0-9_.-]+)+$#
+ => where { $_ =~ m#^(/[a-zA-Z0-9_.-]+)+/?$#
|| $_ =~ m#^([c-zC-Z]:/[a-zA-Z0-9_.-]+)# };
{
package Baz;
Modified: Moose/branches/Moose-XS/t/100_bugs/017_type_constraint_messages.t
===================================================================
--- Moose/branches/Moose-XS/t/100_bugs/017_type_constraint_messages.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/100_bugs/017_type_constraint_messages.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More no_plan => 1;
+use Test::More tests => 3;
use Test::Exception;
@@ -53,16 +53,21 @@
my $foo = Foo->new;
my $obj = MyObject->new;
-throws_ok {
- $foo->ar([]);
-} qr/Attribute \(ar\) does not pass the type constraint because: ref: ARRAY/, '... got the right error message';
+throws_ok {
+ $foo->ar( [] );
+}
+qr/Attribute \(ar\) does not pass the type constraint because: ref: ARRAY/,
+ '... got the right error message';
-throws_ok {
- $foo->obj($foo); # Doh!
-} qr/Attribute \(obj\) does not pass the type constraint because: Well it is an object/, '... got the right error message';
+throws_ok {
+ $foo->obj($foo); # Doh!
+}
+qr/Attribute \(obj\) does not pass the type constraint because: Well it is an object/,
+ '... got the right error message';
-throws_ok {
- $foo->nt($foo); # scalar
-} qr/Attribute \(nt\) does not pass the type constraint because: blessed/, '... got the right error message';
+throws_ok {
+ $foo->nt($foo); # scalar
+}
+qr/Attribute \(nt\) does not pass the type constraint because: blessed/,
+ '... got the right error message';
-
Added: Moose/branches/Moose-XS/t/100_bugs/019_moose_octal_defaults.t
===================================================================
--- Moose/branches/Moose-XS/t/100_bugs/019_moose_octal_defaults.t (rev 0)
+++ Moose/branches/Moose-XS/t/100_bugs/019_moose_octal_defaults.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,117 @@
+#!/usr/bin/env perl
+use Test::More qw(no_plan);
+
+{
+ my $package = qq{
+package Test::Moose::Go::Boom;
+use Moose;
+use lib qw(lib);
+
+has id => (
+ isa => 'Str',
+ is => 'ro',
+ default => '019600', # this caused the original failure
+);
+
+no Moose;
+
+__PACKAGE__->meta->make_immutable;
+};
+
+ eval $package;
+ $@ ? ::fail($@) : ::pass('quoted 019600 default works');
+ my $obj = Test::Moose::Go::Boom->new;
+ ::is( $obj->id, '019600', 'value is still the same' );
+}
+
+{
+ my $package = qq{
+package Test::Moose::Go::Boom2;
+use Moose;
+use lib qw(lib);
+
+has id => (
+ isa => 'Str',
+ is => 'ro',
+ default => 017600,
+);
+
+no Moose;
+
+__PACKAGE__->meta->make_immutable;
+};
+
+ eval $package;
+ $@ ? ::fail($@) : ::pass('017600 octal default works');
+ my $obj = Test::Moose::Go::Boom2->new;
+ ::is( $obj->id, 8064, 'value is still the same' );
+}
+
+{
+ my $package = qq{
+package Test::Moose::Go::Boom3;
+use Moose;
+use lib qw(lib);
+
+has id => (
+ isa => 'Str',
+ is => 'ro',
+ default => 0xFF,
+);
+
+no Moose;
+
+__PACKAGE__->meta->make_immutable;
+};
+
+ eval $package;
+ $@ ? ::fail($@) : ::pass('017600 octal default works');
+ my $obj = Test::Moose::Go::Boom3->new;
+ ::is( $obj->id, 255, 'value is still the same' );
+}
+
+{
+ my $package = qq{
+package Test::Moose::Go::Boom4;
+use Moose;
+use lib qw(lib);
+
+has id => (
+ isa => 'Str',
+ is => 'ro',
+ default => '0xFF',
+);
+
+no Moose;
+
+__PACKAGE__->meta->make_immutable;
+};
+
+ eval $package;
+ $@ ? ::fail($@) : ::pass('017600 octal default works');
+ my $obj = Test::Moose::Go::Boom4->new;
+ ::is( $obj->id, '0xFF', 'value is still the same' );
+}
+
+{
+ my $package = qq{
+package Test::Moose::Go::Boom5;
+use Moose;
+use lib qw(lib);
+
+has id => (
+ isa => 'Str',
+ is => 'ro',
+ default => '0 but true',
+);
+
+no Moose;
+
+__PACKAGE__->meta->make_immutable;
+};
+
+ eval $package;
+ $@ ? ::fail($@) : ::pass('017600 octal default works');
+ my $obj = Test::Moose::Go::Boom5->new;
+ ::is( $obj->id, '0 but true', 'value is still the same' );
+}
\ No newline at end of file
Added: Moose/branches/Moose-XS/t/100_bugs/020_super_recursion.t
===================================================================
--- Moose/branches/Moose-XS/t/100_bugs/020_super_recursion.t (rev 0)
+++ Moose/branches/Moose-XS/t/100_bugs/020_super_recursion.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,67 @@
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+
+{
+ package A;
+ use Moose;
+
+ sub foo {
+ ::BAIL_OUT('A::foo called twice') if $main::seen{'A::foo'}++;
+ return 'a';
+ }
+
+ sub bar {
+ ::BAIL_OUT('A::bar called twice') if $main::seen{'A::bar'}++;
+ return 'a';
+ }
+
+ sub baz {
+ ::BAIL_OUT('A::baz called twice') if $main::seen{'A::baz'}++;
+ return 'a';
+ }
+}
+
+{
+ package B;
+ use Moose;
+ extends qw(A);
+
+ sub foo {
+ ::BAIL_OUT('B::foo called twice') if $main::seen{'B::foo'}++;
+ return 'b' . super();
+ }
+
+ sub bar {
+ ::BAIL_OUT('B::bar called twice') if $main::seen{'B::bar'}++;
+ return 'b' . ( super() || '' );
+ }
+
+ override baz => sub {
+ ::BAIL_OUT('B::baz called twice') if $main::seen{'B::baz'}++;
+ return 'b' . super();
+ };
+}
+
+{
+ package C;
+ use Moose;
+ extends qw(B);
+
+ sub foo { return 'c' . ( super() || '' ) }
+
+ override bar => sub {
+ ::BAIL_OUT('C::bar called twice') if $main::seen{'C::bar'}++;
+ return 'c' . super();
+ };
+
+ override baz => sub {
+ ::BAIL_OUT('C::baz called twice') if $main::seen{'C::baz'}++;
+ return 'c' . super();
+ };
+}
+
+is( C->new->foo, 'c' );
+is( C->new->bar, 'cb' );
+is( C->new->baz, 'cba' );
Modified: Moose/branches/Moose-XS/t/300_immutable/004_inlined_constructors_n_types.t
===================================================================
--- Moose/branches/Moose-XS/t/300_immutable/004_inlined_constructors_n_types.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/300_immutable/004_inlined_constructors_n_types.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -44,8 +44,8 @@
my $mutable_string = $is_immutable ? 'immutable' : 'mutable';
lives_ok {
my $f = Foo->new(foo => 10, bar => "Hello World", baz => 10, zot => 4);
- is($f->moo, 69, "Type coersion works as expected on default ($mutable_string)");
- is($f->boo, 69, "Type coersion works as expected on builder ($mutable_string)");
+ is($f->moo, 69, "Type coercion works as expected on default ($mutable_string)");
+ is($f->boo, 69, "Type coercion works as expected on builder ($mutable_string)");
} "... this passes the constuctor correctly ($mutable_string)";
lives_ok {
Deleted: Moose/branches/Moose-XS/t/300_immutable/006_immutable_nonmoose_subclass.t
===================================================================
--- Moose/branches/Moose-XS/t/300_immutable/006_immutable_nonmoose_subclass.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/300_immutable/006_immutable_nonmoose_subclass.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -1,94 +0,0 @@
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 8;
-use Test::Exception;
-use Scalar::Util 'blessed';
-
-=pod
-
-This test it kind of odd, it tests
-to see if make_immutable will DWIM
-when pressented with a class that
-inherits from a non-Moose base class.
-
-Since immutable only affects the local
-class, and if it doesnt find a constructor
-it will always create one, it won't
-discover this issue, and it will ignore
-the inherited constructor.
-
-This is not really the desired way, but
-detecting this opens a big can of worms
-which we are not going to deal with just
-yet (eventually yes, but most likely it
-will be when we have MooseX::Compile
-available and working).
-
-In the meantime, just know that when you
-call make_immutable on a class which
-inherits from a non-Moose class, you
-should add (inline_constructor => 0).
-
-Sorry Sartak.
-
-=cut
-
-{
- package Grandparent;
-
- sub new {
- my $class = shift;
- my %args = (
- grandparent => 'gramma',
- @_,
- );
-
- bless \%args => $class;
- }
-
- sub grandparent { 1 }
-}
-
-{
- package Parent;
- use Moose;
- extends 'Grandparent';
-
- around new => sub {
- my $orig = shift;
- my $class = shift;
-
- $class->$orig(
- parent => 'mama',
- @_,
- );
- };
-
- sub parent { 1 }
-}
-
-{
- package Child;
- use Moose;
- extends 'Parent';
-
- sub child { 1 }
-
- __PACKAGE__->meta->make_immutable;
-}
-
-is(blessed(Grandparent->new), "Grandparent", "got a Grandparent object out of Grandparent->new");
-is(blessed(Parent->new), "Parent", "got a Parent object out of Parent->new");
-is(blessed(Child->new), "Child", "got a Child object out of Child->new");
-
-is(Child->new->grandparent, 1, "Child responds to grandparent");
-is(Child->new->parent, 1, "Child responds to parent");
-is(Child->new->child, 1, "Child responds to child");
-
-is(Child->new->{grandparent}, undef, "didnt create a value, cause immutable overode the constructor");
-is(Child->new->{parent}, undef, "didnt create a value, cause immutable overode the constructor");
-
-
Added: Moose/branches/Moose-XS/t/300_immutable/010_constructor_is_not_moose.t
===================================================================
--- Moose/branches/Moose-XS/t/300_immutable/010_constructor_is_not_moose.t (rev 0)
+++ Moose/branches/Moose-XS/t/300_immutable/010_constructor_is_not_moose.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,104 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+eval "use Test::Output";
+plan skip_all => "Test::Output is required for this test" if $@;
+
+plan tests => 6;
+
+{
+ package NotMoose;
+
+ sub new {
+ my $class = shift;
+
+ return bless { not_moose => 1 }, $class;
+ }
+}
+
+{
+ package Foo;
+ use Moose;
+
+ extends 'NotMoose';
+
+ ::stderr_is(
+ sub { Foo->meta->make_immutable },
+ "Not inlining a constructor for Foo since it is not inheriting the default Moose::Object constructor\n",
+ 'got a warning that Foo may not have an inlined constructor'
+ );
+}
+
+is(
+ Foo->meta->find_method_by_name('new')->body,
+ NotMoose->can('new'),
+ 'Foo->new is inherited from NotMoose'
+);
+
+{
+ package Bar;
+ use Moose;
+
+ extends 'NotMoose';
+
+ ::stderr_is(
+ sub { Foo->meta->make_immutable( replace_constructor => 1 ) },
+ q{},
+ 'no warning when replace_constructor is true'
+ );
+}
+
+isnt(
+ Bar->meta->find_method_by_name('new')->body,
+ Moose::Object->can('new'),
+ 'Bar->new is not inherited from NotMoose because it was inlined'
+);
+
+{
+ package Baz;
+ use Moose;
+
+ Baz->meta->make_immutable;
+}
+
+{
+ package Quux;
+ use Moose;
+
+ extends 'Baz';
+
+ ::stderr_is(
+ sub { Quux->meta->make_immutable },
+ q{},
+ 'no warning when inheriting from a class that has already made itself immutable'
+ );
+}
+
+{
+ package My::Constructor;
+ use base 'Moose::Meta::Method::Constructor';
+}
+
+{
+ package CustomCons;
+ use Moose;
+
+ CustomCons->meta->make_immutable( constructor_class => 'My::Constructor' );
+}
+
+{
+ package Subclass;
+ use Moose;
+
+ extends 'CustomCons';
+
+ ::stderr_is(
+ sub { Subclass->meta->make_immutable },
+ q{},
+ 'no warning when inheriting from a class that has already made itself immutable'
+ );
+}
Added: Moose/branches/Moose-XS/t/300_immutable/011_constructor_is_wrapped.t
===================================================================
--- Moose/branches/Moose-XS/t/300_immutable/011_constructor_is_wrapped.t (rev 0)
+++ Moose/branches/Moose-XS/t/300_immutable/011_constructor_is_wrapped.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,31 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+eval "use Test::Output";
+plan skip_all => "Test::Output is required for this test" if $@;
+
+plan tests => 1;
+
+{
+ package ModdedNew;
+ use Moose;
+
+ before 'new' => sub { };
+}
+
+{
+ package Foo;
+ use Moose;
+
+ extends 'ModdedNew';
+
+ ::stderr_is(
+ sub { Foo->meta->make_immutable },
+ "Not inlining a constructor for Foo since it is not inheriting the default Moose::Object constructor\n (constructor has method modifiers which would be lost if it were inlined)\n",
+ 'got a warning that Foo may not have an inlined constructor'
+ );
+}
Added: Moose/branches/Moose-XS/t/300_immutable/012_default_values.t
===================================================================
--- Moose/branches/Moose-XS/t/300_immutable/012_default_values.t (rev 0)
+++ Moose/branches/Moose-XS/t/300_immutable/012_default_values.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,64 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 12;
+use Test::Exception;
+
+{
+
+ package Foo;
+ use Moose;
+
+ has 'foo' => ( is => 'rw', default => q{'} );
+ has 'bar' => ( is => 'rw', default => q{\\} );
+ has 'baz' => ( is => 'rw', default => q{"} );
+ has 'buz' => ( is => 'rw', default => q{"'\\} );
+ has 'faz' => ( is => 'rw', default => qq{\0} );
+
+ ::lives_ok { __PACKAGE__->meta->make_immutable }
+ 'no errors making a package immutable when it has default values that could break quoting';
+}
+
+my $foo = Foo->new;
+is( $foo->foo, q{'},
+ 'default value for foo attr' );
+is( $foo->bar, q{\\},
+ 'default value for bar attr' );
+is( $foo->baz, q{"},
+ 'default value for baz attr' );
+is( $foo->buz, q{"'\\},
+ 'default value for buz attr' );
+is( $foo->faz, qq{\0},
+ 'default value for faz attr' );
+
+
+# Lazy attrs were never broken, but it doesn't hurt to test that they
+# won't be broken by any future changes.
+{
+
+ package Bar;
+ use Moose;
+
+ has 'foo' => ( is => 'rw', default => q{'}, lazy => 1 );
+ has 'bar' => ( is => 'rw', default => q{\\}, lazy => 1 );
+ has 'baz' => ( is => 'rw', default => q{"}, lazy => 1 );
+ has 'buz' => ( is => 'rw', default => q{"'\\}, lazy => 1 );
+ has 'faz' => ( is => 'rw', default => qq{\0}, lazy => 1 );
+
+ ::lives_ok { __PACKAGE__->meta->make_immutable }
+ 'no errors making a package immutable when it has lazy default values that could break quoting';
+}
+
+my $bar = Bar->new;
+is( $bar->foo, q{'},
+ 'default value for foo attr' );
+is( $bar->bar, q{\\},
+ 'default value for bar attr' );
+is( $bar->baz, q{"},
+ 'default value for baz attr' );
+is( $bar->buz, q{"'\\},
+ 'default value for buz attr' );
+is( $bar->faz, qq{\0},
+ 'default value for faz attr' );
Added: Moose/branches/Moose-XS/t/300_immutable/013_immutable_roundtrip.t
===================================================================
--- Moose/branches/Moose-XS/t/300_immutable/013_immutable_roundtrip.t (rev 0)
+++ Moose/branches/Moose-XS/t/300_immutable/013_immutable_roundtrip.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,38 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+eval "use Test::Output";
+plan skip_all => "Test::Output is required for this test" if $@;
+
+plan tests => 1;
+
+{
+ package Foo;
+ use Moose;
+ __PACKAGE__->meta->make_immutable;
+}
+
+{
+ package Bar;
+ use Moose;
+
+ extends 'Foo';
+
+ __PACKAGE__->meta->make_immutable;
+ __PACKAGE__->meta->make_mutable;
+
+
+ # This actually is testing for a bug in Class::MOP that cause
+ # Moose::Meta::Method::Constructor to spit out a warning when it
+ # shouldn't have done so. The bug was fixed in CMOP 0.75.
+ ::stderr_unlike(
+ sub { Bar->meta->make_immutable },
+ qr/Not inlining a constructor/,
+ 'no warning that Bar may not have an inlined constructor'
+ );
+}
+
Added: Moose/branches/Moose-XS/t/400_moose_util/004_resolve_alias.t
===================================================================
--- Moose/branches/Moose-XS/t/400_moose_util/004_resolve_alias.t (rev 0)
+++ Moose/branches/Moose-XS/t/400_moose_util/004_resolve_alias.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,77 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 16;
+
+use Moose::Util qw( resolve_metaclass_alias resolve_metatrait_alias );
+
+use lib 't/lib';
+
+# Doing each test twice is intended to make sure that the caching
+# doesn't break name resolution. It doesn't actually test that
+# anything is cached.
+is( resolve_metaclass_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Foo' ),
+ 'Moose::Meta::Attribute::Custom::Foo',
+ 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Foo' );
+
+is( resolve_metaclass_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Foo' ),
+ 'Moose::Meta::Attribute::Custom::Foo',
+ 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Foo second time' );
+
+is( resolve_metaclass_alias( 'Attribute', 'Foo' ),
+ 'Moose::Meta::Attribute::Custom::Foo',
+ 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Foo via alias (Foo)' );
+
+is( resolve_metaclass_alias( 'Attribute', 'Foo' ),
+ 'Moose::Meta::Attribute::Custom::Foo',
+ 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Foo via alias (Foo) a second time' );
+
+is( resolve_metaclass_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Bar' ),
+ 'My::Bar',
+ 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Bar as My::Bar' );
+
+is( resolve_metaclass_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Bar' ),
+ 'My::Bar',
+ 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Bar as My::Bar a second time' );
+
+is( resolve_metaclass_alias( 'Attribute', 'Bar' ),
+ 'My::Bar',
+ 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Bar as My::Bar via alias (Bar)' );
+
+is( resolve_metaclass_alias( 'Attribute', 'Bar' ),
+ 'My::Bar',
+ 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Bar as My::Bar via alias (Bar) a second time' );
+
+is( resolve_metatrait_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Trait::Foo' ),
+ 'Moose::Meta::Attribute::Custom::Trait::Foo',
+ 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Foo' );
+
+is( resolve_metatrait_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Trait::Foo' ),
+ 'Moose::Meta::Attribute::Custom::Trait::Foo',
+ 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Foo second time' );
+
+is( resolve_metatrait_alias( 'Attribute', 'Foo' ),
+ 'Moose::Meta::Attribute::Custom::Trait::Foo',
+ 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Foo via alias (Foo)' );
+
+is( resolve_metatrait_alias( 'Attribute', 'Foo' ),
+ 'Moose::Meta::Attribute::Custom::Trait::Foo',
+ 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Foo via alias (Foo) a second time' );
+
+is( resolve_metatrait_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Trait::Bar' ),
+ 'My::Trait::Bar',
+ 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Bar as My::Trait::Bar' );
+
+is( resolve_metatrait_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Trait::Bar' ),
+ 'My::Trait::Bar',
+ 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Bar as My::Trait::Bar a second time' );
+
+is( resolve_metatrait_alias( 'Attribute', 'Bar' ),
+ 'My::Trait::Bar',
+ 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Bar as My::Trait::Bar via alias (Bar)' );
+
+is( resolve_metatrait_alias( 'Attribute', 'Bar' ),
+ 'My::Trait::Bar',
+ 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Bar as My::Trait::Bar via alias (Bar) a second time' );
Modified: Moose/branches/Moose-XS/t/600_todo_tests/002_various_role_shit.t
===================================================================
--- Moose/branches/Moose-XS/t/600_todo_tests/002_various_role_shit.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/600_todo_tests/002_various_role_shit.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -202,13 +202,9 @@
req_or_has($gorch, "gorch_method");
ok( $gorch->has_method("gorch_method"), "has_method gorch_method" );
ok( !$gorch->requires_method("gorch_method"), "requires gorch method" );
+isa_ok( $gorch->get_method("gorch_method"), "Moose::Meta::Method" );
{
- local $TODO = "role method isn't a meta object yet";
- isa_ok( $gorch->get_method("gorch_method"), "Moose::Meta::Method" );
-}
-
-{
local $TODO = "method modifier doesn't yet create a method requirement or meta object";
req_or_has($gorch, "dandy" );
Deleted: Moose/branches/Moose-XS/t/600_todo_tests/004_inlined_constructor_modified_new.t
===================================================================
--- Moose/branches/Moose-XS/t/600_todo_tests/004_inlined_constructor_modified_new.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/600_todo_tests/004_inlined_constructor_modified_new.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -1,48 +0,0 @@
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 6;
-
-my ($around_new);
-{
- package Foo;
- use Moose;
-
- around new => sub { my $o = shift; $around_new = 1; $o->(@_); };
- has 'foo' => (is => 'rw', isa => 'Int');
-
- package Bar;
- use Moose;
- extends 'Foo';
- Bar->meta->make_immutable;
-}
-
-my $orig_new = Foo->meta->find_method_by_name('new');
-isa_ok($orig_new, 'Class::MOP::Method::Wrapped');
-$orig_new = $orig_new->get_original_method;
-isa_ok($orig_new, 'Moose::Meta::Method');
-
-Foo->meta->make_immutable(debug => 0);
-my $inlined_new = Foo->meta->find_method_by_name('new');
-isa_ok($inlined_new, 'Class::MOP::Method::Wrapped');
-$inlined_new = $inlined_new->get_original_method;
-
-TODO:
-{
- local $TODO = 'but it isa Moose::Meta::Method instead';
- isa_ok($inlined_new, 'Moose::Meta::Method::Constructor');
-}
-
-Foo->new(foo => 100);
-ok($around_new, 'around new called');
-
-$around_new = 0;
-Bar->new(foo => 100);
-
-TODO:
-{
- local $TODO = 'but it is not called';
- ok($around_new, 'around new called');
-}
Modified: Moose/branches/Moose-XS/t/600_todo_tests/005_moose_and_threads.t
===================================================================
--- Moose/branches/Moose-XS/t/600_todo_tests/005_moose_and_threads.t 2009-01-17 01:43:52 UTC (rev 7314)
+++ Moose/branches/Moose-XS/t/600_todo_tests/005_moose_and_threads.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More no_plan => 1;
+use Test::More 'no_plan';
use Test::Exception;
Added: Moose/branches/Moose-XS/t/600_todo_tests/006_attr_metaclass_overrides_metarole.t
===================================================================
--- Moose/branches/Moose-XS/t/600_todo_tests/006_attr_metaclass_overrides_metarole.t (rev 0)
+++ Moose/branches/Moose-XS/t/600_todo_tests/006_attr_metaclass_overrides_metarole.t 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,105 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+BEGIN {
+ # attribute metaclass for specifying with 'has'
+ package Foo::Meta::Attribute;
+ use Moose;
+ extends 'Moose::Meta::Attribute';
+
+ around _process_options => sub {
+ my $orig = shift;
+ my ($class, $name, $opts) = @_;
+ my $default = delete $opts->{default};
+ $opts->{default} = sub { $default->() . "1" };
+ $class->$orig($name, $opts);
+ };
+
+ # trait for specifying with has
+ package Foo::Meta::Trait;
+ use Moose::Role;
+
+ around _process_options => sub {
+ my $orig = shift;
+ my ($class, $name, $opts) = @_;
+ my $default = delete $opts->{default};
+ $opts->{default} = sub { $default->() . "2" };
+ $class->$orig($name, $opts);
+ };
+
+ # attribute metaclass role for specifying with MetaRole
+ package Foo::Meta::Role::Attribute;
+ use Moose::Role;
+
+ around _process_options => sub {
+ my $orig = shift;
+ my ($class, $name, $opts) = @_;
+ my $default = delete $opts->{default};
+ $opts->{default} = sub { "3" . $default->() };
+ $class->$orig($name, $opts);
+ };
+
+ package Foose;
+ use Moose ();
+ use Moose::Exporter;
+ use Moose::Util::MetaRole;
+
+ Moose::Exporter->setup_import_methods(also => ['Moose']);
+
+ sub init_meta {
+ shift;
+ my %options = @_;
+ Moose->init_meta(%options);
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => $options{for_class},
+ attribute_metaclass_roles => ['Foo::Meta::Role::Attribute'],
+ );
+ return $options{for_class}->meta;
+ }
+}
+
+# class that uses both
+{
+ package Foo;
+ BEGIN { Foose->import }
+
+ has bar => (
+ is => 'ro',
+ isa => 'Str',
+ lazy => 1,
+ default => sub { 'BAR' },
+ );
+
+ has baz => (
+ metaclass => 'Foo::Meta::Attribute',
+ is => 'ro',
+ isa => 'Str',
+ lazy => 1,
+ default => sub { 'BAZ' },
+ );
+
+ has quux => (
+ traits => ['Foo::Meta::Trait'],
+ is => 'ro',
+ isa => 'Str',
+ lazy => 1,
+ default => sub { 'QUUX' },
+ );
+}
+
+use Test::More tests => 8;
+my $foo = Foo->new;
+is($foo->bar, '3BAR', 'Attribute meta-role applied by exporter');
+ok($foo->meta->get_attribute('bar')->meta->does_role('Foo::Meta::Role::Attribute'), 'normal attribute does the meta-role');
+
+TODO: {
+ local $TODO = 'metaclass on attribute currently overrides attr metarole';
+ is($foo->baz, '3BAZ1', 'Attribute meta role from exporter + metaclass on attribute');
+ ok($foo->meta->get_attribute('baz')->meta->does_role('Foo::Meta::Role::Attribute'), 'attribute using metaclass does the meta-role');
+};
+ok($foo->meta->get_attribute('baz')->isa('Foo::Meta::Attribute'), 'attribute using a metaclass isa the metaclass');
+
+is($foo->quux, '3QUUX2', 'Attribute meta-role + trait');
+ok($foo->meta->get_attribute('quux')->meta->does_role('Foo::Meta::Role::Attribute'), 'attribute using a trait does the meta-role');
+ok($foo->meta->get_attribute('quux')->meta->does_role('Foo::Meta::Trait'), 'attribute using a trait does the trait');
Property changes on: Moose/branches/Moose-XS/t/600_todo_tests/006_attr_metaclass_overrides_metarole.t
___________________________________________________________________
Name: svn:executable
+ *
Added: Moose/branches/Moose-XS/t/lib/Moose/Meta/Attribute/Custom/Bar.pm
===================================================================
--- Moose/branches/Moose-XS/t/lib/Moose/Meta/Attribute/Custom/Bar.pm (rev 0)
+++ Moose/branches/Moose-XS/t/lib/Moose/Meta/Attribute/Custom/Bar.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,10 @@
+package Moose::Meta::Attribute::Custom::Bar;
+
+sub register_implementation { 'My::Bar' }
+
+
+package My::Bar;
+
+use Moose::Role;
+
+1;
Added: Moose/branches/Moose-XS/t/lib/Moose/Meta/Attribute/Custom/Foo.pm
===================================================================
--- Moose/branches/Moose-XS/t/lib/Moose/Meta/Attribute/Custom/Foo.pm (rev 0)
+++ Moose/branches/Moose-XS/t/lib/Moose/Meta/Attribute/Custom/Foo.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,5 @@
+package Moose::Meta::Attribute::Custom::Foo;
+
+use Moose::Role;
+
+1;
Added: Moose/branches/Moose-XS/t/lib/Moose/Meta/Attribute/Custom/Trait/Bar.pm
===================================================================
--- Moose/branches/Moose-XS/t/lib/Moose/Meta/Attribute/Custom/Trait/Bar.pm (rev 0)
+++ Moose/branches/Moose-XS/t/lib/Moose/Meta/Attribute/Custom/Trait/Bar.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,10 @@
+package Moose::Meta::Attribute::Custom::Trait::Bar;
+
+sub register_implementation { 'My::Trait::Bar' }
+
+
+package My::Trait::Bar;
+
+use Moose::Role;
+
+1;
Added: Moose/branches/Moose-XS/t/lib/Moose/Meta/Attribute/Custom/Trait/Foo.pm
===================================================================
--- Moose/branches/Moose-XS/t/lib/Moose/Meta/Attribute/Custom/Trait/Foo.pm (rev 0)
+++ Moose/branches/Moose-XS/t/lib/Moose/Meta/Attribute/Custom/Trait/Foo.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,5 @@
+package Moose::Meta::Attribute::Custom::Trait::Foo;
+
+use Moose::Role;
+
+1;
Added: Moose/branches/Moose-XS/t/lib/MyMetaclassRole.pm
===================================================================
--- Moose/branches/Moose-XS/t/lib/MyMetaclassRole.pm (rev 0)
+++ Moose/branches/Moose-XS/t/lib/MyMetaclassRole.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,4 @@
+package MyMetaclassRole;
+use Moose::Role;
+
+1;
Added: Moose/branches/Moose-XS/t/lib/Role/Child.pm
===================================================================
--- Moose/branches/Moose-XS/t/lib/Role/Child.pm (rev 0)
+++ Moose/branches/Moose-XS/t/lib/Role/Child.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,8 @@
+package Role::Child;
+use Moose::Role;
+
+with 'Role::Parent' => { alias => { meth1 => 'aliased_meth1', } };
+
+sub meth1 { }
+
+1;
Added: Moose/branches/Moose-XS/t/lib/Role/Interface.pm
===================================================================
--- Moose/branches/Moose-XS/t/lib/Role/Interface.pm (rev 0)
+++ Moose/branches/Moose-XS/t/lib/Role/Interface.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,6 @@
+package Role::Interface;
+use Moose::Role;
+
+requires "meth2";
+
+1;
Added: Moose/branches/Moose-XS/t/lib/Role/Parent.pm
===================================================================
--- Moose/branches/Moose-XS/t/lib/Role/Parent.pm (rev 0)
+++ Moose/branches/Moose-XS/t/lib/Role/Parent.pm 2009-01-17 20:17:26 UTC (rev 7315)
@@ -0,0 +1,7 @@
+package Role::Parent;
+use Moose::Role;
+
+sub meth2 { }
+sub meth1 { }
+
+1;
More information about the Moose-commits
mailing list