--- /dev/null
+# auto-generated shipit config file.
+steps = FindVersion, ChangeVersion, CheckChangeLog, DistTest, Commit, Tag, MakeDist, DistClean
+
+svn.tagpattern = %v
+svn.tagpattern = http://code2.0beta.co.uk/moose/svn/Moose/tags/%v
+
+CheckChangeLog.files = Changes
Revision history for Perl extension Moose
-0.51
+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)
+
+ * Moose::Util::TypeConstraints
+ - Fix warnings from find_type_constraint if the type is not
+ found (t0m).
+
+ * Moose::Meta::TypeConstraint
+ - Predicate methods (equals/is_a_type_of/is_subtype_of) now
+ return false if the type you specify cannot be found in the
+ type registry, rather than throwing an unhelpful and
+ coincidental exception. (t0m).
+ - added docs & test for this (t0m)
+
+ * Moose::Meta::TypeConstraint::Registry
+ - add_type_constraint now throws an exception if a parameter is
+ not supplied (t0m).
+ - 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
+
+ !! Calling Moose::init_meta as a function is now !!
+ !! deprecated. Please see the Moose.pm docs for details. !!
+
+ * Moose::Meta::Method::Constructor
+ - Fix inlined constructor so that values produced by default
+ or builder methods are coerced as required. (t0m)
+ - added test for this (t0m)
+
+ * Moose::Meta::Attribute
+ - A lazy attribute with a default or builder did not attempt to
+ coerce the default value. The immutable code _did_
+ coerce. (t0m)
+ - added test for this (t0m)
+
+ * Moose::Exporter
+ - This is a new helper module for writing "Moose-alike"
+ modules. This should make the lives of MooseX module authors
+ much easier. (Dave Rolsky)
+
+ * Moose
+ * Moose::Cookbook::Meta::Recipe5
+ - Implemented metaclass traits (and wrote a recipe for it):
+
+ use Moose -traits => 'Foo'
+
+ This should make writing small Moose extensions a little
+ easier (Dave Rolsky)
+
+ * Moose::Cookbook::Basics::Recipe1
+ - Removed any examples of direct hashref access, and applied an
+ editorial axe to reduce verbosity. (Dave Rolsky)
+
+ * Moose::Cookbook::Basics::Recipe1
+ - Also applied an editorial axe here. (Dave Rolsky)
+
+ * Moose
+ * Moose::Cookbook::Extending::Recipe1
+ * Moose::Cookbook::Extending::Recipe2
+ - Rewrote extending and embedding moose documentation and
+ recipes to use Moose::Exporter (Dave Rolsky)
+
+ * Moose
+ * Moose::Role
+ - These two modules now warn when you load them from the main
+ package "main" package, because we will not export sugar to
+ main. Previously it just did nothing. (Dave Rolsky)
+
+ * Moose::Role
+ - Now provide an init_meta method just like Moose.pm, and you
+ can call this to provide an alternate role metaclass. (Dave
+ Rolsky and nothingmuch)
+ - get_method_map now respects the package cache flag (nothingmuch)
+
+ * Moose::Meta::Role
+ - Two new methods - add_method and wrap_method_body
+ (nothingmuch)
+
+ * many modules
+ - Optimizations including allowing constructors to accept hash
+ refs, making many more classes immutable, and making
+ constructors immutable. (nothingmuch)
+
+0.55 Sun August 3, 2008
+ * Moose::Meta::Attribute
+ - breaking down the way 'handles' methods are
+ created so that the process can be more easily
+ overridden by subclasses (stevan)
+
+ * Moose::Meta::TypeConstraint
+ - fixing what is passed into a ->message with
+ the type constraints (RT #37569)
+ - added tests for this (Charles Alderman)
+
+ * Moose::Util::TypeConstraints
+ - fix coerce to accept anon types like subtype can (mst)
+
+ * Moose::Cookbook
+ - reorganized the recipes into sections - Basics, Roles, Meta,
+ Extending - and wrote abstracts for each section (Dave Rolsky)
+
+ * Moose::Cookbook::Basics::Recipe10
+ - A new recipe that demonstrates operator overloading
+ in combination with Moose. (bluefeet)
+
+ * Moose::Cookbook::Meta::Recipe1
+ - an introduction to what meta is and why you'd want to make
+ your own metaclass extensions (Dave Rolsky)
+
+ * Moose::Cookbook::Meta::Recipe4
+ - a very simple metaclass example (Dave Rolsky)
+
+ * Moose::Cookbook::Extending::Recipe1
+ - how to write a Moose-alike module to use your own object base
+ class (Dave Rolsky)
+
+ * Moose::Cookbook::Extending::Recipe2
+ - how to write modules with an API just like C<Moose.pm> (Dave
+ Rolsky)
+
+ * all documentation
+ - Tons of fixes, both syntactical and grammatical (Dave
+ Rolsky, Paul Fenwick)
+
+0.54 Thurs. July 3, 2008
+ ... this is not my day today ...
+
+ * Moose::Meta::Attribute
+ - fixed legal_options_for_inheritance such that
+ clone_and_inherit options still works for
+ Class::MOP::Attribute objects and therefore
+ does not break MooseX::AttributeHelpers
+ (stevan)
+
+0.53 Thurs. July 3, 2008
+ * Whoops, I guess I should run 'make manifest' before
+ actually releasing the module. No actual changes
+ in this release, except the fact that it includes
+ the changes that I didn't include in the last
+ release. (stevan--)
+
+0.52 Thurs. July 3, 2008
+ * Moose
+ - added "FEATURE REQUESTS" section to the Moose docs
+ to properly direct people (stevan) (RT #34333)
+ - making 'extends' croak if it is passed a Role since
+ this is not ever something you want to do
+ (fixed by stevan, found by obra)
+ - added tests for this (stevan)
+
+ * Moose::Object
+ - adding support for DOES (as in UNIVERSAL::DOES)
+ (nothingmuch)
+ - added test for this
+
+ * Moose::Meta::Attribute
+ - added legal_options_for_inheritance (wreis)
+ - added tests for this (wreis)
+
+ * Moose::Cookbook::Snacks::*
+ - removed some of the unfinished snacks that should
+ not have been released yet. Added some more examples
+ to the 'Keywords' snack. (stevan)
+
+ * Moose::Cookbook::Style
+ - added general Moose "style guide" of sorts to the
+ cookbook (nothingmuch) (RT #34335)
+
+ * t/
+ - added more BUILDARGS tests (stevan)
+
+0.51 Thurs. Jun 26, 2008
* Moose::Role
- add unimport so "no Moose::Role" actually does
something (sartak)
* Moose::Meta::Attribute
- added support for meta_attr->does("ShortAlias") (sartak)
- added tests for this (sartak)
+ - moved the bulk of the `handles` handling to the new
+ install_delegation method (Stevan)
* Moose::Object
+ - Added BUILDARGS, a new step in new()
+
* Moose::Meta::Role::Application::RoleSummation
- fix typos no one ever sees (sartak)
+ * Moose::Util::TypeConstraints
+ * Moose::Meta::TypeConstraint
+ * Moose::Meta::TypeCoercion
+ - Attempt to work around the ??{ } vs. threads issue
+ (not yet fixed)
+ - Some null_constraint optimizations
+
0.50 Thurs. Jun 11, 2008
- Fixed a version number issue by bumping all modules
to 0.50.
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
* 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
Changes
doap.rdf
-inc/Module/AutoInstall.pm
inc/Module/Install.pm
-inc/Module/Install/AutoInstall.pm
inc/Module/Install/Base.pm
inc/Module/Install/Can.pm
inc/Module/Install/Fetch.pm
-inc/Module/Install/Include.pm
inc/Module/Install/Makefile.pm
inc/Module/Install/Metadata.pm
inc/Module/Install/Win32.pm
inc/Module/Install/WriteAll.pm
lib/Moose.pm
lib/Moose/Cookbook.pod
+lib/Moose/Cookbook/Basics/Recipe1.pod
+lib/Moose/Cookbook/Basics/Recipe10.pod
+lib/Moose/Cookbook/Basics/Recipe2.pod
+lib/Moose/Cookbook/Basics/Recipe3.pod
+lib/Moose/Cookbook/Basics/Recipe4.pod
+lib/Moose/Cookbook/Basics/Recipe5.pod
+lib/Moose/Cookbook/Basics/Recipe6.pod
+lib/Moose/Cookbook/Basics/Recipe7.pod
+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/Recipe1.pod
-lib/Moose/Cookbook/Recipe10.pod
-lib/Moose/Cookbook/Recipe11.pod
-lib/Moose/Cookbook/Recipe2.pod
-lib/Moose/Cookbook/Recipe21.pod
-lib/Moose/Cookbook/Recipe22.pod
-lib/Moose/Cookbook/Recipe3.pod
-lib/Moose/Cookbook/Recipe4.pod
-lib/Moose/Cookbook/Recipe5.pod
-lib/Moose/Cookbook/Recipe6.pod
-lib/Moose/Cookbook/Recipe7.pod
-lib/Moose/Cookbook/Recipe9.pod
-lib/Moose/Cookbook/Snack/ArrayRef.pod
-lib/Moose/Cookbook/Snack/BUILD.pod
-lib/Moose/Cookbook/Snack/HashRef.pod
+lib/Moose/Cookbook/Meta/Recipe1.pod
+lib/Moose/Cookbook/Meta/Recipe2.pod
+lib/Moose/Cookbook/Meta/Recipe3.pod
+lib/Moose/Cookbook/Meta/Recipe4.pod
+lib/Moose/Cookbook/Meta/Recipe5.pod
+lib/Moose/Cookbook/Roles/Recipe1.pod
+lib/Moose/Cookbook/Roles/Recipe2.pod
lib/Moose/Cookbook/Snack/Keywords.pod
-lib/Moose/Cookbook/Snack/Perl5ObjsVsMooseObjs.pod
lib/Moose/Cookbook/Snack/Types.pod
+lib/Moose/Cookbook/Style.pod
lib/Moose/Cookbook/WTF.pod
+lib/Moose/Exporter.pm
lib/Moose/Meta/Attribute.pm
lib/Moose/Meta/Class.pm
lib/Moose/Meta/Instance.pm
lib/Moose/Role.pm
lib/Moose/Spec/Role.pod
lib/Moose/Util.pm
+lib/Moose/Util/MetaRole.pm
lib/Moose/Util/TypeConstraints.pm
lib/Moose/Util/TypeConstraints/OptimizedConstraints.pm
lib/oose.pm
META.yml
README
t/000_load.t
-t/000_recipes/001_point.t
-t/000_recipes/002_bank_account.t
-t/000_recipes/003_binary_tree.t
-t/000_recipes/004_company.t
-t/000_recipes/005_coercion.t
-t/000_recipes/006_augment_inner.t
-t/000_recipes/010_roles.t
-t/000_recipes/011_advanced_role_composition.t
-t/000_recipes/021_meta_attribute.t
-t/000_recipes/022_attribute_trait.t
+t/000_recipes/basics/001_point.t
+t/000_recipes/basics/002_bank_account.t
+t/000_recipes/basics/003_binary_tree.t
+t/000_recipes/basics/004_company.t
+t/000_recipes/basics/005_coercion.t
+t/000_recipes/basics/006_augment_inner.t
+t/000_recipes/basics/010_genes.t
+t/000_recipes/extending/001_base_class.t
+t/000_recipes/extending/002_metaclass_and_sugar.t
+t/000_recipes/meta/002_meta_attribute.t
+t/000_recipes/meta/003_attribute_trait.t
+t/000_recipes/roles/001_roles.t
+t/000_recipes/roles/002_advanced_role_composition.t
t/010_basics/001_basic_class_setup.t
t/010_basics/002_require_superclasses.t
t/010_basics/003_super_and_override.t
t/010_basics/012_rebless.t
t/010_basics/013_create.t
t/010_basics/014_create_anon.t
+t/010_basics/015_buildargs.t
+t/010_basics/016_load_into_main.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
t/020_attributes/019_attribute_lazy_initializer.t
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/030_roles/001_meta_role.t
t/030_roles/002_role.t
t/030_roles/003_apply_role.t
t/030_roles/016_runtime_roles_and_nonmoose.t
t/030_roles/017_extending_role_attrs.t
t/030_roles/018_runtime_roles_w_params.t
+t/030_roles/019_build.t
t/030_roles/020_role_composite.t
t/030_roles/021_role_composite_exclusion.t
t/030_roles/022_role_composition_req_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/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
t/040_type_constraints/022_custom_type_errors.t
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/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
t/050_metaclasses/004_moose_for_meta.t
-t/050_metaclasses/010_extending_and_embedding.t
+t/050_metaclasses/010_extending_and_embedding_back_compat.t
t/050_metaclasses/011_init_meta.t
+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/060_compat/001_module_refresh_compat.t
t/060_compat/002_moose_respects_base.t
t/060_compat/003_foreign_inheritence.t
t/100_bugs/012_DEMOLISH_eats_mini.t
t/100_bugs/013_lazybuild_required_undef.t
t/100_bugs/014_DEMOLISHALL.t
+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/200_examples/001_example.t
t/200_examples/002_example_Moose_POOP.t
t/200_examples/003_example.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/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/500_test_moose/002_test_moose_does_ok.t
t/500_test_moose/003_test_moose_has_attribute_ok.t
t/500_test_moose/004_test_moose_meta_ok.t
+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/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
^\.#
^TODO$
^PLANS$
+^doc/
^benchmarks
-^\._.*$
\ No newline at end of file
+^\._.*$
+^t\/600_todo_tests\/$
+\.shipit
use strict;
use warnings;
-use inc::Module::Install 0.75;
+use inc::Module::Install;
name 'Moose';
all_from 'lib/Moose.pm';
my $win32 = !! ( $^O eq 'Win32' or $^O eq 'cygwin' );
# prereqs
+requires 'perl' => '5.008';
requires 'Scalar::Util' => $win32 ? '1.17' : '1.18';
requires 'Carp';
-requires 'Class::MOP' => '0.59';
-requires 'Sub::Exporter' => '0.972';
+requires 'Class::MOP' => '0.65';
+requires 'List::MoreUtils';
+requires 'Sub::Exporter' => '0.972';
# only used by oose.pm, not Moose.pm :P
requires 'Filter::Simple' => '0';
tests_recursive;
-auto_install;
-
WriteAll();
-Moose version 0.50
+Moose version 0.57
===========================
See the individual module documentation for more information
--- /dev/null
+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
use strict;
use warnings;
-our $VERSION = '0.50';
+use 5.008;
+
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Scalar::Util 'blessed';
use Carp 'confess', 'croak', 'cluck';
-use Sub::Exporter;
+use Moose::Exporter;
-use Class::MOP;
+use Class::MOP 0.65;
use Moose::Meta::Class;
use Moose::Meta::TypeConstraint;
use Moose::Meta::Attribute;
use Moose::Meta::Instance;
+use Moose::Object;
+
use Moose::Meta::Role;
+use Moose::Meta::Role::Composite;
+use Moose::Meta::Role::Application;
+use Moose::Meta::Role::Application::RoleSummation;
+use Moose::Meta::Role::Application::ToClass;
+use Moose::Meta::Role::Application::ToRole;
+use Moose::Meta::Role::Application::ToInstance;
-use Moose::Object;
use Moose::Util::TypeConstraints;
use Moose::Util ();
-{
- my $CALLER;
-
- sub init_meta {
- my ( $class, $base_class, $metaclass ) = @_;
- $base_class = 'Moose::Object' unless defined $base_class;
- $metaclass = 'Moose::Meta::Class' unless defined $metaclass;
-
- confess
- "The Metaclass $metaclass must be a subclass of Moose::Meta::Class."
- unless $metaclass->isa('Moose::Meta::Class');
-
- # make a subtype for each Moose class
- class_type($class)
- unless find_type_constraint($class);
-
- my $meta;
- if ( $class->can('meta') ) {
- # NOTE:
- # this is the case where the metaclass pragma
- # was used before the 'use Moose' statement to
- # override a specific class
- $meta = $class->meta();
- ( blessed($meta) && $meta->isa('Moose::Meta::Class') )
- || confess "You already have a &meta function, but it does not return a Moose::Meta::Class";
- }
- else {
- # NOTE:
- # this is broken currently, we actually need
- # to allow the possiblity of an inherited
- # meta, which will not be visible until the
- # user 'extends' first. This needs to have
- # more intelligence to it
- $meta = $metaclass->initialize($class);
- $meta->add_method(
- 'meta' => sub {
- # re-initialize so it inherits properly
- $metaclass->initialize( blessed( $_[0] ) || $_[0] );
- }
- );
- }
+sub extends {
+ my $class = shift;
- # make sure they inherit from Moose::Object
- $meta->superclasses($base_class)
- unless $meta->superclasses();
-
- return $meta;
+ croak "Must derive at least one class" unless @_;
+
+ my @supers = @_;
+ foreach my $super (@supers) {
+ Class::MOP::load_class($super);
+ croak "You cannot inherit from a Moose Role ($super)"
+ if $super->can('meta') &&
+ blessed $super->meta &&
+ $super->meta->isa('Moose::Meta::Role')
}
- my %exports = (
- extends => sub {
- my $class = $CALLER;
- return Class::MOP::subname('Moose::extends' => sub (@) {
- croak "Must derive at least one class" unless @_;
-
- my @supers = @_;
- foreach my $super (@supers) {
- Class::MOP::load_class($super);
- }
- # 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 = $class->meta->_fix_metaclass_incompatability(@supers);
- $meta->superclasses(@supers);
- });
- },
- with => sub {
- my $class = $CALLER;
- return Class::MOP::subname('Moose::with' => sub (@) {
- Moose::Util::apply_all_roles($class->meta, @_)
- });
- },
- has => sub {
- my $class = $CALLER;
- return Class::MOP::subname('Moose::has' => sub ($;%) {
- my $name = shift;
- croak 'Usage: has \'name\' => ( key => value, ... )' if @_ == 1;
- my %options = @_;
- my $attrs = ( ref($name) eq 'ARRAY' ) ? $name : [ ($name) ];
- $class->meta->add_attribute( $_, %options ) for @$attrs;
- });
- },
- before => sub {
- my $class = $CALLER;
- return Class::MOP::subname('Moose::before' => sub (@&) {
- Moose::Util::add_method_modifier($class, 'before', \@_);
- });
- },
- after => sub {
- my $class = $CALLER;
- return Class::MOP::subname('Moose::after' => sub (@&) {
- Moose::Util::add_method_modifier($class, 'after', \@_);
- });
- },
- around => sub {
- my $class = $CALLER;
- return Class::MOP::subname('Moose::around' => sub (@&) {
- Moose::Util::add_method_modifier($class, 'around', \@_);
- });
- },
- super => sub {
- return Class::MOP::subname('Moose::super' => sub {
- return unless our $SUPER_BODY; $SUPER_BODY->(our @SUPER_ARGS)
- });
- },
- override => sub {
- my $class = $CALLER;
- return Class::MOP::subname('Moose::override' => sub ($&) {
- my ( $name, $method ) = @_;
- $class->meta->add_override_method_modifier( $name => $method );
- });
- },
- inner => sub {
- return Class::MOP::subname('Moose::inner' => sub {
- my $pkg = caller();
- our ( %INNER_BODY, %INNER_ARGS );
-
- if ( my $body = $INNER_BODY{$pkg} ) {
- my @args = @{ $INNER_ARGS{$pkg} };
- local $INNER_ARGS{$pkg};
- local $INNER_BODY{$pkg};
- return $body->(@args);
- } else {
- return;
- }
- });
- },
- augment => sub {
- my $class = $CALLER;
- return Class::MOP::subname('Moose::augment' => sub (@&) {
- my ( $name, $method ) = @_;
- $class->meta->add_augment_method_modifier( $name => $method );
- });
- },
- make_immutable => sub {
- my $class = $CALLER;
- return Class::MOP::subname('Moose::make_immutable' => sub {
- cluck "The make_immutable keyword has been deprecated, " .
- "please go back to __PACKAGE__->meta->make_immutable\n";
- $class->meta->make_immutable(@_);
- });
- },
- confess => sub {
- return \&Carp::confess;
- },
- blessed => sub {
- return \&Scalar::Util::blessed;
- },
- );
-
- my $exporter = Sub::Exporter::build_exporter(
- {
- exports => \%exports,
- groups => { default => [':all'] }
- }
- );
-
- # 1 extra level because it's called by import so there's a layer of indirection
- sub _get_caller{
- my $offset = 1;
- return
- (ref $_[1] && defined $_[1]->{into})
- ? $_[1]->{into}
- : (ref $_[1] && defined $_[1]->{into_level})
- ? caller($offset + $_[1]->{into_level})
- : caller($offset);
- }
- sub import {
- $CALLER = _get_caller(@_);
+ # 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);
+ $meta->superclasses(@supers);
+}
- # 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 with {
+ my $class = shift;
+ Moose::Util::apply_all_roles(Class::MOP::Class->initialize($class), @_);
+}
- strict->import;
- warnings->import;
+sub has {
+ my $class = shift;
+ my $name = shift;
+ croak 'Usage: has \'name\' => ( key => value, ... )' if @_ == 1;
+ my %options = @_;
+ my $attrs = ( ref($name) eq 'ARRAY' ) ? $name : [ ($name) ];
+ Class::MOP::Class->initialize($class)->add_attribute( $_, %options ) for @$attrs;
+}
+
+sub before {
+ my $class = shift;
+ Moose::Util::add_method_modifier($class, 'before', \@_);
+}
- # we should never export to main
- return if $CALLER eq 'main';
+sub after {
+ my $class = shift;
+ Moose::Util::add_method_modifier($class, 'after', \@_);
+}
- init_meta( $CALLER, 'Moose::Object' );
+sub around {
+ my $class = shift;
+ Moose::Util::add_method_modifier($class, 'around', \@_);
+}
+
+sub super {
+ return unless our $SUPER_BODY; $SUPER_BODY->(our @SUPER_ARGS);
+}
- goto $exporter;
+sub override {
+ my $class = shift;
+ my ( $name, $method ) = @_;
+ Class::MOP::Class->initialize($class)->add_override_method_modifier( $name => $method );
+}
+
+sub inner {
+ my $pkg = caller();
+ our ( %INNER_BODY, %INNER_ARGS );
+
+ if ( my $body = $INNER_BODY{$pkg} ) {
+ my @args = @{ $INNER_ARGS{$pkg} };
+ local $INNER_ARGS{$pkg};
+ local $INNER_BODY{$pkg};
+ return $body->(@args);
+ } else {
+ return;
}
-
- # NOTE:
- # This is for special use by
- # some modules and stuff, I
- # dont know if it is sane enough
- # to document actually.
- # - SL
- sub __CURRY_EXPORTS_FOR_CLASS__ {
- $CALLER = shift;
- ($CALLER ne 'Moose')
- || croak "_import_into must be called a function, not a method";
- ($CALLER->can('meta') && $CALLER->meta->isa('Class::MOP::Class'))
- || croak "Cannot call _import_into on a package ($CALLER) without a metaclass";
- return map { $_ => $exports{$_}->() } (@_ ? @_ : keys %exports);
+}
+
+sub augment {
+ my $class = shift;
+ my ( $name, $method ) = @_;
+ 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 )
+ ],
+ as_is => [
+ qw( super inner ),
+ \&Carp::confess,
+ \&Scalar::Util::blessed,
+ ],
+);
+
+sub init_meta {
+ # This used to be called as a function. This hack preserves
+ # backwards compatibility.
+ if ( $_[0] ne __PACKAGE__ ) {
+ return __PACKAGE__->init_meta(
+ for_class => $_[0],
+ base_class => $_[1],
+ metaclass => $_[2],
+ );
}
- sub unimport {
- no strict 'refs';
- my $class = _get_caller(@_);
+ shift;
+ my %args = @_;
+
+ my $class = $args{for_class}
+ or confess "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."
+ unless $metaclass->isa('Moose::Meta::Class');
- # loop through the exports ...
- foreach my $name ( keys %exports ) {
+ # make a subtype for each Moose class
+ class_type($class)
+ unless find_type_constraint($class);
+
+ my $meta;
+
+ 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)";
+ }
+ } else {
+ # no metaclass, no 'meta' method
- # if we find one ...
- if ( defined &{ $class . '::' . $name } ) {
- my $keyword = \&{ $class . '::' . $name };
+ # now we check whether our ancestors have metaclass, and if so borrow that
+ my ( undef, @isa ) = @{ $class->mro::get_linear_isa };
- # make sure it is from Moose
- my ($pkg_name) = Class::MOP::get_code_info($keyword);
- next if $pkg_name ne 'Moose';
+ foreach my $ancestor ( @isa ) {
+ my $ancestor_meta = Class::MOP::get_metaclass_by_name($ancestor) || next;
- # and if it is from Moose then undef the slot
- delete ${ $class . '::' }{$name};
+ my $ancestor_meta_class = ($ancestor_meta->is_immutable
+ ? $ancestor_meta->get_mutable_metaclass_name
+ : 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.
+
+ # the case of having an ancestry is not very common, but arises in
+ # e.g. Reaction
+ unless ( $metaclass->isa( $ancestor_meta_class ) ) {
+ if ( $ancestor_meta_class->isa($metaclass) ) {
+ $metaclass = $ancestor_meta_class;
+ }
}
}
+
+ $meta = $metaclass->initialize($class);
+ }
+
+ if ( $class->can('meta') ) {
+ # check 'meta' method
+
+ # it may be inherited
+
+ # NOTE:
+ # this is the case where the metaclass pragma
+ # was used before the 'use Moose' statement to
+ # override a specific class
+ 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)";
+
+ $meta = $method_meta;
+ }
+
+ unless ( $meta->has_method("meta") ) { # don't overwrite
+ # also check for inherited non moose 'meta' method?
+ # FIXME also skip this if the user requested by passing an option
+ $meta->add_method(
+ 'meta' => sub {
+ # re-initialize so it inherits properly
+ $metaclass->initialize( ref($_[0]) || $_[0] );
+ }
+ );
}
+ # make sure they inherit from Moose::Object
+ $meta->superclasses($base_class)
+ unless $meta->superclasses();
+
+ return $meta;
+}
+
+# This may be used in some older MooseX extensions.
+sub _get_caller {
+ goto &Moose::Exporter::_get_caller;
}
## make 'em all immutable
$_->meta->make_immutable(
- inline_constructor => 0,
+ inline_constructor => 1,
+ constructor_name => "_new",
inline_accessors => 1, # these are Class::MOP accessors, so they need inlining
)
- for (
- 'Moose::Meta::Attribute',
- 'Moose::Meta::Class',
- 'Moose::Meta::Instance',
-
- 'Moose::Meta::TypeConstraint',
- 'Moose::Meta::TypeConstraint::Union',
- 'Moose::Meta::TypeConstraint::Parameterized',
- 'Moose::Meta::TypeCoercion',
-
- 'Moose::Meta::Method',
- 'Moose::Meta::Method::Accessor',
- 'Moose::Meta::Method::Constructor',
- 'Moose::Meta::Method::Destructor',
- 'Moose::Meta::Method::Overriden',
-
- 'Moose::Meta::Role',
- 'Moose::Meta::Role::Method',
- 'Moose::Meta::Role::Method::Required',
- );
+ for (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
+
+ Moose::Meta::Method
+ Moose::Meta::Method::Accessor
+ Moose::Meta::Method::Constructor
+ Moose::Meta::Method::Destructor
+ Moose::Meta::Method::Overriden
+ Moose::Meta::Method::Augmented
+
+ Moose::Meta::Role
+ Moose::Meta::Role::Method
+ Moose::Meta::Role::Method::Required
+
+ Moose::Meta::Role::Composite
+
+ Moose::Meta::Role::Application
+ Moose::Meta::Role::Application::RoleSummation
+ Moose::Meta::Role::Application::ToClass
+ Moose::Meta::Role::Application::ToRole
+ Moose::Meta::Role::Application::ToInstance
+));
1;
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.
+
+=head2 New to Moose?
-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.
+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 L<MooseX::> namespace is the official place to find Moose extensions.
-There are a number of these modules out on CPAN right now the best way to
-find them is to search for MooseX:: on search.cpan.org or to look at the
-latest version of L<Task::Moose> which aims to keep an up to date, easily
-installable list of these extensions.
+The C<MooseX::> namespace is the official place to find Moose extensions.
+These extensions can be found on the CPAN. The easiest way to find them
+is to search for them (L<http://search.cpan.org/search?query=MooseX::>),
+or to examine L<Task::Moose> which aims to keep an up-to-date, easily
+installable list of Moose extensions.
=head1 BUILDING CLASSES WITH MOOSE
This will attempt to use coercion with the supplied type constraint to change
the value passed into any accessors or constructors. You B<must> have supplied
-a type constraint in order for this to work. See L<Moose::Cookbook::Recipe5>
+a type constraint in order for this to work. See L<Moose::Cookbook::Basics::Recipe5>
for an example.
=item I<does =E<gt> $role_name>
in the class being delegated to.
This can be very useful for recursive classes like trees. Here is a
-quick example (soon to be expanded into a Moose::Cookbook::Recipe):
+quick example (soon to be expanded into a Moose::Cookbook recipe):
package Tree;
use Moose;
attribute. Custom attribute metaclasses are useful for extending the
capabilities of the I<has> keyword: they are the simplest way to extend the MOP,
but they are still a fairly advanced topic and too much to cover here, see
-L<Moose::Cookbook::Recipe11> for more information.
+L<Moose::Cookbook::Meta::Recipe1> for more information.
The default behavior here is to just load C<$metaclass_name>; however, we also
have a way to alias to a shorter name. This will first look to see if
This tells Moose to take the list of C<@role_names> and apply them to the
attribute meta-object. This is very similar to the I<metaclass> option, but
-allows you to use more than one extension at a time. This too is an advanced
-topic, we don't yet have a cookbook for it though.
+allows you to use more than one extension at a time.
-As with I<metaclass>, the default behavior is to just load C<$role_name>; however,
-we also have a way to alias to a shorter name. This will first look to see if
-B<Moose::Meta::Attribute::Custom::Trait::$role_name> exists. If it does, Moose
-will then check to see if that has the method C<register_implementation>, which
-should return the actual name of the custom attribute trait. If there is no
-C<register_implementation> method, it will fall back to using
-B<Moose::Meta::Attribute::Custom::Trait::$metaclass_name> as the trait name.
+See L<TRAIT NAME RESOLUTION> for details on how a trait name is
+resolved to a class name.
+
+Also see L<Moose::Cookbook::Meta::Recipe3> for a metaclass trait
+example.
=back
package Foo::Role;
use Moose::Role;
-
+
has 'message' => (
is => 'rw',
isa => 'Str',
default => 'Hello, I am a Foo'
);
-
+
package My::Foo;
use Moose;
-
+
with 'Foo::Role';
-
+
has '+message' => (default => 'Hello I am My::Foo');
In this case, we are basically taking the attribute which the role supplied
The keyword C<inner>, much like C<super>, is a no-op outside of the context of
an C<augment> method. You can think of C<inner> as being the inverse of
C<super>; the details of how C<inner> and C<augment> work is best described in
-the L<Moose::Cookbook::Recipe6>.
+the L<Moose::Cookbook::Basics::Recipe6>.
=item B<augment ($name, &sub)>
An C<augment> method, is a way of explicitly saying "I am augmenting this
method from my superclass". Once again, the details of how C<inner> and
-C<augment> work is best described in the L<Moose::Cookbook::Recipe6>.
+C<augment> work is best described in the L<Moose::Cookbook::Basics::Recipe6>.
=item B<confess>
=back
+=head1 METACLASS TRAITS
+
+When you use Moose, you can also specify traits which will be applied
+to your metaclass:
+
+ use Moose -traits => 'My::Trait';
+
+This is very similar to the attribute traits feature. When you do
+this, your class's C<meta> object will have the specified traits
+applied to it. See L<TRAIT NAME RESOLUTION> for more details.
+
+=head1 TRAIT NAME RESOLUTION
+
+By default, when given a trait name, Moose simply tries to load a
+class of the same name. If such a class does not exist, it then looks
+for for a class matching
+B<Moose::Meta::$type::Custom::Trait::$trait_name>. The C<$type>
+variable here will be one of B<Attribute> or B<Class>, depending on
+what the trait is being applied to.
+
+If a class with this long name exists, Moose checks to see if it has
+the method C<register_implementation>. This method is expected to
+return the I<real> class name of the trait. If there is no
+C<register_implementation> method, it will fall back to using
+B<Moose::Meta::$type::Custom::Trait::$trait> as the trait name.
+
+If all this is confusing, take a look at
+L<Moose::Cookbook::Meta::Recipe3>, which demonstrates how to create an
+attribute trait.
+
=head1 UNIMPORTING FUNCTIONS
=head2 B<unimport>
=head1 EXTENDING AND EMBEDDING MOOSE
-Moose also offers some options for extending or embedding it into your own
-framework. The basic premise is to have something that sets up your class'
-metaclass and export the moose declarators (C<has>, C<with>, C<extends>,...).
-Here is an example:
+Moose also offers some options for extending or embedding it into your
+own framework. 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.
- package MyFramework;
- use Moose;
+=head2 B<< Moose->init_meta(for_class => $class, base_class => $baseclass, metaclass => $metaclass) >>
- sub import {
- my $CALLER = caller();
+The C<init_meta> method sets up the metaclass object for the class
+specified by C<for_class>. This method injects a a C<meta> accessor
+into the class so you can get at this object. It also sets the class's
+superclass to C<base_class>, with L<Moose::Object> as the default.
- strict->import;
- warnings->import;
+You can specify an alternate metaclass with the C<metaclass> parameter.
- # we should never export to main
- return if $CALLER eq 'main';
- Moose::init_meta( $CALLER, 'MyFramework::Base' );
- Moose->import({into => $CALLER});
+For more detail on this topic, see L<Moose::Cookbook::Extending::Recipe2>.
- # Do my custom framework stuff
-
- return 1;
- }
+This method used to be documented as a function which accepted
+positional parameters. This calling style will still work for
+backwards compatibility, but is deprecated.
=head2 B<import>
Moose's C<import> method supports the L<Sub::Exporter> form of C<{into =E<gt> $pkg}>
-and C<{into_level =E<gt> 1}>
-
-=head2 B<init_meta ($class, $baseclass, $metaclass)>
+and C<{into_level =E<gt> 1}>.
-Moose does some boot strapping: it creates a metaclass object for your class,
-and then injects a C<meta> accessor into your class to retrieve it. Then it
-sets your baseclass to Moose::Object or the value you pass in unless you already
-have one. This is all done via C<init_meta> which takes the name of your class
-and optionally a baseclass and a metaclass as arguments.
+B<NOTE>: Doing this is more or less deprecated. Use L<Moose::Exporter>
+instead, which lets you stack multiple C<Moose.pm>-alike modules
+sanely. It handles getting the exported functions into the right place
+for you.
=head1 CAVEATS
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
as well as links to a number of talks and articles on Moose and Moose related
technologies.
+=item L<Moose::Cookbook> - How to cook a Moose
+
+=item The Moose is flying, a tutorial by Randal Schwartz
+
+Part 1 - L<http://www.stonehenge.com/merlyn/LinuxMag/col94.html>
+
+Part 2 - L<http://www.stonehenge.com/merlyn/LinuxMag/col95.html>
+
=item L<Class::MOP> documentation
=item The #moose channel on irc.perl.org
=item Moose stats on ohloh.net - L<http://www.ohloh.net/projects/moose>
-=item Several Moose extension modules in the L<MooseX::> namespace.
+=item Several Moose extension modules in the C<MooseX::> namespace.
+
+See L<http://search.cpan.org/search?query=MooseX::> for extensions.
=back
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
+=head1 FEATURE REQUESTS
+
+We are very strict about what features we add to the Moose core, especially
+the user-visible features. Instead we have made sure that the underlying
+meta-system of Moose is as extensible as possible so that you can add your
+own features easily. That said, occasionally there is a feature needed in the
+meta-system to support your planned extension, in which case you should
+either email the mailing list or join us on irc at #moose to discuss.
+
=head1 AUTHOR
Stevan Little E<lt>stevan@iinteractive.comE<gt>
Chris (perigrin) Prather
+Wallace (wreis) Reis
+
Jonathan (jrockway) Rockway
+Dave (autarch) Rolsky
+
Piotr (dexter) Roszatycki
Sam (mugwump) Vilain
=head2 Basic Moose
+These recipes will give you a good idea of what Moose is capable,
+starting with simple attribute declaration, and moving on to more
+powerful features like laziness, types, type coercion, method
+modifiers, and more.
+
=over 4
-=item L<Moose::Cookbook::Recipe1> - The (always classic) B<Point> example
+=item L<Moose::Cookbook::Basics::Recipe1> - The (always classic) B<Point> example
A simple Moose-based class. Demonstrated Moose attributes and subclassing.
-=item L<Moose::Cookbook::Recipe2> - A simple B<BankAccount> example
+=item L<Moose::Cookbook::Basics::Recipe2> - A simple B<BankAccount> example
A slightly more complex Moose class. Demonstrates using a method
modifier in a subclass.
-=item L<Moose::Cookbook::Recipe3> - A lazy B<BinaryTree> example
+=item L<Moose::Cookbook::Basics::Recipe3> - A lazy B<BinaryTree> example
Demonstrates several attribute features, including types, weak
references, predicates ("does this object have a foo?"), defaults, and
-lazy attribute construction.
+lazy attribute uction.
-=item L<Moose::Cookbook::Recipe4> - Subtypes, and modeling a simple B<Company> class hierarchy
+=item L<Moose::Cookbook::Basics::Recipe4> - Subtypes, and modeling a simple B<Company> class hierarchy
Introduces the creation and use of custom types, a C<BUILD> method,
and the use of C<override> in a subclass.
-=item L<Moose::Cookbook::Recipe5> - More subtypes, coercion in a B<Request> class
+=item L<Moose::Cookbook::Basics::Recipe5> - More subtypes, coercion in a B<Request> class
More type examples, including the use of type coercions.
-=item L<Moose::Cookbook::Recipe6> - The augment/inner example
+=item L<Moose::Cookbook::Basics::Recipe6> - The augment/inner example
Demonstrates the use of C<augment> method modifiers, a way of turning
the usual method overriding style "inside-out".
-=item L<Moose::Cookbook::Recipe7> - Making Moose fast with immutable
+=item L<Moose::Cookbook::Basics::Recipe7> - Making Moose fast with immutable
Making a class immutable greatly increases the speed of accessors and
object construction.
-=item L<Moose::Cookbook::Recipe8> - Managing complex relations with trigger (TODO)
+=item L<Moose::Cookbook::Basics::Recipe8> - Managing complex relations with trigger (TODO)
I<abstract goes here>
Work off of this http://code2.0beta.co.uk/moose/svn/Moose/trunk/t/200_examples/007_Child_Parent_attr_inherit.t
-=item L<Moose::Cookbook::Recipe9> - Builder methods and lazy_build
+=item L<Moose::Cookbook::Basics::Recipe9> - Builder methods and lazy_build
The builder feature provides an inheritable and role-composable way to
provide a default attribute value.
+=item L<Moose::Cookbook::Basics::Recipe10> - Operator overloading, subtypes, and coercion
+
+Demonstrates using operator overloading, coercion, and subtypes to
+model how eye color is determined during reproduction.
+
=back
=head2 Moose Roles
+These recipes will show you how to use Moose roles.
+
=over 4
-=item L<Moose::Cookbook::Recipe10> - The Moose::Role example
+=item L<Moose::Cookbook::Role::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::Recipe11> - Advanced Role Composition - method exclusion and aliasing
+=item L<Moose::Cookbook::Role::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::Recipe12> - Runtime Role Composition (TODO)
+=item L<Moose::Cookbook::Role::Recipe3> - Runtime Role Composition (TODO)
I<abstract goes here>
=head2 Meta Moose
+These recipes show you how to write your own meta classes, which lets
+you extend the object system provide by Moose.
+
=over 4
-=item L<Moose::Cookbook::Recipe20> - Welcome to the meta-world (TODO)
+=item L<Moose::Cookbook::Meta::Recipe1> - Welcome to the meta-world (Why Go Meta?)
-I<abstract goes here>
+If you're wondering what all this "meta" stuff is, and why you should
+care about it, read this "recipe".
-=item L<Moose::Cookbook::Recipe21> - The meta-attribute example
+=item L<Moose::Cookbook::Meta::Recipe2> - A meta-attribute, attributes with labels
One way to extend Moose is to provide your own attribute
metaclasses. Attribute metaclasses let you extend attribute
declarations (with C<has>) and behavior to provide additional
attribute functionality.
-=item L<Moose::Cookbook::Recipe22> - The meta-attribute trait example
+=item L<Moose::Cookbook::Meta::Recipe3> - Labels implemented via attribute traits
Extending Moose's attribute metaclass is a great way to add
functionality. However, attributes can only have one metaclass.
Applying roles to the attribute metaclass lets you provide
composable attribute functionality.
-=item L<Moose::Cookbook::Recipe23> - The meta-instance example (TODO)
+=item L<Moose::Cookbook::Meta::Recipe4> - Adding a "table" attribute to the metaclass
-I<abstract goes here>
+If you want to store more information about your classes, you'll have
+to extend C<Moose::Meta::Class>. Doing so is simple, but you'll
+probably also want to provide some sugar, so see
+L<Moose::Cookbook::Extending::Recipe2> as well.
-=item L<Moose::Cookbook::Recipe24> - The meta-class example (TODO)
+=item L<Moose::Cookbook::Meta::Recipe5> - The "table" attribute implemented as a metaclass trait
+
+This example takes the class metaclass we saw in the previous recipe
+and reimplements it as a metaclass trait.
+
+=item L<Moose::Cookbook::Meta::Recipe6> - Hooking into the immutabilization system (TODO)
+
+Moose has a feature known as "immutabilization". By calling C<<
+__PACKAGE__->meta()->make_immutable() >> after defining your class
+(attributes, roles, etc), you tell Moose to optimize things like
+object creation, attribute access, and so on.
+
+If you are creating your own metaclasses, you may need to hook into
+the immutabilization system. This cuts across a number of spots,
+including the metaclass class, meta method classes, and possibly the
+meta-instance class as well.
+
+This recipe shows you how to write extensions which immutabilize
+properly.
+
+=item L<Moose::Cookbook::Meta::Recipe7> - I<meta-instance> (TODO)
I<abstract goes here>
=back
+=head2 Extending Moose
+
+These recipes cover some more ways to extend Moose, and will be useful
+if you plan to write your own C<MooseX> module.
+
+=over 4
+
+=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::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,
+especially if you want to default to a new metaclass class or base
+object class.
+
+=back
+
=head1 SNACKS
=over 4
+=item L<Moose::Cookbook::Snack::Keywords>
+
=item L<Moose::Cookbook::Snack::Types>
=back
--- /dev/null
+
+=pod
+
+=head1 NAME
+
+Moose::Cookbook::Basics::Recipe1 - The (always classic) B<Point> example.
+
+=head1 SYNOPSIS
+
+ package Point;
+ use Moose;
+
+ has 'x' => (isa => 'Int', is => 'rw', required => 1);
+ has 'y' => (isa => 'Int', is => 'rw', required => 1);
+
+ sub clear {
+ my $self = shift;
+ $self->x(0);
+ $self->y(0);
+ }
+
+ package Point3D;
+ use Moose;
+
+ extends 'Point';
+
+ has 'z' => (isa => 'Int', is => 'rw', required => 1);
+
+ after 'clear' => sub {
+ my $self = shift;
+ $self->z(0);
+ };
+
+ ....
+
+ # 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
+6 Apocalypse 12 document, and is similar to the example found in the
+classic K&R C book as well.
+
+As with all Perl 5 classes, a Moose class is defined in a package.
+Moose handles turning on C<strict> and C<warnings> for us, so all we
+need to do is say C<use Moose>, and no kittens will die.
+
+When Moose is loaded, it exports a set of sugar functions into our
+package. This means that we import some functions which serve as Moose
+"keywords". These aren't real language keywords, they're just Perl
+functions exported into our package.
+
+Moose automatically makes our package a subclass of L<Moose::Object>.
+The L<Moose::Object> class provides us with a constructor that
+respects our attributes, as well other features. See L<Moose::Object>
+for details.
+
+Now, onto the keywords. The first one we see here is C<has>, which
+defines an instance attribute in our class:
+
+ has 'x' => (isa => 'Int', is => 'rw', required => 1);
+
+This will create an attribute named C<x>. The C<isa> parameter says
+that we expect the value stored in this attribute to pass the type
+constraint for C<Int> (1). The accessor generated for this attribute
+will be read-write.
+
+The C<< requires => 1 >> parameter means that this attribute must be
+provided when a new object is created. A point object without
+coordinates doesn't make much sense, so we don't allow it.
+
+We have defined our attributes; next we define our methods. In Moose,
+as with regular Perl 5 OO, a method is just a subroutine defined
+within the package:
+
+ sub clear {
+ my $self = shift;
+ $self->x(0);
+ $self->y(0);
+ }
+
+That concludes the B<Point> class.
+
+Next we have a subclass of B<Point>, B<Point3D>. To declare our
+superclass, we use the Moose keyword C<extends>:
+
+ extends 'Point';
+
+The C<extends> keyword works much like C<use base>. First, it will
+attempt to load your class if needed. However, unlike C<base>, the
+C<extends> keyword will I<overwrite> any previous values in your
+package's C<@ISA>, where C<use base> will C<push> values onto the
+package's C<@ISA>.
+
+It is my opinion that the behavior of C<extends> is more intuitive.
+(2).
+
+Next we create a new attribute for B<Point3D> called C<z>.
+
+ has 'z' => (isa => 'Int', is => 'rw', required => 1);
+
+This attribute is just like B<Point>'s C<x> and C<y> attributes.
+
+The C<after> keyword demonstrates a Moose feature called "method
+modifiers" (or "advice" for the AOP inclined):
+
+ after 'clear' => sub {
+ my $self = shift;
+ $self->z(0);
+ };
+
+When C<clear> is called on a B<Point3D> object, our modifier method
+gets called as well. Unsurprisingly, the modifier is called I<after>
+the real method.
+
+In this case, the real C<clear> method is inherited from B<Point>. Our
+modifier method receives the same arguments as those passed to the
+modified method (just C<$self> here).
+
+Of course, using the C<after> modifier is not the only way to
+accomplish this. This B<is> Perl, right? You can get the same results
+with this code:
+
+ sub clear {
+ my $self = shift;
+ $self->SUPER::clear();
+ $self->z(0);
+ }
+
+You could also use another Moose method modifier, C<override>:
+
+ override 'clear' => sub {
+ my $self = shift;
+ super();
+ $self->z(0);
+ };
+
+The C<override> modifier allows you to use the C<super> keyword to
+dispatch to the superclass's method in a very Ruby-ish style.
+
+The choice of whether to use a method modifier, and which one to use,
+is often a question of style as much as functionality.
+
+Since B<Point> inherits from L<Moose::Object>, it will also inherit
+the default L<Moose::Object> 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);
+
+The C<new> constructor accepts a named argument pair for each
+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
+file.
+
+=head2 Moose Objects are Just Hashrefs
+
+While this all may appear rather magical, it's important to realize
+that Moose objects are just hash references under the hood (3). For
+example, you could pass C<$self> to C<Data::Dumper> and you'd get
+exactly what you'd expect.
+
+You could even poke around inside the object's data structure, but
+that is strongly discouraged.
+
+The fact that Moose objects are hashrefs means it is easy to use Moose
+to extend non-Moose classes, as long as they too are hash
+references. If you want to extend a non-hashref class, check out
+C<MooseX::InsideOut>.
+
+=head1 CONCLUSION
+
+This recipe demonstrates some basic Moose concepts. The next recipe
+will build upon the basics shown here with more complex attributes and
+methods. Please read on :)
+
+=head1 FOOTNOTES
+
+=over 4
+
+=item (1)
+
+Moose provides a number of builtin type constraints are provided by,
+of which C<Int> is one. For more information on the type constraint
+system, see L<Moose::Util::TypeConstraints>.
+
+=item (2)
+
+The C<extends> keyword support multiple inheritance. Simply pass all
+of your superclasses to C<extends> as a list:
+
+ extends 'Foo', 'Bar', 'Baz';
+
+=item (3)
+
+Moose supports using instance structures other than blessed hash
+references (such as in a glob reference - see
+L<MooseX::GlobRef::Object>).
+
+=back
+
+=head1 SEE ALSO
+
+=over 4
+
+=item Method Modifiers
+
+The concept of method modifiers is directly ripped off from CLOS. A
+great explanation of them can be found by following this link.
+
+L<http://www.gigamonkeys.com/book/object-reorientation-generic-functions.html>
+
+=back
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan@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
--- /dev/null
+
+=pod
+
+=head1 NAME
+
+Moose::Cookbook::Basics::Recipe10 - Operator overloading, subtypes, and coercion
+
+=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) = @_;
+
+ 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) );
+
+ my $gender = 'f';
+ $gender = 'm' if (rand() >= 0.5);
+
+ return Human->new(
+ gender => $gender,
+ mother => $mother,
+ father => $father,
+ );
+ }
+
+=head1 DESCRIPTION
+
+This Moose cookbook recipe shows how operator overloading, coercion,
+and sub types can be used to mimic the human reproductive system
+(well, the selection of genes at least). Assumes a basic
+understanding of Moose.
+
+=head1 INTRODUCTION
+
+The example in the SYNOPSIS outlines a very basic use of
+operator overloading and Moose. The example creates a class
+that allows you to add together two humans and produce a
+child from them.
+
+The two parents must be of the opposite gender, as to do
+otherwise wouldn't be biologically possible no matter how much
+I might want to allow it.
+
+While this example works and gets the job done, it really isn't
+all that useful. To take this a step further let's play around
+with genes. Particularly the genes that dictate eye color. Why
+eye color? Because it is simple. There are two genes that have
+the most affect on eye color and each person carries two of each
+gene. Now that will be useful!
+
+Oh, and don't forget that you were promised some coercion goodness.
+
+=head1 TECHNIQUES
+
+First, let's quickly define the techniques that will be used.
+
+=head2 Operator Overloading
+
+Overloading operators takes a simple declaration of which operator
+you want to overload and what method to call. See the perldoc for
+overload to see some good, basic, examples.
+
+=head2 Subtypes
+
+Moose comes with 21 default type constraints, as documented in
+L<Moose::Util::TypeConstraints>. Int, Str, and CodeRef are
+all examples. Subtypes give you the ability to inherit the
+constraints of an existing type, and adding additional
+constraints on that type. An introduction to type constraints
+is available in the L<Moose::Cookbook::Basics::Recipe4>.
+
+=head2 Coercion
+
+When an attribute is assigned a value its type constraint
+is checked to validate the value. Normally, if the value
+does not pass the constraint, an exception will be thrown.
+But, it is possible with Moose to define the rules to coerce
+values from one type to another. A good introduction to
+this can be found in L<Moose::Cookbook::Basics::Recipe5>.
+
+=head1 GENES
+
+As I alluded to in the introduction, there are many different
+genes that affect eye color. But, there are 2 genes that play
+the most prominent role: gey and bey2. To get started let us
+make classes for these genes.
+
+=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
+gene is whether it is of the blue or brown variety. As you can
+see a type constraint for the color attribute has been created
+which validates for the two possible colors.
+
+=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
+has a green or blue variety.
+
+=head1 EYE COLOR
+
+Rather than throwing the 4 gene object (2xbey, 2xgey2) straight
+on to the Human class, let's create an intermediate class that
+abstracts the logic behind eye color. This way the Human class
+won't get all cluttered up with the details behind the different
+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 );
+
+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.
+
+As with most genes there are recessive and dominant genes. The bey2
+brown gene is dominant to both blue and green. The gey green gene is
+recessive to the brown bey gene and dominant to the blues. Finally,
+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');
+ return 'blue';
+ }
+
+To top it off, if I want to access color(), I want to be really lazy
+about it. Perl overloading supports the ability to overload the
+stringification of an object. So, normally if I did "$eye_color"
+I'd get something like "Human::EyeColor=HASH(0xba9348)". What I
+really want is "brown", "green", or "blue". To do this you overload
+the stringification of the object.
+
+ use overload '""' => \&color, fallback => 1;
+
+That's all and good, but don't forget the spawn! Our
+humans have to have children, and those children need to inherit
+genes from their parents. Let's use operator overloading so
+that we can add (+) together two EyeColor characteristics to
+create a new EyeColor that is derived in a similar manner as
+the gene selection in human reproduction.
+
+ use overload '+' => \&_overload_add, fallback => 1;
+
+ sub _overload_add {
+ my ($one, $two) = @_;
+
+ my $one_bey2 = 'bey2_' . _rand2();
+ my $two_bey2 = 'bey2_' . _rand2();
+
+ my $one_gey = 'gey_' . _rand2();
+ my $two_gey = 'gey_' . _rand2();
+
+ return Human::EyeColor->new(
+ bey2_1 => $one->$one_bey2->color(),
+ bey2_2 => $two->$two_bey2->color(),
+ gey_1 => $one->$one_gey->color(),
+ gey_2 => $two->$two_gey->color(),
+ );
+ }
+
+ sub _rand2 {
+ return 1 + int( rand(2) );
+ }
+
+What is happening here is we are overloading the addition
+operator. When two eye color objects are added together
+the _overload_add() method will be called with the two
+objects on the left and right side of the + as arguments.
+The return value of this method should be the expected
+result of the addition. I'm not going to go in to the
+details of how the gene's are selected as it should be
+fairly self-explanatory.
+
+=head1 HUMAN EVOLUTION
+
+Our original human class in the SYNOPSIS requires very little
+change to support the new EyeColor characteristic. All we
+need to do is define a new subtype called EyeColor, a new
+attribute called eye_color, and just for the sake of simple code
+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 );
+
+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,
+ eye_color => ( $one->eye_color() + $two->eye_color() ),
+ mother => $mother,
+ father => $father,
+ );
+
+=head1 CONCLUSION
+
+The three techniques used in this article - overloading, subtypes,
+and coercion - provide the power to produce simple, flexible, powerful,
+explicit, inheritable, and enjoyable interfaces.
+
+If you want to get your hands on this code all combined together, and
+working, download the Moose tarball and look at "t/000_recipes/012_genes.t".
+
+=head1 NEXT STEPS
+
+Has this been a real project we'd probably want to:
+
+=over 4
+
+=item Better Randomization with Crypt::Random
+
+=item Characteristic Base Class
+
+=item Mutating Genes
+
+=item More Characteristics
+
+=item Artificial Life
+
+=back
+
+=head1 AUTHOR
+
+Aran Clary Deltac <bluefeet@cpan.org>
+
+=head1 LICENSE
+
+This work is licensed under a Creative Commons Attribution 3.0 Unported License.
+
+License details are at: L<http://creativecommons.org/licenses/by/3.0/>
+
+=cut
+
--- /dev/null
+
+=pod
+
+=head1 NAME
+
+Moose::Cookbook::Basics::Recipe2 - A simple B<BankAccount> example
+
+=head1 SYNOPSIS
+
+ package BankAccount;
+ use Moose;
+
+ has 'balance' => (isa => 'Int', is => 'rw', default => 0);
+
+ sub deposit {
+ my ($self, $amount) = @_;
+ $self->balance($self->balance + $amount);
+ }
+
+ sub withdraw {
+ my ($self, $amount) = @_;
+ my $current_balance = $self->balance();
+ ($current_balance >= $amount)
+ || confess "Account overdrawn";
+ $self->balance($current_balance - $amount);
+ }
+
+ package CheckingAccount;
+ use Moose;
+
+ extends 'BankAccount';
+
+ has 'overdraft_account' => (isa => 'BankAccount', is => 'rw');
+
+ before 'withdraw' => sub {
+ my ($self, $amount) = @_;
+ my $overdraft_amount = $amount - $self->balance();
+ if ($self->overdraft_account && $overdraft_amount > 0) {
+ $self->overdraft_account->withdraw($overdraft_amount);
+ $self->deposit($overdraft_amount);
+ }
+ };
+
+=head1 DESCRIPTION
+
+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
+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.
+
+The classes in the SYNOPSIS show two kinds of bank account. A simple
+bank account has one attribute, the balance, and two behaviors,
+depositing and withdrawing money.
+
+We then extend the basic bank account in the CheckingAccount
+class. This class adds another attribute, an overdraft account. It
+also adds overdraft protection to the withdraw method. If you try to
+withdraw more than you have, the checking account attempts to
+reconcile the difference by withdrawing money from the overdraft
+account. (1)
+
+The first class, B<BankAccount>, introduces a new attribute feature, a
+default value:
+
+ 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
+of C<0>. This means that every instance of B<BankAccount> that is
+created will have its C<balance> slot initialized to C<0>, unless some
+other value is provided to the constructor.
+
+The C<deposit> and C<withdraw> methods should be fairly
+self-explanatory, as they are just plain old Perl 5 OO.
+
+As you know from the first recipe, the keyword C<extends> sets a
+class's superclass. Here we see that B<CheckingAccount> C<extends>
+B<BankAccount>. The next line introduces yet another new attribute
+feature, class-based type constraints:
+
+ 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
+C<BankAccount> type constraint is new, and was actually defined the
+moment we created the B<BankAccount> class itself. In fact, Moose
+creates a corresponding type constraint for every class in your
+program (2).
+
+This means that in the first recipe, constraints for both C<Point> and
+C<Point3D> were created. In this recipe, both C<BankAccount> and
+C<CheckingAccount> type constraints are created automatically. Moose
+does this as a convenience so that your classes and type constraint
+can be kept in sync with one another. In short, Moose makes sure that
+it will just DWIM (3).
+
+In B<CheckingAccount>, we see another method modifier, the C<before>
+modifier.
+
+ before 'withdraw' => sub {
+ my ($self, $amount) = @_;
+ my $overdraft_amount = $amount - $self->balance();
+ if ($self->overdraft_account && $overdraft_amount > 0) {
+ $self->overdraft_account->withdraw($overdraft_amount);
+ $self->deposit($overdraft_amount);
+ }
+ };
+
+Just as with the C<after> modifier from the first recipe, Moose will
+handle calling the superclass method (in this case C<<
+BankAccount->withdraw >>).
+
+The C<before> modifier will (obviously) run I<before> the code from
+the superclass is run. Here, C<before> modifier implements overdraft
+protection by first checking if there are available funds in the
+checking account. If not (and if there is an overdraft account
+available), it transfers the amount needed into the checking
+account (4).
+
+As with the method modifier in the first recipe, we could use
+C<SUPER::> to get the same effect:
+
+ sub withdraw {
+ my ($self, $amount) = @_;
+ my $overdraft_amount = $amount - $self->balance();
+ if ($self->overdraft_account && $overdraft_amount > 0) {
+ $self->overdraft_account->withdraw($overdraft_amount);
+ $self->deposit($overdraft_amount);
+ }
+ $self->SUPER::withdraw($amount);
+ }
+
+The benefit of taking the method modifier approach is we do not need
+to remember to call C<SUPER::withdraw> and pass it the C<$amount>
+argument when writing C<< CheckingAccount->withdraw >>.
+
+This is actually more than just a convenience for forgetful
+programmers. Using method modifiers helps isolate subclasses from
+changes in the superclasses. For instance, if B<<
+BankAccount->withdraw >> were to add an additional argument of some
+kind, the version of B<< CheckingAccount->withdraw >> which uses
+C<SUPER::withdraw> would not pass that extra argument correctly,
+whereas the method modifier version would automatically pass along all
+arguments correctly.
+
+Just as with the first recipe, object instantiation uses the C<new>
+method, which accepts named parameters.
+
+ my $savings_account = BankAccount->new( balance => 250 );
+
+ my $checking_account = CheckingAccount->new(
+ balance => 100,
+ overdraft_account => $savings_account,
+ );
+
+And as with the first recipe, a more in-depth example can be found in
+the F<t/000_recipes/basics/002_recipe.t> test file.
+
+=head1 CONCLUSION
+
+The aim of this recipe was to take the knowledge gained in the first
+recipe and expand upon it with a more realistic use case. The next
+recipe will expand on Moose attributes to create a behaviorally
+sophisticated class defined almost entirely by its attributes.
+
+=head1 FOOTNOTES
+
+=over 4
+
+=item (1)
+
+If you're paying close attention, you might realize that there's a
+circular loop waiting to happen here. A smarter example would have to
+make sure that we don't accidentally create a loop between the
+checking account and its overdraft account.
+
+=item (2)
+
+In reality, this creation is sensitive to the order in which modules
+are loaded. In more complicated cases, you may find that you need to
+explicitly declare a class type before the corresponding is loaded.
+
+=item (3)
+
+Moose does not attempt to encode a class's is-a relationships within
+the type constraint hierarchy. Instead, Moose just considers the class
+type constraint to be a subtype of C<Object>, and specializes the
+constraint check to allow for subclasses. This means that an instance
+of B<CheckingAccount> will pass a C<BankAccount> type constraint
+successfully. For more details, please refer to the
+L<Moose::Util::TypeConstraints> documentation.
+
+=item (4)
+
+If the overdraft account does not have the amount needed, it will
+throw an error. Of course, the overdraft account could also have
+overdraft protection. See note 1.
+
+=back
+
+=head1 SEE ALSO
+
+=over 4
+
+=item Acknowledgment
+
+The BankAccount example in this recipe is directly taken from the
+examples in this chapter of "Practical Common Lisp":
+
+L<http://www.gigamonkeys.com/book/object-reorientation-generic-functions.html>
+
+=back
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan@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
=head1 NAME
-Moose::Cookbook::Recipe3 - A lazy B<BinaryTree> example
+Moose::Cookbook::Basics::Recipe3 - A lazy B<BinaryTree> example
=head1 SYNOPSIS
you like, as we showed in the second recipe.
And actually, you can use C<builder> instead of C<default>. See
-L<Moose::Cookbook::Recipe9> for details.
+L<Moose::Cookbook::Basics::Recipe9> for details.
=back
=head1 NAME
-Moose::Cookbook::Recipe4 - Subtypes, and modeling a simple B<Company> class hierarchy
+Moose::Cookbook::Basics::Recipe4 - Subtypes, and modeling a simple B<Company> class hierarchy
=head1 SYNOPSIS
=head1 NAME
-Moose::Cookbook::Recipe5 - More subtypes, coercion in a B<Request> class
+Moose::Cookbook::Basics::Recipe5 - More subtypes, coercion in a B<Request> class
=head1 SYNOPSIS
=head1 NAME
-Moose::Cookbook::Recipe6 - The augment/inner example
+Moose::Cookbook::Basics::Recipe6 - The augment/inner example
=head1 SYNOPSIS
=head1 NAME
-Moose::Cookbook::Recipe7 - Making Moose fast with immutable
+Moose::Cookbook::Basics::Recipe7 - Making Moose fast with immutable
=head1 SYNOPSIS
=head1 NAME
-Moose::Cookbook::Recipe9 - Builder methods and lazy_build
+Moose::Cookbook::Basics::Recipe9 - Builder methods and lazy_build
=head1 SYNOPSIS
=head1 DESCRIPTION
-If you've already read L<Moose::Cookbook::Recipe3>, then this example
+If you've already read L<Moose::Cookbook::Basics::Recipe3>, then this example
should look awfully familiar. In fact, all we've done here is replace
the attribute C<default> with a C<builder> method.
--- /dev/null
+
+=pod
+
+=head1 NAME
+
+Moose::Cookbook::Extending::Recipe1 - Moose extension overview
+
+=head1 DESCRIPTION
+
+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.
+
+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.
+
+=head2 Playing Nice With Others
+
+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.
+
+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; # 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',
+ );
+ }
+
+=head2 Extensions as Metaclass (and Base Object) Roles
+
+Implementing your extensions as metaclass roles makes your extensions
+easy to apply, and cooperative with other metaclass role-based extensions.
+
+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.
+
+ package MooseX::Embiggen;
+
+ use Moose ();
+ use Moose::Exporter;
+ use Moose::Util::MetaRole;
+
+ use MooseX::Embiggen::Role::Meta::Class;
+ use MooseX::Embiggen::Role::Meta::Attribute;
+ use MooseX::Embiggen::Role::Meta::Method::Constructor
+ use MooseX::Embiggen::Role::Object;
+
+ Moose::Exporter->setup_import_methods( also => 'Moose' );
+
+ sub init_meta {
+ shift; # just your package name
+ my %options = @_;
+
+ Moose->init_meta(%options);
+
+ 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'],
+ );
+
+ Moose::Util::MetaRole::apply_base_class_roles(
+ for_class => $options{for_class},
+ roles => ['MooseX::Embiggen::Role::Object'],
+ );
+
+ return $meta;
+ }
+
+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@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
--- /dev/null
+
+=pod
+
+=head1 NAME
+
+Moose::Cookbook::Extending::Recipe2 - Providing a role for the base object class
+
+=head1 SYNOPSIS
+
+ package MooseX::Debugging;
+
+ use strict;
+ use warnings;
+
+ use Moose::Exporter;
+ use Moose::Util::MetaRole;
+ use MooseX::Debugging::Role::Object;
+
+ Moose::Exporter->setup_import_methods();
+
+ sub init_meta {
+ shift;
+ my %options = @_;
+
+ Moose::Util::MetaRole::apply_base_object_roles(
+ for_class => $options{for_class},
+ role => ['MooseX::Debugging::Role::Object'],
+ );
+ }
+
+
+ package MooseX::Debugging::Role::Object;
+
+ after 'BUILD' => sub {
+ my $self = shift;
+
+ warn "Made a new " . ref $self . " object\n";
+ }
+
+=head1 DESCRIPTION
+
+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.
+
+Obviously, a real debugging role would do something more interesting,
+but this recipe is all about how we apply that role.
+
+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.
+
+=head1 AUTHOR
+
+Dave Rolsky E<lt>autarch@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
+
--- /dev/null
+
+=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@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
--- /dev/null
+
+=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@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
If you need to affect the constructor's parameters prior to the
instance actually being constructed, you have a number of options.
-First, there are I<coercions> (See the L<Moose::Cookbook::Recipe5>
-for a complete example and explaination 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.
-
-Second, using an C<around> method modifier on C<new> can be an
-effective way to affect the contents of C<@_> prior to letting
-Moose deal with it. This carries with it the extra burden for
-your subclasses, in that they have to be sure to explicitly
-call your C<new> and/or work around your C<new> to get to the
-version from L<Moose::Object>.
-
-The last approach is to use the standard Perl technique of calling
-the C<SUPER::new> within your own custom version of C<new>. This,
-of course, brings with it all the issues of the C<around> solution
-as well as any issues C<SUPER::> might add.
-
-In short, try to use C<BUILD> and coercions, they are your best
-bets.
+To change the parameter processing as a whole, you can use
+the C<BUILDARGS> method. The default implementation accepts key/value
+pairs or a hash reference. You can override it to take positional args,
+or any other format
+
+To change the handling of individual parameters, there are I<coercions>
+(See the L<Moose::Cookbook::Basics::Recipe5> for a complete example and
+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.
=head3 How do I make non-Moose constructors work with Moose?
coercions, and C<lazy_build>, so subclassing is often not the
ideal route.
-That said, the default Moose constructors is inherited from
+That said, the default Moose constructor is inherited from
L<Moose::Object>. When inheriting from a non-Moose class, the
inheritance chain to L<Moose::Object> is broken. The simplest way
to fix this is to simply explicitly inherit from L<Moose::Object>
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
in the C<via> block.
For a more comprehensive example of using coercions, see the
-L<Moose::Cookbook::Recipe5>.
+L<Moose::Cookbook::Basics::Recipe5>.
If you need to deflate your attribute, the current best practice is to
add an C<around> modifier to your accessor. Here is some example code:
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@iinteractive.comE<gt>
--- /dev/null
+
+=pod
+
+=head1 NAME
+
+Moose::Cookbook::Meta::Recipe1 - Welcome to the meta world (Why Go Meta?)
+
+=head1 SUMMARY
+
+If you've ever found yourself thinking "Moose is great, but I wish it
+did X differently", then you've gone meta. The meta recipes are all
+about how to change and extend the way Moose does its thing, by
+changing how the various meta classes (C<Moose::Meta::Class>,
+C<Moose::Meta::Attribute>, etc) work.
+
+The metaclass system is a set of classes that describe classes, roles,
+attributes, etc. The metaclass API lets you ask questions about a
+class, like "what attributes does it have?", or "what roles does the
+class do?"
+
+The metaclass system also lets you actively make changes to a class,
+for example by adding new methods.
+
+The interface with which you normally use Moose (C<has>, C<with>,
+C<extends>) is just a thin layer of syntactic sugar over the
+underlying metaclass system.
+
+By extending and changing how this metaclass system works, you can in
+effect create a modified object implementation for your classes.
+
+=head2 Examples
+
+Let's say that you want to additional properties to
+attributes. Specifically, we want to add a "label" property to each
+attribute, so we can write C<<
+My::Class->meta()->get_attribute('size')->label() >>. The first two
+recipes show two different ways to do this, one with a full
+meta-attribute subclass, and the other with an attribute trait.
+
+You might also want to add additional properties to your
+metaclass. For example, if you were writing an ORM based on Moose, you
+could associate a table name with each class via the class's metaclass
+object, letting you write C<< My::Class->meta()->table_name() >>.
+
+=head1 SEE ALSO
+
+Many of the MooseX modules on CPAN implement metaclass extensions. A
+couple good examples include C<MooseX::Singleton> and
+C<MooseX::AttributeHelpers>. For a more complex example see
+C<Fey::ORM>.
+
+=head1 AUTHOR
+
+Dave Rolsky E<lt>autarch@urth.org<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
+
+
=head1 NAME
-Moose::Cookbook::Recipe21 - The meta-attribute example
+Moose::Cookbook::Meta::Recipe2 - A meta-attribute, attributes with labels
=head1 SYNOPSIS
=head1 NAME
-Moose::Cookbook::Recipe22 - The attribute trait example
+Moose::Cookbook::Meta::Recipe3 - Labels implemented via attribute traits
=head1 SYNOPSIS
=head1 BUT FIRST
-This recipe is a continuation of L<Moose::Cookbook::Recipe21>. Please read that
-first.
+This recipe is a continuation of
+L<Moose::Cookbook::Meta::Recipe2>. Please read that recipe first.
=head1 MOTIVATION
-In Recipe 21, we created an attribute metaclass that gives attributes a "label"
-that can be set in L<Moose/has>. That works well until you want a second
-meta-attribute, or until you want to adjust the behavior of the attribute. You
-could define a specialized attribute metaclass to use in every attribute.
-However, you may want different attributes to have different behaviors. You
-might end up with a unique attribute metaclass for B<every single attribute>,
-with a lot of code copying and pasting!
+In L<Moose::Cookbook::Meta::Recipe2>, we created an attribute
+metaclass that gives attributes a "label" that can be set in
+L<Moose/has>. That works well until you want a second meta-attribute,
+or until you want to adjust the behavior of the attribute. You could
+define a specialized attribute metaclass to use in every attribute.
+However, you may want different attributes to have different
+behaviors. You might end up with a unique attribute metaclass for
+B<every single attribute>, with a lot of code copying and pasting!
Or, if you've been drinking deeply of the Moose kool-aid, you'll have a role
for each of the behaviors. One role would give a label meta-attribute. Another
=head1 DISSECTION
-A side-by-side look of the code examples in this recipe and recipe 21 should
+A side-by-side look of the code examples in this recipe and recipe 2 should
indicate that defining and using a trait is very similar to defining and using
a new attribute metaclass.
name of the trait.
Now we begin writing our application logic. I'll only cover what has changed
-since recipe 21.
+since recipe 2.
has url => (
traits => [qw/Labeled/],
--- /dev/null
+
+=pod
+
+=head1 NAME
+
+Moose::Cookbook::Meta::Recipe4 - Adding a "table" attribute to the metaclass
+
+=head1 SYNOPSIS
+
+ package MyApp::Meta::Class;
+ use Moose;
+ extends 'Moose::Meta::Class';
+
+ has table =>
+ ( is => 'rw',
+ isa => 'Str',
+ );
+
+=head1 DESCRIPTION
+
+In this recipe, we'll create a new metaclass which has a "table"
+attribute. This metaclass is for classes associated with a DBMS table,
+as one might do for an ORM.
+
+In this example, the table name is just a string, but in a real ORM
+the table might be an object describing the table.
+
+=head1 THE METACLASS
+
+The metaclass example really is as simple as the one in the
+synopsis. The trick is getting your classes to use this metaclass, and
+providing some sort of sugar for declaring the table. This is covered
+in L<Moose::Cookbook::Extending::Recipe2>, which shows how to make a
+module like C<Moose.pm> itself, with sugar like C<has_table()>.
+
+=head2 Using this Metaclass in Practice
+
+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();
+
+As long as MyApp::User has arranged to use C<MyApp::Meta::Class> as
+its metaclass, this method call just works.
+
+=head1 SEE ALSO
+
+L<Moose::Cookbook::Meta::Recipe5> - The "table" attribute implemented
+as a metaclass trait
+
+L<Moose::Cookbook::Extending::Recipe2> - Acting like Moose.pm and
+providing sugar Moose-style
+
+=head1 AUTHOR
+
+Dave Rolsky E<lt>autarch@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
--- /dev/null
+
+=pod
+
+=head1 NAME
+
+Moose::Cookbook::Meta::Recipe5 - The "table" attribute as a metaclass trait
+
+=head1 SYNOPSIS
+
+ package MyApp::Meta::Class::Trait::HasTable;
+ use Moose::Role;
+
+ has table =>
+ ( is => 'rw',
+ isa => 'Str',
+ );
+
+ package Moose::Meta::Class::Custom::Trait::HasTable;
+ sub register_implementation { 'MyApp::Meta::Class::Trait::HasTable' }
+
+ package MyApp::User;
+ use Moose -traits => 'HasTable';
+
+ __PACKAGE__->table('User');
+
+=head1 DESCRIPTION
+
+This recipe takes the metaclass table attribute and reimplements it as
+a metaclass trait. Traits are just roles that Moose applies to
+something for you. In this case, that "something" is the class's
+metaclass object.
+
+The advantage of using traits is that it's easy to combine multiple
+traits, whereas combining multiple metaclasses can be tricky (which
+subclasses which?).
+
+The disadvantage is that it's not easy to combine a trait with some
+sort of sugar (like our notional C<has_table> sugar).
+
+=head2 Using this Metaclass Trait in Practice
+
+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();
+
+=head1 SEE ALSO
+
+L<Moose::Cookbook::Meta::Recipe3> - Labels implemented via attribute
+traits
+
+L<Moose::Cookbook::Meta::Recipe4> - Adding a "table" attribute to the
+metaclass
+
+=head1 AUTHOR
+
+Dave Rolsky E<lt>autarch@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
+++ /dev/null
-
-=pod
-
-=head1 NAME
-
-Moose::Cookbook::Recipe1 - The (always classic) B<Point> example.
-
-=head1 SYNOPSIS
-
- package Point;
- use Moose;
-
- has 'x' => (isa => 'Int', is => 'ro');
- has 'y' => (isa => 'Int', is => 'rw');
-
- sub clear {
- my $self = shift;
- $self->{x} = 0;
- $self->y(0);
- }
-
- package Point3D;
- use Moose;
-
- extends 'Point';
-
- has 'z' => (isa => 'Int');
-
- after 'clear' => sub {
- my $self = shift;
- $self->{z} = 0;
- };
-
-=head1 DESCRIPTION
-
-This is the classic Point example. This one in particular I took
-from the Perl 6 Apocalypse 12 document, but it is similar to the
-example found in the classic K&R C book as well, and many other
-places. And now, onto the code:
-
-As with all Perl 5 classes, a Moose class is defined in a package.
-Moose now handles turning on C<strict> and C<warnings> for you, so
-all you need to do is say C<use Moose>, and no kittens will die.
-
-By loading Moose, we are enabling the loading of the Moose
-"environment" into our package. This means that we import some
-functions which serve as Moose "keywords". These aren't anything
-fancy, just plain old exported functions.
-
-Another important thing happens at this stage as well. Moose will
-automatically set your package's superclass to be L<Moose::Object>.
-The reason we do this, is so that we can be sure that your class
-will inherit from L<Moose::Object> and get the benefits that
-provides (such as a constructor; see L<Moose::Object> for details).
-However, you don't actually I<have> to inherit from L<Moose::Object>
-if you don't want to. All Moose features will still be accessible to
-you.
-
-Now, onto the keywords. The first one we see here is C<has>, which
-defines an instance attribute in your class:
-
- has 'x' => (isa => 'Int', is => 'ro');
-
-This will create an attribute named C<x>, which will expect the
-value stored in the attribute to pass the type constraint C<Int> (1),
-and the accessor generated for this attribute will be read-only
-(abbreviated as C<ro>).
-
-The next C<has> line is very similar, with only one difference:
-
- has 'y' => (isa => 'Int', is => 'rw');
-
-A read/write (abbreviated as C<rw>) accessor will be generated for
-the C<y> attribute.
-
-At this point the attributes have been defined, and it is time to
-define our methods. In Moose, as with regular Perl 5 OO, a method
-is just a subroutine defined within the package. So here we create
-the C<clear> method.
-
- sub clear {
- my $self = shift;
- $self->{x} = 0;
- $self->y(0);
- }
-
-It is pretty standard, the only thing to note is that we are directly
-accessing the C<x> slot in the instance L<(2)>. This is because the
-value was created with a read-only accessor. This also shows that Moose
-objects are not anything out of the ordinary, but just regular old
-blessed HASH references. This means they are very compatible with
-other Perl 5 (non-Moose) classes as well.
-
-The next part of the code to review is the B<Point> subclass,
-B<Point3D>. The first item you might notice is that we do not use
-the standard C<use base> declaration here. Instead we use the Moose
-keyword C<extends> like so:
-
- extends 'Point';
-
-This keyword will function very much like C<use base> does in that
-it will make an attempt to load your class if it has not already been
-loaded. However, it differs on one important point. The C<extends>
-keyword will overwrite any previous values in your package's C<@ISA>,
-where C<use base> will C<push> values onto the package's C<@ISA>. It
-is my opinion that the behavior of C<extends> is more intuitive in
-that it is more explicit about defining the superclass relationship.
-
-A small digression here: both Moose and C<extends> support multiple
-inheritance. You simply pass all the superclasses to C<extends>,
-like so:
-
- extends 'Foo', 'Bar', 'Baz';
-
-Now, back to our B<Point3D> class. The next thing we do is to create
-a new attribute for B<Point3D> called C<z>.
-
- has 'z' => (isa => 'Int');
-
-As with B<Point>'s C<x> and C<y> attributes, this attribute has a
-type constraint of C<Int>, but it differs in that it does B<not>
-ask for any autogenerated accessors. The result being (aside from
-broken object encapsulation) that C<z> is a private attribute.
-
-Next comes another Moose feature which we call method "modifiers"
-(or method "advice" for the AOP inclined). The modifier used here
-is the C<after> modifier, and looks like this:
-
- after 'clear' => sub {
- my $self = shift;
- $self->{z} = 0;
- };
-
-This modifier tells Moose to install a C<clear> method for
-B<Point3D> that will first run the C<clear> method for the
-superclass (in this case C<Point::clear>), and then run this
-method I<after> it (passing in the same arguments as the original
-method).
-
-Now, of course using the C<after> modifier is not the only way to
-accomplish this. I mean, after all, this B<is> Perl right? You
-would get the same results with this code:
-
- sub clear {
- my $self = shift;
- $self->SUPER::clear();
- $self->{z} = 0;
- }
-
-You could also use another Moose method modifier, C<override> here,
-and get the same results again. Here is how that would look:
-
- override 'clear' => sub {
- my $self = shift;
- super();
- $self->{z} = 0;
- };
-
-The C<override> modifier allows you to use the C<super> keyword
-within it to dispatch to the superclass's method in a very Ruby-ish
-style.
-
-Now, of course, what use is a class if you can't instantiate objects
-with it? Since B<Point> inherits from L<Moose::Object>, it will also
-inherit the default L<Moose::Object> constructor: C<new>. Here
-are two examples of how that is used:
-
- my $point = Point->new(x => 1, y => 2);
- my $point3d = Point3D->new(x => 1, y => 2, z => 3);
-
-As you can see, C<new> accepts named argument pairs for any of the
-attributes. It does not I<require> that you pass in the all the
-attributes, and it will politely ignore any named arguments it does
-not recognize.
-
-From here on, you 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/001_recipe.t> test file.
-
-=head1 CONCLUSION
-
-I hope this recipe has given you some explanation of how to use
-Moose to build your Perl 5 classes. The next recipe will build upon
-the basics shown here with more complex attributes and methods.
-Please read on :)
-
-=head1 FOOTNOTES
-
-=over 4
-
-=item (1)
-
-Several default type constraints are provided by Moose, of which
-C<Int> is one. For more information on the builtin type constraints
-and the type constraint system in general, see the
-L<Moose::Util::TypeConstraints> documentation.
-
-=item (2)
-
-Moose supports using instance structures other than blessed hash
-references (such as in a glob reference -- see
-L<MooseX::GlobRef::Object>). If you want your Moose classes to
-be interchangeable, it is advisable to avoid direct instance
-access, like that shown above. Moose does let you get and set
-attributes directly without exposing the instance structure, but
-that's an advanced topic (intrepid readers should refer to the
-L<Moose::Meta::Attribute documentation>).
-
-=back
-
-=head1 SEE ALSO
-
-=over 4
-
-=item Method Modifiers
-
-The concept of method modifiers is directly ripped off from CLOS. A
-great explanation of them can be found by following this link.
-
-L<http://www.gigamonkeys.com/book/object-reorientation-generic-functions.html>
-
-=back
-
-=head1 AUTHOR
-
-Stevan Little E<lt>stevan@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
\ No newline at end of file
+++ /dev/null
-
-=pod
-
-=head1 NAME
-
-Moose::Cookbook::Recipe2 - A simple B<BankAccount> example
-
-=head1 SYNOPSIS
-
- package BankAccount;
- use Moose;
-
- has 'balance' => (isa => 'Int', is => 'rw', default => 0);
-
- sub deposit {
- my ($self, $amount) = @_;
- $self->balance($self->balance + $amount);
- }
-
- sub withdraw {
- my ($self, $amount) = @_;
- my $current_balance = $self->balance();
- ($current_balance >= $amount)
- || confess "Account overdrawn";
- $self->balance($current_balance - $amount);
- }
-
- package CheckingAccount;
- use Moose;
-
- extends 'BankAccount';
-
- has 'overdraft_account' => (isa => 'BankAccount', is => 'rw');
-
- before 'withdraw' => sub {
- my ($self, $amount) = @_;
- my $overdraft_amount = $amount - $self->balance();
- if ($self->overdraft_account && $overdraft_amount > 0) {
- $self->overdraft_account->withdraw($overdraft_amount);
- $self->deposit($overdraft_amount);
- }
- };
-
-=head1 DESCRIPTION
-
-In the first recipe we demonstrated the construction of basic
-Moose classes whose attributes had various accessor schemes and
-builtin type constraints. However, our objects were very data-
-oriented, and did not have many behavioral aspects (i.e. methods)
-to them. In this recipe, we will expand upon the concepts from
-the first recipe and give a more realistic scenario of more
-behavior oriented classes.
-
-We are using the example of a bank account, which has a standard
-account (you can deposit money, withdraw money and check your
-current balance), and a checking account which has optional
-overdraft protection. The overdraft protection will protect the
-owner of the checking account by automatically withdrawing the
-needed funds from the overdraft account to ensure that a check
-will not bounce.
-
-Now, onto the code. The first class, B<BankAccount>, introduces a
-new attribute feature: a default value.
-
- has 'balance' => (isa => 'Int', is => 'rw', default => 0);
-
-This tells us that a B<BankAccount> has a C<balance> attribute,
-which has the C<Int> type constraint, a read/write accessor,
-and a default value of C<0>. This means that every instance of
-B<BankAccount> that is created will have its C<balance> slot
-initialized to C<0>. Very simple really :)
-
-Next come the methods. The C<deposit> and C<withdraw> methods
-should be fairly self-explanatory; they are nothing specific to
-Moose, just your standard Perl 5 OO.
-
-Now, onto the B<CheckingAccount> class. As you know from the
-first recipe, the keyword C<extends> sets a class's superclass
-relationship. Here we see that B<CheckingAccount> is a
-B<BankAccount>. The next line introduces yet another new aspect
-of Moose, that of class-based type-constraints:
-
- has 'overdraft_account' => (isa => 'BankAccount', is => 'rw');
-
-Up until now, we have only had C<Int> type constraints, which
-(as I said in the first recipe) is a builtin type constraint
-that Moose provides for you. The C<BankAccount> type constraint
-is new, and was actually defined the moment we created the
-B<BankAccount> class itself. In fact, for every class in
-your program, a corresponding type constraint will be created. This
-means that in the first recipe, both C<Point> and C<Point3D> type
-constraints were created, and in this recipe, both C<BankAccount>
-and C<CheckingAccount> type constraints were created. Moose does
-this as a convenience so that your class model and the type
-constraint model can be kept in sync with one another. In short,
-Moose makes sure that it will just DWIM (1).
-
-Next, we come to the behavioral part of B<CheckingAccount>, and
-again we see a method modifier, but this time it is a C<before>
-modifier.
-
- before 'withdraw' => sub {
- my ($self, $amount) = @_;
- my $overdraft_amount = $amount - $self->balance();
- if ($self->overdraft_account && $overdraft_amount > 0) {
- $self->overdraft_account->withdraw($overdraft_amount);
- $self->deposit($overdraft_amount);
- }
- };
-
-Just as with the C<after> modifier from the first recipe, Moose
-will handle calling the superclass method (in this case the
-C<BankAccount::withdraw> method). The C<before> modifier shown
-above will run (obviously) I<before> the code from the superclass
-with run. The C<before> modifier here implements the overdraft
-protection by first checking if there are enough available
-funds in the checking account and if not (and if there is an overdraft
-account available), it transfers the appropriate funds into the
-checking account.
-
-As with the method modifier in the first recipe, there is another
-way to accomplish this same thing using the built in C<SUPER::>
-pseudo-package. So the above method is equivalent to the one here.
-
- sub withdraw {
- my ($self, $amount) = @_;
- my $overdraft_amount = $amount - $self->balance();
- if ($self->overdraft_account && $overdraft_amount > 0) {
- $self->overdraft_account->withdraw($overdraft_amount);
- $self->deposit($overdraft_amount);
- }
- $self->SUPER::withdraw($amount);
- }
-
-The benefits of taking the method modifier approach is that the
-author of the B<BankAccount> subclass does not need to remember
-to call C<SUPER::withdraw> and to pass it the C<$amount> argument.
-Instead the method modifier ensures that all arguments make it
-to the superclass method correctly. But this is actually more
-than just a convenience for forgetful programmers, it also helps
-isolate subclasses from changes in the superclasses. For instance,
-if B<BankAccount::withdraw> were to add an additional argument
-of some kind, the version of B<CheckingAccount::withdraw> which
-uses C<SUPER::withdraw> would not pass that extra argument
-correctly, whereas the method modifier version would automatically
-pass along all arguments correctly.
-
-Just as with the first recipe, object instantiation is a fairly
-normal process, here is an example:
-
- my $savings_account = BankAccount->new(balance => 250);
- my $checking_account = CheckingAccount->new(
- balance => 100,
- overdraft_account => $savings_account
- );
-
-And as with the first recipe, a more in-depth example of using
-these classes can be found in the F<t/000_recipes/002_recipe.t> test file.
-
-=head1 CONCLUSION
-
-The aim of this recipe was to take the knowledge gained in the
-first recipe and expand upon it with a more realistic use case. I
-hope that this recipe has accomplished this goal. The next recipe
-will expand even more upon the capabilities of attributes in Moose
-to create a behaviorally sophisticated class almost entirely
-defined by attributes.
-
-=head1 FOOTNOTES
-
-=over 4
-
-=item (1)
-
-Moose does not attempt to encode a class's is-a relationships
-within the type constraint hierarchy. Instead, Moose just
-considers the class type constraint to be a subtype of C<Object>,
-and specializes the constraint check to allow for subclasses. This
-means that an instance of B<CheckingAccount> will pass a
-C<BankAccount> type constraint successfully. For more details,
-please refer to the L<Moose::Util::TypeConstraints> documentation.
-
-=back
-
-=head1 SEE ALSO
-
-=over 4
-
-=item Acknowledgment
-
-The BankAccount example in this recipe is directly taken from the
-examples in this chapter of "Practical Common Lisp":
-
-L<http://www.gigamonkeys.com/book/object-reorientation-generic-functions.html>
-
-=back
-
-=head1 AUTHOR
-
-Stevan Little E<lt>stevan@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
=head1 NAME
-Moose::Cookbook::Recipe10 - The Moose::Role example
+Moose::Cookbook::Roles::Recipe1 - The Moose::Role example
=head1 SYNOPSIS
=head1 NAME
-Moose::Cookbook::Recipe11 - Advanced Role Composition - method exclusion and aliasing
+Moose::Cookbook::Roles::Recipe2 - Advanced Role Composition - method exclusion and aliasing
=head1 SYNOPSIS
+++ /dev/null
-
-=pod
-
-=head1 NAME
-
-Moose::Cookbook::Snack::ArrayRef - Using the ArrayRef type constraint
-
-=head1 SYNOPSIS
-
- package Fruit;
- use Moose;
-
- has 'name' => (is => 'rw', required => 1);
- has 'species' => (is => 'rw', required => 1);
-
- package ProduceStore;
- use Moose;
- use Moose::Util::TypeConstraints;
-
- has 'fruit_aisle' => (isa => 'ArrayRef[Fruit]', is => 'rw');
-
- package main;
-
- # we need something to put in the fruit aisle
- my $orange = Fruit->new(name => 'orange', species => 'C. sinensis');
- my $apple = Fruit->new(name => 'apple', species => 'M. domestica');
- my @fruit = ($apple, $orange);
- my $store = ProduceStore->new(fruit_aisle => \@fruit);
-
-=head1 DESCRIPTION
-
-The ArrayRef type constraint is used to store a reference to a Perl list or
-array variable as an attribute of a Moose object.
-
-=head2 Disclaimer
-
-The code in this document will work on Moose as advertised, but the developers
-strongly recommend using something like L<Moose::Autobox> or
-L<MooseX::AttributeHelpers> when working with array references in order to
-help keep your Moose objects nice and encapsulated.
-
-=head2 Assigning arrays to an ArrayRef attribute
-
-Once a Moose-based object with an C<ArrayRef> attribute has been created, you
-can pass an array (by reference) to that object attribute using that
-attribute's accessor. This is how we assign the apple and orange to the
-store's C<fruit_aisle> C<ArrayRef> attribute, we pass an array containing both
-objects by reference to the C<fruit_aisle> attribute:
-
- my @fruit = ($apple, $orange);
- my $store = ProduceStore->new(fruit_aisle => \@fruit);
-
-Or you can pass an anonymous array to the C<ArrayRef> attribute as well. If
-you created two new objects, C<$grape> and C<$tomato>, and assigned them to
-the C<ArrayRef>, they would replace the apple and the orange in the store's
-fruit aisle:
-
- $store->fruit_aisle( [$grape, $tomato] );
-
-Our C<fruit_aisle> C<ArrayRef> is parameterized, meaning, that the
-C<fruit_aisle> C<ArrayRef> can contain nothing but C<Fruit> objects as array
-values. If you try to pass in a reference to a array using C<Str> objects as
-array values for example, Moose will complain:
-
- Attribute (fruit_aisle) does not pass the type constraint (ArrayRef[Str])
-
-=head2 Dumping the contents of an ArrayRef
-
-In order to dump the contents of a C<ArrayRef> object attribute, you must first
-de-reference the C<ArrayRef>, and then enumerate over it's keys. You can add
-this method for showing the store's inventory to the C<ProduceStore>
-object shown in the SYNOPSIS:
-
- sub show_inventory {
- my $self = shift;
- foreach my $item ( @{$self->fruit_aisle} ) {
- # ... access each Fruit object
- }
- }
-
-=head2 Assigning arrays to an ArrayRef will overwrite existing arrays
-
-Once you create an object containing a C<ArrayRef> attribute, if you assign a
-new array reference to that attribute, it will replace any existing array
-reference:
-
- # replace existing inventory
- my $grape = Fruit->new(name => 'grape', species => 'V. vinifera');
- my $tomato = Fruit->new(name => 'tomato', species => 'S. lycopersicum');
- $store->fruit_aisle( [$grape, $tomato] );
-
-=head2 Appending/Deleting values to/from an ArrayRef
-
-In order to append new elements to an array referred to by the C<ArrayRef>
-attribute, you will need to make a copy of the array first, add your new array
-elements, then assign your modified copy back to the C<ArrayRef> attribute:
-
- my @fruit_aisle_copy = @{$store->fruit_aisle};
- my $avocado = Fruit->new(name => 'avocado', species => 'P. americana');
- push(@fruit_aisle_copy, $avocado);
- $store->fruit_aisle( \@fruit_aisle_copy );
-
-And here's an example of deleting an object stored in an ArrayRef:
-
- my @fruit_aisle_copy = @{$store->fruit_aisle};
- # new array to hold the fruit objects that won't be deleted
- my @reworked_fruit_aisle;
- for my $fruit_obj ( @fruit_aisle_copy ) {
- if ( $fruit_obj->name ne 'tomato' ) {
- push(@reworked_fruit_aisle, $fruit_obj);
- }
- }
- $store->fruit_aisle( \@reworked_fruit_aisle );
-
-Putting the above code into their own object methods would make appending to or deleting from an C<ArrayRef> a trivial operation.
-
-=head2 Clearing an ArrayRef
-
-Assigning C<undef> to clear an C<ArrayRef> will not work because the attribute
-was originally defined with a type constraint, meaning that attribute must have
-0 or more of that type of value to be valid. C<undef> in Perl is not a value,
-so it won't work for clearing the C<ArrayRef>.
-
-If you assign an empty anonymous hash to a C<ArrayRef> attribute, this will
-clear out that attribute yet still satisfy the type constraint.
-
- # this clears the ArrayRef
- $store->fruit_aisle( [ ] );
-
-=head1 SEE ALSO
-
-=over 4
-
-=item L<Moose::Cookbook::Recipe4> - Subtypes, and modeling a simple Company
-class hierarchy
-
-=item L<Moose::Cookbook::Snack::Types> - Snippets of code for using Types and
-Type Constraints
-
-=item L<Moose::Util::TypeConstraints> - Type constraints that Moose can use
-and the tools to extend them or create your own.
-
-=item L<Moose::Autobox> - Autoboxed wrappers for Native Perl datatypes
-
-=item L<MooseX::AttributeHelpers> - Extends attribute interfaces
-
-=back
-
-=head1 AUTHOR
-
-Brian Manning <elspicyjack at gmail dot com>
-
-=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
+++ /dev/null
-
-=pod
-
-=head1 NAME
-
-Moose::Cookbook::Snack::BUILD - Custom initialization methods for Moose objects
-
-=head1 SYNOPSIS
-
- package Build::Demo;
- use Moose;
-
- # once the object has been created, don't allow
- # changes to 'example_file'
- has 'example_file' => (is => 'ro', required => 1);
-
- sub BUILD {
- my $self = shift;
- # create the object only if the 'example_file' exists
- if (-e $self->example_file) {
- return $self;
- }
- else {
- die('ERROR: file _' . $self->example_file . '_ does not exist');
- }
- }
-
- package main;
- use Moose;
-
- # the name of this script, which works
- my $first_test = Build::Demo->new(example_file => $0);
- # this should fail (unless there's a file named 'foo'
- # in the current directory)
- my $second_test = Build::Demo->new(example_file => 'foo');
-
-=head1 DESCRIPTION
-
-The C<BUILD()> method allows you to write your own initialization methods for
-your Moose objects.
-
-=head2 Creating new objects in Perl and Moose
-
-By convention, most objects in Perl are created by calling a C<new()> method
-inside that object:
-
- package My::Perl::Class;
-
- sub new {
- # object blessing and initialization code goes here...
- }
-
- package main;
- my $object = My::Perl::Class->new();
-
-Moose is no different in this respect. However, since Moose handles the
-C<new()> method for you, how do you change the default behaivor of the
-C<new()> method in Moose? This is what the C<BUILD()> method was designed
-for.
-
- package My::Moose::Class;
-
- sub BUILD {
- # object initialization code goes here...
- }
-
- package main;
- my $object = My::Moose::Class->new();
-
-=head2 Why would you want a custom constructor?
-
-If your object needs to verify some behaivor or internal state before it is
-created, a good time to do that is when the object is being created. Why
-waste resources (CPU, memory) on objects that won't work because of missing
-resources?
-
-=head2 When would you use an Moose type constraint instead of a custom constructor?
-
-Using type constraints via L<Moose::Util::TypeConstraints>, you can verify
-simple relationships when an object is created:
-
- package Triangle;
- use Moose;
-
- has
-
-You would want to use the C<BUILD()> method in order to verify more complex
-relationships:
-
- package IsoscelesTriangle;
- use Moose;
-
-=head2 BUILD method is run only if it is defined in the object
-
-If your object does not have a C<BUILD> method, then Moose will skip trying to
-run it.
-
-=head2 What is 'BUILDALL'?
-
-(Taken from L<Moose::Object>) The C<BUILDALL> method will call every BUILD
-method in the inheritance hierarchy, and pass it a hash-ref of the the
-C<%params> passed to the C<new()> method.
-
-=head1 SEE ALSO
-
-=over 4
-
-=item L<Moose::Object> - The base object for Moose (BUILDALL)
-
-=item L<Moose::Cookbook::FAQ> - Frequently asked questions about Moose
-(How do I write custom constructors with Moose?)
-
-=item L<Moose::Cookbook::Recipe4> - Subtypes, and modeling a simple
-Company class heirarchy (Example usage of BUILD in action)
-
-=item L<Moose::Cookbook::WTF> - For when things go wrong with Moose
-('Roles' section describes BUILD/BUILDALL)
-
-=back
-
-=head1 AUTHOR
-
-Brian Manning <elspicyjack at gmail dot com>
-
-=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
+++ /dev/null
-
-=pod
-
-=head1 NAME
-
-Moose::Cookbook::Snack::HashRef - Using the HashRef type constraint
-
-=head1 SYNOPSIS
-
- package Fruit;
- use Moose;
-
- has 'species' => ( is => 'rw', required => 1 );
-
- package ProduceStore;
- use Moose;
- use Moose::Util::TypeConstraints;
-
- has 'fruit_aisle' => ( is => 'rw', isa => 'HashRef[Fruit]' );
-
- package main;
- use Moose;
-
- # we need something to put in the fruit aisle
- my $orange = Fruit->new( species => 'C. sinensis' );
- my $apple = Fruit->new( species => 'M. domestica' );
- my %fruit = ( orange => $orange, apple => $apple );
- my $store = ProduceStore->new( fruit_aisle => \%fruit );
-
-=head1 DESCRIPTION
-
-The HashRef type constraint is used to store a reference to a Perl hash
-variable as an attribute of a Moose object.
-
-=head2 Disclaimer
-
-The code in this document will work on Moose as advertised, but the developers
-strongly recommend using something like L<Moose::Autobox> or
-L<MooseX::AttributeHelpers> when working with hash references in order to
-help keep your Moose objects nice and encapsulated. The reason why this POD
-exists is to show potential users of L<Moose> that Moose objects are just like
-Plain Ol' Perl Objects (POPO), albeit with some extra metadata syntatic sugar.
-
-=head2 Assigning hashes to a HashRef attribute
-
-Once a Moose-based object with a C<HashRef> attribute has been created, you
-can pass a hash (by reference) to that attribute using that attribute's
-accessor. This is how we assign the apple and orange to the store's
-C<fruit_aisle> C<HashRef> attribute, we pass a hash containing both objects by
-reference to the C<fruit_aisle> attribute:
-
- my %fruit = ( orange => $orange, apple => $apple );
- my $store = ProduceStore->new( fruit_aisle => \%fruit );
-
-Or you can pass an anonymous hash to the C<HashRef> attribute as well. If you
-created two new objects, C<$grape> and C<$tomato>, and assigned them to the
-C<HashRef>, they would replace the apple and the orange in the store's fruit
-aisle:
-
- $store->fruit_aisle( { grape => $grape, tomato => $tomato } );
-
-Our C<fruit_aisle> C<HashRef> example is parameterized, meaning, that the
-C<fruit_aisle> C<HashRef> can contain nothing but C<Fruit> objects as hash
-values. If you try to pass in a reference to a hash using C<Int> objects as
-hash values for example, Moose will complain:
-
- Attribute (fruit_aisle) does not pass the type constraint (HashRef[Int])
-
-=head2 Dumping the contents of the HashRef
-
-In order to dump the contents of a C<HashRef> object attribute, you must first
-de-reference the C<HashRef>, and then enumerate over it's keys.
-
- foreach my $item ( keys(%{$self->fruit_aisle}) ) {
- my $fruit = $self->{fruit_aisle}{$item};
- print "Item: $item, type: " . $fruit->meta->name
- . " species: " . $fruit->species . "\n";
- }
-
-If the above de-referencing of the C<fruit_aisle> C<HashRef> is a little too
-noisy, you could create a copy of it, and then enumerate over that copy:
-
- my %fruit_aisle_copy = %{$self->fruit_aisle};
- foreach my $item ( keys(%fruit_aisle_copy) ) {
- my $fruit = $fruit_aisle_copy{$item};
- print "Item: $item, type: " . $fruit->meta->name
- . " species: " . $fruit->species . "\n";
- }
-
-=head2 Assigning to a HashRef attribute will overwrite
-
-Once you create an object containing a C<HashRef> attribute, if you assign a
-new hash reference to that attribute, it will replace any existing hash
-reference:
-
- # this replaces the existing HashRef contents
- my $grape = Fruit->new( species => 'V. vinifera' );
- my $tomato = Fruit->new( species => 'S. lycopersicum');
- $store->fruit_aisle( { grape => $grape, tomato => $tomato } );
-
-=head2 Appending/Deleting key/value pairs to a HashRef
-
-In order to append or delete key/value pairs to the hash referred to by the
-C<HashRef> attribute, you will need to make a copy of the hash first, add or
-delete the desired key/value pairs, then assign your modified copy back to the
-C<HashRef> attribute. Here's an example of appending new key/value pars:
-
- my %fruit_aisle_copy = %{$store->fruit_aisle};
- my $avocado = Fruit->new( species => 'P. americana' );
- $fruit_aisle_copy{avocado} = $avocado;
- $store->fruit_aisle( \%fruit_aisle_copy );
- $store->fruit_aisle->{avocado};
-
-And here's an example of deleting existing key/value pairs:
-
- # delete an attribute from the HashRef
- %fruit_aisle_copy = %{$store->fruit_aisle};
- delete($fruit_aisle_copy{tomato});
- $store->fruit_aisle( \%fruit_aisle_copy );
- delete $mooseObj->hashref->{foo};
-
-Putting the above code into their own object methods would make appending to
-and deleting from a C<HashRef> a trivial operation.
-
-=head2 Clearing the HashRef
-
-Assigning C<undef> to clear a C<HashRef> will not work because the attribute
-was originally defined with a type constraint, meaning that attribute must have
-0 or more of that type of value to be valid. B<undef> in Perl is not a value,
-so it won't work for clearing the C<HashRef>.
-
-If you assign an empty anonymous hash to a C<HashRef> attribute, this will
-clear out that attribute yet still satisfy the type constraint.
-
- # this clears the HashRef
- $store->fruit_aisle( { } );
-
-=head1 SEE ALSO
-
-=over 4
-
-=item L<Moose::Cookbook::Snack::Types> - Snippets of code for using Types and
-Type Constraints
-
-=item L<Moose::Util::TypeConstraints> - Type constraints that Moose can use
-and the tools to extend them or create your own.
-
-=item L<Moose::Autobox> - Autoboxed wrappers for Native Perl datatypes
-
-=item L<MooseX::AttributeHelpers> - Extends attribute interfaces
-
-=back
-
-=head1 AUTHOR
-
-Brian Manning <elspicyjack at gmail dot com>
-
-=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
Moose::Cookbook::Snack::Keywords - Restricted keywords in Moose
-=cut
-
=head1 DESCRIPTION
-There are several keywords exported in L<Moose> that cause clashes against
-any barewords such as attribute names, sub names, and globs.
-
+There are several keywords exported by L<Moose> that can cause clashes
+against other user-defined barewords. The following document provides
+a list of those keywords in a single place for easy reference.
=head2 The 'meta' keyword
While most of the reserved keywords collisions can be avoided, however
-I<meta> is the only one you B<cant> override. Do not attempt to override
-I<meta>.
+I<meta> is the only one you B<can not> override. Do not attempt to override
+I<meta>, it will break the Moose internals.
=head2 Moose Keywords
-If you are using Moose its best to avoid these keywords
+If you are using L<Moose> or L<Moose::Role> its best to avoid these
+keywords:
=over 4
=item augment
-=item make_immutable
-
=item confess
=item blessed
=head2 Moose::Util::TypeConstraints Keywords
-If you are using Moose::Util::TypeConstraints its best to avoid
+If you are using L<Moose::Util::TypeConstraints> its best to avoid
these keywords
=over 4
=back
=head2 Avoiding collisions
-
+
=head3 Turning off Moose
-To remove the keywords Moose exports using no Moose at the bottom of your code
+To remove the keywords L<Moose> exports just add C<no Moose> at the bottom of
+your code, like so:
- package Thing;
- use Moose;
+ package Thing;
+ use Moose;
- # code here
+ # code here
- no Moose;
+ no Moose;
+
+This will un-export the keywords that L<Moose> originally exported. The same
+will also work for L<Moose::Role> and L<Moose::Util::TypeConstraints>. It is
+general L<Moose> policy that this feature is used.
=head3 Sub::Exporter
-The L<Sub::Exporter> module can rename keywords
+L<Moose>, L<Moose::Role> and L<Moose::Util::TypeConstraints> all use
+L<Sub::Exporter> to handle all their exporting needs. This means that all the
+features that L<Sub::Exporter> provides are also available to them.
- package LOL::Cat;
- use Moose 'has' => { -as => 'i_can_haz' };
+For instance, with L<Sub::Exporter> you can rename keywords, like so:
- i_can_haz 'cheeseburger' => (
- is => 'rw',
- trigger => sub { print "NOM NOM" }
- );
+ package LOL::Cat;
+ use Moose 'has' => { -as => 'i_can_haz' };
+
+ i_can_haz 'cheeseburger' => (
+ is => 'rw',
+ trigger => sub { print "NOM NOM" }
+ );
+
+ LOL::Cat->new->cheeseburger('KTHNXBYE');
- LOL::Cat->new->cheeseburger('KTHNXBYE');;
+See the L<Sub::Exporter> docs for more information.
=head3 namespace::clean
-You can use L<namespace::clean> to clean up the namespace
+You can also use L<namespace::clean> to clean up your namespace, but you must
+be careful not to remove C<meta> with this. Here is an example of that usage:
+
+ package Foo;
+ use Moose;
+ use namespace::clean -except => 'meta';
+ # ...
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<Moose>
+
+=item L<Moose::Role>
+
+=item L<Moose::Utils::TypeConstraints>
+
+=item L<Sub::Exporter>
+
+=item L<namespace::clean>
-=head1 AUTHOR AND COPYRIGHT
+=back
+
+=head1 AUTHOR
John Goulah C<E<lt>jgoulah@cpan.org<gt>>
-=head1 LICENSE
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
-This program is free software; you can redistribute it and/or modify
-it under the same terms as perl itself.
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
=cut
+++ /dev/null
-
-=pod
-
-=head1 NAME
-
-Moose::Cookbook::Snack::Perl5ObjsVsMooseObjs - Short comparison between Perl 5
-objects and Moose objects
-
-=head1 SYNOPSIS
-
- package Moose::Demo;
- use Moose; # automagically sets 'strict' and 'warnings'
-
- has 'script_name' => ( is => 'rw', required => 1);
-
- package main;
-
- # '$0' is the name of this script, set automatically by Perl
- my $demo = Moose::Demo->new( script_name => $0 );
-
- print "My name is " . $demo->script_name . "\n";
- print "I am a " . $demo->meta->name . " type of object\n";
-
-=head1 DESCRIPTION
-
-So what's the big stink about Moose? Perl 5 comes with objects and object
-oriented programming already. Given the above Moose code, what would similar
-code look like in the existing Perl 5 object-oriented style of programming?
-Let's take a look and find out...
-
-=head2 Perl 5 OO Example
-
- # Perl 5 Object, as taught by the 'perltoot' POD page
- package Perl5::Demo;
- use strict;
- use warnings;
-
-
- sub new {
- my $class = shift;
- # assign the rest of the method arguments to a temp hash
- my %args = @_;
-
- # create the object out of a blessed hash reference
- my $self = bless ( {}, ref($class) || $class );
- # create the script_name attribute
- $self->{script_name} = undef;
-
- # verify that the user passed in the 'script_name' attribute
- if ( exists $args{script_name} ) {
- $self->script_name($args{script_name});
- }
- else {
- die "ERROR: can't create object without 'script_name' ";
- }
-
- # return the object reference back to the caller
- return $self;
- }
-
- sub script_name {
- my $self = shift;
- # check for arguments; use the argument
- # if passed in, otherwise return the
- # existing value (if any)
- if (@_) {
- $self->{script_name} = shift;
- }
- return $self->{script_name};
- }
-
- package main;
- use strict;
- use warnings;
-
- my $demo = Perl5::Demo->new( script_name => $0 );
-
- print "My name is " . $demo->script_name . "\n";
- print "I am a " . ref($demo) . " type of object\n";
-
-Looks more complex, right? Moose does a lot of the labor when working with
-Perl objects, so that you don't have to. What are some of the specific
-differences between Moose and Perl 5 Objects?
-
-=head3 Difference #1 - declaration of object attributes
-
-Both the Moose and Perl 5 objects have one attribute, C<script_name>. It's a
-good programming practice to always validate user input, so we have the Perl 5
-object check to make sure that the user passes in the C<script_name> attribute
-to it when the object is created. The Moose object automatically checks this
-for us when we set C<required =E<gt> 1> in the C<has> function for the Moose
-object.
-
-In more advanced Moose usage, you can use something called 'type constraints'
-when creating your Moose objects. Type constraints are used to validate what
-the user passes in when setting Moose object attributes. If the user passes
-in a type of data that Moose is not expecting, then the type constraints in
-Moose (specifically, the L<Moose::Util::TypeConstraint> module) will let the
-user know this in no uncertain terms. Type constraints in Moose can be as
-simple as strings or numbers, or as complex as other Moose objects.
-
-=head3 Difference #2 - strict and warning pragmas
-
-Moose sets the 'strict' and 'warnings' pragmas for you automatically. We have
-to do this for ourselves in the Perl 5 example.
-
-=head3 Difference #3 - Determining an object's class name
-
-The C<ref()> function in Perl 5 is how you determine an object's class name.
-The proper way to do this with Moose is C<$object-E<gt>meta-E<gt>name>;
-
- # an object's class name in Perl 5 OO
- print "I am a " . ref($demo) . " type of object\n";
-
- # an object's class name in Moose
- print "I am a " . $demo->meta->name . " type of object\n";
-
-Moose builds on C<Class::MOP> to provide a rich introspection API that
-goes way beyond just getting the class name. Check out the
-C<Class::MOP> documentation for more details.
-
-=head3 Difference #4 - Assigning values to Moose object attributes
-
-When you wish to assign a value directly to an object attribute for a Perl 5
-object, you can either create an object method that handles the value for you;
-
- package Perl5Object;
- sub set_x { # some code here that sets 'x' }
- package main;
- # later on...
- $self->set_x(0);
-
-or you can assign the value directly to the Perl 5 object attribute like this:
-
- $self->{x} = 0;
-
-Moose creates object methods for handling attributes for you, as long as you
-specified C<is =E<gt> rw> for each C<has> statement inside the object
-declaration. This is mentioned in L<Moose::Cookbook::WTF>, in the section
-labeld B<Accessors>, but briefly:
-
- package MooseObject;
- has 'x' => (is => 'rw');
- package main;
- # later on...
- $self->x(0);
-
-The syntax shown for the Perl 5 object (C<$self-E<gt>{x} = 0>) will
-also work on the Moose object, as Moose objects are, by default,
-blessed hashes just like the average Perl object is. However, if you
-access the object's hash reference directly via the latter syntax you
-will have several problems.
-
-First, Moose will no longer be able to enforce attribute constraints,
-such as read-only or type constraints. Second, you've broken that
-object's encapsulation, and encapsulation is one of the reasons you
-want to use objects in the first place, right?
-
-=head1 SEE ALSO
-
-=over 4
-
-=item L<Moose::Cookbook::Recipe1> - The 'Point' object example
-
-=item L<Moose::Util::TypeConstraints> - Type constraints that Moose can use
-and the tools to extend them or create your own.
-
-=item L<Moose::Cookbook::WTF> - For when things go wrong with Moose
-
-=back
-
-=head1 AUTHOR
-
-Brian Manning <elspicyjack at gmail dot com>
-
-=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
=head1 DESCRIPTION
-This is the Point example from (L<Moose::Cookbook::Recipe1>) with added
+This is the Point example from (L<Moose::Cookbook::Basics::Recipe1>) with added
type checking.
If we try to assign a string value to an attribute that is defined as
=over 4
-=item L<Moose::Cookbook::Recipe1>
+=item L<Moose::Cookbook::Basics::Recipe1>
=item L<Moose::Utils::TypeConstraints>
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
--- /dev/null
+=pod
+
+=head1 NAME
+
+Moose::Cookbook::Style - The latest in trendy Moose cuisine
+
+=for authors
+
+Please annotate all bad examples with comments so that they won't be copied by
+accident
+
+=cut
+
+=head1 Benefits of Good Style
+
+Good Moose style, as defined by this document, helps ensure your code has the
+following desirable properties:
+
+=over 4
+
+=item Play well with others
+
+Your code will be more reusable and easier to extend.
+
+=item Ease maintenance
+
+The code will be easier to understand because it follows an accepted set of
+conventions and idioms.
+
+This will help others maintaining your code, and also help you to get support
+on IRC for instance.
+
+=item Help Moose generate better code
+
+By using the most appropriate features, the generated code will be safer and
+more efficient.
+
+=item Benefit from meta programming
+
+Code that operates on the metaclass will benefit from clean meta definitions.
+
+If you are manually converting argument types with C<around 'new'> there is no
+meta data explaining your intention. If on the other hand you use coercions,
+there is introspectable meta data that makes this clear.
+
+This means that e.g. MooseX extensions that work by introspecting your class
+will be able to do the right thing more often, because they don't need to
+guess.
+
+=back
+
+=head1 Don't change C<new>
+
+It is generally considered bad style to override L<Moose::Object/new> for a
+number of reasons.
+
+The first reason is consistency. Subclasses of your class and code
+instantiating your class would be simpler if your constructor works closer to
+the default.
+
+The second reason is performance. By calling C<make_immutable> on your metaclass:
+
+ __PACKAGE__->meta->make_immutable;
+
+And opting out of any class definition changes from that point on, you allow
+Moose to create more efficient versions of certain generic methods. Moose will
+generate a tight, optimal C<new> for you, based on the minimal set of features
+you use.
+
+Moose provides many features that allow you to do common object construction
+tasks at the right level of abstraction.
+
+When attributes have the ability to provide the necessary functionality, use
+that. If that isn't sufficient, L<Moose::Object> has numerous features you can
+use at construction time.
+
+=head2 Use C<BUILD> instead of custom initialization or overriding C<new>
+
+Instead of changing C<new>, do initialization in C<BUILD>.
+
+The construction parameters are passed in, so you don't need to replicate
+C<BUILDARGS>, and since C<BUILD> is called for each superclass that defines it,
+you will never forget to invoke your initializers if you extend them.
+
+=head2 Use C<default>, C<builder> or C<lazy_build>
+
+To initialize attributes there is a plethora of methods preferable to assigning
+the value at initialization time.
+
+If you want to translate parameter data, use coercions.
+
+If you want to ensure a parameter can't be overridden by the constructor, set
+the C<init_arg> to C<undef> instead of overwriting it in C<BUILD>.
+
+=head2 Use C<BUILDARGS> to alter C<@_> processing
+
+If you need to change the way C<@_> is processed, for example for
+C<< Class->new( $single_param ) >>, use C<BUILDARGS> instead of wrapping
+C<new>. This ensures the behavior is subclassible, it keeps this logic
+independent of the other aspects of construction, and can be made efficient
+using C<make_immutable>.
+
+=head1 Don't pollute the global type registry
+
+=head2 Use fully qualified type names for your own data
+
+L<MooseX::Types> provides a convenient method to do this.
+
+If you define
+
+ # Bad style:
+
+ subtype Person => (
+ as 'Object',
+ where { $_->can("name") },
+ );
+
+Then the global name C<Person> is registered, and this could conflict with
+other bad usage of the sort.
+
+Instead, prefix type name with your project namespace, or class name:
+
+ subtype 'My::Foo::Person' => (
+ as 'Object',
+ where { $_->can("name") },
+ );
+
+Or with L<MooseX::Types>:
+
+ use MooseX::Types::Moose qw(Object);
+
+ use MooseX::Types (
+ -declare => [qw(Person)],
+ );
+
+ subtype Person() => ( # note parenthesis, "Person" is a function, not a string
+ as Object, # MooseX::Types::Moose exported it
+ where { $_->can("name") },
+ );
+
+=head3 Coerce in a subtype
+
+Likewise use fully qualified subtypes of other types for defining coercions, so
+that they won't affect unrelated code, causing action at a distance.
+
+This is important because the type registry is global, kind of like the symbol
+table.
+
+This means that code like:
+
+ # Bad style:
+
+ coerce ArrayRef => (
+ from Str => via { [ split /,/ ] },
+ );
+
+Will add a coercion to B<all> attributes like:
+
+ has foo => (
+ isa => "ArrayRef",
+ coerce => 1,
+ );
+
+when the actual coercion applies only to your specific cases.
+
+=head1 Clean up your package
+
+Use C<namespace::clean> or C<no Moose> to remove the sugar exports.
+
+This will make sure the sugar isn't accidentally called as methods on your objects.
+
+For instance:
+
+ $obj->can("has");
+
+will return true, even though C<has> is not a method.
+
+=head1 Accept no substitutes
+
+By substitutes I mean hacks instead of "proper" solutions.
+
+When you have a tricky requirement, refrain from abusing Moose or MooseX:: or
+whatever it is you are using.
+
+Instead, drop by IRC and discuss it. Most of the time a crazy idea can either
+be simplified, or it will spawn a clean, reliable feature to whatever package
+you are using.
+
+This will improve your code and also share the benefit with others.
+
+=head1 AUTHOR
+
+Yuval (nothingmuch) Kogman
+
+=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
--- /dev/null
+package Moose::Exporter;
+
+use strict;
+use warnings;
+
+use Carp qw( confess );
+use Class::MOP;
+use List::MoreUtils qw( first_index uniq );
+use Moose::Util::MetaRole;
+use Sub::Exporter;
+
+
+my %EXPORT_SPEC;
+
+sub setup_import_methods {
+ my ( $class, %args ) = @_;
+
+ my $exporting_package = $args{exporting_package} ||= caller();
+
+ my ( $import, $unimport ) = $class->build_import_methods(%args);
+
+ no strict 'refs';
+ *{ $exporting_package . '::import' } = $import;
+ *{ $exporting_package . '::unimport' } = $unimport;
+}
+
+sub build_import_methods {
+ my ( $class, %args ) = @_;
+
+ my $exporting_package = $args{exporting_package} ||= caller();
+
+ $EXPORT_SPEC{$exporting_package} = \%args;
+
+ my @exports_from = $class->_follow_also( $exporting_package );
+
+ my $export_recorder = {};
+
+ my $exports = $class->_make_sub_exporter_params(
+ [ $exporting_package, @exports_from ], $export_recorder );
+
+ my $exporter = Sub::Exporter::build_exporter(
+ {
+ exports => $exports,
+ groups => { default => [':all'] }
+ }
+ );
+
+ # $args{_export_to_main} exists for backwards compat, because
+ # Moose::Util::TypeConstraints did export to main (unlike Moose &
+ # Moose::Role).
+ my $import = $class->_make_import_sub( $exporting_package, $exporter,
+ \@exports_from, $args{_export_to_main} );
+
+ my $unimport = $class->_make_unimport_sub( $exporting_package, $exports,
+ $export_recorder );
+
+ return ( $import, $unimport )
+}
+
+{
+ my $seen = {};
+
+ sub _follow_also {
+ my $class = shift;
+ my $exporting_package = shift;
+
+ local %$seen = ( $exporting_package => 1 );
+
+ return uniq( _follow_also_real($exporting_package) );
+ }
+
+ sub _follow_also_real {
+ my $exporting_package = shift;
+
+ die "Package in also ($exporting_package) does not seem to use MooseX::Exporter"
+ unless exists $EXPORT_SPEC{$exporting_package};
+
+ my $also = $EXPORT_SPEC{$exporting_package}{also};
+
+ return unless defined $also;
+
+ my @also = ref $also ? @{$also} : $also;
+
+ for my $package (@also)
+ {
+ die "Circular reference in also parameter to MooseX::Exporter between $exporting_package and $package"
+ if $seen->{$package};
+
+ $seen->{$package} = 1;
+ }
+
+ return @also, map { _follow_also_real($_) } @also;
+ }
+}
+
+sub _make_sub_exporter_params {
+ my $class = shift;
+ my $packages = shift;
+ my $export_recorder = shift;
+
+ my %exports;
+
+ for my $package ( @{$packages} ) {
+ my $args = $EXPORT_SPEC{$package}
+ or die "The $package package does not use Moose::Exporter\n";
+
+ for my $name ( @{ $args->{with_caller} } ) {
+ my $sub = do {
+ no strict 'refs';
+ \&{ $package . '::' . $name };
+ };
+
+ my $fq_name = $package . '::' . $name;
+
+ $exports{$name} = $class->_make_wrapped_sub(
+ $fq_name,
+ $sub,
+ $export_recorder,
+ );
+ }
+
+ for my $name ( @{ $args->{as_is} } ) {
+ my $sub;
+
+ if ( ref $name ) {
+ $sub = $name;
+ $name = ( Class::MOP::get_code_info($name) )[1];
+ }
+ else {
+ $sub = do {
+ no strict 'refs';
+ \&{ $package . '::' . $name };
+ };
+ }
+
+ $export_recorder->{$sub} = 1;
+
+ $exports{$name} = sub {$sub};
+ }
+ }
+
+ return \%exports;
+}
+
+{
+ # 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;
+
+ sub _make_wrapped_sub {
+ 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;
+
+ my $sub = Class::MOP::subname( $fq_name => sub { $sub->( $caller, @_ ) } );
+
+ $export_recorder->{$sub} = 1;
+
+ return $sub;
+ };
+ }
+
+ sub _make_import_sub {
+ shift;
+ my $exporting_package = shift;
+ my $exporter = shift;
+ my $exports_from = shift;
+ my $export_to_main = shift;
+
+ 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(@_);
+
+ # 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;
+
+ $CALLER = Moose::Exporter::_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} ) {
+
+ $c->init_meta( for_class => $CALLER );
+ $did_init_meta = 1;
+ }
+
+ if ( $did_init_meta && @{$traits} ) {
+ _apply_meta_traits( $CALLER, $traits );
+ }
+ elsif ( @{$traits} ) {
+ confess
+ "Cannot provide traits when $class does not have an init_meta() method";
+ }
+
+ goto $exporter;
+ };
+ }
+}
+
+sub _strip_traits {
+ my $idx = first_index { $_ eq '-traits' } @_;
+
+ return ( [], @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
+
+ my $traits = $_[ $idx + 1 ];
+
+ splice @_, $idx, 2;
+
+ $traits = [ $traits ] unless ref $traits;
+
+ return ( $traits, @_ );
+}
+
+sub _apply_meta_traits {
+ my ( $class, $traits ) = @_;
+
+ return unless @{$traits};
+
+ my $meta = $class->meta();
+
+ my $type = ( split /::/, ref $meta )[-1]
+ or confess
+ 'Cannot determine metaclass type for trait application . Meta isa '
+ . ref $meta;
+
+ my @resolved_traits
+ = map { Moose::Util::resolve_metatrait_alias( $type => $_ ) }
+ @$traits;
+
+ return unless @resolved_traits;
+
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => $class,
+ metaclass_roles => \@resolved_traits,
+ );
+}
+
+sub _get_caller {
+ # 1 extra level because it's called by import so there's a layer
+ # of indirection
+ my $offset = 1;
+
+ return
+ ( ref $_[1] && defined $_[1]->{into} ) ? $_[1]->{into}
+ : ( ref $_[1] && defined $_[1]->{into_level} )
+ ? caller( $offset + $_[1]->{into_level} )
+ : caller($offset);
+}
+
+sub _make_unimport_sub {
+ shift;
+ my $exporting_package = shift;
+ my $exports = shift;
+ my $export_recorder = shift;
+
+ return sub {
+ my $caller = scalar caller();
+ Moose::Exporter->_remove_keywords(
+ $caller,
+ [ keys %{$exports} ],
+ $export_recorder,
+ );
+ };
+}
+
+sub _remove_keywords {
+ shift;
+ my $package = shift;
+ my $keywords = shift;
+ my $recorded_exports = shift;
+
+ no strict 'refs';
+
+ foreach my $name ( @{ $keywords } ) {
+
+ if ( defined &{ $package . '::' . $name } ) {
+ my $sub = \&{ $package . '::' . $name };
+
+ # make sure it is from us
+ next unless $recorded_exports->{$sub};
+
+ # and if it is from us, then undef the slot
+ delete ${ $package . '::' }{$name};
+ }
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Moose::Exporter - make an import() and unimport() just like Moose.pm
+
+=head1 SYNOPSIS
+
+ package MyApp::Moose;
+
+ use strict;
+ use warnings;
+
+ use Moose ();
+ use Moose::Exporter;
+
+ Moose::Exporter->setup_import_methods(
+ with_caller => [ 'sugar1', 'sugar2' ],
+ as_is => [ 'sugar3', \&Some::Random::thing ],
+ also => 'Moose',
+ );
+
+ # then later ...
+ package MyApp::User;
+
+ use MyApp::Moose;
+
+ has 'name';
+ sugar1 'do your thing';
+ thing;
+
+ no MyApp::Moose;
+
+=head1 DESCRIPTION
+
+This module encapsulates the logic to export sugar functions like
+C<Moose.pm>. It does this by building custom C<import> and C<unimport>
+methods for your module, based on a spec your provide.
+
+It also lets your "stack" Moose-alike modules so you can export
+Moose's sugar as well as your own, along with sugar from any random
+C<MooseX> module, as long as they all use C<Moose::Exporter>.
+
+=head1 METHODS
+
+This module provides two public methods:
+
+=head2 Moose::Exporter->setup_import_methods(...)
+
+When you call this method, C<Moose::Exporter> build custom C<import>
+and C<unimport> methods for your module. The import method will export
+the functions you specify, and you can also tell it to export
+functions exported by some other module (like C<Moose.pm>).
+
+The C<unimport> method cleans the callers namespace of all the
+exported functions.
+
+This method accepts the following parameters:
+
+=over 4
+
+=item * with_caller => [ ... ]
+
+This a list of function I<names only> to be exported wrapped and then
+exported. The wrapper will pass the name of the calling package as the
+first argument to the function. Many sugar functions need to know
+their caller so they can get the calling package's metaclass object.
+
+=item * as_is => [ ... ]
+
+This a list of function names or sub references to be exported
+as-is. You can identify a subroutine by reference, which is handy to
+re-export some other module's functions directly by reference
+(C<\&Some::Package::function>).
+
+=item * also => $name or \@names
+
+This is a list of modules which contain functions that the caller
+wants to export. These modules must also use C<Moose::Exporter>. The
+most common use case will be to export the functions from C<Moose.pm>.
+
+C<Moose::Exporter> also makes sure all these functions get removed
+when C<unimport> is called.
+
+=back
+
+=head2 Moose::Exporter->build_import_methods(...)
+
+Returns two code refs, one for import and one for unimport.
+
+Used by C<setup_import_methods>.
+
+=head1 IMPORTING AND init_meta
+
+If you want to set an alternative base object class or metaclass
+class, simply define an C<init_meta> method in your class. The
+C<import> method that C<Moose::Exporter> generates for you will call
+this method (if it exists). It will always pass the caller to this
+method via the C<for_class> parameter.
+
+Most of the time, your C<init_meta> method will probably just call C<<
+Moose->init_meta >> to do the real work:
+
+ sub init_meta {
+ shift; # our class name
+ return Moose->init_meta( @_, metaclass => 'My::Metaclass' );
+ }
+
+=head1 METACLASS TRAITS
+
+The C<import> method generated by C<Moose::Exporter> will allow the
+user of your module to specify metaclass traits in a C<-traits>
+parameter passed as part of the import:
+
+ use Moose -traits => 'My::Meta::Trait';
+
+ use Moose -traits => [ 'My::Meta::Trait', 'My::Other::Trait' ];
+
+These traits will be applied to the caller's metaclass
+instance. Providing traits for an exporting class that does not create
+a metaclass for the caller is an error.
+
+=head1 AUTHOR
+
+Dave Rolsky E<lt>autarch@urth.orgE<gt>
+
+This is largely a reworking of code in Moose.pm originally written by
+Stevan Little and others.
+
+=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
--- /dev/null
+=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<declaritively 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 your 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 vs
+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<may have> one or more superclasses (aka parent classes). A
+class inherits from its superclass(es).
+
+A class may I<have> B<method modifiers>. These modifiers can apply to
+its own methods or methods that are inherited from its ancestors.
+
+A class may I<do> one 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 instances>.
+
+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 analagous to 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 a 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, it's 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 declaritively 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@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 the L<Moose::Unsweetened>.
+
+=head1 AUTHOR
+
+Dave Rolsky E<lt>autarch@urth.orgE<gt> and Stevan Little
+E<lt>stevan@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
use Scalar::Util 'blessed', 'weaken';
use overload ();
-our $VERSION = '0.50';
+our $VERSION = '0.57';
our $AUTHORITY = 'cpan:STEVAN';
use Moose::Meta::Method::Accessor;
return ( wantarray ? ( $class, @traits ) : $class );
}
+# ...
+
+my @legal_options_for_inheritance = qw(
+ default coerce required
+ documentation lazy handles
+ builder type_constraint
+);
+
+sub legal_options_for_inheritance { @legal_options_for_inheritance }
+
+# NOTE/TODO
+# This method *must* be able to handle
+# Class::MOP::Attribute instances as
+# well. Yes, I know that is wrong, but
+# apparently we didn't realize it was
+# doing that and now we have some code
+# which is dependent on it. The real
+# solution of course is to push this
+# feature back up into Class::MOP::Attribute
+# but I not right now, I am too lazy.
+# However if you are reading this and
+# looking for something to do,.. please
+# be my guest.
+# - stevan
sub clone_and_inherit_options {
my ($self, %options) = @_;
+
my %copy = %options;
- # you can change default, required, coerce, documentation, lazy, handles, builder, type_constraint (explicitly or using isa/does), metaclass and traits
+
my %actual_options;
- foreach my $legal_option (qw(default coerce required documentation lazy handles builder type_constraint)) {
+
+ # NOTE:
+ # we may want to extends a Class::MOP::Attribute
+ # in which case we need to be able to use the
+ # core set of legal options that have always
+ # been here. But we allows Moose::Meta::Attribute
+ # instances to changes them.
+ # - SL
+ my @legal_options = $self->can('legal_options_for_inheritance')
+ ? $self->legal_options_for_inheritance
+ : @legal_options_for_inheritance;
+
+ foreach my $legal_option (@legal_options) {
if (exists $options{$legal_option}) {
$actual_options{$legal_option} = $options{$legal_option};
delete $options{$legal_option};
}
- }
+ }
if ($options{isa}) {
my $type_constraint;
}
}
else {
- $class->throw_error("I do not understand this option (is => " . $options->{is} . ") on attribute $name", data => $options->{is});
+ $class->throw_error("I do not understand this option (is => " . $options->{is} . ") on attribute ($name)", data => $options->{is});
}
}
if (exists $options->{does}) {
if (eval { $options->{isa}->can('does') }) {
($options->{isa}->does($options->{does}))
- || $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);
+ || $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 {
- $class->throw_error("Cannot have an isa option which cannot ->does() on attribute $name", data => $options);
+ $class->throw_error("Cannot have an isa option which cannot ->does() on attribute ($name)", data => $options);
}
}
if (exists $options->{coerce} && $options->{coerce}) {
(exists $options->{type_constraint})
- || $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)
+ || $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})
- || $class->throw_error("Trigger must be a CODE ref", data => $options->{trigger});
+ || $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})
- || $class->throw_error("You cannot auto-dereference without specifying a type constraint on attribute $name", data => $options);
+ || $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'))
- || $class->throw_error("You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute $name", data => $options);
+ || $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) {
- $class->throw_error("You can not use lazy_build and default for the same attribute $name", data => $options)
+ $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;
$value_is_set = 1;
}
elsif ($self->has_builder) {
- if (my $builder = $instance->can($self->builder)){
- $val = $instance->$builder;
- $value_is_set = 1;
- }
- else {
- $self->throw_error(blessed($instance)." does not support builder method '".$self->builder."' for attribute '" . $self->name . "'", object => $instance, data => $params);
- }
+ $val = $self->_call_builder($instance);
+ $value_is_set = 1;
}
}
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:
if ($self->is_lazy) {
unless ($self->has_value($instance)) {
+ my $value;
if ($self->has_default) {
- my $default = $self->default($instance);
- $self->set_initial_value($instance, $default);
+ $value = $self->default($instance);
} elsif ( $self->has_builder ) {
- if (my $builder = $instance->can($self->builder)){
- $self->set_initial_value($instance, $instance->$builder);
- }
- else {
- $self->throw_error(blessed($instance)
- . " does not support builder method '"
- . $self->builder
- . "' for attribute '"
- . $self->name
- . "'", object => $instance);
- }
- }
- else {
- $self->set_initial_value($instance, undef);
+ $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)
+ || c$self->throw_error("Attribute (" . $self->name
+ . ") does not pass the type constraint because: "
+ . $type_constraint->get_message($value), type_constraint => $type_constraint, data => $value);
}
+ $self->set_initial_value($instance, $value);
}
}
sub install_accessors {
my $self = shift;
$self->SUPER::install_accessors(@_);
+ $self->install_delegation if $self->has_handles;
+ return;
+}
- if ($self->has_handles) {
+sub install_delegation {
+ my $self = shift;
- # NOTE:
- # Here we canonicalize the 'handles' option
- # this will sort out any details and always
- # return an hash of methods which we want
- # to delagate to, see that method for details
- my %handles = $self->_canonicalize_handles();
-
- # 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;
-
- # install the delegation ...
- my $associated_class = $self->associated_class;
- foreach my $handle (keys %handles) {
- my $method_to_call = $handles{$handle};
- my $class_name = $associated_class->name;
- my $name = "${class_name}::${handle}";
+ # NOTE:
+ # Here we canonicalize the 'handles' option
+ # this will sort out any details and always
+ # return an hash of methods which we want
+ # 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;
+ foreach my $handle (keys %handles) {
+ my $method_to_call = $handles{$handle};
+ my $class_name = $associated_class->name;
+ my $name = "${class_name}::${handle}";
(!$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
- # any of these methods, as they will
- # override the ones in your class, which
- # is almost certainly not what you want.
+ # NOTE:
+ # handles is not allowed to delegate
+ # any of these methods, as they will
+ # override the ones in your class, which
+ # is almost certainly not what you want.
- # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
- #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);
+ # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
+ #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 $instance = shift;
- my $proxy = $instance->$accessor();
- (defined $proxy)
- || $self->throw_error("Cannot delegate $handle to $method_to_call because " .
- "the value of " . $self->name . " is not defined", method_name => $method_to_call, object => $instance);
- $proxy->$method_to_call(@_);
- }));
- }
+ if ('CODE' eq ref($method_to_call)) {
+ $associated_class->add_method($handle => Class::MOP::subname($name, $method_to_call));
}
- }
-
- return;
+ 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 $instance = shift;
+ my $proxy = $instance->$accessor();
+ (defined $proxy)
+ || $self->throw_error("Cannot delegate $handle to $method_to_call because " .
+ "the value of " . $self->name . " is not defined", method_name => $method_to_call, object => $instance);
+ $proxy->$method_to_call(@_);
+ }));
+ }
+ }
}
# private methods to help delegation ...
+sub _get_delegate_accessor {
+ 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;
+}
+
sub _canonicalize_handles {
my $self = shift;
my $handles = $self->handles;
my $self = shift;
my $meta = $self->_find_delegate_metaclass;
if ($meta->isa('Class::MOP::Class')) {
- return map { $_->{name} } # NOTE: !never! delegate &meta
- grep { $_->{class} ne 'Moose::Object' && $_->{name} ne 'meta' }
- $meta->compute_all_applicable_methods;
+ return map { $_->name } # NOTE: !never! delegate &meta
+ grep { $_->package_name ne 'Moose::Object' && $_->name ne 'meta' }
+ $meta->get_all_methods;
}
elsif ($meta->isa('Moose::Meta::Role')) {
return $meta->get_method_list;
=item B<install_accessors>
+=item B<install_delegation>
+
=item B<accessor_metaclass>
=item B<get_value>
To check a value against a type constraint before setting it, fetch the
attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
-and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::RecipeX>
+and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4>
for an example.
=back
from a superclass and allows a very specific set of changes to be made
to the attribute.
+=item B<legal_options_for_inheritance>
+
+Whitelist with options you can change. You can overload it in your custom
+metaclass to allow your options be inheritable.
+
=item B<has_type_constraint>
Returns true if this meta-attribute has a type constraint.
#If your attribute name starts with an underscore:
has '_foo' => (lazy_build => 1);
#is the same as
- has '_foo' => (lazy => 1, required => 1, predicate => '_has_foo', clearer => '_clear_foo', builder => '_build__foo);
+ has '_foo' => (lazy => 1, required => 1, predicate => '_has_foo', clearer => '_clear_foo', builder => '_build__foo');
# or
has '_foo' => (lazy => 1, required => 1, predicate => '_has_foo', clearer => '_clear_foo', default => sub{shift->_build__foo});
#If your attribute name does not start with an underscore:
has 'foo' => (lazy_build => 1);
#is the same as
- has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', builder => '_build_foo);
+ has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', builder => '_build_foo');
# or
has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', default => sub{shift->_build_foo});
use Carp ();
use Scalar::Util 'weaken', 'blessed';
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Moose::Meta::Method::Overriden;
default => sub { [] }
));
+__PACKAGE__->meta->add_attribute('constructor_class' => (
+ accessor => 'constructor_class',
+ default => sub { 'Moose::Meta::Method::Constructor' }
+));
+
+__PACKAGE__->meta->add_attribute('destructor_class' => (
+ accessor => 'destructor_class',
+ default => sub { 'Moose::Meta::Method::Destructor' }
+));
+
__PACKAGE__->meta->add_attribute('error_builder' => (
reader => 'error_builder',
default => 'confess',
}
sub new_object {
- my ($class, %params) = @_;
- my $self = $class->SUPER::new_object(%params);
+ 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}) {
+ if (exists $params->{$init_arg}) {
# and if get here, fire the trigger
$attr->trigger->(
$self,
? $attr->get_read_method_ref->($self)
# otherwise, just get the value from
# the constructor params
- : $params{$init_arg}),
+ : $params->{$init_arg}),
$attr
);
}
}
sub construct_instance {
- my ($class, %params) = @_;
+ my $class = shift;
+ my $params = @_ == 1 ? $_[0] : {@_};
my $meta_instance = $class->get_meta_instance;
# FIXME:
# the code below is almost certainly incorrect
# but this is foreign inheritence, so we might
# have to kludge it in the end.
- my $instance = $params{'__INSTANCE__'} || $meta_instance->create_instance();
+ my $instance = $params->{'__INSTANCE__'} || $meta_instance->create_instance();
foreach my $attr ($class->compute_all_applicable_attributes()) {
- $attr->initialize_instance_slot($meta_instance, $instance, \%params);
+ $attr->initialize_instance_slot($meta_instance, $instance, $params);
}
return $instance;
}
sub get_method_map {
my $self = shift;
- if (defined $self->{'$!_package_cache_flag'} &&
- $self->{'$!_package_cache_flag'} == Class::MOP::check_package_cache_flag($self->meta->name)) {
- return $self->{'%!methods'};
+ my $current = Class::MOP::check_package_cache_flag($self->name);
+
+ if (defined $self->{'_package_cache_flag'} && $self->{'_package_cache_flag'} == $current) {
+ return $self->{'methods'};
}
- my $map = $self->{'%!methods'};
+ $self->{_package_cache_flag} = $current;
+
+ my $map = $self->{'methods'};
my $class_name = $self->name;
my $method_metaclass = $self->method_metaclass;
return undef;
}
+# Right now, this method does not handle the case where two
+# metaclasses differ only in roles applied against a common parent
+# class. This can happen fairly easily when ClassA applies metaclass
+# Role1, and then a subclass, ClassB, applies a metaclass Role2. In
+# reality, the way to resolve the problem is to apply Role1 to
+# ClassB's metaclass. However, we cannot currently detect this, and so
+# we simply fail to fix the incompatibility.
+#
+# The algorithm for fixing it is not that complicated.
+#
+# First, we see if the two metaclasses share a common parent (probably
+# Moose::Meta::Class).
+#
+# Second, we see if the metaclasses only differ in terms of roles
+# applied. This second point is where things break down. There is no
+# easy way to determine if the difference is from roles only. To do
+# that, we'd need to able to reliably determine the origin of each
+# method and attribute in each metaclass. If all the unshared methods
+# & attributes come from roles, and there is no name collision, then
+# we can apply the missing roles to the child's metaclass.
+#
+# Tracking the origin of these things will require some fairly
+# invasive changes to various parts of Moose & Class::MOP.
+#
+# For now, the workaround is for ClassB to subclass ClassA _and then_
+# apply metaclass roles to its metaclass.
sub _fix_metaclass_incompatability {
my ($self, @superclasses) = @_;
+
foreach my $super (@superclasses) {
# don't bother if it does not have a meta.
- next unless $super->can('meta');
+ my $super_meta = Class::MOP::Class->initialize($super) or next;
+ next unless $super_meta->isa("Class::MOP::Class");
+
# get the name, make sure we take
# immutable classes into account
- my $super_meta_name = ($super->meta->is_immutable
- ? $super->meta->get_mutable_metaclass_name
- : blessed($super->meta));
- # if it's meta is a vanilla Moose,
- # then we can safely ignore it.
- next if $super_meta_name eq 'Moose::Meta::Class';
- # 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 see if our instance metaclass is incompatible
- $self->instance_metaclass->isa($super->meta->instance_metaclass)) &&
- # ... and if we are just a vanilla Moose
- $self->isa('Moose::Meta::Class')) {
- # re-initialize the meta ...
- my $super_meta = $super->meta;
- # 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 = $super_meta->reinitialize($self->name => (
- 'attribute_metaclass' => $super_meta->attribute_metaclass,
- 'method_metaclass' => $super_meta->method_metaclass,
- 'instance_metaclass' => $super_meta->instance_metaclass,
- ));
+ my $super_meta_name
+ = $super_meta->is_immutable
+ ? $super_meta->get_mutable_metaclass_name
+ : ref($super_meta);
+
+ next if
+ # if our metaclass is compatible
+ $self->isa($super_meta_name)
+ and
+ # and our instance metaclass is also compatible then no
+ # fixes are needed
+ $self->instance_metaclass->isa( $super_meta->instance_metaclass );
+
+ next unless $super_meta->isa( ref($self) );
+
+ unless ( $self->is_pristine ) {
+ $self->throw_error("Not reinitializing metaclass for "
+ . $self->name
+ . ", it isn't pristine");
}
+
+ $self = $super_meta->reinitialize(
+ $self->name,
+ attribute_metaclass => $super_meta->attribute_metaclass,
+ method_metaclass => $super_meta->method_metaclass,
+ instance_metaclass => $super_meta->instance_metaclass,
+ );
+
+ $self->$_( $super_meta->$_ )
+ for qw( constructor_class destructor_class );
}
+
return $self;
}
sub create_immutable_transformer {
my $self = shift;
my $class = Class::MOP::Immutable->new($self, {
- read_only => [qw/
- superclasses
- roles
- error_class
- error_builder
- /],
- cannot_call => [qw/
- add_method
- alias_method
- remove_method
- add_attribute
- remove_attribute
- remove_package_symbol
- add_role
- /],
- memoize => {
- class_precedence_list => 'ARRAY',
- compute_all_applicable_attributes => 'ARRAY',
- get_meta_instance => 'SCALAR',
- get_method_map => 'SCALAR',
- # maybe ....
- calculate_all_roles => 'ARRAY',
- },
- # NOTE:
- # this is ugly, but so are typeglobs,
- # so whattayahgonnadoboutit
- # - SL
- wrapped => {
- add_package_symbol => sub {
- my $original = shift;
- $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;
- },
- },
+ read_only => [qw/superclasses/],
+ cannot_call => [qw/
+ add_method
+ alias_method
+ remove_method
+ add_attribute
+ remove_attribute
+ remove_package_symbol
+ add_role
+ /],
+ memoize => {
+ class_precedence_list => 'ARRAY',
+ linearized_isa => 'ARRAY', # FIXME perl 5.10 memoizes this on its own, no need?
+ get_all_methods => 'ARRAY',
+ #get_all_attributes => 'ARRAY', # it's an alias, no need, but maybe in the future
+ compute_all_applicable_attributes => 'ARRAY',
+ get_meta_instance => 'SCALAR',
+ get_method_map => 'SCALAR',
+ calculate_all_roles => 'ARRAY',
+ },
+ # NOTE:
+ # this is ugly, but so are typeglobs,
+ # so whattayahgonnadoboutit
+ # - SL
+ wrapped => {
+ add_package_symbol => sub {
+ my $original = shift;
+ $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;
+ },
+ },
});
return $class;
}
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,
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<throw_error $message, %extra>
Throws the error created by C<create_error> using C<raise_error>
use strict;
use warnings;
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base "Class::MOP::Instance";
This class provides the low level data storage abstractions for attributes.
Using this API generally violates attribute encapsulation and is not
-reccomended, instead look at L<Class::MOP::Attribute/get_value>,
+recommended, instead look at L<Class::MOP::Attribute/get_value>,
L<Class::MOP::Attribute/set_value>, etc, as well as L<Moose::Meta::Attribute>
for the recommended way to fiddle with attribute values in a generic way,
independent of how/whether accessors have been defined. Accessors can be found
use strict;
use warnings;
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Class::MOP::Method';
use strict;
use warnings;
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Moose::Meta::Method',
. $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"
. ' }');
$self->_eval_code('sub {'
. $self->_inline_pre_body(@_)
. $self->_inline_throw_error('"Cannot assign a value to a read-only accessor"', 'data => \@_') . ' if @_ > 1;'
- . $self->_inline_check_lazy
+ . $self->_inline_check_lazy($inv)
. $self->_inline_post_body(@_)
. 'return ' . $self->_inline_auto_deref( $slot_access ) . ';'
. '}');
}
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" .
- ' ' . $self->_inline_throw_error('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))' .
' || ' . $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" .
- ' ' . $self->_inline_throw_error('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";
use Carp 'confess';
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Moose::Meta::Method';
use Scalar::Util 'blessed', 'weaken', 'looks_like_number';
-our $VERSION = '0.50';
+our $VERSION = '0.57';
our $AUTHORITY = 'cpan:STEVAN';
use base 'Moose::Meta::Method',
my $self = bless {
# from our superclass
- '&!body' => undef,
- '$!package_name' => $options{package_name},
- '$!name' => $options{name},
+ 'body' => undef,
+ 'package_name' => $options{package_name},
+ 'name' => $options{name},
# specific to this subclass
- '%!options' => $options{options},
- '$!meta_instance' => $meta->get_meta_instance,
- '@!attributes' => [ $meta->compute_all_applicable_attributes ],
+ 'options' => $options{options},
+ 'meta_instance' => $meta->get_meta_instance,
+ 'attributes' => [ $meta->compute_all_applicable_attributes ],
# ...
- '$!associated_metaclass' => $meta,
+ 'associated_metaclass' => $meta,
} => $class;
# we don't want this creating
# a cycle in the code, if not
# needed
- weaken($self->{'$!associated_metaclass'});
+ weaken($self->{'associated_metaclass'});
$self->initialize_body;
## accessors
-sub options { (shift)->{'%!options'} }
-sub meta_instance { (shift)->{'$!meta_instance'} }
-sub attributes { (shift)->{'@!attributes'} }
+sub options { (shift)->{'options'} }
+sub meta_instance { (shift)->{'meta_instance'} }
+sub attributes { (shift)->{'attributes'} }
-sub associated_metaclass { (shift)->{'$!associated_metaclass'} }
+sub associated_metaclass { (shift)->{'associated_metaclass'} }
## method
$source .= "\n" . 'return $class->Moose::Object::new(@_)';
$source .= "\n" . ' if $class ne \'' . $self->associated_metaclass->name . '\';';
- $source .= "\n" . $self->_inline_throw_error('"Single parameters to new() must be a HASH ref"', 'data => $_[0]');
- $source .= "\n" . ' if scalar @_ == 1 && ref($_[0]) ne q{HASH};';
+ $source .= "\n" . 'my $params = ' . $self->_generate_BUILDARGS('$class', '@_');
- $source .= "\n" . 'my %params = (scalar @_ == 1) ? %{$_[0]} : @_;';
-
- $source .= "\n" . 'my $instance = ' . $self->meta_instance->inline_create_instance('$class');
+ $source .= ";\n" . 'my $instance = ' . $self->meta_instance->inline_create_instance('$class');
$source .= ";\n" . (join ";\n" => map {
$self->_generate_slot_initializer($_)
$code = eval $source;
$self->throw_error("Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@", error => $@, data => $source ) if $@;
}
- $self->{'&!body'} = $code;
+ $self->{'body'} = $code;
+}
+
+sub _generate_BUILDARGS {
+ my ( $self, $class, $args ) = @_;
+
+ my $buildargs = $self->associated_metaclass->find_method_by_name("BUILDARGS");
+
+ if ( $args eq '@_' and ( !$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS ) ) {
+ return join("\n",
+ 'do {',
+ $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]}} : {@_};',
+ '}',
+ );
+ } else {
+ return $class . "->BUILDARGS($args)";
+ }
}
sub _generate_BUILDALL {
my $self = shift;
my @BUILD_calls;
foreach my $method (reverse $self->associated_metaclass->find_all_methods_by_name('BUILD')) {
- push @BUILD_calls => '$instance->' . $method->{class} . '::BUILD(\%params)';
+ push @BUILD_calls => '$instance->' . $method->{class} . '::BUILD($params)';
}
return join ";\n" => @BUILD_calls;
}
if ($attr->can('has_trigger') && $attr->has_trigger) {
if (defined(my $init_arg = $attr->init_arg)) {
push @trigger_calls => (
- '(exists $params{\'' . $init_arg . '\'}) && do {' . "\n "
+ '(exists $params->{\'' . $init_arg . '\'}) && do {' . "\n "
. '$attrs->[' . $i . ']->trigger->('
. '$instance, '
. $self->meta_instance->inline_get_slot_value(
my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
if ($is_moose && defined($attr->init_arg) && $attr->is_required && !$attr->has_default && !$attr->has_builder) {
- push @source => ('(exists $params{\'' . $attr->init_arg . '\'}) ' .
+ push @source => ('(exists $params->{\'' . $attr->init_arg . '\'}) ' .
'|| ' . $self->_inline_throw_error('"Attribute (' . $attr->name . ') is required"') .';');
}
if (($attr->has_default || $attr->has_builder) && !($is_moose && $attr->is_lazy)) {
if ( defined( my $init_arg = $attr->init_arg ) ) {
- push @source => 'if (exists $params{\'' . $init_arg . '\'}) {';
-
- push @source => ('my $val = $params{\'' . $init_arg . '\'};');
-
- if ($is_moose && $attr->has_type_constraint) {
- if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
- push @source => $self->_generate_type_coercion(
- $attr,
- '$type_constraints[' . $index . ']',
- '$val',
- '$val'
- );
- }
- push @source => $self->_generate_type_constraint_check(
- $attr,
- '$type_constraint_bodies[' . $index . ']',
- '$type_constraints[' . $index . ']',
- '$val'
- );
- }
- push @source => $self->_generate_slot_assignment($attr, '$val', $index);
-
+ push @source => 'if (exists $params->{\'' . $init_arg . '\'}) {';
+ push @source => ('my $val = $params->{\'' . $init_arg . '\'};');
+ push @source => $self->_generate_type_constraint_and_coercion($attr, $index)
+ if $is_moose;
+ push @source => $self->_generate_slot_assignment($attr, '$val', $index);
push @source => "} else {";
}
my $default;
push @source => '{'; # wrap this to avoid my $val overwrite warnings
push @source => ('my $val = ' . $default . ';');
- push @source => $self->_generate_type_constraint_check(
- $attr,
- ('$type_constraint_bodies[' . $index . ']'),
- ('$type_constraints[' . $index . ']'),
- '$val'
- ) if ($is_moose && $attr->has_type_constraint);
-
+ push @source => $self->_generate_type_constraint_and_coercion($attr, $index)
+ if $is_moose;
push @source => $self->_generate_slot_assignment($attr, '$val', $index);
push @source => '}'; # close - wrap this to avoid my $val overrite warnings
push @source => "}" if defined $attr->init_arg;
}
elsif ( defined( my $init_arg = $attr->init_arg ) ) {
- push @source => '(exists $params{\'' . $init_arg . '\'}) && do {';
+ push @source => '(exists $params->{\'' . $init_arg . '\'}) && do {';
- push @source => ('my $val = $params{\'' . $init_arg . '\'};');
+ push @source => ('my $val = $params->{\'' . $init_arg . '\'};');
if ($is_moose && $attr->has_type_constraint) {
if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
push @source => $self->_generate_type_coercion(
return $source;
}
+sub _generate_type_constraint_and_coercion {
+ my ($self, $attr, $index) = @_;
+
+ return unless $attr->has_type_constraint;
+
+ my @source;
+ if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
+ push @source => $self->_generate_type_coercion(
+ $attr,
+ '$type_constraints[' . $index . ']',
+ '$val',
+ '$val'
+ );
+ }
+ push @source => $self->_generate_type_constraint_check(
+ $attr,
+ ('$type_constraint_bodies[' . $index . ']'),
+ ('$type_constraints[' . $index . ']'),
+ '$val'
+ );
+ return @source;
+}
+
sub _generate_type_coercion {
my ($self, $attr, $type_constraint_name, $value_name, $return_value_name) = @_;
return ($return_value_name . ' = ' . $type_constraint_name . '->coerce(' . $value_name . ');');
use Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Moose::Meta::Method',
my $self = bless {
# from our superclass
- '&!body' => undef,
- '$!package_name' => $options{package_name},
- '$!name' => $options{name},
+ 'body' => undef,
+ 'package_name' => $options{package_name},
+ 'name' => $options{name},
# ...
- '%!options' => $options{options},
- '$!associated_metaclass' => $options{metaclass},
+ 'options' => $options{options},
+ 'associated_metaclass' => $options{metaclass},
} => $class;
# we don't want this creating
# a cycle in the code, if not
# needed
- weaken($self->{'$!associated_metaclass'});
+ weaken($self->{'associated_metaclass'});
$self->initialize_body;
## accessors
-sub options { (shift)->{'%!options'} }
-sub associated_metaclass { (shift)->{'$!associated_metaclass'} }
+sub options { (shift)->{'options'} }
+sub associated_metaclass { (shift)->{'associated_metaclass'} }
## method
|| confess "When calling is_needed as a class method you must pass a class name";
return $_[0]->meta->can('DEMOLISH');
}
- defined $self->{'&!body'} ? 1 : 0
+ defined $self->{'body'} ? 1 : 0
}
sub initialize_body {
$code = eval $source;
confess "Could not eval the destructor :\n\n$source\n\nbecause :\n\n$@" if $@;
}
- $self->{'&!body'} = $code;
+ $self->{'body'} = $code;
}
use strict;
use warnings;
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Moose::Meta::Method';
use Carp 'confess';
use Scalar::Util 'blessed';
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Moose::Meta::Class;
keys %{$self->$accessor};
}
+sub reset_package_cache_flag { (shift)->{'_package_cache_flag'} = undef }
+sub update_package_cache_flag {
+ my $self = shift;
+ $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name);
+}
+
+
+
## ------------------------------------------------------------------
## subroles
(blessed($role) && $role->isa('Moose::Meta::Role'))
|| confess "Roles must be instances of Moose::Meta::Role";
push @{$self->get_roles} => $role;
+ $self->reset_package_cache_flag;
}
sub calculate_all_roles {
sub get_method_map {
my $self = shift;
- my $map = {};
+
+ 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 $role_name = $self->name;
my $method_metaclass = $self->method_metaclass;
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')
# loudly (in the case of Curses.pm) so we
# just be a little overly cautious here.
# - SL
- && eval { no warnings; blessed($pkg->meta) }
+ && eval { no warnings; blessed($pkg->meta) } # FIXME calls meta
&& $pkg->meta->isa('Moose::Meta::Role')) {
my $role = $pkg->meta->name;
next unless $self->does_role($role);
exists $self->get_method_map->{$name} ? 1 : 0
}
+# FIXME this is copypasated 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($body))
+ || confess "Your code block must be a CODE reference";
+
+ $self->method_metaclass->wrap( $body => (
+ 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";
+
+ 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;
+ $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 );
+ }
+
+ $method->attach_to_class($self);
+
+ $self->get_method_map->{$method_name} = $method;
+
+ my $full_method_name = ($self->name . '::' . $method_name);
+ $self->add_package_symbol(
+ { sigil => '&', type => 'CODE', name => $method_name },
+ Class::MOP::subname($full_method_name => $body)
+ );
+
+ $self->update_package_cache_flag; # still valid, since we just added the method to the map, and if it was invalid before that then get_method_map updated it
+}
+
sub find_method_by_name { (shift)->get_method(@_) }
sub get_method_list {
=item B<apply>
+=item B<apply_to_metaclass_instance>
+
=item B<combine>
=back
=item B<has_method>
+=item B<add_method>
+
+=item B<wrap_method_body>
+
=item B<alias_method>
=item B<get_method_list>
use warnings;
use metaclass;
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
__PACKAGE__->meta->add_attribute('method_exclusions' => (
: [ $params{excludes} ]);
}
- $class->meta->new_object(%params);
+ $class->_new(\%params);
}
sub is_method_excluded {
use Carp 'confess';
use Scalar::Util 'blessed';
-use Data::Dumper;
use Moose::Meta::Role::Composite;
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Moose::Meta::Role::Application';
use Carp 'confess';
use Scalar::Util 'blessed';
-use Data::Dumper;
-
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Moose::Meta::Role::Application';
use Carp 'confess';
use Scalar::Util 'blessed';
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Moose::Meta::Role::Application::ToClass';
use Carp 'confess';
use Scalar::Util 'blessed';
-use Data::Dumper;
-
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Moose::Meta::Role::Application';
use Carp 'confess';
use Scalar::Util 'blessed';
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Moose::Meta::Role';
# and the name is created from the
# roles if one has not been provided
$params{name} ||= (join "|" => map { $_->name } @{$params{roles}});
- $class->meta->new_object(%params);
+ $class->_new(\%params);
}
# NOTE:
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
use strict;
use warnings;
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Class::MOP::Method';
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
use strict;
use warnings;
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Moose::Meta::Role::Method';
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
use Moose::Meta::Attribute;
use Moose::Util::TypeConstraints ();
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
__PACKAGE__->meta->add_attribute('type_coercion_map' => (
use Carp 'confess';
use Scalar::Util 'blessed';
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Moose::Meta::TypeCoercion';
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
use Carp 'confess';
use Scalar::Util qw(blessed refaddr);
-our $VERSION = '0.50';
+use base qw(Class::MOP::Object);
+
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
__PACKAGE__->meta->add_attribute('name' => (reader => 'name'));
sub new {
my $class = shift;
- my $self = $class->meta->new_object(@_);
+ my $self = $class->_new(@_);
$self->compile_type_constraint()
unless $self->_has_compiled_type_constraint;
return $self;
sub get_message {
my ($self, $value) = @_;
- $value = (defined $value ? overload::StrVal($value) : 'undef');
if (my $msg = $self->message) {
local $_ = $value;
return $msg->($value);
}
else {
+ $value = (defined $value ? overload::StrVal($value) : 'undef');
return "Validation failed for '" . $self->name . "' failed with value $value";
}
}
sub equals {
my ( $self, $type_or_name ) = @_;
- my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
+ my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
return 1 if refaddr($self) == refaddr($other);
sub is_a_type_of {
my ($self, $type_or_name) = @_;
- my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
+ my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
($self->equals($type) || $self->is_subtype_of($type));
}
sub is_subtype_of {
my ($self, $type_or_name) = @_;
- my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
+ my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
my $current = $self;
=item B<equals ($type_name_or_object)>
+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 name, and if it does not match,
-checks if it is a subtype of it.
+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. 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. 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>
=item B<coerce ($value)>
=item B<name>
+The name of the type in the global type registry.
+
=item B<parent>
+This type's parent type.
+
=item B<has_parent>
+Returns true if this type has a parent type.
+
=item B<parents>
=item B<constraint>
use Scalar::Util 'blessed';
use Moose::Util::TypeConstraints ();
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Moose::Meta::TypeConstraint';
my ( $class, %args ) = @_;
$args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Object');
- my $self = $class->meta->new_object(%args);
+ my $self = $class->_new(\%args);
$self->_create_hand_optimized_type_constraint;
$self->compile_type_constraint();
use Moose::Util::TypeConstraints ();
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Moose::Meta::TypeConstraint';
$args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Str');
- my $self = $class->meta->new_object(%args);
+ my $self = $class->_new(\%args);
$self->compile_type_constraint()
unless $self->_has_compiled_type_constraint;
use warnings;
use metaclass;
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Moose::Meta::TypeConstraint';
use Carp 'confess';
use Moose::Util::TypeConstraints;
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Moose::Meta::TypeConstraint';
use Scalar::Util 'blessed';
use Carp 'confess';
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Class::MOP::Object';
sub new {
my $class = shift;
- my $self = $class->meta->new_object(@_);
+ my $self = $class->_new(@_);
return $self;
}
sub get_type_constraint {
my ($self, $type_name) = @_;
+ return unless defined $type_name;
$self->type_constraints->{$type_name}
}
sub add_type_constraint {
my ($self, $type) = @_;
+ confess("No type supplied / type is not a valid type constraint")
+ unless ($type && blessed $type && $type->isa('Moose::Meta::TypeConstraint'));
$self->type_constraints->{$type->name} = $type;
}
=item B<get_type_constraint ($type_name)>
+Returns a type constraint object from the registry by name. Will return
+false if the supplied type name cannot be found.
+
=item B<add_type_constraint ($type)>
+Adds a type constraint object to the registry. Will throw an exception if
+no type is supplied, or the supplied object does not inherit from
+L<Moose::Meta::TypeConstraint>
+
=item B<find_type_constraint ($type_name)>
=back
use Scalar::Util 'blessed';
use Moose::Util::TypeConstraints ();
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Moose::Meta::TypeConstraint';
my ( $class, %args ) = @_;
$args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Role');
- my $self = $class->meta->new_object(%args);
+ my $self = $class->_new(\%args);
$self->_create_hand_optimized_type_constraint;
$self->compile_type_constraint();
use Moose::Meta::TypeCoercion::Union;
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Moose::Meta::TypeConstraint';
=head1 DESCRIPTION
This metaclass represents a union of Moose type constraints. More
-details to be explained later (possibly in a Cookbook::Recipe).
+details to be explained later (possibly in a Cookbook recipe).
This actually used to be part of Moose::Meta::TypeConstraint, but it
is now better off in it's own file.
use Carp 'confess';
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
sub new {
my $class = shift;
- my %params;
- my $meta = $class->meta;
+ my $params = $class->BUILDARGS(@_);
+ my $self = $class->meta->new_object($params);
+ $self->BUILDALL($params);
+ return $self;
+}
+
+sub BUILDARGS {
+ my $class = shift;
if (scalar @_ == 1) {
if (defined $_[0]) {
(ref($_[0]) eq 'HASH')
- || $meta->throw_error("Single parameters to new() must be a HASH ref", data => $_[0]);
- %params = %{$_[0]};
+ || $class->throw_error("Single parameters to new() must be a HASH ref", data => $_[0]);
+ return {%{$_[0]}};
+ }
+ else {
+ return {}; # FIXME this is compat behavior, but is it correct?
}
- }
+ }
else {
- %params = @_;
+ return {@_};
}
- my $self = $meta->new_object(%params);
- $self->BUILDALL(\%params);
- return $self;
}
sub BUILDALL {
$_[0]->DEMOLISHALL;
}
+# support for UNIVERSAL::DOES ...
+BEGIN {
+ my $does = UNIVERSAL->can("DOES") ? "SUPER::DOES" : "isa";
+ eval 'sub DOES {
+ my ( $self, $class_or_role_name ) = @_;
+ return $self->'.$does.'($class_or_role_name)
+ || $self->does($class_or_role_name);
+ }';
+}
+
# new does() methods will be created
# as approiate see Moose::Meta::Role
sub does {
=item B<new>
-This will create a new instance and call C<BUILDALL>.
+This will call C<BUILDARGS>, create a new instance and call C<BUILDALL>.
+
+=item B<BUILDARGS>
+
+This method processes an argument list into a hash reference. It is used by
+C<new>.
=item B<BUILDALL>
This will check if the invocant's class C<does> a given C<$role_name>.
This is similar to C<isa> for object, but it checks the roles instead.
+=item B<DOES ($class_or_role_name)>
+
+A Moose Role aware implementation of L<UNIVERSAL/DOES>.
+
+C<DOES> is equivalent to C<isa> or C<does>.
+
=item B<dump ($maxdepth)>
Cmon, how many times have you written the following code while debugging:
use Data::OptList;
use Sub::Exporter;
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Moose ();
use Moose::Meta::Role;
use Moose::Util::TypeConstraints;
-{
- my ( $CALLER, %METAS );
+sub extends {
+ croak "Roles do not currently support 'extends'";
+}
+
+sub with {
+ Moose::Util::apply_all_roles( Moose::Meta::Role->initialize(shift), @_ );
+}
+
+sub requires {
+ my $meta = Moose::Meta::Role->initialize(shift);
+ croak "Must specify at least one method" unless @_;
+ $meta->add_required_methods(@_);
+}
+
+sub excludes {
+ my $meta = Moose::Meta::Role->initialize(shift);
+ croak "Must specify at least one role" unless @_;
+ $meta->add_excluded_roles(@_);
+}
- sub _find_meta {
- my $role = $CALLER;
+sub has {
+ my $meta = Moose::Meta::Role->initialize(shift);
+ my $name = shift;
+ croak 'Usage: has \'name\' => ( key => value, ... )' if @_ == 1;
+ my %options = @_;
+ my $attrs = ( ref($name) eq 'ARRAY' ) ? $name : [ ($name) ];
+ $meta->add_attribute( $_, %options ) for @$attrs;
+}
- return $METAS{$role} if exists $METAS{$role};
+sub before {
+ my $meta = Moose::Meta::Role->initialize(shift);
+ my $code = pop @_;
- # make a subtype for each Moose class
- role_type $role unless find_type_constraint($role);
+ for (@_) {
+ croak "Moose::Role do not currently support "
+ . ref($_)
+ . " references for before method modifiers"
+ if ref $_;
+ $meta->add_before_method_modifier( $_, $code );
+ }
+}
- my $meta;
- 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";
- }
- else {
- $meta = Moose::Meta::Role->initialize($role);
- $meta->alias_method('meta' => sub { $meta });
- }
+sub after {
+ my $meta = Moose::Meta::Role->initialize(shift);
- return $METAS{$role} = $meta;
+ my $code = pop @_;
+ for (@_) {
+ croak "Moose::Role do not currently support "
+ . ref($_)
+ . " references for after method modifiers"
+ if ref $_;
+ $meta->add_after_method_modifier( $_, $code );
}
+}
+sub around {
+ my $meta = Moose::Meta::Role->initialize(shift);
+ my $code = pop @_;
+ for (@_) {
+ croak "Moose::Role do not currently support "
+ . ref($_)
+ . " references for around method modifiers"
+ if ref $_;
+ $meta->add_around_method_modifier( $_, $code );
+ }
+}
- my %exports = (
- extends => sub {
- my $meta = _find_meta();
- return Class::MOP::subname('Moose::Role::extends' => sub {
- croak "Roles do not currently support 'extends'"
- });
- },
- with => sub {
- my $meta = _find_meta();
- return Class::MOP::subname('Moose::Role::with' => sub (@) {
- Moose::Util::apply_all_roles($meta, @_)
- });
- },
- requires => sub {
- my $meta = _find_meta();
- return Class::MOP::subname('Moose::Role::requires' => sub (@) {
- croak "Must specify at least one method" unless @_;
- $meta->add_required_methods(@_);
- });
- },
- excludes => sub {
- my $meta = _find_meta();
- return Class::MOP::subname('Moose::Role::excludes' => sub (@) {
- croak "Must specify at least one role" unless @_;
- $meta->add_excluded_roles(@_);
- });
- },
- has => sub {
- my $meta = _find_meta();
- return Class::MOP::subname('Moose::Role::has' => sub ($;%) {
- my $name = shift;
- croak 'Usage: has \'name\' => ( key => value, ... )' if @_ == 1;
- my %options = @_;
- my $attrs = ( ref($name) eq 'ARRAY' ) ? $name : [ ($name) ];
- $meta->add_attribute( $_, %options ) for @$attrs;
- });
- },
- before => sub {
- my $meta = _find_meta();
- return Class::MOP::subname('Moose::Role::before' => sub (@&) {
- my $code = pop @_;
- do {
- croak "Moose::Role do not currently support "
- . ref($_)
- . " references for before method modifiers"
- if ref $_;
- $meta->add_before_method_modifier($_, $code)
- } for @_;
- });
- },
- after => sub {
- my $meta = _find_meta();
- return Class::MOP::subname('Moose::Role::after' => sub (@&) {
- my $code = pop @_;
- do {
- croak "Moose::Role do not currently support "
- . ref($_)
- . " references for after method modifiers"
- if ref $_;
- $meta->add_after_method_modifier($_, $code)
- } for @_;
- });
- },
- around => sub {
- my $meta = _find_meta();
- return Class::MOP::subname('Moose::Role::around' => sub (@&) {
- my $code = pop @_;
- do {
- croak "Moose::Role do not currently support "
- . ref($_)
- . " references for around method modifiers"
- if ref $_;
- $meta->add_around_method_modifier($_, $code)
- } for @_;
- });
- },
- # see Moose.pm for discussion
- super => sub {
- return Class::MOP::subname('Moose::Role::super' => sub {
- return unless $Moose::SUPER_BODY; $Moose::SUPER_BODY->(@Moose::SUPER_ARGS)
- });
- },
- override => sub {
- my $meta = _find_meta();
- return Class::MOP::subname('Moose::Role::override' => sub ($&) {
- my ($name, $code) = @_;
- $meta->add_override_method_modifier($name, $code);
- });
- },
- inner => sub {
- my $meta = _find_meta();
- return Class::MOP::subname('Moose::Role::inner' => sub {
- croak "Moose::Role cannot support 'inner'";
- });
- },
- augment => sub {
- my $meta = _find_meta();
- return Class::MOP::subname('Moose::Role::augment' => sub {
- croak "Moose::Role cannot support 'augment'";
- });
- },
- confess => sub {
- return \&Carp::confess;
- },
- blessed => sub {
- return \&Scalar::Util::blessed;
- }
- );
-
- my $exporter = Sub::Exporter::build_exporter({
- exports => \%exports,
- groups => {
- default => [':all']
- }
- });
-
- sub import {
- $CALLER =
- ref $_[1] && defined $_[1]->{into} ? $_[1]->{into}
- : ref $_[1]
- && defined $_[1]->{into_level} ? caller( $_[1]->{into_level} )
- : 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
- return if $CALLER eq 'main';
-
- goto $exporter;
- };
-
- sub unimport {
- no strict 'refs';
- my $class = Moose::_get_caller(@_);
-
- # loop through the exports ...
- foreach my $name ( keys %exports ) {
-
- # if we find one ...
- if ( defined &{ $class . '::' . $name } ) {
- my $keyword = \&{ $class . '::' . $name };
-
- # make sure it is from Moose::Role
- my ($pkg_name) = Class::MOP::get_code_info($keyword);
- next if $pkg_name ne 'Moose::Role';
-
- # and if it is from Moose::Role then undef the slot
- delete ${ $class . '::' }{$name};
+# see Moose.pm for discussion
+sub super {
+ return unless $Moose::SUPER_BODY;
+ $Moose::SUPER_BODY->(@Moose::SUPER_ARGS);
+}
+
+sub override {
+ my $meta = Moose::Meta::Role->initialize(shift);
+ my ( $name, $code ) = @_;
+ $meta->add_override_method_modifier( $name, $code );
+}
+
+sub inner {
+ croak "Moose::Role cannot support 'inner'";
+}
+
+sub augment {
+ croak "Moose::Role cannot support 'augment'";
+}
+
+my $exporter = Moose::Exporter->setup_import_methods(
+ with_caller => [
+ qw( with requires excludes has before after around override make_immutable )
+ ],
+ as_is => [
+ qw( extends super inner augment ),
+ \&Carp::confess,
+ \&Scalar::Util::blessed,
+ ],
+);
+
+sub init_meta {
+ shift;
+ my %args = @_;
+
+ my $role = $args{for_class}
+ or confess
+ "Cannot call init_meta without specifying a for_class";
+
+ my $metaclass = $args{metaclass} || "Moose::Meta::Role";
+
+ # make a subtype for each Moose class
+ role_type $role unless find_type_constraint($role);
+
+ # FIXME copy from Moose.pm
+ my $meta;
+ 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";
+ }
+ else {
+ $meta = $metaclass->initialize($role);
+
+ $meta->add_method(
+ 'meta' => sub {
+ # re-initialize so it inherits properly
+ $metaclass->initialize( ref($_[0]) || $_[0] );
}
- }
+ );
}
+
+ return $meta;
}
1;
C<unimport> method. You simply have to say C<no Moose::Role> at the bottom of
your code for this to work.
+=head2 B<< Moose::Role->init_meta(for_class => $role, metaclass => $metaclass) >>
+
+The C<init_meta> method sets up the metaclass object for the role
+specified by C<for_class>. It also injects a a C<meta> accessor into
+the role so you can get at this object.
+
+The default metaclass is L<Moose::Meta::Role>. You can specify an
+alternate metaclass with the C<metaclass> parameter.
+
=head1 CAVEATS
Role support has only a few caveats:
--- /dev/null
+=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',
+ );
+
+ 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($date );
+ $class->_validate_birth_date( $date );
+
+ $p{shirt_size} = 'l'
+ unless exists $p{shirt_size}:
+
+ $class->_validate_shirt_size( $p{shirt_size} );
+
+ my %self = map { $_ => $p{$_} } qw( name shirt_size );
+ $self{birth_date} = $date;
+
+ return bless \%self, $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 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, which results in much more
+fragile code.
+
+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.
+
+There's one bit of code in there worth explaining, which is the
+handling of the birth date for coercion. In both the constructor and
+accessor, we first take a copy of the birth date before passing it to
+the coercion routine. This is to avoid changing the value as it was
+passed to those methods, which could cause problems for the caller.
+
+Also 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 code was not easy, which just emphasizes the
+point, that 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.
+
+=head1 AUTHOR
+
+Dave Rolsky E<lt>autarch@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
use Sub::Exporter;
use Scalar::Util 'blessed';
use Carp 'confess';
-use Class::MOP 0.56;
+use Class::MOP 0.57;
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
my @exports = qw[
sub apply_all_roles {
my $applicant = shift;
-
+
confess "Must specify at least one role to apply to $applicant" unless @_;
-
- my $roles = Data::OptList::mkopt([ @_ ]);
-
- #use Data::Dumper;
- #warn Dumper $roles;
-
- my $meta = (blessed $applicant ? $applicant : find_meta($applicant));
-
+
+ my $roles = Data::OptList::mkopt( [@_] );
+
+ my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
+
foreach my $role_spec (@$roles) {
- Class::MOP::load_class($role_spec->[0]);
+ Class::MOP::load_class( $role_spec->[0] );
}
-
- ($_->[0]->can('meta') && $_->[0]->meta->isa('Moose::Meta::Role'))
- || confess "You can only consume roles, " . $_->[0] . " is not a Moose role"
- foreach @$roles;
- if (scalar @$roles == 1) {
- my ($role, $params) = @{$roles->[0]};
- $role->meta->apply($meta, (defined $params ? %$params : ()));
+ ( $_->[0]->can('meta') && $_->[0]->meta->isa('Moose::Meta::Role') )
+ || confess "You can only consume roles, "
+ . $_->[0]
+ . " is not a Moose role"
+ foreach @$roles;
+
+ if ( scalar @$roles == 1 ) {
+ my ( $role, $params ) = @{ $roles->[0] };
+ $role->meta->apply( $meta, ( defined $params ? %$params : () ) );
}
else {
- Moose::Meta::Role->combine(
- @$roles
- )->apply($meta);
- }
+ Moose::Meta::Role->combine( @$roles )->apply($meta);
+ }
}
# instance deconstruction ...
my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
if ( $method_modifier_type eq 'Regexp' ) {
- my @all_methods = $meta->compute_all_applicable_methods;
+ my @all_methods = $meta->get_all_methods;
my @matched_methods
- = grep { $_->{name} =~ @{$args}[0] } @all_methods;
- $meta->$add_modifier_method( $_->{name}, $code )
+ = grep { $_->name =~ @{$args}[0] } @all_methods;
+ $meta->$add_modifier_method( $_->name, $code )
for @matched_methods;
}
}
--- /dev/null
+package Moose::Util::MetaRole;
+
+use strict;
+use warnings;
+
+use List::MoreUtils qw( all );
+
+sub apply_metaclass_roles {
+ my %options = @_;
+
+ my $for = $options{for_class};
+
+ my $meta = _make_new_metaclass( $for, \%options );
+
+ for my $tor_class ( grep { $options{ $_ . '_roles' } }
+ qw( constructor_class destructor_class ) ) {
+
+ my $class = _make_new_class(
+ $meta->$tor_class(),
+ $options{ $tor_class . '_roles' }
+ );
+
+ $meta->$tor_class($class);
+ }
+
+ 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 = $existing_class->meta();
+
+ 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 applyied 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@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
use Carp ();
use Scalar::Util 'blessed';
-use Sub::Exporter;
+use Moose::Exporter;
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
## --------------------------------------------------------
use Moose::Meta::TypeConstraint::Registry;
use Moose::Util::TypeConstraints::OptimizedConstraints;
-my @exports = qw/
- type subtype class_type role_type as where message optimize_as
- coerce from via
- enum
- find_type_constraint
- register_type_constraint
-/;
-
-Sub::Exporter::setup_exporter({
- exports => \@exports,
- groups => { default => [':all'] }
-});
-
-sub unimport {
- no strict 'refs';
- my $class = caller();
- # loop through the exports ...
- foreach my $name (@exports) {
- # if we find one ...
- if (defined &{$class . '::' . $name}) {
- my $keyword = \&{$class . '::' . $name};
-
- # make sure it is from Moose
- my ($pkg_name) = Class::MOP::get_code_info($keyword);
- next if $@;
- next if $pkg_name ne 'Moose::Util::TypeConstraints';
-
- # and if it is from Moose then undef the slot
- delete ${$class . '::'}{$name};
- }
- }
-}
+Moose::Exporter->setup_import_methods(
+ as_is => [
+ qw(
+ type subtype class_type role_type as where message optimize_as
+ coerce from via
+ enum
+ find_type_constraint
+ register_type_constraint )
+ ],
+ _export_to_main => 1,
+);
## --------------------------------------------------------
## type registry and some useful functions for it
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);
-
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;
}
-
+
$REGISTRY->add_type_constraint($constraint);
return $constraint;
}
if ( blessed $type and $type->isa("Moose::Meta::TypeConstraint") ) {
return $type;
- } else {
+ }
+ else {
+ return unless $REGISTRY->has_type_constraint($type);
return $REGISTRY->get_type_constraint($type);
}
}
sub create_enum_type_constraint ($$) {
my ( $type_name, $values ) = @_;
-
+
Moose::Meta::TypeConstraint::Enum->new(
name => $type_name || '__ANON__',
values => $values,
# FIXME should probably not be a special case
if ( defined $parent and $parent = find_or_parse_type_constraint($parent) ) {
- $class = "Moose::Meta::TypeConstraint::Parameterizable"
+ $class = "Moose::Meta::TypeConstraint::Parameterizable"
if $parent->isa("Moose::Meta::TypeConstraint::Parameterizable");
}
sub _install_type_coercions ($$) {
my ($type_name, $coercion_map) = @_;
- my $type = $REGISTRY->get_type_constraint($type_name);
+ my $type = find_type_constraint($type_name);
(defined $type)
|| confess "Cannot find type '$type_name', perhaps you forgot to load it.";
if ($type->has_coercion) {
type 'Num' => where { Scalar::Util::looks_like_number($_) };
subtype 'Natural'
- => as 'Num'
+ => as 'Int'
=> where { $_ > 0 };
subtype 'NaturalLessThanTen'
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
=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
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
+literally interpreted as a type name.
+
B<NOTE:> The C<Undef> type constraint for the most part works
correctly now, but edge cases may still exist, please use it
sparringly.
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.
-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
})))
};
-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
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
+$_. 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 provided in $_). This code
+ref should return a string, which will be used in the text of the
+exception thrown.
+
=item B<optimize_as>
This can be used to define a "hand optimized" version of your
use Scalar::Util 'blessed', 'looks_like_number';
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
sub Value { defined($_[0]) && !ref($_[0]) }
sub Int { defined($_[0]) && !ref($_[0]) && $_[0] =~ /^-?[0-9]+$/ }
-{
- no warnings 'uninitialized';
- sub ScalarRef { ref($_[0]) eq 'SCALAR' }
- sub ArrayRef { ref($_[0]) eq 'ARRAY' }
- sub HashRef { ref($_[0]) eq 'HASH' }
- sub CodeRef { ref($_[0]) eq 'CODE' }
- sub RegexpRef { ref($_[0]) eq 'Regexp' }
- sub GlobRef { ref($_[0]) eq 'GLOB' }
-}
+sub ScalarRef { ref($_[0]) eq 'SCALAR' }
+sub ArrayRef { ref($_[0]) eq 'ARRAY' }
+sub HashRef { ref($_[0]) eq 'HASH' }
+sub CodeRef { ref($_[0]) eq 'CODE' }
+sub RegexpRef { ref($_[0]) eq 'Regexp' }
+sub GlobRef { ref($_[0]) eq 'GLOB' }
sub FileHandle { ref($_[0]) eq 'GLOB' && Scalar::Util::openhandle($_[0]) or blessed($_[0]) && $_[0]->isa("IO::Handle") }
use Moose::Util 'does_role', 'find_meta';
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
my @exports = qw[
use Class::MOP;
-our $VERSION = '0.50';
+our $VERSION = '0.57';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
BEGIN {
use Test::More tests => 1;
-BEGIN {
- use_ok('Moose');
-}
+package Foo;
+
+# Moose will issue a warning if we try to load it from the main
+# package.
+::use_ok('Moose');
+
+
use strict;
use warnings;
-use Test::More tests => 58;
+use Test::More tests => 57;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
+{
+ package Point;
+ use Moose;
+
+ has 'x' => (isa => 'Int', is => 'rw', required => 1);
+ has 'y' => (isa => 'Int', is => 'rw', required => 1);
+
+ sub clear {
+ my $self = shift;
+ $self->x(0);
+ $self->y(0);
+ }
+
+ __PACKAGE__->meta->make_immutable( debug => 0 );
}
{
- package Point;
- use Moose;
-
- has 'x' => (isa => 'Int', is => 'ro');
- has 'y' => (isa => 'Int', is => 'rw');
-
- sub clear {
- my $self = shift;
- $self->{x} = 0;
- $self->y(0);
- }
-
- __PACKAGE__->meta->make_immutable(debug => 0);
-}{
- package Point3D;
- use Moose;
-
- extends 'Point';
-
- has 'z' => (isa => 'Int');
-
- after 'clear' => sub {
- my $self = shift;
- $self->{z} = 0;
- };
-
- __PACKAGE__->meta->make_immutable(debug => 0);
+ package Point3D;
+ use Moose;
+
+ extends 'Point';
+
+ has 'z' => (isa => 'Int', is => 'rw', required => 1);
+
+ after 'clear' => sub {
+ my $self = shift;
+ $self->z(0);
+ };
+
+ __PACKAGE__->meta->make_immutable( debug => 0 );
}
my $point = Point->new(x => 1, y => 2);
} '... cannot assign a non-Int to y';
dies_ok {
- $point->x(1000);
-} '... cannot assign to a read-only method';
-is($point->x, 1, '... got the right (un-changed) value for x');
+ Point->new();
+} '... must provide required attributes to new';
$point->clear();
is($point3d->y, 15, '... got the right value for y');
is($point3d->{'z'}, 3, '... got the right value for z');
-dies_ok {
- $point3d->z;
-} '... there is no method for z';
-
$point3d->clear();
is($point3d->x, 0, '... got the right (cleared) value for x');
is($point3d->y, 0, '... got the right (cleared) value for y');
-is($point3d->{'z'}, 0, '... got the right (cleared) value for z');
+is($point3d->z, 0, '... got the right (cleared) value for z');
dies_ok {
Point3D->new(x => 10, y => 'Foo', z => 3);
Point3D->new(x => 0, y => 10, z => 'Bar');
} '... cannot assign a non-Int to z';
+dies_ok {
+ Point3D->new(x => 10, y => 3);
+} '... z is a required attribute for Point3D';
+
# test some class introspection
can_ok('Point', 'meta');
[ 'Point' ],
'... Point3D gets the parent given to it');
-my @Point3D_methods = qw(new meta clear);
+my @Point3D_methods = qw(new meta z clear);
my @Point3D_attrs = ('z');
is_deeply(
use strict;
use warnings;
-use Test::More tests => 24;
+use Test::More tests => 23;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
-
{
package BankAccount;
use Moose;
-
- has 'balance' => (isa => 'Num', is => 'rw', default => 0);
+
+ has 'balance' => ( isa => 'Num', 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__->meta->make_immutable(debug => 0);
-}{
- package CheckingAccount;
- use Moose;
-
- extends 'BankAccount';
-
- has 'overdraft_account' => (isa => 'BankAccount', is => 'rw');
-
- before 'withdraw' => sub {
- my ($self, $amount) = @_;
- my $overdraft_amount = $amount - $self->balance();
- if ($self->overdraft_account && $overdraft_amount > 0) {
- $self->overdraft_account->withdraw($overdraft_amount);
- $self->deposit($overdraft_amount);
- }
- };
-
- __PACKAGE__->meta->make_immutable(debug => 0);
+
+ __PACKAGE__->meta->make_immutable( debug => 0 );
+}
+
+{
+ package CheckingAccount;
+ use Moose;
+
+ extends 'BankAccount';
+
+ has 'overdraft_account' => ( isa => 'BankAccount', is => 'rw' );
+
+ before 'withdraw' => sub {
+ my ( $self, $amount ) = @_;
+ my $overdraft_amount = $amount - $self->balance();
+ if ( $self->overdraft_account && $overdraft_amount > 0 ) {
+ $self->overdraft_account->withdraw($overdraft_amount);
+ $self->deposit($overdraft_amount);
+ }
+ };
+
+ __PACKAGE__->meta->make_immutable( debug => 0 );
}
my $savings_account = BankAccount->new(balance => 250);
use strict;
use warnings;
-use Test::More tests => 34;
+use Test::More tests => 33;
use Test::Exception;
use Scalar::Util 'isweak';
-BEGIN {
- use_ok('Moose');
-}
-
{
package BinaryTree;
use Moose;
- has 'node' => (is => 'rw', isa => 'Any');
+ has 'node' => ( is => 'rw', isa => 'Any' );
has 'parent' => (
- is => 'rw',
- isa => 'BinaryTree',
+ is => 'rw',
+ isa => 'BinaryTree',
predicate => 'has_parent',
- weak_ref => 1,
+ 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;
- };
-
- __PACKAGE__->meta->make_immutable(debug => 0);
+ my ( $self, $tree ) = @_;
+ $tree->parent($self) if defined $tree;
+ };
+
+ __PACKAGE__->meta->make_immutable( debug => 0 );
}
my $root = BinaryTree->new(node => 'root');
BEGIN {
eval "use Regexp::Common; use Locale::US;";
plan skip_all => "Regexp::Common & Locale::US required for this test" if $@;
- plan tests => 66;
+ plan tests => 65;
}
use Test::Exception;
use Scalar::Util 'isweak';
-BEGIN {
- use_ok('Moose');
-}
+
{
package Address;
BEGIN {
eval "use HTTP::Headers; use Params::Coerce; use URI;";
plan skip_all => "HTTP::Headers & Params::Coerce & URI required for this test" if $@;
- plan tests => 18;
+ plan tests => 17;
}
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
-
{
- package Request;
- use Moose;
+ 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( @{ $_ } ) }
- => from HashRef
- => via { HTTP::Headers->new( %{ $_ } ) };
-
- subtype Uri
- => as Object
- => where { $_->isa('URI') };
-
- coerce Uri
- => from Object
- => via { $_->isa('URI') ? $_ : Params::Coerce::coerce( 'URI', $_ ) }
- => from Str
- => via { URI->new( $_, 'http' ) };
-
- subtype Protocol
- => as Str
- => where { /^HTTP\/[0-9]\.[0-9]$/ };
-
-
- has 'base' => (is => 'rw', isa => 'Uri', coerce => 1);
- has 'url' => (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 }
+
+ use HTTP::Headers ();
+ use Params::Coerce ();
+ use URI ();
+
+ subtype Header => as Object => where { $_->isa('HTTP::Headers') };
+
+ coerce Header => from ArrayRef => via { HTTP::Headers->new( @{$_} ) } =>
+ from HashRef => via { HTTP::Headers->new( %{$_} ) };
+
+ subtype Uri => as Object => where { $_->isa('URI') };
+
+ coerce Uri => from Object =>
+ via { $_->isa('URI') ? $_ : Params::Coerce::coerce( 'URI', $_ ) } =>
+ from Str => via { URI->new( $_, 'http' ) };
+
+ subtype Protocol => as Str => where {/^HTTP\/[0-9]\.[0-9]$/};
+
+ has 'base' => ( is => 'rw', isa => 'Uri', coerce => 1 );
+ has 'url' => ( 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 }
);
-
- __PACKAGE__->meta->make_immutable(debug => 0);
+
+ __PACKAGE__->meta->make_immutable( debug => 0 );
}
my $r = Request->new;
use strict;
use warnings;
-use Test::More tests => 3;
+use Test::More tests => 2;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
## Augment/Inner
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+{
+ package Human;
+
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ subtype 'EyeColor'
+ => as 'Object'
+ => where { $_->isa('Human::EyeColor') };
+
+ coerce 'EyeColor'
+ => from 'ArrayRef'
+ => via {
+ return Human::EyeColor->new(
+ bey2_1 => $_->[0],
+ bey2_2 => $_->[1],
+ gey_1 => $_->[2],
+ gey_2 => $_->[3],
+ );
+ };
+
+ subtype 'Gender'
+ => as 'Str'
+ => where { $_ =~ m{^[mf]$}s };
+
+ has 'gender' => ( is => 'ro', isa => 'Gender', required => 1 );
+
+ has 'eye_color' => ( is => 'ro', isa => 'EyeColor', coerce => 1, required => 1 );
+
+ has 'mother' => ( is => 'ro', isa => 'Human' );
+ has 'father' => ( is => 'ro', isa => 'Human' );
+
+ use overload '+' => \&_overload_add, fallback => 1;
+
+ sub _overload_add {
+ my ($one, $two) = @_;
+
+ die('Only male and female humans may have children')
+ 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);
+
+ # Would be better to use Crypt::Random.
+ #use Crypt::Random qw( makerandom );
+ #$gender = 'm' if (makerandom( Size => 1, Strength => 1, Uniform => 1 ));
+
+ return Human->new(
+ gender => $gender,
+ eye_color => ( $one->eye_color() + $two->eye_color() ),
+ mother => $mother,
+ father => $father,
+ );
+ }
+}
+
+{
+ 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 );
+
+ use overload '+' => \&_overload_add, fallback => 1;
+ use overload '""' => \&color, fallback => 1;
+
+ sub color {
+ my ( $self ) = @_;
+
+ return 'brown' if ($self->bey2_1->color() eq 'brown' or $self->bey2_2->color() eq 'brown');
+ return 'green' if ($self->gey_1->color() eq 'green' or $self->gey_2->color() eq 'green');
+ return 'blue';
+ }
+
+ sub _overload_add {
+ my ($one, $two) = @_;
+
+ my $one_bey2 = 'bey2_' . _rand2();
+ my $two_bey2 = 'bey2_' . _rand2();
+
+ my $one_gey = 'gey_' . _rand2();
+ my $two_gey = 'gey_' . _rand2();
+
+ return Human::EyeColor->new(
+ bey2_1 => $one->$one_bey2->color(),
+ bey2_2 => $two->$two_bey2->color(),
+ gey_1 => $one->$one_gey->color(),
+ gey_2 => $two->$two_gey->color(),
+ );
+ }
+
+ sub _rand2 {
+ # Would be better to use Crypt::Random.
+ #use Crypt::Random qw( makerandom );
+ #return 1 + makerandom( Size => 1, Strength => 1, Uniform => 1 );
+ return 1 + int( rand(2) );
+ }
+}
+
+{
+ package Human::Gene::bey2;
+
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ type 'bey2Color' => where { $_ =~ m{^(?:brown|blue)$}s };
+
+ has 'color' => ( is => 'ro', isa => 'bey2Color' );
+}
+
+{
+ package Human::Gene::gey;
+
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ type 'geyColor' => where { $_ =~ m{^(?:green|blue)$}s };
+
+ has 'color' => ( is => 'ro', isa => 'geyColor' );
+}
+
+use Test::More tests => 10;
+
+my $gene_color_sets = [
+ [qw( blue blue blue blue ) => 'blue'],
+ [qw( blue blue green blue ) => 'green'],
+ [qw( blue blue blue green ) => 'green'],
+ [qw( blue blue green green ) => 'green'],
+ [qw( brown blue blue blue ) => 'brown'],
+ [qw( brown brown green green ) => 'brown'],
+ [qw( blue brown green blue ) => 'brown'],
+];
+
+foreach my $set (@$gene_color_sets) {
+ my $expected_color = pop( @$set );
+ my $person = Human->new(
+ gender => 'f',
+ eye_color => $set,
+ );
+ is(
+ $person->eye_color(),
+ $expected_color,
+ 'gene combination '.join(',',@$set).' produces '.$expected_color.' eye color',
+ );
+}
+
+my $parent_sets = [
+ [ [qw( blue blue blue blue )], [qw( blue blue blue blue )] => 'blue' ],
+ [ [qw( blue blue blue blue )], [qw( brown brown green blue )] => 'brown' ],
+ [ [qw( blue blue green green )], [qw( blue blue green green )] => 'green' ],
+];
+
+foreach my $set (@$parent_sets) {
+ my $expected_color = pop( @$set );
+ my $mother = Human->new(
+ gender => 'f',
+ eye_color => shift(@$set),
+ );
+ my $father = Human->new(
+ gender => 'm',
+ eye_color => shift(@$set),
+ );
+ my $child = $mother + $father;
+ is(
+ $child->eye_color(),
+ $expected_color,
+ 'mother '.$mother->eye_color().' + father '.$father->eye_color().' = child '.$expected_color,
+ );
+}
+
+# Hmm, not sure how to test for random selection of genes since
+# I could theoretically run an infinite number of iterations and
+# never find proof that a child has inherited a particular gene.
+
+# AUTHOR: Aran Clary Deltac <bluefeet@cpan.org>
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+BEGIN {
+ unless ( eval 'use Test::Warn; 1' ) {
+ plan skip_all => 'These tests require Test::Warn';
+ }
+ else {
+ plan tests => 4;
+ }
+}
+
+{
+ 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::Base' );
+ }
+}
+
+{
+ package Foo;
+
+ MyApp::UseMyBase->import;
+
+ has( 'size' => ( is => 'rw' ) );
+}
+
+ok( Foo->isa('MyApp::Base'),
+ 'Foo isa MyApp::Base' );
+
+ok( Foo->can('size'),
+ 'Foo has a size method' );
+
+my $foo;
+warning_is( sub { $foo = Foo->new( size => 2 ) },
+ 'Making a new Foo',
+ 'got expected warning when calling Foo->new' );
+
+is( $foo->size(), 2, '$foo->size is 2' );
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+
+
+{
+ package MyApp::Meta::Class;
+ use Moose;
+
+ extends 'Moose::Meta::Class';
+
+ has 'table' => ( is => 'rw' );
+
+ no Moose;
+
+ 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);
+ }
+}
+
+{
+ package MyApp::User;
+
+ MyApp::Mooseish->import;
+
+ has_table( 'User' );
+
+ has( 'username' => ( is => 'ro' ) );
+ has( 'password' => ( is => 'ro' ) );
+
+ sub login { }
+}
+
+isa_ok( MyApp::User->meta, 'MyApp::Meta::Class' );
+is( MyApp::User->meta->table, 'User',
+ 'MyApp::User->meta->table returns User' );
+ok( MyApp::User->can('username'),
+ 'MyApp::User has username method' );
use strict;
use warnings;
-use Test::More tests => 2;
+use Test::More tests => 1;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
## meta-attribute example
{
use strict;
use warnings;
-use Test::More tests => 3;
+use Test::More tests => 2;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
## attribute trait example
{
use strict;
use warnings;
-use Test::More tests => 62;
+use Test::More tests => 63;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
## Roles
my $hundred = US::Currency->new(amount => 100.00);
isa_ok($hundred, 'US::Currency');
+ok( $hundred->DOES("US::Currency"), "UNIVERSAL::DOES for class" );
+ok( $hundred->DOES("Comparable"), "UNIVERSAL::DOES for role" );
+
can_ok($hundred, 'amount');
is($hundred->amount, 100, '... got the right amount');
use strict;
use warnings;
-use Test::More tests => 23;
+use Test::More tests => 22;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package Foo;
use lib 't/lib', 'lib';
-use Test::More tests => 6;
+use Test::More tests => 5;
+
-BEGIN {
- use_ok('Moose');
-}
{
package Bar;
use strict;
use warnings;
-use Test::More tests => 17;
+use Test::More tests => 16;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package Foo;
use strict;
use warnings;
-use Test::More tests => 17;
+use Test::More tests => 16;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package Foo;
use strict;
use warnings;
-use Test::More tests => 6;
+use Test::More tests => 5;
+
-BEGIN {
- use_ok('Moose');
-}
{
package Foo;
use strict;
use warnings;
-use Test::More tests => 16;
+use Test::More tests => 15;
+
-BEGIN {
- use_ok('Moose');
-}
=pod
use strict;
use warnings;
-use Test::More tests => 8;
+use Test::More tests => 7;
+
-BEGIN {
- use_ok('Moose');
-}
{
package TouchyBase;
use strict;
use warnings;
-use Test::More tests => 47;
+use Test::More tests => 42;
-BEGIN {
- use_ok('Moose');
-}
my @moose_exports = qw(
extends with
{
package Foo;
-}
-eval q{
- package Foo;
- use Moose;
-};
-ok(!$@, '... Moose succesfully exported into Foo');
+ eval 'use Moose';
+ die $@ if $@;
+}
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;
{
package Bar;
-}
-eval q{
- package Bar;
- use Moose::Util::TypeConstraints;
-};
-ok(!$@, '... Moose::Util::TypeConstraints succesfully exported into Bar');
+ eval 'use Moose::Util::TypeConstraints';
+ die $@ if $@;
+}
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;
use strict;
use warnings;
-use Test::More tests => 10;
+use Test::More tests => 9;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
use strict;
use warnings;
-use Test::More tests => 9;
+use Test::More tests => 7;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
- use_ok('Moose::Util::TypeConstraints');
-}
+use Moose::Util::TypeConstraints;
=pod
use strict;
use warnings;
-use Test::More tests => 13;
+use Test::More tests => 11;
use Test::Exception;
use Scalar::Util 'blessed';
-BEGIN {
- use_ok('Moose');
- use_ok("Moose::Util::TypeConstraints");
-}
+use Moose::Util::TypeConstraints;
subtype 'Positive'
=> as 'Num'
use strict;
use warnings;
-use Test::More tests => 10;
+use Test::More tests => 7;
use Test::Exception;
-BEGIN {
- use_ok('Moose::Meta::Class');
- use_ok('Moose');
- use_ok('Moose::Role');
-}
-
{
package Class;
use Moose;
use strict;
use warnings;
-use Test::More tests => 11;
+use Test::More tests => 8;
-BEGIN {
- use_ok('Moose::Meta::Class');
- use_ok('Moose');
- use_ok('Moose::Role');
-}
+use Moose::Meta::Class;
{
package Class;
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 14;
+
+{
+ package Foo;
+ use Moose;
+
+ has bar => ( is => "rw" );
+ has baz => ( is => "rw" );
+
+ sub BUILDARGS {
+ my ( $self, @args ) = @_;
+ unshift @args, "bar" if @args % 2 == 1;
+ return {@args};
+ }
+
+ package Bar;
+ use Moose;
+
+ extends qw(Foo);
+}
+
+foreach my $class qw(Foo Bar) {
+ is( $class->new->bar, undef, "no args" );
+ is( $class->new( bar => 42 )->bar, 42, "normal args" );
+ is( $class->new( 37 )->bar, 37, "single arg" );
+ {
+ my $o = $class->new(bar => 42, baz => 47);
+ is($o->bar, 42, '... got the right bar');
+ is($o->baz, 47, '... got the right bar');
+ }
+ {
+ my $o = $class->new(42, baz => 47);
+ is($o->bar, 42, '... got the right bar');
+ is($o->baz, 47, '... got the right bar');
+ }
+}
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+BEGIN {
+ eval "use Test::Output;";
+ plan skip_all => "Test::Output is required for this test" if $@;
+ plan tests => 2;
+}
+
+stderr_is( sub { package main; eval 'use Moose' },
+ "Moose does not export its sugar to the 'main' package.\n",
+ 'Moose warns when loaded from the main package' );
+
+stderr_is( sub { package main; eval 'use Moose::Role' },
+ "Moose::Role does not export its sugar to the 'main' package.\n",
+ 'Moose::Role warns when loaded from the main package' );
use strict;
use warnings;
-use Test::More tests => 14;
+use Test::More tests => 13;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package Foo;
use strict;
use warnings;
-use Test::More tests => 30;
+use Test::More tests => 29;
use Test::Exception;
use Scalar::Util 'isweak';
-BEGIN {
- use_ok('Moose');
-}
+
{
package Foo;
use strict;
use warnings;
-use Test::More tests => 58;
+use Test::More tests => 57;
use Test::Exception;
use Scalar::Util 'isweak';
-BEGIN {
- use_ok('Moose');
-}
+
{
package Foo;
use Scalar::Util 'isweak';
-use Test::More tests => 26;
+use Test::More tests => 25;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package Foo;
use strict;
use warnings;
-use Test::More tests => 10;
+use Test::More tests => 9;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package Foo::Role;
use strict;
use warnings;
-use Test::More tests => 16;
+use Test::More tests => 15;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package Foo;
use strict;
use warnings;
-use Test::More tests => 17;
+use Test::More tests => 16;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package Foo::Meta::Attribute;
use strict;
use warnings;
-use Test::More tests => 19;
+use Test::More tests => 18;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package Foo;
use strict;
use warnings;
-use Test::More tests => 83;
+use Test::More tests => 82;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package Thing;
use strict;
use warnings;
-use Test::More tests => 85;
+use Test::More tests => 84;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
# -------------------------------------------------------------------
# HASH handles
ok( !$p->can($_), "none of ChildD's methods ($_)" )
- for grep { /^child/ } map { $_->{name} } ChildD->meta->compute_all_applicable_methods();
+ for grep { /^child/ } map { $_->name } ChildD->meta->get_all_methods();
can_ok( $p, "child_c_method_3_la" );
can_ok( $p, "child_c_method_4_la" );
use strict;
use warnings;
-use Test::More tests => 44;
+use Test::More tests => 47;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
{
}
+{
+ package OutOfClassTest;
+
+ use Moose;
+}
+
+lives_ok { OutOfClassTest::has('foo'); } 'create attr via direct sub call';
+lives_ok { OutOfClassTest->can('has')->('bar'); } 'create attr via can';
+
+ok(OutOfClassTest->meta->get_attribute('foo'), 'attr created from sub call');
+ok(OutOfClassTest->meta->get_attribute('bar'), 'attr created from can');
use strict;
use warnings;
-use Test::More tests => 12;
+use Test::More tests => 11;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package Customer;
use strict;
use warnings;
-use Test::More tests => 3;
+use Test::More tests => 2;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package HTTPHeader;
use strict;
use warnings;
-use Test::More tests => 13;
+use Test::More tests => 12;
use Test::Exception;
use Test::Moose;
-BEGIN {
- use_ok('Moose');
-}
+
{
package My::Attribute::Trait;
use strict;
use warnings;
-use Test::More tests => 24;
+use Test::More tests => 23;
use Test::Exception;
use Test::Moose;
-BEGIN {
- use_ok('Moose');
-}
+
{
package My::Attribute::Trait;
use strict;
use warnings;
-use Test::More tests => 8;
+use Test::More tests => 7;
use Test::Exception;
use Test::Moose;
-BEGIN {
- use_ok('Moose');
-}
+
{
package My::Meta::Attribute::DefaultReadOnly;
use strict;
use warnings;
-use Test::More tests => 5;
+use Test::More tests => 4;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package Foo;
use strict;
use warnings;
-use Test::More tests => 24;
+use Test::More tests => 23;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package Foo;
use strict;
use warnings;
-use Test::More tests => 12;
+use Test::More tests => 11;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package Fake::DateTime;
use strict;
use warnings;
-use Test::More tests => 18;
+use Test::More tests => 17;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
=pod
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More tests => 2;
+
+
+
+{
+ package Bar::Meta::Attribute;
+ use Moose;
+
+ extends 'Moose::Meta::Attribute';
+
+ has 'my_legal_option' => (
+ isa => 'CodeRef',
+ is => 'rw',
+ );
+
+ around legal_options_for_inheritance => sub {
+ return (shift->(@_), qw/my_legal_option/);
+ };
+
+ package Bar;
+ use Moose;
+
+ has 'bar' => (
+ metaclass => 'Bar::Meta::Attribute',
+ my_legal_option => sub { 'Bar' }
+ );
+
+ package Bar::B;
+ use Moose;
+
+ extends 'Bar';
+
+ has '+bar' => (
+ my_legal_option => sub { 'Bar::B' }
+ );
+}
+
+my $bar_attr = Bar::B->meta->get_attribute('bar');
+my ($legal_option) = grep {
+ $_ eq 'my_legal_option'
+} $bar_attr->legal_options_for_inheritance;
+is($legal_option, 'my_legal_option',
+ '... added my_legal_option as legal option for inheritance' );
+is($bar_attr->my_legal_option->(), 'Bar::B', '... overloaded my_legal_option');
use strict;
use warnings;
-use Test::More tests => 29;
+use Test::More tests => 27;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
- use_ok('Moose::Meta::Role');
-}
+use Moose::Meta::Role;
{
package FooRole;
use strict;
use warnings;
-use Test::More tests => 37;
+use Test::More tests => 36;
use Test::Exception;
-BEGIN {
- use_ok('Moose::Role');
-}
-
=pod
NOTE:
use strict;
use warnings;
-use Test::More tests => 87;
+use Test::More tests => 86;
use Test::Exception;
-BEGIN {
- use_ok('Moose::Role');
-}
-
{
package FooRole;
use Moose::Role;
use strict;
use warnings;
-use Test::More tests => 11;
+use Test::More tests => 10;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package Foo::Role;
use strict;
use warnings;
-use Test::More tests => 89; # it's really 126 with kolibre's tests;
+use Test::More tests => 87; # it's really 124 with kolibre's tests;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
- use_ok('Moose::Role');
-}
-
=pod
Mutually recursive roles.
use strict;
use warnings;
-use Test::More tests => 24;
+use Test::More tests => 22;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
- use_ok('Moose::Role');
-}
-
=pod
The idea and examples for this feature are taken
use strict;
use warnings;
-use Test::More tests => 17;
+use Test::More tests => 15;
use Test::Exception;
=pod
not any real functionality.
- SL
-=cut
-
-BEGIN {
- use_ok('Moose');
- use_ok('Moose::Role');
-}
-
-=pod
-
Role which requires a method implemented
in another role as an override (it does
not remove the requirement)
use strict;
use warnings;
-use Test::More tests => 34;
+use Test::More tests => 32;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
- use_ok('Moose::Role');
-}
-
=pod
Check for repeated inheritence causing
use strict;
use warnings;
-use Test::More tests => 75;
+use Test::More tests => 74;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
# NOTE:
use strict;
use warnings;
-use Test::More tests => 28;
+use Test::More tests => 27;
use Scalar::Util qw(blessed);
-BEGIN {
- use_ok('Moose');
-}
+
=pod
use strict;
use warnings;
-use Test::More tests => 40;
+use Test::More tests => 39;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
# test no conflicts here
use strict;
use warnings;
-use Test::More tests => 20;
+use Test::More tests => 19;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package My::Role;
use strict;
use warnings;
-use Test::More tests => 36;
+use Test::More tests => 35;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package My::Role;
use strict;
use warnings;
-use Test::More tests => 10;
+use Test::More tests => 9;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package Foo;
use strict;
use warnings;
-use Test::More tests => 12;
+use Test::More tests => 11;
use Test::Exception;
use Scalar::Util 'blessed';
-BEGIN {
- use_ok('Moose');
-}
+
{
use strict;
use warnings;
-use Test::More tests => 8;
+use Test::More tests => 7;
use Test::Exception;
use Scalar::Util 'blessed';
-BEGIN {
- use_ok('Moose');
-}
+
{
use strict;
use warnings;
-use Test::More tests => 28;
+use Test::More tests => 27;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
=pod
use strict;
use warnings;
-use Test::More tests => 22;
+use Test::More tests => 21;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package Foo;
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 6;
+
+# this test script ensures that my idiom of:
+# role: sub BUILD, after BUILD
+# continues to work to run code after object initialization, whether the class
+# has a BUILD method or not
+
+my @CALLS;
+
+do {
+ package TestRole;
+ use Moose::Role;
+
+ sub BUILD { push @CALLS, 'TestRole::BUILD' }
+ before BUILD => sub { push @CALLS, 'TestRole::BUILD:before' };
+ after BUILD => sub { push @CALLS, 'TestRole::BUILD:after' };
+};
+
+do {
+ package ClassWithBUILD;
+ use Moose;
+ with 'TestRole';
+
+ sub BUILD { push @CALLS, 'ClassWithBUILD::BUILD' }
+};
+
+do {
+ package ClassWithoutBUILD;
+ use Moose;
+ with 'TestRole';
+};
+
+is_deeply([splice @CALLS], [], "no calls to BUILD yet");
+
+ClassWithBUILD->new;
+
+is_deeply([splice @CALLS], [
+ 'TestRole::BUILD:before',
+ 'ClassWithBUILD::BUILD',
+ 'TestRole::BUILD:after',
+]);
+
+ClassWithoutBUILD->new;
+
+is_deeply([splice @CALLS], [
+ 'TestRole::BUILD:before',
+ 'TestRole::BUILD',
+ 'TestRole::BUILD:after',
+]);
+
+ClassWithBUILD->meta->make_immutable;
+ClassWithoutBUILD->meta->make_immutable;
+
+is_deeply([splice @CALLS], [], "no calls to BUILD yet");
+
+ClassWithBUILD->new;
+
+is_deeply([splice @CALLS], [
+ 'TestRole::BUILD:before',
+ 'ClassWithBUILD::BUILD',
+ 'TestRole::BUILD:after',
+]);
+
+ClassWithoutBUILD->new;
+
+is_deeply([splice @CALLS], [
+ 'TestRole::BUILD:before',
+ 'TestRole::BUILD',
+ 'TestRole::BUILD:after',
+]);
+
use strict;
use warnings;
-use Test::More tests => 17;
+use Test::More tests => 14;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
- use_ok('Moose::Meta::Role::Application::RoleSummation');
- use_ok('Moose::Meta::Role::Composite');
-}
+use Moose::Meta::Role::Application::RoleSummation;
+use Moose::Meta::Role::Composite;
{
package Role::Foo;
use strict;
use warnings;
-use Test::More tests => 15;
+use Test::More tests => 12;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
- use_ok('Moose::Meta::Role::Application::RoleSummation');
- use_ok('Moose::Meta::Role::Composite');
-}
+use Moose::Meta::Role::Application::RoleSummation;
+use Moose::Meta::Role::Composite;
{
package Role::Foo;
use strict;
use warnings;
-use Test::More tests => 19;
+use Test::More tests => 16;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
- use_ok('Moose::Meta::Role::Application::RoleSummation');
- use_ok('Moose::Meta::Role::Composite');
-}
+use Moose::Meta::Role::Application::RoleSummation;
+use Moose::Meta::Role::Composite;
{
package Role::Foo;
use strict;
use warnings;
-use Test::More tests => 10;
+use Test::More tests => 7;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
- use_ok('Moose::Meta::Role::Application::RoleSummation');
- use_ok('Moose::Meta::Role::Composite');
-}
+use Moose::Meta::Role::Application::RoleSummation;
+use Moose::Meta::Role::Composite;
{
package Role::Foo;
use strict;
use warnings;
-use Test::More tests => 22;
+use Test::More tests => 19;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
- use_ok('Moose::Meta::Role::Application::RoleSummation');
- use_ok('Moose::Meta::Role::Composite');
-}
+use Moose::Meta::Role::Application::RoleSummation;
+use Moose::Meta::Role::Composite;
{
package Role::Foo;
use strict;
use warnings;
-use Test::More tests => 11;
+use Test::More tests => 8;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
- use_ok('Moose::Meta::Role::Application::RoleSummation');
- use_ok('Moose::Meta::Role::Composite');
-}
+use Moose::Meta::Role::Application::RoleSummation;
+use Moose::Meta::Role::Composite;
{
package Role::Foo;
use strict;
use warnings;
-use Test::More tests => 10;
+use Test::More tests => 7;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
- use_ok('Moose::Meta::Role::Application::RoleSummation');
- use_ok('Moose::Meta::Role::Composite');
-}
+use Moose::Meta::Role::Application::RoleSummation;
+use Moose::Meta::Role::Composite;
{
package Role::Foo;
use strict;
use warnings;
-use Test::More tests => 1;
+use Test::More skip_all => 'The feature this test exercises is not yet written';
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
-
-=pod
{
package Scalar;
sub eq { shift == shift }
}
-
-=cut
-
--- /dev/null
+#!/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'
+);
+
use strict;
use warnings;
-use Test::More tests => 38;
+use Test::More tests => 44;
use Test::Exception;
use Scalar::Util ();
lives_ok { Moose::Meta::Attribute->new('bob', isa => 'Spong') }
'meta-attr construction ok even when type constraint utils loaded first';
+
+# Test type constraint predicate return values.
+
+foreach my $predicate (qw/equals is_subtype_of is_a_type_of/) {
+ ok( !defined $string->$predicate('DoesNotExist'), "$predicate predicate returns undef for non existant constraint");
+}
+
+# Test adding things which don't look like types to the registry throws an exception
+
+my $r = Moose::Util::TypeConstraints->get_type_constraint_registry;
+throws_ok {$r->add_type_constraint()} qr/not a valid type constraint/, '->add_type_constraint(undef) throws';
+throws_ok {$r->add_type_constraint('foo')} qr/not a valid type constraint/, '->add_type_constraint("foo") throws';
+throws_ok {$r->add_type_constraint(bless {}, 'SomeClass')} qr/not a valid type constraint/, '->add_type_constraint(SomeClass->new) throws';
+
use strict;
use warnings;
-use Test::More tests => 14;
+use Test::More tests => 24;
use Test::Exception;
BEGIN {
ok(!Header([]), '... this did not pass the type test');
ok(!Header({}), '... this did not pass the type test');
-my $coercion = find_type_constraint('Header')->coercion;
-isa_ok($coercion, 'Moose::Meta::TypeCoercion');
+my $anon_type = subtype Object => where { $_->isa('HTTPHeader') };
-{
- my $coerced = $coercion->coerce([ 1, 2, 3 ]);
- isa_ok($coerced, 'HTTPHeader');
+lives_ok {
+ coerce $anon_type
+ => from ArrayRef
+ => via { HTTPHeader->new(array => $_[0]) }
+ => from HashRef
+ => via { HTTPHeader->new(hash => $_[0]) };
+} 'coercion of anonymous subtype succeeds';
- is_deeply(
- $coerced->array(),
- [ 1, 2, 3 ],
- '... got the right array');
- is($coerced->hash(), undef, '... nothing assigned to the hash');
-}
+foreach my $coercion (
+ find_type_constraint('Header')->coercion,
+ $anon_type->coercion
+ ) {
-{
- my $coerced = $coercion->coerce({ one => 1, two => 2, three => 3 });
- isa_ok($coerced, 'HTTPHeader');
+ my $coercion = find_type_constraint('Header')->coercion;
+ isa_ok($coercion, 'Moose::Meta::TypeCoercion');
- is_deeply(
- $coerced->hash(),
- { one => 1, two => 2, three => 3 },
- '... got the right hash');
- is($coerced->array(), undef, '... nothing assigned to the array');
-}
-
-{
- my $scalar_ref = \(my $var);
- my $coerced = $coercion->coerce($scalar_ref);
- is($coerced, $scalar_ref, '... got back what we put in');
-}
-
-{
- my $coerced = $coercion->coerce("Foo");
- is($coerced, "Foo", '... got back what we put in');
+ {
+ my $coerced = $coercion->coerce([ 1, 2, 3 ]);
+ isa_ok($coerced, 'HTTPHeader');
+
+ is_deeply(
+ $coerced->array(),
+ [ 1, 2, 3 ],
+ '... got the right array');
+ is($coerced->hash(), undef, '... nothing assigned to the hash');
+ }
+
+ {
+ my $coerced = $coercion->coerce({ one => 1, two => 2, three => 3 });
+ isa_ok($coerced, 'HTTPHeader');
+
+ is_deeply(
+ $coerced->hash(),
+ { one => 1, two => 2, three => 3 },
+ '... got the right hash');
+ is($coerced->array(), undef, '... nothing assigned to the array');
+ }
+
+ {
+ my $scalar_ref = \(my $var);
+ my $coerced = $coercion->coerce($scalar_ref);
+ is($coerced, $scalar_ref, '... got back what we put in');
+ }
+
+ {
+ my $coerced = $coercion->coerce("Foo");
+ is($coerced, "Foo", '... got back what we put in');
+ }
}
-
use lib 't/lib', 'lib';
-use Test::More tests => 5;
+use Test::More tests => 4;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
$SIG{__WARN__} = sub { 0 };
use strict;
use warnings;
-use Test::More tests => 26;
+use Test::More tests => 25;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package HTTPHeader;
BEGIN {
eval "use IO::String; use IO::File;";
plan skip_all => "IO::String and IO::File are required for this test" if $@;
- plan tests => 29;
+ plan tests => 28;
}
-BEGIN {
- use_ok('Moose');
-}
+
{
package Email::Moose;
use strict;
use warnings;
-use Test::More tests => 3;
+use Test::More tests => 8;
use Test::Exception;
BEGIN {
} '... 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';
use strict;
use warnings;
-use Test::More tests => 19;
+use Test::More tests => 17;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
- use_ok('Moose::Util::TypeConstraints');
-}
+use Moose::Util::TypeConstraints;
my $type = Moose::Util::TypeConstraints::find_or_parse_type_constraint('Maybe[Int]');
isa_ok($type, 'Moose::Meta::TypeConstraint');
use strict;
use warnings;
-use Test::More tests => 55;
+use Test::More tests => 54;
use Test::Exception;
-BEGIN
-{
- use_ok('Moose');
-}
+
{
package Foo;
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+
+{
+ package SomeClass;
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ subtype 'DigitSix' => as 'Num'
+ => where { /^6$/ };
+ subtype 'TextSix' => as 'Str'
+ => where { /Six/i };
+ coerce 'TextSix'
+ => from 'DigitSix'
+ => via { confess("Cannot live without 6 ($_)") unless /^6$/; 'Six' };
+
+ has foo => (
+ is => 'ro',
+ isa => 'TextSix',
+ coerce => 1,
+ default => 6,
+ lazy => 1
+ );
+}
+
+my $attr = SomeClass->meta->get_attribute('foo');
+is($attr->get_value(SomeClass->new()), 'Six');
+is(SomeClass->new()->foo, 'Six');
+
use strict;
use warnings;
-use Test::More tests => 4;
+use Test::More tests => 3;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package My::Custom::Meta::Attr;
use strict;
use warnings;
-use Test::More tests => 3;
+use Test::More tests => 2;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-};
+;
lives_ok {
package MooseX::Attribute::Test;
use strict;
use warnings;
-use Test::More tests => 5;
+use Test::More tests => 4;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
=pod
eval 'use Moose;';
::ok($@, '... could not load moose without correct metaclass');
::like($@,
- qr/^You already have a \&meta function\, but it does not return a Moose\:\:Meta\:\:Class/,
+ qr/^Bar already has a metaclass, but it does not inherit Moose::Meta::Class/,
'... got the right error too');
}
use strict;
use warnings;
-use Test::More tests => 17;
+use Test::More tests => 16;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
=pod
use strict;
use warnings;
-use Test::More tests => 8;
+use Test::More tests => 7;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
BEGIN {
package MyFramework::Base;
use strict;
use warnings;
-use Test::More tests => 5;
+use Test::More tests => 4;
+
+use Moose ();
-BEGIN {
- use_ok('Moose');
-}
{ package Foo; }
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+BEGIN {
+ unless ( eval 'use Test::Warn; 1' ) {
+ plan skip_all => 'These tests require Test::Warn';
+ }
+ else {
+ plan tests => 40;
+ }
+}
+
+
+{
+ package HasOwnImmutable;
+
+ use Moose;
+
+ no Moose;
+
+ ::warning_is( sub { eval q[sub make_immutable { return 'foo' }] },
+ '',
+ 'no warning when defining our own make_immutable sub' );
+}
+
+{
+ is( HasOwnImmutable->make_immutable(), 'foo',
+ 'HasOwnImmutable->make_immutable does not get overwritten' );
+}
+
+{
+ package MooseX::Empty;
+
+ use Moose ();
+ Moose::Exporter->setup_import_methods( also => 'Moose' );
+}
+
+{
+ package WantsMoose;
+
+ MooseX::Empty->import();
+
+ sub foo { 1 }
+
+ ::can_ok( 'WantsMoose', 'has' );
+ ::can_ok( 'WantsMoose', 'with' );
+ ::can_ok( 'WantsMoose', 'foo' );
+
+ MooseX::Empty->unimport();
+}
+
+{
+ # Note: it's important that these methods be out of scope _now_,
+ # after unimport was called. We tried a
+ # namespace::clean(0.08)-based solution, but had to abandon it
+ # because it cleans the namespace _later_ (when the file scope
+ # ends).
+ ok( ! WantsMoose->can('has'), 'WantsMoose::has() has been cleaned' );
+ ok( ! WantsMoose->can('with'), 'WantsMoose::with() has been cleaned' );
+ can_ok( 'WantsMoose', 'foo' );
+
+ # This makes sure that Moose->init_meta() happens properly
+ isa_ok( WantsMoose->meta(), 'Moose::Meta::Class' );
+ isa_ok( WantsMoose->new(), 'Moose::Object' );
+
+}
+
+{
+ package MooseX::Sugar;
+
+ use Moose ();
+
+ sub wrapped1 {
+ my $caller = shift;
+ return $caller . ' called wrapped1';
+ }
+
+ Moose::Exporter->setup_import_methods(
+ with_caller => ['wrapped1'],
+ also => 'Moose',
+ );
+}
+
+{
+ package WantsSugar;
+
+ MooseX::Sugar->import();
+
+ sub foo { 1 }
+
+ ::can_ok( 'WantsSugar', 'has' );
+ ::can_ok( 'WantsSugar', 'with' );
+ ::can_ok( 'WantsSugar', 'wrapped1' );
+ ::can_ok( 'WantsSugar', 'foo' );
+ ::is( wrapped1(), 'WantsSugar called wrapped1',
+ 'wrapped1 identifies the caller correctly' );
+
+ MooseX::Sugar->unimport();
+}
+
+{
+ ok( ! WantsSugar->can('has'), 'WantsSugar::has() has been cleaned' );
+ ok( ! WantsSugar->can('with'), 'WantsSugar::with() has been cleaned' );
+ ok( ! WantsSugar->can('wrapped1'), 'WantsSugar::wrapped1() has been cleaned' );
+ can_ok( 'WantsSugar', 'foo' );
+}
+
+{
+ package MooseX::MoreSugar;
+
+ use Moose ();
+
+ sub wrapped2 {
+ my $caller = shift;
+ return $caller . ' called wrapped2';
+ }
+
+ sub as_is1 {
+ return 'as_is1';
+ }
+
+ Moose::Exporter->setup_import_methods(
+ with_caller => ['wrapped2'],
+ as_is => ['as_is1'],
+ also => 'MooseX::Sugar',
+ );
+}
+
+{
+ package WantsMoreSugar;
+
+ MooseX::MoreSugar->import();
+
+ sub foo { 1 }
+
+ ::can_ok( 'WantsMoreSugar', 'has' );
+ ::can_ok( 'WantsMoreSugar', 'with' );
+ ::can_ok( 'WantsMoreSugar', 'wrapped1' );
+ ::can_ok( 'WantsMoreSugar', 'wrapped2' );
+ ::can_ok( 'WantsMoreSugar', 'as_is1' );
+ ::can_ok( 'WantsMoreSugar', 'foo' );
+ ::is( wrapped1(), 'WantsMoreSugar called wrapped1',
+ 'wrapped1 identifies the caller correctly' );
+ ::is( wrapped2(), 'WantsMoreSugar called wrapped2',
+ 'wrapped2 identifies the caller correctly' );
+ ::is( as_is1(), 'as_is1',
+ 'as_is1 works as expected' );
+
+ MooseX::MoreSugar->unimport();
+}
+
+{
+ ok( ! WantsMoreSugar->can('has'), 'WantsMoreSugar::has() has been cleaned' );
+ ok( ! WantsMoreSugar->can('with'), 'WantsMoreSugar::with() has been cleaned' );
+ ok( ! WantsMoreSugar->can('wrapped1'), 'WantsMoreSugar::wrapped1() has been cleaned' );
+ ok( ! WantsMoreSugar->can('wrapped2'), 'WantsMoreSugar::wrapped2() has been cleaned' );
+ ok( ! WantsMoreSugar->can('as_is1'), 'WantsMoreSugar::as_is1() has been cleaned' );
+ can_ok( 'WantsMoreSugar', 'foo' );
+}
+
+{
+ package My::Metaclass;
+ use Moose;
+ BEGIN { extends 'Moose::Meta::Class' }
+
+ package My::Object;
+ use Moose;
+ BEGIN { extends 'Moose::Object' }
+
+ package HasInitMeta;
+
+ use Moose ();
+
+ sub init_meta {
+ shift;
+ return Moose->init_meta( @_,
+ metaclass => 'My::Metaclass',
+ base_class => 'My::Object',
+ );
+ }
+
+ Moose::Exporter->setup_import_methods( also => 'Moose' );
+}
+
+{
+ package NewMeta;
+
+ HasInitMeta->import();
+}
+
+{
+ isa_ok( NewMeta->meta(), 'My::Metaclass' );
+ isa_ok( NewMeta->new(), 'My::Object' );
+}
+
+{
+ package MooseX::CircularAlso;
+
+ use Moose ();
+
+ ::dies_ok(
+ sub {
+ Moose::Exporter->setup_import_methods(
+ also => [ 'Moose', 'MooseX::CircularAlso' ],
+ );
+ },
+ 'a circular reference in also dies with an error'
+ );
+
+ ::like(
+ $@,
+ qr/\QCircular reference in also parameter to MooseX::Exporter between MooseX::CircularAlso and MooseX::CircularAlso/,
+ 'got the expected error from circular reference in also'
+ );
+}
+
+{
+ package MooseX::CircularAlso;
+
+ use Moose ();
+
+ ::dies_ok(
+ sub {
+ Moose::Exporter->setup_import_methods(
+ also => [ 'NoSuchThing' ],
+ );
+ },
+ 'a package which does not use Moose::Exporter in also dies with an error'
+ );
+
+ ::like(
+ $@,
+ qr/\QPackage in also (NoSuchThing) does not seem to use MooseX::Exporter/,
+ 'got the expected error from a reference in also to a package which does not use Moose::Exporter'
+ );
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 28;
+use Test::Exception;
+
+{
+ package My::SimpleTrait;
+
+ use Moose::Role;
+
+ sub simple { return 5 }
+}
+
+{
+ package Foo;
+
+ use Moose -traits => [ 'My::SimpleTrait' ];
+}
+
+can_ok( Foo->meta(), 'simple' );
+is( Foo->meta()->simple(), 5,
+ 'Foo->meta()->simple() returns expected value' );
+
+{
+ package Bar;
+
+ use Moose -traits => 'My::SimpleTrait';
+}
+
+can_ok( Bar->meta(), 'simple' );
+is( Bar->meta()->simple(), 5,
+ 'Foo->meta()->simple() returns expected value' );
+
+{
+ package My::SimpleTrait2;
+
+ use Moose::Role;
+
+ # This needs to happen at compile time so it happens before we
+ # apply traits to Bar
+ BEGIN {
+ has 'attr' =>
+ ( is => 'ro',
+ default => 'something',
+ );
+ }
+
+ sub simple { return 5 }
+}
+
+{
+ package Bar;
+
+ use Moose -traits => [ 'My::SimpleTrait2' ];
+}
+
+can_ok( Bar->meta(), 'simple' );
+is( Bar->meta()->simple(), 5,
+ 'Bar->meta()->simple() returns expected value' );
+can_ok( Bar->meta(), 'attr' );
+is( Bar->meta()->attr(), 'something',
+ 'Bar->meta()->attr() returns expected value' );
+
+{
+ package My::SimpleTrait3;
+
+ use Moose::Role;
+
+ BEGIN {
+ has 'attr2' =>
+ ( is => 'ro',
+ default => 'something',
+ );
+ }
+
+ sub simple2 { return 55 }
+}
+
+{
+ package Baz;
+
+ use Moose -traits => [ 'My::SimpleTrait2', 'My::SimpleTrait3' ];
+}
+
+can_ok( Baz->meta(), 'simple' );
+is( Baz->meta()->simple(), 5,
+ 'Baz->meta()->simple() returns expected value' );
+can_ok( Baz->meta(), 'attr' );
+is( Baz->meta()->attr(), 'something',
+ 'Baz->meta()->attr() returns expected value' );
+can_ok( Baz->meta(), 'simple2' );
+is( Baz->meta()->simple2(), 55,
+ 'Baz->meta()->simple2() returns expected value' );
+can_ok( Baz->meta(), 'attr2' );
+is( Baz->meta()->attr2(), 'something',
+ 'Baz->meta()->attr2() returns expected value' );
+
+{
+ package My::Trait::AlwaysRO;
+
+ use Moose::Role;
+
+ around '_process_new_attribute', '_process_inherited_attribute' =>
+ sub {
+ my $orig = shift;
+ my ( $self, $name, %args ) = @_;
+
+ $args{is} = 'ro';
+
+ return $self->$orig( $name, %args );
+ };
+}
+
+{
+ package Quux;
+
+ use Moose -traits => [ 'My::Trait::AlwaysRO' ];
+
+ has 'size' =>
+ ( is => 'rw',
+ isa => 'Int',
+ );
+}
+
+ok( Quux->meta()->has_attribute('size'),
+ 'Quux has size attribute' );
+ok( ! Quux->meta()->get_attribute('size')->writer(),
+ 'size attribute does not have a writer' );
+
+{
+ package My::Class::Whatever;
+
+ use Moose::Role;
+
+ sub whatever { 42 }
+
+ package Moose::Meta::Class::Custom::Trait::Whatever;
+
+ sub register_implementation {
+ return 'My::Class::Whatever';
+ }
+}
+
+{
+ package RanOutOfNames;
+
+ use Moose -traits => [ 'Whatever' ];
+}
+
+ok( RanOutOfNames->meta()->meta()->has_method('whatever'),
+ 'RanOutOfNames->meta() has whatever method' );
+
+{
+ package Role::Foo;
+
+ use Moose::Role -traits => [ 'My::SimpleTrait' ];
+}
+
+can_ok( Role::Foo->meta(), 'simple' );
+is( Role::Foo->meta()->simple(), 5,
+ 'Role::Foo->meta()->simple() returns expected value' );
+
+{
+ require Moose::Util::TypeConstraints;
+ dies_ok( sub { Moose::Util::TypeConstraints->import( -traits => 'My::SimpleTrait' ) },
+ 'cannot provide -traits to an exporting module that does not init_meta' );
+ like( $@, qr/does not have an init_meta/,
+ '... and error provides a useful explanation' );
+}
+
+SKIP:
+{
+ skip 'This will blow up until Moose::Meta::Class->_fix_metaclass_incompatibility understands roles', 5;
+{
+ 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' );
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 8;
+use Test::Exception;
+
+# Some packages out in the wild cooperate with Moose by using goto
+# &Moose::import. we want to make sure it still works.
+
+{
+ package MooseAlike1;
+
+ use strict;
+ use warnings;
+
+ use Moose ();
+
+ sub import {
+ goto &Moose::import;
+ }
+
+ sub unimport {
+ goto &Moose::unimport;
+ }
+}
+
+{
+ package Foo;
+
+ MooseAlike1->import();
+
+ ::lives_ok( sub { has( 'size' ) },
+ 'has was exported via MooseAlike1' );
+
+ MooseAlike1->unimport();
+}
+
+ok( ! Foo->can('has'),
+ 'No has sub in Foo after MooseAlike1 is unimported' );
+ok( Foo->can('meta'),
+ 'Foo has a meta method' );
+isa_ok( Foo->meta(), 'Moose::Meta::Class' );
+
+
+{
+ package MooseAlike2;
+
+ use strict;
+ use warnings;
+
+ use Moose ();
+
+ my $import = \&Moose::import;
+ sub import {
+ goto $import;
+ }
+
+ my $unimport = \&Moose::unimport;
+ sub unimport {
+ goto $unimport;
+ }
+}
+
+{
+ package Bar;
+
+ MooseAlike2->import();
+
+ ::lives_ok( sub { has( 'size' ) },
+ 'has was exported via MooseAlike2' );
+
+ MooseAlike2->unimport();
+}
+
+
+ok( ! Bar->can('has'),
+ 'No has sub in Bar after MooseAlike2 is unimported' );
+ok( Bar->can('meta'),
+ 'Bar has a meta method' );
+isa_ok( Bar->meta(), 'Moose::Meta::Class' );
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 59;
+
+use Moose::Util::MetaRole;
+
+
+{
+ package My::Meta::Class;
+ use Moose;
+ extends 'Moose::Meta::Class';
+}
+
+{
+ package My::Meta::Attribute;
+ use Moose;
+ extends 'Moose::Meta::Attribute';
+}
+
+{
+ package My::Meta::Method;
+ use Moose;
+ extends 'Moose::Meta::Method';
+}
+
+{
+ package My::Meta::Instance;
+ use Moose;
+ extends 'Moose::Meta::Instance';
+}
+
+{
+ package My::Meta::MethodConstructor;
+ use Moose;
+ extends 'Moose::Meta::Method::Constructor';
+}
+
+{
+ package My::Meta::MethodDestructor;
+ use Moose;
+ extends 'Moose::Meta::Method::Destructor';
+}
+
+{
+ 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::Class55->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} );
+}
+
+SKIP:
+{
+ skip
+ 'These tests will fail until Moose::Meta::Class->_fix_metaclass_incompatibility is much smarter.',
+ 2;
+
+{
+ 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 it extends My::Class} );
+}
+}
+
+# This is the hack needed to work around the
+# _fix_metaclass_incompatibility problem. You must call extends()
+# (which in turn calls _fix_metaclass_imcompatibility) _before_ you
+# apply more extensions in the subclass.
+{
+ 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 it extends My::Class} );
+}
--- /dev/null
+#!/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 );
+}
use strict;
use warnings;
-use Test::More tests => 7;
+use Test::More tests => 6;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
=pod
use strict;
use warnings;
-use Test::More tests => 7;
+use Test::More tests => 6;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package Elk;
{ package Object::Test; }
-use_ok('Moose');
+package Foo;
+::use_ok('Moose');
use lib 't/lib', 'lib';
-use Test::More tests => 3;
+use Test::More tests => 2;
+
-BEGIN {
- use_ok('Moose');
-}
use_ok('MyMooseA');
use_ok('MyMooseB');
\ No newline at end of file
use strict;
use warnings;
-use Test::More tests => 3;
+use Test::More tests => 2;
+
-BEGIN {
- use_ok('Moose');
-}
=pod
use strict;
use warnings;
-use Test::More tests => 2;
+use Test::More tests => 1;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
=pod
use strict;
use warnings;
-use Moose;
use Test::More tests => 3;
use strict;
use warnings;
-use Moose;
use Test::More tests => 1;
use Test::Exception;
use strict;
use warnings;
-use Test::More tests => 4;
+use Test::More tests => 3;
+
-BEGIN {
- use_ok('Moose');
-}
{
package Foo;
use strict;
use warnings;
-use Test::More tests => 3;
+use Test::More tests => 2;
+
-BEGIN {
- use_ok('Moose');
-}
{
package Foo;
use warnings;
use FindBin;
-use Test::More tests => 146;
+use Test::More tests => 144;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
- use_ok('Moose::Util::TypeConstraints');
-}
+use Moose::Util::TypeConstraints;
subtype 'FilePath'
=> as 'Str'
use strict;
use warnings;
-use Test::More tests => 5;
+use Test::More tests => 4;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package Foo;
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 1;
+use Test::Exception;
+
+
+
+{
+ package My::Role;
+ use Moose::Role;
+}
+{
+ package My::Class;
+ use Moose;
+
+ ::throws_ok {
+ extends 'My::Role';
+ } qr/You cannot inherit from a Moose Role \(My\:\:Role\)/,
+ '... this croaks correctly';
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+use Test::Exception;
+
+
+
+# RT #37569
+
+{
+ package MyObject;
+ use Moose;
+
+ package Foo;
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ subtype 'MyArrayRef'
+ => as 'ArrayRef'
+ => where { defined $_->[0] }
+ => message { ref $_ ? "ref: ". ref $_ : 'scalar' } # stringy
+ ;
+
+ subtype 'MyObjectType'
+ => as 'Object'
+ => where { $_->isa('MyObject') }
+ => message {
+ if ( $_->isa('SomeObject') ) {
+ return 'More detailed error message';
+ }
+ elsif ( blessed $_ ) {
+ return 'Well it is an object';
+ }
+ else {
+ return 'Doh!';
+ }
+ }
+ ;
+
+ type 'NewType'
+ => where { $_->isa('MyObject') }
+ => message { blessed $_ ? 'blessed' : 'scalar' }
+ ;
+
+ has 'obj' => ( is => 'rw', isa => 'MyObjectType' );
+ has 'ar' => ( is => 'rw', isa => 'MyArrayRef' );
+ has 'nt' => ( is => 'rw', isa => 'NewType' );
+}
+
+my $foo = Foo->new;
+my $obj = MyObject->new;
+
+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->nt($foo); # scalar
+} qr/Attribute \(nt\) does not pass the type constraint because: blessed/, '... got the right error message';
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 36;
+use Test::Exception;
+
+
+
+BEGIN {
+ package MyRole;
+ use Moose::Role;
+
+ requires 'foo';
+
+ package MyMetaclass;
+ use Moose qw(extends with);
+ extends 'Moose::Meta::Class';
+ with 'MyRole';
+
+ sub foo { 'i am foo' }
+}
+
+{
+ package MyClass;
+ use metaclass ('MyMetaclass');
+ use Moose;
+}
+
+my $mc = MyMetaclass->initialize('MyClass');
+isa_ok($mc, 'MyMetaclass');
+
+ok($mc->meta->does_role('MyRole'), '... the metaclass does the role');
+
+is(MyClass->meta, $mc, '... these metas are the same thing');
+is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing');
+
+my $a = MyClass->new;
+ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( $a->meta->foo, 'i am foo', '... foo method returns expected value' );
+ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' );
+
+lives_ok {
+ MyClass->meta->make_immutable;
+} '... make MyClass immutable okay';
+
+is(MyClass->meta, $mc, '... these metas are still the same thing');
+is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing');
+
+ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( $a->meta->foo, 'i am foo', '... foo method returns expected value' );
+ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' );
+
+lives_ok {
+ MyClass->meta->make_mutable;
+} '... make MyClass mutable okay';
+
+is(MyClass->meta, $mc, '... these metas are still the same thing');
+is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing');
+
+ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( $a->meta->foo, 'i am foo', '... foo method returns expected value' );
+ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' );
+
+lives_ok {
+ MyMetaclass->meta->make_immutable;
+} '... make MyClass immutable okay';
+
+is(MyClass->meta, $mc, '... these metas are still the same thing');
+is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing');
+
+ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( $a->meta->foo, 'i am foo', '... foo method returns expected value' );
+ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' );
+
+lives_ok {
+ MyClass->meta->make_immutable;
+} '... make MyClass immutable okay';
+
+is(MyClass->meta, $mc, '... these metas are still the same thing');
+is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing');
+
+ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( $a->meta->foo, 'i am foo', '... foo method returns expected value' );
+ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' );
+
use strict;
use warnings;
-use Test::More tests => 21;
+use Test::More tests => 20;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
## Roles
plan skip_all => "DBM::Deep 1.0003 (or greater) is required for this test" if $@;
eval "use DateTime::Format::MySQL;";
plan skip_all => "DateTime::Format::MySQL is required for this test" if $@;
- plan tests => 89;
+ plan tests => 88;
}
use Test::Exception;
unlink('newswriter.db') if -e 'newswriter.db';
}
-BEGIN {
- use_ok('Moose');
-}
+
=pod
extends 'Moose::Meta::Class';
override 'construct_instance' => sub {
- my ($class, %params) = @_;
- return $class->get_meta_instance->find_instance($params{oid})
- if $params{oid};
+ my $class = shift;
+ my $params = @_ == 1 ? $_[0] : {@_};
+ return $class->get_meta_instance->find_instance($params->{oid})
+ if $params->{oid};
super();
};
use strict;
use warnings;
-use Test::More tests => 32;
+use Test::More tests => 30;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
- use_ok('Moose::Role');
-}
-
sub U {
my $f = shift;
sub { $f->($f, @_) };
BEGIN {
eval "use Declare::Constraints::Simple;";
plan skip_all => "Declare::Constraints::Simple is required for this test" if $@;
- plan tests => 11;
+ plan tests => 9;
}
use Test::Exception;
-BEGIN {
- use_ok('Moose');
- use_ok('Moose::Util::TypeConstraints');
-}
-
{
package Foo;
use Moose;
BEGIN {
eval "use Test::Deep;";
plan skip_all => "Test::Deep is required for this test" if $@;
- plan tests => 7;
+ plan tests => 5;
}
use Test::Exception;
-BEGIN {
- use_ok('Moose');
- use_ok('Moose::Util::TypeConstraints');
-}
-
{
package Foo;
use Moose;
use strict;
use warnings;
-use Test::More tests => 9;
+use Test::More tests => 8;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package Record;
use strict;
use warnings;
-use Test::More tests => 17;
+use Test::More tests => 15;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
- use_ok('Moose::Meta::Role');
-}
+use Moose::Meta::Role;
+
{
- package FooRole;
- our $VERSION = '0.01';
- sub foo { 'FooRole::foo' }
+ package FooRole;
+ our $VERSION = '0.01';
+ sub foo {'FooRole::foo'}
}
{
- package Foo;
- use Moose;
-
- #two checks because the inlined methods are different when
- #there is a TC present.
- has 'foos' => (is => 'ro', lazy_build => 1);
- has 'bars' => (isa => 'Str', is => 'ro', lazy_build => 1);
- has 'bazes' => (isa => 'Str', is => 'ro', builder => '_build_bazes');
- sub _build_foos { "many foos" }
- sub _build_bars { "many bars" }
- sub _build_bazes { "many bazes" }
+ package Foo;
+ use Moose;
+
+ #two checks because the inlined methods are different when
+ #there is a TC present.
+ has 'foos' => ( is => 'ro', lazy_build => 1 );
+ has 'bars' => ( isa => 'Str', is => 'ro', lazy_build => 1 );
+ has 'bazes' => ( isa => 'Str', is => 'ro', builder => '_build_bazes' );
+ sub _build_foos {"many foos"}
+ sub _build_bars {"many bars"}
+ sub _build_bazes {"many bazes"}
}
{
- my $foo_role = Moose::Meta::Role->initialize('FooRole');
- my $meta = Foo->meta;
-
- lives_ok{ Foo->new } "lazy_build works";
- is(Foo->new->foos, 'many foos' , "correct value for 'foos' before inlining constructor");
- is(Foo->new->bars, 'many bars' , "correct value for 'bars' before inlining constructor");
- is(Foo->new->bazes, 'many bazes' , "correct value for 'bazes' before inlining constructor");
- lives_ok{ $meta->make_immutable } "Foo is imutable";
- lives_ok{ $meta->identifier } "->identifier on metaclass lives";
- dies_ok{ $meta->add_role($foo_role) } "Add Role is locked";
- lives_ok{ Foo->new } "Inlined constructor works with lazy_build";
- is(Foo->new->foos, 'many foos' , "correct value for 'foos' after inlining constructor");
- is(Foo->new->bars, 'many bars' , "correct value for 'bars' after inlining constructor");
- is(Foo->new->bazes, 'many bazes' , "correct value for 'bazes' after inlining constructor");
- lives_ok{ $meta->make_mutable } "Foo is mutable";
- lives_ok{ $meta->add_role($foo_role) } "Add Role is unlocked";
-
+ my $foo_role = Moose::Meta::Role->initialize('FooRole');
+ my $meta = Foo->meta;
+
+ lives_ok { Foo->new } "lazy_build works";
+ is( Foo->new->foos, 'many foos',
+ "correct value for 'foos' before inlining constructor" );
+ is( Foo->new->bars, 'many bars',
+ "correct value for 'bars' before inlining constructor" );
+ is( Foo->new->bazes, 'many bazes',
+ "correct value for 'bazes' before inlining constructor" );
+ lives_ok { $meta->make_immutable } "Foo is imutable";
+ lives_ok { $meta->identifier } "->identifier on metaclass lives";
+ dies_ok { $meta->add_role($foo_role) } "Add Role is locked";
+ lives_ok { Foo->new } "Inlined constructor works with lazy_build";
+ is( Foo->new->foos, 'many foos',
+ "correct value for 'foos' after inlining constructor" );
+ is( Foo->new->bars, 'many bars',
+ "correct value for 'bars' after inlining constructor" );
+ is( Foo->new->bazes, 'many bazes',
+ "correct value for 'bazes' after inlining constructor" );
+ lives_ok { $meta->make_mutable } "Foo is mutable";
+ lives_ok { $meta->add_role($foo_role) } "Add Role is unlocked";
}
use strict;
use warnings;
-use Test::More tests => 5;
+use Test::More tests => 4;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package My::Role;
use strict;
use warnings;
-use Test::More tests => 2;
+use Test::More tests => 1;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package My::Meta;
use strict;
use warnings;
-use Test::More tests => 4;
+use Test::More tests => 10;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
-
=pod
This tests to make sure that the inlined constructor
{
package Foo;
use Moose;
+ use Moose::Util::TypeConstraints;
+
+ coerce 'Int' => from 'Str' => via { length $_ ? $_ : 69 };
has 'foo' => (is => 'rw', isa => 'Int');
has 'baz' => (is => 'rw', isa => 'Int');
has 'zot' => (is => 'rw', isa => 'Int', init_arg => undef);
-
+ has 'moo' => (is => 'rw', isa => 'Int', coerce => 1, default => '', required => 1);
+ has 'boo' => (is => 'rw', isa => 'Int', coerce => 1, builder => '_build_boo', required => 1);
+
+ sub _build_boo { '' }
+
Foo->meta->add_attribute(
Class::MOP::Attribute->new(
'bar' => (
)
)
);
-
- Foo->meta->make_immutable(debug => 0);
}
-lives_ok {
- Foo->new(foo => 10, bar => "Hello World", baz => 10, zot => 4);
-} '... this passes the constuctor correctly';
+for (1..2) {
+ my $is_immutable = Foo->meta->is_immutable;
+ 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)");
+ } "... this passes the constuctor correctly ($mutable_string)";
-lives_ok {
- Foo->new(foo => 10, bar => "Hello World", baz => 10, zot => "not an int");
-} "... the constructor doesn't care about 'zot'";
+ lives_ok {
+ Foo->new(foo => 10, bar => "Hello World", baz => 10, zot => "not an int");
+ } "... the constructor doesn't care about 'zot' ($mutable_string)";
-dies_ok {
- Foo->new(foo => "Hello World", bar => 100, baz => "Hello World");
-} '... this fails the constuctor correctly';
+ dies_ok {
+ Foo->new(foo => "Hello World", bar => 100, baz => "Hello World");
+ } "... this fails the constuctor correctly ($mutable_string)";
+ Foo->meta->make_immutable(debug => 0) unless $is_immutable;
+}
use strict;
use warnings;
-use Test::More tests => 3;
+use Test::More tests => 2;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package Foo;
use strict;
use warnings;
-use Test::More tests => 10;
+use Test::More tests => 8;
use Test::Exception;
use Scalar::Util 'blessed';
-BEGIN {
- use_ok('Moose');
- use_ok('Moose::Meta::Role');
-}
-
=pod
This test it kind of odd, it tests
use strict;
use warnings;
-use Test::More tests => 4;
+use Test::More tests => 3;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
{
package AClass;
use strict;
use warnings;
-use Test::More tests => 3;
+use Test::More tests => 2;
use Test::Exception;
-BEGIN {
- use_ok('Moose');
-}
+
=pod
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 14;
+
+{
+ package Foo;
+ use Moose;
+
+ has bar => ( is => "rw" );
+ has baz => ( is => "rw" );
+
+ sub BUILDARGS {
+ my ( $self, @args ) = @_;
+ unshift @args, "bar" if @args % 2 == 1;
+ return {@args};
+ }
+
+ __PACKAGE__->meta->make_immutable;
+
+ package Bar;
+ use Moose;
+
+ extends qw(Foo);
+
+ __PACKAGE__->meta->make_immutable;
+}
+
+foreach my $class qw(Foo Bar) {
+ is( $class->new->bar, undef, "no args" );
+ is( $class->new( bar => 42 )->bar, 42, "normal args" );
+ is( $class->new( 37 )->bar, 37, "single arg" );
+ {
+ my $o = $class->new(bar => 42, baz => 47);
+ is($o->bar, 42, '... got the right bar');
+ is($o->baz, 47, '... got the right bar');
+ }
+ {
+ my $o = $class->new(42, baz => 47);
+ is($o->bar, 42, '... got the right bar');
+ is($o->baz, 47, '... got the right bar');
+ }
+}
+
+
--- /dev/null
+#!/usr/bin/perl
+
+# In the case where a child type constraint's parent constraint fails,
+# the exception should reference the parent type constraint that actually
+# failed instead of always referencing the child'd type constraint
+
+use strict;
+use warnings;
+
+use Test::More tests => 4;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Moose::Util::TypeConstraints');
+}
+
+lives_ok {
+ subtype 'ParentConstraint' => as 'Str' => where {0};
+} 'specified parent type constraint';
+
+my $tc;
+lives_ok {
+ $tc = subtype 'ChildConstraint' => as 'ParentConstraint' => where {1};
+} 'specified child type constraint';
+
+{
+ my $errmsg = $tc->validate();
+
+ TODO: {
+ local $TODO = 'Not yet supported';
+ ok($errmsg !~ /Validation failed for 'ChildConstraint'/, 'exception references failing parent constraint');
+ };
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+use Test::Exception;
+
+sub req_or_has ($$) {
+ my ( $role, $method ) = @_;
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ if ( $role ) {
+ ok(
+ $role->has_method($method) || $role->requires_method($method),
+ $role->name . " has or requires method $method"
+ );
+ } else {
+ fail("role has or requires method $method");
+ }
+}
+
+{
+ package Bar;
+ use Moose::Role;
+
+ # this role eventually adds three methods, qw(foo bar xxy), but only one is
+ # known when it's still a role
+
+ has foo => ( is => "rw" );
+
+ has gorch => ( reader => "bar" );
+
+ sub xxy { "BAAAD" }
+
+ package Gorch;
+ use Moose::Role;
+
+ # similarly this role gives attr and gorch_method
+
+ has attr => ( is => "rw" );
+
+ sub gorch_method { "gorch method" }
+
+ around dandy => sub { shift->(@_) . "bar" };
+
+ package Quxx;
+ use Moose;
+
+ sub dandy { "foo" }
+
+ # this object will be used in an attr of Foo to test that Foo can do the
+ # Gorch interface
+
+ with qw(Gorch);
+
+ package Dancer;
+ use Moose::Role;
+
+ requires "twist";
+
+ package Dancer::Ballerina;
+ use Moose;
+
+ with qw(Dancer);
+
+ sub twist { }
+
+ sub pirouette { }
+
+ package Dancer::Robot;
+ use Moose::Role;
+
+ # this doesn't fail but it produces a requires in the role
+ # the order doesn't matter
+ has twist => ( is => "rw" );
+ ::lives_ok { with qw(Dancer) };
+
+ package Dancer::Something;
+ use Moose;
+
+ # this fail even though the method already exists
+
+ has twist => ( is => "rw" );
+
+ {
+ local our $TODO = "accessors don't satisfy role requires";
+ ::lives_ok { with qw(Dancer) };
+ }
+
+ package Dancer::80s;
+ use Moose;
+
+ # this should pass because ::Robot has the attribute to fill in the requires
+ # but due to the deferrence logic that doesn't actually work
+ {
+ local our $TODO = "attribute accessor in role doesn't satisfy role requires";
+ ::lives_ok { with qw(Dancer::Robot) };
+ }
+
+ package Foo;
+ use Moose;
+
+ with qw(Bar);
+
+ has oink => (
+ is => "rw",
+ handles => "Gorch", # should handles take the same arguments as 'with'? Meta::Role::Application::Delegation?
+ default => sub { Quxx->new },
+ );
+
+ has dancer => (
+ is => "rw",
+ does => "Dancer",
+ handles => "Dancer",
+ default => sub { Dancer::Ballerina->new },
+ );
+
+ sub foo { 42 }
+
+ sub bar { 33 }
+
+ sub xxy { 7 }
+
+ package Tree;
+ use Moose::Role;
+
+ has bark => ( is => "rw" );
+
+ package Dog;
+ use Moose::Role;
+
+ sub bark { warn "woof!" };
+
+ package EntPuppy;
+ use Moose;
+
+ {
+ local our $TODO = "attrs and methods from a role should clash";
+ ::dies_ok { with qw(Tree Dog) }
+ }
+}
+
+# these fail because of the deferral logic winning over actual methods
+# this might be tricky to fix due to the 'sub foo {}; has foo => ( )' hack
+# we've been doing for a long while, though I doubt people relied on it for
+# anything other than fulfilling 'requires'
+{
+ local $TODO = "attributes from role overwrite class methods";
+ is( Foo->new->foo, 42, "attr did not zap overriding method" );
+ is( Foo->new->bar, 33, "attr did not zap overriding method" );
+}
+is( Foo->new->xxy, 7, "method did not zap overriding method" ); # duh
+
+# these pass, simple delegate
+# mostly they are here to contrast the next blck
+can_ok( Foo->new->oink, "dandy" );
+can_ok( Foo->new->oink, "attr" );
+can_ok( Foo->new->oink, "gorch_method" );
+
+ok( Foo->new->oink->does("Gorch"), "Quxx does Gorch" );
+
+
+# these are broken because 'attr' is not technically part of the interface
+can_ok( Foo->new, "gorch_method" );
+{
+ local $TODO = "accessor methods from a role are omitted in handles role";
+ can_ok( Foo->new, "attr" );
+}
+
+{
+ local $TODO = "handles role doesn't add the role to the ->does of the delegate's parent class";
+ ok( Foo->new->does("Gorch"), "Foo does Gorch" );
+}
+
+
+# these work
+can_ok( Foo->new->dancer, "pirouette" );
+can_ok( Foo->new->dancer, "twist" );
+
+can_ok( Foo->new, "twist" );
+ok( !Foo->new->can("pirouette"), "can't pirouette, not part of the iface" );
+
+{
+ local $TODO = "handles role doesn't add the role to the ->does of the delegate's parent class";
+ ok( Foo->new->does("Dancer") );
+}
+
+
+
+
+my $gorch = Gorch->meta;
+
+isa_ok( $gorch, "Moose::Meta::Role" );
+
+ok( $gorch->has_attribute("attr"), "has attribute 'attr'" );
+
+{
+ local $TODO = "role attribute isn't a meta attribute yet";
+ isa_ok( $gorch->get_attribute("attr"), "Moose::Meta::Attribute" );
+}
+
+req_or_has($gorch, "gorch_method");
+ok( $gorch->has_method("gorch_method"), "has_method gorch_method" );
+ok( !$gorch->requires_method("gorch_method"), "requires gorch method" );
+
+{
+ 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" );
+
+ # this specific test is maybe not backwards compat, but in theory it *does*
+ # require that method to exist
+ ok( $gorch->requires_method("dandy"), "requires the dandy method for the modifier" );
+}
+
+{
+ local $TODO = "attribute related methods are not yet known by the role";
+ # we want this to be a part of the interface, somehow
+ req_or_has($gorch, "attr");
+ ok( $gorch->has_method("attr"), "has_method attr" );
+ isa_ok( $gorch->get_method("attr"), "Moose::Meta::Method" );
+ isa_ok( $gorch->get_method("attr"), "Moose::Meta::Method::Accessor" );
+}
+
+my $robot = Dancer::Robot->meta;
+
+isa_ok( $robot, "Moose::Meta::Role" );
+
+ok( $robot->has_attribute("twist"), "has attr 'twist'" );
+
+{
+ local $TODO = "role attribute isn't a meta attribute yet";
+ isa_ok( $robot->get_attribute("twist"), "Moose::Meta::Attribute" );
+}
+
+{
+ req_or_has($robot, "twist");
+
+ local $TODO = "attribute related methods are not yet known by the role";
+ ok( $robot->has_method("twist"), "has twist method" );
+ isa_ok( $robot->get_method("twist"), "Moose::Meta::Method" );
+ isa_ok( $robot->get_method("twist"), "Moose::Meta::Method::Accessor" );
+}
+
+__END__
+
+I think Attribute needs to be refactored in some way to better support roles.
+
+There are several possible ways to do this, all of them seem plausible to me.
+
+The first approach would be to change the attribute class to allow it to be
+queried about the methods it would install.
+
+Then we instantiate the attribute in the role, and instead of deferring the
+arguments, we just make an C<unpack>ish method.
+
+Then we can interrogate the attr when adding it to the role, and generate stub
+methods for all the methods it would produce.
+
+A second approach is kinda like the Immutable hack: wrap the attr in an
+anonmyous class that disables part of its interface.
+
+A third method would be to create an Attribute::Partial object that would
+provide a more role-ish behavior, and to do this independently of the actual
+Attribute class.
+
+Something similar can be done for method modifiers, but I think that's even simpler.
+
+
+
+The benefits of doing this are:
+
+* Much better introspection of roles
+
+* More correctness in many cases (in my opinion anyway)
+
+* More roles are more usable as interface declarations, without having to split
+ them into two pieces (one for the interface with a bunch of requires(), and
+ another for the actual impl with the problematic attrs (and stub methods to
+ fix the accessors) and method modifiers (dunno if this can even work at all)
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+
+# if make_immutable is removed from the following code the tests pass
+
+{
+ package Foo;
+ use Moose;
+
+ has foo => ( is => "ro" );
+
+ package Bar;
+ use Moose;
+
+ extends qw(Foo);
+
+ around new => sub {
+ my $next = shift;
+ my ( $self, @args ) = @_;
+ $self->$next( foo => 42 );
+ };
+
+ package Gorch;
+ use Moose;
+
+ extends qw(Bar);
+
+ package Zoink;
+ use Moose;
+
+ extends qw(Gorch);
+
+}
+
+my @classes = qw(Foo Bar Gorch Zoink);
+
+tests: {
+ TODO: {
+ is( Foo->new->foo, undef, "base class (" . (Foo->meta->is_immutable ? "immutable" : "mutable") . ")" );
+ is( Bar->new->foo, 42, "around new called on Bar->new (" . (Bar->meta->is_immutable ? "immutable" : "mutable") . ")" );
+ local $TODO = 'these tests fail once Gorch is immutable' if Gorch->meta->is_immutable;
+ is( Gorch->new->foo, 42, "around new called on Gorch->new (" . (Gorch->meta->is_immutable ? "immutable" : "mutable") . ")" );
+ is( Zoink->new->foo, 42, "around new called Zoink->new (" . (Zoink->meta->is_immutable ? "immutable" : "mutable") . ")" );
+ }
+
+ if ( @classes ) {
+ ( shift @classes )->meta->make_immutable;
+ redo tests;
+ }
+}
--- /dev/null
+#!/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');
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+use Test::Exception;
+
+
+
+=pod
+
+See this for some details:
+
+http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=476579
+
+Here is the basic test case, it segfaults, so I am going
+to leave it commented out. Basically it seems that there
+is some bad interaction between the ??{} construct that
+is used in the "parser" for type definitions and threading
+so probably the fix would involve removing the ??{} usage
+for something else.
+
+use threads;
+
+{
+ package Foo;
+ use Moose;
+ has "bar" => (is => 'rw', isa => "Str | Num");
+}
+
+my $thr = threads->create(sub {});
+$thr->join();
+
+=cut
+
+{
+ local $TODO = 'This is just a stub for the test, see the POD';
+ fail('Moose type constraints and threads dont get along');
+}
+
+
+
+
--- /dev/null
+package Role::Child;
+use Moose::Role;
+
+with 'Role::Parent' => { alias => { meth1 => 'aliased_meth1', } };
+
+sub meth1 { }
+
+1;
--- /dev/null
+package Role::Interface;
+use Moose::Role;
+
+requires "meth2";
+
+1;
--- /dev/null
+package Role::Parent;
+use Moose::Role;
+
+sub meth2 { }
+sub meth1 { }
+
+1;
eval "use Test::Pod::Coverage 1.04";
plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@;
-all_pod_coverage_ok( { trustme => [ qr/intialize_body/ ] } );
+# This is a stripped down version of all_pod_coverage_ok which lets us
+# vary the trustme parameter per module.
+my @modules = all_modules();
+plan tests => scalar @modules;
+
+my %trustme = (
+ 'Moose' => ['make_immutable'],
+ 'Moose::Meta::Method::Constructor' =>
+ [qw( initialize_body intialize_body)],
+ 'Moose::Meta::Method::Destructor' => ['initialize_body'],
+ 'Moose::Role' => [
+ qw( after around augment before extends has inner make_immutable override super with )
+ ],
+);
+
+for my $module ( sort @modules ) {
+ my $trustme = [];
+ if ( $trustme{$module} ) {
+ my $methods = join '|', @{ $trustme{$module} };
+ $trustme = [qr/$methods/];
+ }
+
+ pod_coverage_ok(
+ $module, { trustme => $trustme },
+ "Pod coverage for $module"
+ );
+}
projects / gitmo/Moose.git / commitdiff